{-# LANGUAGE RecordWildCards, CPP, ViewPatterns, ForeignFunctionInterface, TupleSections #-}-- | Progress trackingmoduleDevelopment.Shake.Internal.Progress(progress ,progressSimple ,progressDisplay ,progressTitlebar ,progressProgram ,ProgressEntry (..),progressReplay ,writeProgressReport -- INTERNAL USE ONLY)whereimportControl.ApplicativeimportData.Tuple.ExtraimportControl.Exception.ExtraimportControl.Monad.ExtraimportSystem.DirectoryimportSystem.ProcessimportSystem.FilePathimportData.CharimportData.IORefimportData.ListimportData.MaybeimportDevelopment.Shake.Internal.Options importDevelopment.Shake.Internal.Core.Types importDevelopment.Shake.Internal.Core.Database importqualifiedData.ByteString.Char8asBSimportqualifiedData.ByteString.Lazy.Char8asLBSimportNumeric.ExtraimportGeneral.Template importGeneral.EscCodes importGeneral.Extra importDevelopment.Shake.Internal.Paths importSystem.Time.Extra#ifdef mingw32_HOST_OS
importForeign.C.String#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif
foreignimportCALLCONV"Windows.h SetConsoleTitleW"c_setConsoleTitleW::CWString->IOBool#endif
----------------------------------------------------------------------- PROGRESSprogress::Database ->Step ->IOProgress progress db step =doxs <-getKeyValues db return$!foldl'f mempty$mapsndxs whereg =floatToDoublef s (Ready Result {..})=ifstep ==built thens {countBuilt=countBuilts +1,timeBuilt=timeBuilts +g execution }elses {countSkipped=countSkippeds +1,timeSkipped=timeSkippeds +g execution }fs (Loaded Result {..})=s {countUnknown=countUnknowns +1,timeUnknown=timeUnknowns +g execution }fs (Running _r )=let(d ,c )=timeTodos t |JustResult {..}<-r =letd2 =d +g execution ind2 `seq`(d2 ,c )|otherwise=letc2 =c +1inc2 `seq`(d ,c2 )ins {countTodo=countTodos +1,timeTodo=t }fs _=s ----------------------------------------------------------------------- MEALY TYPE - for writing the progress functions-- See <https://hackage.haskell.org/package/machines-0.2.3.1/docs/Data-Machine-Mealy.html>-- | A machine that takes inputs and produces outputsnewtypeMealy i a =Mealy {runMealy ::i ->(a ,Mealy i a )}instanceFunctor(Mealy i )wherefmap f (Mealy m )=Mealy $\i ->casem i of(x ,m )->(f x ,fmapf m )instanceApplicative(Mealy i )wherepure x =letr =Mealy (const(x ,r ))inr Mealy mf <*> Mealy mx =Mealy $\i ->casemf i of(f ,mf )->casemx i of(x ,mx )->(f x ,mf <*>mx )echoMealy::Mealy i i echoMealy =Mealy (,echoMealy )scanMealy::(a ->b ->a )->a ->Mealy i b ->Mealy i a scanMealy f z (Mealy m )=Mealy $\i ->casem i of(x ,m )->letz2 =f z x in(z2 ,scanMealy f z2 m )----------------------------------------------------------------------- MEALY UTILITIESoldMealy::a ->Mealy i a ->Mealy i (a ,a )oldMealy old =scanMealy (\(_,old )new ->(old ,new ))(old ,old )latch::Mealy i (Bool,a )->Mealy i a latch s =fromJust<$>scanMealy f Nothings wheref old (b ,v )=Just$ifb thenfromMaybev old elsev iff::Mealy i Bool->Mealy i a ->Mealy i a ->Mealy i a iff c t f =(\c t f ->ifc thent elsef )<$>c <*>t <*>f -- decay'd division, compute a/b, with a decay of f-- r' is the new result, r is the last result-- r' ~= a' / b'-- r' = r*b + f*(a'-a)-- --------------- b + f*(b'-b)-- when f == 1, r == r'---- both streams must only ever increasedecay::Double->Mealy i Double->Mealy i Double->Mealy i Doubledecay f a b =scanMealy step 0$(,)<$>oldMealy 0a <*>oldMealy 0b wherestep r ((a ,a' ),(b ,b' ))=ifisNaNr thena' /b' else((r *b )+f *(a' -a ))/(b +f *(b' -b ))----------------------------------------------------------------------- MESSAGE GENERATORformatMessage::Double->Double->StringformatMessage secs perc =(ifisNaNsecs ||secs <0then"??s"elseshowMinSec $ceilingsecs )++" ("++(ifisNaNperc ||perc <0||perc >100then"??"elseshow$floorperc )++"%)"showMinSec::Int->StringshowMinSec secs =(ifm ==0then""elseshowm ++"m"++['0'|s <10])++shows ++"s"where(m ,s )=divModsecs 60liftA2'::Applicativem =>m a ->m b ->(a ->b ->c )->m c liftA2' a b f =liftA2f a b -- | return (number of seconds, percentage, explanation)message::Mealy (Double,Progress )(Double,Progress )->Mealy (Double,Progress )(Double,Double,String)message input =liftA3(,,)time perc debug whereprogress =snd<$>input secs =fst<$>input debug =(\donePerSec ruleTime (todoKnown ,todoUnknown )->"Progress: "++"((known="++showDP2todoKnown ++"s) + "++"(unknown="++showtodoUnknown ++" * time="++showDP2ruleTime ++"s)) "++"(rate="++showDP2donePerSec ++"))")<$>donePerSec <*>ruleTime <*>(timeTodo<$>progress )-- Number of seconds work completed in this build run-- Ignores timeSkipped which would be more truthful, but it makes the % drop sharply-- which isn't what users wantdone =timeBuilt<$>progress -- Work done per second, don't divide by 0 and don't update if 'done' doesn't changedonePerSec =iff ((==)0<$>done )(pure1)perSecStable whereperSecStable =latch $liftA2(,)(uncurry(==)<$>oldMealy 0done )perSecRaw perSecRaw =decay 1.2done secs -- Predicted build time for a rule that has never been built before-- The high decay means if a build goes in "phases" - lots of source files, then lots of compiling-- we reach a reasonable number fairly quickly, without bouncing too muchruleTime =liftA2weightedAverage (f (decay 10)timeBuiltcountBuilt)(f (liftA2(/))(fst.timeTodo)(\Progress {..}->countTodo -sndtimeTodo ))-- don't call decay on todo, since it goes up and down (as things get done)whereweightedAverage (w1 ,x1 )(w2 ,x2 )|w1 ==0&&w2 ==0=0|otherwise=((w1 *. x1 )+(w2 *. x2 ))/intToDouble(w1 +w2 )wherei *. d =ifi ==0then0elseintToDoublei *d -- since d might be NaNf divide time count =letxs =count <$>progress inliftA2(,)xs $divide (time <$>progress )(intToDouble<$>xs )-- Number of seconds work remaining, ignoring multiple threadstodo =f <$>progress <*>ruleTime wheref Progress {..}ruleTime =fsttimeTodo +(fromIntegral(sndtimeTodo )*ruleTime )-- Display informationtime =liftA2(/)todo donePerSec perc =iff ((==)0<$>done )(pure0)$liftA2' done todo $\done todo ->100*done /(done +todo )----------------------------------------------------------------------- EXPOSED FUNCTIONS-- | Given a sampling interval (in seconds) and a way to display the status message,-- produce a function suitable for using as 'Development.Shake.shakeProgress'.-- This function polls the progress information every /n/ seconds, produces a status-- message and displays it using the display function.---- Typical status messages will take the form of @1m25s (15%)@, indicating that the build-- is predicted to complete in 1 minute 25 seconds (85 seconds total), and 15% of the necessary build time has elapsed.-- This function uses past observations to predict future behaviour, and as such, is only-- guessing. The time is likely to go up as well as down, and will be less accurate from a-- clean build (as the system has fewer past observations).---- The current implementation is to predict the time remaining (based on 'timeTodo') and the-- work already done ('timeBuilt'). The percentage is then calculated as @remaining / (done + remaining)@,-- while time left is calculated by scaling @remaining@ by the observed work rate in this build,-- roughly @done / time_elapsed@.progressDisplay::Double->(String->IO())->IOProgress ->IO()progressDisplay sample disp prog =dodisp "Starting..."-- no useful info at this stagetime <-offsetTimecatchJust(\x ->ifx ==ThreadKilledthenJust()elseNothing)(loop time $message echoMealy )(const$dot <-time ;disp $"Finished in "++showDurationt )whereloop::IODouble->Mealy (Double,Progress )(Double,Double,String)->IO()loop time mealy =dosleepsample p <-prog t <-time ((secs ,perc ,_debug ),mealy )<-return$runMealymealy (t ,p )-- putStrLn _debugletdone =countSkippedp +countBuiltp lettodo =done +countUnknownp +countTodop disp $"Running for "++showDurationSecs t ++" ["++showdone ++"/"++showtodo ++"]"++", predicted "++formatMessage secs perc ++maybe""(", Failure! "++)(isFailurep )loop time mealy dataProgressEntry =ProgressEntry {idealSecs ::Double,idealPerc ::Double,actualSecs ::Double,actualPerc ::Double}isInvalid::ProgressEntry ->BoolisInvalid ProgressEntry {..}=isNaNactualSecs ||isNaNactualPerc -- | Given a list of progress inputs, what would you have suggested (seconds, percentage)progressReplay::[(Double,Progress )]->[ProgressEntry ]progressReplay []=[]progressReplayps =snd$mapAccumLf (message echoMealy )ps whereend =fst$lastps f a (time ,p )=(a2 ,ProgressEntry (end -time )(time *100/end )secs perc )where((secs ,perc ,_),a2 )=runMealya (time ,p )-- | Given a trace, display information about how well we didwriteProgressReport::FilePath->[(FilePath,[(Double,Progress )])]->IO()writeProgressReport out (map(secondprogressReplay )->xs )|(bad ,_):_<-filter(anyisInvalid .snd)xs =errorIO$"Progress generates NaN for "++bad |takeExtensionout ==".js"=writeFileout $"var shake = \n"++generateJSON xs |takeExtensionout ==".json"=writeFileout $generateJSON xs |out =="-"=putStr$unlines$generateSummary xs |otherwise=LBS.writeFileout =<<generateHTML xs generateSummary::[(FilePath,[ProgressEntry ])]->[String]generateSummary xs =flipconcatMapxs $\(file ,xs )->["# "++file ,f xs "Seconds"idealSecsactualSecs,f xs "Percent"idealPercactualPerc]wherelevels =[100,90,80,50]f xs lbl ideal actual =lbl ++": "++intercalate", "[showl ++"% within "++show(ceiling$maximum$0:take((lengthxs *l )`div`100)diff )|l <-levels ]wherediff =sort[abs$ideal x -actual x |x <-xs ]generateHTML::[(FilePath,[ProgressEntry ])]->IOLBS.ByteStringgenerateHTML xs =doreport <-readDataFileHTML "progress.html"letf "data/progress-data.js"=return$LBS.pack$"var progress =\n"++generateJSON xs runTemplate f report generateJSON::[(FilePath,[ProgressEntry ])]->StringgenerateJSON =concat.jsonList .map((++"}").unlines.f )wheref (file ,ps )=("{\"name\":"++show(takeFileNamefile )++", \"values\":"):indent (jsonList $mapg ps )shw =showDP1g ProgressEntry {..}=jsonObject [("idealSecs",shw idealSecs ),("idealPerc",shw idealPerc ),("actualSecs",shw actualSecs ),("actualPerc",shw actualPerc )]indent =map(" "++)jsonList xs =zipWith(:)('[':repeat',')xs ++["]"]jsonObject xs ="{"++intercalate", "[showa ++":"++b |(a ,b )<-xs ]++"}"-- | Set the title of the current console window to the given text. If the-- environment variable @$TERM@ is set to @xterm@ this uses xterm escape sequences.-- On Windows, if not detected as an xterm, this function uses the @SetConsoleTitle@ API.progressTitlebar::String->IO()progressTitlebar x =unlessMwin lin where#ifdef mingw32_HOST_OS
win=withCWStringxc_setConsoleTitleW#else
win =returnFalse#endif
lin =whenMcheckEscCodes $BS.putStr$BS.pack$escWindowTitle x -- | Call the program @shake-progress@ if it is on the @$PATH@. The program is called with-- the following arguments:---- * @--title=string@ - the string passed to @progressProgram@.---- * @--state=Normal@, or one of @NoProgress@, @Normal@, or @Error@ to indicate-- what state the progress bar should be in.---- * @--value=25@ - the percent of the build that has completed, if not in @NoProgress@ state.---- The program will not be called consecutively with the same @--state@ and @--value@ options.---- Windows 7 or higher users can get taskbar progress notifications by placing the following-- program in their @$PATH@: <https://github.com/ndmitchell/shake/releases>.progressProgram::IO(String->IO())progressProgram =doexe <-findExecutable"shake-progress"caseexe ofNothing->return$const$return()Justexe ->dolastArgs <-newIORefNothing-- the arguments we passed to shake-progress last timereturn$\msg ->doletfailure =" Failure! "`isInfixOf`msg letperc =let(a ,b )=break(=='%')msg inifnullb then""elsereverse$takeWhileisDigit$reversea letstate |perc ==""="NoProgress"|failure ="Error"|otherwise="Normal"letargs =["--title="++msg ,"--state="++state ]++["--value="++perc |perc /=""]same <-atomicModifyIOReflastArgs $\old ->(Justargs ,old ==Justargs )unlesssame $void$rawSystemexe args -- | A simple method for displaying progress messages, suitable for using as 'Development.Shake.shakeProgress'.-- This function writes the current progress to the titlebar every five seconds using 'progressTitlebar',-- and calls any @shake-progress@ program on the @$PATH@ using 'progressProgram'.progressSimple::IOProgress ->IO()progressSimple p =doprogram <-progressProgram progressDisplay 5(\s ->progressTitlebar s >>program s )p