{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables, PatternGuards #-}{-# LANGUAGE ConstraintKinds, TupleSections #-}{-# LANGUAGE TypeFamilies #-}moduleDevelopment.Shake.Internal.Core.Run(RunState ,open ,reset ,run ,shakeRunAfter ,liveFilesState ,profileState ,errorsState )whereimportControl.ExceptionimportControl.ApplicativeimportData.Tuple.ExtraimportControl.Concurrent.Extrahiding(withNumCapabilities)importGeneral.Binary importDevelopment.Shake.Internal.Core.Storage importDevelopment.Shake.Internal.History.Shared importDevelopment.Shake.Internal.History.Cloud importqualifiedGeneral.Ids asIdsimportqualifiedGeneral.Intern asInternimportqualifiedGeneral.TypeMap asTMapimportGeneral.Wait importControl.Monad.ExtraimportData.Typeable.ExtraimportData.FunctionimportData.Either.ExtraimportData.List.ExtraimportqualifiedData.HashMap.StrictasMapimportData.DynamicimportData.MaybeimportData.IORefimportSystem.DirectoryimportSystem.IO.ExtraimportSystem.Time.ExtraimportqualifiedData.ByteStringasBSimportDevelopment.Shake.Classes importDevelopment.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.Extra importGeneral.Cleanup importData.MonoidimportPrelude----------------------------------------------------------------------- MAKEdataRunState =RunState {opts ::ShakeOptions ,ruleinfo ::Map.HashMapTypeRepBuiltinRule ,userRules ::TMap.Map UserRuleVersioned ,databaseVar ::VarDatabase ,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 )<-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 <-getCurrentDirectorydatabaseVar <-newVar=<<usingDatabase cleanup opts diagnostic ruleinfo (shared ,cloud )<-loadSharedCloud databaseVar opts ruleinfo returnRunState {..}-- Prepare for a fresh run by changing Result to Loadedreset::RunState ->IO()reset RunState {..}=withVardatabaseVar $\database ->Ids.forMutate (statusdatabase )$\(k ,s )->(k ,f s )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 =withCleanup $\cleanup ->withInit opts $\opts @ShakeOptions {..}diagnostic output ->doregister cleanup $dowhen(shakeTimings &&shakeVerbosity >=Normal )printTimings resetTimings -- so we don't leak memorystart <-offsetTimedatabase <-readVardatabaseVar except <-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"addTiming "Running rules"runPool (shakeThreads ==1)shakeThreads $\pool ->doletglobal =Global databaseVar pool cleanup start ruleinfo output opts diagnostic curdir 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 $\x ->casex ofLefte ->raiseError =<<shakeException global stack e Rightx ->returnx maybe(return())(throwIO.snd)=<<readIORefexcept assertFinishedDatabase database letputWhen lvl msg =when(shakeVerbosity >=lvl )$output lvl msg when(nullactions &&nullactions2 )$putWhen Normal "Warning: No want/action statements, nothing to do"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 readIORefafter -- | 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 =dowait <-newBarrierletgetProgress =dofailure <-getFailure stats <-progress database step returnstats {isFailure=failure }allocate cleanup (flipforkFinally(const$signalBarrierwait ())$shakeProgress getProgress )(\tid ->dokillThreadtid void$timeout1$waitBarrierwait )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 <-Ids.elems status letbad =[key |(key ,Running {})<-status ]when(bad /=[])$throwM $errorComplexRecursion (mapshowbad )liveFilesState::RunState ->IO[FilePath]liveFilesState RunState {..}=dodatabase <-readVardatabaseVar liveFiles database profileState::RunState ->FilePath->IO()profileState RunState {..}file =dodatabase <-readVardatabaseVar writeProfile file database liveFiles::Database ->IO[FilePath]liveFiles database =dostatus <-Ids.elems $statusdatabase letspecialIsFileKey t =show(fst$splitTyConAppt )=="FileQ"return[showk |(k ,Ready {})<-status ,specialIsFileKey $typeKey k ]errorsState::RunState ->IO[(String,SomeException)]errorsState RunState {..}=dodatabase <-readVardatabaseVar status <-Ids.elems $statusdatabase return[(showk ,e )|(k ,Error e _)<-status ]checkValid::(IOString->IO())->Database ->(Key ->Value ->IO(MaybeString))->[(Key ,Key )]->IO()checkValid diagnostic Database {..}check missing =dostatus <-Ids.elems status intern <-readIORefintern diagnostic $return"Starting validity/lint checking"-- 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 ])""bad <-return[(parent ,key )|(parent ,key )<-missing ,isJust$Intern.lookup key intern ]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 )))witness <-return$Map.fromList[(QTypeRep t ,(version ,BinaryOp (putDatabase putOp )(getDatabase getOp )))|(t ,(version ,BinaryOp {..}))<-step :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 ,Loaded v )xs <-Ids.toList status intern <-newIORef$Intern.fromList [(k ,i )|(i ,(k ,_))<-xs ]returnDatabase {..}incrementStep::Database ->IOStep incrementStep Database {..}=dois <-readIORefintern stepId <-caseIntern.lookup stepKey is ofJuststepId ->returnstepId Nothing->do(is ,stepId )<-return$Intern.add stepKey is writeIORefintern is returnstepId step <-dov <-Ids.lookup status stepId return$casev ofJust(_,Loaded r )->incStep $fromStepResult r _->Step 1letstepRes =toStepResult step Ids.insert status stepId (stepKey ,Ready stepRes )journal stepId stepKey $fmapsndstepRes returnstep loadSharedCloud::Vara ->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 .const)(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 )))