{-# LANGUAGE CPP #-}{-# LANGUAGE ScopedTypeVariables, ConstraintKinds, RecordWildCards, GeneralizedNewtypeDeriving, ViewPatterns, Rank2Types #-}moduleGeneral.Extra(getProcessorCount ,findGcc ,whenLeft ,randomElem ,wrapQuote ,showBracket ,withs ,forNothingM ,maximum' ,maximumBy' ,unconcat ,fastAt ,zipExact ,zipWithExact ,isAsyncException ,showDurationSecs ,usingLineBuffering ,doesFileExist_ ,doesDirectoryExist_ ,usingNumCapabilities ,removeFile_ ,createDirectoryRecursive ,catchIO ,tryIO ,handleIO ,handleSynchronous ,Located ,Partial,callStackTop ,callStackFull ,withFrozenCallStack,callStackFromException ,Ver (..),makeVer ,QTypeRep (..),NoShow (..))whereimportControl.Exception.ExtraimportData.CharimportData.List.ExtraimportSystem.EnvironmentimportDevelopment.Shake.FilePath importControl.DeepSeqimportGeneral.Cleanup importData.TypeableimportSystem.IO.ErrorimportSystem.IO.ExtraimportSystem.Time.ExtraimportSystem.IO.UnsafeimportSystem.Info.ExtraimportSystem.RandomimportSystem.DirectoryimportSystem.ExitimportNumeric.ExtraimportForeign.StorableimportControl.Concurrent.ExtraimportData.MaybeimportData.HashableimportData.Primitive.ArrayimportControl.MonadimportControl.Monad.STimportGHC.Conc(getNumProcessors)#if __GLASGOW_HASKELL__ >= 800
importGHC.Stack#endif
----------------------------------------------------------------------- Prelude-- See https://ghc.haskell.org/trac/ghc/ticket/10830 - they broke maximumBymaximumBy'::(a ->a ->Ordering)->[a ]->a maximumBy' cmp =foldl1'$\x y ->ifcmp x y ==GTthenx elsey maximum'::Orda =>[a ]->a maximum' =maximumBy' comparenewtypeNoShow a =NoShow a instanceShow(NoShow a )whereshow _="NoShow"unconcat::[[a ]]->[b ]->[[b ]]unconcat []_=[]unconcat(a :as)bs =b1 :unconcat asb2 where(b1 ,b2 )=splitAt(lengtha )bs ----------------------------------------------------------------------- Data.List-- | If a string has any spaces then put quotes around and double up all internal quotes.-- Roughly the inverse of Windows command line parsing.wrapQuote::String->StringwrapQuote xs |anyisSpacexs ="\""++concatMap(\x ->ifx =='\"'then"\"\""else[x ])xs ++"\""|otherwise=xs -- | If a string has any spaces then put brackets around it.wrapBracket::String->StringwrapBracket xs |anyisSpacexs ="("++xs ++")"|otherwise=xs -- | Alias for @wrapBracket . show@.showBracket::Showa =>a ->StringshowBracket =wrapBracket .show-- | Version of '!!' which is fast and returns 'Nothing' if the index is not present.fastAt::[a ]->(Int->Maybea )fastAt xs =\i ->ifi <0||i >=n thenNothingelseJust$indexArrayarr i wheren =lengthxs arr =runST$doletn =lengthxs arr <-newArrayn undefinedforM_(zipFrom0xs )$\(i ,x )->writeArrayarr i x unsafeFreezeArrayarr zipWithExact::Partial=>(a ->b ->c )->[a ]->[b ]->[c ]zipWithExact f =g whereg [][]=[]g(a :as)(b :bs )=f a b :g asbs g__=error"zipWithExacts: unequal lengths"zipExact::Partial=>[a ]->[b ]->[(a ,b )]zipExact =zipWithExact (,)----------------------------------------------------------------------- System.Info{-# NOINLINEgetProcessorCount#-}getProcessorCount::IOInt-- unsafePefromIO so we cache the result and only compute it oncegetProcessorCount =letres =unsafePerformIOact inreturnres whereact =ifrtsSupportsBoundThreadsthenfromIntegral<$>getNumProcessorselsedoenv <-lookupEnv"NUMBER_OF_PROCESSORS"caseenv ofJusts |[(i ,"")]<-readss ->returni _->dosrc <-readFile'"/proc/cpuinfo"`catchIO `\_->return""return$!max1$length[()|x <-linessrc ,"processor"`isPrefixOf`x ]-- Can you find a GCC executable? return a Bool, and optionally something to add to $PATH to run itfindGcc::IO(Bool,MaybeFilePath)findGcc =dov <-findExecutable"gcc"casev ofNothing|isWindows->doghc <-findExecutable"ghc"caseghc ofJustghc ->doletgcc =takeDirectory(takeDirectoryghc )</>"mingw/bin/gcc.exe"b <-doesFileExist_ gcc return$ifb then(True,Just$takeDirectorygcc )else(False,Nothing)_->return(False,Nothing)_->return(isJustv ,Nothing)----------------------------------------------------------------------- System.RandomrandomElem::[a ]->IOa randomElem xs =dowhen(nullxs )$fail"General.Extra.randomElem called with empty list, can't pick a random element"i <-randomRIO(0,lengthxs -1)return$xs !!i ----------------------------------------------------------------------- System.IOusingLineBuffering::Cleanup ->IO()usingLineBuffering cleanup =doout <-hGetBufferingstdouterr <-hGetBufferingstderrwhen(out /=LineBuffering||err /=LineBuffering)$doregister cleanup $hSetBufferingstdoutout >>hSetBufferingstderrerr hSetBufferingstdoutLineBuffering>>hSetBufferingstderrLineBuffering----------------------------------------------------------------------- System.TimeshowDurationSecs::Seconds->StringshowDurationSecs =replace".00s""s".showDuration.intToDouble.round----------------------------------------------------------------------- Control.Monadwiths::[(a ->r )->r ]->([a ]->r )->r withs []act =act []withs(f :fs )act =f $\a ->withs fs $\as->act $a :asforNothingM::Monadm =>[a ]->(a ->m (Maybeb ))->m (Maybe[b ])forNothingM []f =return$Just[]forNothingM(x :xs )f =dov <-f x casev ofNothing->returnNothingJustv ->liftM(v :)`liftM`forNothingM xs f ----------------------------------------------------------------------- Control.ConcurrentusingNumCapabilities::Cleanup ->Int->IO()usingNumCapabilities cleanup new =whenrtsSupportsBoundThreads$doold <-getNumCapabilitieswhen(old /=new )$doregister cleanup $setNumCapabilitiesold setNumCapabilitiesnew ----------------------------------------------------------------------- Control.Exception-- | Is the exception asynchronous, not a "coding error" that should be ignoredisAsyncException::SomeException->BoolisAsyncException e |Just(_::AsyncException)<-fromExceptione =True|Just(_::ExitCode)<-fromExceptione =True|otherwise=FalsecatchIO::IOa ->(IOException->IOa )->IOa catchIO =catchtryIO::IOa ->IO(EitherIOExceptiona )tryIO =tryhandleIO::(IOException->IOa )->IOa ->IOa handleIO =handlehandleSynchronous::(SomeException->IOa )->IOa ->IOa handleSynchronous =handleBool(not.isAsyncException )----------------------------------------------------------------------- System.DirectorydoesFileExist_::FilePath->IOBooldoesFileExist_ x =doesFileExistx `catchIO `\_->returnFalsedoesDirectoryExist_::FilePath->IOBooldoesDirectoryExist_ x =doesDirectoryExistx `catchIO `\_->returnFalse-- | Remove a file, but don't worry if it failsremoveFile_::FilePath->IO()removeFile_ x =removeFilex `catchIO `\e ->when(isPermissionErrore )$handleIO (\_->return())$doperms <-getPermissionsx setPermissionsx perms {readable=True,searchable=True,writable=True}removeFilex -- | Like @createDirectoryIfMissing True@ but faster, as it avoids-- any work in the common case the directory already exists.createDirectoryRecursive::FilePath->IO()createDirectoryRecursive dir =dox <-tryIO $doesDirectoryExistdir when(x /=RightTrue)$createDirectoryIfMissingTruedir ----------------------------------------------------------------------- Data.EitherwhenLeft::Applicativem =>Eithera b ->(a ->m ())->m ()whenLeft x f =eitherf (const$pure())x ----------------------------------------------------------------------- Data.CallStacktypeLocated =PartialcallStackTop::Partial=>StringcallStackTop =withFrozenCallStack$head$callStackFull ++["unknown location"]callStackFull::Partial=>[String]callStackFromException::SomeException->([String],SomeException)#if __GLASGOW_HASKELL__ >= 800
-- | Invert 'prettyCallStack', which GHC pre-applies in certain casesparseCallStack =reverse.maptrimStart.drop1.linescallStackFull =parseCallStack $prettyCallStack$popCallStackcallStackcallStackFromException (fromException->Just(ErrorCallWithLocationmsg loc ))=(parseCallStack loc ,toException$ErrorCallmsg )callStackFromExceptione =([],e )#else
callStackFull=[]callStackFromExceptione=([],e)withFrozenCallStack::a->awithFrozenCallStack=id#endif
----------------------------------------------------------------------- Data.Version-- | A version number that indicates change, not ordering or compatibilty.-- Always presented as an 'Int' to the user, but a newtype inside the library for safety.newtypeVer =Ver Intderiving(Show,Eq,Storable)makeVer::String->Ver makeVer =Ver .hash----------------------------------------------------------------------- Data.Typeable-- | Like TypeRep, but the Show includes enough information to be unique-- so I can rely on @a == b === show a == show b@.newtypeQTypeRep =QTypeRep {fromQTypeRep ::TypeRep}deriving(Eq,Hashable,NFData)instanceShowQTypeRep where-- Need to show enough so that different types with the same names don't clash-- But can't show too much or the history is not portable https://github.com/ndmitchell/shake/issues/670show (QTypeRep x )=f x wheref x =['('|xs /=[]]++(unwords$g c :mapf xs )++[')'|xs /=[]]where(c ,xs )=splitTyConAppx g x =tyConModulex ++"."++tyConNamex