{-# LANGUAGE RecordWildCards, PatternGuards, ScopedTypeVariables, NamedFieldPuns, GADTs #-}{-# LANGUAGE Rank2Types, ConstraintKinds, TupleSections, ViewPatterns #-}moduleDevelopment.Shake.Internal.Core.Build(getDatabaseValue ,getDatabaseValueGeneric ,historyIsEnabled ,historySave ,historyLoad ,applyKeyValue ,apply ,apply1 ,)whereimportDevelopment.Shake.Classes importGeneral.Pool importDevelopment.Shake.Internal.Core.Database importDevelopment.Shake.Internal.Value importDevelopment.Shake.Internal.Errors importDevelopment.Shake.Internal.Core.Types importDevelopment.Shake.Internal.Core.Action importDevelopment.Shake.Internal.History.Shared importDevelopment.Shake.Internal.History.Cloud importDevelopment.Shake.Internal.Options importDevelopment.Shake.Internal.Core.Monad importGeneral.Wait importqualifiedData.ByteString.Char8asBSimportControl.Monad.IO.ClassimportGeneral.Extra importGeneral.Intern (Id )importControl.ExceptionimportControl.Monad.ExtraimportNumeric.ExtraimportqualifiedData.HashMap.StrictasMapimportDevelopment.Shake.Internal.Core.Rules importData.TypeableimportData.MaybeimportData.List.ExtraimportData.Either.ExtraimportSystem.Time.Extra----------------------------------------------------------------------- LOW-LEVEL OPERATIONS ON THE DATABASEsetIdKeyStatus::Global ->Database ->Id ->Key ->Status ->Locked ()setIdKeyStatus Global {..}db i k v =doliftIO$globalDiagnostic $do-- actually safe because we only lose the Locked to enter the diagnostic contextold <-getKeyValueFromId db i letchangeStatus =maybe"Missing"(statusType .snd)old ++" -> "++statusType v ++", "++maybe"<unknown>"(show.fst)old letchangeValue =casev ofReady r ->Just$" = "++showBracket (resultr )++" "++(ifbuiltr ==changedr then"(changed)"else"(unchanged)")_->Nothingreturn$changeStatus ++maybe""("\n"++)changeValue setMem db i k v ----------------------------------------------------------------------- QUERIESgetDatabaseValue::(RuleResultkey ~value ,ShakeValue key ,Typeablevalue )=>key ->Action (Maybe(Result (EitherBS.ByteStringvalue )))getDatabaseValue k =fmap(fmap$fmap$fmapfromValue )$getDatabaseValueGeneric $newKey k getDatabaseValueGeneric::Key ->Action (Maybe(Result (EitherBS.ByteStringValue )))getDatabaseValueGeneric k =doGlobal {..}<-Action getRO Juststatus <-liftIO$getValueFromKey globalDatabase k return$getResult status ----------------------------------------------------------------------- NEW STYLE PRIMITIVES-- | Lookup the value for a single Id, may need to spawn itlookupOne::Global ->Stack ->Database ->Id ->Wait Locked (EitherSomeException(Result (Value ,BS_Store )))lookupOne global stack database i =dores <-quickly $liftIO$getKeyValueFromId database i caseres ofNothing->Now $Left$errorStructured "Shake Id no longer exists"[("Id",Just$showi )]""Just(k ,s )->cases ofReady r ->Now $Rightr Failed e _->Now $Lefte Running {}|Lefte <-addStack i k stack ->Now $Lefte _->Later $\continue ->doJust(_,s )<-liftIO$getKeyValueFromId database i cases ofReady r ->continue $Rightr Failed e _->continue $Lefte Running (NoShow w )r ->doletw2 v =w v >>continue v setMem database i k $Running (NoShow w2 )r Loaded r ->buildOne global stack database i k (Justr )`fromLater `continue Missing ->buildOne global stack database i k Nothing`fromLater `continue -- | Build a key, must currently be either Loaded or Missing, changes to WaitingbuildOne::Global ->Stack ->Database ->Id ->Key ->Maybe(Result BS.ByteString)->Wait Locked (EitherSomeException(Result (Value ,BS_Store )))buildOne global @Global {..}stack database i k r =caseaddStack i k stack ofLefte ->doquickly $setIdKeyStatus global database i k $mkError e return$Lefte Rightstack ->Later $\continue ->dosetIdKeyStatus global database i k (Running (NoShow continue )r )letgo =buildRunMode global stack database r fromLater go $\mode ->liftIO$addPool PoolStart globalPool $runKey global stack k r mode $\res ->dorunLocked database $doletval =fmaprunValueres res <-liftIO$getKeyValueFromId database i w <-caseres ofJust(_,Running (NoShow w )_)->returnw -- We used to be able to hit here, but we fixed it by ensuring the thread pool workers are all-- dead _before_ any exception bubbles up_->throwM $errorInternal $"expected Waiting but got "++maybe"nothing"(statusType .snd)res ++", key "++showk setIdKeyStatus global database i k $eithermkError Ready val w val caseres ofRightRunResult {..}|runChanged /=ChangedNothing ->setDisk database i k $Loaded runValue {result=runStore }_->return()wheremkError e =Failed e $ifglobalOneShot thenNothingelser -- | Compute the value for a given RunMode and a restore function to runbuildRunMode::Global ->Stack ->Database ->Maybe(Result a )->Wait Locked RunMode buildRunMode global stack database me =dochanged <-caseme ofNothing->returnTrueJustme ->buildRunDependenciesChanged global stack database me return$ifchanged thenRunDependenciesChanged elseRunDependenciesSame -- | Have the dependencies changedbuildRunDependenciesChanged::Global ->Stack ->Database ->Result a ->Wait Locked BoolbuildRunDependenciesChanged global stack database me =isJust<$>firstJustMid[firstJustWaitUnordered (fmaptest .lookupOne global stack database )x |Depends x <-dependsme ]wheretest (Rightdep )|changeddep <=builtme =Nothingtest_=Just()----------------------------------------------------------------------- ACTUAL WORKERSapplyKeyValue::[String]->[Key ]->Action [Value ]applyKeyValue callStack ks =do-- this is the only place a user can inject a key into our world, so check they aren't throwing-- in unevaluated bottomsliftIO$mapM_(evaluate.rnf)ks global @Global {..}<-Action getRO Local {localStack ,localBlockApply }<-Action getRW letstack =addCallStack callStack localStack lettk =typeKey $head$ks ++[newKey ()]-- always called at non-empty so never see () keywhenJustlocalBlockApply $throwM .errorNoApply tk (show<$>listToMaybeks )letdatabase =globalDatabase (is ,wait )<-liftIO$runLocked database $dois <-mapM(mkId database )ks wait <-runWait $dox <-firstJustWaitUnordered (fmap(eitherJust(constNothing)).lookupOne global stack database )$nubOrdis casex ofJuste ->return$Lefte Nothing->quickly $Right<$>mapM(fmap(\(Just(_,Ready r ))->fst$resultr ).liftIO.getKeyValueFromId database )is return(is ,wait )Action $modifyRW $\s ->s {localDepends=Depends is :localDependss }casewait ofNow vs ->eitherthrowM returnvs _->dooffset <-liftIOoffsetTimevs <-Action $captureRAW $\continue ->runLocked globalDatabase $fromLater wait $\x ->liftIO$addPool (ifisLeftx thenPoolException elsePoolResume )globalPool $continue x offset <-liftIOoffset Action $modifyRW $addDiscount offset returnvs runKey::Global ->Stack -- Given the current stack with the key added on->Key -- The key to build->Maybe(Result BS.ByteString)-- A previous result, or Nothing if never been built before->RunMode -- True if any of the children were dirty->Capture (EitherSomeException(RunResult (Result (Value ,BS_Store ))))-- Either an error, or a (the produced files, the result).runKey global @Global {globalOptions=ShakeOptions {..},..}stack k r mode continue =dolettk =typeKey k BuiltinRule {..}<-caseMap.lookuptk globalRules ofNothing->throwM $errorNoRuleToBuildType tk (Just$showk )NothingJustr ->returnr lets =(newLocal stack shakeVerbosity ){localBuiltinVersion=builtinVersion }time <-offsetTimerunAction global s (dores <-builtinRun k (fmapresultr )mode liftIO$evaluate$rnfres -- completed, now track anything required afterwardswhen(runChangedres `elem`[ChangedRecomputeSame ,ChangedRecomputeDiff ])$do-- if the users code didn't run you don't have to check anything (we assume builtin rules are correct)globalRuleFinished k producesCheck Action $fmap(res ,)getRW )$\x ->casex ofLefte ->continue .Left.toException=<<shakeException global stack e Right(RunResult {..},Local {..})|runChanged ==ChangedNothing ||runChanged ==ChangedStore ,Justr <-r ->continue $Right$RunResult runChanged runStore (r {result=mkResult runValue runStore })|otherwise->dodur <-time let(cr ,c )|Justr <-r ,runChanged ==ChangedRecomputeSame =(ChangedRecomputeSame ,changedr )|otherwise=(ChangedRecomputeDiff ,globalStep )continue $Right$RunResult cr runStore Result {result=mkResult runValue runStore ,changed=c ,built=globalStep ,depends=nubDepends $reverselocalDepends ,execution=doubleToFloat$dur -localDiscount ,traces=reverselocalTraces }wheremkResult value store =(value ,ifglobalOneShot thenBS.emptyelsestore )----------------------------------------------------------------------- USER key/value WRAPPERS-- | Execute a rule, returning the associated values. If possible, the rules will be run in parallel.-- This function requires that appropriate rules have been added with 'addBuiltinRule'.-- All @key@ values passed to 'apply' become dependencies of the 'Action'.apply::(Partial,RuleResultkey ~value ,ShakeValue key ,Typeablevalue )=>[key ]->Action [value ]apply []=-- if they do [] then we don't test localBlockApply, but unclear if that should be an error or notreturn[]applyks =fmap(mapfromValue )$Action $stepRAW (callStackFull ,mapnewKey ks )-- | Apply a single rule, equivalent to calling 'apply' with a singleton list. Where possible,-- use 'apply' to allow parallelism.apply1::(Partial,RuleResultkey ~value ,ShakeValue key ,Typeablevalue )=>key ->Action value apply1 =withFrozenCallStack$fmaphead.apply .return----------------------------------------------------------------------- HISTORY STUFF-- | Load a value from the history. Given a version from any user rule-- (or @0@), return the payload that was stored by 'historySave'.---- If this function returns 'Just' it will also have restored any files that-- were saved by 'historySave'.historyLoad::Int->Action (MaybeBS.ByteString)historyLoad (Ver ->ver )=doglobal @Global {..}<-Action getRO Local {localStack ,localBuiltinVersion }<-Action getRW ifisNothingglobalShared &&isNothingglobalCloud thenreturnNothingelsedokey <-liftIO$evaluate$fromMaybe(error"Can't call historyLoad outside a rule")$topStack localStack letdatabase =globalDatabase res <-liftIO$runLocked database $runWait $doletask k =doi <-quickly $mkId database k letidentify =runIdentify globalRules k .fst.resulteither(constNothing)identify <$>lookupOne global localStack database i x <-caseglobalShared ofNothing->returnNothingJustshared ->lookupShared shared ask key localBuiltinVersion ver x <-casex ofJustres ->return$Justres Nothing->caseglobalCloud ofNothing->returnNothingJustcloud ->lookupCloud cloud ask key localBuiltinVersion ver casex ofNothing->returnNothingJust(a ,b ,c )->quickly $Just.(a ,,c )<$>mapM(mapM$mkId database )b -- FIXME: If running with cloud and shared, and you got a hit in cloud, should also add it to sharedres <-caseres ofNow x ->returnx _->dooffset <-liftIOoffsetTimeres <-Action $captureRAW $\continue ->runLocked globalDatabase $fromLater res $\x ->liftIO$addPool PoolResume globalPool $continue $Rightx offset <-liftIOoffset Action $modifyRW $addDiscount offset returnres caseres ofNothing->returnNothingJust(res ,deps ,restore )->doliftIO$globalDiagnostic $return$"History hit for "++showkey liftIOrestore Action $modifyRW $\s ->s {localDepends=reverse$mapDepends deps }return(Justres )-- | Is the history enabled, returns 'True' if you have a 'shakeShare' or 'shakeCloud',-- and haven't called 'historyDisable' so far in this rule.historyIsEnabled::Action BoolhistoryIsEnabled =Action $doGlobal {..}<-getRO Local {localHistory }<-getRW return$localHistory &&(isJustglobalShared ||isJustglobalCloud )-- | Save a value to the history. Record the version of any user rule-- (or @0@), and a payload. Must be run at the end of the rule, after-- any dependencies have been captured. If history is enabled, stores the information-- in a cache.---- This function relies on 'produces' to have been called correctly to describe-- which files were written during the execution of this rule.historySave::Int->BS.ByteString->Action ()historySave (Ver ->ver )store =whenMhistoryIsEnabled $Action $doGlobal {..}<-getRO Local {localProduces ,localDepends ,localBuiltinVersion ,localStack }<-getRW liftIO$do-- make sure we throw errors before we get into the historyevaluatever evaluatestore key <-evaluate$fromMaybe(error"Can't call historySave outside a rule")$topStack localStack letproduced =reverse$mapsndlocalProduces deps <--- can do this without the DB lock, since it reads things that are stableforNothingM (reverselocalDepends )$\(Depends is )->forNothingM is $\i ->doJust(k ,Ready r )<-getKeyValueFromId globalDatabase i return$(k ,)<$>runIdentify globalRules k (fst$resultr )letk =topStack localStack casedeps ofNothing->liftIO$globalDiagnostic $return$"Dependency with no identity for "++showk Justdeps ->dowhenJustglobalShared $\shared ->addShared shared key localBuiltinVersion ver deps store produced whenJustglobalCloud $\cloud ->addCloud cloud key localBuiltinVersion ver deps store produced liftIO$globalDiagnostic $return$"History saved for "++showk runIdentify::Map.HashMapTypeRepBuiltinRule ->Key ->Value ->MaybeBS.ByteStringrunIdentify mp k v |JustBuiltinRule {..}<-Map.lookup(typeKey k )mp =builtinIdentity k v |otherwise=throwImpure $errorInternal "runIdentify can't find rule"