1{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}
2{-# LANGUAGE ViewPatterns, TypeFamilies, ConstraintKinds #-}
3
4module Development.Shake.Internal.Rules.Files(
5    (&?>), (&%>), defaultRuleFiles
6    ) where
7
8import Control.Monad
9import Control.Monad.IO.Class
10import Data.Maybe
11import Data.List.Extra
12import Data.Typeable
13import General.Binary
14
15import Development.Shake.Internal.Core.Action
16import Development.Shake.Internal.Core.Types hiding (Result)
17import Development.Shake.Internal.Core.Build
18import Development.Shake.Internal.Core.Rules
19import Development.Shake.Internal.Errors
20import General.Extra
21import Development.Shake.Internal.FileName
22import Development.Shake.Classes
23import Development.Shake.Internal.Rules.Rerun
24import Development.Shake.Internal.Rules.File
25import Development.Shake.Internal.FilePattern
26import Development.Shake.FilePath
27import Development.Shake.Internal.FileInfo
28import Development.Shake.Internal.Options
29import Data.Monoid
30import Prelude
31
32
33infix 1 &?>, &%>
34
35
36type instance RuleResult FilesQ = FilesA
37
38newtype FilesQ = FilesQ {fromFilesQ :: [FileQ]}
39    deriving (Typeable,Eq,Hashable,Binary,BinaryEx,NFData)
40
41newtype FilesA = FilesA [FileA]
42    deriving (Typeable,BinaryEx,NFData)
43
44instance Show FilesA where show (FilesA xs) = unwords $ "Files" : map (drop 5 . show) xs
45
46instance Show FilesQ where show (FilesQ xs) = unwords $ map (wrapQuote . show) xs
47
48data FilesRule = FilesRule String (FilesQ -> Maybe (Action FilesA))
49    deriving Typeable
50
51data Result = Result Ver FilesA
52
53instance BinaryEx Result where
54    putEx (Result v x) = putExStorable v <> putEx x
55    getEx s = let (a,b) = binarySplit s in Result a $ getEx b
56
57
58filesStoredValue :: ShakeOptions -> FilesQ -> IO (Maybe FilesA)
59filesStoredValue opts (FilesQ xs) = fmap FilesA . sequence <$> mapM (fileStoredValue opts) xs
60
61filesEqualValue :: ShakeOptions -> FilesA -> FilesA -> EqualCost
62filesEqualValue opts (FilesA xs) (FilesA ys)
63    | length xs /= length ys = NotEqual
64    | otherwise = foldr and_ EqualCheap $ zipWithExact (fileEqualValue opts) xs ys
65        where and_ NotEqual _ = NotEqual
66              and_ EqualCheap x = x
67              and_ EqualExpensive x = if x == NotEqual then NotEqual else EqualExpensive
68
69defaultRuleFiles :: Rules ()
70defaultRuleFiles = do
71    opts <- getShakeOptionsRules
72    -- A rule from FilesQ to FilesA. The result value is only useful for linting.
73    addBuiltinRuleEx (ruleLint opts) (ruleIdentity opts) (ruleRun opts $ shakeRebuildApply opts)
74
75ruleLint :: ShakeOptions -> BuiltinLint FilesQ FilesA
76ruleLint _ _ (FilesA []) = pure Nothing -- in the case of disabling lint
77ruleLint opts k v = do
78    now <- filesStoredValue opts k
79    pure $ case now of
80        Nothing -> Just "<missing>"
81        Just now | filesEqualValue opts v now == EqualCheap -> Nothing
82                 | otherwise -> Just $ show now
83
84ruleIdentity :: ShakeOptions -> BuiltinIdentity FilesQ FilesA
85ruleIdentity opts | shakeChange opts == ChangeModtime = throwImpure $ errorStructured
86    "Cannot use shakeChange=ChangeModTime with shakeShare" [] ""
87ruleIdentity _ = \_ (FilesA files) ->
88    Just $ runBuilder $ putExList [putExStorable size <> putExStorable hash | FileA _ size hash <- files]
89
90
91
92ruleRun :: ShakeOptions -> (FilePath -> Rebuild) -> BuiltinRun FilesQ FilesA
93ruleRun opts rebuildFlags k o@(fmap getEx -> old :: Maybe Result) mode = do
94    let r = map (rebuildFlags . fileNameToString . fromFileQ) $ fromFilesQ k
95
96    (ruleVer, ruleAct, ruleErr) <- getUserRuleInternal k (\(FilesRule s _) -> Just s) $ \(FilesRule _ f) -> f k
97    let verEq v = Just v == ruleVer || map (Ver . fst) ruleAct == [v]
98    let rebuild = do
99            putWhen Verbose $ "# " ++ show k
100            case ruleAct of
101                [x] -> rebuildWith x
102                _ -> throwM ruleErr
103
104    case old of
105        _ | RebuildNow `elem` r -> rebuild
106        _ | RebuildLater `elem` r -> case old of
107            Just _ ->
108                -- ignoring the currently stored value, which may trigger lint has changed
109                -- so disable lint on this file
110                pure $ RunResult ChangedNothing (fromJust o) $ FilesA []
111            Nothing -> do
112                -- i don't have a previous value, so assume this is a source node, and mark rebuild in future
113                now <- liftIO $ filesStoredValue opts k
114                case now of
115                    Nothing -> rebuild
116                    Just now -> do alwaysRerun; pure $ RunResult ChangedStore (runBuilder $ putEx $ Result (Ver 0) now) now
117        Just (Result ver old) | mode == RunDependenciesSame, verEq ver -> do
118            v <- liftIO $ filesStoredValue opts k
119            case v of
120                Just v -> case filesEqualValue opts old v of
121                    NotEqual -> rebuild
122                    -- See #810, important we pass old (which can be cheaply evaluated)
123                    -- and not v, which might have some lazily-evaluated file hashes in
124                    EqualCheap -> pure $ RunResult ChangedNothing (fromJust o) old
125                    EqualExpensive -> pure $ RunResult ChangedStore (runBuilder $ putEx $ Result ver v) v
126                Nothing -> rebuild
127        _ -> rebuild
128    where
129        rebuildWith (ver, act) = do
130            cache <- historyLoad ver
131            v <- case cache of
132                Just res ->
133                    fmap FilesA $ forM (zipExact (getExList res) (fromFilesQ k)) $ \(bin, file) -> do
134                        Just (FileA mod size _) <- liftIO $ fileStoredValue opts file
135                        pure $ FileA mod size $ getExStorable bin
136                Nothing -> do
137                    FilesA v <- act
138                    producesUnchecked $ map (fileNameToString . fromFileQ) $ fromFilesQ k
139                    historySave ver $ runBuilder $ putExList
140                        [if isNoFileHash hash then throwImpure errorNoHash else putExStorable hash | FileA _ _ hash <- v]
141                    pure $ FilesA v
142            let c | Just (Result _ old) <- old, filesEqualValue opts old v /= NotEqual = ChangedRecomputeSame
143                  | otherwise = ChangedRecomputeDiff
144            pure $ RunResult c (runBuilder $ putEx $ Result (Ver ver) v) v
145
146
147
148-- | Define a rule for building multiple files at the same time.
149--   Think of it as the AND (@&&@) equivalent of '%>'.
150--   As an example, a single invocation of GHC produces both @.hi@ and @.o@ files:
151--
152-- @
153-- [\"*.o\",\"*.hi\"] '&%>' \\[o,hi] -> do
154--     let hs = o 'Development.Shake.FilePath.-<.>' \"hs\"
155--     'Development.Shake.need' ... -- all files the .hs import
156--     'Development.Shake.cmd' \"ghc -c\" [hs]
157-- @
158--
159--   However, in practice, it's usually easier to define rules with '%>' and make the @.hi@ depend
160--   on the @.o@. When defining rules that build multiple files, all the 'FilePattern' values must
161--   have the same sequence of @\/\/@ and @*@ wildcards in the same order.
162--   This function will create directories for the result files, if necessary.
163(&%>) :: Located => [FilePattern] -> ([FilePath] -> Action ()) -> Rules ()
164[p] &%> act = withFrozenCallStack $ p %> act . pure
165ps &%> act
166    | not $ compatible ps = error $ unlines $
167        "All patterns to &%> must have the same number and position of ** and * wildcards" :
168        ["* " ++ p ++ (if compatible [p, head ps] then "" else " (incompatible)") | p <- ps]
169    | otherwise = withFrozenCallStack $ do
170        forM_ (zipFrom 0 ps) $ \(i,p) ->
171            (if simple p then id else priority 0.5) $
172                fileForward (show ps ++ " &%> at " ++ callStackTop) $ let op = (p ?==) in \file -> if not $ op file then Nothing else Just $ do
173                    FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString . substitute (extract p file)) ps
174                    pure $ if null res then Nothing else Just $ res !! i
175        (if all simple ps then id else priority 0.5) $ do
176            mapM_ addTarget ps
177            addUserRule $ FilesRule (show ps ++ " &%> " ++ callStackTop) $ \(FilesQ xs_) -> let xs = map (fileNameToString . fromFileQ) xs_ in
178                if not $ length xs == length ps && and (zipWithExact (?==) ps xs) then Nothing else Just $ do
179                    liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs
180                    trackAllow xs
181                    act xs
182                    getFileTimes "&%>" xs_
183
184
185-- | Define a rule for building multiple files at the same time, a more powerful
186--   and more dangerous version of '&%>'. Think of it as the AND (@&&@) equivalent of '?>'.
187--
188--   Given an application @test &?> ...@, @test@ should return @Just@ if the rule applies, and should
189--   return the list of files that will be produced. This list /must/ include the file passed as an argument and should
190--   obey the invariant:
191--
192-- > forAll $ \x ys -> test x == Just ys ==> x `elem` ys && all ((== Just ys) . test) ys
193--
194--   Intuitively, the function defines a set partitioning, mapping each element to the partition that contains it.
195--   As an example of a function satisfying the invariaint:
196--
197-- @
198-- test x | 'Development.Shake.FilePath.takeExtension' x \`elem\` [\".hi\",\".o\"]
199--        = Just ['Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"hi\", 'Development.Shake.FilePath.dropExtension' x 'Development.Shake.FilePath.<.>' \"o\"]
200-- test _ = Nothing
201-- @
202--
203--   Regardless of whether @Foo.hi@ or @Foo.o@ is passed, the function always returns @[Foo.hi, Foo.o]@.
204(&?>) :: Located => (FilePath -> Maybe [FilePath]) -> ([FilePath] -> Action ()) -> Rules ()
205(&?>) test act = priority 0.5 $ do
206    let inputOutput suf inp out =
207            ["Input" ++ suf ++ ":", "  " ++ inp] ++
208            ["Output" ++ suf ++ ":"] ++ map ("  "++) out
209    let normTest = fmap (map $ toStandard . normaliseEx) . test
210    let checkedTest x = case normTest x of
211            Nothing -> Nothing
212            Just ys | x `notElem` ys -> error $ unlines $
213                "Invariant broken in &?>, did not pure the input (after normalisation)." :
214                inputOutput "" x ys
215            Just ys | bad:_ <- filter ((/= Just ys) . normTest) ys -> error $ unlines $
216                ["Invariant broken in &?>, not equalValue for all arguments (after normalisation)."] ++
217                inputOutput "1" x ys ++
218                inputOutput "2" bad (fromMaybe ["Nothing"] $ normTest bad)
219            Just ys -> Just ys
220
221    fileForward ("&?> at " ++ callStackTop) $ \x -> case checkedTest x of
222        Nothing -> Nothing
223        Just ys -> Just $ do
224            FilesA res <- apply1 $ FilesQ $ map (FileQ . fileNameFromString) ys
225            pure $ if null res then Nothing else Just $ res !! fromJust (elemIndex x ys)
226
227    addUserRule $ FilesRule ("&?> " ++ callStackTop) $ \(FilesQ xs_) -> let xs@(x:_) = map (fileNameToString . fromFileQ) xs_ in
228        case checkedTest x of
229            Just ys | ys == xs -> Just $ do
230                liftIO $ mapM_ createDirectoryRecursive $ nubOrd $ map takeDirectory xs
231                act xs
232                getFileTimes "&?>" xs_
233            Just ys -> error $ "Error, &?> is incompatible with " ++ show xs ++ " vs " ++ show ys
234            Nothing -> Nothing
235
236
237getFileTimes :: String -> [FileQ] -> Action FilesA
238getFileTimes name xs = do
239    opts <- getShakeOptions
240    let opts2 = if shakeChange opts == ChangeModtimeAndDigestInput then opts{shakeChange=ChangeModtime} else opts
241    ys <- liftIO $ mapM (fileStoredValue opts2) xs
242    case sequence ys of
243        Just ys -> pure $ FilesA ys
244        Nothing | not $ shakeCreationCheck opts -> pure $ FilesA []
245        Nothing -> do
246            let missing = length $ filter isNothing ys
247            error $ "Error, " ++ name ++ " rule failed to produce " ++ show missing ++
248                    " file" ++ (if missing == 1 then "" else "s") ++ " (out of " ++ show (length xs) ++ ")" ++
249                    concat ["\n  " ++ fileNameToString x ++ if isNothing y then " - MISSING" else "" | (FileQ x,y) <- zipExact xs ys]
250