{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, ScopedTypeVariables #-}{-# LANGUAGE ViewPatterns, TypeFamilies, ConstraintKinds #-}moduleDevelopment.Shake.Internal.Rules.Files((&?> ),(&%> ),defaultRuleFiles )whereimportControl.MonadimportControl.Monad.IO.ClassimportData.MaybeimportData.List.ExtraimportData.TypeableimportGeneral.Binary importDevelopment.Shake.Internal.Core.Action importDevelopment.Shake.Internal.Core.Types hiding(Result )importDevelopment.Shake.Internal.Core.Build importDevelopment.Shake.Internal.Core.Rules importDevelopment.Shake.Internal.Errors importGeneral.Extra importDevelopment.Shake.Internal.FileName importDevelopment.Shake.Classes importDevelopment.Shake.Internal.Rules.Rerun importDevelopment.Shake.Internal.Rules.File importDevelopment.Shake.Internal.FilePattern importDevelopment.Shake.FilePath importDevelopment.Shake.Internal.FileInfo importDevelopment.Shake.Internal.Options importData.MonoidimportPreludeinfix1&?> ,&%> typeinstanceRuleResult FilesQ =FilesA newtypeFilesQ =FilesQ {fromFilesQ ::[FileQ ]}deriving(Typeable,Eq,Hashable,Binary,BinaryEx ,NFData)newtypeFilesA =FilesA [FileA ]deriving(Typeable,BinaryEx ,NFData)instanceShowFilesA whereshow (FilesA xs )=unwords$"Files":map(drop5.show)xs instanceShowFilesQ whereshow (FilesQ xs )=unwords$map(wrapQuote .show)xs dataFilesRule =FilesRule String(FilesQ ->Maybe(Action FilesA ))derivingTypeabledataResult =Result Ver FilesA instanceBinaryEx Result whereputEx (Result v x )=putExStorable v <>putEx x getEx s =let(a ,b )=binarySplit s inResult a $getEx b filesStoredValue::ShakeOptions ->FilesQ ->IO(MaybeFilesA )filesStoredValue opts (FilesQ xs )=fmapFilesA .sequence<$>mapM(fileStoredValue opts )xs filesEqualValue::ShakeOptions ->FilesA ->FilesA ->EqualCost filesEqualValue opts (FilesA xs )(FilesA ys )|lengthxs /=lengthys =NotEqual |otherwise=foldrand_ EqualCheap $zipWithExact (fileEqualValue opts )xs ys whereand_ NotEqual _=NotEqual and_EqualCheap x =x and_EqualExpensive x =ifx ==NotEqual thenNotEqual elseEqualExpensive defaultRuleFiles::Rules ()defaultRuleFiles =doopts <-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 [])=returnNothing-- in the case of disabling lintruleLintopts k v =donow <-filesStoredValue opts k return$casenow ofNothing->Just"<missing>"Justnow |filesEqualValue opts v now ==EqualCheap ->Nothing|otherwise->Just$shownow ruleIdentity::ShakeOptions ->BuiltinIdentity FilesQ FilesA ruleIdentity opts |shakeChangeopts ==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 @(fmapgetEx ->old ::MaybeResult )mode =doletr =map(rebuildFlags .fileNameToString .fromFileQ)$fromFilesQk (ruleVer ,ruleAct ,ruleErr )<-getUserRuleInternal k (\(FilesRule s _)->Justs )$\(FilesRule _f )->f k letverEq v =Justv ==ruleVer ||map(Ver .fst)ruleAct ==[v ]letrebuild =doputWhen Chatty $"# "++showk caseruleAct of[x ]->rebuildWith x _->throwM ruleErr caseold of_|RebuildNow `elem`r ->rebuild _|RebuildLater `elem`r ->caseold ofJust_->-- ignoring the currently stored value, which may trigger lint has changed-- so disable lint on this filereturn$RunResult ChangedNothing (fromJusto )$FilesA []Nothing->do-- i don't have a previous value, so assume this is a source node, and mark rebuild in futurenow <-liftIO$filesStoredValue opts k casenow ofNothing->rebuild Justnow ->doalwaysRerun ;return$RunResult ChangedStore (runBuilder $putEx $Result (Ver 0)now )now Just(Result ver old )|mode ==RunDependenciesSame ,verEq ver ->dov <-liftIO$filesStoredValue opts k casev ofJustv ->casefilesEqualValue opts old v ofNotEqual ->rebuild EqualCheap ->return$RunResult ChangedNothing (fromJusto )v EqualExpensive ->return$RunResult ChangedStore (runBuilder $putEx $Result ver v )v Nothing->rebuild _->rebuild whererebuildWith (ver ,act )=docache <-historyLoad ver v <-casecache ofJustres ->fmapFilesA $forM(zipExact (getExList res )(fromFilesQk ))$\(bin ,file )->doJust(FileA mod size _)<-liftIO$fileStoredValue opts file return$FileA mod size $getExStorable bin Nothing->doFilesA v <-act producesUnchecked $map(fileNameToString .fromFileQ)$fromFilesQk historySave ver $runBuilder $putExList [ifisNoFileHash hash thenthrowImpure errorNoHash elseputExStorable hash |FileA __hash <-v ]return$FilesA v letc |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 .returnps &%>act |not$compatible ps =error$unlines$"All patterns to &%> must have the same number and position of ** and * wildcards":["* "++p ++(ifcompatible [p ,headps ]then""else" (incompatible)")|p <-ps ]|otherwise=withFrozenCallStack$doforM_(zipFrom0ps )$\(i ,p )->(ifsimple p thenidelsepriority 0.5)$fileForward (showps ++" &%> at "++callStackTop )$letop =(p ?== )in\file ->ifnot$op file thenNothingelseJust$doFilesA res <-apply1 $FilesQ $map(FileQ .fileNameFromString .substitute (extract p file ))ps return$ifnullres thenNothingelseJust$res !!i (ifallsimple ps thenidelsepriority 0.5)$domapM_addTarget ps addUserRule $FilesRule (showps ++" &%> "++callStackTop )$\(FilesQ xs_ )->letxs =map(fileNameToString .fromFileQ)xs_ inifnot$lengthxs ==lengthps &&and(zipWithExact (?== )ps xs )thenNothingelseJust$doliftIO$mapM_createDirectoryRecursive $nubOrd$maptakeDirectoryxs 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$doletinputOutput suf inp out =["Input"++suf ++":"," "++inp ]++["Output"++suf ++":"]++map(" "++)out letnormTest =fmap(map$toStandard .normaliseEx ).test letcheckedTest x =casenormTest x ofNothing->NothingJustys |x `notElem`ys ->error$unlines$"Invariant broken in &?>, did not return the input (after normalisation).":inputOutput ""x ys Justys |bad :_<-filter((/=Justys ).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 )Justys ->Justys fileForward ("&?> at "++callStackTop )$\x ->casecheckedTest x ofNothing->NothingJustys ->Just$doFilesA res <-apply1 $FilesQ $map(FileQ .fileNameFromString )ys return$ifnullres thenNothingelseJust$res !!fromJust(elemIndexx ys )addUserRule $FilesRule ("&?> "++callStackTop )$\(FilesQ xs_ )->letxs @(x :_)=map(fileNameToString .fromFileQ)xs_ incasecheckedTest x ofJustys |ys ==xs ->Just$doliftIO$mapM_createDirectoryRecursive $nubOrd$maptakeDirectoryxs act xs getFileTimes "&?>"xs_ Justys ->error$"Error, &?> is incompatible with "++showxs ++" vs "++showys Nothing->NothinggetFileTimes::String->[FileQ ]->Action FilesA getFileTimes name xs =doopts <-getShakeOptions letopts2 =ifshakeChangeopts ==ChangeModtimeAndDigestInput thenopts {shakeChange=ChangeModtime }elseopts ys <-liftIO$mapM(fileStoredValue opts2 )xs casesequenceys ofJustys ->return$FilesA ys Nothing|not$shakeCreationCheckopts ->return$FilesA []Nothing->doletmissing =length$filterisNothingys error$"Error, "++name ++" rule failed to produce "++showmissing ++" file"++(ifmissing ==1then""else"s")++" (out of "++show(lengthxs )++")"++concat["\n "++fileNameToString x ++ifisNothingy then" - MISSING"else""|(FileQ x ,y )<-zipExact xs ys ]