{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-}{-# LANGUAGE GeneralizedNewtypeDeriving, ConstraintKinds #-}{-# LANGUAGE ExistentialQuantification, RankNTypes #-}{-# LANGUAGE TypeFamilies #-}moduleDevelopment.Shake.Internal.Core.Rules(Rules ,runRules ,RuleResult ,addBuiltinRule ,addBuiltinRuleEx ,noLint ,noIdentity ,getShakeOptionsRules ,getUserRuleInternal ,getUserRuleOne ,getUserRuleList ,getUserRuleMaybe ,addUserRule ,alternatives ,priority ,versioned ,action ,withoutActions )whereimportControl.ApplicativeimportData.Tuple.ExtraimportControl.ExceptionimportControl.Monad.ExtraimportControl.Monad.FiximportControl.Monad.IO.ClassimportControl.Monad.Trans.ReaderimportDevelopment.Shake.Classes importGeneral.Binary importGeneral.Extra importData.Typeable.ExtraimportData.FunctionimportData.List.ExtraimportqualifiedData.HashMap.StrictasMapimportqualifiedGeneral.TypeMap asTMapimportData.MaybeimportData.IORef.ExtraimportSystem.IO.ExtraimportData.Semigroup(Semigroup(..))importData.Monoidhiding((<>))importqualifiedData.ByteString.LazyasLBSimportqualifiedData.Binary.BuilderasBinimportData.Binary.PutimportData.Binary.GetimportGeneral.ListBuilder importDevelopment.Shake.Internal.Core.Types importDevelopment.Shake.Internal.Core.Monad importDevelopment.Shake.Internal.Value importDevelopment.Shake.Internal.Options importDevelopment.Shake.Internal.Errors importPrelude----------------------------------------------------------------------- RULES-- | Get the 'ShakeOptions' that were used.getShakeOptionsRules::Rules ShakeOptions getShakeOptionsRules =Rules $asksfst-- | Internal variant, more flexible, but not such a nice API-- Same args as getuserRuleMaybe, but returns (guaranteed version, items, error to throw if wrong number)-- Fields are returned lazily, in particular ver can be looked up cheapergetUserRuleInternal::forallkey a b .(ShakeValue key ,Typeablea )=>key ->(a ->MaybeString)->(a ->Maybeb )->Action (MaybeVer ,[(Int,b )],SomeException)getUserRuleInternal key disp test =doGlobal {..}<-Action getRO letUserRuleVersioned versioned rules =fromMaybemempty$TMap.lookup globalUserRules letver =ifversioned thenNothingelseJust$Ver 0letitems =head$(mapsnd$reverse$groupSort$f (Ver 0)Nothingrules )++[[]]leterr =errorMultipleRulesMatch (typeOfkey )(showkey )(mapsnd3items )return(ver ,map(\(Ver v ,_,x )->(v ,x ))items ,err )wheref::Ver ->MaybeDouble->UserRule a ->[(Double,(Ver ,MaybeString,b ))]f v p (UserRule x )=[(fromMaybe1p ,(v ,disp x ,x2 ))|Justx2 <-[test x ]]fv p (Unordered xs )=concatMap(f v p )xs fv p (Priority p2 x )=f v (Just$fromMaybep2 p )x f_p (Versioned v x )=f v p x fv p (Alternative x )=take1$f v p x -- | Get the user rules that were added at a particular type which return 'Just' on a given function.-- Return all equally applicable rules, paired with the version of the rule-- (set by 'versioned'). Where rules are specified with 'alternatives' or 'priority'-- the less-applicable rules will not be returned.---- If you can only deal with zero/one results, call 'getUserRuleMaybe' or 'getUserRuleOne',-- which raise informative errors.getUserRuleList::Typeablea =>(a ->Maybeb )->Action [(Int,b )]getUserRuleList test =snd3<$>getUserRuleInternal ()(constNothing)test -- | A version of 'getUserRuleList' that fails if there is more than one result-- Requires a @key@ for better error messages.getUserRuleMaybe::(ShakeValue key ,Typeablea )=>key ->(a ->MaybeString)->(a ->Maybeb )->Action (Maybe(Int,b ))getUserRuleMaybe key disp test =do(_,xs ,err )<-getUserRuleInternal key disp test casexs of[]->returnNothing[x ]->return$Justx _->throwM err -- | A version of 'getUserRuleList' that fails if there is not exactly one result-- Requires a @key@ for better error messages.getUserRuleOne::(ShakeValue key ,Typeablea )=>key ->(a ->MaybeString)->(a ->Maybeb )->Action (Int,b )getUserRuleOne key disp test =do(_,xs ,err )<-getUserRuleInternal key disp test casexs of[x ]->returnx _->throwM err -- | Define a set of rules. Rules can be created with calls to functions such as 'Development.Shake.%>' or 'action'.-- Rules are combined with either the 'Monoid' instance, or (more commonly) the 'Monad' instance and @do@ notation.-- To define your own custom types of rule, see "Development.Shake.Rule".newtypeRules a =Rules (ReaderT(ShakeOptions ,IORefSRules )IOa )-- All IO must be associative/commutative (e.g. creating IORef/MVars)deriving(Functor,Applicative,Monad,MonadIO,MonadFix)newRules::SRules ->Rules ()newRules x =Rules $liftIO.flipmodifyIORef'(<>x )=<<askssndmodifyRulesScoped::(SRules ->SRules )->Rules a ->Rules a modifyRulesScoped f (Rules r )=Rules $do(opts ,refOld )<-askliftIO$dorefNew <-newIORefmemptyres <-runReaderTr (opts ,refNew )rules <-readIORefrefNew modifyIORef'refOld (<>f rules )returnres runRules::ShakeOptions ->Rules ()->IO([(Stack ,Action ())],Map.HashMapTypeRepBuiltinRule ,TMap.Map UserRuleVersioned )runRules opts (Rules r )=doref <-newIORefmemptyrunReaderTr (opts ,ref )SRules {..}<-readIORefref return(runListBuilder actions ,builtinRules ,userRules )dataSRules =SRules {actions ::!(ListBuilder (Stack ,Action ())),builtinRules ::!(Map.HashMapTypeRep{-k-}BuiltinRule ),userRules ::!(TMap.Map UserRuleVersioned )}instanceSemigroupSRules where(SRules x1 x2 x3 )<> (SRules y1 y2 y3 )=SRules (mappendx1 y1 )(Map.unionWithKeyf x2 y2 )(TMap.unionWith (<>)x3 y3 )wheref k a b =throwImpure $errorRuleDefinedMultipleTimes k [builtinLocationa ,builtinLocationb ]instanceMonoidSRules wheremempty =SRules memptyMap.emptyTMap.empty mappend =(<>)instanceSemigroupa =>Semigroup(Rules a )where(<> )=liftA2(<>)instance(Semigroupa ,Monoida )=>Monoid(Rules a )wheremempty =returnmemptymappend =(<>)-- | Add a user rule. In general these should be specialised to the type expected by a builtin rule.-- The user rules can be retrieved by 'getUserRuleList'.addUserRule::Typeablea =>a ->Rules ()addUserRule r =newRules mempty{userRules=TMap.singleton $UserRuleVersioned False$UserRule r }-- | A suitable 'BuiltinLint' that always succeeds.noLint::BuiltinLint key value noLint __=returnNothing-- | A suitable 'BuiltinIdentity' that always fails with a runtime error, incompatible with 'shakeShare'.-- Use this function if you don't care about 'shakeShare', or if your rule provides a dependency that can-- never be cached (in which case you should also call 'Development.Shake.historyDisable').noIdentity::Typeablekey =>BuiltinIdentity key value noIdentity k _=throwImpure $errorStructured "Key type does not support BuiltinIdentity, so does not work with 'shakeShare'"[("Key type",Just$show(typeOfk ))][]-- | The type mapping between the @key@ or a rule and the resulting @value@.-- See 'addBuiltinRule' and 'apply'.typefamilyRuleResult key -- = value-- | Define a builtin rule, passing the functions to run in the right circumstances.-- The @key@ and @value@ types will be what is used by 'Development.Shake.apply'.-- As a start, you can use 'noLint' and 'noIdentity' as the first two functions,-- but are required to supply a suitable 'BuiltinRun'.---- Raises an error if any other rule exists at this type.addBuiltinRule::(RuleResultkey ~value ,ShakeValue key ,Typeablevalue ,NFDatavalue ,Showvalue ,Partial)=>BuiltinLint key value ->BuiltinIdentity key value ->BuiltinRun key value ->Rules ()addBuiltinRule =withFrozenCallStack$addBuiltinRuleInternal $BinaryOp (putEx .Bin.toLazyByteString.execPut.put)(runGetget.LBS.fromChunks.return)addBuiltinRuleEx::(RuleResultkey ~value ,ShakeValue key ,BinaryEx key ,Typeablevalue ,NFDatavalue ,Showvalue ,Partial)=>BuiltinLint key value ->BuiltinIdentity key value ->BuiltinRun key value ->Rules ()addBuiltinRuleEx =addBuiltinRuleInternal $BinaryOp putEx getEx -- | Unexpected version of 'addBuiltinRule', which also lets me set the 'BinaryOp'.addBuiltinRuleInternal::(RuleResultkey ~value ,ShakeValue key ,Typeablevalue ,NFDatavalue ,Showvalue ,Partial)=>BinaryOp key ->BuiltinLint key value ->BuiltinIdentity key value ->BuiltinRun key value ->Rules ()addBuiltinRuleInternal binary lint check (run ::BuiltinRun key value )=doletk =Proxy::Proxykey letlint_ k v =lint (fromKey k )(fromValue v )letcheck_ k v =check (fromKey k )(fromValue v )letrun_ k v b =fmapnewValue <$>run (fromKey k )v b letbinary_ =BinaryOp (putOpbinary .fromKey )(newKey .getOpbinary )newRules mempty{builtinRules=Map.singleton(typeRepk )$BuiltinRule lint_ check_ run_ binary_ (Ver 0)callStackTop }-- | Change the priority of a given set of rules, where higher priorities take precedence.-- All matching rules at a given priority must be disjoint, or an error is raised.-- All builtin Shake rules have priority between 0 and 1.-- Excessive use of 'priority' is discouraged. As an example:---- @-- 'priority' 4 $ \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"-- 'priority' 8 $ \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"-- @---- In this example @hello.txt@ will match the second rule, instead of raising an error about ambiguity.---- The 'priority' function obeys the invariants:---- @-- 'priority' p1 ('priority' p2 r1) === 'priority' p1 r1-- 'priority' p1 (r1 >> r2) === 'priority' p1 r1 >> 'priority' p1 r2-- @priority::Double->Rules a ->Rules a priority d =modifyRulesScoped $\s ->s {userRules=TMap.map (\(UserRuleVersioned b x )->UserRuleVersioned b $Priority d x )$userRuless }-- | Indicate that the nested rules have a given version. If you change the semantics of the rule then updating (or adding)-- a version will cause the rule to rebuild in some circumstances.---- @-- 'versioned' 1 $ \"hello.*\" %> \\out ->-- 'writeFile'' out \"Writes v1 now\" -- previously wrote out v0-- @---- You should only use 'versioned' to track changes in the build source, for standard runtime dependencies you should use-- other mechanisms, e.g. 'Development.Shake.addOracle'.versioned::Int->Rules a ->Rules a versioned v =modifyRulesScoped $\s ->s {userRules=TMap.map (\(UserRuleVersioned b x )->UserRuleVersioned (b ||v /=0)$Versioned (Ver v )x )$userRuless ,builtinRules=Map.map(\b ->b {builtinVersion=Ver v })$builtinRuless }-- | Change the matching behaviour of rules so rules do not have to be disjoint, but are instead matched-- in order. Only recommended for small blocks containing a handful of rules.---- @-- 'alternatives' $ do-- \"hello.*\" %> \\out -> 'writeFile'' out \"hello.*\"-- \"*.txt\" %> \\out -> 'writeFile'' out \"*.txt\"-- @---- In this example @hello.txt@ will match the first rule, instead of raising an error about ambiguity.-- Inside 'alternatives' the 'priority' of each rule is not used to determine which rule matches,-- but the resulting match uses that priority compared to the rules outside the 'alternatives' block.alternatives::Rules a ->Rules a alternatives =modifyRulesScoped $\r ->r {userRules=TMap.map (\(UserRuleVersioned b x )->UserRuleVersioned b $Alternative x )$userRulesr }-- | Run an action, usually used for specifying top-level requirements.---- @-- main = 'Development.Shake.shake' 'shakeOptions' $ do-- 'action' $ do-- b <- 'Development.Shake.doesFileExist' \"file.src\"-- when b $ 'Development.Shake.need' [\"file.out\"]-- @---- This 'action' builds @file.out@, but only if @file.src@ exists. The 'action'-- will be run in every build execution (unless 'withoutActions' is used), so only cheap-- operations should be performed. On the flip side, consulting system information-- (e.g. environment variables) can be done directly as the information will not be cached.-- All calls to 'action' may be run in parallel, in any order.---- For the standard requirement of only 'Development.Shake.need'ing a fixed list of files in the 'action',-- see 'Development.Shake.want'.action::Partial=>Action a ->Rules ()action act =newRules mempty{actions=newListBuilder (addCallStack callStackFull emptyStack ,voidact )}-- | Remove all actions specified in a set of rules, usually used for implementing-- command line specification of what to build.withoutActions::Rules a ->Rules a withoutActions =modifyRulesScoped $\x ->x {actions=mempty}