{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, PatternGuards #-}{-# LANGUAGE ConstraintKinds, TupleSections, ViewPatterns #-}{-# LANGUAGE TypeFamilies #-}moduleDevelopment.Shake.Internal.Core.Run(RunState ,open ,reset ,run ,shakeRunAfter ,liveFilesState ,profileState ,errorsState )whereimportControl.ExceptionimportData.Tuple.ExtraimportControl.Concurrent.Extrahiding(withNumCapabilities)importDevelopment.Shake.Internal.Core.Database importControl.Monad.IO.ClassimportGeneral.Binary importDevelopment.Shake.Classes importDevelopment.Shake.Internal.Core.Storage importDevelopment.Shake.Internal.History.Shared importDevelopment.Shake.Internal.History.Cloud importqualifiedGeneral.TypeMap asTMapimportControl.Monad.ExtraimportData.TypeableimportNumeric.ExtraimportData.List.ExtraimportqualifiedData.HashMap.StrictasMapimportqualifiedData.HashSetasSetimportData.DynamicimportData.MaybeimportData.IORefimportSystem.DirectoryimportSystem.Time.ExtraimportqualifiedData.ByteStringasBSimportDevelopment.Shake.Internal.Core.Types importDevelopment.Shake.Internal.Core.Action importDevelopment.Shake.Internal.Core.Rules importGeneral.Pool importDevelopment.Shake.Internal.Progress importDevelopment.Shake.Internal.Value importDevelopment.Shake.Internal.Profile importDevelopment.Shake.Internal.Options importDevelopment.Shake.Internal.Errors importGeneral.Timing importGeneral.Thread importGeneral.Extra importGeneral.Cleanup importData.MonoidimportPrelude----------------------------------------------------------------------- MAKEdataRunState =RunState {opts ::ShakeOptions ,ruleinfo ::Map.HashMapTypeRepBuiltinRule ,userRules ::TMap.Map UserRuleVersioned ,database ::Database ,curdir ::FilePath,shared ::MaybeShared ,cloud ::MaybeCloud ,actions ::[(Stack ,Action ())]}open::Cleanup ->ShakeOptions ->Rules ()->IORunState open cleanup opts rs =withInit opts $\opts @ShakeOptions {..}diagnostic _->dodiagnostic $return"Starting run"(actions ,ruleinfo ,userRules ,_targets )<-runRules opts rs diagnostic $return$"Number of actions = "++show(lengthactions )diagnostic $return$"Number of builtin rules = "++show(Map.sizeruleinfo )++" "++show(Map.keysruleinfo )diagnostic $return$"Number of user rule types = "++show(TMap.size userRules )diagnostic $return$"Number of user rules = "++show(sum(TMap.toList (userRuleSize .userRuleContents)userRules ))checkShakeExtra shakeExtra curdir <-getCurrentDirectorydatabase <-usingDatabase cleanup opts diagnostic ruleinfo (shared ,cloud )<-loadSharedCloud database opts ruleinfo returnRunState {..}-- Prepare for a fresh run by changing Result to Loadedreset::RunState ->IO()reset RunState {..}=runLocked database $modifyAllMem database f wheref (Ready r )=Loaded (snd<$>r )f(Error _x )=maybeMissing Loaded x f(Running _x )=maybeMissing Loaded x -- shouldn't ever happen, but Loaded is least worstfx =x run::RunState ->Bool->[Action ()]->IO[IO()]run RunState {..}oneshot actions2 =withInit opts $\opts @ShakeOptions {..}diagnostic output ->do-- timings are a bit delicate, we want to make sure we clear them before we leave (so each run is fresh)-- but we also want to only print them if there is no exception, and have to caputre them before we clear them-- we use this variable to stash them away, then print after the exception handling blocktimingsToShow <-newIORefNothingres <-withCleanup $\cleanup ->doregister cleanup $dowhen(shakeTimings &&shakeVerbosity >=Normal )$writeIOReftimingsToShow .Just=<<getTimings resetTimings start <-offsetTimeexcept <-newIORef(Nothing::Maybe(String,ShakeException ))letgetFailure =fmapfst<$>readIORefexcept letraiseError err |notshakeStaunch =throwIOerr |otherwise=doletnamed =shakeAbbreviationsApply opts .shakeExceptionTargetatomicModifyIORefexcept $\v ->(Just$fromMaybe(named err ,err )v ,())-- no need to print exceptions here, they get printed when they are wrappedafter <-newIORef[]absent <-newIORef[]step <-incrementStep database getProgress <-usingProgress cleanup opts database step getFailure lintCurrentDirectory curdir "When running"watch <-lintWatch shakeLintWatch letruleFinished |isJustshakeLint =\k ->doliftIO$lintCurrentDirectory curdir $showk lintTrackFinished liftIO$watch $showk |otherwise=liftIO.watch .showaddTiming "Running rules"locals <-newIORef[]runPool (shakeThreads ==1)shakeThreads $\pool ->doletglobal =Global database pool cleanup start ruleinfo output opts diagnostic ruleFinished after absent getProgress userRules shared cloud step oneshot -- give each action a stack to start with!forM_(actions ++map(emptyStack ,)actions2 )$\(stack ,act )->doletlocal =newLocal stack shakeVerbosity addPool PoolStart pool $runAction global local (act >>getLocal )$\x ->casex ofLefte ->raiseError =<<shakeException global stack e Rightlocal ->atomicModifyIOReflocals $\rest ->(local :rest ,())maybe(return())(throwIO.snd)=<<readIORefexcept assertFinishedDatabase database letputWhen lvl msg =when(shakeVerbosity >=lvl )$output lvl msg locals <-readIOReflocals end <-start ifnullactions &&nullactions2 thenputWhen Normal "Warning: No want/action statements, nothing to do"elserecordRoot step locals end database when(isJustshakeLint )$doaddTiming "Lint checking"lintCurrentDirectory curdir "After completion"checkValid diagnostic database (runLint ruleinfo )=<<readIORefabsent putWhen Loud "Lint checking succeeded"when(shakeReport /=[])$doaddTiming "Profile report"forM_shakeReport $\file ->doputWhen Normal $"Writing report to "++file writeProfile file database when(shakeLiveFiles /=[])$doaddTiming "Listing live"diagnostic $return"Listing live keys"xs <-liveFiles database forM_shakeLiveFiles $\file ->doputWhen Normal $"Writing live list to "++file (iffile =="-"thenputStrelsewriteFilefile )$unlinesxs res <-readIORefafter addTiming "Cleanup"returnres whenJustM(readIOReftimingsToShow )$putStr.unlinesreturnres -- | Run a set of IO actions, treated as \"after\" actions, typically returned from-- 'Development.Shake.Database.shakeRunDatabase'. The actions will be run with diagnostics-- etc as specified in the 'ShakeOptions'.shakeRunAfter::ShakeOptions ->[IO()]->IO()shakeRunAfter _[]=return()shakeRunAfteropts after =withInit opts $\ShakeOptions {..}diagnostic _->doletn =show$lengthafter diagnostic $return$"Running "++n ++" after actions"(time ,_)<-duration$sequence_$reverseafter when(shakeTimings &&shakeVerbosity >=Normal )$putStrLn$"(+ running "++shown ++" after actions in "++showDurationtime ++")"withInit::ShakeOptions ->(ShakeOptions ->(IOString->IO())->(Verbosity ->String->IO())->IOa )->IOa withInit opts act =withCleanup $\cleanup ->doopts @ShakeOptions {..}<-usingShakeOptions cleanup opts (diagnostic ,output )<-outputFunctions opts <$>newLockact opts diagnostic output usingShakeOptions::Cleanup ->ShakeOptions ->IOShakeOptions usingShakeOptions cleanup opts =doopts @ShakeOptions {..}<-ifshakeThreadsopts /=0thenreturnopts elsedop <-getProcessorCount ;returnopts {shakeThreads=p }whenshakeLineBuffering $usingLineBuffering cleanup usingNumCapabilities cleanup shakeThreads returnopts outputFunctions::ShakeOptions ->Lock->(IOString->IO(),Verbosity ->String->IO())outputFunctions opts @ShakeOptions {..}outputLock =(diagnostic ,output )whereoutputLocked v msg =withLockoutputLock $shakeOutput v msg diagnostic |shakeVerbosity <Diagnostic =const$return()|otherwise=\act ->dov <-act ;outputLocked Diagnostic $"% "++v output v =outputLocked v .shakeAbbreviationsApply opts usingProgress::Cleanup ->ShakeOptions ->Database ->Step ->IO(MaybeString)->IO(IOProgress )usingProgress cleanup ShakeOptions {..}database step getFailure =doletgetProgress =dofailure <-getFailure stats <-progress database step returnstats {isFailure=failure }allocateThread cleanup $shakeProgress getProgress returngetProgress checkShakeExtra::Map.HashMapTypeRepDynamic->IO()checkShakeExtra mp =doletbad =[(k ,t )|(k ,v )<-Map.toListmp ,lett =dynTypeRepv ,t /=k ]casebad of(k ,t ):xs ->throwIO$errorStructured "Invalid Map in shakeExtra"[("Key",Just$showk ),("Value type",Just$showt )](ifnullxs then""else"Plus "++show(lengthxs )++" other keys")_->return()runLint::Map.HashMapTypeRepBuiltinRule ->Key ->Value ->IO(MaybeString)runLint mp k v =caseMap.lookup(typeKey k )mp ofNothing->returnNothingJustBuiltinRule {..}->builtinLint k v assertFinishedDatabase::Database ->IO()assertFinishedDatabase database =do-- if you have anyone Waiting, and are not exiting with an error, then must have a complex recursion (see #400)status <-getKeyValues database letbad =[key |(key ,Running {})<-status ]when(bad /=[])$throwM $errorComplexRecursion (mapshowbad )liveFilesState::RunState ->IO[FilePath]liveFilesState RunState {..}=liveFiles database profileState::RunState ->FilePath->IO()profileState RunState {..}file =writeProfile file database liveFiles::Database ->IO[FilePath]liveFiles database =dostatus <-getKeyValues database letspecialIsFileKey t =show(fst$splitTyConAppt )=="FileQ"return[showk |(k ,Ready {})<-status ,specialIsFileKey $typeKey k ]errorsState::RunState ->IO[(String,SomeException)]errorsState RunState {..}=dostatus <-getKeyValues database return[(showk ,e )|(k ,Error e _)<-status ]checkValid::(IOString->IO())->Database ->(Key ->Value ->IO(MaybeString))->[(Key ,Key )]->IO()checkValid diagnostic db check absent =dostatus <-getKeyValues db diagnostic $return"Starting validity/lint checking"-- TEST 1: Have values changed since being depended on-- Do not use a forM here as you use too much stack spacebad <-(\f ->foldMf []status )$\seen v ->casev of(key ,Ready Result {..})->dogood <-check key $fstresult diagnostic $return$"Checking if "++showkey ++" is "++showresult ++", "++ifisNothinggood then"passed"else"FAILED"return$[(key ,result ,now )|Justnow <-[good ]]++seen _->returnseen unless(nullbad )$doletn =lengthbad throwM $errorStructured ("Lint checking error - "++(ifn ==1then"value has"elseshown ++" values have")++" changed since being depended upon")(intercalate[("",Just"")][[("Key",Just$showkey ),("Old",Just$showresult ),("New",Justnow )]|(key ,result ,now )<-bad ])""-- TEST 2: Is anything from lintTrackWrite which promised not to exist actually been createdexists <-getIdFromKey db bad <-return[(parent ,key )|(parent ,key )<-Set.toList$Set.fromListabsent ,isJust$exists key ]unless(nullbad )$doletn =lengthbad throwM $errorStructured ("Lint checking error - "++(ifn ==1then"value"elseshown ++" values")++" did not have "++(ifn ==1then"its"else"their")++" creation tracked")(intercalate[("",Just"")][[("Rule",Just$showparent ),("Created",Just$showkey )]|(parent ,key )<-bad ])""diagnostic $return"Validity/lint check passed"----------------------------------------------------------------------- STORAGEusingDatabase::Cleanup ->ShakeOptions ->(IOString->IO())->Map.HashMapTypeRepBuiltinRule ->IODatabase usingDatabase cleanup opts diagnostic owitness =doletstep =(typeRep(Proxy::ProxyStepKey ),(Ver 0,BinaryOp (constmempty)(conststepKey )))letroot =(typeRep(Proxy::ProxyRoot ),(Ver 0,BinaryOp (constmempty)(constrootKey )))witness <-return$Map.fromList[(QTypeRep t ,(version ,BinaryOp (putDatabase putOp )(getDatabase getOp )))|(t ,(version ,BinaryOp {..}))<-step :root :Map.toList(Map.map(\BuiltinRule {..}->(builtinVersion ,builtinKey ))owitness )](status ,journal )<-usingStorage cleanup opts diagnostic witness journal <-return$\i k v ->journal (QTypeRep $typeKey k )i (k ,v )createDatabase status journal Missing incrementStep::Database ->IOStep incrementStep db =runLocked db $dostepId <-mkId db stepKey v <-liftIO$getKeyValueFromId db stepId step <-return$casev ofJust(_,Loaded r )->incStep $fromStepResult r _->Step 1letstepRes =toStepResult step setMem db stepId stepKey $Ready stepRes liftIO$setDisk db stepId stepKey $Loaded $fmapsndstepRes returnstep toStepResult::Step ->Result (Value ,BS_Store )toStepResult i =Result (newValue i ,runBuilder $putEx i )i i []0[]fromStepResult::Result BS_Store ->Step fromStepResult =getEx .resultrecordRoot::Step ->[Local ]->Seconds->Database ->IO()recordRoot step locals (doubleToFloat->end )db =runLocked db $dorootId <-mkId db rootKey letlocal =localMergeMutable (newLocal emptyStack Normal )locals letrootRes =Result {result=(newValue (),BS.empty),changed=step ,built=step ,depends=nubDepends $reverse$localDependslocal ,execution=0,traces=reverse$Trace BS.emptyend end :localTraceslocal }setMem db rootId rootKey $Ready rootRes liftIO$setDisk db rootId rootKey $Loaded $fmapsndrootRes loadSharedCloud::DatabasePoly k v ->ShakeOptions ->Map.HashMapTypeRepBuiltinRule ->IO(MaybeShared ,MaybeCloud )loadSharedCloud var opts owitness =doletmp =Map.fromList$map(first$show.QTypeRep )$Map.toListowitness letwit =binaryOpMap $\a ->maybe(error$"loadSharedCloud, couldn't find map for "++showa )builtinKey$Map.lookupa mp letwit2 =BinaryOp (\k ->putOpwit (show$QTypeRep $typeKey k ,k ))(snd.getOpwit )letkeyVers =[(k ,builtinVersionv )|(k ,v )<-Map.toListowitness ]letver =makeVer $shakeVersionopts shared <-caseshakeShareopts ofNothing->returnNothingJustx ->Just<$>newShared wit2 ver x cloud <-casenewCloud (runLocked var )(Map.mapbuiltinKeyowitness )ver keyVers $shakeCloudopts of_|null$shakeCloudopts ->returnNothingNothing->fail"shakeCloud set but Shake not compiled for cloud operation"Justres ->Just<$>res return(shared ,cloud )putDatabase::(Key ->Builder )->((Key ,Status )->Builder )putDatabase putKey (key ,Loaded (Result x1 x2 x3 x4 x5 x6 ))=putExN (putKey key )<>putExN (putEx x1 )<>putEx x2 <>putEx x3 <>putEx x5 <>putExN (putEx x4 )<>putEx x6 putDatabase_(_,x )=throwImpure $errorInternal $"putWith, Cannot write Status with constructor "++statusType x getDatabase::(BS.ByteString->Key )->BS.ByteString->(Key ,Status )getDatabase getKey bs |(key ,bs )<-getExN bs ,(x1 ,bs )<-getExN bs ,(x2 ,x3 ,x5 ,bs )<-binarySplit3 bs ,(x4 ,x6 )<-getExN bs =(getKey key ,Loaded (Result x1 x2 x3 (getEx x4 )x5 (getEx x6 )))