lol

Author: sheaf

Cabal/src/Distribution/Simple/SetupHooks/Rule.hs

@@ -493,14 +493,17 @@ newtype instance Static User fnTy = UserStatic {userStaticPtr :: StaticPtr fnTy}
 newtype instance Static System fnTy = SystemStatic {userStaticKey :: StaticKey}
   deriving newtype (Eq, Ord, Show, Binary)
 
+systemStatic :: Static User fnTy -> Static System fnTy
+systemStatic (UserStatic ptr) = SystemStatic (staticKey ptr)
+
 instance Show (Static User fnTy) where
-  showsPrec p ptr = showsPrec p (staticKey $ userStaticPtr ptr)
+  showsPrec p ptr = showsPrec p (systemStatic ptr)
 instance Eq (Static User fnTy) where
-  (==) = (==) `on` (staticKey . userStaticPtr)
+  (==) = (==) `on` systemStatic
 instance Ord (Static User fnTy) where
-  compare = compare `on` (staticKey . userStaticPtr)
+  compare = compare `on` systemStatic
 instance Binary (Static User fnTy) where
-  put (UserStatic ptr) = put (staticKey ptr)
+  put = put . systemStatic
   get = do
     ptrKey <- get @StaticKey
     case unsafePerformIO $ unsafeLookupStaticPtr ptrKey of
@@ -525,7 +528,7 @@ type Command = CommandData User
 data CommandData (scope :: Scope) (arg :: Hs.Type) (res :: Hs.Type) = Command
   { actionPtr :: !(Static scope (arg -> res))
   -- ^ The (statically-known) action to execute.
-  , actionArg :: !(BinaryArg scope arg)
+  , actionArg :: !(ScopedArgument scope arg)
   -- ^ The (possibly dynamic) argument to pass to the action.
   , cmdInstances :: !(Static scope (Dict (Binary arg, Show arg)))
   -- ^ Static evidence that the argument can be serialised and deserialised.
@@ -543,13 +546,13 @@ mkCommand
 mkCommand dict actionPtr arg =
   Command
     { actionPtr = UserStatic actionPtr
-    , actionArg = BinaryArg arg
+    , actionArg = ScopedArgument arg
     , cmdInstances = UserStatic dict
     }
 
 -- | Run a 'Command'.
 runCommand :: Command args res -> res
-runCommand (Command{actionPtr = UserStatic ptr, actionArg = BinaryArg arg}) =
+runCommand (Command{actionPtr = UserStatic ptr, actionArg = ScopedArgument arg}) =
   deRefStaticPtr ptr arg
 
 -- | Commands to execute a rule:
@@ -626,7 +629,7 @@ 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
-trated as opaque blobs of data (in particular if the Hooks are compiled into
+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).
@@ -650,29 +653,29 @@ an 'Int64', we are nevertheless required to also serialise its size. This is bec
 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 'BinaryArg' newtype is used, with a custom 'Binary' instance that always
+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 BinaryArg (scope :: Scope) arg = BinaryArg {getArg :: arg}
+newtype ScopedArgument (scope :: Scope) arg = ScopedArgument {getArg :: arg}
   deriving newtype (Eq, Ord, Show)
 
 -- | Serialise/deserialise, always including the length of the payload.
-instance Binary arg => Binary (BinaryArg User arg) where
-  put (BinaryArg arg) = put @LBS.ByteString (Binary.encode arg)
+instance Binary arg => Binary (ScopedArgument User arg) where
+  put (ScopedArgument arg) = put @LBS.ByteString (Binary.encode arg)
   get = do
     dat <- get @LBS.ByteString
     case Binary.decodeOrFail dat of
       Left (_, _, err) -> fail err
-      Right (_, _, res) -> return $ BinaryArg res
+      Right (_, _, res) -> return $ ScopedArgument res
 
 -- | Serialise and deserialise a raw ByteString, leaving it untouched.
-instance arg ~ LBS.ByteString => Binary (BinaryArg System arg) where
-  put (BinaryArg arg) = put arg
-  get = BinaryArg <$> get
+instance arg ~ LBS.ByteString => Binary (ScopedArgument System arg) where
+  put (ScopedArgument arg) = put arg
+  get = ScopedArgument <$> 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.
@@ -681,7 +684,10 @@ data NoCmd (scope :: Scope) arg res = CmdOmitted
   deriving anyclass (Binary)
 
 -- | A dynamic dependency command.
-newtype DynDepsCmd scope depsArg depsRes = DynDepsCmd {dynDepsCmd :: CommandData scope depsArg (IO ([Dependency], depsRes))}
+newtype DynDepsCmd scope depsArg depsRes = DynDepsCmd
+  { dynDepsCmd
+      :: CommandData scope depsArg (IO ([Dependency], depsRes))
+  }
 
 deriving newtype instance Show (DynDepsCmd User depsArg depsRes)
 deriving newtype instance Eq (DynDepsCmd User depsArg depsRes)
@@ -694,9 +700,16 @@ deriving newtype instance
   => Binary (DynDepsCmd System arg depsRes)
 
 -- | The result of a dynamic dependency computation.
-newtype DepsRes (scope :: Scope) depsArg depsRes = DepsRes {depsRes :: BinaryArg scope depsRes}
+newtype DepsRes (scope :: Scope) depsArg depsRes = DepsRes
+  { depsRes
+      :: ScopedArgument scope depsRes -- See Note [Hooks Binary instances]
+  }
   deriving newtype (Show, Eq, 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
 
@@ -743,7 +756,8 @@ runRuleDynDepsCmd = \case
       | Dict <- deRefStaticPtr instsPtr ->
           Just $ do
             (deps, depsRes) <- runCommand depsCmd
-            return $ (deps, Binary.encode depsRes)
+            -- See Note [Hooks Binary instances]
+            return $ (deps, Binary.encode $ ScopedArgument @User depsRes)
 
 -- | Project out the command for running the rule, passing in the result of
 -- the dependency computation if there was one.
@@ -783,7 +797,7 @@ ruleExecCmd
             DynamicRuleCommands
               { dynamicRuleInstances = instsPtr
               , dynamicRuleCommand = cmd
-              , dynamicDeps = DepsRes $ BinaryArg depsResBinary
+              , dynamicDeps = DepsRes $ ScopedArgument depsResBinary
               , dynamicRuleTypeRep = tr
               }
 
@@ -792,7 +806,7 @@ runRuleExecCmd :: RuleExecCmd User -> IO ()
 runRuleExecCmd = \case
   StaticRuleCommand{staticRuleCommand = cmd} -> runCommand cmd
   DynamicRuleCommands
-    { dynamicDeps = DepsRes (BinaryArg{getArg = res})
+    { dynamicDeps = DepsRes (ScopedArgument{getArg = res})
     , dynamicRuleCommand = cmd
     } ->
       runCommand cmd res
@@ -930,12 +944,6 @@ instance
     a1 == a2 && b1 == b2 && c1 == c2 && d1 == d2
   _ == _ = False
 
-instance Binary (BinaryArg scope depsRes) => Binary (DepsRes scope depsArgs depsRes) where
-  put (DepsRes deps) = put $ Binary.encode deps -- See Note [put/get ByteString]
-  get = do
-    bs <- get
-    return $ DepsRes $ Binary.decode bs -- See Note [put/get ByteString]
-
 instance
   ( forall arg res. Binary (ruleCmd User arg res)
   , forall depsArg depsRes. Binary depsRes => Binary (deps User depsArg depsRes)
@@ -1054,7 +1062,8 @@ instance
             , dynamicRuleTypeRep = sTr
             }
 
--- | Convenience function used for the pretty-printing @'Show' 'RuleBinary'@
--- instance.
+--------------------------------------------------------------------------------
+-- Showing rules
+
 ruleBinary :: Rule -> RuleBinary
 ruleBinary = Binary.decode . Binary.encode