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

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

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

import Development.Shake.Internal.Core.Action
import Development.Shake.Internal.Core.Types hiding (Result)
import Development.Shake.Internal.Core.Build
import Development.Shake.Internal.Core.Rules
import Development.Shake.Internal.Errors
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.FileInfo
import Development.Shake.Internal.Options
import Data.Monoid
import Prelude


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

data FilesRule = FilesRule String (FilesQ -> Maybe (Action FilesA))
    deriving Typeable

data Result = Result Ver FilesA

instance BinaryEx Result where
    putEx (Result v x) = putExStorable v <> putEx x
    getEx s = let (a,b) = binarySplit s in Result a $ getEx b


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 $ zipWithExact (fileEqualValue opts) xs ys
        where and_ NotEqual _ = 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) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts)

ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA
ruleLint _ _ (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

ruleIdentity :: ShakeOptions -> BuiltinIdentity FilesQ FilesA
ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure $ errorStructured
    "Cannot use shakeChange=ChangeModTime with shakeShare" [] ""
ruleIdentity _ = \_ (FilesA files) ->
    Just $ runBuilder $ putExList [putExStorable size <> putExStorable hash | FileA _ size hash <- files]



ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
ruleRun opts rebuildFlags k o@(fmap getEx -> old :: Maybe Result) mode = do
    let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k

    (ruleVer, ruleAct, ruleErr) <- getUserRuleInternal k (\(FilesRule s _) -> Just s) $ \(FilesRule _ f) -> f k
    let verEq v = Just v == ruleVer || map (Ver . fst) ruleAct == [v]
    let rebuild = do
            putWhen Chatty $ "# " ++ show k
            case ruleAct of
                [x] -> rebuildWith x
                _ -> throwM ruleErr

    case old of
        _ | RebuildNow `elem` r -> rebuild
        _ | RebuildLater `elem` r -> case old of
            Just _ ->
                -- 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 $ Result (Ver 0) now) now
        Just (Result ver old) | mode == RunDependenciesSame, verEq ver -> 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 $ Result ver v) v
                Nothing -> rebuild
        _ -> rebuild
    where
        rebuildWith (ver, act) = do
            cache <- historyLoad ver
            v <- case cache of
                Just res ->
                    fmap FilesA $ forM (zipExact (getExList res) (fromFilesQ k)) $ \(bin, file) -> do
                        Just (FileA mod size _) <- liftIO $ fileStoredValue opts file
                        return $ FileA mod size $ getExStorable bin
                Nothing -> do
                    FilesA v <- act
                    producesUnchecked $ map (fileNameToString . fromFileQ) $ fromFilesQ k
                    historySave ver $ runBuilder $ putExList
                        [if isNoFileHash hash then throwImpure errorNoHash else putExStorable hash | FileA _ _ hash <- v]
                    return $ FilesA v
            let c | Just (Result _ old) <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame
                  | otherwise = ChangedRecomputeDiff
            return $ RunResult c (runBuilder $ putEx $ Result (Ver ver) 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.
(&%>) :: Located => [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
[p] &%> act = withFrozenCallStack $ 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 = withFrozenCallStack $ do
        forM_ (zipFrom 0 ps) $ \(i,p) ->
            (if simple p then id else priority 0.5) $
                fileForward (show ps ++ " &%> at " ++ callStackTop) $ 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) $ do
            mapM_ addTarget ps
            addUserRule $ FilesRule (show ps ++ " &%> " ++ callStackTop) $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in
                if not $ length xs == length ps && and (zipWithExact (?==) 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
--
--   Intuitively, the function defines a set partitioning, mapping each element to the partition that contains it.
--   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]@.
(&?>) :: Located => (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 ("&?> at " ++ callStackTop) $ \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 $ FilesRule ("&?> " ++ callStackTop) $ \(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) <- zipExact xs ys]