    {-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}

    module Development.Shake.Rules.Files(
        (&?>), (&%>)
        ) where

    import Control.Monad
    import Control.Monad.IO.Class
    import Data.Maybe
    import Data.List.Extra
    import System.Directory
    import Control.Applicative
    import Prelude

    import Development.Shake.Core hiding (trackAllow)
    import General.Extra
    import General.String
    import Development.Shake.Classes
    import Development.Shake.Rules.File
    import Development.Shake.FilePattern
    import Development.Shake.FilePath
    import Development.Shake.Types
    import Development.Shake.ByteString

    infix 1 &?>, &%>

    newtype FilesQ = FilesQ [FileQ]
        deriving (Typeable,Eq,Hashable,Binary,NFData)

    newtype FilesA = FilesA [FileA]
        deriving (Typeable,Eq,Hashable,Binary,NFData)

    instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs

    instance Show FilesQ where show (FilesQ xs) = unwords $ map (showQuote . show) xs

    instance Rule FilesQ FilesA where
        storedValue opts (FilesQ xs) = (fmap FilesA . sequence) <$> mapM (storedValue opts) xs
        equalValue opts (FilesQ qs) (FilesA xs) (FilesA ys)
            | let n = length qs in n /= length xs || n /= length ys = NotEqual
            | otherwise = foldr and_ EqualCheap (zipWith3 (equalValue opts) qs xs ys)
                where and_ NotEqual x = NotEqual
                      and_ EqualCheap x = x
                      and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive

    -- | Define a rule for building multiple files at the same time.
    --   Think of it as the AND (@&&@) equivalent of '%>'.
    --   As an example, a single invocation of GHC produces both @.hi@ and @.o@ files:
    --
    -- @
    -- [\"*.o\",\"*.hi\"] '&%>' \\[o,hi] -> do
    --     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"
    --     'Development.Shake.need' ... -- all files the .hs import
    --     'Development.Shake.cmd' \"ghc -c\" [hs]
    -- @
    --
    --   However, in practice, it's usually easier to define rules with '%>' and make the @.hi@ depend
    --   on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must
    --   have the same sequence of @\/\/@ and @*@ wildcards in the same order.
    --   This function will create directories for the result files, if necessary.
    (&%>) :: [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
    ps &%> act
        | not $ compatible ps = error $ unlines $
            "All patterns to &%> must have the same number and position of // and * wildcards" :
            ["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps]
        | otherwise = do
            forM_ ps $ \p ->
                p %> \file -> do
                    _ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU . substitute (extract p file)) ps
                    return ()
            (if all simple ps then id else priority 0.5) $
                rule $ \(FilesQ xs_) -> let xs = map (unpackU . fromFileQ) xs_ in
                    if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do
                        liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs
                        trackAllow xs
                        act xs
                        getFileTimes "&%>" xs_

    -- | Define a rule for building multiple files at the same time, a more powerful
    --   and more dangerous version of '&%>'. Think of it as the AND (@&&@) equivalent of '?>'.
    --
    --   Given an application @test &?> ...@, @test@ should return @Just@ if the rule applies, and should
    --   return the list of files that will be produced. This list /must/ include the file passed as an argument and should
    --   obey the invariant:
    --
    -- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys
    --
    --   As an example of a function satisfying the invariaint:
    --
    -- @
    -- test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]
    --        = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]
    -- test _ = Nothing
    -- @
    --
    --   Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.
    (&?>) :: (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()
    (&?>) test act = priority 0.5 $ do
        let norm = toStandard . normaliseEx
        let inputOutput suf inp out =
                ["Input" ++ suf ++ ":", "  " ++ inp] ++
                ["Output" ++ suf ++ ":"] ++ map ("  "++) out
        let normTest = fmap (map norm) . test
        let checkedTest x = case normTest x of
                Nothing -> Nothing
                Just ys | x `notElem` ys -> error $ unlines $
                    "Invariant broken in &?>, did not return the input (after normalisation)." :
                    inputOutput "" x ys
                Just ys | bad:_ <- filter ((/= Just ys) . normTest) ys -> error $ unlines $
                    ["Invariant broken in &?>, not equal for all arguments (after normalisation)."] ++
                    inputOutput "1" x ys ++
                    inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)
                Just ys -> Just ys

        isJust . checkedTest ?> \x -> do
            -- FIXME: Could optimise this test by calling rule directly and returning FileA Eq Eq Eq
            --        But only saves noticable time on uncommon Change modes
            _ :: FilesA <- apply1 $ FilesQ $ map (FileQ . packU_ . filepathNormalise . unpackU_ . packU) $ fromJust $ test x
            return ()

        rule $ \(FilesQ xs_) -> let xs@(x:_) = map (unpackU . fromFileQ) xs_ in
            case checkedTest x of
                Just ys | ys == xs -> Just $ do
                    liftIO $ mapM_ (createDirectoryIfMissing True) $ nubOrd $ map takeDirectory xs
                    act xs
                    getFileTimes "&?>" xs_
                Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys
                Nothing -> Nothing

    getFileTimes :: String -> [FileQ] -> Action FilesA
    getFileTimes name xs = do
        opts <- getShakeOptions
        let opts2 = if shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts
        ys <- liftIO $ mapM (storedValue opts2) xs
        case sequence ys of
            Just ys -> return $ FilesA ys
            Nothing | not $ shakeCreationCheck opts -> return $ FilesA []
            Nothing -> do
                let missing = length $ filter isNothing ys
                error $ "Error, " ++ name ++ " rule failed to build " ++ show missing ++
                        " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++
                        concat ["\n  " ++ unpackU x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]