    {-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}
    {-# LANGUAGE ViewPatterns, TypeFamilies #-}

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

    import Control.Monad
    import Control.Monad.IO.Class
    import Data.Maybe
    import Data.List.Extra
    import Control.Applicative
    import Data.Typeable.Extra
    import General.Binary
    import Prelude

    import Development.Shake.Internal.Errors
    import Development.Shake.Internal.Core.Action hiding (trackAllow)
    import Development.Shake.Internal.Core.Run
    import Development.Shake.Internal.Core.Types
    import Development.Shake.Internal.Core.Rules
    import General.Extra
    import Development.Shake.Internal.FileName
    import Development.Shake.Classes
    import Development.Shake.Internal.Rules.Rerun
    import Development.Shake.Internal.Rules.File
    import Development.Shake.Internal.FilePattern
    import Development.Shake.FilePath
    import Development.Shake.Internal.Options

    infix 1 &?>, &%>

    type instance RuleResult FilesQ = FilesA

    newtype FilesQ = FilesQ {fromFilesQ :: [FileQ]}
        deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)

    newtype FilesA = FilesA [FileA]
        deriving (Typeable,BinaryEx,NFData)

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

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

    filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA)
    filesStoredValue opts (FilesQ xs) = fmap FilesA . sequence <$> mapM (fileStoredValue opts) xs

    filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost
    filesEqualValue opts (FilesA xs) (FilesA ys)
        | length xs /= length ys = NotEqual
        | otherwise = foldr and_ EqualCheap $ zipWith (fileEqualValue opts) xs ys
            where and_ NotEqual x = NotEqual
                  and_ EqualCheap x = x
                  and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive

    defaultRuleFiles :: Rules ()
    defaultRuleFiles = do
        opts <- getShakeOptionsRules
        -- A rule from FilesQ to FilesA. The result value is only useful for linting.
        addBuiltinRuleEx (ruleLint opts) (ruleRun opts $ shakeRebuildApply opts)

    ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA
    ruleLint opts k (FilesA []) = return Nothing -- in the case of disabling lint
    ruleLint opts k v = do
        now <- filesStoredValue opts k
        return $ case now of
            Nothing -> Just "<missing>"
            Just now | filesEqualValue opts v now == EqualCheap -> Nothing
                     | otherwise -> Just $ show now

    ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
    ruleRun opts rebuildFlags k o@(fmap getEx -> old) dirtyChildren = do
        let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k
        case old of
            _ | RebuildNow `elem` r -> rebuild
            _ | RebuildLater `elem` r -> case old of
                Just old ->
                    -- ignoring the currently stored value, which may trigger lint has changed
                    -- so disable lint on this file
                    return $ RunResult ChangedNothing (fromJust o) $ FilesA []
                Nothing -> do
                    -- i don't have a previous value, so assume this is a source node, and mark rebuild in future
                    now <- liftIO $ filesStoredValue opts k
                    case now of
                        Nothing -> rebuild
                        Just now -> do alwaysRerun; return $ RunResult ChangedStore (runBuilder $ putEx now) now
            Just old | not dirtyChildren -> do
                v <- liftIO $ filesStoredValue opts k
                case v of
                    Just v -> case filesEqualValue opts old v of
                        NotEqual -> rebuild
                        EqualCheap -> return $ RunResult ChangedNothing (fromJust o) v
                        EqualExpensive -> return $ RunResult ChangedStore (runBuilder $ putEx v) v
                    Nothing -> rebuild
            _ -> rebuild
        where
            rebuild = do
                putWhen Chatty $ "# " ++ show k
                rules :: UserRule (FilesQ -> Maybe (Action FilesA)) <- getUserRules
                v <- case userRuleMatch rules ($ k) of
                    [r] -> r
                    rs  -> liftIO $ errorMultipleRulesMatch (typeOf k) (show k) (length rs)
                let c | Just old <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame
                        | otherwise = ChangedRecomputeDiff
                return $ RunResult c (runBuilder $ putEx v) v

    -- | 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 ()
    [p] &%> act = p %> act . return
    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_ (zip [0..] ps) $ \(i,p) ->
                (if simple p then id else priority 0.5) $
                    fileForward $ let op = (p ?==) in \file -> if not $ op file then Nothing else Just $ do
                        FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString . substitute (extract p file)) ps
                        return $ if null res then Nothing else Just $ res !! i
            (if all simple ps then id else priority 0.5) $
                addUserRule $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in
                    if not $ length xs == length ps && and (zipWith (?==) ps xs) then Nothing else Just $ do
                        liftIO $ mapM_ createDirectoryRecursive $ 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 inputOutput suf inp out =
                ["Input" ++ suf ++ ":", "  " ++ inp] ++
                ["Output" ++ suf ++ ":"] ++ map ("  "++) out
        let normTest = fmap (map $ toStandard . normaliseEx) . 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 equalValue for all arguments (after normalisation)."] ++
                    inputOutput "1" x ys ++
                    inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)
                Just ys -> Just ys

        fileForward $ \x -> case checkedTest x of
            Nothing -> Nothing
            Just ys -> Just $ do
                FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString) ys
                return $ if null res then Nothing else Just $ res !! fromJust (elemIndex x ys)

        addUserRule $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in
            case checkedTest x of
                Just ys | ys == xs -> Just $ do
                    liftIO $ mapM_ createDirectoryRecursive $ 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 (fileStoredValue 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 produce " ++ show missing ++
                        " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++
                        concat ["\n  " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zip xs ys]