{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- Module: Distribution.Simple.SetupHooks.Rule
--
-- Internal module that defines fine-grained rules for setup hooks.
-- Users should import 'Distribution.Simple.SetupHooks' instead.
module Distribution.Simple.SetupHooks.Rule
  ( -- * Rules

    -- ** Rule
    Rule
  , RuleData (..)
  , RuleId (..)
  , staticRule
  , dynamicRule

    -- ** Commands
  , RuleCommands (..)
  , Command
  , CommandData (..)
  , runCommand
  , mkCommand
  , Dict (..)

    -- *** Helpers for executing commands
  , RuleCmds
  , RuleDynDepsCmd
  , RuleExecCmd
  , DynDepsCmd (..)
  , DepsRes (..)
  , ruleDepsCmd
  , runRuleDynDepsCmd
  , ruleExecCmd
  , runRuleExecCmd

    -- ** Collections of rules
  , Rules (..)
  , Dependency (..)
  , RuleOutput (..)
  , rules
  , noRules

    -- ** Rule inputs/outputs
  , Location (..)
  , location

    -- ** File/directory monitoring
  , MonitorFilePath (..)
  , MonitorKindFile (..)
  , MonitorKindDir (..)

    -- *** Monadic API for generation of 'ActionId'
  , RulesM
  , RulesT (..)
  , RulesEnv (..)
  , computeRules

    -- * Internals
  , Scope (..)
  , SScope (..)
  , Static (..)
  , RuleBinary
  , ruleBinary
  )
where

import qualified Distribution.Compat.Binary as Binary
import Distribution.Compat.Prelude

import Distribution.ModuleName
  ( ModuleName
  )
import Distribution.Simple.FileMonitor.Types
import Distribution.Types.UnitId
import Distribution.Utils.Path
  ( FileOrDir (..)
  , Pkg
  , RelativePath
  , SymbolicPath
  , getSymbolicPath
  , (</>)
  )
import Distribution.Utils.ShortText
  ( ShortText
  )
import Distribution.Utils.Structured
  ( Structure (..)
  , Structured (..)
  , nominalStructure
  )
import Distribution.Verbosity
  ( Verbosity
  )

import Control.Monad.Fix
  ( MonadFix
  )
import Control.Monad.Trans
  ( MonadIO
  , MonadTrans (..)
  )
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.State as State
#if MIN_VERSION_transformers(0,5,6)
import qualified Control.Monad.Trans.Writer.CPS as Writer
#else
import qualified Control.Monad.Trans.Writer.Strict as Writer
#endif
import qualified Data.ByteString.Lazy as LBS
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map
  ( empty
  )

import qualified Data.Kind as Hs
import Data.Type.Bool
  ( If
  )
import Data.Type.Equality
  ( (:~~:) (HRefl)
  , type (==)
  )
import GHC.Show
  ( showCommaSpace
  )
import GHC.StaticPtr
import GHC.TypeLits
  ( Symbol
  )
import System.IO.Unsafe
  ( unsafePerformIO
  )
import qualified Type.Reflection as Typeable
  ( SomeTypeRep (..)
  , TypeRep
  , eqTypeRep
  , typeRep
  , typeRepKind
  , withTypeable
  , pattern App
  )

import System.FilePath
  ( normalise
  )

--------------------------------------------------------------------------------

{- Note [Fine-grained hooks]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
To best understand how the framework of fine-grained build rules
fits into Cabal and the greater Haskell ecosystem, it is helpful to think
that we want build tools (such as cabal-install or HLS) to be able to call
individual build rules on-demand, so that e.g. when a user modifies a .xyz file
the associated preprocessor is re-run.

To do this, we need to perform two different kinds of invocations:

  Query: query the package for the rules that it provides, with their
         dependency information. This allows one to determine when each
         rule should be rerun.

         (For example, if one rule preprocesses *.xyz into *.hs, we need to
         re-run the rule whenever *.xyz is modified.)

  Run: run the relevant action, once one has determined that the rule
       has gone stale.

To do this, any Cabal package with Hooks build-type provides a SetupHooks
module which supports these queries; for example it can be compiled into
a separate executable which can be invoked in the manner described above.
-}

---------
-- Rules

-- | A unique identifier for a t'Rule'.
data RuleId = RuleId
  { RuleId -> RulesNameSpace
ruleNameSpace :: !RulesNameSpace
  , RuleId -> ShortText
ruleName :: !ShortText
  }
  deriving stock (Int -> RuleId -> ShowS
[RuleId] -> ShowS
RuleId -> String
(Int -> RuleId -> ShowS)
-> (RuleId -> String) -> ([RuleId] -> ShowS) -> Show RuleId
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RuleId -> ShowS
showsPrec :: Int -> RuleId -> ShowS
$cshow :: RuleId -> String
show :: RuleId -> String
$cshowList :: [RuleId] -> ShowS
showList :: [RuleId] -> ShowS
Show, RuleId -> RuleId -> Bool
(RuleId -> RuleId -> Bool)
-> (RuleId -> RuleId -> Bool) -> Eq RuleId
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RuleId -> RuleId -> Bool
== :: RuleId -> RuleId -> Bool
$c/= :: RuleId -> RuleId -> Bool
/= :: RuleId -> RuleId -> Bool
Eq, Eq RuleId
Eq RuleId =>
(RuleId -> RuleId -> Ordering)
-> (RuleId -> RuleId -> Bool)
-> (RuleId -> RuleId -> Bool)
-> (RuleId -> RuleId -> Bool)
-> (RuleId -> RuleId -> Bool)
-> (RuleId -> RuleId -> RuleId)
-> (RuleId -> RuleId -> RuleId)
-> Ord RuleId
RuleId -> RuleId -> Bool
RuleId -> RuleId -> Ordering
RuleId -> RuleId -> RuleId
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RuleId -> RuleId -> Ordering
compare :: RuleId -> RuleId -> Ordering
$c< :: RuleId -> RuleId -> Bool
< :: RuleId -> RuleId -> Bool
$c<= :: RuleId -> RuleId -> Bool
<= :: RuleId -> RuleId -> Bool
$c> :: RuleId -> RuleId -> Bool
> :: RuleId -> RuleId -> Bool
$c>= :: RuleId -> RuleId -> Bool
>= :: RuleId -> RuleId -> Bool
$cmax :: RuleId -> RuleId -> RuleId
max :: RuleId -> RuleId -> RuleId
$cmin :: RuleId -> RuleId -> RuleId
min :: RuleId -> RuleId -> RuleId
Ord, (forall x. RuleId -> Rep RuleId x)
-> (forall x. Rep RuleId x -> RuleId) -> Generic RuleId
forall x. Rep RuleId x -> RuleId
forall x. RuleId -> Rep RuleId x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RuleId -> Rep RuleId x
from :: forall x. RuleId -> Rep RuleId x
$cto :: forall x. Rep RuleId x -> RuleId
to :: forall x. Rep RuleId x -> RuleId
Generic)
  deriving anyclass (Get RuleId
[RuleId] -> Put
RuleId -> Put
(RuleId -> Put) -> Get RuleId -> ([RuleId] -> Put) -> Binary RuleId
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: RuleId -> Put
put :: RuleId -> Put
$cget :: Get RuleId
get :: Get RuleId
$cputList :: [RuleId] -> Put
putList :: [RuleId] -> Put
Binary, Typeable RuleId
Tagged RuleId MD5
Typeable RuleId =>
(Proxy RuleId -> Structure)
-> Tagged RuleId MD5 -> Structured RuleId
Proxy RuleId -> Structure
forall a.
Typeable a =>
(Proxy a -> Structure) -> Tagged a MD5 -> Structured a
$cstructure :: Proxy RuleId -> Structure
structure :: Proxy RuleId -> Structure
$cstructureHash' :: Tagged RuleId MD5
structureHash' :: Tagged RuleId MD5
Structured)

data RulesNameSpace = RulesNameSpace
  { RulesNameSpace -> UnitId
rulesUnitId :: !UnitId
  , RulesNameSpace -> ModuleName
rulesModuleName :: !ModuleName
  , RulesNameSpace -> (Int, Int)
rulesSrcLoc :: !(Int, Int)
  }
  deriving stock (Int -> RulesNameSpace -> ShowS
[RulesNameSpace] -> ShowS
RulesNameSpace -> String
(Int -> RulesNameSpace -> ShowS)
-> (RulesNameSpace -> String)
-> ([RulesNameSpace] -> ShowS)
-> Show RulesNameSpace
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RulesNameSpace -> ShowS
showsPrec :: Int -> RulesNameSpace -> ShowS
$cshow :: RulesNameSpace -> String
show :: RulesNameSpace -> String
$cshowList :: [RulesNameSpace] -> ShowS
showList :: [RulesNameSpace] -> ShowS
Show, RulesNameSpace -> RulesNameSpace -> Bool
(RulesNameSpace -> RulesNameSpace -> Bool)
-> (RulesNameSpace -> RulesNameSpace -> Bool) -> Eq RulesNameSpace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RulesNameSpace -> RulesNameSpace -> Bool
== :: RulesNameSpace -> RulesNameSpace -> Bool
$c/= :: RulesNameSpace -> RulesNameSpace -> Bool
/= :: RulesNameSpace -> RulesNameSpace -> Bool
Eq, Eq RulesNameSpace
Eq RulesNameSpace =>
(RulesNameSpace -> RulesNameSpace -> Ordering)
-> (RulesNameSpace -> RulesNameSpace -> Bool)
-> (RulesNameSpace -> RulesNameSpace -> Bool)
-> (RulesNameSpace -> RulesNameSpace -> Bool)
-> (RulesNameSpace -> RulesNameSpace -> Bool)
-> (RulesNameSpace -> RulesNameSpace -> RulesNameSpace)
-> (RulesNameSpace -> RulesNameSpace -> RulesNameSpace)
-> Ord RulesNameSpace
RulesNameSpace -> RulesNameSpace -> Bool
RulesNameSpace -> RulesNameSpace -> Ordering
RulesNameSpace -> RulesNameSpace -> RulesNameSpace
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RulesNameSpace -> RulesNameSpace -> Ordering
compare :: RulesNameSpace -> RulesNameSpace -> Ordering
$c< :: RulesNameSpace -> RulesNameSpace -> Bool
< :: RulesNameSpace -> RulesNameSpace -> Bool
$c<= :: RulesNameSpace -> RulesNameSpace -> Bool
<= :: RulesNameSpace -> RulesNameSpace -> Bool
$c> :: RulesNameSpace -> RulesNameSpace -> Bool
> :: RulesNameSpace -> RulesNameSpace -> Bool
$c>= :: RulesNameSpace -> RulesNameSpace -> Bool
>= :: RulesNameSpace -> RulesNameSpace -> Bool
$cmax :: RulesNameSpace -> RulesNameSpace -> RulesNameSpace
max :: RulesNameSpace -> RulesNameSpace -> RulesNameSpace
$cmin :: RulesNameSpace -> RulesNameSpace -> RulesNameSpace
min :: RulesNameSpace -> RulesNameSpace -> RulesNameSpace
Ord, (forall x. RulesNameSpace -> Rep RulesNameSpace x)
-> (forall x. Rep RulesNameSpace x -> RulesNameSpace)
-> Generic RulesNameSpace
forall x. Rep RulesNameSpace x -> RulesNameSpace
forall x. RulesNameSpace -> Rep RulesNameSpace x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RulesNameSpace -> Rep RulesNameSpace x
from :: forall x. RulesNameSpace -> Rep RulesNameSpace x
$cto :: forall x. Rep RulesNameSpace x -> RulesNameSpace
to :: forall x. Rep RulesNameSpace x -> RulesNameSpace
Generic)
  deriving anyclass (Get RulesNameSpace
[RulesNameSpace] -> Put
RulesNameSpace -> Put
(RulesNameSpace -> Put)
-> Get RulesNameSpace
-> ([RulesNameSpace] -> Put)
-> Binary RulesNameSpace
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: RulesNameSpace -> Put
put :: RulesNameSpace -> Put
$cget :: Get RulesNameSpace
get :: Get RulesNameSpace
$cputList :: [RulesNameSpace] -> Put
putList :: [RulesNameSpace] -> Put
Binary, Typeable RulesNameSpace
Tagged RulesNameSpace MD5
Typeable RulesNameSpace =>
(Proxy RulesNameSpace -> Structure)
-> Tagged RulesNameSpace MD5 -> Structured RulesNameSpace
Proxy RulesNameSpace -> Structure
forall a.
Typeable a =>
(Proxy a -> Structure) -> Tagged a MD5 -> Structured a
$cstructure :: Proxy RulesNameSpace -> Structure
structure :: Proxy RulesNameSpace -> Structure
$cstructureHash' :: Tagged RulesNameSpace MD5
structureHash' :: Tagged RulesNameSpace MD5
Structured)

-- | Internal function: create a 'RulesNameSpace' from a 'StaticPtrInfo'.
staticPtrNameSpace :: StaticPtrInfo -> RulesNameSpace
staticPtrNameSpace :: StaticPtrInfo -> RulesNameSpace
staticPtrNameSpace
  StaticPtrInfo
    { spInfoUnitId :: StaticPtrInfo -> String
spInfoUnitId = String
unitId
    , spInfoModuleName :: StaticPtrInfo -> String
spInfoModuleName = String
modName
    , spInfoSrcLoc :: StaticPtrInfo -> (Int, Int)
spInfoSrcLoc = (Int, Int)
srcLoc
    } =
    RulesNameSpace
      { rulesUnitId :: UnitId
rulesUnitId = String -> UnitId
mkUnitId String
unitId
      , rulesModuleName :: ModuleName
rulesModuleName = String -> ModuleName
forall a. IsString a => String -> a
fromString String
modName
      , rulesSrcLoc :: (Int, Int)
rulesSrcLoc = (Int, Int)
srcLoc
      }

-- | 'Rule's are defined with rich types by the package.
--
-- The build system only has a limited view of these; most data consists of
-- opaque 'ByteString's.
--
-- The 'Scope' data-type describes which side of this divide we are on.
data Scope
  = -- | User space (with rich types).
    User
  | -- | Build-system space (manipulation of raw data).
    System

data SScope (scope :: Scope) where
  SUser :: SScope User
  SSystem :: SScope System

type Rule = RuleData User
type RuleBinary = RuleData System

-- | A rule consists of:
--
--  - an action to run to execute the rule,
--  - a description of the rule inputs and outputs.
--
-- Use 'staticRule' or 'dynamicRule' to construct a rule, overriding specific
-- fields, rather than directly using the 'Rule' constructor.
data RuleData (scope :: Scope)
  = -- | Please use the 'staticRule' or 'dynamicRule' smart constructors
    -- instead of this constructor, in order to avoid relying on internal
    -- implementation details.
    Rule
    { forall (scope :: Scope). RuleData scope -> RuleCmds scope
ruleCommands :: !(RuleCmds scope)
    -- ^ To run this rule, which t'Command's should we execute?
    , forall (scope :: Scope). RuleData scope -> [Dependency]
staticDependencies :: ![Dependency]
    -- ^ Static dependencies of this rule.
    , forall (scope :: Scope). RuleData scope -> NonEmpty Location
results :: !(NE.NonEmpty Location)
    -- ^ Results of this rule.
    }
  deriving stock ((forall x. RuleData scope -> Rep (RuleData scope) x)
-> (forall x. Rep (RuleData scope) x -> RuleData scope)
-> Generic (RuleData scope)
forall x. Rep (RuleData scope) x -> RuleData scope
forall x. RuleData scope -> Rep (RuleData scope) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (scope :: Scope) x. Rep (RuleData scope) x -> RuleData scope
forall (scope :: Scope) x. RuleData scope -> Rep (RuleData scope) x
$cfrom :: forall (scope :: Scope) x. RuleData scope -> Rep (RuleData scope) x
from :: forall x. RuleData scope -> Rep (RuleData scope) x
$cto :: forall (scope :: Scope) x. Rep (RuleData scope) x -> RuleData scope
to :: forall x. Rep (RuleData scope) x -> RuleData scope
Generic)

deriving stock instance Show (RuleData User)
deriving stock instance Eq (RuleData User)
deriving stock instance Eq (RuleData System)
deriving anyclass instance Binary (RuleData User)
deriving anyclass instance Binary (RuleData System)

-- | Trimmed down 'Show' instance, mostly for error messages.
instance Show RuleBinary where
  show :: RuleBinary -> String
show (Rule{staticDependencies :: forall (scope :: Scope). RuleData scope -> [Dependency]
staticDependencies = [Dependency]
deps, results :: forall (scope :: Scope). RuleData scope -> NonEmpty Location
results = NonEmpty Location
reslts, ruleCommands :: forall (scope :: Scope). RuleData scope -> RuleCmds scope
ruleCommands = RuleCmds 'System
cmds}) =
    String
what String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Dependency] -> String
showDeps [Dependency]
deps String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" --> " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Location] -> String
forall a. Show a => a -> String
show (NonEmpty Location -> [Location]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty Location
reslts)
    where
      what :: String
what = case RuleCmds 'System
cmds of
        StaticRuleCommand{} -> String
"Rule"
        DynamicRuleCommands{} -> String
"Rule (dyn-deps)"
      showDeps :: [Dependency] -> String
      showDeps :: [Dependency] -> String
showDeps [Dependency]
ds = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ((Dependency -> String) -> [Dependency] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Dependency -> String
showDep [Dependency]
ds) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
      showDep :: Dependency -> String
      showDep :: Dependency -> String
showDep = \case
        RuleDependency (RuleOutput{outputOfRule :: RuleOutput -> RuleId
outputOfRule = RuleId
rId, outputIndex :: RuleOutput -> Word
outputIndex = Word
i}) ->
          String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ RuleId -> String
forall a. Show a => a -> String
show RuleId
rId String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word -> String
forall a. Show a => a -> String
show Word
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
        FileDependency Location
loc -> Location -> String
forall a. Show a => a -> String
show Location
loc

-- | A rule with static dependencies.
--
-- Prefer using this smart constructor instead of v'Rule' whenever possible.
staticRule
  :: forall arg
   . Typeable arg
  => Command arg (IO ())
  -> [Dependency]
  -> NE.NonEmpty Location
  -> Rule
staticRule :: forall arg.
Typeable arg =>
Command arg (IO ()) -> [Dependency] -> NonEmpty Location -> Rule
staticRule Command arg (IO ())
cmd [Dependency]
dep NonEmpty Location
res =
  Rule
    { ruleCommands :: RuleCmds 'User
ruleCommands =
        StaticRuleCommand
          { staticRuleCommand :: Command arg (IO ())
staticRuleCommand = Command arg (IO ())
cmd
          , staticRuleArgRep :: If ('User == 'System) SomeTypeRep (TypeRep arg)
staticRuleArgRep = forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Typeable.typeRep @arg
          }
    , staticDependencies :: [Dependency]
staticDependencies = [Dependency]
dep
    , results :: NonEmpty Location
results = NonEmpty Location
res
    }

-- | A rule with dynamic dependencies.
--
-- Prefer using this smart constructor instead of v'Rule' whenever possible.
dynamicRule
  :: forall depsArg depsRes arg
   . (Typeable depsArg, Typeable depsRes, Typeable arg)
  => StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
  -> Command depsArg (IO ([Dependency], depsRes))
  -> Command arg (depsRes -> IO ())
  -> [Dependency]
  -> NE.NonEmpty Location
  -> Rule
dynamicRule :: forall depsArg depsRes arg.
(Typeable depsArg, Typeable depsRes, Typeable arg) =>
StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Command depsArg (IO ([Dependency], depsRes))
-> Command arg (depsRes -> IO ())
-> [Dependency]
-> NonEmpty Location
-> Rule
dynamicRule StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
dict Command depsArg (IO ([Dependency], depsRes))
depsCmd Command arg (depsRes -> IO ())
action [Dependency]
dep NonEmpty Location
res =
  Rule
    { ruleCommands :: RuleCmds 'User
ruleCommands =
        DynamicRuleCommands
          { dynamicRuleInstances :: Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
dynamicRuleInstances = StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
forall fnTy. StaticPtr fnTy -> Static 'User fnTy
UserStatic StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
dict
          , dynamicDeps :: DynDepsCmd 'User depsArg depsRes
dynamicDeps = DynDepsCmd{dynDepsCmd :: Command depsArg (IO ([Dependency], depsRes))
dynDepsCmd = Command depsArg (IO ([Dependency], depsRes))
depsCmd}
          , dynamicRuleCommand :: Command arg (depsRes -> IO ())
dynamicRuleCommand = Command arg (depsRes -> IO ())
action
          , dynamicRuleTypeRep :: If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
dynamicRuleTypeRep = forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Typeable.typeRep @(depsArg, depsRes, arg)
          }
    , staticDependencies :: [Dependency]
staticDependencies = [Dependency]
dep
    , results :: NonEmpty Location
results = NonEmpty Location
res
    }

-----------------------
-- Rule inputs/outputs

-- | A (fully resolved) location of a dependency or result of a rule,
-- consisting of a base directory and of a file path relative to that base
-- directory path.
--
-- In practice, this will be something like @'Location' dir ('moduleNameSymbolicPath' mod <.> "hs")@,
-- where:
--
--  - for a file dependency, @dir@ is one of the Cabal search directories,
--  - for an output, @dir@ is a directory such as @autogenComponentModulesDir@
--    or @componentBuildDir@.
data Location where
  Location
    :: { ()
locationBaseDir :: !(SymbolicPath Pkg (Dir baseDir))
        -- ^ Base directory.
       , ()
locationRelPath :: !(RelativePath baseDir File)
        -- ^ File path relative to base directory (including file extension).
       }
    -> Location

instance Eq Location where
  Location SymbolicPath Pkg ('Dir baseDir)
b1 RelativePath baseDir 'File
l1 == :: Location -> Location -> Bool
== Location SymbolicPath Pkg ('Dir baseDir)
b2 RelativePath baseDir 'File
l2 =
    (SymbolicPath Pkg ('Dir baseDir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir baseDir)
b1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== SymbolicPath Pkg ('Dir baseDir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir baseDir)
b2)
      Bool -> Bool -> Bool
&& (RelativePath baseDir 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath RelativePath baseDir 'File
l1 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== RelativePath baseDir 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath RelativePath baseDir 'File
l2)
instance Ord Location where
  compare :: Location -> Location -> Ordering
compare (Location SymbolicPath Pkg ('Dir baseDir)
b1 RelativePath baseDir 'File
l1) (Location SymbolicPath Pkg ('Dir baseDir)
b2 RelativePath baseDir 'File
l2) =
    (String, String) -> (String, String) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare
      (SymbolicPath Pkg ('Dir baseDir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir baseDir)
b1, RelativePath baseDir 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath RelativePath baseDir 'File
l1)
      (SymbolicPath Pkg ('Dir baseDir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir baseDir)
b2, RelativePath baseDir 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath RelativePath baseDir 'File
l2)
instance Binary Location where
  put :: Location -> Put
put (Location SymbolicPath Pkg ('Dir baseDir)
base RelativePath baseDir 'File
loc) = (SymbolicPath Pkg ('Dir baseDir), RelativePath baseDir 'File)
-> Put
forall t. Binary t => t -> Put
put (SymbolicPath Pkg ('Dir baseDir)
base, RelativePath baseDir 'File
loc)
  get :: Get Location
get = SymbolicPath Pkg ('Dir Any) -> RelativePath Any 'File -> Location
forall baseDir.
SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> Location
Location (SymbolicPath Pkg ('Dir Any) -> RelativePath Any 'File -> Location)
-> Get (SymbolicPath Pkg ('Dir Any))
-> Get (RelativePath Any 'File -> Location)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get (SymbolicPath Pkg ('Dir Any))
forall t. Binary t => Get t
get Get (RelativePath Any 'File -> Location)
-> Get (RelativePath Any 'File) -> Get Location
forall a b. Get (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get (RelativePath Any 'File)
forall t. Binary t => Get t
get
instance Structured Location where
  structure :: Proxy Location -> Structure
structure Proxy Location
_ =
    SomeTypeRep -> TypeVersion -> String -> SopStructure -> Structure
Structure
      SomeTypeRep
tr
      TypeVersion
0
      (SomeTypeRep -> String
forall a. Show a => a -> String
show SomeTypeRep
tr)
      [
        ( String
"Location"
        ,
          [ Proxy (SymbolicPath Pkg ('Dir (Tok "baseDir"))) -> Structure
forall {k} (a :: k). Typeable a => Proxy a -> Structure
nominalStructure (Proxy (SymbolicPath Pkg ('Dir (Tok "baseDir"))) -> Structure)
-> Proxy (SymbolicPath Pkg ('Dir (Tok "baseDir"))) -> Structure
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(SymbolicPath Pkg (Dir (Tok "baseDir")))
          , Proxy (RelativePath (Tok "baseDir") 'File) -> Structure
forall {k} (a :: k). Typeable a => Proxy a -> Structure
nominalStructure (Proxy (RelativePath (Tok "baseDir") 'File) -> Structure)
-> Proxy (RelativePath (Tok "baseDir") 'File) -> Structure
forall a b. (a -> b) -> a -> b
$ forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @(RelativePath (Tok "baseDir") File)
          ]
        )
      ]
    where
      tr :: SomeTypeRep
tr = TypeRep Location -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
Typeable.SomeTypeRep (TypeRep Location -> SomeTypeRep)
-> TypeRep Location -> SomeTypeRep
forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Typeable.typeRep @Location

-- | Get a (relative or absolute) un-interpreted path to a 'Location'.
location :: Location -> SymbolicPath Pkg File
location :: Location -> SymbolicPath Pkg 'File
location (Location SymbolicPath Pkg ('Dir baseDir)
base RelativePath baseDir 'File
rel) = SymbolicPath Pkg ('Dir baseDir)
base SymbolicPath Pkg ('Dir baseDir)
-> RelativePath baseDir 'File -> SymbolicPath Pkg 'File
forall p q r. PathLike p q r => p -> q -> r
</> RelativePath baseDir 'File
rel

instance Show Location where
  showsPrec :: Int -> Location -> ShowS
showsPrec Int
p (Location SymbolicPath Pkg ('Dir baseDir)
base RelativePath baseDir 'File
rel) =
    Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString (ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SymbolicPath Pkg ('Dir baseDir) -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath SymbolicPath Pkg ('Dir baseDir)
base)
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" </> "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (ShowS
normalise ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ RelativePath baseDir 'File -> String
forall (allowAbsolute :: AllowAbsolute) from (to :: FileOrDir).
SymbolicPathX allowAbsolute from to -> String
getSymbolicPath RelativePath baseDir 'File
rel)

-- The reason for splitting it up this way is that some pre-processors don't
-- simply generate one output @.hs@ file from one input file, but have
-- dependencies on other generated files (notably @c2hs@, where building one
-- @.hs@ file may require reading other @.chi@ files, and then compiling the
-- @.hs@ file may require reading a generated @.h@ file).
-- In these cases, the generated files need to embed relative path names to each
-- other (eg the generated @.hs@ file mentions the @.h@ file in the FFI imports).
-- This path must be relative to the base directory where the generated files
-- are located; it cannot be relative to the top level of the build tree because
-- the compilers do not look for @.h@ files relative to there, ie we do not use
-- @-I .@, instead we use @-I dist/build@ (or whatever dist dir has been set
-- by the user).

-- | A dependency of a rule.
data Dependency
  = -- | A dependency on an output of another rule.
    RuleDependency !RuleOutput
  | -- | A direct dependency on a file at a particular location on disk.
    --
    -- This should not be used for files that are generated by other rules;
    -- use 'RuleDependency' instead.
    FileDependency !Location
  deriving stock (Int -> Dependency -> ShowS
[Dependency] -> ShowS
Dependency -> String
(Int -> Dependency -> ShowS)
-> (Dependency -> String)
-> ([Dependency] -> ShowS)
-> Show Dependency
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependency -> ShowS
showsPrec :: Int -> Dependency -> ShowS
$cshow :: Dependency -> String
show :: Dependency -> String
$cshowList :: [Dependency] -> ShowS
showList :: [Dependency] -> ShowS
Show, Dependency -> Dependency -> Bool
(Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Bool) -> Eq Dependency
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dependency -> Dependency -> Bool
== :: Dependency -> Dependency -> Bool
$c/= :: Dependency -> Dependency -> Bool
/= :: Dependency -> Dependency -> Bool
Eq, Eq Dependency
Eq Dependency =>
(Dependency -> Dependency -> Ordering)
-> (Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Bool)
-> (Dependency -> Dependency -> Dependency)
-> (Dependency -> Dependency -> Dependency)
-> Ord Dependency
Dependency -> Dependency -> Bool
Dependency -> Dependency -> Ordering
Dependency -> Dependency -> Dependency
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Dependency -> Dependency -> Ordering
compare :: Dependency -> Dependency -> Ordering
$c< :: Dependency -> Dependency -> Bool
< :: Dependency -> Dependency -> Bool
$c<= :: Dependency -> Dependency -> Bool
<= :: Dependency -> Dependency -> Bool
$c> :: Dependency -> Dependency -> Bool
> :: Dependency -> Dependency -> Bool
$c>= :: Dependency -> Dependency -> Bool
>= :: Dependency -> Dependency -> Bool
$cmax :: Dependency -> Dependency -> Dependency
max :: Dependency -> Dependency -> Dependency
$cmin :: Dependency -> Dependency -> Dependency
min :: Dependency -> Dependency -> Dependency
Ord, (forall x. Dependency -> Rep Dependency x)
-> (forall x. Rep Dependency x -> Dependency) -> Generic Dependency
forall x. Rep Dependency x -> Dependency
forall x. Dependency -> Rep Dependency x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Dependency -> Rep Dependency x
from :: forall x. Dependency -> Rep Dependency x
$cto :: forall x. Rep Dependency x -> Dependency
to :: forall x. Rep Dependency x -> Dependency
Generic)
  deriving anyclass (Get Dependency
[Dependency] -> Put
Dependency -> Put
(Dependency -> Put)
-> Get Dependency -> ([Dependency] -> Put) -> Binary Dependency
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: Dependency -> Put
put :: Dependency -> Put
$cget :: Get Dependency
get :: Get Dependency
$cputList :: [Dependency] -> Put
putList :: [Dependency] -> Put
Binary, Typeable Dependency
Tagged Dependency MD5
Typeable Dependency =>
(Proxy Dependency -> Structure)
-> Tagged Dependency MD5 -> Structured Dependency
Proxy Dependency -> Structure
forall a.
Typeable a =>
(Proxy a -> Structure) -> Tagged a MD5 -> Structured a
$cstructure :: Proxy Dependency -> Structure
structure :: Proxy Dependency -> Structure
$cstructureHash' :: Tagged Dependency MD5
structureHash' :: Tagged Dependency MD5
Structured)

-- | A reference to an output of another rule.
data RuleOutput = RuleOutput
  { RuleOutput -> RuleId
outputOfRule :: !RuleId
  -- ^ which rule's outputs are we referring to?
  , RuleOutput -> Word
outputIndex :: !Word
  -- ^ which particular output of that rule?
  }
  deriving stock (Int -> RuleOutput -> ShowS
[RuleOutput] -> ShowS
RuleOutput -> String
(Int -> RuleOutput -> ShowS)
-> (RuleOutput -> String)
-> ([RuleOutput] -> ShowS)
-> Show RuleOutput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RuleOutput -> ShowS
showsPrec :: Int -> RuleOutput -> ShowS
$cshow :: RuleOutput -> String
show :: RuleOutput -> String
$cshowList :: [RuleOutput] -> ShowS
showList :: [RuleOutput] -> ShowS
Show, RuleOutput -> RuleOutput -> Bool
(RuleOutput -> RuleOutput -> Bool)
-> (RuleOutput -> RuleOutput -> Bool) -> Eq RuleOutput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RuleOutput -> RuleOutput -> Bool
== :: RuleOutput -> RuleOutput -> Bool
$c/= :: RuleOutput -> RuleOutput -> Bool
/= :: RuleOutput -> RuleOutput -> Bool
Eq, Eq RuleOutput
Eq RuleOutput =>
(RuleOutput -> RuleOutput -> Ordering)
-> (RuleOutput -> RuleOutput -> Bool)
-> (RuleOutput -> RuleOutput -> Bool)
-> (RuleOutput -> RuleOutput -> Bool)
-> (RuleOutput -> RuleOutput -> Bool)
-> (RuleOutput -> RuleOutput -> RuleOutput)
-> (RuleOutput -> RuleOutput -> RuleOutput)
-> Ord RuleOutput
RuleOutput -> RuleOutput -> Bool
RuleOutput -> RuleOutput -> Ordering
RuleOutput -> RuleOutput -> RuleOutput
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: RuleOutput -> RuleOutput -> Ordering
compare :: RuleOutput -> RuleOutput -> Ordering
$c< :: RuleOutput -> RuleOutput -> Bool
< :: RuleOutput -> RuleOutput -> Bool
$c<= :: RuleOutput -> RuleOutput -> Bool
<= :: RuleOutput -> RuleOutput -> Bool
$c> :: RuleOutput -> RuleOutput -> Bool
> :: RuleOutput -> RuleOutput -> Bool
$c>= :: RuleOutput -> RuleOutput -> Bool
>= :: RuleOutput -> RuleOutput -> Bool
$cmax :: RuleOutput -> RuleOutput -> RuleOutput
max :: RuleOutput -> RuleOutput -> RuleOutput
$cmin :: RuleOutput -> RuleOutput -> RuleOutput
min :: RuleOutput -> RuleOutput -> RuleOutput
Ord, (forall x. RuleOutput -> Rep RuleOutput x)
-> (forall x. Rep RuleOutput x -> RuleOutput) -> Generic RuleOutput
forall x. Rep RuleOutput x -> RuleOutput
forall x. RuleOutput -> Rep RuleOutput x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RuleOutput -> Rep RuleOutput x
from :: forall x. RuleOutput -> Rep RuleOutput x
$cto :: forall x. Rep RuleOutput x -> RuleOutput
to :: forall x. Rep RuleOutput x -> RuleOutput
Generic)
  deriving anyclass (Get RuleOutput
[RuleOutput] -> Put
RuleOutput -> Put
(RuleOutput -> Put)
-> Get RuleOutput -> ([RuleOutput] -> Put) -> Binary RuleOutput
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: RuleOutput -> Put
put :: RuleOutput -> Put
$cget :: Get RuleOutput
get :: Get RuleOutput
$cputList :: [RuleOutput] -> Put
putList :: [RuleOutput] -> Put
Binary, Typeable RuleOutput
Tagged RuleOutput MD5
Typeable RuleOutput =>
(Proxy RuleOutput -> Structure)
-> Tagged RuleOutput MD5 -> Structured RuleOutput
Proxy RuleOutput -> Structure
forall a.
Typeable a =>
(Proxy a -> Structure) -> Tagged a MD5 -> Structured a
$cstructure :: Proxy RuleOutput -> Structure
structure :: Proxy RuleOutput -> Structure
$cstructureHash' :: Tagged RuleOutput MD5
structureHash' :: Tagged RuleOutput MD5
Structured)

---------
-- Rules

-- | Monad for constructing rules.
type RulesM a = RulesT IO a

-- | The environment within the monadic API.
data RulesEnv = RulesEnv
  { RulesEnv -> Verbosity
rulesEnvVerbosity :: !Verbosity
  , RulesEnv -> RulesNameSpace
rulesEnvNameSpace :: !RulesNameSpace
  }

-- | Monad transformer for defining rules. Usually wraps the 'IO' monad,
-- allowing @IO@ actions to be performed using @liftIO@.
newtype RulesT m a = RulesT
  { forall (m :: * -> *) a.
RulesT m a
-> ReaderT
     RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
runRulesT
      :: Reader.ReaderT
          RulesEnv
          ( State.StateT
              (Map RuleId Rule)
              (Writer.WriterT [MonitorFilePath] m)
          )
          a
  }
  deriving newtype ((forall a b. (a -> b) -> RulesT m a -> RulesT m b)
-> (forall a b. a -> RulesT m b -> RulesT m a)
-> Functor (RulesT m)
forall a b. a -> RulesT m b -> RulesT m a
forall a b. (a -> b) -> RulesT m a -> RulesT m b
forall (m :: * -> *) a b.
Functor m =>
a -> RulesT m b -> RulesT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RulesT m a -> RulesT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RulesT m a -> RulesT m b
fmap :: forall a b. (a -> b) -> RulesT m a -> RulesT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RulesT m b -> RulesT m a
<$ :: forall a b. a -> RulesT m b -> RulesT m a
Functor, Functor (RulesT m)
Functor (RulesT m) =>
(forall a. a -> RulesT m a)
-> (forall a b. RulesT m (a -> b) -> RulesT m a -> RulesT m b)
-> (forall a b c.
    (a -> b -> c) -> RulesT m a -> RulesT m b -> RulesT m c)
-> (forall a b. RulesT m a -> RulesT m b -> RulesT m b)
-> (forall a b. RulesT m a -> RulesT m b -> RulesT m a)
-> Applicative (RulesT m)
forall a. a -> RulesT m a
forall a b. RulesT m a -> RulesT m b -> RulesT m a
forall a b. RulesT m a -> RulesT m b -> RulesT m b
forall a b. RulesT m (a -> b) -> RulesT m a -> RulesT m b
forall a b c.
(a -> b -> c) -> RulesT m a -> RulesT m b -> RulesT m c
forall (m :: * -> *). Monad m => Functor (RulesT m)
forall (m :: * -> *) a. Monad m => a -> RulesT m a
forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> RulesT m b -> RulesT m a
forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> RulesT m b -> RulesT m b
forall (m :: * -> *) a b.
Monad m =>
RulesT m (a -> b) -> RulesT m a -> RulesT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> RulesT m a -> RulesT m b -> RulesT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall (m :: * -> *) a. Monad m => a -> RulesT m a
pure :: forall a. a -> RulesT m a
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
RulesT m (a -> b) -> RulesT m a -> RulesT m b
<*> :: forall a b. RulesT m (a -> b) -> RulesT m a -> RulesT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> RulesT m a -> RulesT m b -> RulesT m c
liftA2 :: forall a b c.
(a -> b -> c) -> RulesT m a -> RulesT m b -> RulesT m c
$c*> :: forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> RulesT m b -> RulesT m b
*> :: forall a b. RulesT m a -> RulesT m b -> RulesT m b
$c<* :: forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> RulesT m b -> RulesT m a
<* :: forall a b. RulesT m a -> RulesT m b -> RulesT m a
Applicative, Applicative (RulesT m)
Applicative (RulesT m) =>
(forall a b. RulesT m a -> (a -> RulesT m b) -> RulesT m b)
-> (forall a b. RulesT m a -> RulesT m b -> RulesT m b)
-> (forall a. a -> RulesT m a)
-> Monad (RulesT m)
forall a. a -> RulesT m a
forall a b. RulesT m a -> RulesT m b -> RulesT m b
forall a b. RulesT m a -> (a -> RulesT m b) -> RulesT m b
forall (m :: * -> *). Monad m => Applicative (RulesT m)
forall (m :: * -> *) a. Monad m => a -> RulesT m a
forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> RulesT m b -> RulesT m b
forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> (a -> RulesT m b) -> RulesT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> (a -> RulesT m b) -> RulesT m b
>>= :: forall a b. RulesT m a -> (a -> RulesT m b) -> RulesT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
RulesT m a -> RulesT m b -> RulesT m b
>> :: forall a b. RulesT m a -> RulesT m b -> RulesT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> RulesT m a
return :: forall a. a -> RulesT m a
Monad, Monad (RulesT m)
Monad (RulesT m) =>
(forall a. IO a -> RulesT m a) -> MonadIO (RulesT m)
forall a. IO a -> RulesT m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (RulesT m)
forall (m :: * -> *) a. MonadIO m => IO a -> RulesT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> RulesT m a
liftIO :: forall a. IO a -> RulesT m a
MonadIO, Monad (RulesT m)
Monad (RulesT m) =>
(forall a. (a -> RulesT m a) -> RulesT m a) -> MonadFix (RulesT m)
forall a. (a -> RulesT m a) -> RulesT m a
forall (m :: * -> *).
Monad m =>
(forall a. (a -> m a) -> m a) -> MonadFix m
forall (m :: * -> *). MonadFix m => Monad (RulesT m)
forall (m :: * -> *) a.
MonadFix m =>
(a -> RulesT m a) -> RulesT m a
$cmfix :: forall (m :: * -> *) a.
MonadFix m =>
(a -> RulesT m a) -> RulesT m a
mfix :: forall a. (a -> RulesT m a) -> RulesT m a
MonadFix)

instance MonadTrans RulesT where
  lift :: forall (m :: * -> *) a. Monad m => m a -> RulesT m a
lift = ReaderT
  RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
-> RulesT m a
forall (m :: * -> *) a.
ReaderT
  RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
-> RulesT m a
RulesT (ReaderT
   RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
 -> RulesT m a)
-> (m a
    -> ReaderT
         RulesEnv
         (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
         a)
-> m a
-> RulesT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) a
-> ReaderT
     RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
forall (m :: * -> *) a. Monad m => m a -> ReaderT RulesEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) a
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m))
      a)
-> (m a
    -> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) a)
-> m a
-> ReaderT
     RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT [MonitorFilePath] m a
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (Map RuleId Rule) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT [MonitorFilePath] m a
 -> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) a)
-> (m a -> WriterT [MonitorFilePath] m a)
-> m a
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> WriterT [MonitorFilePath] m a
forall (m :: * -> *) a.
Monad m =>
m a -> WriterT [MonitorFilePath] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

-- | A collection of t'Rule's.
--
-- Use the 'rules' smart constructor instead of directly using the v'Rules'
-- constructor.
--
--   - Rules are registered using 'registerRule',
--   - Monitored files or directories are declared using 'addRuleMonitors';
--     a change in these will trigger the recomputation of all rules.
--
-- The @env@ type parameter represents an extra argument, which usually
-- consists of information known to Cabal such as 'LocalBuildInfo' and
-- 'ComponentLocalBuildInfo'.
newtype Rules env = Rules {forall env. Rules env -> env -> RulesM ()
runRules :: env -> RulesM ()}

-- | __Warning__: this 'Semigroup' instance is not commutative.
instance Semigroup (Rules env) where
  (Rules env -> RulesM ()
rs1) <> :: Rules env -> Rules env -> Rules env
<> (Rules env -> RulesM ()
rs2) =
    (env -> RulesM ()) -> Rules env
forall env. (env -> RulesM ()) -> Rules env
Rules ((env -> RulesM ()) -> Rules env)
-> (env -> RulesM ()) -> Rules env
forall a b. (a -> b) -> a -> b
$ \env
inputs -> do
      ()
y1 <- env -> RulesM ()
rs1 env
inputs
      ()
y2 <- env -> RulesM ()
rs2 env
inputs
      () -> RulesM ()
forall a. a -> RulesT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> RulesM ()) -> () -> RulesM ()
forall a b. (a -> b) -> a -> b
$ ()
y1 () -> () -> ()
forall a. Semigroup a => a -> a -> a
<> ()
y2

instance Monoid (Rules env) where
  mempty :: Rules env
mempty = (env -> RulesM ()) -> Rules env
forall env. (env -> RulesM ()) -> Rules env
Rules ((env -> RulesM ()) -> Rules env)
-> (env -> RulesM ()) -> Rules env
forall a b. (a -> b) -> a -> b
$ RulesM () -> env -> RulesM ()
forall a b. a -> b -> a
const RulesM ()
noRules

-- | An empty collection of rules.
noRules :: RulesM ()
noRules :: RulesM ()
noRules = () -> RulesM ()
forall a. a -> RulesT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Construct a collection of rules with a given label.
--
-- A label for the rules can be constructed using the @static@ keyword,
-- using the @StaticPointers@ extension.
-- NB: separate calls to 'rules' should have different labels.
--
-- Example usage:
--
-- > myRules :: Rules env
-- > myRules = rules (static ()) $ \ env -> do { .. } -- use the monadic API here
rules
  :: StaticPtr label
  -- ^ unique label for this collection of rules
  -> (env -> RulesM ())
  -- ^ the computation of rules
  -> Rules env
rules :: forall label env.
StaticPtr label -> (env -> RulesM ()) -> Rules env
rules StaticPtr label
label = RulesNameSpace -> (env -> RulesM ()) -> Rules env
forall env. RulesNameSpace -> (env -> RulesM ()) -> Rules env
rulesInNameSpace (StaticPtrInfo -> RulesNameSpace
staticPtrNameSpace (StaticPtrInfo -> RulesNameSpace)
-> StaticPtrInfo -> RulesNameSpace
forall a b. (a -> b) -> a -> b
$ StaticPtr label -> StaticPtrInfo
forall a. StaticPtr a -> StaticPtrInfo
staticPtrInfo StaticPtr label
label)

-- | Internal function to create a collection of rules.
--
-- API users should go through the 'rules' function instead.
rulesInNameSpace
  :: RulesNameSpace
  -- ^ rule namespace
  -> (env -> RulesM ())
  -- ^ the computation of rules
  -> Rules env
rulesInNameSpace :: forall env. RulesNameSpace -> (env -> RulesM ()) -> Rules env
rulesInNameSpace RulesNameSpace
nameSpace env -> RulesM ()
f =
  (env -> RulesM ()) -> Rules env
forall env. (env -> RulesM ()) -> Rules env
Rules ((env -> RulesM ()) -> Rules env)
-> (env -> RulesM ()) -> Rules env
forall a b. (a -> b) -> a -> b
$ \env
env -> ReaderT
  RulesEnv
  (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
  ()
-> RulesM ()
forall (m :: * -> *) a.
ReaderT
  RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
-> RulesT m a
RulesT (ReaderT
   RulesEnv
   (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
   ()
 -> RulesM ())
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
-> RulesM ()
forall a b. (a -> b) -> a -> b
$ do
    (RulesEnv -> RulesEnv)
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
Reader.withReaderT (\RulesEnv
rulesEnv -> RulesEnv
rulesEnv{rulesEnvNameSpace = nameSpace}) (ReaderT
   RulesEnv
   (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
   ()
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
      ())
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall a b. (a -> b) -> a -> b
$
      RulesM ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall (m :: * -> *) a.
RulesT m a
-> ReaderT
     RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
runRulesT (RulesM ()
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
      ())
-> RulesM ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall a b. (a -> b) -> a -> b
$
        env -> RulesM ()
f env
env

-- | Internal function: run the monadic 'Rules' computations in order
-- to obtain all the 'Rule's with their 'RuleId's.
computeRules
  :: Verbosity
  -> env
  -> Rules env
  -> IO (Map RuleId Rule, [MonitorFilePath])
computeRules :: forall env.
Verbosity
-> env -> Rules env -> IO (Map RuleId Rule, [MonitorFilePath])
computeRules Verbosity
verbosity env
inputs (Rules env -> RulesM ()
rs) = do
  -- Bogus namespace to start with. This will be the first thing
  -- to be set when users use the 'rules' smart constructor.
  let noNameSpace :: RulesNameSpace
noNameSpace =
        RulesNameSpace
          { rulesUnitId :: UnitId
rulesUnitId = String -> UnitId
mkUnitId String
""
          , rulesModuleName :: ModuleName
rulesModuleName = String -> ModuleName
forall a. IsString a => String -> a
fromString String
""
          , rulesSrcLoc :: (Int, Int)
rulesSrcLoc = (Int
0, Int
0)
          }
      env0 :: RulesEnv
env0 =
        RulesEnv
          { rulesEnvVerbosity :: Verbosity
rulesEnvVerbosity = Verbosity
verbosity
          , rulesEnvNameSpace :: RulesNameSpace
rulesEnvNameSpace = RulesNameSpace
noNameSpace
          }
  WriterT [MonitorFilePath] IO (Map RuleId Rule)
-> IO (Map RuleId Rule, [MonitorFilePath])
forall w (m :: * -> *) a. Monoid w => WriterT w m a -> m (a, w)
Writer.runWriterT (WriterT [MonitorFilePath] IO (Map RuleId Rule)
 -> IO (Map RuleId Rule, [MonitorFilePath]))
-> WriterT [MonitorFilePath] IO (Map RuleId Rule)
-> IO (Map RuleId Rule, [MonitorFilePath])
forall a b. (a -> b) -> a -> b
$
    (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
-> Map RuleId Rule
-> WriterT [MonitorFilePath] IO (Map RuleId Rule)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
`State.execStateT` Map RuleId Rule
forall k a. Map k a
Map.empty) (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
 -> WriterT [MonitorFilePath] IO (Map RuleId Rule))
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
-> WriterT [MonitorFilePath] IO (Map RuleId Rule)
forall a b. (a -> b) -> a -> b
$
      (ReaderT
  RulesEnv
  (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
  ()
-> RulesEnv
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`Reader.runReaderT` RulesEnv
env0) (ReaderT
   RulesEnv
   (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
   ()
 -> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ())
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
-> StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO) ()
forall a b. (a -> b) -> a -> b
$
        RulesM ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall (m :: * -> *) a.
RulesT m a
-> ReaderT
     RulesEnv (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] m)) a
runRulesT (RulesM ()
 -> ReaderT
      RulesEnv
      (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
      ())
-> RulesM ()
-> ReaderT
     RulesEnv
     (StateT (Map RuleId Rule) (WriterT [MonitorFilePath] IO))
     ()
forall a b. (a -> b) -> a -> b
$
          env -> RulesM ()
rs env
inputs

------------
-- Commands

-- | A static pointer (in user scope) or its key (in system scope).
data family Static (scope :: Scope) :: Hs.Type -> Hs.Type

newtype instance Static User fnTy = UserStatic {forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr :: StaticPtr fnTy}
newtype instance Static System fnTy = SystemStatic {forall fnTy. Static 'System fnTy -> MD5
userStaticKey :: StaticKey}
  deriving newtype (Static 'System fnTy -> Static 'System fnTy -> Bool
(Static 'System fnTy -> Static 'System fnTy -> Bool)
-> (Static 'System fnTy -> Static 'System fnTy -> Bool)
-> Eq (Static 'System fnTy)
forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
== :: Static 'System fnTy -> Static 'System fnTy -> Bool
$c/= :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
/= :: Static 'System fnTy -> Static 'System fnTy -> Bool
Eq, Eq (Static 'System fnTy)
Eq (Static 'System fnTy) =>
(Static 'System fnTy -> Static 'System fnTy -> Ordering)
-> (Static 'System fnTy -> Static 'System fnTy -> Bool)
-> (Static 'System fnTy -> Static 'System fnTy -> Bool)
-> (Static 'System fnTy -> Static 'System fnTy -> Bool)
-> (Static 'System fnTy -> Static 'System fnTy -> Bool)
-> (Static 'System fnTy
    -> Static 'System fnTy -> Static 'System fnTy)
-> (Static 'System fnTy
    -> Static 'System fnTy -> Static 'System fnTy)
-> Ord (Static 'System fnTy)
Static 'System fnTy -> Static 'System fnTy -> Bool
Static 'System fnTy -> Static 'System fnTy -> Ordering
Static 'System fnTy -> Static 'System fnTy -> Static 'System fnTy
forall fnTy. Eq (Static 'System fnTy)
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Ordering
forall fnTy.
Static 'System fnTy -> Static 'System fnTy -> Static 'System fnTy
$ccompare :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Ordering
compare :: Static 'System fnTy -> Static 'System fnTy -> Ordering
$c< :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
< :: Static 'System fnTy -> Static 'System fnTy -> Bool
$c<= :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
<= :: Static 'System fnTy -> Static 'System fnTy -> Bool
$c> :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
> :: Static 'System fnTy -> Static 'System fnTy -> Bool
$c>= :: forall fnTy. Static 'System fnTy -> Static 'System fnTy -> Bool
>= :: Static 'System fnTy -> Static 'System fnTy -> Bool
$cmax :: forall fnTy.
Static 'System fnTy -> Static 'System fnTy -> Static 'System fnTy
max :: Static 'System fnTy -> Static 'System fnTy -> Static 'System fnTy
$cmin :: forall fnTy.
Static 'System fnTy -> Static 'System fnTy -> Static 'System fnTy
min :: Static 'System fnTy -> Static 'System fnTy -> Static 'System fnTy
Ord, Int -> Static 'System fnTy -> ShowS
[Static 'System fnTy] -> ShowS
Static 'System fnTy -> String
(Int -> Static 'System fnTy -> ShowS)
-> (Static 'System fnTy -> String)
-> ([Static 'System fnTy] -> ShowS)
-> Show (Static 'System fnTy)
forall fnTy. Int -> Static 'System fnTy -> ShowS
forall fnTy. [Static 'System fnTy] -> ShowS
forall fnTy. Static 'System fnTy -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall fnTy. Int -> Static 'System fnTy -> ShowS
showsPrec :: Int -> Static 'System fnTy -> ShowS
$cshow :: forall fnTy. Static 'System fnTy -> String
show :: Static 'System fnTy -> String
$cshowList :: forall fnTy. [Static 'System fnTy] -> ShowS
showList :: [Static 'System fnTy] -> ShowS
Show, Get (Static 'System fnTy)
[Static 'System fnTy] -> Put
Static 'System fnTy -> Put
(Static 'System fnTy -> Put)
-> Get (Static 'System fnTy)
-> ([Static 'System fnTy] -> Put)
-> Binary (Static 'System fnTy)
forall fnTy. Get (Static 'System fnTy)
forall fnTy. [Static 'System fnTy] -> Put
forall fnTy. Static 'System fnTy -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: forall fnTy. Static 'System fnTy -> Put
put :: Static 'System fnTy -> Put
$cget :: forall fnTy. Get (Static 'System fnTy)
get :: Get (Static 'System fnTy)
$cputList :: forall fnTy. [Static 'System fnTy] -> Put
putList :: [Static 'System fnTy] -> Put
Binary)

systemStatic :: Static User fnTy -> Static System fnTy
systemStatic :: forall fnTy. Static 'User fnTy -> Static 'System fnTy
systemStatic (UserStatic StaticPtr fnTy
ptr) = MD5 -> Static 'System fnTy
forall fnTy. MD5 -> Static 'System fnTy
SystemStatic (StaticPtr fnTy -> MD5
forall a. StaticPtr a -> MD5
staticKey StaticPtr fnTy
ptr)

instance Show (Static User fnTy) where
  showsPrec :: Int -> Static 'User fnTy -> ShowS
showsPrec Int
p Static 'User fnTy
ptr = Int -> Static 'System fnTy -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p (Static 'User fnTy -> Static 'System fnTy
forall fnTy. Static 'User fnTy -> Static 'System fnTy
systemStatic Static 'User fnTy
ptr)
instance Eq (Static User fnTy) where
  == :: Static 'User fnTy -> Static 'User fnTy -> Bool
(==) = Static 'System fnTy -> Static 'System fnTy -> Bool
forall a. Eq a => a -> a -> Bool
(==) (Static 'System fnTy -> Static 'System fnTy -> Bool)
-> (Static 'User fnTy -> Static 'System fnTy)
-> Static 'User fnTy
-> Static 'User fnTy
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Static 'User fnTy -> Static 'System fnTy
forall fnTy. Static 'User fnTy -> Static 'System fnTy
systemStatic
instance Ord (Static User fnTy) where
  compare :: Static 'User fnTy -> Static 'User fnTy -> Ordering
compare = Static 'System fnTy -> Static 'System fnTy -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Static 'System fnTy -> Static 'System fnTy -> Ordering)
-> (Static 'User fnTy -> Static 'System fnTy)
-> Static 'User fnTy
-> Static 'User fnTy
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Static 'User fnTy -> Static 'System fnTy
forall fnTy. Static 'User fnTy -> Static 'System fnTy
systemStatic
instance Binary (Static User fnTy) where
  put :: Static 'User fnTy -> Put
put = Static 'System fnTy -> Put
forall t. Binary t => t -> Put
put (Static 'System fnTy -> Put)
-> (Static 'User fnTy -> Static 'System fnTy)
-> Static 'User fnTy
-> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Static 'User fnTy -> Static 'System fnTy
forall fnTy. Static 'User fnTy -> Static 'System fnTy
systemStatic
  get :: Get (Static 'User fnTy)
get = do
    MD5
ptrKey <- forall t. Binary t => Get t
get @StaticKey
    case IO (Maybe (StaticPtr fnTy)) -> Maybe (StaticPtr fnTy)
forall a. IO a -> a
unsafePerformIO (IO (Maybe (StaticPtr fnTy)) -> Maybe (StaticPtr fnTy))
-> IO (Maybe (StaticPtr fnTy)) -> Maybe (StaticPtr fnTy)
forall a b. (a -> b) -> a -> b
$ MD5 -> IO (Maybe (StaticPtr fnTy))
forall a. MD5 -> IO (Maybe (StaticPtr a))
unsafeLookupStaticPtr MD5
ptrKey of
      Just StaticPtr fnTy
ptr -> Static 'User fnTy -> Get (Static 'User fnTy)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (Static 'User fnTy -> Get (Static 'User fnTy))
-> Static 'User fnTy -> Get (Static 'User fnTy)
forall a b. (a -> b) -> a -> b
$ StaticPtr fnTy -> Static 'User fnTy
forall fnTy. StaticPtr fnTy -> Static 'User fnTy
UserStatic StaticPtr fnTy
ptr
      Maybe (StaticPtr fnTy)
Nothing ->
        String -> Get (Static 'User fnTy)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (Static 'User fnTy))
-> String -> Get (Static 'User fnTy)
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines
            [ String
"Failed to look up static pointer key for action."
            , String
"NB: Binary instances for 'User' types cannot be used in external executables."
            ]

-- | A command consists of a statically-known action together with a
-- (possibly dynamic) argument to that action.
--
-- For example, the action can consist of running an executable
-- (such as @happy@ or @c2hs@), while the argument consists of the variable
-- component of the command, e.g. the specific file to run @happy@ on.
type Command = CommandData User

-- | Internal datatype used for commands, both for the Hooks API ('Command')
-- and for the build system.
data CommandData (scope :: Scope) (arg :: Hs.Type) (res :: Hs.Type) = Command
  { forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr :: !(Static scope (arg -> res))
  -- ^ The (statically-known) action to execute.
  , forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg :: !(ScopedArgument scope arg)
  -- ^ The (possibly dynamic) argument to pass to the action.
  , forall (scope :: Scope) arg res.
CommandData scope arg res
-> Static scope (Dict (Binary arg, Show arg))
cmdInstances :: !(Static scope (Dict (Binary arg, Show arg)))
  -- ^ Static evidence that the argument can be serialised and deserialised.
  }

-- | Construct a command.
--
-- Prefer using this smart constructor instead of v'Command' whenever possible.
mkCommand
  :: forall arg res
   . StaticPtr (Dict (Binary arg, Show arg))
  -> StaticPtr (arg -> res)
  -> arg
  -> Command arg res
mkCommand :: forall arg res.
StaticPtr (Dict (Binary arg, Show arg))
-> StaticPtr (arg -> res) -> arg -> Command arg res
mkCommand StaticPtr (Dict (Binary arg, Show arg))
dict StaticPtr (arg -> res)
actionPtr arg
arg =
  Command
    { actionPtr :: Static 'User (arg -> res)
actionPtr = StaticPtr (arg -> res) -> Static 'User (arg -> res)
forall fnTy. StaticPtr fnTy -> Static 'User fnTy
UserStatic StaticPtr (arg -> res)
actionPtr
    , actionArg :: ScopedArgument 'User arg
actionArg = arg -> ScopedArgument 'User arg
forall (scope :: Scope) arg. arg -> ScopedArgument scope arg
ScopedArgument arg
arg
    , cmdInstances :: Static 'User (Dict (Binary arg, Show arg))
cmdInstances = StaticPtr (Dict (Binary arg, Show arg))
-> Static 'User (Dict (Binary arg, Show arg))
forall fnTy. StaticPtr fnTy -> Static 'User fnTy
UserStatic StaticPtr (Dict (Binary arg, Show arg))
dict
    }

-- | Run a 'Command'.
runCommand :: Command args res -> res
runCommand :: forall args res. Command args res -> res
runCommand (Command{actionPtr :: forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr = UserStatic StaticPtr (args -> res)
ptr, actionArg :: forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg = ScopedArgument args
arg}) =
  StaticPtr (args -> res) -> args -> res
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (args -> res)
ptr args
arg

-- | Commands to execute a rule:
--
--   - for a rule with static dependencies, a single command,
--   - for a rule with dynamic dependencies, a command for computing dynamic
--     dependencies, and a command for executing the rule.
data
  RuleCommands
    (scope :: Scope)
    (deps :: Scope -> Hs.Type -> Hs.Type -> Hs.Type)
    (ruleCmd :: Scope -> Hs.Type -> Hs.Type -> Hs.Type)
  where
  -- | A rule with statically-known dependencies.
  StaticRuleCommand
    :: forall arg deps ruleCmd scope
     . If
        (scope == System)
        (arg ~ LBS.ByteString)
        (() :: Hs.Constraint)
    => { ()
staticRuleCommand :: !(ruleCmd scope arg (IO ()))
        -- ^ The command to execute the rule.
       , ()
staticRuleArgRep :: !(If (scope == System) Typeable.SomeTypeRep (Typeable.TypeRep arg))
        -- ^ A 'TypeRep' for 'arg'.
       }
    -> RuleCommands scope deps ruleCmd
  DynamicRuleCommands
    :: forall depsArg depsRes arg deps ruleCmd scope
     . If
        (scope == System)
        (depsArg ~ LBS.ByteString, depsRes ~ LBS.ByteString, arg ~ LBS.ByteString)
        (() :: Hs.Constraint)
    => { ()
dynamicRuleInstances :: !(Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes)))
        -- ^ A rule with dynamic dependencies, which consists of two parts:
        --
        --  - a dynamic dependency computation, that returns additional edges to
        --    be added to the build graph together with an additional piece of data,
        --  - the command to execute the rule itself, which receives the additional
        --    piece of data returned by the dependency computation.
       , -- \^ Static evidence used for serialisation, in order to pass the result
         -- of the dependency computation to the main rule action.
         ()
dynamicDeps :: !(deps scope depsArg depsRes)
        -- ^ A dynamic dependency computation. The resulting dependencies
        -- will be injected into the build graph, and the result of the computation
        -- will be passed on to the command that executes the rule.
       , ()
dynamicRuleCommand :: !(ruleCmd scope arg (depsRes -> IO ()))
        -- ^ The command to execute the rule. It will receive the result
        -- of the dynamic dependency computation.
       , ()
dynamicRuleTypeRep
          :: !( If
                  (scope == System)
                  Typeable.SomeTypeRep
                  (Typeable.TypeRep (depsArg, depsRes, arg))
              )
        -- ^ A 'TypeRep' for the triple @(depsArg,depsRes,arg)@.
       }
    -> RuleCommands scope deps ruleCmd

{- Note [Hooks Binary instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Hooks API is strongly typed: users can declare rule commands with varying
types, e.g.

  staticRule
  :: forall arg
   . Typeable arg
  => Command arg (IO ())
  -> [Dependency]
  -> NE.NonEmpty Location
  -> Rule

allows a user to declare a 'Command' that receives an argument of type 'arg'
of their choosing.

This all makes sense within the Hooks API, but when communicating with an
external build system (such as cabal-install or HLS), these arguments are
treated as opaque blobs of data (in particular if the Hooks are compiled into
a separate executable, then the static pointers that contain the relevant
instances for these user-chosen types can only be dereferenced from within that
executable, and not on the side of the build system).

This means that, to enable Hooks to be communicated between the package and the
build system, we need:

  1. Two representations of rules: one for the package author using the Hooks API,
     and one for the build system.
  2. Compatibility in the 'Binary' instances for these two types. One needs to be
     able to serialise a 'User'-side 'Rule', and de-serialise it on the build system
     into a 'System'-side 'Rule' which contains some opaque bits of data, and
     vice-versa.

(1) is achieved using the 'Scope' parameter to the 'RuleData' datatype.
@Rule = RuleData User@ is the API-side representation, whereas
@RuleBinary = RuleData System@ is the build-system-side representation.

For (2), note that when we serialise a value of known type and known size, e.g.
an 'Int64', we are nevertheless required to also serialise its size. This is because,
on the build-system side, we don't have access to any of the types, and thus don't know
how much to read in order to reconstruct the associated opaque 'ByteString'.
To ensure we always serialise/deserialise including the length of the data,
the 'ScopedArgument' newtype is used, with a custom 'Binary' instance that always
incldues the length. We use this newtype:

  - in the definition of 'CommandData', for arguments to rules,
  - in the definition of 'DepsRes', for the result of dynamic dependency computations.
-}

newtype ScopedArgument (scope :: Scope) arg = ScopedArgument {forall (scope :: Scope) arg. ScopedArgument scope arg -> arg
getArg :: arg}
  deriving newtype (ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
(ScopedArgument scope arg -> ScopedArgument scope arg -> Bool)
-> (ScopedArgument scope arg -> ScopedArgument scope arg -> Bool)
-> Eq (ScopedArgument scope arg)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (scope :: Scope) arg.
Eq arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
$c== :: forall (scope :: Scope) arg.
Eq arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
== :: ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
$c/= :: forall (scope :: Scope) arg.
Eq arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
/= :: ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
Eq, Eq (ScopedArgument scope arg)
Eq (ScopedArgument scope arg) =>
(ScopedArgument scope arg -> ScopedArgument scope arg -> Ordering)
-> (ScopedArgument scope arg -> ScopedArgument scope arg -> Bool)
-> (ScopedArgument scope arg -> ScopedArgument scope arg -> Bool)
-> (ScopedArgument scope arg -> ScopedArgument scope arg -> Bool)
-> (ScopedArgument scope arg -> ScopedArgument scope arg -> Bool)
-> (ScopedArgument scope arg
    -> ScopedArgument scope arg -> ScopedArgument scope arg)
-> (ScopedArgument scope arg
    -> ScopedArgument scope arg -> ScopedArgument scope arg)
-> Ord (ScopedArgument scope arg)
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
ScopedArgument scope arg -> ScopedArgument scope arg -> Ordering
ScopedArgument scope arg
-> ScopedArgument scope arg -> ScopedArgument scope arg
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (scope :: Scope) arg.
Ord arg =>
Eq (ScopedArgument scope arg)
forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Ordering
forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg
-> ScopedArgument scope arg -> ScopedArgument scope arg
$ccompare :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Ordering
compare :: ScopedArgument scope arg -> ScopedArgument scope arg -> Ordering
$c< :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
< :: ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
$c<= :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
<= :: ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
$c> :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
> :: ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
$c>= :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
>= :: ScopedArgument scope arg -> ScopedArgument scope arg -> Bool
$cmax :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg
-> ScopedArgument scope arg -> ScopedArgument scope arg
max :: ScopedArgument scope arg
-> ScopedArgument scope arg -> ScopedArgument scope arg
$cmin :: forall (scope :: Scope) arg.
Ord arg =>
ScopedArgument scope arg
-> ScopedArgument scope arg -> ScopedArgument scope arg
min :: ScopedArgument scope arg
-> ScopedArgument scope arg -> ScopedArgument scope arg
Ord, Int -> ScopedArgument scope arg -> ShowS
[ScopedArgument scope arg] -> ShowS
ScopedArgument scope arg -> String
(Int -> ScopedArgument scope arg -> ShowS)
-> (ScopedArgument scope arg -> String)
-> ([ScopedArgument scope arg] -> ShowS)
-> Show (ScopedArgument scope arg)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (scope :: Scope) arg.
Show arg =>
Int -> ScopedArgument scope arg -> ShowS
forall (scope :: Scope) arg.
Show arg =>
[ScopedArgument scope arg] -> ShowS
forall (scope :: Scope) arg.
Show arg =>
ScopedArgument scope arg -> String
$cshowsPrec :: forall (scope :: Scope) arg.
Show arg =>
Int -> ScopedArgument scope arg -> ShowS
showsPrec :: Int -> ScopedArgument scope arg -> ShowS
$cshow :: forall (scope :: Scope) arg.
Show arg =>
ScopedArgument scope arg -> String
show :: ScopedArgument scope arg -> String
$cshowList :: forall (scope :: Scope) arg.
Show arg =>
[ScopedArgument scope arg] -> ShowS
showList :: [ScopedArgument scope arg] -> ShowS
Show)

-- | Serialise/deserialise, always including the length of the payload.
instance Binary arg => Binary (ScopedArgument User arg) where
  put :: ScopedArgument 'User arg -> Put
put (ScopedArgument arg
arg) = forall t. Binary t => t -> Put
put @LBS.ByteString (arg -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode arg
arg)
  get :: Get (ScopedArgument 'User arg)
get = do
    ByteString
dat <- forall t. Binary t => Get t
get @LBS.ByteString
    case ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, arg)
forall a.
Binary a =>
ByteString
-> Either
     (ByteString, ByteOffset, String) (ByteString, ByteOffset, a)
Binary.decodeOrFail ByteString
dat of
      Left (ByteString
_, ByteOffset
_, String
err) -> String -> Get (ScopedArgument 'User arg)
forall a. String -> Get a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
      Right (ByteString
_, ByteOffset
_, arg
res) -> ScopedArgument 'User arg -> Get (ScopedArgument 'User arg)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (ScopedArgument 'User arg -> Get (ScopedArgument 'User arg))
-> ScopedArgument 'User arg -> Get (ScopedArgument 'User arg)
forall a b. (a -> b) -> a -> b
$ arg -> ScopedArgument 'User arg
forall (scope :: Scope) arg. arg -> ScopedArgument scope arg
ScopedArgument arg
res

-- | Serialise and deserialise a raw ByteString, leaving it untouched.
instance arg ~ LBS.ByteString => Binary (ScopedArgument System arg) where
  put :: ScopedArgument 'System arg -> Put
put (ScopedArgument arg
arg) = arg -> Put
forall t. Binary t => t -> Put
put arg
arg
  get :: Get (ScopedArgument 'System arg)
get = arg -> ScopedArgument 'System arg
forall (scope :: Scope) arg. arg -> ScopedArgument scope arg
ScopedArgument (arg -> ScopedArgument 'System arg)
-> Get arg -> Get (ScopedArgument 'System arg)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get arg
forall t. Binary t => Get t
get

-- | A placeholder for a command that has been omitted, e.g. when we don't
-- care about serialising/deserialising one particular command in a datatype.
data NoCmd (scope :: Scope) arg res = CmdOmitted
  deriving stock ((forall x. NoCmd scope arg res -> Rep (NoCmd scope arg res) x)
-> (forall x. Rep (NoCmd scope arg res) x -> NoCmd scope arg res)
-> Generic (NoCmd scope arg res)
forall x. Rep (NoCmd scope arg res) x -> NoCmd scope arg res
forall x. NoCmd scope arg res -> Rep (NoCmd scope arg res) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (scope :: Scope) k (arg :: k) k (res :: k) x.
Rep (NoCmd scope arg res) x -> NoCmd scope arg res
forall (scope :: Scope) k (arg :: k) k (res :: k) x.
NoCmd scope arg res -> Rep (NoCmd scope arg res) x
$cfrom :: forall (scope :: Scope) k (arg :: k) k (res :: k) x.
NoCmd scope arg res -> Rep (NoCmd scope arg res) x
from :: forall x. NoCmd scope arg res -> Rep (NoCmd scope arg res) x
$cto :: forall (scope :: Scope) k (arg :: k) k (res :: k) x.
Rep (NoCmd scope arg res) x -> NoCmd scope arg res
to :: forall x. Rep (NoCmd scope arg res) x -> NoCmd scope arg res
Generic, NoCmd scope arg res -> NoCmd scope arg res -> Bool
(NoCmd scope arg res -> NoCmd scope arg res -> Bool)
-> (NoCmd scope arg res -> NoCmd scope arg res -> Bool)
-> Eq (NoCmd scope arg res)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
$c== :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
== :: NoCmd scope arg res -> NoCmd scope arg res -> Bool
$c/= :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
/= :: NoCmd scope arg res -> NoCmd scope arg res -> Bool
Eq, Eq (NoCmd scope arg res)
Eq (NoCmd scope arg res) =>
(NoCmd scope arg res -> NoCmd scope arg res -> Ordering)
-> (NoCmd scope arg res -> NoCmd scope arg res -> Bool)
-> (NoCmd scope arg res -> NoCmd scope arg res -> Bool)
-> (NoCmd scope arg res -> NoCmd scope arg res -> Bool)
-> (NoCmd scope arg res -> NoCmd scope arg res -> Bool)
-> (NoCmd scope arg res
    -> NoCmd scope arg res -> NoCmd scope arg res)
-> (NoCmd scope arg res
    -> NoCmd scope arg res -> NoCmd scope arg res)
-> Ord (NoCmd scope arg res)
NoCmd scope arg res -> NoCmd scope arg res -> Bool
NoCmd scope arg res -> NoCmd scope arg res -> Ordering
NoCmd scope arg res -> NoCmd scope arg res -> NoCmd scope arg res
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (scope :: Scope) k (arg :: k) k (res :: k).
Eq (NoCmd scope arg res)
forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Ordering
forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> NoCmd scope arg res
$ccompare :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Ordering
compare :: NoCmd scope arg res -> NoCmd scope arg res -> Ordering
$c< :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
< :: NoCmd scope arg res -> NoCmd scope arg res -> Bool
$c<= :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
<= :: NoCmd scope arg res -> NoCmd scope arg res -> Bool
$c> :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
> :: NoCmd scope arg res -> NoCmd scope arg res -> Bool
$c>= :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> Bool
>= :: NoCmd scope arg res -> NoCmd scope arg res -> Bool
$cmax :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> NoCmd scope arg res
max :: NoCmd scope arg res -> NoCmd scope arg res -> NoCmd scope arg res
$cmin :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> NoCmd scope arg res -> NoCmd scope arg res
min :: NoCmd scope arg res -> NoCmd scope arg res -> NoCmd scope arg res
Ord, Int -> NoCmd scope arg res -> ShowS
[NoCmd scope arg res] -> ShowS
NoCmd scope arg res -> String
(Int -> NoCmd scope arg res -> ShowS)
-> (NoCmd scope arg res -> String)
-> ([NoCmd scope arg res] -> ShowS)
-> Show (NoCmd scope arg res)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (scope :: Scope) k (arg :: k) k (res :: k).
Int -> NoCmd scope arg res -> ShowS
forall (scope :: Scope) k (arg :: k) k (res :: k).
[NoCmd scope arg res] -> ShowS
forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> String
$cshowsPrec :: forall (scope :: Scope) k (arg :: k) k (res :: k).
Int -> NoCmd scope arg res -> ShowS
showsPrec :: Int -> NoCmd scope arg res -> ShowS
$cshow :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> String
show :: NoCmd scope arg res -> String
$cshowList :: forall (scope :: Scope) k (arg :: k) k (res :: k).
[NoCmd scope arg res] -> ShowS
showList :: [NoCmd scope arg res] -> ShowS
Show)
  deriving anyclass (Get (NoCmd scope arg res)
[NoCmd scope arg res] -> Put
NoCmd scope arg res -> Put
(NoCmd scope arg res -> Put)
-> Get (NoCmd scope arg res)
-> ([NoCmd scope arg res] -> Put)
-> Binary (NoCmd scope arg res)
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
forall (scope :: Scope) k (arg :: k) k (res :: k).
Get (NoCmd scope arg res)
forall (scope :: Scope) k (arg :: k) k (res :: k).
[NoCmd scope arg res] -> Put
forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> Put
$cput :: forall (scope :: Scope) k (arg :: k) k (res :: k).
NoCmd scope arg res -> Put
put :: NoCmd scope arg res -> Put
$cget :: forall (scope :: Scope) k (arg :: k) k (res :: k).
Get (NoCmd scope arg res)
get :: Get (NoCmd scope arg res)
$cputList :: forall (scope :: Scope) k (arg :: k) k (res :: k).
[NoCmd scope arg res] -> Put
putList :: [NoCmd scope arg res] -> Put
Binary)

-- | A dynamic dependency command.
newtype DynDepsCmd scope depsArg depsRes = DynDepsCmd
  { forall (scope :: Scope) depsArg depsRes.
DynDepsCmd scope depsArg depsRes
-> CommandData scope depsArg (IO ([Dependency], depsRes))
dynDepsCmd
      :: CommandData scope depsArg (IO ([Dependency], depsRes))
  }

deriving newtype instance Show (DynDepsCmd User depsArg depsRes)
deriving newtype instance Eq (DynDepsCmd User depsArg depsRes)
deriving newtype instance Binary (DynDepsCmd User depsArg depsRes)
deriving newtype instance
  (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString)
  => Eq (DynDepsCmd System arg depsRes)
deriving newtype instance
  (arg ~ LBS.ByteString, depsRes ~ LBS.ByteString)
  => Binary (DynDepsCmd System arg depsRes)

-- | The result of a dynamic dependency computation.
newtype DepsRes (scope :: Scope) depsArg depsRes = DepsRes
  { forall {k} (scope :: Scope) (depsArg :: k) depsRes.
DepsRes scope depsArg depsRes -> ScopedArgument scope depsRes
depsRes
      :: ScopedArgument scope depsRes -- See Note [Hooks Binary instances]
  }
  deriving newtype (Int -> DepsRes scope depsArg depsRes -> ShowS
[DepsRes scope depsArg depsRes] -> ShowS
DepsRes scope depsArg depsRes -> String
(Int -> DepsRes scope depsArg depsRes -> ShowS)
-> (DepsRes scope depsArg depsRes -> String)
-> ([DepsRes scope depsArg depsRes] -> ShowS)
-> Show (DepsRes scope depsArg depsRes)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (scope :: Scope) k (depsArg :: k) depsRes.
Show depsRes =>
Int -> DepsRes scope depsArg depsRes -> ShowS
forall (scope :: Scope) k (depsArg :: k) depsRes.
Show depsRes =>
[DepsRes scope depsArg depsRes] -> ShowS
forall (scope :: Scope) k (depsArg :: k) depsRes.
Show depsRes =>
DepsRes scope depsArg depsRes -> String
$cshowsPrec :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Show depsRes =>
Int -> DepsRes scope depsArg depsRes -> ShowS
showsPrec :: Int -> DepsRes scope depsArg depsRes -> ShowS
$cshow :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Show depsRes =>
DepsRes scope depsArg depsRes -> String
show :: DepsRes scope depsArg depsRes -> String
$cshowList :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Show depsRes =>
[DepsRes scope depsArg depsRes] -> ShowS
showList :: [DepsRes scope depsArg depsRes] -> ShowS
Show, DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
(DepsRes scope depsArg depsRes
 -> DepsRes scope depsArg depsRes -> Bool)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> Bool)
-> Eq (DepsRes scope depsArg depsRes)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (scope :: Scope) k (depsArg :: k) depsRes.
Eq depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
$c== :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Eq depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
== :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
$c/= :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Eq depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
/= :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
Eq, Eq (DepsRes scope depsArg depsRes)
Eq (DepsRes scope depsArg depsRes) =>
(DepsRes scope depsArg depsRes
 -> DepsRes scope depsArg depsRes -> Ordering)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> Bool)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> Bool)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> Bool)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> Bool)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes)
-> (DepsRes scope depsArg depsRes
    -> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes)
-> Ord (DepsRes scope depsArg depsRes)
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Ordering
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
Eq (DepsRes scope depsArg depsRes)
forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Ordering
forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes
$ccompare :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Ordering
compare :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Ordering
$c< :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
< :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
$c<= :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
<= :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
$c> :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
> :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
$c>= :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
>= :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> Bool
$cmax :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes
max :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes
$cmin :: forall (scope :: Scope) k (depsArg :: k) depsRes.
Ord depsRes =>
DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes
min :: DepsRes scope depsArg depsRes
-> DepsRes scope depsArg depsRes -> DepsRes scope depsArg depsRes
Ord)

deriving newtype instance
  Binary (ScopedArgument scope depsRes)
  => Binary (DepsRes scope depsArg depsRes)

-- | Both the rule command and the (optional) dynamic dependency command.
type RuleCmds scope = RuleCommands scope DynDepsCmd CommandData

-- | Only the (optional) dynamic dependency command.
type RuleDynDepsCmd scope = RuleCommands scope DynDepsCmd NoCmd

-- | The rule command together with the result of the (optional) dynamic
-- dependency computation.
type RuleExecCmd scope = RuleCommands scope DepsRes CommandData

-- | Project out the (optional) dependency computation command, so that
-- it can be serialised without serialising anything else.
ruleDepsCmd :: RuleCmds scope -> RuleDynDepsCmd scope
ruleDepsCmd :: forall (scope :: Scope). RuleCmds scope -> RuleDynDepsCmd scope
ruleDepsCmd = \case
  StaticRuleCommand
    { staticRuleCommand :: ()
staticRuleCommand = CommandData scope arg (IO ())
_ :: CommandData scope args (IO ())
    , staticRuleArgRep :: ()
staticRuleArgRep = If (scope == 'System) SomeTypeRep (TypeRep arg)
tr
    } ->
      StaticRuleCommand
        { staticRuleCommand :: NoCmd scope arg (IO ())
staticRuleCommand = NoCmd scope arg (IO ())
forall {k} {k} (scope :: Scope) (arg :: k) (res :: k).
NoCmd scope arg res
CmdOmitted :: NoCmd scope args (IO ())
        , staticRuleArgRep :: If (scope == 'System) SomeTypeRep (TypeRep arg)
staticRuleArgRep = If (scope == 'System) SomeTypeRep (TypeRep arg)
tr
        }
  DynamicRuleCommands
    { dynamicRuleCommand :: ()
dynamicRuleCommand = CommandData scope arg (depsRes -> IO ())
_ :: CommandData scope args (depsRes -> IO ())
    , dynamicRuleInstances :: ()
dynamicRuleInstances = Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
    , dynamicDeps :: ()
dynamicDeps = DynDepsCmd scope depsArg depsRes
deps
    , dynamicRuleTypeRep :: ()
dynamicRuleTypeRep = If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr
    } ->
      DynamicRuleCommands
        { dynamicRuleInstances :: Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
dynamicRuleInstances = Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
        , dynamicDeps :: DynDepsCmd scope depsArg depsRes
dynamicDeps = DynDepsCmd scope depsArg depsRes
deps
        , dynamicRuleCommand :: NoCmd scope arg (depsRes -> IO ())
dynamicRuleCommand = NoCmd scope arg (depsRes -> IO ())
forall {k} {k} (scope :: Scope) (arg :: k) (res :: k).
NoCmd scope arg res
CmdOmitted :: NoCmd scope args (depsRes -> IO ())
        , dynamicRuleTypeRep :: If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
dynamicRuleTypeRep = If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr
        }

-- | Obtain the (optional) 'IO' action that computes dynamic dependencies.
runRuleDynDepsCmd :: RuleDynDepsCmd User -> Maybe (IO ([Dependency], LBS.ByteString))
runRuleDynDepsCmd :: RuleDynDepsCmd 'User -> Maybe (IO ([Dependency], ByteString))
runRuleDynDepsCmd = \case
  StaticRuleCommand{} -> Maybe (IO ([Dependency], ByteString))
forall a. Maybe a
Nothing
  DynamicRuleCommands
    { dynamicRuleInstances :: ()
dynamicRuleInstances = UserStatic StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
    , dynamicDeps :: ()
dynamicDeps = DynDepsCmd{dynDepsCmd :: forall (scope :: Scope) depsArg depsRes.
DynDepsCmd scope depsArg depsRes
-> CommandData scope depsArg (IO ([Dependency], depsRes))
dynDepsCmd = CommandData 'User depsArg (IO ([Dependency], depsRes))
depsCmd}
    }
      | Dict (Binary depsRes, Show depsRes, Eq depsRes)
Dict <- StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Dict (Binary depsRes, Show depsRes, Eq depsRes)
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr ->
          IO ([Dependency], ByteString)
-> Maybe (IO ([Dependency], ByteString))
forall a. a -> Maybe a
Just (IO ([Dependency], ByteString)
 -> Maybe (IO ([Dependency], ByteString)))
-> IO ([Dependency], ByteString)
-> Maybe (IO ([Dependency], ByteString))
forall a b. (a -> b) -> a -> b
$ do
            ([Dependency]
deps, depsRes
depsRes) <- CommandData 'User depsArg (IO ([Dependency], depsRes))
-> IO ([Dependency], depsRes)
forall args res. Command args res -> res
runCommand CommandData 'User depsArg (IO ([Dependency], depsRes))
depsCmd
            -- See Note [Hooks Binary instances]
            ([Dependency], ByteString) -> IO ([Dependency], ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (([Dependency], ByteString) -> IO ([Dependency], ByteString))
-> ([Dependency], ByteString) -> IO ([Dependency], ByteString)
forall a b. (a -> b) -> a -> b
$ ([Dependency]
deps, ScopedArgument 'User depsRes -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode (ScopedArgument 'User depsRes -> ByteString)
-> ScopedArgument 'User depsRes -> ByteString
forall a b. (a -> b) -> a -> b
$ forall (scope :: Scope) arg. arg -> ScopedArgument scope arg
ScopedArgument @User depsRes
depsRes)

-- | Project out the command for running the rule, passing in the result of
-- the dependency computation if there was one.
ruleExecCmd :: SScope scope -> RuleCmds scope -> Maybe LBS.ByteString -> RuleExecCmd scope
ruleExecCmd :: forall (scope :: Scope).
SScope scope
-> RuleCmds scope -> Maybe ByteString -> RuleExecCmd scope
ruleExecCmd
  SScope scope
_
  StaticRuleCommand{staticRuleCommand :: ()
staticRuleCommand = CommandData scope arg (IO ())
cmd, staticRuleArgRep :: ()
staticRuleArgRep = If (scope == 'System) SomeTypeRep (TypeRep arg)
tr}
  Maybe ByteString
_ =
    StaticRuleCommand{staticRuleCommand :: CommandData scope arg (IO ())
staticRuleCommand = CommandData scope arg (IO ())
cmd, staticRuleArgRep :: If (scope == 'System) SomeTypeRep (TypeRep arg)
staticRuleArgRep = If (scope == 'System) SomeTypeRep (TypeRep arg)
tr}
ruleExecCmd
  SScope scope
scope
  DynamicRuleCommands
    { dynamicRuleInstances :: ()
dynamicRuleInstances = Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
    , dynamicRuleCommand :: ()
dynamicRuleCommand = CommandData scope arg (depsRes -> IO ())
cmd :: CommandData scope arg (depsRes -> IO ())
    , dynamicDeps :: ()
dynamicDeps = DynDepsCmd scope depsArg depsRes
_ :: DynDepsCmd scope depsArg depsRes
    , dynamicRuleTypeRep :: ()
dynamicRuleTypeRep = If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr
    }
  Maybe ByteString
mbDepsResBinary =
    case Maybe ByteString
mbDepsResBinary of
      Maybe ByteString
Nothing ->
        String -> RuleCommands scope DepsRes CommandData
forall a. HasCallStack => String -> a
error (String -> RuleCommands scope DepsRes CommandData)
-> String -> RuleCommands scope DepsRes CommandData
forall a b. (a -> b) -> a -> b
$
          [String] -> String
unlines
            [ String
"Missing ByteString argument in 'ruleExecCmd'."
            , String
"Run 'runRuleDynDepsCmd' on the rule to obtain this data."
            ]
      Just ByteString
depsResBinary ->
        case SScope scope
scope of
          SScope scope
SUser
            | Dict (Binary depsRes, Show depsRes, Eq depsRes)
Dict <- StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Dict (Binary depsRes, Show depsRes, Eq depsRes)
forall a. StaticPtr a -> a
deRefStaticPtr (Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr) ->
                DynamicRuleCommands
                  { dynamicRuleInstances :: Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
dynamicRuleInstances = Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
                  , dynamicRuleCommand :: CommandData scope arg (depsRes -> IO ())
dynamicRuleCommand = CommandData scope arg (depsRes -> IO ())
cmd
                  , dynamicDeps :: DepsRes scope depsArg depsRes
dynamicDeps = ByteString -> DepsRes 'User depsArg depsRes
forall a. Binary a => ByteString -> a
Binary.decode ByteString
depsResBinary :: DepsRes User depsArg depsRes
                  , dynamicRuleTypeRep :: If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
dynamicRuleTypeRep = If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr
                  }
          SScope scope
SSystem ->
            DynamicRuleCommands
              { dynamicRuleInstances :: Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
dynamicRuleInstances = Static scope (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
              , dynamicRuleCommand :: CommandData scope arg (depsRes -> IO ())
dynamicRuleCommand = CommandData scope arg (depsRes -> IO ())
cmd
              , dynamicDeps :: DepsRes scope ByteString depsRes
dynamicDeps = ScopedArgument scope depsRes -> DepsRes scope ByteString depsRes
forall {k} (scope :: Scope) (depsArg :: k) depsRes.
ScopedArgument scope depsRes -> DepsRes scope depsArg depsRes
DepsRes (ScopedArgument scope depsRes -> DepsRes scope ByteString depsRes)
-> ScopedArgument scope depsRes -> DepsRes scope ByteString depsRes
forall a b. (a -> b) -> a -> b
$ depsRes -> ScopedArgument scope depsRes
forall (scope :: Scope) arg. arg -> ScopedArgument scope arg
ScopedArgument depsRes
ByteString
depsResBinary
              , dynamicRuleTypeRep :: If
  (scope == 'System) SomeTypeRep (TypeRep (ByteString, depsRes, arg))
dynamicRuleTypeRep = If (scope == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
If
  (scope == 'System) SomeTypeRep (TypeRep (ByteString, depsRes, arg))
tr
              }

-- | Obtain the 'IO' action that executes a rule.
runRuleExecCmd :: RuleExecCmd User -> IO ()
runRuleExecCmd :: RuleExecCmd 'User -> IO ()
runRuleExecCmd = \case
  StaticRuleCommand{staticRuleCommand :: ()
staticRuleCommand = CommandData 'User arg (IO ())
cmd} -> CommandData 'User arg (IO ()) -> IO ()
forall args res. Command args res -> res
runCommand CommandData 'User arg (IO ())
cmd
  DynamicRuleCommands
    { dynamicDeps :: ()
dynamicDeps = DepsRes (ScopedArgument{getArg :: forall (scope :: Scope) arg. ScopedArgument scope arg -> arg
getArg = depsRes
res})
    , dynamicRuleCommand :: ()
dynamicRuleCommand = CommandData 'User arg (depsRes -> IO ())
cmd
    } ->
      CommandData 'User arg (depsRes -> IO ()) -> depsRes -> IO ()
forall args res. Command args res -> res
runCommand CommandData 'User arg (depsRes -> IO ())
cmd depsRes
res

--------------------------------------------------------------------------------
-- Instances

-- | A wrapper used to pass evidence of a constraint as an explicit value.
data Dict c where
  Dict :: c => Dict c

instance Show (CommandData User arg res) where
  showsPrec :: Int -> CommandData 'User arg res -> ShowS
showsPrec Int
prec (Command{actionPtr :: forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr = Static 'User (arg -> res)
cmdPtr, actionArg :: forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg = ScopedArgument 'User arg
arg, cmdInstances :: forall (scope :: Scope) arg res.
CommandData scope arg res
-> Static scope (Dict (Binary arg, Show arg))
cmdInstances = Static 'User (Dict (Binary arg, Show arg))
insts})
    | Dict (Binary arg, Show arg)
Dict <- StaticPtr (Dict (Binary arg, Show arg))
-> Dict (Binary arg, Show arg)
forall a. StaticPtr a -> a
deRefStaticPtr (Static 'User (Dict (Binary arg, Show arg))
-> StaticPtr (Dict (Binary arg, Show arg))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static 'User (Dict (Binary arg, Show arg))
insts) =
        Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
          String -> ShowS
showString String
"Command {"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"actionPtrKey = "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Static 'User (arg -> res) -> ShowS
forall a. Show a => a -> ShowS
shows Static 'User (arg -> res)
cmdPtr
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"actionArg = "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScopedArgument 'User arg -> ShowS
forall a. Show a => a -> ShowS
shows ScopedArgument 'User arg
arg
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"

instance Eq (CommandData User arg res) where
  Command{actionPtr :: forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr = Static 'User (arg -> res)
cmdPtr1, actionArg :: forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg = ScopedArgument 'User arg
arg1, cmdInstances :: forall (scope :: Scope) arg res.
CommandData scope arg res
-> Static scope (Dict (Binary arg, Show arg))
cmdInstances = Static 'User (Dict (Binary arg, Show arg))
insts1}
    == :: CommandData 'User arg res -> CommandData 'User arg res -> Bool
== Command{actionPtr :: forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr = Static 'User (arg -> res)
cmdPtr2, actionArg :: forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg = ScopedArgument 'User arg
arg2, cmdInstances :: forall (scope :: Scope) arg res.
CommandData scope arg res
-> Static scope (Dict (Binary arg, Show arg))
cmdInstances = Static 'User (Dict (Binary arg, Show arg))
insts2}
      | Static 'User (arg -> res)
cmdPtr1 Static 'User (arg -> res) -> Static 'User (arg -> res) -> Bool
forall a. Eq a => a -> a -> Bool
== Static 'User (arg -> res)
cmdPtr2
      , Static 'User (Dict (Binary arg, Show arg))
insts1 Static 'User (Dict (Binary arg, Show arg))
-> Static 'User (Dict (Binary arg, Show arg)) -> Bool
forall a. Eq a => a -> a -> Bool
== Static 'User (Dict (Binary arg, Show arg))
insts2
      , Dict (Binary arg, Show arg)
Dict <- StaticPtr (Dict (Binary arg, Show arg))
-> Dict (Binary arg, Show arg)
forall a. StaticPtr a -> a
deRefStaticPtr (Static 'User (Dict (Binary arg, Show arg))
-> StaticPtr (Dict (Binary arg, Show arg))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static 'User (Dict (Binary arg, Show arg))
insts1) =
          ScopedArgument 'User arg -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode ScopedArgument 'User arg
arg1 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ScopedArgument 'User arg -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode ScopedArgument 'User arg
arg2
      | Bool
otherwise =
          Bool
False
instance arg ~ LBS.ByteString => Eq (CommandData System arg res) where
  Command Static 'System (arg -> res)
a1 ScopedArgument 'System arg
b1 Static 'System (Dict (Binary arg, Show arg))
c1 == :: CommandData 'System arg res -> CommandData 'System arg res -> Bool
== Command Static 'System (arg -> res)
a2 ScopedArgument 'System arg
b2 Static 'System (Dict (Binary arg, Show arg))
c2 =
    Static 'System (arg -> res)
a1 Static 'System (arg -> res) -> Static 'System (arg -> res) -> Bool
forall a. Eq a => a -> a -> Bool
== Static 'System (arg -> res)
a2 Bool -> Bool -> Bool
&& ScopedArgument 'System arg
b1 ScopedArgument 'System arg -> ScopedArgument 'System arg -> Bool
forall a. Eq a => a -> a -> Bool
== ScopedArgument 'System arg
b2 Bool -> Bool -> Bool
&& Static 'System (Dict (Binary arg, Show arg))
c1 Static 'System (Dict (Binary arg, Show arg))
-> Static 'System (Dict (Binary arg, Show arg)) -> Bool
forall a. Eq a => a -> a -> Bool
== Static 'System (Dict (Binary arg, Show arg))
c2

instance Binary (CommandData User arg res) where
  put :: CommandData 'User arg res -> Put
put (Command{actionPtr :: forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr = Static 'User (arg -> res)
cmdPtr, actionArg :: forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg = ScopedArgument 'User arg
arg, cmdInstances :: forall (scope :: Scope) arg res.
CommandData scope arg res
-> Static scope (Dict (Binary arg, Show arg))
cmdInstances = Static 'User (Dict (Binary arg, Show arg))
insts})
    | Dict (Binary arg, Show arg)
Dict <- StaticPtr (Dict (Binary arg, Show arg))
-> Dict (Binary arg, Show arg)
forall a. StaticPtr a -> a
deRefStaticPtr (Static 'User (Dict (Binary arg, Show arg))
-> StaticPtr (Dict (Binary arg, Show arg))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static 'User (Dict (Binary arg, Show arg))
insts) =
        do
          Static 'User (arg -> res) -> Put
forall t. Binary t => t -> Put
put Static 'User (arg -> res)
cmdPtr
          Static 'User (Dict (Binary arg, Show arg)) -> Put
forall t. Binary t => t -> Put
put Static 'User (Dict (Binary arg, Show arg))
insts
          ScopedArgument 'User arg -> Put
forall t. Binary t => t -> Put
put ScopedArgument 'User arg
arg
  get :: Get (CommandData 'User arg res)
get = do
    Static 'User (arg -> res)
cmdPtr <- Get (Static 'User (arg -> res))
forall t. Binary t => Get t
get
    Static 'User (Dict (Binary arg, Show arg))
instsPtr <- Get (Static 'User (Dict (Binary arg, Show arg)))
forall t. Binary t => Get t
get
    case forall a. StaticPtr a -> a
deRefStaticPtr @(Dict (Binary arg, Show arg)) (StaticPtr (Dict (Binary arg, Show arg))
 -> Dict (Binary arg, Show arg))
-> StaticPtr (Dict (Binary arg, Show arg))
-> Dict (Binary arg, Show arg)
forall a b. (a -> b) -> a -> b
$ Static 'User (Dict (Binary arg, Show arg))
-> StaticPtr (Dict (Binary arg, Show arg))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static 'User (Dict (Binary arg, Show arg))
instsPtr of
      Dict (Binary arg, Show arg)
Dict -> do
        ScopedArgument 'User arg
arg <- Get (ScopedArgument 'User arg)
forall t. Binary t => Get t
get
        CommandData 'User arg res -> Get (CommandData 'User arg res)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandData 'User arg res -> Get (CommandData 'User arg res))
-> CommandData 'User arg res -> Get (CommandData 'User arg res)
forall a b. (a -> b) -> a -> b
$
          Command
            { actionPtr :: Static 'User (arg -> res)
actionPtr = Static 'User (arg -> res)
cmdPtr
            , actionArg :: ScopedArgument 'User arg
actionArg = ScopedArgument 'User arg
arg
            , cmdInstances :: Static 'User (Dict (Binary arg, Show arg))
cmdInstances = Static 'User (Dict (Binary arg, Show arg))
instsPtr
            }
instance arg ~ LBS.ByteString => Binary (CommandData System arg res) where
  put :: CommandData 'System arg res -> Put
put (Command{actionPtr :: forall (scope :: Scope) arg res.
CommandData scope arg res -> Static scope (arg -> res)
actionPtr = Static 'System (arg -> res)
cmdPtr, actionArg :: forall (scope :: Scope) arg res.
CommandData scope arg res -> ScopedArgument scope arg
actionArg = ScopedArgument 'System arg
arg, cmdInstances :: forall (scope :: Scope) arg res.
CommandData scope arg res
-> Static scope (Dict (Binary arg, Show arg))
cmdInstances = Static 'System (Dict (Binary arg, Show arg))
insts}) =
    do
      Static 'System (arg -> res) -> Put
forall t. Binary t => t -> Put
put Static 'System (arg -> res)
cmdPtr
      Static 'System (Dict (Binary arg, Show arg)) -> Put
forall t. Binary t => t -> Put
put Static 'System (Dict (Binary arg, Show arg))
insts
      ScopedArgument 'System arg -> Put
forall t. Binary t => t -> Put
put ScopedArgument 'System arg
arg
  get :: Get (CommandData 'System arg res)
get = do
    Static 'System (arg -> res)
cmdKey <- Get (Static 'System (arg -> res))
forall t. Binary t => Get t
get
    Static 'System (Dict (Binary arg, Show arg))
instsKey <- Get (Static 'System (Dict (Binary arg, Show arg)))
forall t. Binary t => Get t
get
    ScopedArgument 'System arg
arg <- Get (ScopedArgument 'System arg)
forall t. Binary t => Get t
get
    CommandData 'System arg res -> Get (CommandData 'System arg res)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (CommandData 'System arg res -> Get (CommandData 'System arg res))
-> CommandData 'System arg res -> Get (CommandData 'System arg res)
forall a b. (a -> b) -> a -> b
$ Command{actionPtr :: Static 'System (arg -> res)
actionPtr = Static 'System (arg -> res)
cmdKey, actionArg :: ScopedArgument 'System arg
actionArg = ScopedArgument 'System arg
arg, cmdInstances :: Static 'System (Dict (Binary arg, Show arg))
cmdInstances = Static 'System (Dict (Binary arg, Show arg))
instsKey}

instance
  ( forall arg res. Show (ruleCmd User arg res)
  , forall depsArg depsRes. Show depsRes => Show (deps User depsArg depsRes)
  )
  => Show (RuleCommands User deps ruleCmd)
  where
  showsPrec :: Int -> RuleCommands 'User deps ruleCmd -> ShowS
showsPrec Int
prec (StaticRuleCommand{staticRuleCommand :: ()
staticRuleCommand = ruleCmd 'User arg (IO ())
cmd}) =
    Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
      String -> ShowS
showString String
"StaticRuleCommand {"
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"staticRuleCommand = "
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ruleCmd 'User arg (IO ()) -> ShowS
forall a. Show a => a -> ShowS
shows ruleCmd 'User arg (IO ())
cmd
        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"
  showsPrec
    Int
prec
    ( DynamicRuleCommands
        { dynamicDeps :: ()
dynamicDeps = deps 'User depsArg depsRes
deps
        , dynamicRuleCommand :: ()
dynamicRuleCommand = ruleCmd 'User arg (depsRes -> IO ())
cmd
        , dynamicRuleInstances :: ()
dynamicRuleInstances = UserStatic StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
        }
      )
      | Dict (Binary depsRes, Show depsRes, Eq depsRes)
Dict <- StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Dict (Binary depsRes, Show depsRes, Eq depsRes)
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr =
          Bool -> ShowS -> ShowS
showParen (Int
prec Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
11) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
            String -> ShowS
showString String
"DynamicRuleCommands {"
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"dynamicDeps = "
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. deps 'User depsArg depsRes -> ShowS
forall a. Show a => a -> ShowS
shows deps 'User depsArg depsRes
deps
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showCommaSpace
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"dynamicRuleCommand = "
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ruleCmd 'User arg (depsRes -> IO ()) -> ShowS
forall a. Show a => a -> ShowS
shows ruleCmd 'User arg (depsRes -> IO ())
cmd
              ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
"}"

instance
  ( forall arg res. Eq (ruleCmd User arg res)
  , forall depsArg depsRes. Eq depsRes => Eq (deps User depsArg depsRes)
  )
  => Eq (RuleCommands User deps ruleCmd)
  where
  StaticRuleCommand{staticRuleCommand :: ()
staticRuleCommand = ruleCmd 'User arg (IO ())
ruleCmd1 :: ruleCmd User arg1 (IO ()), staticRuleArgRep :: ()
staticRuleArgRep = If ('User == 'System) SomeTypeRep (TypeRep arg)
tr1}
    == :: RuleCommands 'User deps ruleCmd
-> RuleCommands 'User deps ruleCmd -> Bool
== StaticRuleCommand{staticRuleCommand :: ()
staticRuleCommand = ruleCmd 'User arg (IO ())
ruleCmd2 :: ruleCmd User arg2 (IO ()), staticRuleArgRep :: ()
staticRuleArgRep = If ('User == 'System) SomeTypeRep (TypeRep arg)
tr2}
      | Just arg :~~: arg
HRefl <- TypeRep arg -> TypeRep arg -> Maybe (arg :~~: arg)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
Typeable.eqTypeRep TypeRep arg
If ('User == 'System) SomeTypeRep (TypeRep arg)
tr1 TypeRep arg
If ('User == 'System) SomeTypeRep (TypeRep arg)
tr2 =
          ruleCmd 'User arg (IO ())
ruleCmd1 ruleCmd 'User arg (IO ()) -> ruleCmd 'User arg (IO ()) -> Bool
forall a. Eq a => a -> a -> Bool
== ruleCmd 'User arg (IO ())
ruleCmd 'User arg (IO ())
ruleCmd2
  DynamicRuleCommands
    { dynamicDeps :: ()
dynamicDeps = deps 'User depsArg depsRes
depsCmd1 :: deps User depsArg1 depsRes1
    , dynamicRuleCommand :: ()
dynamicRuleCommand = ruleCmd 'User arg (depsRes -> IO ())
ruleCmd1 :: ruleCmd User arg1 (depsRes1 -> IO ())
    , dynamicRuleInstances :: ()
dynamicRuleInstances = UserStatic StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr1
    , dynamicRuleTypeRep :: ()
dynamicRuleTypeRep = If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr1
    }
    == DynamicRuleCommands
      { dynamicDeps :: ()
dynamicDeps = deps 'User depsArg depsRes
depsCmd2 :: deps User depsArg2 depsRes2
      , dynamicRuleCommand :: ()
dynamicRuleCommand = ruleCmd 'User arg (depsRes -> IO ())
ruleCmd2 :: ruleCmd User arg2 (depsRes2 -> IO ())
      , dynamicRuleInstances :: ()
dynamicRuleInstances = UserStatic StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr2
      , dynamicRuleTypeRep :: ()
dynamicRuleTypeRep = If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr2
      }
      | Just (depsArg, depsRes, arg) :~~: (depsArg, depsRes, arg)
HRefl <- TypeRep (depsArg, depsRes, arg)
-> TypeRep (depsArg, depsRes, arg)
-> Maybe ((depsArg, depsRes, arg) :~~: (depsArg, depsRes, arg))
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
Typeable.eqTypeRep TypeRep (depsArg, depsRes, arg)
If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr1 TypeRep (depsArg, depsRes, arg)
If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr2
      , Dict (Binary depsRes, Show depsRes, Eq depsRes)
Dict <- StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Dict (Binary depsRes, Show depsRes, Eq depsRes)
forall a. StaticPtr a -> a
deRefStaticPtr StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr1 =
          deps 'User depsArg depsRes
depsCmd1 deps 'User depsArg depsRes -> deps 'User depsArg depsRes -> Bool
forall a. Eq a => a -> a -> Bool
== deps 'User depsArg depsRes
deps 'User depsArg depsRes
depsCmd2
            Bool -> Bool -> Bool
&& ruleCmd 'User arg (depsRes -> IO ())
ruleCmd1 ruleCmd 'User arg (depsRes -> IO ())
-> ruleCmd 'User arg (depsRes -> IO ()) -> Bool
forall a. Eq a => a -> a -> Bool
== ruleCmd 'User arg (depsRes -> IO ())
ruleCmd 'User arg (depsRes -> IO ())
ruleCmd2
            Bool -> Bool -> Bool
&& StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes)) -> MD5
forall a. StaticPtr a -> MD5
staticKey StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr1 MD5 -> MD5 -> Bool
forall a. Eq a => a -> a -> Bool
== StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes)) -> MD5
forall a. StaticPtr a -> MD5
staticKey StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr2
  RuleCommands 'User deps ruleCmd
_ == RuleCommands 'User deps ruleCmd
_ = Bool
False

instance
  ( forall res. Eq (ruleCmd System LBS.ByteString res)
  , Eq (deps System LBS.ByteString LBS.ByteString)
  )
  => Eq (RuleCommands System deps ruleCmd)
  where
  StaticRuleCommand ruleCmd 'System arg (IO ())
c1 If ('System == 'System) SomeTypeRep (TypeRep arg)
d1 == :: RuleCommands 'System deps ruleCmd
-> RuleCommands 'System deps ruleCmd -> Bool
== StaticRuleCommand ruleCmd 'System arg (IO ())
c2 If ('System == 'System) SomeTypeRep (TypeRep arg)
d2 = ruleCmd 'System arg (IO ())
c1 ruleCmd 'System arg (IO ()) -> ruleCmd 'System arg (IO ()) -> Bool
forall a. Eq a => a -> a -> Bool
== ruleCmd 'System arg (IO ())
ruleCmd 'System arg (IO ())
c2 Bool -> Bool -> Bool
&& SomeTypeRep
If ('System == 'System) SomeTypeRep (TypeRep arg)
d1 SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== SomeTypeRep
If ('System == 'System) SomeTypeRep (TypeRep arg)
d2
  DynamicRuleCommands Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
a1 deps 'System depsArg depsRes
b1 ruleCmd 'System arg (depsRes -> IO ())
c1 If
  ('System == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
d1 == DynamicRuleCommands Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
a2 deps 'System depsArg depsRes
b2 ruleCmd 'System arg (depsRes -> IO ())
c2 If
  ('System == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
d2 =
    Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
a1 Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Bool
forall a. Eq a => a -> a -> Bool
== Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
a2 Bool -> Bool -> Bool
&& deps 'System depsArg depsRes
b1 deps 'System depsArg depsRes
-> deps 'System depsArg depsRes -> Bool
forall a. Eq a => a -> a -> Bool
== deps 'System depsArg depsRes
deps 'System depsArg depsRes
b2 Bool -> Bool -> Bool
&& ruleCmd 'System arg (depsRes -> IO ())
c1 ruleCmd 'System arg (depsRes -> IO ())
-> ruleCmd 'System arg (depsRes -> IO ()) -> Bool
forall a. Eq a => a -> a -> Bool
== ruleCmd 'System arg (depsRes -> IO ())
ruleCmd 'System arg (depsRes -> IO ())
c2 Bool -> Bool -> Bool
&& SomeTypeRep
If
  ('System == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
d1 SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== SomeTypeRep
If
  ('System == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
d2
  RuleCommands 'System deps ruleCmd
_ == RuleCommands 'System deps ruleCmd
_ = Bool
False

instance
  ( forall arg res. Binary (ruleCmd User arg res)
  , forall depsArg depsRes. Binary depsRes => Binary (deps User depsArg depsRes)
  )
  => Binary (RuleCommands User deps ruleCmd)
  where
  put :: RuleCommands 'User deps ruleCmd -> Put
put = \case
    StaticRuleCommand
      { staticRuleCommand :: ()
staticRuleCommand = ruleCmd 'User arg (IO ())
ruleCmd :: ruleCmd User arg (IO ())
      , staticRuleArgRep :: ()
staticRuleArgRep = If ('User == 'System) SomeTypeRep (TypeRep arg)
tr
      } -> do
        forall t. Binary t => t -> Put
put @Word Word
0
        SomeTypeRep -> Put
forall t. Binary t => t -> Put
put (TypeRep arg -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
Typeable.SomeTypeRep TypeRep arg
If ('User == 'System) SomeTypeRep (TypeRep arg)
tr)
        ruleCmd 'User arg (IO ()) -> Put
forall t. Binary t => t -> Put
put ruleCmd 'User arg (IO ())
ruleCmd
    DynamicRuleCommands
      { dynamicDeps :: ()
dynamicDeps = deps 'User depsArg depsRes
deps :: deps User depsArg depsRes
      , dynamicRuleCommand :: ()
dynamicRuleCommand = ruleCmd 'User arg (depsRes -> IO ())
ruleCmd :: ruleCmd User arg (depsRes -> IO ())
      , dynamicRuleInstances :: ()
dynamicRuleInstances = Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
      , dynamicRuleTypeRep :: ()
dynamicRuleTypeRep = If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr
      } | Dict (Binary depsRes, Show depsRes, Eq depsRes)
Dict <- StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Dict (Binary depsRes, Show depsRes, Eq depsRes)
forall a. StaticPtr a -> a
deRefStaticPtr (Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> StaticPtr (Dict (Binary depsRes, Show depsRes, Eq depsRes))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr) ->
        do
          forall t. Binary t => t -> Put
put @Word Word
1
          SomeTypeRep -> Put
forall t. Binary t => t -> Put
put (TypeRep (depsArg, depsRes, arg) -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
Typeable.SomeTypeRep TypeRep (depsArg, depsRes, arg)
If ('User == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
tr)
          Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Put
forall t. Binary t => t -> Put
put Static 'User (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsPtr
          ruleCmd 'User arg (depsRes -> IO ()) -> Put
forall t. Binary t => t -> Put
put ruleCmd 'User arg (depsRes -> IO ())
ruleCmd
          deps 'User depsArg depsRes -> Put
forall t. Binary t => t -> Put
put deps 'User depsArg depsRes
deps
  get :: Get (RuleCommands 'User deps ruleCmd)
get = do
    Word
tag <- forall t. Binary t => Get t
get @Word
    case Word
tag of
      Word
0 -> do
        Typeable.SomeTypeRep (TypeRep a
trArg :: Typeable.TypeRep arg) <- Get SomeTypeRep
forall t. Binary t => Get t
get
        if
            | Just k :~~: *
HRefl <- TypeRep k -> TypeRep (*) -> Maybe (k :~~: *)
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
Typeable.eqTypeRep (TypeRep a -> TypeRep k
forall k (a :: k). TypeRep a -> TypeRep k
Typeable.typeRepKind TypeRep a
trArg) (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
Typeable.typeRep @Hs.Type) ->
                do
                  ruleCmd 'User a (IO ())
ruleCmd <- forall t. Binary t => Get t
get @(ruleCmd User arg (IO ()))
                  RuleCommands 'User deps ruleCmd
-> Get (RuleCommands 'User deps ruleCmd)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleCommands 'User deps ruleCmd
 -> Get (RuleCommands 'User deps ruleCmd))
-> RuleCommands 'User deps ruleCmd
-> Get (RuleCommands 'User deps ruleCmd)
forall a b. (a -> b) -> a -> b
$
                    TypeRep a
-> (Typeable a => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
Typeable.withTypeable TypeRep a
trArg ((Typeable a => RuleCommands 'User deps ruleCmd)
 -> RuleCommands 'User deps ruleCmd)
-> (Typeable a => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall a b. (a -> b) -> a -> b
$
                      StaticRuleCommand
                        { staticRuleCommand :: ruleCmd 'User a (IO ())
staticRuleCommand = ruleCmd 'User a (IO ())
ruleCmd
                        , staticRuleArgRep :: If ('User == 'System) SomeTypeRep (TypeRep a)
staticRuleArgRep = TypeRep a
If ('User == 'System) SomeTypeRep (TypeRep a)
trArg
                        }
            | Bool
otherwise ->
                String -> Get (RuleCommands 'User deps ruleCmd)
forall a. HasCallStack => String -> a
error String
"internal error when decoding static rule command"
      Word
_ -> do
        Typeable.SomeTypeRep (TypeRep a
tr :: Typeable.TypeRep ty) <- Get SomeTypeRep
forall t. Binary t => Get t
get
        case TypeRep a
tr of
          Typeable.App
            ( Typeable.App
                (Typeable.App (TypeRep a
tup3Tr :: Typeable.TypeRep tup3) (TypeRep b
trDepsArg :: Typeable.TypeRep depsArg))
                (TypeRep b
trDepsRes :: Typeable.TypeRep depsRes)
              )
            (TypeRep b
trArg :: Typeable.TypeRep arg)
              | Just a :~~: (,,)
HRefl <- TypeRep a -> TypeRep (,,) -> Maybe (a :~~: (,,))
forall k1 k2 (a :: k1) (b :: k2).
TypeRep a -> TypeRep b -> Maybe (a :~~: b)
Typeable.eqTypeRep TypeRep a
tup3Tr (forall {k} (a :: k). Typeable a => TypeRep a
forall (a :: * -> * -> * -> *). Typeable a => TypeRep a
Typeable.typeRep @(,,)) -> do
                  Static 'User (Dict (Binary b, Show b, Eq b))
instsPtr <- Get (Static 'User (Dict (Binary b, Show b, Eq b)))
forall t. Binary t => Get t
get
                  case StaticPtr (Dict (Binary b, Show b, Eq b))
-> Dict (Binary b, Show b, Eq b)
forall a. StaticPtr a -> a
deRefStaticPtr (StaticPtr (Dict (Binary b, Show b, Eq b))
 -> Dict (Binary b, Show b, Eq b))
-> StaticPtr (Dict (Binary b, Show b, Eq b))
-> Dict (Binary b, Show b, Eq b)
forall a b. (a -> b) -> a -> b
$ Static 'User (Dict (Binary b, Show b, Eq b))
-> StaticPtr (Dict (Binary b, Show b, Eq b))
forall fnTy. Static 'User fnTy -> StaticPtr fnTy
userStaticPtr Static 'User (Dict (Binary b, Show b, Eq b))
instsPtr of
                    (Dict (Binary b, Show b, Eq b)
Dict :: Dict (Binary depsRes, Show depsRes, Eq depsRes)) ->
                      do
                        ruleCmd 'User b (b -> IO ())
ruleCmd <- forall t. Binary t => Get t
get @(ruleCmd User arg (depsRes -> IO ()))
                        deps 'User b b
deps <- forall t. Binary t => Get t
get @(deps User depsArg depsRes)
                        RuleCommands 'User deps ruleCmd
-> Get (RuleCommands 'User deps ruleCmd)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleCommands 'User deps ruleCmd
 -> Get (RuleCommands 'User deps ruleCmd))
-> RuleCommands 'User deps ruleCmd
-> Get (RuleCommands 'User deps ruleCmd)
forall a b. (a -> b) -> a -> b
$
                          TypeRep b
-> (Typeable b => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
Typeable.withTypeable TypeRep b
trDepsArg ((Typeable b => RuleCommands 'User deps ruleCmd)
 -> RuleCommands 'User deps ruleCmd)
-> (Typeable b => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall a b. (a -> b) -> a -> b
$
                            TypeRep b
-> (Typeable b => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
Typeable.withTypeable TypeRep b
trDepsRes ((Typeable b => RuleCommands 'User deps ruleCmd)
 -> RuleCommands 'User deps ruleCmd)
-> (Typeable b => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall a b. (a -> b) -> a -> b
$
                              TypeRep b
-> (Typeable b => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall k (a :: k) r. TypeRep a -> (Typeable a => r) -> r
Typeable.withTypeable TypeRep b
trArg ((Typeable b => RuleCommands 'User deps ruleCmd)
 -> RuleCommands 'User deps ruleCmd)
-> (Typeable b => RuleCommands 'User deps ruleCmd)
-> RuleCommands 'User deps ruleCmd
forall a b. (a -> b) -> a -> b
$
                                DynamicRuleCommands
                                  { dynamicDeps :: deps 'User b b
dynamicDeps = deps 'User b b
deps
                                  , dynamicRuleCommand :: ruleCmd 'User b (b -> IO ())
dynamicRuleCommand = ruleCmd 'User b (b -> IO ())
ruleCmd
                                  , dynamicRuleInstances :: Static 'User (Dict (Binary b, Show b, Eq b))
dynamicRuleInstances = Static 'User (Dict (Binary b, Show b, Eq b))
instsPtr
                                  , dynamicRuleTypeRep :: If ('User == 'System) SomeTypeRep (TypeRep (b, b, b))
dynamicRuleTypeRep = TypeRep a
If ('User == 'System) SomeTypeRep (TypeRep (b, b, b))
tr
                                  }
          TypeRep a
_ -> String -> Get (RuleCommands 'User deps ruleCmd)
forall a. HasCallStack => String -> a
error String
"internal error when decoding dynamic rule commands"

-- | A token constructor used to define 'Structured' instances on types
-- that involve existential quantification.
data family Tok (arg :: Symbol) :: k

instance
  ( forall res. Binary (ruleCmd System LBS.ByteString res)
  , Binary (deps System LBS.ByteString LBS.ByteString)
  )
  => Binary (RuleCommands System deps ruleCmd)
  where
  put :: RuleCommands 'System deps ruleCmd -> Put
put = \case
    StaticRuleCommand{staticRuleCommand :: ()
staticRuleCommand = ruleCmd 'System arg (IO ())
ruleCmd, staticRuleArgRep :: ()
staticRuleArgRep = If ('System == 'System) SomeTypeRep (TypeRep arg)
sTr} -> do
      forall t. Binary t => t -> Put
put @Word Word
0
      SomeTypeRep -> Put
forall t. Binary t => t -> Put
put SomeTypeRep
If ('System == 'System) SomeTypeRep (TypeRep arg)
sTr
      ruleCmd 'System arg (IO ()) -> Put
forall t. Binary t => t -> Put
put ruleCmd 'System arg (IO ())
ruleCmd
    DynamicRuleCommands
      { dynamicDeps :: ()
dynamicDeps = deps 'System depsArg depsRes
deps
      , dynamicRuleCommand :: ()
dynamicRuleCommand = ruleCmd 'System arg (depsRes -> IO ())
ruleCmd
      , dynamicRuleInstances :: ()
dynamicRuleInstances = Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsKey
      , dynamicRuleTypeRep :: ()
dynamicRuleTypeRep = If
  ('System == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
sTr
      } ->
        do
          forall t. Binary t => t -> Put
put @Word Word
1
          SomeTypeRep -> Put
forall t. Binary t => t -> Put
put SomeTypeRep
If
  ('System == 'System) SomeTypeRep (TypeRep (depsArg, depsRes, arg))
sTr
          Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
-> Put
forall t. Binary t => t -> Put
put Static 'System (Dict (Binary depsRes, Show depsRes, Eq depsRes))
instsKey
          ruleCmd 'System arg (depsRes -> IO ()) -> Put
forall t. Binary t => t -> Put
put ruleCmd 'System arg (depsRes -> IO ())
ruleCmd
          deps 'System depsArg depsRes -> Put
forall t. Binary t => t -> Put
put deps 'System depsArg depsRes
deps
  get :: Get (RuleCommands 'System deps ruleCmd)
get = do
    Word
tag <- forall t. Binary t => Get t
get @Word
    case Word
tag of
      Word
0 -> do
        SomeTypeRep
sTr <- forall t. Binary t => Get t
get @Typeable.SomeTypeRep
        ruleCmd 'System ByteString (IO ())
ruleCmd <- Get (ruleCmd 'System ByteString (IO ()))
forall t. Binary t => Get t
get
        RuleCommands 'System deps ruleCmd
-> Get (RuleCommands 'System deps ruleCmd)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleCommands 'System deps ruleCmd
 -> Get (RuleCommands 'System deps ruleCmd))
-> RuleCommands 'System deps ruleCmd
-> Get (RuleCommands 'System deps ruleCmd)
forall a b. (a -> b) -> a -> b
$
          StaticRuleCommand
            { staticRuleCommand :: ruleCmd 'System ByteString (IO ())
staticRuleCommand = ruleCmd 'System ByteString (IO ())
ruleCmd
            , staticRuleArgRep :: If ('System == 'System) SomeTypeRep (TypeRep ByteString)
staticRuleArgRep = SomeTypeRep
If ('System == 'System) SomeTypeRep (TypeRep ByteString)
sTr
            }
      Word
_ -> do
        SomeTypeRep
sTr <- forall t. Binary t => Get t
get @Typeable.SomeTypeRep
        Static
  'System (Dict (Binary ByteString, Show ByteString, Eq ByteString))
instsKey <- Get
  (Static
     'System (Dict (Binary ByteString, Show ByteString, Eq ByteString)))
forall t. Binary t => Get t
get
        ruleCmd 'System ByteString (ByteString -> IO ())
ruleCmd <- Get (ruleCmd 'System ByteString (ByteString -> IO ()))
forall t. Binary t => Get t
get
        deps 'System ByteString ByteString
deps <- Get (deps 'System ByteString ByteString)
forall t. Binary t => Get t
get
        RuleCommands 'System deps ruleCmd
-> Get (RuleCommands 'System deps ruleCmd)
forall a. a -> Get a
forall (m :: * -> *) a. Monad m => a -> m a
return (RuleCommands 'System deps ruleCmd
 -> Get (RuleCommands 'System deps ruleCmd))
-> RuleCommands 'System deps ruleCmd
-> Get (RuleCommands 'System deps ruleCmd)
forall a b. (a -> b) -> a -> b
$
          DynamicRuleCommands
            { dynamicDeps :: deps 'System ByteString ByteString
dynamicDeps = deps 'System ByteString ByteString
deps
            , dynamicRuleCommand :: ruleCmd 'System ByteString (ByteString -> IO ())
dynamicRuleCommand = ruleCmd 'System ByteString (ByteString -> IO ())
ruleCmd
            , dynamicRuleInstances :: Static
  'System (Dict (Binary ByteString, Show ByteString, Eq ByteString))
dynamicRuleInstances = Static
  'System (Dict (Binary ByteString, Show ByteString, Eq ByteString))
instsKey
            , dynamicRuleTypeRep :: If
  ('System == 'System)
  SomeTypeRep
  (TypeRep (ByteString, ByteString, ByteString))
dynamicRuleTypeRep = SomeTypeRep
If
  ('System == 'System)
  SomeTypeRep
  (TypeRep (ByteString, ByteString, ByteString))
sTr
            }

--------------------------------------------------------------------------------
-- Showing rules

ruleBinary :: Rule -> RuleBinary
ruleBinary :: Rule -> RuleBinary
ruleBinary = ByteString -> RuleBinary
forall a. Binary a => ByteString -> a
Binary.decode (ByteString -> RuleBinary)
-> (Rule -> ByteString) -> Rule -> RuleBinary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rule -> ByteString
forall a. Binary a => a -> ByteString
Binary.encode