diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml deleted file mode 100644 --- a/.gitlab-ci.yml +++ /dev/null @@ -1,33 +0,0 @@ -before_script: - # Report the versions of varioius software, to make diagnosing problems - # easier: - - ghc --version - - cabal --version - - capnp --version - - stylish-haskell --version - - hlint --version - # Update the hackage databse: - - cabal update -test:alltests: - image: zenhack/haskell-capnp-ci - variables: - CXX_CALCULATOR_CLIENT: /usr/local/bin/c++-calculator-client - CXX_CALCULATOR_SERVER: /usr/local/bin/c++-calculator-server - script: - # First build the code generator plugin. - - cabal new-build capnpc-haskell - # Then, regenerate the schema modules, and make sure they're in-sync - # with what was committed. This is also necessary to generate the - # Schema modules used by the test suite, which are not committed. - - ./scripts/regen.sh - - git diff --exit-code - # Now build everything else (incl. examples): - - cabal new-build all - # ...run the tests. We use new-run so we can pass rts options - # to the test binary -- these tell it to parallelize the tests. - - cabal new-run test:tests -- +RTS -N - # Linting: - - ./scripts/hlint.sh - # Run stylish-haskell, and fail if it changes anything: - - ./scripts/format.sh - - git diff --exit-code diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,13 @@ +# 0.17.0.0 + +- Get rid of the New qualifier in module paths, now that the old + API has been removed. +- Remove references to the old API from the tutorial. +- Add two new modules: + - `Capnp.Rpc.Membrane`, which provides helpers for implementing + membranes. + - `Capnp.Rpc.Revoke`, which supports revocable capabilities. + # 0.16.0.0 - Updated to work with GHC 9.2.x. In particular: diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,3 @@ -[![build status][ci-img]][ci] [![hackage][hackage-img]][hackage] A Haskell library for the [Cap'N Proto][1] Cerialization and RPC @@ -38,9 +37,6 @@ [issue27]: https://github.com/zenhack/haskell-capnp/issues/27 [issue28]: https://github.com/zenhack/haskell-capnp/issues/28 - -[ci-img]: https://gitlab.com/isd/haskell-capnp/badges/master/pipeline.svg -[ci]: https://gitlab.com/isd/haskell-capnp/pipelines [hackage-img]: https://img.shields.io/hackage/v/capnp.svg [hackage]: https://hackage.haskell.org/package/capnp diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,64 +1,68 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -module Main (main) where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +module Main (main) where -import Capnp.Mutability (thaw) -import qualified Capnp.New as C -import qualified Capnp.Untyped as U -import Control.DeepSeq (NFData(..)) -import Control.Monad (unless) -import Criterion.Main -import qualified Data.ByteString as BS -import System.Exit (ExitCode(..)) +import qualified Capnp as C +import Capnp.Mutability (thaw) +import qualified Capnp.Untyped as U +import Control.DeepSeq (NFData (..)) +import Control.Monad (unless) +import Criterion.Main +import qualified Data.ByteString as BS +import System.Exit (ExitCode (..)) import qualified System.Process.ByteString as PB -- Get the raw bytes of a CodeGeneratorRequest for all of the bundled -- capnproto core schema. Useful as a source of generic test data. getCGRBytes :: IO BS.ByteString getCGRBytes = do - (exit, cgrBytes, _) <- PB.readProcessWithExitCode "capnp" - [ "compile", "-o-" - , "-I", "core-schema/" - , "--src-prefix=core-schema/" - , "core-schema/capnp/schema.capnp" - , "core-schema/capnp/stream.capnp" - , "core-schema/capnp/rpc-twoparty.capnp" - , "core-schema/capnp/persistent.capnp" - , "core-schema/capnp/rpc.capnp" - , "core-schema/capnp/compat/json.capnp" - , "core-schema/capnp/c++.capnp" - ] - "" - unless (exit == ExitSuccess) $ error "capnp compile failed" - pure cgrBytes + (exit, cgrBytes, _) <- + PB.readProcessWithExitCode + "capnp" + [ "compile", + "-o-", + "-I", + "core-schema/", + "--src-prefix=core-schema/", + "core-schema/capnp/schema.capnp", + "core-schema/capnp/stream.capnp", + "core-schema/capnp/rpc-twoparty.capnp", + "core-schema/capnp/persistent.capnp", + "core-schema/capnp/rpc.capnp", + "core-schema/capnp/compat/json.capnp", + "core-schema/capnp/c++.capnp" + ] + "" + unless (exit == ExitSuccess) $ error "capnp compile failed" + pure cgrBytes instance NFData (C.Message mut) where - rnf = (`seq` ()) + rnf = (`seq` ()) main :: IO () main = do - cgrBytes <- getCGRBytes - msg <- C.bsToMsg cgrBytes - let whnfLTIO = whnfIO . C.evalLimitT maxBound - defaultMain - [ bench "canonicalize/IO" $ whnfLTIO $ do - root <- U.rootPtr msg - C.canonicalize root - , bench "canonicalize/PureBuilder" $ whnfLTIO $ do - C.createPure maxBound $ do - root <- U.rootPtr msg - (msg, _seg) <- C.canonicalize root - pure msg - , env - (C.evalLimitT maxBound $ do - mutMsg <- thaw msg - newMsg <- C.newMessage Nothing - pure (mutMsg, newMsg) - ) - (\ ~(mutMsg, newMsg) -> bench "copy" $ whnfLTIO $ do - root <- U.rootPtr mutMsg - U.copyPtr newMsg (Just (U.PtrStruct root)) - ) - ] + cgrBytes <- getCGRBytes + msg <- C.bsToMsg cgrBytes + let whnfLTIO = whnfIO . C.evalLimitT maxBound + defaultMain + [ bench "canonicalize/IO" $ whnfLTIO $ do + root <- U.rootPtr msg + C.canonicalize root, + bench "canonicalize/PureBuilder" $ whnfLTIO $ do + C.createPure maxBound $ do + root <- U.rootPtr msg + (msg, _seg) <- C.canonicalize root + pure msg, + env + ( C.evalLimitT maxBound $ do + mutMsg <- thaw msg + newMsg <- C.newMessage Nothing + pure (mutMsg, newMsg) + ) + ( \ ~(mutMsg, newMsg) -> bench "copy" $ whnfLTIO $ do + root <- U.rootPtr mutMsg + U.copyPtr newMsg (Just (U.PtrStruct root)) + ) + ] diff --git a/capnp.cabal b/capnp.cabal --- a/capnp.cabal +++ b/capnp.cabal @@ -1,8 +1,8 @@ cabal-version: 2.2 name: capnp -version: 0.16.0.0 +version: 0.17.0.0 category: Data, Serialization, Network, Rpc -copyright: 2016-2022 haskell-capnp contributors (see CONTRIBUTORS file). +copyright: 2016-2023 haskell-capnp contributors (see CONTRIBUTORS file). author: Ian Denhardt maintainer: ian@zenhack.net license: MIT @@ -40,7 +40,6 @@ , .stylish-haskell.yaml , .gitattributes , .gitignore - , .gitlab-ci.yml -------------------------------------------------------------------------------- @@ -59,13 +58,13 @@ , containers >= 0.5.9 && <0.7 , data-default ^>= 0.7.1 , exceptions ^>= 0.10.0 - , ghc-prim >= 0.6.1 && <0.9 - , mtl ^>= 2.2.2 + , ghc-prim >= 0.6.1 && <0.10 + , mtl >= 2.2.2 && <2.4 , primitive >= 0.6.3 && <0.8 , safe-exceptions ^>= 0.1.7 - , text >= 1.2 && < 2.0 + , text >= 1.2 && < 2.1 , transformers >= 0.5.2 && <0.7 - , vector ^>= 0.12.0 + , vector >= 0.12.0 && <0.14 , monad-stm ^>= 0.1 ghc-options: -Wall @@ -95,18 +94,21 @@ Capnp.Address , Capnp.Bits , Capnp.Canonicalize - , Capnp.New - , Capnp.New.Accessors - , Capnp.New.Basics - , Capnp.New.Classes - , Capnp.New.Constraints - , Capnp.New.Rpc.Common + , Capnp + , Capnp.Accessors + , Capnp.Basics + , Capnp.Classes + , Capnp.Constraints + , Capnp.Rpc.Common + , Capnp.Rpc.Membrane + , Capnp.Rpc.Server + , Capnp.Rpc.Revoke , Capnp.New.Rpc.Server , Capnp.Convert , Capnp.Errors , Capnp.Fields - , Capnp.GenHelpers.New - , Capnp.GenHelpers.New.Rpc + , Capnp.GenHelpers + , Capnp.GenHelpers.Rpc , Capnp.IO , Capnp.Message , Capnp.Mutability @@ -121,7 +123,6 @@ , Capnp.Rpc.Untyped , Capnp.Rpc.Errors , Capnp.Rpc.Transport - , Capnp.Rpc.Server , Capnp.Tutorial , Data.Mutable @@ -130,21 +131,21 @@ , Capnp.Gen.Capnp -- BEGIN GENERATED SCHEMA MODULES - , Capnp.Gen.Capnp.Cxx.New - , Capnp.Gen.Capnp.Compat.Json.New - , Capnp.Gen.Capnp.Persistent.New - , Capnp.Gen.Capnp.Rpc.New - , Capnp.Gen.Capnp.RpcTwoparty.New - , Capnp.Gen.Capnp.Schema.New - , Capnp.Gen.Capnp.Stream.New + , Capnp.Gen.Capnp.Cxx + , Capnp.Gen.Capnp.Compat.Json + , Capnp.Gen.Capnp.Persistent + , Capnp.Gen.Capnp.Rpc + , Capnp.Gen.Capnp.RpcTwoparty + , Capnp.Gen.Capnp.Schema + , Capnp.Gen.Capnp.Stream - , Capnp.Gen.ById.Xbdf87d7bb8304e81.New - , Capnp.Gen.ById.X8ef99297a43a5e34.New - , Capnp.Gen.ById.Xb8630836983feed7.New - , Capnp.Gen.ById.Xb312981b2552a250.New - , Capnp.Gen.ById.Xa184c7885cdaf2a1.New - , Capnp.Gen.ById.Xa93fc509624c72d9.New - , Capnp.Gen.ById.X86c366a91393f3f8.New + , Capnp.Gen.ById.Xbdf87d7bb8304e81 + , Capnp.Gen.ById.X8ef99297a43a5e34 + , Capnp.Gen.ById.Xb8630836983feed7 + , Capnp.Gen.ById.Xb312981b2552a250 + , Capnp.Gen.ById.Xa184c7885cdaf2a1 + , Capnp.Gen.ById.Xa93fc509624c72d9 + , Capnp.Gen.ById.X86c366a91393f3f8 -- END GENERATED SCHEMA MODULES other-modules: Internal.AppendVec @@ -153,9 +154,10 @@ , Internal.TCloseQ , Internal.BuildPure , Internal.STE + , Internal.Rpc.Breaker -- other-extensions: build-depends: - hashable >= 1.2.7 && <1.4 + hashable >= 1.2.7 && <1.5 , data-default-instances-vector ^>= 0.0.1 , stm ^>= 2.5.0 , stm-containers >= 1.1.0 && <1.3 @@ -167,7 +169,7 @@ , supervisors ^>= 0.2.1 , lifetimes ^>= 0.1 , pretty-show >= 1.9.5 && <1.11 - , template-haskell ^>=2.18 + , template-haskell >=2.18 && <2.20 -------------------------------------------------------------------------------- @@ -178,16 +180,16 @@ main-is: Main.hs other-modules: IR.Name - IR.New + , IR.AbstractOp , IR.Common , IR.Stage1 , IR.Flat , IR.Haskell , Trans.CgrToStage1 , Trans.Stage1ToFlat - , Trans.FlatToNew + , Trans.FlatToAbstractOp , Trans.ToHaskellCommon - , Trans.NewToHaskell + , Trans.AbstractOpToHaskell , Trans.HaskellToText , Check build-depends: @@ -220,20 +222,20 @@ , Examples.Rpc.CalculatorServer -- Generated code for examples/calculator.capnp - , Capnp.Gen.Calculator.New - , Capnp.Gen.ById.X85150b117366d14b.New + , Capnp.Gen.Calculator + , Capnp.Gen.ById.X85150b117366d14b -- Generated code for examples/echo.capnp - , Capnp.Gen.Echo.New - , Capnp.Gen.ById.Xd0a87f36fa0182f5.New + , Capnp.Gen.Echo + , Capnp.Gen.ById.Xd0a87f36fa0182f5 -- generated from tests/data/aircraft.capnp - , Capnp.Gen.Aircraft.New - , Capnp.Gen.ById.X832bcc6686a26d56.New + , Capnp.Gen.Aircraft + , Capnp.Gen.ById.X832bcc6686a26d56 -- generated from tests/data/generics.capnp - , Capnp.Gen.Generics.New - , Capnp.Gen.ById.Xb6421fb8e478d144.New + , Capnp.Gen.Generics + , Capnp.Gen.ById.Xb6421fb8e478d144 -- Actual tests: , Module.Capnp.Gen.Capnp.Schema @@ -278,6 +280,6 @@ hs-source-dirs: bench build-depends: capnp - , criterion ^>=1.5.9 + , criterion >=1.5.9 && <0.7 , deepseq , process-extras diff --git a/cmd/capnpc-haskell/Check.hs b/cmd/capnpc-haskell/Check.hs --- a/cmd/capnpc-haskell/Check.hs +++ b/cmd/capnpc-haskell/Check.hs @@ -1,13 +1,12 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} + module Check (reportIssues) where +import Capnp.Gen.Capnp.Schema import Data.Foldable (for_) -import System.IO (hPutStrLn, stderr) - import qualified Data.Vector as V - -import Capnp.Gen.Capnp.Schema.New +import System.IO (hPutStrLn, stderr) -- | Scan the code generator request for certain issues, and warn the user -- if found. @@ -15,42 +14,47 @@ -- We still assume the input is *valid*, so these are issues regarding things -- that our implementation can't handle. reportIssues :: Parsed CodeGeneratorRequest -> IO () -reportIssues CodeGeneratorRequest{nodes} = - let problemFields = - [ (displayName, name) - | Node{displayName, union'=Node'struct Node'struct'{fields}} <- V.toList nodes - , Field - { name - , union'=Field'slot Field'slot'{hadExplicitDefault, defaultValue} - } <- V.toList fields - , hadExplicitDefault && isPtrValue defaultValue - ] - in - for_ problemFields $ \(displayName, name) -> - hPutStrLn stderr $ concat - [ "WARNING: the field ", show name, " in ", show displayName, "\n" - , " has a custom default value, but haskell-capnp does not\n" - , " support this for pointer-valued fields. The custom\n" - , " default will be ignored; please be careful. See:\n" - , "\n" - , "https://github.com/zenhack/haskell-capnp/issues/28\n" - , "\n" - , "for more information.\n" +reportIssues CodeGeneratorRequest {nodes} = + let problemFields = + [ (displayName, name) + | Node {displayName, union' = Node'struct Node'struct' {fields}} <- V.toList nodes, + Field + { name, + union' = Field'slot Field'slot' {hadExplicitDefault, defaultValue} + } <- + V.toList fields, + hadExplicitDefault && isPtrValue defaultValue + ] + in for_ problemFields $ \(displayName, name) -> + hPutStrLn stderr $ + concat + [ "WARNING: the field ", + show name, + " in ", + show displayName, + "\n", + " has a custom default value, but haskell-capnp does not\n", + " support this for pointer-valued fields. The custom\n", + " default will be ignored; please be careful. See:\n", + "\n", + "https://github.com/zenhack/haskell-capnp/issues/28\n", + "\n", + "for more information.\n" ] isPtrValue :: Parsed Value -> Bool isPtrValue (Value v) = case v of - Value'void -> False - Value'bool _ -> False - Value'int8 _ -> False - Value'int16 _ -> False - Value'int32 _ -> False - Value'int64 _ -> False - Value'uint8 _ -> False - Value'uint16 _ -> False - Value'uint32 _ -> False - Value'uint64 _ -> False - Value'float32 _ -> False - Value'float64 _ -> False - Value'enum _ -> False - _ -> True + Value'void -> False + Value'bool _ -> False + Value'int8 _ -> False + Value'int16 _ -> False + Value'int32 _ -> False + Value'int64 _ -> False + Value'uint8 _ -> False + Value'uint16 _ -> False + Value'uint32 _ -> False + Value'uint64 _ -> False + Value'float32 _ -> False + Value'float64 _ -> False + Value'enum _ -> False + _ -> True diff --git a/cmd/capnpc-haskell/IR/AbstractOp.hs b/cmd/capnpc-haskell/IR/AbstractOp.hs new file mode 100644 --- /dev/null +++ b/cmd/capnpc-haskell/IR/AbstractOp.hs @@ -0,0 +1,94 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module IR.AbstractOp where + +import qualified Capnp.Repr as R +import Data.Word +import qualified IR.Common as C +import qualified IR.Name as Name + +type Brand = C.ListBrand Name.CapnpQ + +data File = File + { fileId :: !Word64, + decls :: [Decl], + fileName :: FilePath, + usesRpc :: !Bool + } + +data Decl + = TypeDecl + { name :: Name.LocalQ, + nodeId :: !Word64, + params :: [Name.UnQ], + repr :: R.Repr, + extraTypeInfo :: Maybe ExtraTypeInfo + } + | FieldDecl + { containerType :: Name.LocalQ, + typeParams :: [Name.UnQ], + fieldName :: Name.UnQ, + fieldLocType :: C.FieldLocType Brand Name.CapnpQ + } + | UnionDecl + { name :: Name.LocalQ, + typeParams :: [Name.UnQ], + tagLoc :: C.DataLoc, + variants :: [UnionVariant] + } + | MethodDecl + { interfaceName :: Name.LocalQ, + interfaceId :: !Word64, + methodId :: !Word16, + methodInfo :: MethodInfo + } + | SuperDecl + { subName :: Name.LocalQ, + typeParams :: [Name.UnQ], + superType :: C.InterfaceType Brand Name.CapnpQ + } + | ParsedInstanceDecl + { typeName :: Name.LocalQ, + typeParams :: [Name.UnQ], + parsedInstances :: ParsedInstances + } + | ConstDecl + { name :: Name.LocalQ, + value :: C.Value Brand Name.CapnpQ + } + +-- | Data needed for declaring a Parsed instance, and instances +-- of related classes. +data ParsedInstances + = ParsedStruct + { fields :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)], + hasUnion :: !Bool, + dataCtorName :: Name.LocalQ + } + | ParsedUnion + { variants :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)] + } + +data MethodInfo = MethodInfo + { typeParams :: [Name.UnQ], + methodName :: Name.UnQ, + paramType :: C.CompositeType Brand Name.CapnpQ, + resultType :: C.CompositeType Brand Name.CapnpQ + } + +data ExtraTypeInfo + = StructTypeInfo + { nWords :: !Word16, + nPtrs :: !Word16 + } + | EnumTypeInfo [Name.UnQ] + | InterfaceTypeInfo + { methods :: [MethodInfo], + supers :: [C.InterfaceType Brand Name.CapnpQ] + } + +data UnionVariant = UnionVariant + { variantName :: Name.UnQ, + tagValue :: !Word16, + fieldLocType :: C.FieldLocType Brand Name.CapnpQ + } diff --git a/cmd/capnpc-haskell/IR/Common.hs b/cmd/capnpc-haskell/IR/Common.hs --- a/cmd/capnpc-haskell/IR/Common.hs +++ b/cmd/capnpc-haskell/IR/Common.hs @@ -2,38 +2,38 @@ -- See also IR.Name, which defines identifiers, which are also -- used in more than one IR. {-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} + module IR.Common where +import qualified Capnp.Basics as B +import Capnp.Repr.Parsed (Parsed) +import Data.Bifunctor (Bifunctor (..)) +import qualified Data.Map.Strict as M +import qualified Data.Vector as V import Data.Word - -import qualified Capnp.New.Basics as B -import Capnp.Repr.Parsed (Parsed) -import Data.Bifunctor (Bifunctor(..)) -import qualified Data.Map.Strict as M -import qualified Data.Vector as V -import qualified IR.Name as Name +import qualified IR.Name as Name newtype TypeId = TypeId Word64 - deriving(Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord) data IntType = IntType !Sign !IntSize - deriving(Show, Read, Eq) + deriving (Show, Read, Eq) data Sign - = Signed - | Unsigned - deriving(Show, Read, Eq) + = Signed + | Unsigned + deriving (Show, Read, Eq) data IntSize - = Sz8 - | Sz16 - | Sz32 - | Sz64 - deriving(Show, Read, Eq) + = Sz8 + | Sz16 + | Sz32 + | Sz64 + deriving (Show, Read, Eq) sizeBits :: IntSize -> Int -sizeBits Sz8 = 8 +sizeBits Sz8 = 8 sizeBits Sz16 = 16 sizeBits Sz32 = 32 sizeBits Sz64 = 64 @@ -41,11 +41,11 @@ -- | Return the size in bits of a type that belongs in the data section of a struct. dataFieldSize :: WordType r -> Int dataFieldSize = \case - EnumType _ -> 16 - PrimWord (PrimInt (IntType _ size)) -> sizeBits size - PrimWord PrimFloat32 -> 32 - PrimWord PrimFloat64 -> 64 - PrimWord PrimBool -> 1 + EnumType _ -> 16 + PrimWord (PrimInt (IntType _ size)) -> sizeBits size + PrimWord PrimFloat32 -> 32 + PrimWord PrimFloat64 -> 64 + PrimWord PrimBool -> 1 -- Capnproto types. The 'r' type parameter is the type of references to other nodes, -- which may be different in different stages of the pipeline. Likewise, the 'b' @@ -55,160 +55,160 @@ bothMap f = bimap (fmap f) f newtype ListBrand r = ListBrand [PtrType (ListBrand r) r] - deriving(Show, Read, Eq) + deriving (Show, Read, Eq) instance Functor ListBrand where - fmap f (ListBrand ps) = ListBrand (fmap (bothMap f) ps) + fmap f (ListBrand ps) = ListBrand (fmap (bothMap f) ps) newtype MapBrand r = MapBrand (M.Map Word64 (BrandScope r)) - deriving(Show, Eq) + deriving (Show, Eq) instance Functor MapBrand where - fmap f (MapBrand m) = MapBrand $ fmap (fmap f) m + fmap f (MapBrand m) = MapBrand $ fmap (fmap f) m newtype BrandScope r = Bind (V.Vector (Binding r)) - deriving(Show, Eq) + deriving (Show, Eq) instance Functor BrandScope where - fmap f (Bind bs) = Bind $ fmap (fmap f) bs + fmap f (Bind bs) = Bind $ fmap (fmap f) bs data Binding r = Unbound | BoundType (PtrType (MapBrand r) r) - deriving(Show, Eq) + deriving (Show, Eq) instance Functor Binding where - fmap _ Unbound = Unbound - fmap f (BoundType ty) = BoundType $ bothMap f ty + fmap _ Unbound = Unbound + fmap f (BoundType ty) = BoundType $ bothMap f ty data TypeParamRef r = TypeParamRef - { paramScope :: r - , paramIndex :: !Int - , paramName :: Name.UnQ - } - deriving(Show, Read, Eq, Functor) + { paramScope :: r, + paramIndex :: !Int, + paramName :: Name.UnQ + } + deriving (Show, Read, Eq, Functor) data Type b r - = CompositeType (CompositeType b r) - | VoidType - | WordType (WordType r) - | PtrType (PtrType b r) - deriving(Show, Read, Eq, Functor) + = CompositeType (CompositeType b r) + | VoidType + | WordType (WordType r) + | PtrType (PtrType b r) + deriving (Show, Read, Eq, Functor) instance Bifunctor Type where - second = fmap - first f = \case - CompositeType x -> CompositeType (first f x) - VoidType -> VoidType - WordType x -> WordType x - PtrType x -> PtrType (first f x) + second = fmap + first f = \case + CompositeType x -> CompositeType (first f x) + VoidType -> VoidType + WordType x -> WordType x + PtrType x -> PtrType (first f x) data CompositeType b r - = StructType r b - deriving(Show, Read, Eq, Functor) + = StructType r b + deriving (Show, Read, Eq, Functor) instance Bifunctor CompositeType where - second = fmap - first f (StructType r b) = StructType r (f b) + second = fmap + first f (StructType r b) = StructType r (f b) data InterfaceType b r - = InterfaceType r b - deriving(Show, Read, Eq, Functor) + = InterfaceType r b + deriving (Show, Read, Eq, Functor) instance Bifunctor InterfaceType where - second = fmap - first f (InterfaceType r b) = InterfaceType r (f b) + second = fmap + first f (InterfaceType r b) = InterfaceType r (f b) data WordType r - = EnumType r - | PrimWord PrimWord - deriving(Show, Read, Eq, Functor) + = EnumType r + | PrimWord PrimWord + deriving (Show, Read, Eq, Functor) data PtrType b r - = ListOf (Type b r) - | PrimPtr PrimPtr - | PtrComposite (CompositeType b r) - | PtrInterface (InterfaceType b r) - | PtrParam (TypeParamRef r) - deriving(Show, Read, Eq, Functor) + = ListOf (Type b r) + | PrimPtr PrimPtr + | PtrComposite (CompositeType b r) + | PtrInterface (InterfaceType b r) + | PtrParam (TypeParamRef r) + deriving (Show, Read, Eq, Functor) instance Bifunctor PtrType where - second = fmap - first f = \case - ListOf x -> ListOf (first f x) - PrimPtr x -> PrimPtr x - PtrComposite x -> PtrComposite (first f x) - PtrInterface x -> PtrInterface (first f x) - PtrParam p -> PtrParam p + second = fmap + first f = \case + ListOf x -> ListOf (first f x) + PrimPtr x -> PrimPtr x + PtrComposite x -> PtrComposite (first f x) + PtrInterface x -> PtrInterface (first f x) + PtrParam p -> PtrParam p data PrimWord - = PrimInt IntType - | PrimFloat32 - | PrimFloat64 - | PrimBool - deriving(Show, Read, Eq) + = PrimInt IntType + | PrimFloat32 + | PrimFloat64 + | PrimBool + deriving (Show, Read, Eq) data PrimPtr - = PrimText - | PrimData - | PrimAnyPtr AnyPtr - deriving(Show, Read, Eq) + = PrimText + | PrimData + | PrimAnyPtr AnyPtr + deriving (Show, Read, Eq) data AnyPtr - = Struct - | List - | Cap - | Ptr - deriving(Show, Read, Eq) + = Struct + | List + | Cap + | Ptr + deriving (Show, Read, Eq) -- | The type and location of a field. data FieldLocType b r - -- | The field is in the struct's data section. - = DataField DataLoc (WordType r) - -- | The field is in the struct's pointer section (the argument is the + = -- | The field is in the struct's data section. + DataField DataLoc (WordType r) + | -- | The field is in the struct's pointer section (the argument is the -- index). - | PtrField !Word16 (PtrType b r) - -- | The field is a group or union; it's "location" is the whole struct. - | HereField (CompositeType b r) - -- | The field is of type void (and thus is zero-size). - | VoidField - deriving(Show, Read, Eq, Functor) + PtrField !Word16 (PtrType b r) + | -- | The field is a group or union; it's "location" is the whole struct. + HereField (CompositeType b r) + | -- | The field is of type void (and thus is zero-size). + VoidField + deriving (Show, Read, Eq, Functor) instance Bifunctor FieldLocType where - second = fmap - first f = \case - DataField l t -> DataField l t - PtrField idx t -> PtrField idx (first f t) - HereField t -> HereField (first f t) - VoidField -> VoidField + second = fmap + first f = \case + DataField l t -> DataField l t + PtrField idx t -> PtrField idx (first f t) + HereField t -> HereField (first f t) + VoidField -> VoidField -- | The location of a field within a struct's data section. data DataLoc = DataLoc - { dataIdx :: !Int - -- ^ The index of the 64-bit word containing the field. - , dataOff :: !Int - -- ^ The bit offset inside the 64-bit word. - , dataDef :: !Word64 - -- ^ The value is stored xor-ed with this value. This is used + { -- | The index of the 64-bit word containing the field. + dataIdx :: !Int, + -- | The bit offset inside the 64-bit word. + dataOff :: !Int, + -- | The value is stored xor-ed with this value. This is used -- to allow for encoding default values. Note that this is xor-ed -- with the bits representing the value, not the whole word. - } - deriving(Show, Read, Eq) + dataDef :: !Word64 + } + deriving (Show, Read, Eq) data Value b r - = VoidValue - | WordValue (WordType r) !Word64 - | PtrValue (PtrType b r) (Maybe (Parsed B.AnyPointer)) - deriving(Show, Eq, Functor) + = VoidValue + | WordValue (WordType r) !Word64 + | PtrValue (PtrType b r) (Maybe (Parsed B.AnyPointer)) + deriving (Show, Eq, Functor) instance Bifunctor Value where - second = fmap - first f = \case - VoidValue -> VoidValue - WordValue t v -> WordValue t v - PtrValue t v -> PtrValue (first f t) v + second = fmap + first f = \case + VoidValue -> VoidValue + WordValue t v -> WordValue t v + PtrValue t v -> PtrValue (first f t) v -- | Extract the type from a 'FildLocType'. fieldType :: FieldLocType r b -> Type r b fieldType (DataField _ ty) = WordType ty -fieldType (PtrField _ ty) = PtrType ty -fieldType (HereField ty) = CompositeType ty -fieldType VoidField = VoidType +fieldType (PtrField _ ty) = PtrType ty +fieldType (HereField ty) = CompositeType ty +fieldType VoidField = VoidType diff --git a/cmd/capnpc-haskell/IR/Flat.hs b/cmd/capnpc-haskell/IR/Flat.hs --- a/cmd/capnpc-haskell/IR/Flat.hs +++ b/cmd/capnpc-haskell/IR/Flat.hs @@ -1,88 +1,87 @@ {-# LANGUAGE DuplicateRecordFields #-} + module IR.Flat - ( File(..) - , CodeGenReq(..) - , Node(..) - , Node'(..) - , Field(..) - , Method(..) - , Variant(..) - , Union(..) - ) where + ( File (..), + CodeGenReq (..), + Node (..), + Node' (..), + Field (..), + Method (..), + Variant (..), + Union (..), + ) +where import Data.Word - import qualified IR.Common as Common -import qualified IR.Name as Name +import qualified IR.Name as Name type Brand = Common.ListBrand Node data CodeGenReq = CodeGenReq - { allNodes :: [Node] - , reqFiles :: [File] - } - deriving(Show, Eq) + { allNodes :: [Node], + reqFiles :: [File] + } + deriving (Show, Eq) data File = File - { nodes :: [Node] - , fileId :: !Word64 - , fileName :: FilePath - } - deriving(Show, Eq) + { nodes :: [Node], + fileId :: !Word64, + fileName :: FilePath + } + deriving (Show, Eq) data Node = Node - { name :: Name.CapnpQ - , nodeId :: !Word64 - , union_ :: Node' - , typeParams :: [Common.TypeParamRef Node] - } - deriving(Show, Eq) + { name :: Name.CapnpQ, + nodeId :: !Word64, + union_ :: Node', + typeParams :: [Common.TypeParamRef Node] + } + deriving (Show, Eq) data Node' - = Enum [Name.UnQ] - | Struct - { fields :: [Field] - -- ^ The struct's fields, excluding an anonymous union, if any. - , isGroup :: !Bool - , dataWordCount :: !Word16 - , pointerCount :: !Word16 - , union :: Maybe Union - -- ^ The struct's anonymous union, if any. - } - | Interface - { methods :: [Method] - , supers :: [Common.InterfaceType Brand Node] - } - | Constant - { value :: Common.Value Brand Node - } - | Other - deriving(Show, Eq) - + = Enum [Name.UnQ] + | Struct + { -- | The struct's fields, excluding an anonymous union, if any. + fields :: [Field], + isGroup :: !Bool, + dataWordCount :: !Word16, + pointerCount :: !Word16, + -- | The struct's anonymous union, if any. + union :: Maybe Union + } + | Interface + { methods :: [Method], + supers :: [Common.InterfaceType Brand Node] + } + | Constant + { value :: Common.Value Brand Node + } + | Other + deriving (Show, Eq) data Method = Method - { name :: Name.UnQ - , paramType :: Common.CompositeType Brand Node - , resultType :: Common.CompositeType Brand Node - } - deriving(Show, Eq) - + { name :: Name.UnQ, + paramType :: Common.CompositeType Brand Node, + resultType :: Common.CompositeType Brand Node + } + deriving (Show, Eq) data Union = Union - { tagOffset :: !Word32 - , variants :: [Variant] - } - deriving(Show, Eq) + { tagOffset :: !Word32, + variants :: [Variant] + } + deriving (Show, Eq) data Field = Field - { fieldName :: Name.CapnpQ - , fieldLocType :: Common.FieldLocType Brand Node - } - deriving(Show, Eq) + { fieldName :: Name.CapnpQ, + fieldLocType :: Common.FieldLocType Brand Node + } + deriving (Show, Eq) data Variant = Variant - { tagValue :: !Word16 - , field :: Field - -- ^ The field's name is really the name of the variant. - } - deriving(Show, Eq) + { tagValue :: !Word16, + -- | The field's name is really the name of the variant. + field :: Field + } + deriving (Show, Eq) diff --git a/cmd/capnpc-haskell/IR/Haskell.hs b/cmd/capnpc-haskell/IR/Haskell.hs --- a/cmd/capnpc-haskell/IR/Haskell.hs +++ b/cmd/capnpc-haskell/IR/Haskell.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + -- A last-leg intermediate form, before emitting actually Haskell source code. -- -- This module contains a *simplified* Haskell AST; it only includes the @@ -13,200 +14,198 @@ -- #32), and I(zenhack) don't see a good way to do that with the libraries -- I looked at. module IR.Haskell - ( modFilePath - - , DataArgs(..) - , DataDecl(..) - , DataVariant(..) - , ClassDecl(..) - , Decl(..) - , Do(..) - , Exp(..) - , Export(..) - , Import(..) - , InstanceDef(..) - , Module(..) - , Pattern(..) - , Type(..) - , TypeAlias(..) - , ValueDef(..) - ) where - -import Data.List (intercalate) + ( modFilePath, + DataArgs (..), + DataDecl (..), + DataVariant (..), + ClassDecl (..), + Decl (..), + Do (..), + Exp (..), + Export (..), + Import (..), + InstanceDef (..), + Module (..), + Pattern (..), + Type (..), + TypeAlias (..), + ValueDef (..), + ) +where import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as T - +import Data.List (intercalate) +import qualified Data.Text as T import qualified IR.Common as Common -import qualified IR.Name as Name +import qualified IR.Name as Name -- | A Haskell module data Module = Module - { modName :: [Name.UnQ] - -- ^ The parts of the module path - , modLangPragmas :: [T.Text] - -- ^ The language extensions enabled in this module. - , modExports :: Maybe [Export] - -- ^ The export list. If it is 'Nothing' that means there is no export + { -- | The parts of the module path + modName :: [Name.UnQ], + -- | The language extensions enabled in this module. + modLangPragmas :: [T.Text], + -- | The export list. If it is 'Nothing' that means there is no export -- list (and therefore everything is exported). - , modDecls :: [Decl] - -- ^ The declarations in the module. - , modImports :: [Import] - -- ^ Modules to import. - } - deriving(Show, Read, Eq) + modExports :: Maybe [Export], + -- | The declarations in the module. + modDecls :: [Decl], + -- | Modules to import. + modImports :: [Import] + } + deriving (Show, Read, Eq) data Export - = ExportMod [Name.UnQ] -- module Foo.Bar - | ExportGCtors Name.GlobalQ -- Foo.Bar.Baz(..) - | ExportLCtors Name.LocalQ -- Baz(..) - | ExportGName Name.GlobalQ -- Foo.Bar.Baz - | ExportLName Name.LocalQ -- Baz - deriving(Show, Read, Eq) + = ExportMod [Name.UnQ] -- module Foo.Bar + | ExportGCtors Name.GlobalQ -- Foo.Bar.Baz(..) + | ExportLCtors Name.LocalQ -- Baz(..) + | ExportGName Name.GlobalQ -- Foo.Bar.Baz + | ExportLName Name.LocalQ -- Baz + deriving (Show, Read, Eq) data Import - = ImportAs -- import qualified Foo.Bar as Bar - { importAs :: Name.UnQ - , parts :: [Name.UnQ] - } - | ImportQual -- import qualified Foo.Bar - { parts :: [Name.UnQ] - } - | ImportAll -- import Foo.Bar - { parts :: [Name.UnQ] - } - deriving(Show, Read, Eq) + = ImportAs -- import qualified Foo.Bar as Bar + { importAs :: Name.UnQ, + parts :: [Name.UnQ] + } + | ImportQual -- import qualified Foo.Bar + { parts :: [Name.UnQ] + } + | ImportAll -- import Foo.Bar + { parts :: [Name.UnQ] + } + deriving (Show, Read, Eq) -- | A declaration. data Decl - = DcData DataDecl - | DcValue - { typ :: Type - , def :: ValueDef - } - | DcInstance - { ctx :: [Type] - , typ :: Type - , defs :: [InstanceDef] - } - | DcTypeInstance Type Type - | DcDeriveInstance - { ctx :: [Type] - , typ :: Type - } - | DcClass - { ctx :: [Type] - , name :: Name.LocalQ - , params :: [Name.UnQ] - , funDeps :: [(T.Text, T.Text)] - , decls :: [ClassDecl] - } - deriving(Show, Read, Eq) + = DcData DataDecl + | DcValue + { typ :: Type, + def :: ValueDef + } + | DcInstance + { ctx :: [Type], + typ :: Type, + defs :: [InstanceDef] + } + | DcTypeInstance Type Type + | DcDeriveInstance + { ctx :: [Type], + typ :: Type + } + | DcClass + { ctx :: [Type], + name :: Name.LocalQ, + params :: [Name.UnQ], + funDeps :: [(T.Text, T.Text)], + decls :: [ClassDecl] + } + deriving (Show, Read, Eq) data DataDecl = Data - { dataName :: Name.UnQ - -- ^ The name of the declared type. - , typeArgs :: [Type] - , dataVariants :: [DataVariant] - -- ^ The variants/data constructors for the type. - , derives :: [Name.UnQ] - -- ^ A list of type classes to include in the deriving clause. - , dataNewtype :: !Bool - -- ^ Whether the declarationis a "newtype" or "data" declaration. - , dataInstance :: !Bool - -- ^ If true, this is actually an instance of a data family, rather + { -- | The name of the declared type. + dataName :: Name.UnQ, + typeArgs :: [Type], + -- | The variants/data constructors for the type. + dataVariants :: [DataVariant], + -- | A list of type classes to include in the deriving clause. + derives :: [Name.UnQ], + -- | Whether the declarationis a "newtype" or "data" declaration. + dataNewtype :: !Bool, + -- | If true, this is actually an instance of a data family, rather -- than a stand-alone type. - } - deriving(Show, Read, Eq) + dataInstance :: !Bool + } + deriving (Show, Read, Eq) data ClassDecl - = CdValueDecl Name.UnQ Type - | CdValueDef ValueDef - | CdMinimal [Name.UnQ] - -- ^ A MINIMAL pragma. - deriving(Show, Read, Eq) + = CdValueDecl Name.UnQ Type + | CdValueDef ValueDef + | -- | A MINIMAL pragma. + CdMinimal [Name.UnQ] + deriving (Show, Read, Eq) data InstanceDef - = IdValue ValueDef - | IdData DataDecl - | IdType TypeAlias - deriving(Show, Read, Eq) + = IdValue ValueDef + | IdData DataDecl + | IdType TypeAlias + deriving (Show, Read, Eq) data TypeAlias = TypeAlias Name.UnQ [Type] Type - deriving(Show, Read, Eq) + deriving (Show, Read, Eq) data ValueDef = DfValue - { name :: Name.UnQ - , value :: Exp - , params :: [Pattern] - } - deriving(Show, Read, Eq) + { name :: Name.UnQ, + value :: Exp, + params :: [Pattern] + } + deriving (Show, Read, Eq) -- | A data constructor data DataVariant = DataVariant - { dvCtorName :: Name.UnQ - -- ^ The name of the constructor. - , dvArgs :: DataArgs - } - deriving(Show, Read, Eq) + { -- | The name of the constructor. + dvCtorName :: Name.UnQ, + dvArgs :: DataArgs + } + deriving (Show, Read, Eq) -- | Arguments to a data constructor data DataArgs - = APos [Type] - | ARec [(Name.UnQ, Type)] - deriving(Show, Read, Eq) + = APos [Type] + | ARec [(Name.UnQ, Type)] + deriving (Show, Read, Eq) data Type - = TGName Name.GlobalQ - | TLName Name.LocalQ - | TVar T.Text - | TApp Type [Type] - | TFn [Type] - | TCtx [Type] Type - | TPrim Common.PrimWord - | TUnit - | TKindAnnotated Type Type - | TString T.Text -- type-level string literal - deriving(Show, Read, Eq) + = TGName Name.GlobalQ + | TLName Name.LocalQ + | TVar T.Text + | TApp Type [Type] + | TFn [Type] + | TCtx [Type] Type + | TPrim Common.PrimWord + | TUnit + | TKindAnnotated Type Type + | TString T.Text -- type-level string literal + deriving (Show, Read, Eq) data Exp - = EVar T.Text - | EApp Exp [Exp] - | EFApp Exp [Exp] - -- ^ "Functorial" application, i.e. f <$> x <*> y <*> z. - | EGName Name.GlobalQ - | ELName Name.LocalQ - | EInt Integer - | EDo [Do] Exp - | EBind Exp Exp - -- ^ A call to (>>=) - | ETup [Exp] - | EBytes LBS.ByteString - | ECase Exp [(Pattern, Exp)] - | ETypeAnno Exp Type - | ELambda [Pattern] Exp - | ERecord Exp [(Name.UnQ, Exp)] - | ELabel Name.UnQ - | EList [Exp] - | ETypeApp Exp [Type] -- TypeApplications; f @x @y @z - deriving(Show, Read, Eq) + = EVar T.Text + | EApp Exp [Exp] + | -- | "Functorial" application, i.e. f <$> x <*> y <*> z. + EFApp Exp [Exp] + | EGName Name.GlobalQ + | ELName Name.LocalQ + | EInt Integer + | EDo [Do] Exp + | -- | A call to (>>=) + EBind Exp Exp + | ETup [Exp] + | EBytes LBS.ByteString + | ECase Exp [(Pattern, Exp)] + | ETypeAnno Exp Type + | ELambda [Pattern] Exp + | ERecord Exp [(Name.UnQ, Exp)] + | ELabel Name.UnQ + | EList [Exp] + | ETypeApp Exp [Type] -- TypeApplications; f @x @y @z + deriving (Show, Read, Eq) data Do - = DoBind Name.UnQ Exp - | DoE Exp - deriving(Show, Read, Eq) + = DoBind Name.UnQ Exp + | DoE Exp + deriving (Show, Read, Eq) data Pattern - = PVar T.Text - | PLCtor Name.LocalQ [Pattern] - | PGCtor Name.GlobalQ [Pattern] - | PInt Integer - -- | Name{..} - | PLRecordWildCard Name.LocalQ - deriving(Show, Read, Eq) + = PVar T.Text + | PLCtor Name.LocalQ [Pattern] + | PGCtor Name.GlobalQ [Pattern] + | PInt Integer + | -- | Name{..} + PLRecordWildCard Name.LocalQ + deriving (Show, Read, Eq) -- | Get the file path for a module. For example, the module @Foo.Bar.Baz@ will -- have a file path of @Foo/Bar/Baz.hs@. modFilePath :: Module -> FilePath -modFilePath Module{modName} = - intercalate "/" (map (T.unpack . Name.renderUnQ) modName) ++ ".hs" +modFilePath Module {modName} = + intercalate "/" (map (T.unpack . Name.renderUnQ) modName) ++ ".hs" diff --git a/cmd/capnpc-haskell/IR/Name.hs b/cmd/capnpc-haskell/IR/Name.hs --- a/cmd/capnpc-haskell/IR/Name.hs +++ b/cmd/capnpc-haskell/IR/Name.hs @@ -1,100 +1,132 @@ -{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -module IR.Name where - -import Data.Word +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -import Data.Char (toLower) -import Data.List (intersperse) -import Data.String (IsString(fromString)) +module IR.Name where -import qualified Data.Set as S +import Data.Char (toLower) +import Data.List (intersperse) +import qualified Data.Set as S +import Data.String (IsString (fromString)) import qualified Data.Text as T +import Data.Word class HasUnQ a where - getUnQ :: a -> UnQ + getUnQ :: a -> UnQ + class MkSub a where - mkSub :: a -> UnQ -> a + mkSub :: a -> UnQ -> a instance HasUnQ UnQ where - getUnQ = id + getUnQ = id + instance HasUnQ LocalQ where - getUnQ = localUnQ + getUnQ = localUnQ + instance HasUnQ CapnpQ where - getUnQ CapnpQ{local} = getUnQ local + getUnQ CapnpQ {local} = getUnQ local + instance HasUnQ GlobalQ where - getUnQ GlobalQ{local} = getUnQ local + getUnQ GlobalQ {local} = getUnQ local newtype UnQ = UnQ T.Text - deriving(Show, Read, Eq, Ord, IsString, Semigroup) + deriving (Show, Read, Eq, Ord, IsString, Semigroup) newtype NS = NS [T.Text] - deriving(Show, Read, Eq, Ord) + deriving (Show, Read, Eq, Ord) data LocalQ = LocalQ - { localUnQ :: UnQ - , localNS :: NS - } - deriving(Show, Read, Eq, Ord) + { localUnQ :: UnQ, + localNS :: NS + } + deriving (Show, Read, Eq, Ord) instance IsString LocalQ where - fromString s = LocalQ - { localUnQ = fromString s - , localNS = emptyNS - } + fromString s = + LocalQ + { localUnQ = fromString s, + localNS = emptyNS + } -- | A fully qualified name for something defined in a capnproto schema. -- this includes a local name within a file, and the file's capnp id. data CapnpQ = CapnpQ - { local :: LocalQ - , fileId :: !Word64 - } - deriving(Show, Read, Eq, Ord) + { local :: LocalQ, + fileId :: !Word64 + } + deriving (Show, Read, Eq, Ord) data GlobalQ = GlobalQ - { local :: LocalQ - , globalNS :: NS - } - deriving(Show, Read, Eq, Ord) + { local :: LocalQ, + globalNS :: NS + } + deriving (Show, Read, Eq, Ord) emptyNS :: NS emptyNS = NS [] mkLocal :: NS -> UnQ -> LocalQ -mkLocal localNS localUnQ = LocalQ{localNS, localUnQ} +mkLocal localNS localUnQ = LocalQ {localNS, localUnQ} unQToLocal :: UnQ -> LocalQ unQToLocal = mkLocal emptyNS instance MkSub LocalQ where - mkSub q = mkLocal (localQToNS q) + mkSub q = mkLocal (localQToNS q) instance MkSub GlobalQ where - mkSub q@GlobalQ{local} unQ = q { local = mkSub local unQ } + mkSub GlobalQ {local, ..} unQ = GlobalQ {local = mkSub local unQ, ..} instance MkSub CapnpQ where - mkSub q@CapnpQ{local} unQ = q { local = mkSub local unQ } + mkSub CapnpQ {local, ..} unQ = CapnpQ {local = mkSub local unQ, ..} localQToNS :: LocalQ -> NS -localQToNS LocalQ{localUnQ=UnQ part, localNS=NS parts} = NS (part:parts) +localQToNS LocalQ {localUnQ = UnQ part, localNS = NS parts} = NS (part : parts) localToUnQ :: LocalQ -> UnQ -localToUnQ LocalQ{localUnQ, localNS} - | localNS == emptyNS = localUnQ - | otherwise = UnQ (renderLocalNS localNS <> "'" <> renderUnQ localUnQ) +localToUnQ LocalQ {localUnQ, localNS} + | localNS == emptyNS = localUnQ + | otherwise = UnQ (renderLocalNS localNS <> "'" <> renderUnQ localUnQ) renderUnQ :: UnQ -> T.Text renderUnQ (UnQ name) - | name `S.member` keywords = name <> "_" - | otherwise = name + | name `S.member` keywords = name <> "_" + | otherwise = name where - keywords = S.fromList - [ "as", "case", "of", "class", "data", "family", "instance", "default" - , "deriving", "do", "forall", "foreign", "hiding", "if", "then", "else" - , "import", "infix", "infixl", "infixr", "let", "in", "mdo", "module" - , "newtype", "proc", "qualified", "rec", "type", "where" + keywords = + S.fromList + [ "as", + "case", + "of", + "class", + "data", + "family", + "instance", + "default", + "deriving", + "do", + "forall", + "foreign", + "hiding", + "if", + "then", + "else", + "import", + "infix", + "infixl", + "infixr", + "let", + "in", + "mdo", + "module", + "newtype", + "proc", + "qualified", + "rec", + "type", + "where" ] renderLocalQ :: LocalQ -> T.Text @@ -126,5 +158,5 @@ lowerFst :: T.Text -> T.Text lowerFst txt = case T.unpack txt of - [] -> "" - (c:cs) -> T.pack $ toLower c : cs + [] -> "" + (c : cs) -> T.pack $ toLower c : cs diff --git a/cmd/capnpc-haskell/IR/New.hs b/cmd/capnpc-haskell/IR/New.hs deleted file mode 100644 --- a/cmd/capnpc-haskell/IR/New.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -module IR.New where - -import qualified Capnp.Repr as R -import Data.Word -import qualified IR.Common as C -import qualified IR.Name as Name - -type Brand = C.ListBrand Name.CapnpQ - -data File - = File - { fileId :: !Word64 - , decls :: [Decl] - , fileName :: FilePath - , usesRpc :: !Bool - } - -data Decl - = TypeDecl - { name :: Name.LocalQ - , nodeId :: !Word64 - , params :: [Name.UnQ] - , repr :: R.Repr - , extraTypeInfo :: Maybe ExtraTypeInfo - } - | FieldDecl - { containerType :: Name.LocalQ - , typeParams :: [Name.UnQ] - , fieldName :: Name.UnQ - , fieldLocType :: C.FieldLocType Brand Name.CapnpQ - } - | UnionDecl - { name :: Name.LocalQ - , typeParams :: [Name.UnQ] - , tagLoc :: C.DataLoc - , variants :: [UnionVariant] - } - | MethodDecl - { interfaceName :: Name.LocalQ - , interfaceId :: !Word64 - , methodId :: !Word16 - , methodInfo :: MethodInfo - } - | SuperDecl - { subName :: Name.LocalQ - , typeParams :: [Name.UnQ] - , superType :: C.InterfaceType Brand Name.CapnpQ - } - | ParsedInstanceDecl - { typeName :: Name.LocalQ - , typeParams :: [Name.UnQ] - , parsedInstances :: ParsedInstances - } - | ConstDecl - { name :: Name.LocalQ - , value :: C.Value Brand Name.CapnpQ - } - --- | Data needed for declaring a Parsed instance, and instances --- of related classes. -data ParsedInstances - = ParsedStruct - { fields :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)] - , hasUnion :: !Bool - , dataCtorName :: Name.LocalQ - } - | ParsedUnion - { variants :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)] - } - -data MethodInfo = MethodInfo - { typeParams :: [Name.UnQ] - , methodName :: Name.UnQ - , paramType :: C.CompositeType Brand Name.CapnpQ - , resultType :: C.CompositeType Brand Name.CapnpQ - } - -data ExtraTypeInfo - = StructTypeInfo - { nWords :: !Word16 - , nPtrs :: !Word16 - } - | EnumTypeInfo [Name.UnQ] - | InterfaceTypeInfo - { methods :: [MethodInfo] - , supers :: [C.InterfaceType Brand Name.CapnpQ] - } - -data UnionVariant = UnionVariant - { variantName :: Name.UnQ - , tagValue :: !Word16 - , fieldLocType :: C.FieldLocType Brand Name.CapnpQ - } diff --git a/cmd/capnpc-haskell/IR/Stage1.hs b/cmd/capnpc-haskell/IR/Stage1.hs --- a/cmd/capnpc-haskell/IR/Stage1.hs +++ b/cmd/capnpc-haskell/IR/Stage1.hs @@ -1,97 +1,98 @@ -- First stage IR. This models the data structures in schema.capnp more closely -- than the other intermediate forms. Differences: -- --- * Lots of information which we won't use is discarded. --- * Nodes no longer reference eachother by ID; instead we include direct +-- \* Lots of information which we won't use is discarded. +-- \* Nodes no longer reference eachother by ID; instead we include direct -- references to the objects. --- * The details of some structures are tweaked to make them more ergonomic +-- \* The details of some structures are tweaked to make them more ergonomic -- to use and/or more idiomatic Haskell. {-# LANGUAGE DuplicateRecordFields #-} -module IR.Stage1 - ( File(..) - , ReqFile(..) - , Interface(..) - , Method(..) - , Node(..) - , NodeCommon(..) - , NodeUnion(..) - , Struct(..) - , Field(..) - , CodeGenReq(..) - , Brand - ) where -import Data.Word +module IR.Stage1 + ( File (..), + ReqFile (..), + Interface (..), + Method (..), + Node (..), + NodeCommon (..), + NodeUnion (..), + Struct (..), + Field (..), + CodeGenReq (..), + Brand, + ) +where import qualified Data.Vector as V -import qualified IR.Common as Common -import qualified IR.Name as Name +import Data.Word +import qualified IR.Common as Common +import qualified IR.Name as Name type Brand = Common.MapBrand Node data CodeGenReq = CodeGenReq - { reqFiles :: [ReqFile] - , allFiles :: [File] - } + { reqFiles :: [ReqFile], + allFiles :: [File] + } data ReqFile = ReqFile - { file :: File - , fileName :: FilePath - } + { file :: File, + fileName :: FilePath + } data File = File - { fileNodes :: [(Name.UnQ, Node)] - , fileId :: !Word64 - } - deriving(Show, Eq) + { fileNodes :: [(Name.UnQ, Node)], + fileId :: !Word64 + } + deriving (Show, Eq) data Node = Node - { nodeCommon :: NodeCommon - , nodeUnion :: NodeUnion - } - deriving(Show, Eq) + { nodeCommon :: NodeCommon, + nodeUnion :: NodeUnion + } + deriving (Show, Eq) data NodeCommon = NodeCommon - { nodeNested :: [(Name.UnQ, Node)] - , nodeParent :: Maybe Node - , nodeId :: !Word64 - , nodeParams :: V.Vector Name.UnQ - } - deriving(Show, Eq) + { nodeNested :: [(Name.UnQ, Node)], + nodeParent :: Maybe Node, + nodeId :: !Word64, + nodeParams :: V.Vector Name.UnQ + } + deriving (Show, Eq) data NodeUnion - = NodeEnum [Name.UnQ] - | NodeStruct Struct - | NodeInterface Interface - | NodeConstant (Common.Value Brand Node) - | NodeOther - deriving(Show, Eq) + = NodeEnum [Name.UnQ] + | NodeStruct Struct + | NodeInterface Interface + | NodeConstant (Common.Value Brand Node) + | NodeOther + deriving (Show, Eq) data Interface = Interface - { methods :: [Method] - , supers :: [Common.InterfaceType Brand Node] - } - deriving(Show, Eq) + { methods :: [Method], + supers :: [Common.InterfaceType Brand Node] + } + deriving (Show, Eq) data Method = Method - { name :: Name.UnQ - , paramType :: Common.CompositeType Brand Node - , resultType :: Common.CompositeType Brand Node - } - deriving(Show, Eq) + { name :: Name.UnQ, + paramType :: Common.CompositeType Brand Node, + resultType :: Common.CompositeType Brand Node + } + deriving (Show, Eq) data Struct = Struct - { dataWordCount :: !Word16 - , pointerCount :: !Word16 - , isGroup :: !Bool - , tagOffset :: !Word32 - , fields :: [Field] - } - deriving(Show, Eq) + { dataWordCount :: !Word16, + pointerCount :: !Word16, + isGroup :: !Bool, + tagOffset :: !Word32, + fields :: [Field] + } + deriving (Show, Eq) data Field = Field - { name :: Name.UnQ - , tag :: Maybe Word16 - , locType :: Common.FieldLocType Brand Node - } - deriving(Show, Eq) + { name :: Name.UnQ, + tag :: Maybe Word16, + locType :: Common.FieldLocType Brand Node + } + deriving (Show, Eq) diff --git a/cmd/capnpc-haskell/Main.hs b/cmd/capnpc-haskell/Main.hs --- a/cmd/capnpc-haskell/Main.hs +++ b/cmd/capnpc-haskell/Main.hs @@ -2,52 +2,48 @@ -- generator plugin. module Main (main) where -import Data.Foldable (for_) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory) -import System.IO (IOMode(WriteMode), withFile) - -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.IO as TIO - -import Capnp.Gen.Capnp.Schema.New (CodeGeneratorRequest) -import Capnp.New (Parsed, defaultLimit, getParsed) - +import Capnp (Parsed, defaultLimit, getParsed) +import Capnp.Gen.Capnp.Schema (CodeGeneratorRequest) import qualified Check -import qualified IR.Flat as Flat -import qualified IR.Haskell as Haskell +import Data.Foldable (for_) +import qualified Data.Text.Lazy as LT +import qualified Data.Text.Lazy.IO as TIO +import qualified IR.Flat as Flat +import qualified IR.Haskell as Haskell +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) +import System.IO (IOMode (WriteMode), withFile) +import qualified Trans.AbstractOpToHaskell import qualified Trans.CgrToStage1 -import qualified Trans.FlatToNew +import qualified Trans.FlatToAbstractOp import qualified Trans.HaskellToText -import qualified Trans.NewToHaskell import qualified Trans.Stage1ToFlat main :: IO () main = do - cgr <- getParsed defaultLimit - Check.reportIssues cgr - for_ (handleCGR cgr) $ \(path, contents) -> do - createDirectoryIfMissing True (takeDirectory path) - withFile path WriteMode $ \h -> - TIO.hPutStr h contents + cgr <- getParsed defaultLimit + Check.reportIssues cgr + for_ (handleCGR cgr) $ \(path, contents) -> do + createDirectoryIfMissing True (takeDirectory path) + withFile path WriteMode $ \h -> + TIO.hPutStr h contents -- | Convert a 'CodeGeneratorRequest' to a list of files to create. handleCGR :: Parsed CodeGeneratorRequest -> [(FilePath, LT.Text)] handleCGR cgr = - let flat = - Trans.Stage1ToFlat.cgrToCgr $ - Trans.CgrToStage1.cgrToCgr cgr - modules = handleFlatNew flat - in - map - (\mod -> - ( Haskell.modFilePath mod - , Trans.HaskellToText.moduleToText mod + let flat = + Trans.Stage1ToFlat.cgrToCgr $ + Trans.CgrToStage1.cgrToCgr cgr + modules = handleFlatNew flat + in map + ( \mod -> + ( Haskell.modFilePath mod, + Trans.HaskellToText.moduleToText mod ) ) modules handleFlatNew :: Flat.CodeGenReq -> [Haskell.Module] handleFlatNew = - concatMap Trans.NewToHaskell.fileToModules - . Trans.FlatToNew.cgrToFiles + concatMap Trans.AbstractOpToHaskell.fileToModules + . Trans.FlatToAbstractOp.cgrToFiles diff --git a/cmd/capnpc-haskell/Trans/AbstractOpToHaskell.hs b/cmd/capnpc-haskell/Trans/AbstractOpToHaskell.hs new file mode 100644 --- /dev/null +++ b/cmd/capnpc-haskell/Trans/AbstractOpToHaskell.hs @@ -0,0 +1,1076 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Trans.AbstractOpToHaskell + ( fileToModules, + ) +where + +import qualified Capnp.Repr as R +import Control.Monad (guard) +import Data.String (IsString (fromString)) +import Data.Word +import qualified IR.AbstractOp as AO +import qualified IR.Common as C +import qualified IR.Haskell as Hs +import qualified IR.Name as Name +import Trans.ToHaskellCommon + +-- | Modules imported by all generated modules. +imports :: [Hs.Import] +imports = + [ Hs.ImportAs {importAs = "R", parts = ["Capnp", "Repr"]}, + Hs.ImportAs {importAs = "RP", parts = ["Capnp", "Repr", "Parsed"]}, + Hs.ImportAs {importAs = "Basics", parts = ["Capnp", "Basics"]}, + Hs.ImportAs {importAs = "OL", parts = ["GHC", "OverloadedLabels"]}, + Hs.ImportAs {importAs = "GH", parts = ["Capnp", "GenHelpers"]}, + Hs.ImportAs {importAs = "C", parts = ["Capnp", "Classes"]}, + Hs.ImportAs {importAs = "Generics", parts = ["GHC", "Generics"]} + ] + +-- | Modules imported by generated modules that use rpc. We separate these out to +-- avoid a circular import when generating code for rpc.capnp -- which does not +-- contain interfaces, so does not need to import the rpc system -- but which +-- must be imported *by* the rpc system. +rpcImports :: [Hs.Import] +rpcImports = + [ Hs.ImportAs {importAs = "GH", parts = ["Capnp", "GenHelpers", "Rpc"]} + ] + +fileToModules :: AO.File -> [Hs.Module] +fileToModules file = + [ fileToMainModule file, + fileToModuleAlias file + ] + +fileToMainModule :: AO.File -> Hs.Module +fileToMainModule file@AO.File {fileName, usesRpc} = + fixImports $ + Hs.Module + { modName = ["Capnp", "Gen"] ++ makeModName fileName, + modLangPragmas = + [ "TypeFamilies", + "DataKinds", + "DeriveGeneric", + "DuplicateRecordFields", + "EmptyDataDeriving", + "FlexibleContexts", + "FlexibleInstances", + "MultiParamTypeClasses", + "UndecidableInstances", + "UndecidableSuperClasses", + "OverloadedLabels", + "OverloadedStrings", + "StandaloneDeriving", + "RecordWildCards", + "TypeApplications", + "ScopedTypeVariables" + ], + modExports = Nothing, + modImports = imports ++ (guard usesRpc >> rpcImports), + modDecls = fileToDecls file + } + +fileToModuleAlias :: AO.File -> Hs.Module +fileToModuleAlias AO.File {fileId, fileName} = + let reExport = ["Capnp", "Gen"] ++ makeModName fileName + in Hs.Module + { modName = idToModule fileId, + modLangPragmas = [], + modExports = Just [Hs.ExportMod reExport], + modImports = [Hs.ImportAll {parts = reExport}], + modDecls = [] + } + +fileToDecls :: AO.File -> [Hs.Decl] +fileToDecls AO.File {fileId, decls} = + concatMap (declToDecls fileId) decls + +declToDecls :: Word64 -> AO.Decl -> [Hs.Decl] +declToDecls thisMod decl = + case decl of + AO.TypeDecl {name, nodeId, params, repr, extraTypeInfo} -> + let dataName = Name.localToUnQ name + typeArgs = toTVars params + typ = case typeArgs of + [] -> tuName dataName + _ -> Hs.TApp (tuName dataName) typeArgs + in [ Hs.DcData + Hs.Data + { dataName, + typeArgs, + dataVariants = + case extraTypeInfo of + Just (AO.EnumTypeInfo variants) -> + [ Hs.DataVariant + { dvCtorName = Name.localToUnQ $ Name.mkSub name variantName, + dvArgs = Hs.APos [] + } + | variantName <- variants + ] + ++ [declareUnknownVariant name] + _ -> [], + derives = + case extraTypeInfo of + Just AO.EnumTypeInfo {} -> ["Std_.Eq", "Std_.Show", "Generics.Generic"] + _ -> [], + dataNewtype = False, + dataInstance = False + }, + Hs.DcTypeInstance + (Hs.TApp (tgName ["R"] "ReprFor") [typ]) + (toType repr), + Hs.DcInstance + { ctx = [], + typ = Hs.TApp (tgName ["C"] "HasTypeId") [typ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "typeId", + params = [], + value = Hs.EInt (fromIntegral nodeId) + } + ] + } + ] + ++ let ctx = paramsContext typeArgs + in case extraTypeInfo of + Just AO.StructTypeInfo {nWords, nPtrs} -> + [ Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "TypedStruct") [typ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "numStructWords", + params = [], + value = Hs.EInt $ fromIntegral nWords + }, + Hs.IdValue + Hs.DfValue + { name = "numStructPtrs", + params = [], + value = Hs.EInt $ fromIntegral nPtrs + } + ] + }, + Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "Allocate") [typ], + defs = + [ Hs.IdType $ + Hs.TypeAlias "AllocHint" [typ] Hs.TUnit, + Hs.IdValue + Hs.DfValue + { name = "new", + params = [Hs.PVar "_"], + value = egName ["C"] "newTypedStruct" + } + ] + }, + Hs.DcInstance + { ctx, + typ = + Hs.TApp + (tgName ["C"] "EstimateAlloc") + [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]], + defs = [] + }, + Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "AllocateList") [typ], + defs = + [ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int"), + Hs.IdValue + Hs.DfValue + { name = "newList", + params = [], + value = egName ["C"] "newTypedStructList" + } + ] + }, + Hs.DcInstance + { ctx, + typ = + Hs.TApp + (tgName ["C"] "EstimateListAlloc") + [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]], + defs = [] + } + ] + Just (AO.EnumTypeInfo variants) -> + [ Hs.DcInstance + { ctx, + typ = Hs.TApp (tStd_ "Enum") [typ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "toEnum", + params = [Hs.PVar "n_"], + value = + Hs.ECase (euName "n_") $ + [ ( Hs.PInt i, + Hs.ELName (Name.mkSub name variantName) + ) + | (i, variantName) <- zip [0 ..] variants + ] + ++ [ ( Hs.PVar "tag_", + Hs.EApp + (Hs.ELName (unknownVariant name)) + [Hs.EApp (eStd_ "fromIntegral") [euName "tag_"]] + ) + ] + }, + Hs.IdValue + Hs.DfValue + { name = "fromEnum", + params = [Hs.PVar "value_"], + value = + Hs.ECase (euName "value_") $ + [ ( Hs.PLCtor (Name.mkSub name variantName) [], + Hs.EInt i + ) + | (i, variantName) <- zip [0 ..] variants + ] + ++ [ ( Hs.PLCtor (unknownVariant name) [Hs.PVar "tag_"], + Hs.EApp (eStd_ "fromIntegral") [euName "tag_"] + ) + ] + } + ] + }, + Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "IsWord") [typ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "fromWord", + params = [Hs.PVar "w_"], + value = Hs.EApp (eStd_ "toEnum") [Hs.EApp (eStd_ "fromIntegral") [Hs.EVar "w_"]] + }, + Hs.IdValue + Hs.DfValue + { name = "toWord", + params = [Hs.PVar "v_"], + value = Hs.EApp (eStd_ "fromIntegral") [Hs.EApp (eStd_ "fromEnum") [Hs.EVar "v_"]] + } + ] + }, + Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "Parse") [typ, typ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "parse", + params = [], + value = egName ["GH"] "parseEnum" + }, + Hs.IdValue + Hs.DfValue + { name = "encode", + params = [], + value = egName ["GH"] "encodeEnum" + } + ] + }, + Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "AllocateList") [typ], + defs = + [ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int") + ] + }, + Hs.DcInstance + { ctx, + typ = Hs.TApp (tgName ["C"] "EstimateListAlloc") [typ, typ], + defs = [] + } + ] + Just AO.InterfaceTypeInfo {methods, supers} -> + defineInterfaceParse name params + ++ defineInterfaceServer thisMod name params methods supers + Nothing -> [] + AO.FieldDecl {containerType, typeParams, fieldName, fieldLocType} -> + let tVars = toTVars typeParams + ctx = paramsContext tVars + labelType = Hs.TString (Name.renderUnQ fieldName) + parentType = Hs.TApp (Hs.TLName containerType) tVars + childType = fieldLocTypeToType thisMod fieldLocType + fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType + in [ Hs.DcInstance + { ctx, + typ = + Hs.TApp + (tgName ["GH"] "HasField") + [labelType, fieldKind, parentType, childType], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "fieldByLabel", + value = fieldLocTypeToField fieldLocType, + params = [] + } + ] + } + ] + AO.UnionDecl {name, typeParams, tagLoc, variants} -> + let tVars = toTVars typeParams + typ = Hs.TApp (Hs.TLName name) tVars + in Hs.DcInstance + { ctx = paramsContext tVars, + typ = Hs.TApp (tgName ["GH"] "HasUnion") [typ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "unionField", + params = [], + value = + fieldLocTypeToField $ + C.DataField + tagLoc + (C.PrimWord (C.PrimInt (C.IntType C.Unsigned C.Sz16))) + }, + defineRawData thisMod name tVars variants, + defineInternalWhich name variants, + Hs.IdData + Hs.Data + { dataName = "Which", + typeArgs = [typ], + dataVariants = [], + derives = [], + dataNewtype = False, + dataInstance = False + } + ] + } + : concatMap (variantToDecls thisMod name typeParams) variants + AO.SuperDecl {subName, typeParams, superType} -> + let tVars = toTVars typeParams + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = + Hs.TApp + (tgName ["C"] "Super") + [ typeToType thisMod $ C.PtrType $ C.PtrInterface superType, + Hs.TApp (Hs.TLName subName) tVars + ], + defs = [] + } + ] + AO.MethodDecl + { interfaceName, + interfaceId, + methodId, + methodInfo = + AO.MethodInfo + { typeParams, + methodName, + paramType, + resultType + } + } -> + let tVars = toTVars typeParams + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = + Hs.TApp + (tgName ["GH"] "HasMethod") + [ Hs.TString (Name.renderUnQ methodName), + Hs.TApp (Hs.TLName interfaceName) tVars, + compositeTypeToType thisMod paramType, + compositeTypeToType thisMod resultType + ], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "methodByLabel", + params = [], + value = + Hs.EApp + (egName ["GH"] "Method") + [ Hs.EInt $ fromIntegral interfaceId, + Hs.EInt $ fromIntegral methodId + ] + } + ] + } + ] + AO.ParsedInstanceDecl {typeName, typeParams, parsedInstances} -> + defineParsedInstances thisMod typeName typeParams parsedInstances + AO.ConstDecl {name, value} -> + defineConstant thisMod name value + +defineConstant thisMod localName value = + let name = Name.localToUnQ localName + in case value of + C.VoidValue -> + [ Hs.DcValue + { typ = Hs.TUnit, + def = + Hs.DfValue + { name, + params = [], + value = Hs.ETup [] + } + } + ] + C.WordValue t v -> + [ Hs.DcValue + { typ = typeToType thisMod (C.WordType t), + def = + Hs.DfValue + { name, + params = [], + value = Hs.EApp (egName ["C"] "fromWord") [Hs.EInt (fromIntegral v)] + } + } + ] + C.PtrValue t v -> + [ Hs.DcValue + { typ = Hs.TApp (tgName ["R"] "Raw") [typeToType thisMod (C.PtrType t), tgName ["GH"] "Const"], + def = + Hs.DfValue + { name, + params = [], + value = + Hs.EApp + (egName ["GH"] "getPtrConst") + [Hs.ETypeAnno (Hs.EBytes (makePtrBytes v)) (tgName ["GH"] "ByteString")] + } + } + ] + +defineRawData thisMod name tVars variants = + Hs.IdData + Hs.Data + { dataName = "RawWhich", + typeArgs = + [ Hs.TApp (Hs.TVar $ Name.renderUnQ $ Name.localToUnQ name) tVars, + Hs.TVar "mut_" + ], + dataNewtype = False, + dataInstance = False, + dataVariants = + [ Hs.DataVariant + { dvCtorName = + "RW_" <> Name.localToUnQ (Name.mkSub name variantName), + dvArgs = + Hs.APos + [ Hs.TApp + (tReprName "Raw") + [ fieldLocTypeToType thisMod fieldLocType, + Hs.TVar "mut_" + ] + ] + } + | AO.UnionVariant {variantName, fieldLocType} <- variants + ] + ++ [ Hs.DataVariant + { dvCtorName = "RW_" <> Name.localToUnQ (unknownVariant name), + dvArgs = Hs.APos [tStd_ "Word16"] + } + ], + -- TODO: derive Show, Read, Eq, Generic, to be feature complete with the code generated by RawToHaskell. + -- This will require a stand-alone deriving declaration + derives = [] + } + +unknownVariant :: Name.LocalQ -> Name.LocalQ +unknownVariant name = Name.mkSub name "unknown'" + +rawCtorName :: Name.LocalQ -> Name.UnQ +rawCtorName local = "RW_" <> Name.localToUnQ local + +defineInternalWhich structName variants = + Hs.IdValue + Hs.DfValue + { name = "internalWhich", + params = [Hs.PVar "tag_", Hs.PVar "struct_"], + value = + Hs.ECase (Hs.ELName "tag_") $ + [ ( Hs.PInt $ fromIntegral tagValue, + Hs.EFApp + (euName $ rawCtorName (Name.mkSub structName variantName)) + [ Hs.EApp + (egName ["GH"] "readVariant") + [ Hs.ELabel variantName, + euName "struct_" + ] + ] + ) + | AO.UnionVariant {tagValue, variantName} <- variants + ] + ++ [ ( Hs.PVar "_", + Hs.EApp + (eStd_ "pure") + [ Hs.EApp + (euName $ rawCtorName (unknownVariant structName)) + [euName "tag_"] + ] + ) + ] + } + +variantToDecls thisMod containerType typeParams AO.UnionVariant {tagValue, variantName, fieldLocType} = + let tVars = toTVars typeParams + ctx = paramsContext tVars + labelType = Hs.TString (Name.renderUnQ variantName) + parentType = Hs.TApp (Hs.TLName containerType) tVars + childType = fieldLocTypeToType thisMod fieldLocType + fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType + in [ Hs.DcInstance + { ctx, + typ = + Hs.TApp + (tgName ["GH"] "HasVariant") + [labelType, fieldKind, parentType, childType], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "variantByLabel", + params = [], + value = + Hs.EApp + (egName ["GH"] "Variant") + [ fieldLocTypeToField fieldLocType, + Hs.EInt (fromIntegral tagValue) + ] + } + ] + } + ] + +paramsContext :: [Hs.Type] -> [Hs.Type] +paramsContext = map paramConstraints + +-- | Constraints required for a capnproto type parameter. The returned +-- expression has kind 'Constraint'. +paramConstraints :: Hs.Type -> Hs.Type +paramConstraints t = + Hs.TApp (tgName ["GH"] "TypeParam") [t] + +tCapnp :: Word64 -> Name.CapnpQ -> Hs.Type +tCapnp thisMod Name.CapnpQ {local, fileId} + | thisMod == fileId = Hs.TLName local + | otherwise = tgName (map Name.renderUnQ $ idToModule fileId) local + +fieldLocTypeToType :: Word64 -> C.FieldLocType AO.Brand Name.CapnpQ -> Hs.Type +fieldLocTypeToType thisMod = \case + C.VoidField -> Hs.TUnit + C.DataField _ t -> wordTypeToType thisMod t + C.PtrField _ t -> ptrTypeToType thisMod t + C.HereField t -> compositeTypeToType thisMod t + +fieldLocTypeToFieldKind :: C.FieldLocType b n -> Name.GlobalQ +fieldLocTypeToFieldKind = \case + C.HereField _ -> gName ["GH"] "Group" + _ -> gName ["GH"] "Slot" + +wordTypeToType thisMod = \case + C.EnumType t -> tCapnp thisMod t + C.PrimWord t -> primWordToType t + +primWordToType = \case + C.PrimInt t -> intTypeToType t + C.PrimFloat32 -> tStd_ "Float" + C.PrimFloat64 -> tStd_ "Double" + C.PrimBool -> tStd_ "Bool" + +intTypeToType (C.IntType sign size) = + let prefix = case sign of + C.Signed -> "Int" + C.Unsigned -> "Word" + in tStd_ $ fromString $ prefix ++ show (C.sizeBits size) + +wordTypeBits = \case + C.EnumType _ -> 16 + C.PrimWord (C.PrimInt (C.IntType _ size)) -> C.sizeBits size + C.PrimWord C.PrimFloat32 -> 32 + C.PrimWord C.PrimFloat64 -> 64 + C.PrimWord C.PrimBool -> 1 + +ptrTypeToType thisMod = \case + C.ListOf t -> Hs.TApp (tgName ["R"] "List") [typeToType thisMod t] + C.PrimPtr t -> primPtrToType t + C.PtrComposite t -> compositeTypeToType thisMod t + C.PtrInterface t -> interfaceTypeToType thisMod t + C.PtrParam t -> typeParamToType t + +typeToType thisMod = \case + C.CompositeType t -> compositeTypeToType thisMod t + C.VoidType -> Hs.TUnit + C.WordType t -> wordTypeToType thisMod t + C.PtrType t -> ptrTypeToType thisMod t + +primPtrToType = \case + C.PrimText -> tgName ["Basics"] "Text" + C.PrimData -> tgName ["Basics"] "Data" + C.PrimAnyPtr t -> anyPtrToType t + +anyPtrToType :: C.AnyPtr -> Hs.Type +anyPtrToType t = case t of + C.Struct -> basics "AnyStruct" + C.List -> basics "AnyList" + C.Cap -> basics "Capability" + C.Ptr -> Hs.TApp (tStd_ "Maybe") [basics "AnyPointer"] + where + basics = tgName ["Basics"] + +compositeTypeToType thisMod (C.StructType name brand) = namedType thisMod name brand + +interfaceTypeToType thisMod (C.InterfaceType name brand) = namedType thisMod name brand + +typeParamToType = Hs.TVar . Name.typeVarName . C.paramName + +namedType :: Word64 -> Name.CapnpQ -> C.ListBrand Name.CapnpQ -> Hs.Type +namedType thisMod name (C.ListBrand []) = tCapnp thisMod name +namedType thisMod name (C.ListBrand args) = + Hs.TApp + (tCapnp thisMod name) + [typeToType thisMod (C.PtrType t) | t <- args] + +fieldLocTypeToField = \case + C.DataField loc wt -> + let shift = C.dataOff loc + index = C.dataIdx loc + nbits = wordTypeBits wt + defaultValue = C.dataDef loc + in Hs.EApp + (egName ["GH"] "dataField") + [ Hs.EInt $ fromIntegral shift, + Hs.EInt $ fromIntegral index, + Hs.EInt $ fromIntegral nbits, + Hs.EInt $ fromIntegral defaultValue + ] + C.PtrField idx _ -> + Hs.EApp (egName ["GH"] "ptrField") [Hs.EInt $ fromIntegral idx] + C.VoidField -> + egName ["GH"] "voidField" + C.HereField _ -> + egName ["GH"] "groupField" + +class ToType a where + toType :: a -> Hs.Type + +instance ToType R.Repr where + toType (R.Ptr p) = rApp "Ptr" [toType p] + toType (R.Data d) = rApp "Data" [toType d] + +instance ToType a => ToType (Maybe a) where + toType Nothing = tStd_ "Nothing" + toType (Just a) = Hs.TApp (tStd_ "Just") [toType a] + +instance ToType R.PtrRepr where + toType R.Cap = tReprName "Cap" + toType (R.List r) = rApp "List" [toType r] + toType R.Struct = tReprName "Struct" + +instance ToType R.ListRepr where + toType (R.ListNormal nl) = rApp "ListNormal" [toType nl] + toType R.ListComposite = tReprName "ListComposite" + +instance ToType R.NormalListRepr where + toType (R.NormalListData r) = rApp "ListData" [toType r] + toType R.NormalListPtr = tReprName "ListPtr" + +instance ToType R.DataSz where + toType = tReprName . fromString . show + +rApp :: Name.LocalQ -> [Hs.Type] -> Hs.Type +rApp n = Hs.TApp (tReprName n) + +tReprName :: Name.LocalQ -> Hs.Type +tReprName = tgName ["R"] + +declareUnknownVariant :: Name.LocalQ -> Hs.DataVariant +declareUnknownVariant name = + Hs.DataVariant + { dvCtorName = Name.localToUnQ $ Name.mkSub name "unknown'", + dvArgs = Hs.APos [tStd_ "Word16"] + } + +defineParsedInstances :: Word64 -> Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl] +defineParsedInstances thisMod typeName typeParams instanceInfo = + concatMap + (\f -> f typeName typeParams instanceInfo) + [ defineParsed thisMod, + defineParse, + defineMarshal + ] + +defineParsed :: Word64 -> Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl] +defineParsed thisMod typeName typeParams instanceInfo = + let tVars = map (Hs.TVar . Name.typeVarName) typeParams + typ = Hs.TApp (Hs.TLName typeName) tVars + parsedTy = case instanceInfo of + AO.ParsedStruct {} -> typ + AO.ParsedUnion {} -> Hs.TApp (tgName ["GH"] "Which") [typ] + in Hs.DcData + Hs.Data + { dataName = "C.Parsed", + typeArgs = [parsedTy], + derives = ["Generics.Generic"], + dataNewtype = False, + dataInstance = True, + dataVariants = + case instanceInfo of + AO.ParsedStruct {fields, hasUnion, dataCtorName} -> + [ Hs.DataVariant + { dvCtorName = Name.localToUnQ dataCtorName, + dvArgs = + Hs.ARec $ + [ ( name, + Hs.TApp + (tgName ["RP"] "Parsed") + [fieldLocTypeToType thisMod typ] + ) + | (name, typ) <- fields + ] + ++ [ ( "union'", + Hs.TApp + (tgName ["C"] "Parsed") + [Hs.TApp (tgName ["GH"] "Which") [typ]] + ) + | hasUnion + ] + } + ] + AO.ParsedUnion {variants} -> + [ Hs.DataVariant + { dvCtorName = Name.localToUnQ $ Name.mkSub typeName name, + dvArgs = case ftype of + C.VoidField -> Hs.APos [] + _ -> + Hs.APos + [ Hs.TApp + (tgName ["RP"] "Parsed") + [fieldLocTypeToType thisMod ftype] + ] + } + | (name, ftype) <- variants + ] + ++ [declareUnknownVariant typeName] + } + : [ Hs.DcDeriveInstance + [ Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["RP"] "Parsed") [v]] + | v <- tVars + ] + (Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["C"] "Parsed") [parsedTy]]) + | cls <- ["Show", "Eq"] + ] + +defineParse :: Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl] +defineParse typeName typeParams AO.ParsedStruct {fields, hasUnion, dataCtorName} = + let tVars = toTVars typeParams + typ = Hs.TApp (Hs.TLName typeName) tVars + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "parse", + params = [Hs.PVar "raw_"], + value = + Hs.EFApp (Hs.ELName dataCtorName) $ + [ Hs.EApp + (egName ["GH"] "parseField") + [Hs.ELabel field, euName "raw_"] + | field <- map fst fields + ] + ++ if hasUnion + then + [ Hs.EApp + (egName ["C"] "parse") + [Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"]] + ] + else [] + } + ] + } + ] +defineParse typeName typeParams AO.ParsedUnion {variants} = + let tVars = toTVars typeParams + typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars] + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "parse", + params = [Hs.PVar "raw_"], + value = + Hs.EDo + [ Hs.DoBind "rawWhich_" $ Hs.EApp (egName ["GH"] "unionWhich") [euName "raw_"] + ] + ( Hs.ECase (euName "rawWhich_") $ + [ let ctorName = Name.mkSub typeName variantName + in case fieldLocType of + C.VoidField -> + ( puName (rawCtorName ctorName) [Hs.PVar "_"], + Hs.EApp (eStd_ "pure") [Hs.ELName ctorName] + ) + _ -> + ( puName (rawCtorName ctorName) [Hs.PVar "rawArg_"], + Hs.EFApp + (Hs.ELName ctorName) + [Hs.EApp (egName ["C"] "parse") [euName "rawArg_"]] + ) + | (variantName, fieldLocType) <- variants + ] + ++ [ let ctorName = unknownVariant typeName + in ( puName (rawCtorName ctorName) [Hs.PVar "tag_"], + Hs.EApp + (eStd_ "pure") + [Hs.EApp (Hs.ELName ctorName) [euName "tag_"]] + ) + ] + ) + } + ] + } + ] + +defineInterfaceParse typeName typeParams = + let tVars = toTVars typeParams + typ = Hs.TApp (Hs.TLName typeName) tVars + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["GH"] "Client") [typ]], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "parse", + params = [], + value = egName ["GH"] "parseCap" + }, + Hs.IdValue + Hs.DfValue + { name = "encode", + params = [], + value = egName ["GH"] "encodeCap" + } + ] + } + ] + +defineMarshal :: Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl] +defineMarshal typeName typeParams AO.ParsedStruct {fields, hasUnion, dataCtorName} = + let tVars = toTVars typeParams + typ = Hs.TApp (Hs.TLName typeName) tVars + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = + Hs.TApp + (tgName ["C"] "Marshal") + [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]], + defs = + [ if null fields && not hasUnion + then -- We need to special case this, since otherwise GHC will complain about + -- the record wildcard pattern on a ctor with no arguments. + + Hs.IdValue + Hs.DfValue + { name = "marshalInto", + params = [Hs.PVar "_raw", Hs.PLCtor dataCtorName []], + value = Hs.EApp (eStd_ "pure") [Hs.ETup []] + } + else + Hs.IdValue + Hs.DfValue + { name = "marshalInto", + params = + [Hs.PVar "raw_", Hs.PLRecordWildCard dataCtorName], + value = + Hs.EDo + (map (Hs.DoE . uncurry emitMarshalField) fields) + ( if hasUnion + then + Hs.EApp + (egName ["C"] "marshalInto") + [ Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"], + euName "union'" + ] + else Hs.EApp (eStd_ "pure") [Hs.ETup []] + ) + } + ] + } + ] +defineMarshal typeName typeParams AO.ParsedUnion {variants} = + let tVars = toTVars typeParams + typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars] + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = + Hs.TApp + (tgName ["C"] "Marshal") + [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]], + defs = + [ Hs.IdValue + Hs.DfValue + { name = "marshalInto", + params = [Hs.PVar "raw_", Hs.PVar "parsed_"], + value = + Hs.ECase (Hs.EVar "parsed_") $ + [ ( Hs.PLCtor (Name.mkSub typeName name) $ + case fieldLocType of + C.VoidField -> [] + _ -> [Hs.PVar "arg_"], + emitMarshalVariant name fieldLocType + ) + | (name, fieldLocType) <- variants + ] + ++ [ ( Hs.PLCtor (unknownVariant typeName) [Hs.PVar "tag_"], + Hs.EApp + (egName ["GH"] "encodeField") + [ egName ["GH"] "unionField", + Hs.EVar "tag_", + unionStruct (euName "raw_") + ] + ) + ] + } + ] + } + ] + +defineInterfaceServer thisMod typeName typeParams methods supers = + let tVars = toTVars typeParams + typ = Hs.TApp (Hs.TLName typeName) tVars + clsName = Name.mkSub typeName "server_" + in [ Hs.DcInstance + { ctx = paramsContext tVars, + typ = Hs.TApp (tgName ["GH"] "Export") [typ], + defs = + [ Hs.IdType $ Hs.TypeAlias "Server" [typ] $ Hs.TApp (Hs.TLName clsName) tVars, + Hs.IdValue + Hs.DfValue + { name = "methodHandlerTree", + params = [Hs.PVar "_", Hs.PVar "s_"], + value = + Hs.EApp + (egName ["GH"] "MethodHandlerTree") + [ Hs.ETypeApp (egName ["C"] "typeId") [typ], + Hs.EList + [ Hs.EApp + (egName ["GH"] "toUntypedMethodHandler") + [ Hs.EApp + ( Hs.ETypeApp + (Hs.EVar (Name.renderUnQ (Name.valueName (Name.mkSub typeName methodName)))) + tVars + ) + [Hs.EVar "s_"] + ] + | AO.MethodInfo {methodName} <- methods + ], + Hs.EList + [ Hs.EApp + (egName ["GH"] "methodHandlerTree") + [ Hs.ETypeApp + (egName ["GH"] "Proxy") + [typeToType thisMod $ C.PtrType $ C.PtrInterface super], + Hs.EVar "s_" + ] + | super <- supers + ] + ] + } + ] + }, + Hs.DcClass + { ctx = + [ Hs.TApp + (tgName ["GH"] "Server") + [ typeToType thisMod $ C.PtrType $ C.PtrInterface super, + Hs.TVar "s_" + ] + | super <- supers + ], + name = clsName, + params = map (Name.UnQ . Name.typeVarName) typeParams ++ ["s_"], + funDeps = [], + decls = + Hs.CdMinimal + [ mkMethodName typeName methodName + | AO.MethodInfo {methodName} <- methods + ] + : concatMap (defineIfaceClassMethod thisMod typeName) methods + } + ] + +defineIfaceClassMethod thisMod typeName AO.MethodInfo {methodName, paramType, resultType} = + let mkType t = typeToType thisMod (C.CompositeType t) + name = mkMethodName typeName methodName + in [ Hs.CdValueDecl + name + ( Hs.TFn + [ Hs.TVar "s_", + Hs.TApp + (tgName ["GH"] "MethodHandler") + [ mkType paramType, + mkType resultType + ] + ] + ), + Hs.CdValueDef + Hs.DfValue + { name, + params = [Hs.PVar "_"], + value = egName ["GH"] "methodUnimplemented" + } + ] + +mkMethodName typeName methodName = + Name.valueName (Name.mkSub typeName methodName) + +emitMarshalField :: Name.UnQ -> C.FieldLocType AO.Brand Name.CapnpQ -> Hs.Exp +emitMarshalField name (C.HereField _) = + Hs.EDo + [ Hs.DoBind "group_" $ + Hs.EApp + (egName ["GH"] "readField") + [Hs.ELabel name, Hs.EVar "raw_"] + ] + (Hs.EApp (egName ["C"] "marshalInto") [Hs.EVar "group_", euName name]) +emitMarshalField name _ = + Hs.EApp + (egName ["GH"] "encodeField") + [ Hs.ELabel name, + euName name, + euName "raw_" + ] + +emitMarshalVariant :: Name.UnQ -> C.FieldLocType AO.Brand Name.CapnpQ -> Hs.Exp +emitMarshalVariant name (C.HereField _) = + Hs.EDo + [ Hs.DoBind "rawGroup_" $ + Hs.EApp + (egName ["GH"] "initVariant") + [ Hs.ELabel name, + unionStruct (euName "raw_") + ] + ] + (Hs.EApp (egName ["C"] "marshalInto") [euName "rawGroup_", euName "arg_"]) +emitMarshalVariant name C.VoidField = + Hs.EApp + (egName ["GH"] "encodeVariant") + [ Hs.ELabel name, + Hs.ETup [], + unionStruct (euName "raw_") + ] +emitMarshalVariant name _ = + Hs.EApp + (egName ["GH"] "encodeVariant") + [ Hs.ELabel name, + euName "arg_", + unionStruct (euName "raw_") + ] + +unionStruct :: Hs.Exp -> Hs.Exp +unionStruct e = Hs.EApp (egName ["GH"] "unionStruct") [e] diff --git a/cmd/capnpc-haskell/Trans/CgrToStage1.hs b/cmd/capnpc-haskell/Trans/CgrToStage1.hs --- a/cmd/capnpc-haskell/Trans/CgrToStage1.hs +++ b/cmd/capnpc-haskell/Trans/CgrToStage1.hs @@ -1,31 +1,28 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} + -- | Module: Trans.CgrToStage1 -- Description: Translate from schema.capnp's codegenerator request to IR.Stage1. -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} module Trans.CgrToStage1 (cgrToCgr) where -import Data.Word - -import Data.Function ((&)) -import Data.Maybe (mapMaybe) -import Data.Text.Encoding (encodeUtf8) -import GHC.Float (castDoubleToWord64, castFloatToWord32) - +import qualified Capnp.Basics as B +import Capnp.Classes (toWord) +import Capnp.Fields (HasUnion (..)) +import qualified Capnp.Gen.Capnp.Schema as Schema +import Capnp.Repr.Parsed (Parsed) import qualified Data.ByteString as BS +import Data.Function ((&)) import qualified Data.Map.Strict as M -import qualified Data.Text as T -import qualified Data.Vector as V - -import Capnp.Fields (HasUnion(..)) -import Capnp.New.Classes (toWord) -import Capnp.Repr.Parsed (Parsed) - -import qualified Capnp.Gen.Capnp.Schema.New as Schema -import qualified Capnp.New.Basics as B -import qualified IR.Common as C -import qualified IR.Name as Name -import qualified IR.Stage1 as Stage1 +import Data.Maybe (mapMaybe) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Vector as V +import Data.Word +import GHC.Float (castDoubleToWord64, castFloatToWord32) +import qualified IR.Common as C +import qualified IR.Name as Name +import qualified IR.Stage1 as Stage1 type NodeMap v = M.Map Word64 v @@ -34,233 +31,244 @@ where outMap = M.map translate inMap - translate Schema.Node{scopeId, id, nestedNodes, union', parameters} = Stage1.Node - { nodeCommon = Stage1.NodeCommon - { nodeId = id - , nodeNested = - [ (Name.UnQ name, node) - | Schema.Node'NestedNode{name, id} <- V.toList nestedNodes - , Just node <- [M.lookup id outMap] - ] - , nodeParent = - if scopeId == 0 then - Nothing - else - Just (outMap M.! id) - , nodeParams = V.fromList - [ Name.UnQ name - | Schema.Node'Parameter{name} <- V.toList parameters - ] - } - , nodeUnion = case union' of - Schema.Node'enum Schema.Node'enum'{enumerants} -> - Stage1.NodeEnum $ map enumerantToName $ V.toList enumerants - Schema.Node'struct Schema.Node'struct' - { dataWordCount - , pointerCount - , isGroup - , discriminantOffset - , fields - } -> - Stage1.NodeStruct Stage1.Struct - { dataWordCount - , pointerCount - , isGroup - , tagOffset = discriminantOffset - , fields = map (fieldToField outMap) (V.toList fields) - } - Schema.Node'interface Schema.Node'interface'{ methods, superclasses } -> - Stage1.NodeInterface Stage1.Interface - { methods = map (methodToMethod outMap) (V.toList methods) - , supers = - [ C.InterfaceType (outMap M.! id) (brandToBrand outMap brand) - | Schema.Superclass{id, brand} <- V.toList superclasses - ] + translate Schema.Node {scopeId, id, nestedNodes, union', parameters} = + Stage1.Node + { nodeCommon = + Stage1.NodeCommon + { nodeId = id, + nodeNested = + [ (Name.UnQ name, node) + | Schema.Node'NestedNode {name, id} <- V.toList nestedNodes, + Just node <- [M.lookup id outMap] + ], + nodeParent = + if scopeId == 0 + then Nothing + else Just (outMap M.! id), + nodeParams = + V.fromList + [ Name.UnQ name + | Schema.Node'Parameter {name} <- V.toList parameters + ] + }, + nodeUnion = case union' of + Schema.Node'enum Schema.Node'enum' {enumerants} -> + Stage1.NodeEnum $ map enumerantToName $ V.toList enumerants + Schema.Node'struct + Schema.Node'struct' + { dataWordCount, + pointerCount, + isGroup, + discriminantOffset, + fields + } -> + Stage1.NodeStruct + Stage1.Struct + { dataWordCount, + pointerCount, + isGroup, + tagOffset = discriminantOffset, + fields = map (fieldToField outMap) (V.toList fields) } - Schema.Node'const Schema.Node'const'{ type_ = Schema.Type type_, value = Schema.Value value } -> + Schema.Node'interface Schema.Node'interface' {methods, superclasses} -> + Stage1.NodeInterface + Stage1.Interface + { methods = map (methodToMethod outMap) (V.toList methods), + supers = + [ C.InterfaceType (outMap M.! id) (brandToBrand outMap brand) + | Schema.Superclass {id, brand} <- V.toList superclasses + ] + } + Schema.Node'const Schema.Node'const' {type_ = Schema.Type type_, value = Schema.Value value} -> Stage1.NodeConstant $ let mismatch = error "ERROR: Constant's type and value do not agree" - in case value of - Schema.Value'void -> + in case value of + Schema.Value'void -> C.VoidValue - - Schema.Value'bool v -> + Schema.Value'bool v -> C.WordValue (C.PrimWord C.PrimBool) (toWord v) - - Schema.Value'int8 v -> + Schema.Value'int8 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz8) (toWord v) - Schema.Value'int16 v -> + Schema.Value'int16 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz16) (toWord v) - Schema.Value'int32 v -> + Schema.Value'int32 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz32) (toWord v) - Schema.Value'int64 v -> + Schema.Value'int64 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz64) (toWord v) - - Schema.Value'uint8 v -> + Schema.Value'uint8 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz8) (toWord v) - Schema.Value'uint16 v -> + Schema.Value'uint16 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz16) (toWord v) - Schema.Value'uint32 v -> + Schema.Value'uint32 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz32) (toWord v) - Schema.Value'uint64 v -> + Schema.Value'uint64 v -> C.WordValue (C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz64) (toWord v) - - Schema.Value'float32 v -> + Schema.Value'float32 v -> C.WordValue (C.PrimWord C.PrimFloat32) (toWord v) - Schema.Value'float64 v -> + Schema.Value'float64 v -> C.WordValue (C.PrimWord C.PrimFloat64) (toWord v) - - Schema.Value'text v -> - C.PtrValue (C.PrimPtr C.PrimText) $ Just $ B.PtrList $ B.List8 $ - encodeUtf8 v - & BS.unpack - & (++ [0]) - & V.fromList - Schema.Value'data_ v -> - C.PtrValue (C.PrimPtr C.PrimText) $ Just $ B.PtrList $ B.List8 $ - BS.unpack v - & V.fromList - - Schema.Value'list v -> + Schema.Value'text v -> + C.PtrValue (C.PrimPtr C.PrimText) $ + Just $ + B.PtrList $ + B.List8 $ + encodeUtf8 v + & BS.unpack + & (++ [0]) + & V.fromList + Schema.Value'data_ v -> + C.PtrValue (C.PrimPtr C.PrimText) $ + Just $ + B.PtrList $ + B.List8 $ + BS.unpack v + & V.fromList + Schema.Value'list v -> case type_ of - Schema.Type'list (Schema.Type'list' (Schema.Type elementType)) -> - C.PtrValue - (C.ListOf (typeToType outMap elementType)) - v - _ -> - mismatch - - Schema.Value'enum v -> + Schema.Type'list (Schema.Type'list' (Schema.Type elementType)) -> + C.PtrValue + (C.ListOf (typeToType outMap elementType)) + v + _ -> + mismatch + Schema.Value'enum v -> case type_ of - -- TODO: brand - Schema.Type'enum Schema.Type'enum'{ typeId } -> - C.WordValue (C.EnumType (outMap M.! typeId)) (toWord v) - _ -> - mismatch - - Schema.Value'struct v -> + -- TODO: brand + Schema.Type'enum Schema.Type'enum' {typeId} -> + C.WordValue (C.EnumType (outMap M.! typeId)) (toWord v) + _ -> + mismatch + Schema.Value'struct v -> case type_ of - -- TODO: brand - Schema.Type'struct Schema.Type'struct'{ typeId, brand } -> C.PtrValue - (C.PtrComposite $ C.StructType + -- TODO: brand + Schema.Type'struct Schema.Type'struct' {typeId, brand} -> + C.PtrValue + ( C.PtrComposite $ + C.StructType (outMap M.! typeId) (brandToBrand outMap brand) - ) - v - _ -> - mismatch - - Schema.Value'interface -> + ) + v + _ -> + mismatch + Schema.Value'interface -> case type_ of - Schema.Type'interface Schema.Type'interface'{ typeId, brand } -> - C.PtrValue - (C.PtrInterface (C.InterfaceType (outMap M.! typeId) (brandToBrand outMap brand))) - Nothing - _ -> - mismatch - - Schema.Value'anyPointer v -> + Schema.Type'interface Schema.Type'interface' {typeId, brand} -> + C.PtrValue + (C.PtrInterface (C.InterfaceType (outMap M.! typeId) (brandToBrand outMap brand))) + Nothing + _ -> + mismatch + Schema.Value'anyPointer v -> C.PtrValue (C.PrimPtr (C.PrimAnyPtr C.Ptr)) v - - Schema.Value'unknown' tag -> + Schema.Value'unknown' tag -> error $ "Unknown variant for Value #" ++ show tag _ -> - Stage1.NodeOther + Stage1.NodeOther } brandToBrand :: NodeMap Stage1.Node -> Parsed Schema.Brand -> Stage1.Brand -brandToBrand nodeMap Schema.Brand{scopes} = - C.MapBrand $ M.fromList $ mapMaybe scopeToScope (V.toList scopes) +brandToBrand nodeMap Schema.Brand {scopes} = + C.MapBrand $ M.fromList $ mapMaybe scopeToScope (V.toList scopes) where - scopeToScope Schema.Brand'Scope{scopeId, union'} = case union' of - Schema.Brand'Scope'unknown' _ -> Nothing - Schema.Brand'Scope'inherit -> Nothing - Schema.Brand'Scope'bind bindings -> Just - ( scopeId - , C.Bind $ bindings - & V.map (\(Schema.Brand'Binding b) -> case b of - Schema.Brand'Binding'type_ (Schema.Type typ) -> + scopeToScope Schema.Brand'Scope {scopeId, union'} = case union' of + Schema.Brand'Scope'unknown' _ -> Nothing + Schema.Brand'Scope'inherit -> Nothing + Schema.Brand'Scope'bind bindings -> + Just + ( scopeId, + C.Bind $ + bindings + & V.map + ( \(Schema.Brand'Binding b) -> case b of + Schema.Brand'Binding'type_ (Schema.Type typ) -> case typeToType nodeMap typ of - C.PtrType t -> - C.BoundType t - C.CompositeType t -> - C.BoundType (C.PtrComposite t) - _ -> error - "Invalid schema: a type parameter was set to a non-pointer type." - - Schema.Brand'Binding'unbound -> C.Unbound - Schema.Brand'Binding'unknown' _ -> C.Unbound - ) - ) + C.PtrType t -> + C.BoundType t + C.CompositeType t -> + C.BoundType (C.PtrComposite t) + _ -> + error + "Invalid schema: a type parameter was set to a non-pointer type." + Schema.Brand'Binding'unbound -> C.Unbound + Schema.Brand'Binding'unknown' _ -> C.Unbound + ) + ) methodToMethod :: NodeMap Stage1.Node -> Parsed Schema.Method -> Stage1.Method -methodToMethod nodeMap Schema.Method - { name - , paramStructType, paramBrand - , resultStructType, resultBrand +methodToMethod + nodeMap + Schema.Method + { name, + paramStructType, + paramBrand, + resultStructType, + resultBrand } = Stage1.Method - { name = Name.UnQ name - , paramType = structTypeToType nodeMap paramStructType paramBrand - , resultType = structTypeToType nodeMap resultStructType resultBrand - } + { name = Name.UnQ name, + paramType = structTypeToType nodeMap paramStructType paramBrand, + resultType = structTypeToType nodeMap resultStructType resultBrand + } enumerantToName :: Parsed Schema.Enumerant -> Name.UnQ -enumerantToName Schema.Enumerant{name} = Name.UnQ name +enumerantToName Schema.Enumerant {name} = Name.UnQ name fieldToField :: NodeMap Stage1.Node -> Parsed Schema.Field -> Stage1.Field -fieldToField nodeMap Schema.Field{name, discriminantValue, union'} = - Stage1.Field - { name = Name.UnQ name - , tag = - if discriminantValue == Schema.field'noDiscriminant then - Nothing - else - Just discriminantValue - , locType = getFieldLocType nodeMap union' - } +fieldToField nodeMap Schema.Field {name, discriminantValue, union'} = + Stage1.Field + { name = Name.UnQ name, + tag = + if discriminantValue == Schema.field'noDiscriminant + then Nothing + else Just discriminantValue, + locType = getFieldLocType nodeMap union' + } getFieldLocType :: NodeMap Stage1.Node -> Parsed (Which Schema.Field) -> C.FieldLocType Stage1.Brand Stage1.Node getFieldLocType nodeMap = \case - Schema.Field'slot Schema.Field'slot' - { type_ = Schema.Type type_ - , defaultValue = Schema.Value defaultValue - , offset + Schema.Field'slot + Schema.Field'slot' + { type_ = Schema.Type type_, + defaultValue = Schema.Value defaultValue, + offset } -> - case typeToType nodeMap type_ of - C.VoidType -> - C.VoidField - C.PtrType ty -> - C.PtrField (fromIntegral offset) ty - C.WordType ty -> - case valueBits defaultValue of - Nothing -> error $ - "Invlaid schema: a field in a struct's data section " ++ - "had an illegal (non-data) default value." - Just defaultVal -> - C.DataField - (dataLoc offset ty defaultVal) - ty - C.CompositeType ty -> - C.PtrField (fromIntegral offset) (C.PtrComposite ty) - Schema.Field'group Schema.Field'group'{typeId} -> - C.HereField $ C.StructType - (nodeMap M.! typeId) - (C.MapBrand M.empty) -- groups are always monomorphic - Schema.Field'unknown' _ -> - -- Don't know how to interpret this; we'll have to leave the argument - -- opaque. - C.VoidField + case typeToType nodeMap type_ of + C.VoidType -> + C.VoidField + C.PtrType ty -> + C.PtrField (fromIntegral offset) ty + C.WordType ty -> + case valueBits defaultValue of + Nothing -> + error $ + "Invlaid schema: a field in a struct's data section " + ++ "had an illegal (non-data) default value." + Just defaultVal -> + C.DataField + (dataLoc offset ty defaultVal) + ty + C.CompositeType ty -> + C.PtrField (fromIntegral offset) (C.PtrComposite ty) + Schema.Field'group Schema.Field'group' {typeId} -> + C.HereField $ + C.StructType + (nodeMap M.! typeId) + (C.MapBrand M.empty) -- groups are always monomorphic + Schema.Field'unknown' _ -> + -- Don't know how to interpret this; we'll have to leave the argument + -- opaque. + C.VoidField -- | Given the offset field from the capnp schema, a type, and a -- default value, return a DataLoc describing the location of a field. dataLoc :: Word32 -> C.WordType Stage1.Node -> Word64 -> C.DataLoc dataLoc offset ty defaultVal = - let bitsOffset = fromIntegral offset * C.dataFieldSize ty - in C.DataLoc - { dataIdx = bitsOffset `div` 64 - , dataOff = bitsOffset `mod` 64 - , dataDef = defaultVal + let bitsOffset = fromIntegral offset * C.dataFieldSize ty + in C.DataLoc + { dataIdx = bitsOffset `div` 64, + dataOff = bitsOffset `mod` 64, + dataDef = defaultVal } -- | Return the raw bit-level representation of a value that is stored @@ -269,104 +277,105 @@ -- returns Nothing if the value is a non-word type. valueBits :: Parsed (Which Schema.Value) -> Maybe Word64 valueBits = \case - Schema.Value'bool b -> Just $ fromIntegral $ fromEnum b - Schema.Value'int8 n -> Just $ fromIntegral n - Schema.Value'int16 n -> Just $ fromIntegral n - Schema.Value'int32 n -> Just $ fromIntegral n - Schema.Value'int64 n -> Just $ fromIntegral n - Schema.Value'uint8 n -> Just $ fromIntegral n - Schema.Value'uint16 n -> Just $ fromIntegral n - Schema.Value'uint32 n -> Just $ fromIntegral n - Schema.Value'uint64 n -> Just n - Schema.Value'float32 n -> Just $ fromIntegral $ castFloatToWord32 n - Schema.Value'float64 n -> Just $ castDoubleToWord64 n - Schema.Value'enum n -> Just $ fromIntegral n - _ -> Nothing -- some non-word type. + Schema.Value'bool b -> Just $ fromIntegral $ fromEnum b + Schema.Value'int8 n -> Just $ fromIntegral n + Schema.Value'int16 n -> Just $ fromIntegral n + Schema.Value'int32 n -> Just $ fromIntegral n + Schema.Value'int64 n -> Just $ fromIntegral n + Schema.Value'uint8 n -> Just $ fromIntegral n + Schema.Value'uint16 n -> Just $ fromIntegral n + Schema.Value'uint32 n -> Just $ fromIntegral n + Schema.Value'uint64 n -> Just n + Schema.Value'float32 n -> Just $ fromIntegral $ castFloatToWord32 n + Schema.Value'float64 n -> Just $ castDoubleToWord64 n + Schema.Value'enum n -> Just $ fromIntegral n + _ -> Nothing -- some non-word type. reqFileToReqFile :: NodeMap Stage1.Node -> Parsed Schema.CodeGeneratorRequest'RequestedFile -> Stage1.ReqFile -reqFileToReqFile nodeMap Schema.CodeGeneratorRequest'RequestedFile{id, filename} = - let Stage1.Node{nodeCommon=Stage1.NodeCommon{nodeNested}} = nodeMap M.! id - in Stage1.ReqFile - { fileName = T.unpack filename - , file = Stage1.File - { fileNodes = nodeNested - , fileId = id - } +reqFileToReqFile nodeMap Schema.CodeGeneratorRequest'RequestedFile {id, filename} = + let Stage1.Node {nodeCommon = Stage1.NodeCommon {nodeNested}} = nodeMap M.! id + in Stage1.ReqFile + { fileName = T.unpack filename, + file = + Stage1.File + { fileNodes = nodeNested, + fileId = id + } } cgrToCgr :: Parsed Schema.CodeGeneratorRequest -> Stage1.CodeGenReq -cgrToCgr Schema.CodeGeneratorRequest{nodes, requestedFiles} = - Stage1.CodeGenReq{allFiles, reqFiles} +cgrToCgr Schema.CodeGeneratorRequest {nodes, requestedFiles} = + Stage1.CodeGenReq {allFiles, reqFiles} where - nodeMap = nodesToNodes $ M.fromList [(id, node) | node@Schema.Node{id} <- V.toList nodes] + nodeMap = nodesToNodes $ M.fromList [(id, node) | node@Schema.Node {id} <- V.toList nodes] reqFiles = map (reqFileToReqFile nodeMap) $ V.toList requestedFiles allFiles = - [ let fileNodes = - [ (Name.UnQ name, nodeMap M.! id) - | Schema.Node'NestedNode{name, id} <- V.toList nestedNodes - - -- If the file is an import (i.e. not part of requestedFiles), then - -- the code generator will sometimes omit parts of it that are not - -- used. We need to check that the nestedNodes are actually included; - -- if not, we omit them from the otuput as well. - , M.member id nodeMap - ] - in - Stage1.File{fileId, fileNodes} - | Schema.Node{union'=Schema.Node'file, id=fileId, nestedNodes} <- V.toList nodes - ] + [ let fileNodes = + [ (Name.UnQ name, nodeMap M.! id) + | Schema.Node'NestedNode {name, id} <- V.toList nestedNodes, + -- If the file is an import (i.e. not part of requestedFiles), then + -- the code generator will sometimes omit parts of it that are not + -- used. We need to check that the nestedNodes are actually included; + -- if not, we omit them from the otuput as well. + M.member id nodeMap + ] + in Stage1.File {fileId, fileNodes} + | Schema.Node {union' = Schema.Node'file, id = fileId, nestedNodes} <- V.toList nodes + ] -structTypeToType - :: NodeMap Stage1.Node - -> Word64 - -> Parsed Schema.Brand - -> C.CompositeType Stage1.Brand Stage1.Node +structTypeToType :: + NodeMap Stage1.Node -> + Word64 -> + Parsed Schema.Brand -> + C.CompositeType Stage1.Brand Stage1.Node structTypeToType nodeMap typeId brand = - C.StructType (nodeMap M.! typeId) (brandToBrand nodeMap brand) + C.StructType (nodeMap M.! typeId) (brandToBrand nodeMap brand) typeToType :: NodeMap Stage1.Node -> Parsed (Which Schema.Type) -> C.Type Stage1.Brand Stage1.Node typeToType nodeMap = \case - Schema.Type'void -> C.VoidType - Schema.Type'bool -> C.WordType $ C.PrimWord C.PrimBool - Schema.Type'int8 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz8 - Schema.Type'int16 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz16 - Schema.Type'int32 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz32 - Schema.Type'int64 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz64 - Schema.Type'uint8 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz8 - Schema.Type'uint16 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz16 - Schema.Type'uint32 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz32 - Schema.Type'uint64 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz64 - Schema.Type'float32 -> C.WordType $ C.PrimWord C.PrimFloat32 - Schema.Type'float64 -> C.WordType $ C.PrimWord C.PrimFloat64 - Schema.Type'text -> C.PtrType $ C.PrimPtr C.PrimText - Schema.Type'data_ -> C.PtrType $ C.PrimPtr C.PrimData - Schema.Type'list Schema.Type'list'{elementType = Schema.Type t} -> - C.PtrType $ C.ListOf (typeToType nodeMap t) - -- nb. enum has a brand field, but it's not actually use for anything. - Schema.Type'enum Schema.Type'enum'{typeId, brand = _ } -> - C.WordType $ C.EnumType $ nodeMap M.! typeId - -- TODO: use 'brand' to generate type parameters. - Schema.Type'struct Schema.Type'struct'{typeId, brand} -> - C.CompositeType $ structTypeToType nodeMap typeId brand - Schema.Type'interface Schema.Type'interface'{typeId, brand} -> - C.PtrType $ C.PtrInterface (C.InterfaceType (nodeMap M.! typeId) (brandToBrand nodeMap brand)) - Schema.Type'anyPointer (Schema.Type'anyPointer' p) -> - case p of - Schema.Type'anyPointer'parameter Schema.Type'anyPointer'parameter'{scopeId, parameterIndex} -> - let paramScope = nodeMap M.! scopeId in - C.PtrType $ C.PtrParam C.TypeParamRef - { paramScope - , paramIndex = fromIntegral parameterIndex - , paramName = Stage1.nodeParams (Stage1.nodeCommon paramScope) V.! fromIntegral parameterIndex - } - Schema.Type'anyPointer'unconstrained - (Schema.Type'anyPointer'unconstrained' unconstrained) -> - C.PtrType $ C.PrimPtr $ C.PrimAnyPtr $ case unconstrained of - Schema.Type'anyPointer'unconstrained'anyKind -> C.Ptr - Schema.Type'anyPointer'unconstrained'struct -> C.Struct - Schema.Type'anyPointer'unconstrained'list -> C.List - Schema.Type'anyPointer'unconstrained'capability -> C.Cap - Schema.Type'anyPointer'unconstrained'unknown' _ -> C.Ptr - -- ^ Something we don't know about; assume it could be anything. - _ -> C.VoidType -- TODO: implicitMethodParameter - _ -> C.VoidType -- TODO: constrained anyPointers + Schema.Type'void -> C.VoidType + Schema.Type'bool -> C.WordType $ C.PrimWord C.PrimBool + Schema.Type'int8 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz8 + Schema.Type'int16 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz16 + Schema.Type'int32 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz32 + Schema.Type'int64 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Signed C.Sz64 + Schema.Type'uint8 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz8 + Schema.Type'uint16 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz16 + Schema.Type'uint32 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz32 + Schema.Type'uint64 -> C.WordType $ C.PrimWord $ C.PrimInt $ C.IntType C.Unsigned C.Sz64 + Schema.Type'float32 -> C.WordType $ C.PrimWord C.PrimFloat32 + Schema.Type'float64 -> C.WordType $ C.PrimWord C.PrimFloat64 + Schema.Type'text -> C.PtrType $ C.PrimPtr C.PrimText + Schema.Type'data_ -> C.PtrType $ C.PrimPtr C.PrimData + Schema.Type'list Schema.Type'list' {elementType = Schema.Type t} -> + C.PtrType $ C.ListOf (typeToType nodeMap t) + -- nb. enum has a brand field, but it's not actually use for anything. + Schema.Type'enum Schema.Type'enum' {typeId, brand = _} -> + C.WordType $ C.EnumType $ nodeMap M.! typeId + -- TODO: use 'brand' to generate type parameters. + Schema.Type'struct Schema.Type'struct' {typeId, brand} -> + C.CompositeType $ structTypeToType nodeMap typeId brand + Schema.Type'interface Schema.Type'interface' {typeId, brand} -> + C.PtrType $ C.PtrInterface (C.InterfaceType (nodeMap M.! typeId) (brandToBrand nodeMap brand)) + Schema.Type'anyPointer (Schema.Type'anyPointer' p) -> + case p of + Schema.Type'anyPointer'parameter Schema.Type'anyPointer'parameter' {scopeId, parameterIndex} -> + let paramScope = nodeMap M.! scopeId + in C.PtrType $ + C.PtrParam + C.TypeParamRef + { paramScope, + paramIndex = fromIntegral parameterIndex, + paramName = Stage1.nodeParams (Stage1.nodeCommon paramScope) V.! fromIntegral parameterIndex + } + Schema.Type'anyPointer'unconstrained + (Schema.Type'anyPointer'unconstrained' unconstrained) -> + C.PtrType $ C.PrimPtr $ C.PrimAnyPtr $ case unconstrained of + Schema.Type'anyPointer'unconstrained'anyKind -> C.Ptr + Schema.Type'anyPointer'unconstrained'struct -> C.Struct + Schema.Type'anyPointer'unconstrained'list -> C.List + Schema.Type'anyPointer'unconstrained'capability -> C.Cap + Schema.Type'anyPointer'unconstrained'unknown' _ -> C.Ptr + -- \^ Something we don't know about; assume it could be anything. + _ -> C.VoidType -- TODO: implicitMethodParameter + _ -> C.VoidType -- TODO: constrained anyPointers diff --git a/cmd/capnpc-haskell/Trans/FlatToAbstractOp.hs b/cmd/capnpc-haskell/Trans/FlatToAbstractOp.hs new file mode 100644 --- /dev/null +++ b/cmd/capnpc-haskell/Trans/FlatToAbstractOp.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Trans.FlatToAbstractOp (cgrToFiles) where + +import qualified Capnp.Repr as R +import Data.Bifunctor (Bifunctor (..)) +import Data.Maybe (isJust) +import qualified IR.AbstractOp as AO +import qualified IR.Common as C +import qualified IR.Flat as Flat +import qualified IR.Name as Name + +cgrToFiles :: Flat.CodeGenReq -> [AO.File] +cgrToFiles = map fileToFile . Flat.reqFiles + +fileToFile :: Flat.File -> AO.File +fileToFile Flat.File {fileId, fileName, nodes} = + AO.File + { fileId, + fileName, + decls = concatMap nodeToDecls nodes, + usesRpc = not $ null [() | Flat.Node {union_ = Flat.Interface {}} <- nodes] + } + +mapTypes :: (Bifunctor p, Functor f) => p (f Flat.Node) Flat.Node -> p (f Name.CapnpQ) Name.CapnpQ +mapTypes = C.bothMap (\Flat.Node {name} -> name) + +nodeToDecls :: Flat.Node -> [AO.Decl] +nodeToDecls Flat.Node {nodeId, name = Name.CapnpQ {local}, typeParams, union_} = + let mkType repr extraTypeInfo = + AO.TypeDecl + { name = local, + nodeId, + params = map C.paramName typeParams, + repr, + extraTypeInfo + } + mkField field = + fieldToDecl local typeParams field + + mkMethodInfo Flat.Method {name, paramType, resultType} = + AO.MethodInfo + { typeParams = map C.paramName typeParams, + methodName = name, + paramType = mapTypes paramType, + resultType = mapTypes resultType + } + + parsedStructNode fields hasUnion isGroup = + AO.ParsedInstanceDecl + { typeName = local, + typeParams = map C.paramName typeParams, + parsedInstances = + AO.ParsedStruct + { fields = + [ ( Name.getUnQ fieldName, + mapTypes fieldLocType + ) + | Flat.Field {fieldName, fieldLocType} <- fields + ], + hasUnion, + dataCtorName = dataCtorName isGroup + } + } + + parsedUnionNode Flat.Union {variants} = + AO.ParsedInstanceDecl + { typeName = local, + typeParams = map C.paramName typeParams, + parsedInstances = + AO.ParsedUnion + { variants = + [ ( Name.getUnQ fieldName, + mapTypes fieldLocType + ) + | Flat.Variant {field = Flat.Field {fieldName, fieldLocType}} <- variants + ] + } + } + + dataCtorName isGroup + | isGroup = Name.mkSub local "" + | otherwise = local + + structUnionNodes Nothing = [] + structUnionNodes (Just union@Flat.Union {tagOffset, variants}) = + [ AO.UnionDecl + { name = local, + typeParams = map C.paramName typeParams, + tagLoc = + C.DataLoc + { dataIdx = fromIntegral $ tagOffset `div` 4, + dataOff = fromIntegral $ (tagOffset `mod` 4) * 16, + dataDef = 0 + }, + variants = map variantToVariant variants + }, + parsedUnionNode union + ] + in case union_ of + Flat.Other -> [] + Flat.Constant {value} -> + [AO.ConstDecl {name = local, value = mapTypes value}] + Flat.Enum enumerants -> + [mkType (R.Data R.Sz16) $ Just $ AO.EnumTypeInfo enumerants] + Flat.Interface {methods, supers} -> + let methodInfos = map mkMethodInfo methods + superTypes = map mapTypes supers + in mkType + (R.Ptr (Just R.Cap)) + ( Just + AO.InterfaceTypeInfo + { methods = methodInfos, + supers = superTypes + } + ) + : [ AO.SuperDecl + { subName = local, + typeParams = map C.paramName typeParams, + superType = superType + } + | superType <- superTypes + ] + ++ [ AO.MethodDecl + { interfaceName = local, + interfaceId = nodeId, + methodId, + methodInfo + } + | (methodId, methodInfo) <- zip [0 ..] methodInfos + ] + Flat.Struct {isGroup, fields, union, dataWordCount = nWords, pointerCount = nPtrs} -> + mkType (R.Ptr (Just R.Struct)) (Just AO.StructTypeInfo {nWords, nPtrs}) + : parsedStructNode fields (isJust union) isGroup + : (structUnionNodes union ++ map mkField fields) + +fieldToDecl :: Name.LocalQ -> [C.TypeParamRef Flat.Node] -> Flat.Field -> AO.Decl +fieldToDecl containerType typeParams Flat.Field {fieldName, fieldLocType} = + AO.FieldDecl + { containerType, + typeParams = map C.paramName typeParams, + fieldName = Name.getUnQ fieldName, + fieldLocType = mapTypes fieldLocType + } + +variantToVariant :: Flat.Variant -> AO.UnionVariant +variantToVariant Flat.Variant {tagValue, field = Flat.Field {fieldName, fieldLocType}} = + AO.UnionVariant + { variantName = Name.getUnQ fieldName, + tagValue, + fieldLocType = mapTypes fieldLocType + } diff --git a/cmd/capnpc-haskell/Trans/FlatToNew.hs b/cmd/capnpc-haskell/Trans/FlatToNew.hs deleted file mode 100644 --- a/cmd/capnpc-haskell/Trans/FlatToNew.hs +++ /dev/null @@ -1,152 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -module Trans.FlatToNew (cgrToFiles) where - -import Data.Bifunctor (Bifunctor(..)) - -import qualified Capnp.Repr as R -import Data.Maybe (isJust) -import qualified IR.Common as C -import qualified IR.Flat as Flat -import qualified IR.Name as Name -import qualified IR.New as New - -cgrToFiles :: Flat.CodeGenReq -> [New.File] -cgrToFiles = map fileToFile . Flat.reqFiles - -fileToFile :: Flat.File -> New.File -fileToFile Flat.File{fileId, fileName, nodes} = - New.File - { fileId - , fileName - , decls = concatMap nodeToDecls nodes - , usesRpc = not $ null [ () | Flat.Node{ union_ = Flat.Interface{} } <- nodes ] - } - -mapTypes :: (Bifunctor p, Functor f) => p (f Flat.Node) Flat.Node -> p (f Name.CapnpQ) Name.CapnpQ -mapTypes = C.bothMap (\Flat.Node{name} -> name) - -nodeToDecls :: Flat.Node -> [New.Decl] -nodeToDecls Flat.Node{nodeId, name=Name.CapnpQ{local}, typeParams, union_} = - let mkType repr extraTypeInfo = - New.TypeDecl - { name = local - , nodeId - , params = map C.paramName typeParams - , repr - , extraTypeInfo - } - mkField field = - fieldToDecl local typeParams field - - mkMethodInfo Flat.Method{name, paramType, resultType} = - New.MethodInfo - { typeParams = map C.paramName typeParams - , methodName = name - , paramType = mapTypes paramType - , resultType = mapTypes resultType - } - - parsedStructNode fields hasUnion isGroup = - New.ParsedInstanceDecl - { typeName = local - , typeParams = map C.paramName typeParams - , parsedInstances = New.ParsedStruct - { fields = - [ ( Name.getUnQ fieldName - , mapTypes fieldLocType - ) - | Flat.Field{fieldName, fieldLocType} <- fields - ] - , hasUnion - , dataCtorName = dataCtorName isGroup - } - } - - parsedUnionNode Flat.Union{variants} = - New.ParsedInstanceDecl - { typeName = local - , typeParams = map C.paramName typeParams - , parsedInstances = New.ParsedUnion - { variants = - [ ( Name.getUnQ fieldName - , mapTypes fieldLocType - ) - | Flat.Variant{field=Flat.Field{fieldName, fieldLocType}} <- variants - ] - } - } - - dataCtorName isGroup - | isGroup = Name.mkSub local "" - | otherwise = local - - structUnionNodes Nothing = [] - structUnionNodes (Just union@Flat.Union{tagOffset, variants}) = - [ New.UnionDecl - { name = local - , typeParams = map C.paramName typeParams - , tagLoc = C.DataLoc - { dataIdx = fromIntegral $ tagOffset `div` 4 - , dataOff = fromIntegral $ (tagOffset `mod` 4) * 16 - , dataDef = 0 - } - , variants = map variantToVariant variants - } - , parsedUnionNode union - ] - in - case union_ of - Flat.Other -> [] - Flat.Constant { value } -> - [ New.ConstDecl { name = local, value = mapTypes value } ] - Flat.Enum enumerants -> - [ mkType (R.Data R.Sz16) $ Just $ New.EnumTypeInfo enumerants ] - Flat.Interface{methods, supers} -> - let methodInfos = map mkMethodInfo methods - superTypes = map mapTypes supers - in - mkType - (R.Ptr (Just R.Cap)) - (Just New.InterfaceTypeInfo - { methods = methodInfos - , supers = superTypes - } - ) - : [ New.SuperDecl - { subName = local - , typeParams = map C.paramName typeParams - , superType = superType - } - | superType <- superTypes - ] ++ - [ New.MethodDecl - { interfaceName = local - , interfaceId = nodeId - , methodId - , methodInfo - } - | (methodId, methodInfo) <- zip [0..] methodInfos - ] - Flat.Struct{isGroup, fields, union, dataWordCount = nWords, pointerCount = nPtrs} -> - mkType (R.Ptr (Just R.Struct)) (Just New.StructTypeInfo { nWords, nPtrs }) - : parsedStructNode fields (isJust union) isGroup - : (structUnionNodes union ++ map mkField fields) - -fieldToDecl :: Name.LocalQ -> [C.TypeParamRef Flat.Node] -> Flat.Field -> New.Decl -fieldToDecl containerType typeParams Flat.Field{fieldName, fieldLocType} = - New.FieldDecl - { containerType - , typeParams = map C.paramName typeParams - , fieldName = Name.getUnQ fieldName - , fieldLocType = mapTypes fieldLocType - } - -variantToVariant :: Flat.Variant -> New.UnionVariant -variantToVariant Flat.Variant{tagValue, field = Flat.Field{fieldName, fieldLocType}} = - New.UnionVariant - { variantName = Name.getUnQ fieldName - , tagValue - , fieldLocType = mapTypes fieldLocType - } diff --git a/cmd/capnpc-haskell/Trans/HaskellToText.hs b/cmd/capnpc-haskell/Trans/HaskellToText.hs --- a/cmd/capnpc-haskell/Trans/HaskellToText.hs +++ b/cmd/capnpc-haskell/Trans/HaskellToText.hs @@ -1,21 +1,19 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + module Trans.HaskellToText (moduleToText) where -import Data.List (intersperse) -import Data.String (fromString) +import Data.List (intersperse) +import Data.String (fromString) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import qualified IR.Common as C +import IR.Haskell +import qualified IR.Name as Name import Text.PrettyPrint.Leijen.Text (hcat, vcat) -import Trans.ToHaskellCommon (eStd_) - -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT import qualified Text.PrettyPrint.Leijen.Text as PP - -import IR.Haskell - -import qualified IR.Common as C -import qualified IR.Name as Name +import Trans.ToHaskellCommon (eStd_) moduleToText :: Module -> LT.Text moduleToText mod = PP.displayT $ PP.renderPretty 0.4 80 (format mod) @@ -30,11 +28,12 @@ -- via the library and only ever render it in the one place (in main), it isn't -- a huge priority. class Format a where - format :: a -> PP.Doc + format :: a -> PP.Doc instance Format Module where - format Module{modName, modLangPragmas, modDecls, modExports, modImports} = vcat - [ vcat [ "{-# LANGUAGE " <> PP.textStrict ext <> " #-}" | ext <- modLangPragmas ] + format Module {modName, modLangPragmas, modDecls, modExports, modImports} = + vcat + [ vcat ["{-# LANGUAGE " <> PP.textStrict ext <> " #-}" | ext <- modLangPragmas], -- The generated code sometimes triggers these warnings, but they're nothing to -- worry about. -- @@ -42,294 +41,328 @@ -- export, in which case GHC complains in the machine readable module alias that -- we're trying to re-export everything from a module with no-exports. This -- happens with e.g. c++.capnp, which only defines annotations. - , "{-# OPTIONS_GHC -Wno-unused-imports #-}" - , "{-# OPTIONS_GHC -Wno-dodgy-exports #-}" - , "{-# OPTIONS_GHC -Wno-unused-matches #-}" - , "{-# OPTIONS_GHC -Wno-orphans #-}" - , "{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}" - , "{-# OPTIONS_GHC -Wno-name-shadowing #-}" - , hcat - [ "module " - , PP.textStrict $ mconcat $ intersperse "." $ map Name.renderUnQ modName - , case modExports of - Nothing -> "" - Just exports -> - PP.tupled (map format exports) - , " where" - ] - , vcat $ map format modImports + "{-# OPTIONS_GHC -Wno-unused-imports #-}", + "{-# OPTIONS_GHC -Wno-dodgy-exports #-}", + "{-# OPTIONS_GHC -Wno-unused-matches #-}", + "{-# OPTIONS_GHC -Wno-orphans #-}", + "{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}", + "{-# OPTIONS_GHC -Wno-name-shadowing #-}", + hcat + [ "module ", + PP.textStrict $ mconcat $ intersperse "." $ map Name.renderUnQ modName, + case modExports of + Nothing -> "" + Just exports -> + PP.tupled (map format exports), + " where" + ], + vcat $ map format modImports, -- We import many things, including the prelude, qualified under the -- "Std_" namespace, so that they don't collide with names in the -- generated code; see issue #58. - , vcat $ map format - [ ImportAs { importAs = "Std_", parts = ["Prelude"] } - , ImportAs { importAs = "Std_", parts = ["Data", "Word"] } - , ImportAs { importAs = "Std_", parts = ["Data", "Int"] } - ] + vcat $ + map + format + [ ImportAs {importAs = "Std_", parts = ["Prelude"]}, + ImportAs {importAs = "Std_", parts = ["Data", "Word"]}, + ImportAs {importAs = "Std_", parts = ["Data", "Int"]} + ], -- ...but there are a couple operators we still want unqaulified: - , "import Prelude ((<$>), (<*>), (>>=))" - , vcat $ map format modDecls - ] + "import Prelude ((<$>), (<*>), (>>=))", + vcat $ map format modDecls + ] instance Format Export where - format (ExportMod parts) = - "module " <> PP.textStrict (mconcat $ intersperse "." $ map Name.renderUnQ parts) - format (ExportLCtors name) = format name <> "(..)" - format (ExportGCtors name) = format name <> "(..)" - format (ExportGName name) = format name - format (ExportLName name) = format name + format (ExportMod parts) = + "module " <> PP.textStrict (mconcat $ intersperse "." $ map Name.renderUnQ parts) + format (ExportLCtors name) = format name <> "(..)" + format (ExportGCtors name) = format name <> "(..)" + format (ExportGName name) = format name + format (ExportLName name) = format name instance Format Decl where - format (DcData d) = format d - format DcValue{typ, def=def@DfValue{name}} = vcat - [ hcat [ format name, " :: ", format typ ] - , format def - ] - format DcInstance{ctx, typ, defs} = hcat - [ "instance " - , format (TCtx ctx typ) - , whereBlock defs - ] - format (DcTypeInstance alias orig) = hcat - [ "type instance " - , format alias - , " = " - , format orig - ] - format (DcDeriveInstance ctx typ) = hcat - [ "deriving instance " - , format $ TCtx ctx typ - ] - format DcClass{ctx, name, params, funDeps, decls} = hcat - [ "class " - , format $ - TCtx ctx $ - TApp - (TLName name) - [TLName (Name.unQToLocal p) | p <- params] - , formatFunDeps funDeps - , whereBlock decls - ] + format (DcData d) = format d + format DcValue {typ, def = def@DfValue {name}} = + vcat + [ hcat [format name, " :: ", format typ], + format def + ] + format DcInstance {ctx, typ, defs} = + hcat + [ "instance ", + format (TCtx ctx typ), + whereBlock defs + ] + format (DcTypeInstance alias orig) = + hcat + [ "type instance ", + format alias, + " = ", + format orig + ] + format (DcDeriveInstance ctx typ) = + hcat + [ "deriving instance ", + format $ TCtx ctx typ + ] + format DcClass {ctx, name, params, funDeps, decls} = + hcat + [ "class ", + format $ + TCtx ctx $ + TApp + (TLName name) + [TLName (Name.unQToLocal p) | p <- params], + formatFunDeps funDeps, + whereBlock decls + ] formatFunDeps :: [(T.Text, T.Text)] -> PP.Doc formatFunDeps [] = "" -formatFunDeps deps = mconcat - [ " | " - , mconcat $ intersperse ", " - [ PP.textStrict a <> " -> " <> PP.textStrict b - | (a, b) <- deps - ] +formatFunDeps deps = + mconcat + [ " | ", + mconcat $ + intersperse + ", " + [ PP.textStrict a <> " -> " <> PP.textStrict b + | (a, b) <- deps + ] ] whereBlock :: Format a => [a] -> PP.Doc whereBlock [] = "" -whereBlock xs = vcat - [ " where" - , indent $ vcat $ map format xs +whereBlock xs = + vcat + [ " where", + indent $ vcat $ map format xs ] instance Format ClassDecl where - format (CdValueDecl name typ) = hcat [ format name, " :: ", format typ ] - format (CdValueDef def) = format def - format (CdMinimal names) = hcat - [ "{-# MINIMAL " - , hcat $ PP.punctuate PP.comma (map format names) - , " #-}" - ] + format (CdValueDecl name typ) = hcat [format name, " :: ", format typ] + format (CdValueDef def) = format def + format (CdMinimal names) = + hcat + [ "{-# MINIMAL ", + hcat $ PP.punctuate PP.comma (map format names), + " #-}" + ] instance Format InstanceDef where - format (IdData d) = format d - format (IdValue d) = format d - format (IdType d) = format d + format (IdData d) = format d + format (IdValue d) = format d + format (IdType d) = format d instance Format TypeAlias where - format (TypeAlias name params value) = hcat - [ "type " - , format name - , " " - , mconcat $ intersperse " " (map format params) - , " = " - , format value - ] + format (TypeAlias name params value) = + hcat + [ "type ", + format name, + " ", + mconcat $ intersperse " " (map format params), + " = ", + format value + ] instance Format DataDecl where - format Data{dataName, typeArgs, dataVariants, dataInstance, dataNewtype, derives} = vcat - [ hcat - [ if dataNewtype - then "newtype " - else "data " - , if dataInstance - then "instance " - else "" - , format dataName - , " " - , mconcat $ intersperse " " $ map format typeArgs - ] - , indent $ vcat + format Data {dataName, typeArgs, dataVariants, dataInstance, dataNewtype, derives} = + vcat + [ hcat + [ if dataNewtype + then "newtype " + else "data ", + if dataInstance + then "instance " + else "", + format dataName, + " ", + mconcat $ intersperse " " $ map format typeArgs + ], + indent $ + vcat [ case dataVariants of - (d:ds) -> vcat $ ("= " <> format d) : map (("| " <>) . format) ds - [] -> "" - , formatDerives derives + (d : ds) -> vcat $ ("= " <> format d) : map (("| " <>) . format) ds + [] -> "", + formatDerives derives ] - ] + ] instance Format ValueDef where - format DfValue{name, value, params} = hcat - [ format name - , " " - , hcat $ intersperse " " $ map format params - , " = " - , format value - ] + format DfValue {name, value, params} = + hcat + [ format name, + " ", + hcat $ intersperse " " $ map format params, + " = ", + format value + ] instance Format Exp where - format (EApp e []) = format e - format (EApp e es) = hcat - [ "(" - , hcat $ intersperse " " $ map format (e:es) - , ")" - ] - format (EFApp e []) = format (EApp (eStd_ "pure") [e]) - format (EFApp e es) = hcat - [ "(" - , format e - , PP.encloseSep " <$> " ")" " <*> " $ map format es - ] - format (EGName e) = format e - format (ELName e) = format e - format (EVar name) = PP.textStrict name - format (EInt n) = fromString (show n) - format (EDo ds ex) = vcat - [ "(do" - , indent $ vcat (map format ds ++ [format ex, ")"]) - ] - format (EBind x f) = PP.parens (format x <> " >>= " <> format f) - format (ETup es) = PP.tupled (map format es) - format (EList es) = PP.list (map format es) - format (ECase ex arms) = vcat - [ hcat [ "case ", format ex, " of"] - , indent $ vcat + format (EApp e []) = format e + format (EApp e es) = + hcat + [ "(", + hcat $ intersperse " " $ map format (e : es), + ")" + ] + format (EFApp e []) = format (EApp (eStd_ "pure") [e]) + format (EFApp e es) = + hcat + [ "(", + format e, + PP.encloseSep " <$> " ")" " <*> " $ map format es + ] + format (EGName e) = format e + format (ELName e) = format e + format (EVar name) = PP.textStrict name + format (EInt n) = fromString (show n) + format (EDo ds ex) = + vcat + [ "(do", + indent $ vcat (map format ds ++ [format ex, ")"]) + ] + format (EBind x f) = PP.parens (format x <> " >>= " <> format f) + format (ETup es) = PP.tupled (map format es) + format (EList es) = PP.list (map format es) + format (ECase ex arms) = + vcat + [ hcat ["case ", format ex, " of"], + indent $ + vcat [ vcat - [ hcat [ format p, " ->" ] - , indent (format e) + [ hcat [format p, " ->"], + indent (format e) ] - | (p, e) <- arms + | (p, e) <- arms ] + ] + format (ETypeAnno e ty) = + PP.parens $ + hcat + [ format e, + " :: ", + format ty ] - format (ETypeAnno e ty) = PP.parens $ hcat - [ format e - , " :: " - , format ty + format (EBytes bytes) = fromString (show bytes) + format (ELambda params body) = + PP.parens $ + hcat + [ "\\", + hcat (PP.punctuate " " (map format params)), + " -> ", + format body ] - format (EBytes bytes) = fromString (show bytes) - format (ELambda params body) = PP.parens $ hcat - [ "\\" - , hcat (PP.punctuate " " (map format params)) - , " -> " - , format body + format (ERecord old updates) = + format old + <> PP.encloseSep + "{" + "}" + "," + [ hcat [format name, " = ", format value] + | (name, value) <- updates ] - format (ERecord old updates) = - format old <> PP.encloseSep "{" "}" "," - [ hcat [ format name, " = ", format value ] - | (name, value) <- updates - ] - format (ETypeApp e ts) = - hcat ("(": format e : [ " @(" <> format t <> ")" | t <- ts ] ++ [")"]) - format (ELabel name) = "#" <> format name + format (ETypeApp e ts) = + hcat ("(" : format e : [" @(" <> format t <> ")" | t <- ts] ++ [")"]) + format (ELabel name) = "#" <> format name instance Format Do where - format (DoBind var ex) = format var <> " <- " <> format ex - format (DoE ex) = format ex + format (DoBind var ex) = format var <> " <- " <> format ex + format (DoE ex) = format ex instance Format Pattern where - format (PVar v) = PP.textStrict v - format (PLCtor c ps) = hcat - [ "(" - , mconcat $ intersperse " " (format c : map format ps) - , ")" - ] - format (PGCtor c ps) = hcat - [ "(" - , mconcat $ intersperse " " (format c : map format ps) - , ")" - ] - format (PInt n) = fromString (show n) - format (PLRecordWildCard name) = format name <> "{..}" + format (PVar v) = PP.textStrict v + format (PLCtor c ps) = + hcat + [ "(", + mconcat $ intersperse " " (format c : map format ps), + ")" + ] + format (PGCtor c ps) = + hcat + [ "(", + mconcat $ intersperse " " (format c : map format ps), + ")" + ] + format (PInt n) = fromString (show n) + format (PLRecordWildCard name) = format name <> "{..}" formatDerives :: [Name.UnQ] -> PP.Doc formatDerives [] = "" formatDerives ds = "deriving" <> PP.tupled (map format ds) instance Format DataVariant where - format DataVariant{dvCtorName, dvArgs} = - hcat [ format dvCtorName, " ", format dvArgs ] + format DataVariant {dvCtorName, dvArgs} = + hcat [format dvCtorName, " ", format dvArgs] instance Format DataArgs where - format (APos types) = - mconcat $ intersperse " " (map format types) - format (ARec fields) = PP.line <> indent - (PP.encloseSep - "{" "}" "," - [ format name <> " :: " <> format ty | (name, ty) <- fields ] + format (APos types) = + mconcat $ intersperse " " (map format types) + format (ARec fields) = + PP.line + <> indent + ( PP.encloseSep + "{" + "}" + "," + [format name <> " :: " <> format ty | (name, ty) <- fields] ) instance Format Type where - format (TGName ty) = format ty - format (TLName ty) = format ty - format (TVar txt) = PP.textStrict txt - format (TApp t []) = format t - format (TApp f xs) = - "(" <> mconcat (intersperse " " $ map format (f:xs)) <> ")" - format (TFn types) = - mconcat $ intersperse " -> " $ map format types - format (TCtx[] ty) = format ty - format (TCtx constraints ty) = - PP.tupled (map format constraints) <> " => " <> format ty - format (TPrim ty) = format ty - format TUnit = "()" - format (TKindAnnotated ty kind) = - "(" <> format ty <> " :: " <> format kind <> ")" - format (TString str) = fromString $ show str + format (TGName ty) = format ty + format (TLName ty) = format ty + format (TVar txt) = PP.textStrict txt + format (TApp t []) = format t + format (TApp f xs) = + "(" <> mconcat (intersperse " " $ map format (f : xs)) <> ")" + format (TFn types) = + mconcat $ intersperse " -> " $ map format types + format (TCtx [] ty) = format ty + format (TCtx constraints ty) = + PP.tupled (map format constraints) <> " => " <> format ty + format (TPrim ty) = format ty + format TUnit = "()" + format (TKindAnnotated ty kind) = + "(" <> format ty <> " :: " <> format kind <> ")" + format (TString str) = fromString $ show str instance Format Name.GlobalQ where - format Name.GlobalQ{local, globalNS=Name.NS parts} = - mconcat - [ mconcat $ intersperse "." (map PP.textStrict parts) - , "." - , format local - ] + format Name.GlobalQ {local, globalNS = Name.NS parts} = + mconcat + [ mconcat $ intersperse "." (map PP.textStrict parts), + ".", + format local + ] instance Format Name.LocalQ where - format = PP.textStrict . Name.renderLocalQ + format = PP.textStrict . Name.renderLocalQ instance Format Name.UnQ where - format = PP.textStrict . Name.renderUnQ - + format = PP.textStrict . Name.renderUnQ instance Format Import where - format ImportAs{importAs, parts} = hcat - [ "import qualified " - , implodeNS parts - , " as " - , format importAs - ] - format ImportQual{ parts } = hcat [ "import qualified ", implodeNS parts ] - format ImportAll { parts } = hcat [ "import ", implodeNS parts ] + format ImportAs {importAs, parts} = + hcat + [ "import qualified ", + implodeNS parts, + " as ", + format importAs + ] + format ImportQual {parts} = hcat ["import qualified ", implodeNS parts] + format ImportAll {parts} = hcat ["import ", implodeNS parts] implodeNS :: Format a => [a] -> PP.Doc implodeNS parts = mconcat $ intersperse "." (map format parts) instance Format C.PrimWord where - format C.PrimBool = "Std_.Bool" - format (C.PrimInt (C.IntType sign sz)) = - let szDoc = fromString $ show $ C.sizeBits sz - typePrefix = case sign of - C.Signed -> "Int" - C.Unsigned -> "Word" - in - "Std_." <> typePrefix <> szDoc - format C.PrimFloat32 = "Std_.Float" - format C.PrimFloat64 = "Std_.Double" + format C.PrimBool = "Std_.Bool" + format (C.PrimInt (C.IntType sign sz)) = + let szDoc = fromString $ show $ C.sizeBits sz + typePrefix = case sign of + C.Signed -> "Int" + C.Unsigned -> "Word" + in "Std_." <> typePrefix <> szDoc + format C.PrimFloat32 = "Std_.Float" + format C.PrimFloat64 = "Std_.Double" -- | Indent the argument by four spaces. indent :: PP.Doc -> PP.Doc diff --git a/cmd/capnpc-haskell/Trans/NewToHaskell.hs b/cmd/capnpc-haskell/Trans/NewToHaskell.hs deleted file mode 100644 --- a/cmd/capnpc-haskell/Trans/NewToHaskell.hs +++ /dev/null @@ -1,1032 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -module Trans.NewToHaskell - ( fileToModules - ) where - -import qualified Capnp.Repr as R -import Control.Monad (guard) -import Data.String (IsString(fromString)) -import Data.Word -import qualified IR.Common as C -import qualified IR.Haskell as Hs -import qualified IR.Name as Name -import qualified IR.New as New -import Trans.ToHaskellCommon - --- | Modules imported by all generated modules. -imports :: [Hs.Import] -imports = - [ Hs.ImportAs { importAs = "R", parts = ["Capnp", "Repr"] } - , Hs.ImportAs { importAs = "RP", parts = ["Capnp", "Repr", "Parsed"] } - , Hs.ImportAs { importAs = "Basics", parts = ["Capnp", "New", "Basics"] } - , Hs.ImportAs { importAs = "OL", parts = ["GHC", "OverloadedLabels"] } - , Hs.ImportAs { importAs = "GH", parts = ["Capnp", "GenHelpers", "New"] } - , Hs.ImportAs { importAs = "C", parts = ["Capnp", "New", "Classes"] } - , Hs.ImportAs { importAs = "Generics", parts = ["GHC", "Generics"] } - ] - --- | Modules imported by generated modules that use rpc. We separate these out to --- avoid a circular import when generating code for rpc.capnp -- which does not --- contain interfaces, so does not need to import the rpc system -- but which --- must be imported *by* the rpc system. -rpcImports :: [Hs.Import] -rpcImports = - [ Hs.ImportAs { importAs = "GH", parts = ["Capnp", "GenHelpers", "New", "Rpc"] } - ] - -fileToModules :: New.File -> [Hs.Module] -fileToModules file = - [ fileToMainModule file - , fileToModuleAlias file - ] - -fileToMainModule :: New.File -> Hs.Module -fileToMainModule file@New.File{fileName, usesRpc} = - fixImports $ Hs.Module - { modName = ["Capnp", "Gen"] ++ makeModName fileName ++ ["New"] - , modLangPragmas = - [ "TypeFamilies" - , "DataKinds" - , "DeriveGeneric" - , "DuplicateRecordFields" - , "EmptyDataDeriving" - , "FlexibleContexts" - , "FlexibleInstances" - , "MultiParamTypeClasses" - , "UndecidableInstances" - , "UndecidableSuperClasses" - , "OverloadedLabels" - , "OverloadedStrings" - , "StandaloneDeriving" - , "RecordWildCards" - , "TypeApplications" - , "ScopedTypeVariables" - ] - , modExports = Nothing - , modImports = imports ++ (guard usesRpc >> rpcImports) - , modDecls = fileToDecls file - } - -fileToModuleAlias :: New.File -> Hs.Module -fileToModuleAlias New.File{fileId,fileName} = - let reExport = ["Capnp", "Gen"] ++ makeModName fileName ++ ["New"] - in Hs.Module - { modName = idToModule fileId ++ ["New"] - , modLangPragmas = [] - , modExports = Just [Hs.ExportMod reExport] - , modImports = [ Hs.ImportAll { parts = reExport } ] - , modDecls = [] - } - -fileToDecls :: New.File -> [Hs.Decl] -fileToDecls New.File{fileId, decls} = - concatMap (declToDecls fileId) decls - - -declToDecls :: Word64 -> New.Decl -> [Hs.Decl] -declToDecls thisMod decl = - case decl of - New.TypeDecl {name, nodeId, params, repr, extraTypeInfo} -> - let dataName = Name.localToUnQ name - typeArgs = toTVars params - typ = case typeArgs of - [] -> tuName dataName - _ -> Hs.TApp (tuName dataName) typeArgs - in - [ Hs.DcData Hs.Data - { dataName - , typeArgs - , dataVariants = - case extraTypeInfo of - Just (New.EnumTypeInfo variants) -> - [ Hs.DataVariant - { dvCtorName = Name.localToUnQ $ Name.mkSub name variantName - , dvArgs = Hs.APos [] - } - | variantName <- variants - ] - ++ - [ declareUnknownVariant name ] - _ -> [] - , derives = - case extraTypeInfo of - Just New.EnumTypeInfo {} -> [ "Std_.Eq", "Std_.Show", "Generics.Generic" ] - _ -> [] - , dataNewtype = False - , dataInstance = False - } - , Hs.DcTypeInstance - (Hs.TApp (tgName ["R"] "ReprFor") [typ]) - (toType repr) - , Hs.DcInstance - { ctx = [] - , typ = Hs.TApp (tgName ["C"] "HasTypeId") [typ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "typeId" - , params = [] - , value = Hs.EInt (fromIntegral nodeId) - } - ] - } - ] ++ - let ctx = paramsContext typeArgs in - case extraTypeInfo of - Just New.StructTypeInfo{nWords, nPtrs} -> - [ Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "TypedStruct") [typ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "numStructWords" - , params = [] - , value = Hs.EInt $ fromIntegral nWords - } - , Hs.IdValue Hs.DfValue - { name = "numStructPtrs" - , params = [] - , value = Hs.EInt $ fromIntegral nPtrs - } - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "Allocate") [typ] - , defs = - [ Hs.IdType $ - Hs.TypeAlias "AllocHint" [typ] Hs.TUnit - , Hs.IdValue Hs.DfValue - { name = "new" - , params = [Hs.PVar "_"] - , value = egName ["C"] "newTypedStruct" - } - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp - (tgName ["C"] "EstimateAlloc") - [ typ, Hs.TApp (tgName ["C"] "Parsed") [typ] ] - , defs = [] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "AllocateList") [typ] - , defs = - [ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int") - , Hs.IdValue Hs.DfValue - { name = "newList" - , params = [] - , value = egName ["C"] "newTypedStructList" - } - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp - (tgName ["C"] "EstimateListAlloc") - [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]] - , defs = [] - } - ] - Just (New.EnumTypeInfo variants) -> - [ Hs.DcInstance - { ctx - , typ = Hs.TApp (tStd_ "Enum") [typ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "toEnum" - , params = [Hs.PVar "n_"] - , value = - Hs.ECase (euName "n_") $ - [ ( Hs.PInt i - , Hs.ELName (Name.mkSub name variantName) - ) - | (i, variantName) <- zip [0..] variants - ] ++ - [ ( Hs.PVar "tag_" - , Hs.EApp - (Hs.ELName (unknownVariant name)) - [Hs.EApp (eStd_ "fromIntegral") [euName "tag_"]] - ) - ] - - } - , Hs.IdValue Hs.DfValue - { name = "fromEnum" - , params = [Hs.PVar "value_"] - , value = - Hs.ECase (euName "value_") $ - [ ( Hs.PLCtor (Name.mkSub name variantName) [] - , Hs.EInt i - ) - | (i, variantName) <- zip [0..] variants - ] ++ - [ ( Hs.PLCtor (unknownVariant name) [Hs.PVar "tag_"] - , Hs.EApp (eStd_ "fromIntegral") [euName "tag_"] - ) - ] - } - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "IsWord") [typ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "fromWord" - , params = [Hs.PVar "w_"] - , value = Hs.EApp (eStd_ "toEnum") [Hs.EApp (eStd_ "fromIntegral") [Hs.EVar "w_"]] - } - , Hs.IdValue Hs.DfValue - { name = "toWord" - , params = [Hs.PVar "v_"] - , value = Hs.EApp (eStd_ "fromIntegral") [Hs.EApp (eStd_ "fromEnum") [Hs.EVar "v_"]] - } - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "Parse") [typ, typ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "parse" - , params = [] - , value = egName ["GH"] "parseEnum" - } - , Hs.IdValue Hs.DfValue - { name = "encode" - , params = [] - , value = egName ["GH"] "encodeEnum" - } - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "AllocateList") [typ] - , defs = - [ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int") - ] - } - , Hs.DcInstance - { ctx - , typ = Hs.TApp (tgName ["C"] "EstimateListAlloc") [typ, typ] - , defs = [] - } - ] - Just New.InterfaceTypeInfo {methods, supers} -> - defineInterfaceParse name params - ++ defineInterfaceServer thisMod name params methods supers - Nothing -> [] - New.FieldDecl{containerType, typeParams, fieldName, fieldLocType} -> - let tVars = toTVars typeParams - ctx = paramsContext tVars - labelType = Hs.TString (Name.renderUnQ fieldName) - parentType = Hs.TApp (Hs.TLName containerType) tVars - childType = fieldLocTypeToType thisMod fieldLocType - fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType - in - [ Hs.DcInstance - { ctx - , typ = Hs.TApp - (tgName ["GH"] "HasField") - [labelType, fieldKind, parentType, childType] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "fieldByLabel" - , value = fieldLocTypeToField fieldLocType - , params = [] - } - ] - } - ] - New.UnionDecl{name, typeParams, tagLoc, variants} -> - let tVars = toTVars typeParams - typ = Hs.TApp (Hs.TLName name) tVars - in - Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp (tgName ["GH"] "HasUnion") [typ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "unionField" - , params = [] - , value = fieldLocTypeToField $ C.DataField - tagLoc - (C.PrimWord (C.PrimInt (C.IntType C.Unsigned C.Sz16))) - } - , defineRawData thisMod name tVars variants - , defineInternalWhich name variants - , Hs.IdData Hs.Data - { dataName = "Which" - , typeArgs = [typ] - , dataVariants = [] - , derives = [] - , dataNewtype = False - , dataInstance = False - } - ] - } - : concatMap (variantToDecls thisMod name typeParams) variants - New.SuperDecl { subName, typeParams, superType } -> - let tVars = toTVars typeParams in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp (tgName ["C"] "Super") - [ typeToType thisMod $ C.PtrType $ C.PtrInterface superType - , Hs.TApp (Hs.TLName subName) tVars - ] - , defs = [] - } - ] - New.MethodDecl - { interfaceName - , interfaceId - , methodId - , methodInfo = New.MethodInfo - { typeParams - , methodName - , paramType - , resultType - } - } -> - let tVars = toTVars typeParams in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp - (tgName ["GH"] "HasMethod") - [ Hs.TString (Name.renderUnQ methodName) - , Hs.TApp (Hs.TLName interfaceName) tVars - , compositeTypeToType thisMod paramType - , compositeTypeToType thisMod resultType - ] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "methodByLabel" - , params = [] - , value = Hs.EApp - (egName ["GH"] "Method") - [ Hs.EInt $ fromIntegral interfaceId - , Hs.EInt $ fromIntegral methodId - ] - } - ] - } - ] - New.ParsedInstanceDecl{ typeName, typeParams, parsedInstances } -> - defineParsedInstances thisMod typeName typeParams parsedInstances - New.ConstDecl { name, value } -> - defineConstant thisMod name value - -defineConstant thisMod localName value = - let name = Name.localToUnQ localName in - case value of - C.VoidValue -> - [ Hs.DcValue - { typ = Hs.TUnit - , def = Hs.DfValue - { name - , params = [] - , value = Hs.ETup [] - } - } - ] - C.WordValue t v -> - [ Hs.DcValue - { typ = typeToType thisMod (C.WordType t) - , def = Hs.DfValue - { name - , params = [] - , value = Hs.EApp (egName ["C"] "fromWord") [Hs.EInt (fromIntegral v)] - } - } - ] - C.PtrValue t v -> - [ Hs.DcValue - { typ = Hs.TApp (tgName ["R"] "Raw") [ typeToType thisMod (C.PtrType t), tgName ["GH"] "Const"] - , def = Hs.DfValue - { name - , params = [] - , value = Hs.EApp - (egName ["GH"] "getPtrConst") - [Hs.ETypeAnno (Hs.EBytes (makePtrBytes v)) (tgName ["GH"] "ByteString")] - } - } - ] - -defineRawData thisMod name tVars variants = - Hs.IdData Hs.Data - { dataName = "RawWhich" - , typeArgs = - [ Hs.TApp (Hs.TVar $ Name.renderUnQ $ Name.localToUnQ name) tVars - , Hs.TVar "mut_" - ] - - , dataNewtype = False - , dataInstance = False - , dataVariants = - [ Hs.DataVariant - { dvCtorName = - "RW_" <> Name.localToUnQ (Name.mkSub name variantName) - , dvArgs = Hs.APos - [ Hs.TApp - (tReprName "Raw") - [ fieldLocTypeToType thisMod fieldLocType - , Hs.TVar "mut_" - ] - ] - } - | New.UnionVariant{variantName, fieldLocType} <- variants - ] - ++ - [ Hs.DataVariant - { dvCtorName = "RW_" <> Name.localToUnQ (unknownVariant name) - , dvArgs = Hs.APos [tStd_ "Word16"] - } - ] - - -- TODO: derive Show, Read, Eq, Generic, to be feature complete with the code generated by RawToHaskell. - -- This will require a stand-alone deriving declaration - , derives = [] - } - -unknownVariant :: Name.LocalQ -> Name.LocalQ -unknownVariant name = Name.mkSub name "unknown'" - -rawCtorName :: Name.LocalQ -> Name.UnQ -rawCtorName local = "RW_" <> Name.localToUnQ local - - -defineInternalWhich structName variants = - Hs.IdValue Hs.DfValue - { name = "internalWhich" - , params = [Hs.PVar "tag_", Hs.PVar "struct_"] - , value = - Hs.ECase (Hs.ELName "tag_") $ - [ ( Hs.PInt $ fromIntegral tagValue - , Hs.EFApp - (euName $ rawCtorName (Name.mkSub structName variantName)) - [ Hs.EApp - (egName ["GH"] "readVariant") - [ Hs.ELabel variantName - , euName "struct_" - ] - ] - ) - | New.UnionVariant{tagValue, variantName} <- variants - ] - ++ - [ ( Hs.PVar "_" - , Hs.EApp (eStd_ "pure") - [ Hs.EApp - (euName $ rawCtorName (unknownVariant structName)) - [euName "tag_"] - ] - ) - ] - } - -variantToDecls thisMod containerType typeParams New.UnionVariant{tagValue, variantName, fieldLocType} = - let tVars = toTVars typeParams - ctx = paramsContext tVars - labelType = Hs.TString (Name.renderUnQ variantName) - parentType = Hs.TApp (Hs.TLName containerType) tVars - childType = fieldLocTypeToType thisMod fieldLocType - fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType - in - [ Hs.DcInstance - { ctx - , typ = Hs.TApp - (tgName ["GH"] "HasVariant") - [labelType, fieldKind, parentType, childType] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "variantByLabel" - , params = [] - , value = Hs.EApp - (egName ["GH"] "Variant") - [ fieldLocTypeToField fieldLocType - , Hs.EInt (fromIntegral tagValue) - ] - } - ] - } - ] - -paramsContext :: [Hs.Type] -> [Hs.Type] -paramsContext = map paramConstraints - --- | Constraints required for a capnproto type parameter. The returned --- expression has kind 'Constraint'. -paramConstraints :: Hs.Type -> Hs.Type -paramConstraints t = - Hs.TApp (tgName ["GH"] "TypeParam") [t] - -tCapnp :: Word64 -> Name.CapnpQ -> Hs.Type -tCapnp thisMod Name.CapnpQ{local, fileId} - | thisMod == fileId = Hs.TLName local - | otherwise = tgName (map Name.renderUnQ $ idToModule fileId ++ ["New"]) local - -fieldLocTypeToType :: Word64 -> C.FieldLocType New.Brand Name.CapnpQ -> Hs.Type -fieldLocTypeToType thisMod = \case - C.VoidField -> Hs.TUnit - C.DataField _ t -> wordTypeToType thisMod t - C.PtrField _ t -> ptrTypeToType thisMod t - C.HereField t -> compositeTypeToType thisMod t - -fieldLocTypeToFieldKind :: C.FieldLocType b n -> Name.GlobalQ -fieldLocTypeToFieldKind = \case - C.HereField _ -> gName ["GH"] "Group" - _ -> gName ["GH"] "Slot" - -wordTypeToType thisMod = \case - C.EnumType t -> tCapnp thisMod t - C.PrimWord t -> primWordToType t - -primWordToType = \case - C.PrimInt t -> intTypeToType t - C.PrimFloat32 -> tStd_ "Float" - C.PrimFloat64 -> tStd_ "Double" - C.PrimBool -> tStd_ "Bool" - -intTypeToType (C.IntType sign size) = - let prefix = case sign of - C.Signed -> "Int" - C.Unsigned -> "Word" - in - tStd_ $ fromString $ prefix ++ show (C.sizeBits size) - -wordTypeBits = \case - C.EnumType _ -> 16 - C.PrimWord (C.PrimInt (C.IntType _ size)) -> C.sizeBits size - C.PrimWord C.PrimFloat32 -> 32 - C.PrimWord C.PrimFloat64 -> 64 - C.PrimWord C.PrimBool -> 1 - -ptrTypeToType thisMod = \case - C.ListOf t -> Hs.TApp (tgName ["R"] "List") [typeToType thisMod t] - C.PrimPtr t -> primPtrToType t - C.PtrComposite t -> compositeTypeToType thisMod t - C.PtrInterface t -> interfaceTypeToType thisMod t - C.PtrParam t -> typeParamToType t - -typeToType thisMod = \case - C.CompositeType t -> compositeTypeToType thisMod t - C.VoidType -> Hs.TUnit - C.WordType t -> wordTypeToType thisMod t - C.PtrType t -> ptrTypeToType thisMod t - -primPtrToType = \case - C.PrimText -> tgName ["Basics"] "Text" - C.PrimData -> tgName ["Basics"] "Data" - C.PrimAnyPtr t -> anyPtrToType t - -anyPtrToType :: C.AnyPtr -> Hs.Type -anyPtrToType t = case t of - C.Struct -> basics "AnyStruct" - C.List -> basics "AnyList" - C.Cap -> basics "Capability" - C.Ptr -> Hs.TApp (tStd_ "Maybe") [basics "AnyPointer"] - where - basics = tgName ["Basics"] - -compositeTypeToType thisMod (C.StructType name brand) = namedType thisMod name brand -interfaceTypeToType thisMod (C.InterfaceType name brand) = namedType thisMod name brand - -typeParamToType = Hs.TVar . Name.typeVarName . C.paramName - -namedType :: Word64 -> Name.CapnpQ -> C.ListBrand Name.CapnpQ -> Hs.Type -namedType thisMod name (C.ListBrand []) = tCapnp thisMod name -namedType thisMod name (C.ListBrand args) = - Hs.TApp - (tCapnp thisMod name) - [ typeToType thisMod (C.PtrType t) | t <- args ] - -fieldLocTypeToField = \case - C.DataField loc wt -> - let shift = C.dataOff loc - index = C.dataIdx loc - nbits = wordTypeBits wt - defaultValue = C.dataDef loc - in - Hs.EApp - (egName ["GH"] "dataField") - [ Hs.EInt $ fromIntegral shift - , Hs.EInt $ fromIntegral index - , Hs.EInt $ fromIntegral nbits - , Hs.EInt $ fromIntegral defaultValue - ] - C.PtrField idx _ -> - Hs.EApp (egName ["GH"] "ptrField") [Hs.EInt $ fromIntegral idx] - C.VoidField -> - egName ["GH"] "voidField" - C.HereField _ -> - egName ["GH"] "groupField" - - -class ToType a where - toType :: a -> Hs.Type - -instance ToType R.Repr where - toType (R.Ptr p) = rApp "Ptr" [toType p] - toType (R.Data d) = rApp "Data" [toType d] - -instance ToType a => ToType (Maybe a) where - toType Nothing = tStd_ "Nothing" - toType (Just a) = Hs.TApp (tStd_ "Just") [toType a] - -instance ToType R.PtrRepr where - toType R.Cap = tReprName "Cap" - toType (R.List r) = rApp "List" [toType r] - toType R.Struct = tReprName "Struct" - -instance ToType R.ListRepr where - toType (R.ListNormal nl) = rApp "ListNormal" [toType nl] - toType R.ListComposite = tReprName "ListComposite" - -instance ToType R.NormalListRepr where - toType (R.NormalListData r) = rApp "ListData" [toType r] - toType R.NormalListPtr = tReprName "ListPtr" - -instance ToType R.DataSz where - toType = tReprName . fromString . show - - -rApp :: Name.LocalQ -> [Hs.Type] -> Hs.Type -rApp n = Hs.TApp (tReprName n) - -tReprName :: Name.LocalQ -> Hs.Type -tReprName = tgName ["R"] - -declareUnknownVariant :: Name.LocalQ -> Hs.DataVariant -declareUnknownVariant name = Hs.DataVariant - { dvCtorName = Name.localToUnQ $ Name.mkSub name "unknown'" - , dvArgs = Hs.APos [tStd_ "Word16"] - } - - -defineParsedInstances :: Word64 -> Name.LocalQ -> [Name.UnQ] -> New.ParsedInstances -> [Hs.Decl] -defineParsedInstances thisMod typeName typeParams instanceInfo = - concatMap (\f -> f typeName typeParams instanceInfo) - [ defineParsed thisMod - , defineParse - , defineMarshal - ] - -defineParsed :: Word64 -> Name.LocalQ -> [Name.UnQ] -> New.ParsedInstances -> [Hs.Decl] -defineParsed thisMod typeName typeParams instanceInfo = - let tVars = map (Hs.TVar . Name.typeVarName) typeParams - typ = Hs.TApp (Hs.TLName typeName) tVars - parsedTy = case instanceInfo of - New.ParsedStruct{} -> typ - New.ParsedUnion{} -> Hs.TApp (tgName ["GH"] "Which") [typ] - in - Hs.DcData Hs.Data - { dataName = "C.Parsed" - , typeArgs = [parsedTy] - , derives = [ "Generics.Generic" ] - , dataNewtype = False - , dataInstance = True - , dataVariants = - case instanceInfo of - New.ParsedStruct { fields, hasUnion, dataCtorName } -> - [ Hs.DataVariant - { dvCtorName = Name.localToUnQ dataCtorName - , dvArgs = Hs.ARec $ - [ ( name - , Hs.TApp - (tgName ["RP"] "Parsed") - [fieldLocTypeToType thisMod typ] - ) - | (name, typ) <- fields - ] ++ - [ ( "union'" - , Hs.TApp (tgName ["C"] "Parsed") - [Hs.TApp (tgName ["GH"] "Which") [typ]] - ) - | hasUnion - ] - } - ] - New.ParsedUnion { variants } -> - [ Hs.DataVariant - { dvCtorName = Name.localToUnQ $ Name.mkSub typeName name - , dvArgs = case ftype of - C.VoidField -> Hs.APos [] - _ -> Hs.APos - [ Hs.TApp - (tgName ["RP"] "Parsed") - [fieldLocTypeToType thisMod ftype] - ] - } - | (name, ftype) <- variants - ] - ++ - [ declareUnknownVariant typeName ] - - } - : - [ Hs.DcDeriveInstance - [ Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["RP"] "Parsed") [v]] - | v <- tVars - ] - (Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["C"] "Parsed") [parsedTy]]) - | cls <- ["Show", "Eq"] - ] - -defineParse :: Name.LocalQ -> [Name.UnQ] -> New.ParsedInstances -> [Hs.Decl] -defineParse typeName typeParams New.ParsedStruct { fields, hasUnion, dataCtorName } = - let tVars = toTVars typeParams - typ = Hs.TApp (Hs.TLName typeName) tVars - in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "parse" - , params = [Hs.PVar "raw_"] - , value = Hs.EFApp (Hs.ELName dataCtorName) $ - [ Hs.EApp - (egName ["GH"] "parseField") - [Hs.ELabel field, euName "raw_"] - | field <- map fst fields - ] - ++ - if hasUnion then - [ Hs.EApp - (egName ["C"] "parse") - [Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"]] - ] - else - [] - } - ] - } - ] -defineParse typeName typeParams New.ParsedUnion{ variants } = - let tVars = toTVars typeParams - typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars] - in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "parse" - , params = [Hs.PVar "raw_"] - , value = Hs.EDo - [ Hs.DoBind "rawWhich_" $ Hs.EApp (egName ["GH"] "unionWhich") [euName "raw_"] - ] - (Hs.ECase (euName "rawWhich_") $ - [ let ctorName = Name.mkSub typeName variantName in - case fieldLocType of - C.VoidField -> - ( puName (rawCtorName ctorName) [Hs.PVar "_"] - , Hs.EApp (eStd_ "pure") [Hs.ELName ctorName] - ) - _ -> - ( puName (rawCtorName ctorName) [Hs.PVar "rawArg_"] - , Hs.EFApp - (Hs.ELName ctorName) - [Hs.EApp (egName ["C"] "parse") [euName "rawArg_"]] - ) - | (variantName, fieldLocType) <- variants - ] - ++ - [ let ctorName = unknownVariant typeName in - ( puName (rawCtorName ctorName) [Hs.PVar "tag_"] - , Hs.EApp - (eStd_ "pure") - [Hs.EApp (Hs.ELName ctorName) [euName "tag_"]] - ) - ] - ) - } - ] - } - ] - -defineInterfaceParse typeName typeParams = - let tVars = toTVars typeParams - typ = Hs.TApp (Hs.TLName typeName) tVars - in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["GH"] "Client") [typ]] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "parse" - , params = [] - , value = egName ["GH"] "parseCap" - } - , Hs.IdValue Hs.DfValue - { name = "encode" - , params = [] - , value = egName ["GH"] "encodeCap" - } - ] - } - ] - -defineMarshal :: Name.LocalQ -> [Name.UnQ] -> New.ParsedInstances -> [Hs.Decl] -defineMarshal typeName typeParams New.ParsedStruct { fields, hasUnion, dataCtorName } = - let tVars = toTVars typeParams - typ = Hs.TApp (Hs.TLName typeName) tVars - in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp - (tgName ["C"] "Marshal") - [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]] - , defs = - [ if null fields && not hasUnion then - -- We need to special case this, since otherwise GHC will complain about - -- the record wildcard pattern on a ctor with no arguments. - Hs.IdValue Hs.DfValue - { name = "marshalInto" - , params = [ Hs.PVar "_raw", Hs.PLCtor dataCtorName [] ] - , value = Hs.EApp (eStd_ "pure") [Hs.ETup []] - } - else - Hs.IdValue Hs.DfValue - { name = "marshalInto" - , params = - [ Hs.PVar "raw_", Hs.PLRecordWildCard dataCtorName] - , value = Hs.EDo - (map (Hs.DoE . uncurry emitMarshalField) fields) - (if hasUnion then - Hs.EApp (egName ["C"] "marshalInto") - [ Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"] - , euName "union'" - ] - else - Hs.EApp (eStd_ "pure") [Hs.ETup []] - ) - } - ] - } - ] -defineMarshal typeName typeParams New.ParsedUnion { variants } = - let tVars = toTVars typeParams - typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars] - in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp - (tgName ["C"] "Marshal") - [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]] - , defs = - [ Hs.IdValue Hs.DfValue - { name = "marshalInto" - , params = [ Hs.PVar "raw_", Hs.PVar "parsed_" ] - , value = Hs.ECase (Hs.EVar "parsed_") $ - [ ( Hs.PLCtor (Name.mkSub typeName name) $ - case fieldLocType of - C.VoidField -> [] - _ -> [Hs.PVar "arg_"] - , emitMarshalVariant name fieldLocType - ) - | (name, fieldLocType) <- variants - ] ++ - [ ( Hs.PLCtor (unknownVariant typeName) [Hs.PVar "tag_"] - , Hs.EApp - (egName ["GH"] "encodeField") - [ egName ["GH"] "unionField" - , Hs.EVar "tag_" - , unionStruct (euName "raw_") - ] - ) - ] - } - ] - } - ] - -defineInterfaceServer thisMod typeName typeParams methods supers = - let tVars = toTVars typeParams - typ = Hs.TApp (Hs.TLName typeName) tVars - clsName = Name.mkSub typeName "server_" - in - [ Hs.DcInstance - { ctx = paramsContext tVars - , typ = Hs.TApp (tgName ["GH"] "Export") [typ] - , defs = - [ Hs.IdType $ Hs.TypeAlias "Server" [typ] $ Hs.TApp (Hs.TLName clsName) tVars - , Hs.IdValue Hs.DfValue - { name = "methodHandlerTree" - , params = [Hs.PVar "_", Hs.PVar "s_"] - , value = - Hs.EApp (egName ["GH"] "MethodHandlerTree") - [ Hs.ETypeApp (egName ["C"] "typeId") [typ] - , Hs.EList - [ Hs.EApp - (egName ["GH"] "toUntypedMethodHandler") - [ Hs.EApp - (Hs.ETypeApp - (Hs.EVar (Name.renderUnQ (Name.valueName (Name.mkSub typeName methodName)))) - tVars - ) - [Hs.EVar "s_"] - ] - | New.MethodInfo{methodName} <- methods - ] - , Hs.EList - [ Hs.EApp (egName ["GH"] "methodHandlerTree") - [ Hs.ETypeApp - (egName ["GH"] "Proxy") - [typeToType thisMod $ C.PtrType $ C.PtrInterface super] - , Hs.EVar "s_" - ] - | super <- supers - ] - ] - } - ] - } - , Hs.DcClass - { ctx = - [ Hs.TApp (tgName ["GH"] "Server") - [ typeToType thisMod $ C.PtrType $ C.PtrInterface super - , Hs.TVar "s_" - ] - | super <- supers - ] - , name = clsName - , params = map (Name.UnQ . Name.typeVarName) typeParams ++ ["s_"] - , funDeps = [] - , decls = - Hs.CdMinimal - [ mkMethodName typeName methodName - | New.MethodInfo{methodName} <- methods - ] - : concatMap (defineIfaceClassMethod thisMod typeName) methods - } - ] -defineIfaceClassMethod thisMod typeName New.MethodInfo{methodName, paramType, resultType} = - let mkType t = typeToType thisMod (C.CompositeType t) - name = mkMethodName typeName methodName - in - [ Hs.CdValueDecl - name - (Hs.TFn - [ Hs.TVar "s_" - , Hs.TApp - (tgName ["GH"] "MethodHandler") - [ mkType paramType - , mkType resultType - ] - ] - ) - , Hs.CdValueDef Hs.DfValue - { name - , params = [Hs.PVar "_"] - , value = egName ["GH"] "methodUnimplemented" - } - ] - -mkMethodName typeName methodName = - Name.valueName (Name.mkSub typeName methodName) - -emitMarshalField :: Name.UnQ -> C.FieldLocType New.Brand Name.CapnpQ -> Hs.Exp -emitMarshalField name (C.HereField _) = - Hs.EDo - [ Hs.DoBind "group_" $ Hs.EApp - (egName ["GH"] "readField") - [Hs.ELabel name, Hs.EVar "raw_"] - ] - (Hs.EApp (egName ["C"] "marshalInto") [Hs.EVar "group_", euName name]) -emitMarshalField name _ = - Hs.EApp (egName ["GH"] "encodeField") - [ Hs.ELabel name - , euName name - , euName "raw_" - ] - -emitMarshalVariant :: Name.UnQ -> C.FieldLocType New.Brand Name.CapnpQ -> Hs.Exp -emitMarshalVariant name (C.HereField _) = Hs.EDo - [ Hs.DoBind "rawGroup_" $ - Hs.EApp (egName ["GH"] "initVariant") - [ Hs.ELabel name - , unionStruct (euName "raw_") - ] - ] - (Hs.EApp (egName ["C"] "marshalInto") [euName "rawGroup_", euName "arg_"]) -emitMarshalVariant name C.VoidField = - Hs.EApp (egName ["GH"] "encodeVariant") - [ Hs.ELabel name - , Hs.ETup [] - , unionStruct (euName "raw_") - ] -emitMarshalVariant name _ = - Hs.EApp (egName ["GH"] "encodeVariant") - [ Hs.ELabel name - , euName "arg_" - , unionStruct (euName "raw_") - ] - -unionStruct :: Hs.Exp -> Hs.Exp -unionStruct e = Hs.EApp (egName ["GH"] "unionStruct") [e] diff --git a/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs b/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs --- a/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs +++ b/cmd/capnpc-haskell/Trans/Stage1ToFlat.hs @@ -1,86 +1,87 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + -- Translate from the 'Stage1' IR to the 'Flat' IR. -- -- As the name of the latter suggests, this involves flattening the namepace. module Trans.Stage1ToFlat (cgrToCgr) where -import Data.Word - -import qualified Data.Map as M +import qualified Data.Map as M import qualified Data.Vector as V - +import Data.Word import qualified IR.Common as C -import qualified IR.Flat as Flat -import qualified IR.Name as Name +import qualified IR.Flat as Flat +import qualified IR.Name as Name import qualified IR.Stage1 as Stage1 type NodeMap = M.Map Word64 Flat.Node cgrToCgr :: Stage1.CodeGenReq -> Flat.CodeGenReq -cgrToCgr Stage1.CodeGenReq{allFiles, reqFiles=inFiles} = Flat.CodeGenReq - { reqFiles = outFiles - , allNodes +cgrToCgr Stage1.CodeGenReq {allFiles, reqFiles = inFiles} = + Flat.CodeGenReq + { reqFiles = outFiles, + allNodes } where outFiles = map (reqFileToFile fileMap) inFiles - fileMap = M.fromList + fileMap = + M.fromList [ (fileId, fileToNodes nodeMap file) - | file@Stage1.File{fileId} <- allFiles + | file@Stage1.File {fileId} <- allFiles ] allNodes = concatMap snd (M.toList fileMap) - nodeMap = M.fromList [(nodeId, node) | node@Flat.Node{nodeId} <- allNodes] + nodeMap = M.fromList [(nodeId, node) | node@Flat.Node {nodeId} <- allNodes] fileToNodes :: NodeMap -> Stage1.File -> [Flat.Node] -fileToNodes nodeMap Stage1.File{fileNodes, fileId} = - concatMap - (\(unQ, node) -> - nestedToNodes nodeMap fileId (Name.unQToLocal unQ) node [] - ) - fileNodes +fileToNodes nodeMap Stage1.File {fileNodes, fileId} = + concatMap + ( \(unQ, node) -> + nestedToNodes nodeMap fileId (Name.unQToLocal unQ) node [] + ) + fileNodes reqFileToFile :: M.Map Word64 [Flat.Node] -> Stage1.ReqFile -> Flat.File -reqFileToFile fileMap Stage1.ReqFile{fileName, file=Stage1.File{fileId}} = - Flat.File - { nodes = fileMap M.! fileId - , fileName - , fileId - } +reqFileToFile fileMap Stage1.ReqFile {fileName, file = Stage1.File {fileId}} = + Flat.File + { nodes = fileMap M.! fileId, + fileName, + fileId + } paramsToParams :: NodeMap -> Word64 -> [Name.UnQ] -> [C.TypeParamRef Flat.Node] paramsToParams nodeMap nodeId names = - [ C.TypeParamRef - { paramName = name - , paramIndex = i - , paramScope = nodeMap M.! nodeId - } - | (i, name) <- zip [0..] names - ] + [ C.TypeParamRef + { paramName = name, + paramIndex = i, + paramScope = nodeMap M.! nodeId + } + | (i, name) <- zip [0 ..] names + ] applyBrandNode :: C.MapBrand Flat.Node -> Flat.Node -> C.ListBrand Flat.Node -applyBrandNode m Flat.Node{typeParams} = applyBrandParams typeParams m +applyBrandNode m Flat.Node {typeParams} = applyBrandParams typeParams m applyBrandParams :: [C.TypeParamRef Flat.Node] -> C.MapBrand Flat.Node -> C.ListBrand Flat.Node applyBrandParams params m = C.ListBrand $ map (`applyBrandParam` m) params -applyBrandParam - :: C.TypeParamRef Flat.Node - -> C.MapBrand Flat.Node - -> C.PtrType (C.ListBrand Flat.Node) Flat.Node -applyBrandParam param@C.TypeParamRef{paramIndex, paramScope=Flat.Node{nodeId}} (C.MapBrand m) = - case M.lookup nodeId m of - Nothing -> C.PtrParam param - Just (C.Bind bindings) -> - let binding = bindings V.! paramIndex in - case binding of - C.Unbound -> C.PtrParam param - C.BoundType ty -> applyBrandPtrType ty +applyBrandParam :: + C.TypeParamRef Flat.Node -> + C.MapBrand Flat.Node -> + C.PtrType (C.ListBrand Flat.Node) Flat.Node +applyBrandParam param@C.TypeParamRef {paramIndex, paramScope = Flat.Node {nodeId}} (C.MapBrand m) = + case M.lookup nodeId m of + Nothing -> C.PtrParam param + Just (C.Bind bindings) -> + let binding = bindings V.! paramIndex + in case binding of + C.Unbound -> C.PtrParam param + C.BoundType ty -> applyBrandPtrType ty -type ApplyBrandFn f - = f (C.MapBrand Flat.Node) Flat.Node - -> f (C.ListBrand Flat.Node) Flat.Node +type ApplyBrandFn f = + f (C.MapBrand Flat.Node) Flat.Node -> + f (C.ListBrand Flat.Node) Flat.Node applyBrandCompositeType :: ApplyBrandFn C.CompositeType applyBrandCompositeType (C.StructType n b) = C.StructType n (applyBrandNode b n) @@ -90,206 +91,213 @@ applyBrandValue :: ApplyBrandFn C.Value applyBrandValue = \case - C.VoidValue -> C.VoidValue - C.WordValue v t -> C.WordValue v t - C.PtrValue t p -> C.PtrValue (applyBrandPtrType t) p + C.VoidValue -> C.VoidValue + C.WordValue v t -> C.WordValue v t + C.PtrValue t p -> C.PtrValue (applyBrandPtrType t) p applyBrandPtrType :: ApplyBrandFn C.PtrType applyBrandPtrType = \case - C.ListOf t -> C.ListOf $ applyBrandType t - C.PrimPtr p -> C.PrimPtr p - C.PtrInterface t -> C.PtrInterface (applyBrandInterfaceType t) - C.PtrComposite t -> C.PtrComposite (applyBrandCompositeType t) - C.PtrParam p -> C.PtrParam p + C.ListOf t -> C.ListOf $ applyBrandType t + C.PrimPtr p -> C.PrimPtr p + C.PtrInterface t -> C.PtrInterface (applyBrandInterfaceType t) + C.PtrComposite t -> C.PtrComposite (applyBrandCompositeType t) + C.PtrParam p -> C.PtrParam p applyBrandType :: ApplyBrandFn C.Type applyBrandType = \case - C.CompositeType t -> C.CompositeType $ applyBrandCompositeType t - C.VoidType -> C.VoidType - C.WordType t -> C.WordType t - C.PtrType t -> C.PtrType $ applyBrandPtrType t + C.CompositeType t -> C.CompositeType $ applyBrandCompositeType t + C.VoidType -> C.VoidType + C.WordType t -> C.WordType t + C.PtrType t -> C.PtrType $ applyBrandPtrType t applyBrandFieldLocType :: ApplyBrandFn C.FieldLocType applyBrandFieldLocType = \case - C.DataField l t -> C.DataField l t - C.PtrField i t -> C.PtrField i $ applyBrandPtrType t - C.HereField t -> C.HereField $ applyBrandCompositeType t - C.VoidField -> C.VoidField + C.DataField l t -> C.DataField l t + C.PtrField i t -> C.PtrField i $ applyBrandPtrType t + C.HereField t -> C.HereField $ applyBrandCompositeType t + C.VoidField -> C.VoidField -- | Generate @'Flat.Node'@s from a 'Stage1.Node' and its local name. nestedToNodes :: NodeMap -> Word64 -> Name.LocalQ -> Stage1.Node -> [C.TypeParamRef Flat.Node] -> [Flat.Node] nestedToNodes - nodeMap - thisMod - localName - Stage1.Node - { nodeCommon = Stage1.NodeCommon{nodeId, nodeNested, nodeParams} - , nodeUnion - } - typeParams - = + nodeMap + thisMod + localName + Stage1.Node + { nodeCommon = Stage1.NodeCommon {nodeId, nodeNested, nodeParams}, + nodeUnion + } + typeParams = mine ++ kids - where - myParams = typeParams ++ paramsToParams nodeMap nodeId (V.toList nodeParams) - kidsNS = Name.localQToNS localName - kids = concatMap - (\(unQ, node) -> - nestedToNodes nodeMap thisMod (Name.mkLocal kidsNS unQ) node myParams - ) - nodeNested - name = Name.CapnpQ - { local = localName - , fileId = thisMod - } - mine = case nodeUnion of + where + myParams = typeParams ++ paramsToParams nodeMap nodeId (V.toList nodeParams) + kidsNS = Name.localQToNS localName + kids = + concatMap + ( \(unQ, node) -> + nestedToNodes nodeMap thisMod (Name.mkLocal kidsNS unQ) node myParams + ) + nodeNested + name = + Name.CapnpQ + { local = localName, + fileId = thisMod + } + mine = case nodeUnion of Stage1.NodeEnum enumerants -> - [ Flat.Node - { name - , nodeId - , typeParams = myParams - , union_ = Flat.Enum enumerants - } - ] + [ Flat.Node + { name, + nodeId, + typeParams = myParams, + union_ = Flat.Enum enumerants + } + ] Stage1.NodeStruct struct -> - structToNodes nodeMap thisMod nodeId name kidsNS struct myParams + structToNodes nodeMap thisMod nodeId name kidsNS struct myParams Stage1.NodeInterface iface -> - interfaceToNodes nodeMap thisMod nodeId name kidsNS iface myParams + interfaceToNodes nodeMap thisMod nodeId name kidsNS iface myParams Stage1.NodeConstant value -> - [ Flat.Node - { name = Name.CapnpQ - { local = Name.unQToLocal $ Name.valueName localName - , fileId = thisMod - } - , nodeId - , union_ = Flat.Constant - { value = applyBrandValue $ C.bothMap - (\Stage1.Node{nodeCommon=Stage1.NodeCommon{nodeId}} -> nodeMap M.! nodeId) - value - } - , typeParams = myParams - } - ] + [ Flat.Node + { name = + Name.CapnpQ + { local = Name.unQToLocal $ Name.valueName localName, + fileId = thisMod + }, + nodeId, + union_ = + Flat.Constant + { value = + applyBrandValue $ + C.bothMap + (\Stage1.Node {nodeCommon = Stage1.NodeCommon {nodeId}} -> nodeMap M.! nodeId) + value + }, + typeParams = myParams + } + ] Stage1.NodeOther -> - [ Flat.Node - { name - , nodeId - , union_ = Flat.Other - , typeParams = myParams - } - ] + [ Flat.Node + { name, + nodeId, + union_ = Flat.Other, + typeParams = myParams + } + ] interfaceToNodes :: NodeMap -> Word64 -> Word64 -> Name.CapnpQ -> Name.NS -> Stage1.Interface -> [C.TypeParamRef Flat.Node] -> [Flat.Node] -interfaceToNodes nodeMap thisMod nodeId name kidsNS Stage1.Interface{ methods, supers } typeParams = - let translateSuper = - applyBrandInterfaceType - . C.bothMap (\Stage1.Node{nodeCommon=Stage1.NodeCommon{nodeId}} -> nodeMap M.! nodeId) - prType = applyBrandCompositeType . C.bothMap - (\Stage1.Node{nodeCommon=Stage1.NodeCommon{nodeId}} -> +interfaceToNodes nodeMap thisMod nodeId name kidsNS Stage1.Interface {methods, supers} typeParams = + let translateSuper = + applyBrandInterfaceType + . C.bothMap (\Stage1.Node {nodeCommon = Stage1.NodeCommon {nodeId}} -> nodeMap M.! nodeId) + prType = + applyBrandCompositeType + . C.bothMap + ( \Stage1.Node {nodeCommon = Stage1.NodeCommon {nodeId}} -> nodeMap M.! nodeId ) - in - Flat.Node - { name - , nodeId - , union_ = Flat.Interface - { methods = - [ Flat.Method - { name - , paramType = prType paramType - , resultType = prType resultType - } - | Stage1.Method { name, paramType, resultType } <- methods - ] - , supers = map translateSuper supers - } - , typeParams + in Flat.Node + { name, + nodeId, + union_ = + Flat.Interface + { methods = + [ Flat.Method + { name, + paramType = prType paramType, + resultType = prType resultType + } + | Stage1.Method {name, paramType, resultType} <- methods + ], + supers = map translateSuper supers + }, + typeParams } - : concatMap (\method -> methodToNodes nodeMap thisMod kidsNS method typeParams) methods + : concatMap (\method -> methodToNodes nodeMap thisMod kidsNS method typeParams) methods structToNodes :: NodeMap -> Word64 -> Word64 -> Name.CapnpQ -> Name.NS -> Stage1.Struct -> [C.TypeParamRef Flat.Node] -> [Flat.Node] structToNodes - nodeMap - thisMod - nodeId - name - kidsNS - Stage1.Struct - { fields - , isGroup - , dataWordCount - , pointerCount - , tagOffset + nodeMap + thisMod + nodeId + name + kidsNS + Stage1.Struct + { fields, + isGroup, + dataWordCount, + pointerCount, + tagOffset + } + typeParams = + let mkField fieldUnQ locType = + Flat.Field + { fieldName = Name.mkSub name fieldUnQ, + fieldLocType = + applyBrandFieldLocType $ + C.bothMap + (\Stage1.Node {nodeCommon = Stage1.NodeCommon {nodeId}} -> nodeMap M.! nodeId) + locType } - typeParams = - let - mkField fieldUnQ locType = - Flat.Field - { fieldName = Name.mkSub name fieldUnQ - , fieldLocType = applyBrandFieldLocType $ C.bothMap - (\Stage1.Node{nodeCommon=Stage1.NodeCommon{nodeId}} -> nodeMap M.! nodeId) - locType - } - variants = - [ Flat.Variant - { field = mkField fieldUnQ locType - , tagValue - } - | Stage1.Field{name=fieldUnQ, locType, tag=Just tagValue} <- fields - ] - commonFields = - [ mkField fieldUnQ locType - | Stage1.Field{name=fieldUnQ, locType, tag=Nothing} <- fields - ] - fieldNodes = - concatMap (fieldToNodes nodeMap thisMod kidsNS typeParams) fields + variants = + [ Flat.Variant + { field = mkField fieldUnQ locType, + tagValue + } + | Stage1.Field {name = fieldUnQ, locType, tag = Just tagValue} <- fields + ] + commonFields = + [ mkField fieldUnQ locType + | Stage1.Field {name = fieldUnQ, locType, tag = Nothing} <- fields + ] + fieldNodes = + concatMap (fieldToNodes nodeMap thisMod kidsNS typeParams) fields - commonNode = - Flat.Node - { name - , nodeId - , union_ = Flat.Struct - { fields = commonFields - , union = - if null variants then - Nothing - else - Just Flat.Union - { variants - , tagOffset - } - , isGroup - , dataWordCount - , pointerCount - } - , typeParams - } - in - commonNode : fieldNodes + commonNode = + Flat.Node + { name, + nodeId, + union_ = + Flat.Struct + { fields = commonFields, + union = + if null variants + then Nothing + else + Just + Flat.Union + { variants, + tagOffset + }, + isGroup, + dataWordCount, + pointerCount + }, + typeParams + } + in commonNode : fieldNodes fieldToNodes :: NodeMap -> Word64 -> Name.NS -> [C.TypeParamRef Flat.Node] -> Stage1.Field -> [Flat.Node] -fieldToNodes nodeMap thisMod ns typeParams Stage1.Field{name, locType} = case locType of - C.HereField - (C.StructType - struct@Stage1.Node - { nodeUnion = Stage1.NodeStruct Stage1.Struct{isGroup=True} - } - _ -- Type parameters will be the same as the enclosing scope. - ) -> nestedToNodes nodeMap thisMod (Name.mkLocal ns name) struct typeParams - _ -> - [] +fieldToNodes nodeMap thisMod ns typeParams Stage1.Field {name, locType} = case locType of + C.HereField + ( C.StructType + struct@Stage1.Node + { nodeUnion = Stage1.NodeStruct Stage1.Struct {isGroup = True} + } + _ -- Type parameters will be the same as the enclosing scope. + ) -> nestedToNodes nodeMap thisMod (Name.mkLocal ns name) struct typeParams + _ -> + [] methodToNodes :: NodeMap -> Word64 -> Name.NS -> Stage1.Method -> [C.TypeParamRef Flat.Node] -> [Flat.Node] -methodToNodes nodeMap thisMod ns Stage1.Method{ name, paramType, resultType } typeParams = - -- If the parameter and result types are anonymous, we need to generate - -- structs for them. - let maybeAnon ty suffix = - case ty of - C.StructType node@Stage1.Node{nodeCommon=Stage1.NodeCommon{nodeParent=Nothing}} _ -> - let localName = Name.mkLocal ns name - kidsNS = Name.localQToNS localName - in - nestedToNodes nodeMap thisMod (Name.mkLocal kidsNS suffix) node typeParams - _ -> - [] - in - maybeAnon paramType "params" ++ maybeAnon resultType "results" +methodToNodes nodeMap thisMod ns Stage1.Method {name, paramType, resultType} typeParams = + -- If the parameter and result types are anonymous, we need to generate + -- structs for them. + let maybeAnon ty suffix = + case ty of + C.StructType node@Stage1.Node {nodeCommon = Stage1.NodeCommon {nodeParent = Nothing}} _ -> + let localName = Name.mkLocal ns name + kidsNS = Name.localQToNS localName + in nestedToNodes nodeMap thisMod (Name.mkLocal kidsNS suffix) node typeParams + _ -> + [] + in maybeAnon paramType "params" ++ maybeAnon resultType "results" diff --git a/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs b/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs --- a/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs +++ b/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs @@ -1,32 +1,27 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + -- Things used by both RawToHaskell and PureToHaskell. module Trans.ToHaskellCommon where -import Data.Word - -import Data.Char (toUpper) -import Data.Maybe (fromJust) -import GHC.Exts (fromList) -import System.FilePath (splitDirectories) -import Text.Printf (printf) - - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Set as S -import qualified Data.Text as T - -import Capnp.New.Classes (encode) +import qualified Capnp as Capnp +import qualified Capnp.Basics as B +import Capnp.Classes (encode) import Capnp.Repr.Parsed (Parsed) - -import qualified Capnp.New as Capnp -import qualified Capnp.New.Basics as B -import qualified IR.Common as C -import qualified IR.Name as Name - +import qualified Data.ByteString.Lazy as LBS +import Data.Char (toUpper) +import Data.Maybe (fromJust) +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Word +import GHC.Exts (fromList) +import qualified IR.Common as C import IR.Haskell +import qualified IR.Name as Name +import System.FilePath (splitDirectories) +import Text.Printf (printf) -- Misc shortcuts for common constructs: @@ -43,9 +38,10 @@ tStd_ = TGName . std_ gName :: [T.Text] -> Name.LocalQ -> Name.GlobalQ -gName parts local = Name.GlobalQ - { globalNS = Name.NS parts - , local +gName parts local = + Name.GlobalQ + { globalNS = Name.NS parts, + local } egName :: [T.Text] -> Name.LocalQ -> Exp @@ -73,43 +69,47 @@ iType name params value = IdType $ TypeAlias name params value readCtx :: T.Text -> T.Text -> Type -readCtx m msg = TApp +readCtx m msg = + TApp (tgName ["Untyped"] "ReadCtx") - [ TVar m - , TVar msg + [ TVar m, + TVar msg ] rwCtx :: T.Text -> T.Text -> Type -rwCtx m s = TApp +rwCtx m s = + TApp (tgName ["Untyped"] "RWCtx") - [ TVar m - , TVar s + [ TVar m, + TVar s ] eGetWordField :: Exp -> C.DataLoc -> Exp -eGetWordField struct C.DataLoc{dataIdx, dataOff, dataDef} = - EApp - (egName ["GenHelpers"] "getWordField") - [ struct - , EInt $ fromIntegral dataIdx - , EInt $ fromIntegral dataOff - , EInt $ fromIntegral dataDef - ] +eGetWordField struct C.DataLoc {dataIdx, dataOff, dataDef} = + EApp + (egName ["GenHelpers"] "getWordField") + [ struct, + EInt $ fromIntegral dataIdx, + EInt $ fromIntegral dataOff, + EInt $ fromIntegral dataDef + ] idToModule :: Word64 -> [Name.UnQ] idToModule fileId = - ["Capnp", "Gen", "ById", Name.UnQ $ T.pack $ printf "X%x" fileId] + ["Capnp", "Gen", "ById", Name.UnQ $ T.pack $ printf "X%x" fileId] instance_ :: [Type] -> [T.Text] -> Name.LocalQ -> [Type] -> [InstanceDef] -> Decl -instance_ ctx [] className tys defs = DcInstance - { ctx - , typ = TApp (TLName className) tys - , defs +instance_ ctx [] className tys defs = + DcInstance + { ctx, + typ = TApp (TLName className) tys, + defs } -instance_ ctx classNS className tys defs = DcInstance - { ctx - , typ = TApp (tgName classNS className) tys - , defs +instance_ ctx classNS className tys defs = + DcInstance + { ctx, + typ = TApp (tgName classNS className) tys, + defs } -- | Transform the file path into a valid haskell module name. @@ -123,16 +123,16 @@ -- @myorg/example.capnp@ it generates @["Myorg", "Example"]@. makeModName :: FilePath -> [Name.UnQ] makeModName fileName = - [ Name.UnQ (T.pack (mangleSegment seg)) | seg <- splitDirectories fileName ] + [Name.UnQ (T.pack (mangleSegment seg)) | seg <- splitDirectories fileName] where mangleSegment "c++.capnp" = "Cxx" - mangleSegment "" = error "Unexpected empty file name" - mangleSegment (c:cs) = go (toUpper c : cs) where - go ('-':c:cs) = toUpper c : go cs - go ".capnp" = "" - go [] = "" - go (c:cs) = c : go cs - + mangleSegment "" = error "Unexpected empty file name" + mangleSegment (c : cs) = go (toUpper c : cs) + where + go ('-' : c : cs) = toUpper c : go cs + go ".capnp" = "" + go [] = "" + go (c : cs) = c : go cs -- | Fix the capnp imports of a module, so that they correspond to the -- imports actually used in the body of the module and/or export list. @@ -140,123 +140,128 @@ -- Note that this only looks at imports of the form Capnp.Gen....; other -- imports are not touched. fixImports :: Module -> Module -fixImports m@Module{modImports} = - let namespaces = S.toList $ S.fromList -- deduplicate +fixImports m@Module {modImports} = + let namespaces = + S.toList $ + S.fromList -- deduplicate [ nsParts - | Name.GlobalQ - { globalNS = Name.NS nsParts@(map T.unpack -> "Capnp":"Gen":_) - } - <- S.toList (findGNames m) - ] - neededImports = - [ ImportQual { parts = map Name.UnQ nsParts } - | nsParts <- namespaces + | Name.GlobalQ + { globalNS = Name.NS nsParts@(map T.unpack -> "Capnp" : "Gen" : _) + } <- + S.toList (findGNames m) ] - in - m { modImports = modImports ++ neededImports } + neededImports = + [ ImportQual {parts = map Name.UnQ nsParts} + | nsParts <- namespaces + ] + in m {modImports = modImports ++ neededImports} toTVars :: [Name.UnQ] -> [Type] toTVars = map (TVar . Name.typeVarName) makePtrBytes :: Maybe (Parsed B.AnyPointer) -> LBS.ByteString makePtrBytes ptr = - Capnp.msgToLBS $ fromJust $ Capnp.createPure Capnp.defaultLimit $ do - msg <- Capnp.newMessage Nothing - rootPtr <- encode msg $ B.Struct - (fromList []) - (fromList [ptr]) - Capnp.setRoot rootPtr - pure msg + Capnp.msgToLBS $ fromJust $ Capnp.createPure Capnp.defaultLimit $ do + msg <- Capnp.newMessage Nothing + rootPtr <- + encode msg $ + B.Struct + (fromList []) + (fromList [ptr]) + Capnp.setRoot rootPtr + pure msg class HasGNames a where - -- | Collect all of the 'Name.GlobalQ's used in the module. - -- - -- This seems like it would be the perfect use case for something - -- like syb or similar libraries, but I(zenhack) haven't taken the - -- time to fully wrap my head around how to use those yet, so we do - -- it the boilerplate-heavy way. - findGNames :: a -> S.Set Name.GlobalQ + -- | Collect all of the 'Name.GlobalQ's used in the module. + -- + -- This seems like it would be the perfect use case for something + -- like syb or similar libraries, but I(zenhack) haven't taken the + -- time to fully wrap my head around how to use those yet, so we do + -- it the boilerplate-heavy way. + findGNames :: a -> S.Set Name.GlobalQ instance HasGNames Module where - findGNames Module{modExports=Just exports, modDecls} = - S.unions $ map findGNames exports ++ map findGNames modDecls - findGNames Module{modExports=Nothing, modDecls} = - S.unions $ map findGNames modDecls + findGNames Module {modExports = Just exports, modDecls} = + S.unions $ map findGNames exports ++ map findGNames modDecls + findGNames Module {modExports = Nothing, modDecls} = + S.unions $ map findGNames modDecls instance HasGNames Export where - findGNames (ExportGCtors name) = S.singleton name - findGNames (ExportGName name) = S.singleton name - findGNames _ = S.empty + findGNames (ExportGCtors name) = S.singleton name + findGNames (ExportGName name) = S.singleton name + findGNames _ = S.empty instance HasGNames Decl where - findGNames (DcData d) = findGNames d - findGNames DcValue{typ, def} = findGNames typ `S.union` findGNames def - findGNames DcInstance{ctx, typ, defs} = S.unions - [ S.unions $ map findGNames ctx - , findGNames typ - , S.unions $ map findGNames defs - ] - findGNames (DcTypeInstance alias orig) = findGNames alias `S.union` findGNames orig - findGNames (DcDeriveInstance ctx typ) = findGNames (TCtx ctx typ) - findGNames DcClass{ctx, decls} = - S.unions $ map findGNames ctx ++ map findGNames decls + findGNames (DcData d) = findGNames d + findGNames DcValue {typ, def} = findGNames typ `S.union` findGNames def + findGNames DcInstance {ctx, typ, defs} = + S.unions + [ S.unions $ map findGNames ctx, + findGNames typ, + S.unions $ map findGNames defs + ] + findGNames (DcTypeInstance alias orig) = findGNames alias `S.union` findGNames orig + findGNames (DcDeriveInstance ctx typ) = findGNames (TCtx ctx typ) + findGNames DcClass {ctx, decls} = + S.unions $ map findGNames ctx ++ map findGNames decls instance HasGNames DataDecl where - findGNames Data{typeArgs, dataVariants} = - S.unions $ map findGNames typeArgs ++ map findGNames dataVariants + findGNames Data {typeArgs, dataVariants} = + S.unions $ map findGNames typeArgs ++ map findGNames dataVariants instance HasGNames ClassDecl where - findGNames (CdValueDecl _ ty) = findGNames ty - findGNames (CdValueDef d) = findGNames d - findGNames (CdMinimal _) = S.empty + findGNames (CdValueDecl _ ty) = findGNames ty + findGNames (CdValueDef d) = findGNames d + findGNames (CdMinimal _) = S.empty instance HasGNames InstanceDef where - findGNames (IdValue d) = findGNames d - findGNames (IdData d) = findGNames d - findGNames (IdType t) = findGNames t + findGNames (IdValue d) = findGNames d + findGNames (IdData d) = findGNames d + findGNames (IdType t) = findGNames t instance HasGNames TypeAlias where - findGNames (TypeAlias _ ts t) = S.unions $ map findGNames (t:ts) + findGNames (TypeAlias _ ts t) = S.unions $ map findGNames (t : ts) instance HasGNames ValueDef where - findGNames DfValue{value, params} = - S.unions $ findGNames value : map findGNames params + findGNames DfValue {value, params} = + S.unions $ findGNames value : map findGNames params instance HasGNames DataVariant where - findGNames DataVariant{dvArgs} = findGNames dvArgs + findGNames DataVariant {dvArgs} = findGNames dvArgs instance HasGNames DataArgs where - findGNames (APos tys) = S.unions $ map findGNames tys - findGNames (ARec fields) = S.unions $ map (findGNames . snd) fields + findGNames (APos tys) = S.unions $ map findGNames tys + findGNames (ARec fields) = S.unions $ map (findGNames . snd) fields instance HasGNames Type where - findGNames (TGName n) = S.singleton n - findGNames (TApp t ts) = S.unions $ map findGNames (t:ts) - findGNames (TFn ts) = S.unions $ map findGNames ts - findGNames (TCtx ts t) = S.unions $ map findGNames (t:ts) - findGNames _ = S.empty + findGNames (TGName n) = S.singleton n + findGNames (TApp t ts) = S.unions $ map findGNames (t : ts) + findGNames (TFn ts) = S.unions $ map findGNames ts + findGNames (TCtx ts t) = S.unions $ map findGNames (t : ts) + findGNames _ = S.empty instance HasGNames Exp where - findGNames (EApp e es) = S.unions $ map findGNames (e:es) - findGNames (EFApp e es) = S.unions $ map findGNames (e:es) - findGNames (EDo ds e) = S.unions $ findGNames e : map findGNames ds - findGNames (EBind x y) = findGNames x `S.union` findGNames y - findGNames (ETup es) = S.unions $ map findGNames es - findGNames (ECase e arms) = S.unions - [ findGNames e - , S.unions $ map (findGNames . fst) arms - , S.unions $ map (findGNames . snd) arms - ] - findGNames (ETypeAnno e t) = findGNames e `S.union` findGNames t - findGNames (ELambda ps e) = S.unions $ findGNames e : map findGNames ps - findGNames (ERecord e fields) = S.unions $ findGNames e : map (findGNames . snd) fields - findGNames _ = S.empty + findGNames (EApp e es) = S.unions $ map findGNames (e : es) + findGNames (EFApp e es) = S.unions $ map findGNames (e : es) + findGNames (EDo ds e) = S.unions $ findGNames e : map findGNames ds + findGNames (EBind x y) = findGNames x `S.union` findGNames y + findGNames (ETup es) = S.unions $ map findGNames es + findGNames (ECase e arms) = + S.unions + [ findGNames e, + S.unions $ map (findGNames . fst) arms, + S.unions $ map (findGNames . snd) arms + ] + findGNames (ETypeAnno e t) = findGNames e `S.union` findGNames t + findGNames (ELambda ps e) = S.unions $ findGNames e : map findGNames ps + findGNames (ERecord e fields) = S.unions $ findGNames e : map (findGNames . snd) fields + findGNames _ = S.empty instance HasGNames Do where - findGNames (DoBind _ e) = findGNames e - findGNames (DoE e) = findGNames e + findGNames (DoBind _ e) = findGNames e + findGNames (DoE e) = findGNames e instance HasGNames Pattern where - findGNames (PLCtor _ ps) = S.unions $ map findGNames ps - findGNames (PGCtor n ps) = S.unions $ S.singleton n : map findGNames ps - findGNames _ = S.empty + findGNames (PLCtor _ ps) = S.unions $ map findGNames ps + findGNames (PGCtor n ps) = S.unions $ S.singleton n : map findGNames ps + findGNames _ = S.empty diff --git a/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs b/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs new file mode 100644 --- /dev/null +++ b/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Capnp.Gen.ById.X85150b117366d14b (module Capnp.Gen.Calculator) where + +import Capnp.Gen.Calculator +import qualified Data.Int as Std_ +import qualified Data.Word as Std_ +import Prelude ((<$>), (<*>), (>>=)) +import qualified Prelude as Std_ diff --git a/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b/New.hs b/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b/New.hs deleted file mode 100644 --- a/examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.X85150b117366d14b.New(module Capnp.Gen.Calculator.New) where -import Capnp.Gen.Calculator.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs b/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs new file mode 100644 --- /dev/null +++ b/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Capnp.Gen.ById.Xd0a87f36fa0182f5 (module Capnp.Gen.Echo) where + +import Capnp.Gen.Echo +import qualified Data.Int as Std_ +import qualified Data.Word as Std_ +import Prelude ((<$>), (<*>), (>>=)) +import qualified Prelude as Std_ diff --git a/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5/New.hs b/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5/New.hs deleted file mode 100644 --- a/examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xd0a87f36fa0182f5.New(module Capnp.Gen.Echo.New) where -import Capnp.Gen.Echo.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/examples/gen/lib/Capnp/Gen/Calculator.hs b/examples/gen/lib/Capnp/Gen/Calculator.hs new file mode 100644 --- /dev/null +++ b/examples/gen/lib/Capnp/Gen/Calculator.hs @@ -0,0 +1,793 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Capnp.Gen.Calculator where + +import qualified Capnp.Basics as Basics +import qualified Capnp.Classes as C +import qualified Capnp.GenHelpers as GH +import qualified Capnp.GenHelpers.Rpc as GH +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Data.Int as Std_ +import qualified Data.Word as Std_ +import qualified GHC.Generics as Generics +import qualified GHC.OverloadedLabels as OL +import Prelude ((<$>), (<*>), (>>=)) +import qualified Prelude as Std_ + +data Calculator + +type instance R.ReprFor Calculator = (R.Ptr (Std_.Just R.Cap)) + +instance (C.HasTypeId Calculator) where + typeId = 10923537602090224694 + +instance (C.Parse Calculator (GH.Client Calculator)) where + parse = GH.parseCap + encode = GH.encodeCap + +instance (GH.Export Calculator) where + type Server Calculator = Calculator'server_ + methodHandlerTree _ s_ = + ( GH.MethodHandlerTree + (C.typeId @(Calculator)) + [ (GH.toUntypedMethodHandler ((calculator'evaluate) s_)), + (GH.toUntypedMethodHandler ((calculator'defFunction) s_)), + (GH.toUntypedMethodHandler ((calculator'getOperator) s_)) + ] + [] + ) + +class Calculator'server_ s_ where + {-# MINIMAL calculator'evaluate, calculator'defFunction, calculator'getOperator #-} + calculator'evaluate :: s_ -> (GH.MethodHandler Calculator'evaluate'params Calculator'evaluate'results) + calculator'evaluate _ = GH.methodUnimplemented + calculator'defFunction :: s_ -> (GH.MethodHandler Calculator'defFunction'params Calculator'defFunction'results) + calculator'defFunction _ = GH.methodUnimplemented + calculator'getOperator :: s_ -> (GH.MethodHandler Calculator'getOperator'params Calculator'getOperator'results) + calculator'getOperator _ = GH.methodUnimplemented + +instance (GH.HasMethod "evaluate" Calculator Calculator'evaluate'params Calculator'evaluate'results) where + methodByLabel = (GH.Method 10923537602090224694 0) + +instance (GH.HasMethod "defFunction" Calculator Calculator'defFunction'params Calculator'defFunction'results) where + methodByLabel = (GH.Method 10923537602090224694 1) + +instance (GH.HasMethod "getOperator" Calculator Calculator'getOperator'params Calculator'getOperator'results) where + methodByLabel = (GH.Method 10923537602090224694 2) + +data Calculator'evaluate'params + +type instance R.ReprFor Calculator'evaluate'params = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Calculator'evaluate'params) where + typeId = 13478898619544909524 + +instance (C.TypedStruct Calculator'evaluate'params) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Calculator'evaluate'params) where + type AllocHint Calculator'evaluate'params = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) + +instance (C.AllocateList Calculator'evaluate'params) where + type ListAllocHint Calculator'evaluate'params = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) + +data instance C.Parsed Calculator'evaluate'params = Calculator'evaluate'params + {expression :: (RP.Parsed Expression)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Calculator'evaluate'params)) + +deriving instance (Std_.Eq (C.Parsed Calculator'evaluate'params)) + +instance (C.Parse Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) where + parse raw_ = (Calculator'evaluate'params <$> (GH.parseField #expression raw_)) + +instance (C.Marshal Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) where + marshalInto raw_ Calculator'evaluate'params {..} = + ( do + (GH.encodeField #expression expression raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "expression" GH.Slot Calculator'evaluate'params Expression) where + fieldByLabel = (GH.ptrField 0) + +data Calculator'evaluate'results + +type instance R.ReprFor Calculator'evaluate'results = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Calculator'evaluate'results) where + typeId = 9345430975918089745 + +instance (C.TypedStruct Calculator'evaluate'results) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Calculator'evaluate'results) where + type AllocHint Calculator'evaluate'results = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) + +instance (C.AllocateList Calculator'evaluate'results) where + type ListAllocHint Calculator'evaluate'results = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) + +data instance C.Parsed Calculator'evaluate'results = Calculator'evaluate'results + {value :: (RP.Parsed Value)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Calculator'evaluate'results)) + +deriving instance (Std_.Eq (C.Parsed Calculator'evaluate'results)) + +instance (C.Parse Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) where + parse raw_ = (Calculator'evaluate'results <$> (GH.parseField #value raw_)) + +instance (C.Marshal Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) where + marshalInto raw_ Calculator'evaluate'results {..} = + ( do + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "value" GH.Slot Calculator'evaluate'results Value) where + fieldByLabel = (GH.ptrField 0) + +data Calculator'defFunction'params + +type instance R.ReprFor Calculator'defFunction'params = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Calculator'defFunction'params) where + typeId = 17476144387247758473 + +instance (C.TypedStruct Calculator'defFunction'params) where + numStructWords = 1 + numStructPtrs = 1 + +instance (C.Allocate Calculator'defFunction'params) where + type AllocHint Calculator'defFunction'params = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) + +instance (C.AllocateList Calculator'defFunction'params) where + type ListAllocHint Calculator'defFunction'params = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) + +data instance C.Parsed Calculator'defFunction'params = Calculator'defFunction'params + { paramCount :: (RP.Parsed Std_.Int32), + body :: (RP.Parsed Expression) + } + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Calculator'defFunction'params)) + +deriving instance (Std_.Eq (C.Parsed Calculator'defFunction'params)) + +instance (C.Parse Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) where + parse raw_ = + ( Calculator'defFunction'params + <$> (GH.parseField #paramCount raw_) + <*> (GH.parseField #body raw_) + ) + +instance (C.Marshal Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) where + marshalInto raw_ Calculator'defFunction'params {..} = + ( do + (GH.encodeField #paramCount paramCount raw_) + (GH.encodeField #body body raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "paramCount" GH.Slot Calculator'defFunction'params Std_.Int32) where + fieldByLabel = (GH.dataField 0 0 32 0) + +instance (GH.HasField "body" GH.Slot Calculator'defFunction'params Expression) where + fieldByLabel = (GH.ptrField 0) + +data Calculator'defFunction'results + +type instance R.ReprFor Calculator'defFunction'results = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Calculator'defFunction'results) where + typeId = 10170522573213587144 + +instance (C.TypedStruct Calculator'defFunction'results) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Calculator'defFunction'results) where + type AllocHint Calculator'defFunction'results = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) + +instance (C.AllocateList Calculator'defFunction'results) where + type ListAllocHint Calculator'defFunction'results = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) + +data instance C.Parsed Calculator'defFunction'results = Calculator'defFunction'results + {func :: (RP.Parsed Function)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Calculator'defFunction'results)) + +deriving instance (Std_.Eq (C.Parsed Calculator'defFunction'results)) + +instance (C.Parse Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) where + parse raw_ = (Calculator'defFunction'results <$> (GH.parseField #func raw_)) + +instance (C.Marshal Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) where + marshalInto raw_ Calculator'defFunction'results {..} = + ( do + (GH.encodeField #func func raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "func" GH.Slot Calculator'defFunction'results Function) where + fieldByLabel = (GH.ptrField 0) + +data Calculator'getOperator'params + +type instance R.ReprFor Calculator'getOperator'params = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Calculator'getOperator'params) where + typeId = 9983863225544066352 + +instance (C.TypedStruct Calculator'getOperator'params) where + numStructWords = 1 + numStructPtrs = 0 + +instance (C.Allocate Calculator'getOperator'params) where + type AllocHint Calculator'getOperator'params = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) + +instance (C.AllocateList Calculator'getOperator'params) where + type ListAllocHint Calculator'getOperator'params = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) + +data instance C.Parsed Calculator'getOperator'params = Calculator'getOperator'params + {op :: (RP.Parsed Operator)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Calculator'getOperator'params)) + +deriving instance (Std_.Eq (C.Parsed Calculator'getOperator'params)) + +instance (C.Parse Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) where + parse raw_ = (Calculator'getOperator'params <$> (GH.parseField #op raw_)) + +instance (C.Marshal Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) where + marshalInto raw_ Calculator'getOperator'params {..} = + ( do + (GH.encodeField #op op raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "op" GH.Slot Calculator'getOperator'params Operator) where + fieldByLabel = (GH.dataField 0 0 16 0) + +data Calculator'getOperator'results + +type instance R.ReprFor Calculator'getOperator'results = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Calculator'getOperator'results) where + typeId = 15100494197045627936 + +instance (C.TypedStruct Calculator'getOperator'results) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Calculator'getOperator'results) where + type AllocHint Calculator'getOperator'results = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) + +instance (C.AllocateList Calculator'getOperator'results) where + type ListAllocHint Calculator'getOperator'results = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) + +data instance C.Parsed Calculator'getOperator'results = Calculator'getOperator'results + {func :: (RP.Parsed Function)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Calculator'getOperator'results)) + +deriving instance (Std_.Eq (C.Parsed Calculator'getOperator'results)) + +instance (C.Parse Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) where + parse raw_ = (Calculator'getOperator'results <$> (GH.parseField #func raw_)) + +instance (C.Marshal Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) where + marshalInto raw_ Calculator'getOperator'results {..} = + ( do + (GH.encodeField #func func raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "func" GH.Slot Calculator'getOperator'results Function) where + fieldByLabel = (GH.ptrField 0) + +data Expression + +type instance R.ReprFor Expression = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Expression) where + typeId = 15292209801435843861 + +instance (C.TypedStruct Expression) where + numStructWords = 2 + numStructPtrs = 2 + +instance (C.Allocate Expression) where + type AllocHint Expression = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Expression (C.Parsed Expression)) + +instance (C.AllocateList Expression) where + type ListAllocHint Expression = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Expression (C.Parsed Expression)) + +data instance C.Parsed Expression = Expression + {union' :: (C.Parsed (GH.Which Expression))} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Expression)) + +deriving instance (Std_.Eq (C.Parsed Expression)) + +instance (C.Parse Expression (C.Parsed Expression)) where + parse raw_ = (Expression <$> (C.parse (GH.structUnion raw_))) + +instance (C.Marshal Expression (C.Parsed Expression)) where + marshalInto raw_ Expression {..} = + ( do + (C.marshalInto (GH.structUnion raw_) union') + ) + +instance (GH.HasUnion Expression) where + unionField = (GH.dataField 0 1 16 0) + data RawWhich Expression mut_ + = RW_Expression'literal (R.Raw Std_.Double mut_) + | RW_Expression'previousResult (R.Raw Value mut_) + | RW_Expression'parameter (R.Raw Std_.Word32 mut_) + | RW_Expression'call (R.Raw Expression'call mut_) + | RW_Expression'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Expression'literal <$> (GH.readVariant #literal struct_)) + 1 -> + (RW_Expression'previousResult <$> (GH.readVariant #previousResult struct_)) + 2 -> + (RW_Expression'parameter <$> (GH.readVariant #parameter struct_)) + 3 -> + (RW_Expression'call <$> (GH.readVariant #call struct_)) + _ -> + (Std_.pure (RW_Expression'unknown' tag_)) + data Which Expression + +instance (GH.HasVariant "literal" GH.Slot Expression Std_.Double) where + variantByLabel = (GH.Variant (GH.dataField 0 0 64 0) 0) + +instance (GH.HasVariant "previousResult" GH.Slot Expression Value) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) + +instance (GH.HasVariant "parameter" GH.Slot Expression Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 2) + +instance (GH.HasVariant "call" GH.Group Expression Expression'call) where + variantByLabel = (GH.Variant GH.groupField 3) + +data instance C.Parsed (GH.Which Expression) + = Expression'literal (RP.Parsed Std_.Double) + | Expression'previousResult (RP.Parsed Value) + | Expression'parameter (RP.Parsed Std_.Word32) + | Expression'call (RP.Parsed Expression'call) + | Expression'unknown' Std_.Word16 + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed (GH.Which Expression))) + +deriving instance (Std_.Eq (C.Parsed (GH.Which Expression))) + +instance (C.Parse (GH.Which Expression) (C.Parsed (GH.Which Expression))) where + parse raw_ = + ( do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Expression'literal rawArg_) -> + (Expression'literal <$> (C.parse rawArg_)) + (RW_Expression'previousResult rawArg_) -> + (Expression'previousResult <$> (C.parse rawArg_)) + (RW_Expression'parameter rawArg_) -> + (Expression'parameter <$> (C.parse rawArg_)) + (RW_Expression'call rawArg_) -> + (Expression'call <$> (C.parse rawArg_)) + (RW_Expression'unknown' tag_) -> + (Std_.pure (Expression'unknown' tag_)) + ) + +instance (C.Marshal (GH.Which Expression) (C.Parsed (GH.Which Expression))) where + marshalInto raw_ parsed_ = case parsed_ of + (Expression'literal arg_) -> + (GH.encodeVariant #literal arg_ (GH.unionStruct raw_)) + (Expression'previousResult arg_) -> + (GH.encodeVariant #previousResult arg_ (GH.unionStruct raw_)) + (Expression'parameter arg_) -> + (GH.encodeVariant #parameter arg_ (GH.unionStruct raw_)) + (Expression'call arg_) -> + ( do + rawGroup_ <- (GH.initVariant #call (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Expression'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) + +data Expression'call + +type instance R.ReprFor Expression'call = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Expression'call) where + typeId = 15678475764784139622 + +instance (C.TypedStruct Expression'call) where + numStructWords = 2 + numStructPtrs = 2 + +instance (C.Allocate Expression'call) where + type AllocHint Expression'call = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Expression'call (C.Parsed Expression'call)) + +instance (C.AllocateList Expression'call) where + type ListAllocHint Expression'call = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Expression'call (C.Parsed Expression'call)) + +data instance C.Parsed Expression'call = Expression'call' + { function :: (RP.Parsed Function), + params :: (RP.Parsed (R.List Expression)) + } + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Expression'call)) + +deriving instance (Std_.Eq (C.Parsed Expression'call)) + +instance (C.Parse Expression'call (C.Parsed Expression'call)) where + parse raw_ = + ( Expression'call' + <$> (GH.parseField #function raw_) + <*> (GH.parseField #params raw_) + ) + +instance (C.Marshal Expression'call (C.Parsed Expression'call)) where + marshalInto raw_ Expression'call' {..} = + ( do + (GH.encodeField #function function raw_) + (GH.encodeField #params params raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "function" GH.Slot Expression'call Function) where + fieldByLabel = (GH.ptrField 0) + +instance (GH.HasField "params" GH.Slot Expression'call (R.List Expression)) where + fieldByLabel = (GH.ptrField 1) + +data Value + +type instance R.ReprFor Value = (R.Ptr (Std_.Just R.Cap)) + +instance (C.HasTypeId Value) where + typeId = 14116142932258867410 + +instance (C.Parse Value (GH.Client Value)) where + parse = GH.parseCap + encode = GH.encodeCap + +instance (GH.Export Value) where + type Server Value = Value'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Value)) [(GH.toUntypedMethodHandler ((value'read) s_))] []) + +class Value'server_ s_ where + {-# MINIMAL value'read #-} + value'read :: s_ -> (GH.MethodHandler Value'read'params Value'read'results) + value'read _ = GH.methodUnimplemented + +instance (GH.HasMethod "read" Value Value'read'params Value'read'results) where + methodByLabel = (GH.Method 14116142932258867410 0) + +data Value'read'params + +type instance R.ReprFor Value'read'params = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Value'read'params) where + typeId = 15227555948799047000 + +instance (C.TypedStruct Value'read'params) where + numStructWords = 0 + numStructPtrs = 0 + +instance (C.Allocate Value'read'params) where + type AllocHint Value'read'params = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Value'read'params (C.Parsed Value'read'params)) + +instance (C.AllocateList Value'read'params) where + type ListAllocHint Value'read'params = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Value'read'params (C.Parsed Value'read'params)) + +data instance C.Parsed Value'read'params = Value'read'params + {} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Value'read'params)) + +deriving instance (Std_.Eq (C.Parsed Value'read'params)) + +instance (C.Parse Value'read'params (C.Parsed Value'read'params)) where + parse raw_ = (Std_.pure Value'read'params) + +instance (C.Marshal Value'read'params (C.Parsed Value'read'params)) where + marshalInto _raw (Value'read'params) = (Std_.pure ()) + +data Value'read'results + +type instance R.ReprFor Value'read'results = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Value'read'results) where + typeId = 16626840274624768034 + +instance (C.TypedStruct Value'read'results) where + numStructWords = 1 + numStructPtrs = 0 + +instance (C.Allocate Value'read'results) where + type AllocHint Value'read'results = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Value'read'results (C.Parsed Value'read'results)) + +instance (C.AllocateList Value'read'results) where + type ListAllocHint Value'read'results = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Value'read'results (C.Parsed Value'read'results)) + +data instance C.Parsed Value'read'results = Value'read'results + {value :: (RP.Parsed Std_.Double)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Value'read'results)) + +deriving instance (Std_.Eq (C.Parsed Value'read'results)) + +instance (C.Parse Value'read'results (C.Parsed Value'read'results)) where + parse raw_ = (Value'read'results <$> (GH.parseField #value raw_)) + +instance (C.Marshal Value'read'results (C.Parsed Value'read'results)) where + marshalInto raw_ Value'read'results {..} = + ( do + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "value" GH.Slot Value'read'results Std_.Double) where + fieldByLabel = (GH.dataField 0 0 64 0) + +data Function + +type instance R.ReprFor Function = (R.Ptr (Std_.Just R.Cap)) + +instance (C.HasTypeId Function) where + typeId = 17143016017778443156 + +instance (C.Parse Function (GH.Client Function)) where + parse = GH.parseCap + encode = GH.encodeCap + +instance (GH.Export Function) where + type Server Function = Function'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Function)) [(GH.toUntypedMethodHandler ((function'call) s_))] []) + +class Function'server_ s_ where + {-# MINIMAL function'call #-} + function'call :: s_ -> (GH.MethodHandler Function'call'params Function'call'results) + function'call _ = GH.methodUnimplemented + +instance (GH.HasMethod "call" Function Function'call'params Function'call'results) where + methodByLabel = (GH.Method 17143016017778443156 0) + +data Function'call'params + +type instance R.ReprFor Function'call'params = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Function'call'params) where + typeId = 12795114529121400599 + +instance (C.TypedStruct Function'call'params) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Function'call'params) where + type AllocHint Function'call'params = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Function'call'params (C.Parsed Function'call'params)) + +instance (C.AllocateList Function'call'params) where + type ListAllocHint Function'call'params = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Function'call'params (C.Parsed Function'call'params)) + +data instance C.Parsed Function'call'params = Function'call'params + {params :: (RP.Parsed (R.List Std_.Double))} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Function'call'params)) + +deriving instance (Std_.Eq (C.Parsed Function'call'params)) + +instance (C.Parse Function'call'params (C.Parsed Function'call'params)) where + parse raw_ = (Function'call'params <$> (GH.parseField #params raw_)) + +instance (C.Marshal Function'call'params (C.Parsed Function'call'params)) where + marshalInto raw_ Function'call'params {..} = + ( do + (GH.encodeField #params params raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "params" GH.Slot Function'call'params (R.List Std_.Double)) where + fieldByLabel = (GH.ptrField 0) + +data Function'call'results + +type instance R.ReprFor Function'call'results = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Function'call'results) where + typeId = 13898297529173597869 + +instance (C.TypedStruct Function'call'results) where + numStructWords = 1 + numStructPtrs = 0 + +instance (C.Allocate Function'call'results) where + type AllocHint Function'call'results = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Function'call'results (C.Parsed Function'call'results)) + +instance (C.AllocateList Function'call'results) where + type ListAllocHint Function'call'results = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Function'call'results (C.Parsed Function'call'results)) + +data instance C.Parsed Function'call'results = Function'call'results + {value :: (RP.Parsed Std_.Double)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Function'call'results)) + +deriving instance (Std_.Eq (C.Parsed Function'call'results)) + +instance (C.Parse Function'call'results (C.Parsed Function'call'results)) where + parse raw_ = (Function'call'results <$> (GH.parseField #value raw_)) + +instance (C.Marshal Function'call'results (C.Parsed Function'call'results)) where + marshalInto raw_ Function'call'results {..} = + ( do + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "value" GH.Slot Function'call'results Std_.Double) where + fieldByLabel = (GH.dataField 0 0 64 0) + +data Operator + = Operator'add + | Operator'subtract + | Operator'multiply + | Operator'divide + | Operator'unknown' Std_.Word16 + deriving + ( Std_.Eq, + Std_.Show, + Generics.Generic + ) + +type instance R.ReprFor Operator = (R.Data R.Sz16) + +instance (C.HasTypeId Operator) where + typeId = 9769222902479511526 + +instance (Std_.Enum Operator) where + toEnum n_ = case n_ of + 0 -> + Operator'add + 1 -> + Operator'subtract + 2 -> + Operator'multiply + 3 -> + Operator'divide + tag_ -> + (Operator'unknown' (Std_.fromIntegral tag_)) + fromEnum value_ = case value_ of + (Operator'add) -> + 0 + (Operator'subtract) -> + 1 + (Operator'multiply) -> + 2 + (Operator'divide) -> + 3 + (Operator'unknown' tag_) -> + (Std_.fromIntegral tag_) + +instance (C.IsWord Operator) where + fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) + toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) + +instance (C.Parse Operator Operator) where + parse = GH.parseEnum + encode = GH.encodeEnum + +instance (C.AllocateList Operator) where + type ListAllocHint Operator = Std_.Int + +instance (C.EstimateListAlloc Operator Operator) diff --git a/examples/gen/lib/Capnp/Gen/Calculator/New.hs b/examples/gen/lib/Capnp/Gen/Calculator/New.hs deleted file mode 100644 --- a/examples/gen/lib/Capnp/Gen/Calculator/New.hs +++ /dev/null @@ -1,566 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Calculator.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Capnp.GenHelpers.New.Rpc as GH -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Calculator -type instance (R.ReprFor Calculator) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Calculator) where - typeId = 10923537602090224694 -instance (C.Parse Calculator (GH.Client Calculator)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Calculator) where - type Server Calculator = Calculator'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Calculator)) [(GH.toUntypedMethodHandler ((calculator'evaluate) s_)) - ,(GH.toUntypedMethodHandler ((calculator'defFunction) s_)) - ,(GH.toUntypedMethodHandler ((calculator'getOperator) s_))] []) -class (Calculator'server_ s_) where - {-# MINIMAL calculator'evaluate,calculator'defFunction,calculator'getOperator #-} - calculator'evaluate :: s_ -> (GH.MethodHandler Calculator'evaluate'params Calculator'evaluate'results) - calculator'evaluate _ = GH.methodUnimplemented - calculator'defFunction :: s_ -> (GH.MethodHandler Calculator'defFunction'params Calculator'defFunction'results) - calculator'defFunction _ = GH.methodUnimplemented - calculator'getOperator :: s_ -> (GH.MethodHandler Calculator'getOperator'params Calculator'getOperator'results) - calculator'getOperator _ = GH.methodUnimplemented -instance (GH.HasMethod "evaluate" Calculator Calculator'evaluate'params Calculator'evaluate'results) where - methodByLabel = (GH.Method 10923537602090224694 0) -instance (GH.HasMethod "defFunction" Calculator Calculator'defFunction'params Calculator'defFunction'results) where - methodByLabel = (GH.Method 10923537602090224694 1) -instance (GH.HasMethod "getOperator" Calculator Calculator'getOperator'params Calculator'getOperator'results) where - methodByLabel = (GH.Method 10923537602090224694 2) -data Calculator'evaluate'params -type instance (R.ReprFor Calculator'evaluate'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Calculator'evaluate'params) where - typeId = 13478898619544909524 -instance (C.TypedStruct Calculator'evaluate'params) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Calculator'evaluate'params) where - type AllocHint Calculator'evaluate'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) -instance (C.AllocateList Calculator'evaluate'params) where - type ListAllocHint Calculator'evaluate'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) -data instance C.Parsed Calculator'evaluate'params - = Calculator'evaluate'params - {expression :: (RP.Parsed Expression)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Calculator'evaluate'params)) -deriving instance (Std_.Eq (C.Parsed Calculator'evaluate'params)) -instance (C.Parse Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) where - parse raw_ = (Calculator'evaluate'params <$> (GH.parseField #expression raw_)) -instance (C.Marshal Calculator'evaluate'params (C.Parsed Calculator'evaluate'params)) where - marshalInto raw_ Calculator'evaluate'params{..} = (do - (GH.encodeField #expression expression raw_) - (Std_.pure ()) - ) -instance (GH.HasField "expression" GH.Slot Calculator'evaluate'params Expression) where - fieldByLabel = (GH.ptrField 0) -data Calculator'evaluate'results -type instance (R.ReprFor Calculator'evaluate'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Calculator'evaluate'results) where - typeId = 9345430975918089745 -instance (C.TypedStruct Calculator'evaluate'results) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Calculator'evaluate'results) where - type AllocHint Calculator'evaluate'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) -instance (C.AllocateList Calculator'evaluate'results) where - type ListAllocHint Calculator'evaluate'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) -data instance C.Parsed Calculator'evaluate'results - = Calculator'evaluate'results - {value :: (RP.Parsed Value)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Calculator'evaluate'results)) -deriving instance (Std_.Eq (C.Parsed Calculator'evaluate'results)) -instance (C.Parse Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) where - parse raw_ = (Calculator'evaluate'results <$> (GH.parseField #value raw_)) -instance (C.Marshal Calculator'evaluate'results (C.Parsed Calculator'evaluate'results)) where - marshalInto raw_ Calculator'evaluate'results{..} = (do - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance (GH.HasField "value" GH.Slot Calculator'evaluate'results Value) where - fieldByLabel = (GH.ptrField 0) -data Calculator'defFunction'params -type instance (R.ReprFor Calculator'defFunction'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Calculator'defFunction'params) where - typeId = 17476144387247758473 -instance (C.TypedStruct Calculator'defFunction'params) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Calculator'defFunction'params) where - type AllocHint Calculator'defFunction'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) -instance (C.AllocateList Calculator'defFunction'params) where - type ListAllocHint Calculator'defFunction'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) -data instance C.Parsed Calculator'defFunction'params - = Calculator'defFunction'params - {paramCount :: (RP.Parsed Std_.Int32) - ,body :: (RP.Parsed Expression)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Calculator'defFunction'params)) -deriving instance (Std_.Eq (C.Parsed Calculator'defFunction'params)) -instance (C.Parse Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) where - parse raw_ = (Calculator'defFunction'params <$> (GH.parseField #paramCount raw_) - <*> (GH.parseField #body raw_)) -instance (C.Marshal Calculator'defFunction'params (C.Parsed Calculator'defFunction'params)) where - marshalInto raw_ Calculator'defFunction'params{..} = (do - (GH.encodeField #paramCount paramCount raw_) - (GH.encodeField #body body raw_) - (Std_.pure ()) - ) -instance (GH.HasField "paramCount" GH.Slot Calculator'defFunction'params Std_.Int32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "body" GH.Slot Calculator'defFunction'params Expression) where - fieldByLabel = (GH.ptrField 0) -data Calculator'defFunction'results -type instance (R.ReprFor Calculator'defFunction'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Calculator'defFunction'results) where - typeId = 10170522573213587144 -instance (C.TypedStruct Calculator'defFunction'results) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Calculator'defFunction'results) where - type AllocHint Calculator'defFunction'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) -instance (C.AllocateList Calculator'defFunction'results) where - type ListAllocHint Calculator'defFunction'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) -data instance C.Parsed Calculator'defFunction'results - = Calculator'defFunction'results - {func :: (RP.Parsed Function)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Calculator'defFunction'results)) -deriving instance (Std_.Eq (C.Parsed Calculator'defFunction'results)) -instance (C.Parse Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) where - parse raw_ = (Calculator'defFunction'results <$> (GH.parseField #func raw_)) -instance (C.Marshal Calculator'defFunction'results (C.Parsed Calculator'defFunction'results)) where - marshalInto raw_ Calculator'defFunction'results{..} = (do - (GH.encodeField #func func raw_) - (Std_.pure ()) - ) -instance (GH.HasField "func" GH.Slot Calculator'defFunction'results Function) where - fieldByLabel = (GH.ptrField 0) -data Calculator'getOperator'params -type instance (R.ReprFor Calculator'getOperator'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Calculator'getOperator'params) where - typeId = 9983863225544066352 -instance (C.TypedStruct Calculator'getOperator'params) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate Calculator'getOperator'params) where - type AllocHint Calculator'getOperator'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) -instance (C.AllocateList Calculator'getOperator'params) where - type ListAllocHint Calculator'getOperator'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) -data instance C.Parsed Calculator'getOperator'params - = Calculator'getOperator'params - {op :: (RP.Parsed Operator)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Calculator'getOperator'params)) -deriving instance (Std_.Eq (C.Parsed Calculator'getOperator'params)) -instance (C.Parse Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) where - parse raw_ = (Calculator'getOperator'params <$> (GH.parseField #op raw_)) -instance (C.Marshal Calculator'getOperator'params (C.Parsed Calculator'getOperator'params)) where - marshalInto raw_ Calculator'getOperator'params{..} = (do - (GH.encodeField #op op raw_) - (Std_.pure ()) - ) -instance (GH.HasField "op" GH.Slot Calculator'getOperator'params Operator) where - fieldByLabel = (GH.dataField 0 0 16 0) -data Calculator'getOperator'results -type instance (R.ReprFor Calculator'getOperator'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Calculator'getOperator'results) where - typeId = 15100494197045627936 -instance (C.TypedStruct Calculator'getOperator'results) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Calculator'getOperator'results) where - type AllocHint Calculator'getOperator'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) -instance (C.AllocateList Calculator'getOperator'results) where - type ListAllocHint Calculator'getOperator'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) -data instance C.Parsed Calculator'getOperator'results - = Calculator'getOperator'results - {func :: (RP.Parsed Function)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Calculator'getOperator'results)) -deriving instance (Std_.Eq (C.Parsed Calculator'getOperator'results)) -instance (C.Parse Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) where - parse raw_ = (Calculator'getOperator'results <$> (GH.parseField #func raw_)) -instance (C.Marshal Calculator'getOperator'results (C.Parsed Calculator'getOperator'results)) where - marshalInto raw_ Calculator'getOperator'results{..} = (do - (GH.encodeField #func func raw_) - (Std_.pure ()) - ) -instance (GH.HasField "func" GH.Slot Calculator'getOperator'results Function) where - fieldByLabel = (GH.ptrField 0) -data Expression -type instance (R.ReprFor Expression) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Expression) where - typeId = 15292209801435843861 -instance (C.TypedStruct Expression) where - numStructWords = 2 - numStructPtrs = 2 -instance (C.Allocate Expression) where - type AllocHint Expression = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Expression (C.Parsed Expression)) -instance (C.AllocateList Expression) where - type ListAllocHint Expression = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Expression (C.Parsed Expression)) -data instance C.Parsed Expression - = Expression - {union' :: (C.Parsed (GH.Which Expression))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Expression)) -deriving instance (Std_.Eq (C.Parsed Expression)) -instance (C.Parse Expression (C.Parsed Expression)) where - parse raw_ = (Expression <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Expression (C.Parsed Expression)) where - marshalInto raw_ Expression{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Expression) where - unionField = (GH.dataField 0 1 16 0) - data RawWhich Expression mut_ - = RW_Expression'literal (R.Raw Std_.Double mut_) - | RW_Expression'previousResult (R.Raw Value mut_) - | RW_Expression'parameter (R.Raw Std_.Word32 mut_) - | RW_Expression'call (R.Raw Expression'call mut_) - | RW_Expression'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Expression'literal <$> (GH.readVariant #literal struct_)) - 1 -> - (RW_Expression'previousResult <$> (GH.readVariant #previousResult struct_)) - 2 -> - (RW_Expression'parameter <$> (GH.readVariant #parameter struct_)) - 3 -> - (RW_Expression'call <$> (GH.readVariant #call struct_)) - _ -> - (Std_.pure (RW_Expression'unknown' tag_)) - data Which Expression -instance (GH.HasVariant "literal" GH.Slot Expression Std_.Double) where - variantByLabel = (GH.Variant (GH.dataField 0 0 64 0) 0) -instance (GH.HasVariant "previousResult" GH.Slot Expression Value) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -instance (GH.HasVariant "parameter" GH.Slot Expression Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 2) -instance (GH.HasVariant "call" GH.Group Expression Expression'call) where - variantByLabel = (GH.Variant GH.groupField 3) -data instance C.Parsed (GH.Which Expression) - = Expression'literal (RP.Parsed Std_.Double) - | Expression'previousResult (RP.Parsed Value) - | Expression'parameter (RP.Parsed Std_.Word32) - | Expression'call (RP.Parsed Expression'call) - | Expression'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Expression))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Expression))) -instance (C.Parse (GH.Which Expression) (C.Parsed (GH.Which Expression))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Expression'literal rawArg_) -> - (Expression'literal <$> (C.parse rawArg_)) - (RW_Expression'previousResult rawArg_) -> - (Expression'previousResult <$> (C.parse rawArg_)) - (RW_Expression'parameter rawArg_) -> - (Expression'parameter <$> (C.parse rawArg_)) - (RW_Expression'call rawArg_) -> - (Expression'call <$> (C.parse rawArg_)) - (RW_Expression'unknown' tag_) -> - (Std_.pure (Expression'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Expression) (C.Parsed (GH.Which Expression))) where - marshalInto raw_ parsed_ = case parsed_ of - (Expression'literal arg_) -> - (GH.encodeVariant #literal arg_ (GH.unionStruct raw_)) - (Expression'previousResult arg_) -> - (GH.encodeVariant #previousResult arg_ (GH.unionStruct raw_)) - (Expression'parameter arg_) -> - (GH.encodeVariant #parameter arg_ (GH.unionStruct raw_)) - (Expression'call arg_) -> - (do - rawGroup_ <- (GH.initVariant #call (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Expression'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Expression'call -type instance (R.ReprFor Expression'call) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Expression'call) where - typeId = 15678475764784139622 -instance (C.TypedStruct Expression'call) where - numStructWords = 2 - numStructPtrs = 2 -instance (C.Allocate Expression'call) where - type AllocHint Expression'call = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Expression'call (C.Parsed Expression'call)) -instance (C.AllocateList Expression'call) where - type ListAllocHint Expression'call = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Expression'call (C.Parsed Expression'call)) -data instance C.Parsed Expression'call - = Expression'call' - {function :: (RP.Parsed Function) - ,params :: (RP.Parsed (R.List Expression))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Expression'call)) -deriving instance (Std_.Eq (C.Parsed Expression'call)) -instance (C.Parse Expression'call (C.Parsed Expression'call)) where - parse raw_ = (Expression'call' <$> (GH.parseField #function raw_) - <*> (GH.parseField #params raw_)) -instance (C.Marshal Expression'call (C.Parsed Expression'call)) where - marshalInto raw_ Expression'call'{..} = (do - (GH.encodeField #function function raw_) - (GH.encodeField #params params raw_) - (Std_.pure ()) - ) -instance (GH.HasField "function" GH.Slot Expression'call Function) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "params" GH.Slot Expression'call (R.List Expression)) where - fieldByLabel = (GH.ptrField 1) -data Value -type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Value) where - typeId = 14116142932258867410 -instance (C.Parse Value (GH.Client Value)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Value) where - type Server Value = Value'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Value)) [(GH.toUntypedMethodHandler ((value'read) s_))] []) -class (Value'server_ s_) where - {-# MINIMAL value'read #-} - value'read :: s_ -> (GH.MethodHandler Value'read'params Value'read'results) - value'read _ = GH.methodUnimplemented -instance (GH.HasMethod "read" Value Value'read'params Value'read'results) where - methodByLabel = (GH.Method 14116142932258867410 0) -data Value'read'params -type instance (R.ReprFor Value'read'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Value'read'params) where - typeId = 15227555948799047000 -instance (C.TypedStruct Value'read'params) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Value'read'params) where - type AllocHint Value'read'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Value'read'params (C.Parsed Value'read'params)) -instance (C.AllocateList Value'read'params) where - type ListAllocHint Value'read'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Value'read'params (C.Parsed Value'read'params)) -data instance C.Parsed Value'read'params - = Value'read'params - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Value'read'params)) -deriving instance (Std_.Eq (C.Parsed Value'read'params)) -instance (C.Parse Value'read'params (C.Parsed Value'read'params)) where - parse raw_ = (Std_.pure Value'read'params) -instance (C.Marshal Value'read'params (C.Parsed Value'read'params)) where - marshalInto _raw (Value'read'params) = (Std_.pure ()) -data Value'read'results -type instance (R.ReprFor Value'read'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Value'read'results) where - typeId = 16626840274624768034 -instance (C.TypedStruct Value'read'results) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate Value'read'results) where - type AllocHint Value'read'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Value'read'results (C.Parsed Value'read'results)) -instance (C.AllocateList Value'read'results) where - type ListAllocHint Value'read'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Value'read'results (C.Parsed Value'read'results)) -data instance C.Parsed Value'read'results - = Value'read'results - {value :: (RP.Parsed Std_.Double)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Value'read'results)) -deriving instance (Std_.Eq (C.Parsed Value'read'results)) -instance (C.Parse Value'read'results (C.Parsed Value'read'results)) where - parse raw_ = (Value'read'results <$> (GH.parseField #value raw_)) -instance (C.Marshal Value'read'results (C.Parsed Value'read'results)) where - marshalInto raw_ Value'read'results{..} = (do - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance (GH.HasField "value" GH.Slot Value'read'results Std_.Double) where - fieldByLabel = (GH.dataField 0 0 64 0) -data Function -type instance (R.ReprFor Function) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Function) where - typeId = 17143016017778443156 -instance (C.Parse Function (GH.Client Function)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Function) where - type Server Function = Function'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Function)) [(GH.toUntypedMethodHandler ((function'call) s_))] []) -class (Function'server_ s_) where - {-# MINIMAL function'call #-} - function'call :: s_ -> (GH.MethodHandler Function'call'params Function'call'results) - function'call _ = GH.methodUnimplemented -instance (GH.HasMethod "call" Function Function'call'params Function'call'results) where - methodByLabel = (GH.Method 17143016017778443156 0) -data Function'call'params -type instance (R.ReprFor Function'call'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Function'call'params) where - typeId = 12795114529121400599 -instance (C.TypedStruct Function'call'params) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Function'call'params) where - type AllocHint Function'call'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Function'call'params (C.Parsed Function'call'params)) -instance (C.AllocateList Function'call'params) where - type ListAllocHint Function'call'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Function'call'params (C.Parsed Function'call'params)) -data instance C.Parsed Function'call'params - = Function'call'params - {params :: (RP.Parsed (R.List Std_.Double))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Function'call'params)) -deriving instance (Std_.Eq (C.Parsed Function'call'params)) -instance (C.Parse Function'call'params (C.Parsed Function'call'params)) where - parse raw_ = (Function'call'params <$> (GH.parseField #params raw_)) -instance (C.Marshal Function'call'params (C.Parsed Function'call'params)) where - marshalInto raw_ Function'call'params{..} = (do - (GH.encodeField #params params raw_) - (Std_.pure ()) - ) -instance (GH.HasField "params" GH.Slot Function'call'params (R.List Std_.Double)) where - fieldByLabel = (GH.ptrField 0) -data Function'call'results -type instance (R.ReprFor Function'call'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Function'call'results) where - typeId = 13898297529173597869 -instance (C.TypedStruct Function'call'results) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate Function'call'results) where - type AllocHint Function'call'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Function'call'results (C.Parsed Function'call'results)) -instance (C.AllocateList Function'call'results) where - type ListAllocHint Function'call'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Function'call'results (C.Parsed Function'call'results)) -data instance C.Parsed Function'call'results - = Function'call'results - {value :: (RP.Parsed Std_.Double)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Function'call'results)) -deriving instance (Std_.Eq (C.Parsed Function'call'results)) -instance (C.Parse Function'call'results (C.Parsed Function'call'results)) where - parse raw_ = (Function'call'results <$> (GH.parseField #value raw_)) -instance (C.Marshal Function'call'results (C.Parsed Function'call'results)) where - marshalInto raw_ Function'call'results{..} = (do - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance (GH.HasField "value" GH.Slot Function'call'results Std_.Double) where - fieldByLabel = (GH.dataField 0 0 64 0) -data Operator - = Operator'add - | Operator'subtract - | Operator'multiply - | Operator'divide - | Operator'unknown' Std_.Word16 - deriving(Std_.Eq - ,Std_.Show - ,Generics.Generic) -type instance (R.ReprFor Operator) = (R.Data R.Sz16) -instance (C.HasTypeId Operator) where - typeId = 9769222902479511526 -instance (Std_.Enum Operator) where - toEnum n_ = case n_ of - 0 -> - Operator'add - 1 -> - Operator'subtract - 2 -> - Operator'multiply - 3 -> - Operator'divide - tag_ -> - (Operator'unknown' (Std_.fromIntegral tag_)) - fromEnum value_ = case value_ of - (Operator'add) -> - 0 - (Operator'subtract) -> - 1 - (Operator'multiply) -> - 2 - (Operator'divide) -> - 3 - (Operator'unknown' tag_) -> - (Std_.fromIntegral tag_) -instance (C.IsWord Operator) where - fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) - toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) -instance (C.Parse Operator Operator) where - parse = GH.parseEnum - encode = GH.encodeEnum -instance (C.AllocateList Operator) where - type ListAllocHint Operator = Std_.Int -instance (C.EstimateListAlloc Operator Operator) diff --git a/examples/gen/lib/Capnp/Gen/Echo.hs b/examples/gen/lib/Capnp/Gen/Echo.hs new file mode 100644 --- /dev/null +++ b/examples/gen/lib/Capnp/Gen/Echo.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} + +module Capnp.Gen.Echo where + +import qualified Capnp.Basics as Basics +import qualified Capnp.Classes as C +import qualified Capnp.GenHelpers as GH +import qualified Capnp.GenHelpers.Rpc as GH +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Data.Int as Std_ +import qualified Data.Word as Std_ +import qualified GHC.Generics as Generics +import qualified GHC.OverloadedLabels as OL +import Prelude ((<$>), (<*>), (>>=)) +import qualified Prelude as Std_ + +data Echo + +type instance R.ReprFor Echo = (R.Ptr (Std_.Just R.Cap)) + +instance (C.HasTypeId Echo) where + typeId = 16940812395455687611 + +instance (C.Parse Echo (GH.Client Echo)) where + parse = GH.parseCap + encode = GH.encodeCap + +instance (GH.Export Echo) where + type Server Echo = Echo'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) + +class Echo'server_ s_ where + {-# MINIMAL echo'echo #-} + echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) + echo'echo _ = GH.methodUnimplemented + +instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where + methodByLabel = (GH.Method 16940812395455687611 0) + +data Echo'echo'params + +type instance R.ReprFor Echo'echo'params = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Echo'echo'params) where + typeId = 11805419372138457970 + +instance (C.TypedStruct Echo'echo'params) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Echo'echo'params) where + type AllocHint Echo'echo'params = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Echo'echo'params (C.Parsed Echo'echo'params)) + +instance (C.AllocateList Echo'echo'params) where + type ListAllocHint Echo'echo'params = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Echo'echo'params (C.Parsed Echo'echo'params)) + +data instance C.Parsed Echo'echo'params = Echo'echo'params + {query :: (RP.Parsed Basics.Text)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Echo'echo'params)) + +deriving instance (Std_.Eq (C.Parsed Echo'echo'params)) + +instance (C.Parse Echo'echo'params (C.Parsed Echo'echo'params)) where + parse raw_ = (Echo'echo'params <$> (GH.parseField #query raw_)) + +instance (C.Marshal Echo'echo'params (C.Parsed Echo'echo'params)) where + marshalInto raw_ Echo'echo'params {..} = + ( do + (GH.encodeField #query query raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "query" GH.Slot Echo'echo'params Basics.Text) where + fieldByLabel = (GH.ptrField 0) + +data Echo'echo'results + +type instance R.ReprFor Echo'echo'results = (R.Ptr (Std_.Just R.Struct)) + +instance (C.HasTypeId Echo'echo'results) where + typeId = 9634882973594762090 + +instance (C.TypedStruct Echo'echo'results) where + numStructWords = 0 + numStructPtrs = 1 + +instance (C.Allocate Echo'echo'results) where + type AllocHint Echo'echo'results = () + new _ = C.newTypedStruct + +instance (C.EstimateAlloc Echo'echo'results (C.Parsed Echo'echo'results)) + +instance (C.AllocateList Echo'echo'results) where + type ListAllocHint Echo'echo'results = Std_.Int + newList = C.newTypedStructList + +instance (C.EstimateListAlloc Echo'echo'results (C.Parsed Echo'echo'results)) + +data instance C.Parsed Echo'echo'results = Echo'echo'results + {reply :: (RP.Parsed Basics.Text)} + deriving (Generics.Generic) + +deriving instance (Std_.Show (C.Parsed Echo'echo'results)) + +deriving instance (Std_.Eq (C.Parsed Echo'echo'results)) + +instance (C.Parse Echo'echo'results (C.Parsed Echo'echo'results)) where + parse raw_ = (Echo'echo'results <$> (GH.parseField #reply raw_)) + +instance (C.Marshal Echo'echo'results (C.Parsed Echo'echo'results)) where + marshalInto raw_ Echo'echo'results {..} = + ( do + (GH.encodeField #reply reply raw_) + (Std_.pure ()) + ) + +instance (GH.HasField "reply" GH.Slot Echo'echo'results Basics.Text) where + fieldByLabel = (GH.ptrField 0) diff --git a/examples/gen/lib/Capnp/Gen/Echo/New.hs b/examples/gen/lib/Capnp/Gen/Echo/New.hs deleted file mode 100644 --- a/examples/gen/lib/Capnp/Gen/Echo/New.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Echo.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Capnp.GenHelpers.New.Rpc as GH -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Echo -type instance (R.ReprFor Echo) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Echo) where - typeId = 16940812395455687611 -instance (C.Parse Echo (GH.Client Echo)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Echo) where - type Server Echo = Echo'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) -class (Echo'server_ s_) where - {-# MINIMAL echo'echo #-} - echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) - echo'echo _ = GH.methodUnimplemented -instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where - methodByLabel = (GH.Method 16940812395455687611 0) -data Echo'echo'params -type instance (R.ReprFor Echo'echo'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Echo'echo'params) where - typeId = 11805419372138457970 -instance (C.TypedStruct Echo'echo'params) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Echo'echo'params) where - type AllocHint Echo'echo'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Echo'echo'params (C.Parsed Echo'echo'params)) -instance (C.AllocateList Echo'echo'params) where - type ListAllocHint Echo'echo'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Echo'echo'params (C.Parsed Echo'echo'params)) -data instance C.Parsed Echo'echo'params - = Echo'echo'params - {query :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Echo'echo'params)) -deriving instance (Std_.Eq (C.Parsed Echo'echo'params)) -instance (C.Parse Echo'echo'params (C.Parsed Echo'echo'params)) where - parse raw_ = (Echo'echo'params <$> (GH.parseField #query raw_)) -instance (C.Marshal Echo'echo'params (C.Parsed Echo'echo'params)) where - marshalInto raw_ Echo'echo'params{..} = (do - (GH.encodeField #query query raw_) - (Std_.pure ()) - ) -instance (GH.HasField "query" GH.Slot Echo'echo'params Basics.Text) where - fieldByLabel = (GH.ptrField 0) -data Echo'echo'results -type instance (R.ReprFor Echo'echo'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Echo'echo'results) where - typeId = 9634882973594762090 -instance (C.TypedStruct Echo'echo'results) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Echo'echo'results) where - type AllocHint Echo'echo'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Echo'echo'results (C.Parsed Echo'echo'results)) -instance (C.AllocateList Echo'echo'results) where - type ListAllocHint Echo'echo'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Echo'echo'results (C.Parsed Echo'echo'results)) -data instance C.Parsed Echo'echo'results - = Echo'echo'results - {reply :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Echo'echo'results)) -deriving instance (Std_.Eq (C.Parsed Echo'echo'results)) -instance (C.Parse Echo'echo'results (C.Parsed Echo'echo'results)) where - parse raw_ = (Echo'echo'results <$> (GH.parseField #reply raw_)) -instance (C.Marshal Echo'echo'results (C.Parsed Echo'echo'results)) where - marshalInto raw_ Echo'echo'results{..} = (do - (GH.encodeField #reply reply raw_) - (Std_.pure ()) - ) -instance (GH.HasField "reply" GH.Slot Echo'echo'results Basics.Text) where - fieldByLabel = (GH.ptrField 0) diff --git a/examples/lib/Examples/Rpc/CalculatorClient.hs b/examples/lib/Examples/Rpc/CalculatorClient.hs --- a/examples/lib/Examples/Rpc/CalculatorClient.hs +++ b/examples/lib/Examples/Rpc/CalculatorClient.hs @@ -1,70 +1,88 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -module Examples.Rpc.CalculatorClient (main) where +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} -import qualified Capnp.New as C -import Capnp.Rpc - (ConnConfig(..), fromClient, handleConn, socketTransport) -import Control.Monad (when) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import qualified Data.Vector as V -import Network.Simple.TCP (connect) +module Examples.Rpc.CalculatorClient (main) where -import Capnp.Gen.Calculator.New +import Capnp.Gen.Calculator +import qualified Capnp as C +import Capnp.Rpc + ( ConnConfig (..), + fromClient, + handleConn, + socketTransport, + ) +import Control.Monad (when) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import qualified Data.Vector as V +import Network.Simple.TCP (connect) main :: IO () main = connect "localhost" "4000" $ \(sock, _addr) -> - handleConn (socketTransport sock C.defaultLimit) C.def - { debugMode = True - , withBootstrap = Just $ \_sup client -> do - let calc :: C.Client Calculator - calc = fromClient client + handleConn + (socketTransport sock C.defaultLimit) + C.def + { debugMode = True, + withBootstrap = Just $ \_sup client -> do + let calc :: C.Client Calculator + calc = fromClient client - value <- calc - & C.callP #evaluate C.def { expression = Expression $ Expression'literal 123 } - <&> C.pipe #value - >>= C.callR #read C.def - >>= C.waitPipeline - >>= C.evalLimitT C.defaultLimit . C.parseField #value - assertEq value 123 + value <- + calc + & C.callP #evaluate C.def {expression = Expression $ Expression'literal 123} + <&> C.pipe #value + >>= C.callR #read C.def + >>= C.waitPipeline + >>= C.evalLimitT C.defaultLimit . C.parseField #value + assertEq value 123 - let getOp op = calc - & C.callP #getOperator C.def { op } - <&> C.pipe #func - >>= C.asClient + let getOp op = + calc + & C.callP #getOperator C.def {op} + <&> C.pipe #func + >>= C.asClient - add <- getOp Operator'add - subtract <- getOp Operator'subtract + add <- getOp Operator'add + subtract <- getOp Operator'subtract - value <- calc - & C.callP #evaluate C.def - { expression = - Expression $ Expression'call Expression'call' - { function = subtract - , params = V.fromList - [ Expression $ Expression'call Expression'call' - { function = add - , params = V.fromList - [ Expression $ Expression'literal 123 - , Expression $ Expression'literal 45 - ] - } - , Expression $ Expression'literal 67 - ] + value <- + calc + & C.callP + #evaluate + C.def + { expression = + Expression $ + Expression'call + Expression'call' + { function = subtract, + params = + V.fromList + [ Expression $ + Expression'call + Expression'call' + { function = add, + params = + V.fromList + [ Expression $ Expression'literal 123, + Expression $ Expression'literal 45 + ] + }, + Expression $ Expression'literal 67 + ] } - } - <&> C.pipe #value - >>= C.callR #read C.def - >>= C.waitPipeline - >>= C.evalLimitT C.defaultLimit . C.parseField #value - assertEq value 101 + } + <&> C.pipe #value + >>= C.callR #read C.def + >>= C.waitPipeline + >>= C.evalLimitT C.defaultLimit . C.parseField #value + assertEq value 101 - putStrLn "PASS" - } + putStrLn "PASS" + } assertEq :: (Show a, Eq a) => a -> a -> IO () assertEq got want = - when (got /= want) $ - error $ "Got " ++ show got ++ " but wanted " ++ show want + when (got /= want) $ + error $ + "Got " ++ show got ++ " but wanted " ++ show want diff --git a/examples/lib/Examples/Rpc/CalculatorServer.hs b/examples/lib/Examples/Rpc/CalculatorServer.hs --- a/examples/lib/Examples/Rpc/CalculatorServer.hs +++ b/examples/lib/Examples/Rpc/CalculatorServer.hs @@ -1,155 +1,159 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Examples.Rpc.CalculatorServer (main) where - -import Prelude hiding (subtract) +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -import Data.Int +module Examples.Rpc.CalculatorServer (main) where +import Capnp.Gen.Calculator +import Capnp + ( Client, + Pipeline, + SomeServer, + callP, + def, + defaultLimit, + export, + getField, + handleParsed, + waitPipeline, + ) +import Capnp.Rpc + ( ConnConfig (..), + handleConn, + socketTransport, + throwFailed, + toClient, + ) import Control.Concurrent.STM (STM, atomically) -import Control.Monad (when) -import Data.Function ((&)) -import Data.Functor ((<&>)) -import Network.Simple.TCP (serve) -import Supervisors (Supervisor) - +import Control.Monad (when) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import Data.Int import qualified Data.Vector as V - -import Capnp.New - ( Client - , Pipeline - , SomeServer - , callP - , def - , defaultLimit - , export - , getField - , handleParsed - , waitPipeline - ) -import Capnp.Rpc - (ConnConfig(..), handleConn, socketTransport, throwFailed, toClient) - -import Capnp.Gen.Calculator.New +import Network.Simple.TCP (serve) +import Supervisors (Supervisor) +import Prelude hiding (subtract) newtype LitValue = LitValue Double instance SomeServer LitValue instance Value'server_ LitValue where - value'read (LitValue val) = handleParsed $ \_ -> - pure Value'read'results { value = val } + value'read (LitValue val) = handleParsed $ \_ -> + pure Value'read'results {value = val} newtype OpFunc = OpFunc (Double -> Double -> Double) instance SomeServer OpFunc instance Function'server_ OpFunc where - function'call (OpFunc op) = handleParsed $ \Function'call'params{params} -> do - when (V.length params /= 2) $ - throwFailed "Wrong number of parameters." - pure Function'call'results - { value = (params V.! 0) `op` (params V.! 1) } + function'call (OpFunc op) = handleParsed $ \Function'call'params {params} -> do + when (V.length params /= 2) $ + throwFailed "Wrong number of parameters." + pure + Function'call'results + { value = (params V.! 0) `op` (params V.! 1) + } data ExprFunc = ExprFunc - { paramCount :: !Int32 - , body :: Parsed Expression - } + { paramCount :: !Int32, + body :: Parsed Expression + } instance SomeServer ExprFunc instance Function'server_ ExprFunc where - function'call ExprFunc{..} = - handleParsed $ \Function'call'params{params} -> do - when (fromIntegral (V.length params) /= paramCount) $ - throwFailed "Wrong number of parameters." - eval params body - >>= waitResult - <&> Function'call'results + function'call ExprFunc {..} = + handleParsed $ \Function'call'params {params} -> do + when (fromIntegral (V.length params) /= paramCount) $ + throwFailed "Wrong number of parameters." + eval params body + >>= waitResult + <&> Function'call'results data MyCalc = MyCalc - { add :: Client Function - , subtract :: Client Function - , multiply :: Client Function - , divide :: Client Function - , sup :: Supervisor - } + { add :: Client Function, + subtract :: Client Function, + multiply :: Client Function, + divide :: Client Function, + sup :: Supervisor + } instance SomeServer MyCalc instance Calculator'server_ MyCalc where - calculator'evaluate MyCalc{sup} = - handleParsed $ \Calculator'evaluate'params{expression} -> do - eval V.empty expression - >>= waitResult - >>= export @Value sup . LitValue - <&> Calculator'evaluate'results - - calculator'getOperator MyCalc{..} = - handleParsed $ \Calculator'getOperator'params{op} -> - Calculator'getOperator'results <$> case op of - Operator'add -> pure add - Operator'subtract -> pure subtract - Operator'multiply -> pure multiply - Operator'divide -> pure divide + calculator'evaluate MyCalc {sup} = + handleParsed $ \Calculator'evaluate'params {expression} -> do + eval V.empty expression + >>= waitResult + >>= export @Value sup . LitValue + <&> Calculator'evaluate'results - Operator'unknown' _ -> - throwFailed "Unknown operator" + calculator'getOperator MyCalc {..} = + handleParsed $ \Calculator'getOperator'params {op} -> + Calculator'getOperator'results <$> case op of + Operator'add -> pure add + Operator'subtract -> pure subtract + Operator'multiply -> pure multiply + Operator'divide -> pure divide + Operator'unknown' _ -> + throwFailed "Unknown operator" - calculator'defFunction MyCalc{sup} = - handleParsed $ \Calculator'defFunction'params{..} -> - Calculator'defFunction'results <$> - atomically (export @Function sup ExprFunc{..}) + calculator'defFunction MyCalc {sup} = + handleParsed $ \Calculator'defFunction'params {..} -> + Calculator'defFunction'results + <$> atomically (export @Function sup ExprFunc {..}) newCalculator :: Supervisor -> STM (Client Calculator) newCalculator sup = do - add <- export @Function sup $ OpFunc (+) - subtract <- export @Function sup $ OpFunc (-) - multiply <- export @Function sup $ OpFunc (*) - divide <- export @Function sup $ OpFunc (/) - export @Calculator sup MyCalc{..} - + add <- export @Function sup $ OpFunc (+) + subtract <- export @Function sup $ OpFunc (-) + multiply <- export @Function sup $ OpFunc (*) + divide <- export @Function sup $ OpFunc (/) + export @Calculator sup MyCalc {..} data EvalResult - = Immediate Double - | CallResult (Pipeline Function'call'results) - | ReadResult (Pipeline Value'read'results) + = Immediate Double + | CallResult (Pipeline Function'call'results) + | ReadResult (Pipeline Value'read'results) waitResult :: EvalResult -> IO Double -waitResult (Immediate v) = pure v +waitResult (Immediate v) = pure v waitResult (CallResult p) = getField #value <$> waitPipeline p waitResult (ReadResult p) = getField #value <$> waitPipeline p eval :: V.Vector Double -> Parsed Expression -> IO EvalResult -eval outerParams (Expression exp) = go outerParams exp where +eval outerParams (Expression exp) = go outerParams exp + where go _ (Expression'literal lit) = - pure $ Immediate lit + pure $ Immediate lit go _ (Expression'previousResult val) = do - val - & callP #read def - <&> ReadResult + val + & callP #read def + <&> ReadResult go args (Expression'parameter idx) - | fromIntegral idx >= V.length args = - throwFailed "Parameter index out of bounds" - | otherwise = - pure $ Immediate $ args V.! fromIntegral idx - go outerParams (Expression'call Expression'call'{function, params=innerParams}) = do - argPipelines <- traverse (eval outerParams) innerParams - argValues <- traverse waitResult argPipelines - function - & callP #call Function'call'params { params = argValues } - <&> CallResult + | fromIntegral idx >= V.length args = + throwFailed "Parameter index out of bounds" + | otherwise = + pure $ Immediate $ args V.! fromIntegral idx + go outerParams (Expression'call Expression'call' {function, params = innerParams}) = do + argPipelines <- traverse (eval outerParams) innerParams + argValues <- traverse waitResult argPipelines + function + & callP #call Function'call'params {params = argValues} + <&> CallResult go _ (Expression'unknown' _) = - throwFailed "Unknown expression type" + throwFailed "Unknown expression type" main :: IO () main = serve "localhost" "4000" $ \(sock, _addr) -> - handleConn (socketTransport sock defaultLimit) def - { getBootstrap = fmap (Just . toClient) . newCalculator - , debugMode = True - } + handleConn + (socketTransport sock defaultLimit) + def + { getBootstrap = fmap (Just . toClient) . newCalculator, + debugMode = True + } diff --git a/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8.hs b/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.X86c366a91393f3f8(module Capnp.Gen.Capnp.Stream) where +import Capnp.Gen.Capnp.Stream +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8/New.hs b/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/X86c366a91393f3f8/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.X86c366a91393f3f8.New(module Capnp.Gen.Capnp.Stream.New) where -import Capnp.Gen.Capnp.Stream.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34.hs b/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.X8ef99297a43a5e34(module Capnp.Gen.Capnp.Compat.Json) where +import Capnp.Gen.Capnp.Compat.Json +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34/New.hs b/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.X8ef99297a43a5e34.New(module Capnp.Gen.Capnp.Compat.Json.New) where -import Capnp.Gen.Capnp.Compat.Json.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1.hs b/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xa184c7885cdaf2a1(module Capnp.Gen.Capnp.RpcTwoparty) where +import Capnp.Gen.Capnp.RpcTwoparty +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1/New.hs b/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xa184c7885cdaf2a1.New(module Capnp.Gen.Capnp.RpcTwoparty.New) where -import Capnp.Gen.Capnp.RpcTwoparty.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9.hs b/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xa93fc509624c72d9(module Capnp.Gen.Capnp.Schema) where +import Capnp.Gen.Capnp.Schema +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9/New.hs b/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xa93fc509624c72d9.New(module Capnp.Gen.Capnp.Schema.New) where -import Capnp.Gen.Capnp.Schema.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xb312981b2552a250.hs b/gen/lib/Capnp/Gen/ById/Xb312981b2552a250.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/Xb312981b2552a250.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xb312981b2552a250(module Capnp.Gen.Capnp.Rpc) where +import Capnp.Gen.Capnp.Rpc +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xb312981b2552a250/New.hs b/gen/lib/Capnp/Gen/ById/Xb312981b2552a250/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/Xb312981b2552a250/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xb312981b2552a250.New(module Capnp.Gen.Capnp.Rpc.New) where -import Capnp.Gen.Capnp.Rpc.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xb8630836983feed7.hs b/gen/lib/Capnp/Gen/ById/Xb8630836983feed7.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/Xb8630836983feed7.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xb8630836983feed7(module Capnp.Gen.Capnp.Persistent) where +import Capnp.Gen.Capnp.Persistent +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xb8630836983feed7/New.hs b/gen/lib/Capnp/Gen/ById/Xb8630836983feed7/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/Xb8630836983feed7/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xb8630836983feed7.New(module Capnp.Gen.Capnp.Persistent.New) where -import Capnp.Gen.Capnp.Persistent.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81.hs b/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xbdf87d7bb8304e81(module Capnp.Gen.Capnp.Cxx) where +import Capnp.Gen.Capnp.Cxx +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81/New.hs b/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xbdf87d7bb8304e81.New(module Capnp.Gen.Capnp.Cxx.New) where -import Capnp.Gen.Capnp.Cxx.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/Capnp/Compat/Json.hs b/gen/lib/Capnp/Gen/Capnp/Compat/Json.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/Compat/Json.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.Compat.Json where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data Value +type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value) where + typeId = 11815888814287216003 +instance (C.TypedStruct Value) where + numStructWords = 2 + numStructPtrs = 1 +instance (C.Allocate Value) where + type AllocHint Value = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Value (C.Parsed Value)) +instance (C.AllocateList Value) where + type ListAllocHint Value = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Value (C.Parsed Value)) +data instance C.Parsed Value + = Value + {union' :: (C.Parsed (GH.Which Value))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Value)) +deriving instance (Std_.Eq (C.Parsed Value)) +instance (C.Parse Value (C.Parsed Value)) where + parse raw_ = (Value <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Value (C.Parsed Value)) where + marshalInto raw_ Value{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Value) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Value mut_ + = RW_Value'null (R.Raw () mut_) + | RW_Value'boolean (R.Raw Std_.Bool mut_) + | RW_Value'number (R.Raw Std_.Double mut_) + | RW_Value'string (R.Raw Basics.Text mut_) + | RW_Value'array (R.Raw (R.List Value) mut_) + | RW_Value'object (R.Raw (R.List Value'Field) mut_) + | RW_Value'call (R.Raw Value'Call mut_) + | RW_Value'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Value'null <$> (GH.readVariant #null struct_)) + 1 -> + (RW_Value'boolean <$> (GH.readVariant #boolean struct_)) + 2 -> + (RW_Value'number <$> (GH.readVariant #number struct_)) + 3 -> + (RW_Value'string <$> (GH.readVariant #string struct_)) + 4 -> + (RW_Value'array <$> (GH.readVariant #array struct_)) + 5 -> + (RW_Value'object <$> (GH.readVariant #object struct_)) + 6 -> + (RW_Value'call <$> (GH.readVariant #call struct_)) + _ -> + (Std_.pure (RW_Value'unknown' tag_)) + data Which Value +instance (GH.HasVariant "null" GH.Slot Value ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "boolean" GH.Slot Value Std_.Bool) where + variantByLabel = (GH.Variant (GH.dataField 16 0 1 0) 1) +instance (GH.HasVariant "number" GH.Slot Value Std_.Double) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 2) +instance (GH.HasVariant "string" GH.Slot Value Basics.Text) where + variantByLabel = (GH.Variant (GH.ptrField 0) 3) +instance (GH.HasVariant "array" GH.Slot Value (R.List Value)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 4) +instance (GH.HasVariant "object" GH.Slot Value (R.List Value'Field)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 5) +instance (GH.HasVariant "call" GH.Slot Value Value'Call) where + variantByLabel = (GH.Variant (GH.ptrField 0) 6) +data instance C.Parsed (GH.Which Value) + = Value'null + | Value'boolean (RP.Parsed Std_.Bool) + | Value'number (RP.Parsed Std_.Double) + | Value'string (RP.Parsed Basics.Text) + | Value'array (RP.Parsed (R.List Value)) + | Value'object (RP.Parsed (R.List Value'Field)) + | Value'call (RP.Parsed Value'Call) + | Value'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Value))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Value))) +instance (C.Parse (GH.Which Value) (C.Parsed (GH.Which Value))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Value'null _) -> + (Std_.pure Value'null) + (RW_Value'boolean rawArg_) -> + (Value'boolean <$> (C.parse rawArg_)) + (RW_Value'number rawArg_) -> + (Value'number <$> (C.parse rawArg_)) + (RW_Value'string rawArg_) -> + (Value'string <$> (C.parse rawArg_)) + (RW_Value'array rawArg_) -> + (Value'array <$> (C.parse rawArg_)) + (RW_Value'object rawArg_) -> + (Value'object <$> (C.parse rawArg_)) + (RW_Value'call rawArg_) -> + (Value'call <$> (C.parse rawArg_)) + (RW_Value'unknown' tag_) -> + (Std_.pure (Value'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Value) (C.Parsed (GH.Which Value))) where + marshalInto raw_ parsed_ = case parsed_ of + (Value'null) -> + (GH.encodeVariant #null () (GH.unionStruct raw_)) + (Value'boolean arg_) -> + (GH.encodeVariant #boolean arg_ (GH.unionStruct raw_)) + (Value'number arg_) -> + (GH.encodeVariant #number arg_ (GH.unionStruct raw_)) + (Value'string arg_) -> + (GH.encodeVariant #string arg_ (GH.unionStruct raw_)) + (Value'array arg_) -> + (GH.encodeVariant #array arg_ (GH.unionStruct raw_)) + (Value'object arg_) -> + (GH.encodeVariant #object arg_ (GH.unionStruct raw_)) + (Value'call arg_) -> + (GH.encodeVariant #call arg_ (GH.unionStruct raw_)) + (Value'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Value'Field +type instance (R.ReprFor Value'Field) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value'Field) where + typeId = 16361620220719570399 +instance (C.TypedStruct Value'Field) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate Value'Field) where + type AllocHint Value'Field = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Value'Field (C.Parsed Value'Field)) +instance (C.AllocateList Value'Field) where + type ListAllocHint Value'Field = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Value'Field (C.Parsed Value'Field)) +data instance C.Parsed Value'Field + = Value'Field + {name :: (RP.Parsed Basics.Text) + ,value :: (RP.Parsed Value)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Value'Field)) +deriving instance (Std_.Eq (C.Parsed Value'Field)) +instance (C.Parse Value'Field (C.Parsed Value'Field)) where + parse raw_ = (Value'Field <$> (GH.parseField #name raw_) + <*> (GH.parseField #value raw_)) +instance (C.Marshal Value'Field (C.Parsed Value'Field)) where + marshalInto raw_ Value'Field{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot Value'Field Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "value" GH.Slot Value'Field Value) where + fieldByLabel = (GH.ptrField 1) +data Value'Call +type instance (R.ReprFor Value'Call) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value'Call) where + typeId = 11590566612201717064 +instance (C.TypedStruct Value'Call) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate Value'Call) where + type AllocHint Value'Call = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Value'Call (C.Parsed Value'Call)) +instance (C.AllocateList Value'Call) where + type ListAllocHint Value'Call = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Value'Call (C.Parsed Value'Call)) +data instance C.Parsed Value'Call + = Value'Call + {function :: (RP.Parsed Basics.Text) + ,params :: (RP.Parsed (R.List Value))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Value'Call)) +deriving instance (Std_.Eq (C.Parsed Value'Call)) +instance (C.Parse Value'Call (C.Parsed Value'Call)) where + parse raw_ = (Value'Call <$> (GH.parseField #function raw_) + <*> (GH.parseField #params raw_)) +instance (C.Marshal Value'Call (C.Parsed Value'Call)) where + marshalInto raw_ Value'Call{..} = (do + (GH.encodeField #function function raw_) + (GH.encodeField #params params raw_) + (Std_.pure ()) + ) +instance (GH.HasField "function" GH.Slot Value'Call Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "params" GH.Slot Value'Call (R.List Value)) where + fieldByLabel = (GH.ptrField 1) +data FlattenOptions +type instance (R.ReprFor FlattenOptions) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId FlattenOptions) where + typeId = 14186078402951440993 +instance (C.TypedStruct FlattenOptions) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate FlattenOptions) where + type AllocHint FlattenOptions = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc FlattenOptions (C.Parsed FlattenOptions)) +instance (C.AllocateList FlattenOptions) where + type ListAllocHint FlattenOptions = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc FlattenOptions (C.Parsed FlattenOptions)) +data instance C.Parsed FlattenOptions + = FlattenOptions + {prefix :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed FlattenOptions)) +deriving instance (Std_.Eq (C.Parsed FlattenOptions)) +instance (C.Parse FlattenOptions (C.Parsed FlattenOptions)) where + parse raw_ = (FlattenOptions <$> (GH.parseField #prefix raw_)) +instance (C.Marshal FlattenOptions (C.Parsed FlattenOptions)) where + marshalInto raw_ FlattenOptions{..} = (do + (GH.encodeField #prefix prefix raw_) + (Std_.pure ()) + ) +instance (GH.HasField "prefix" GH.Slot FlattenOptions Basics.Text) where + fieldByLabel = (GH.ptrField 0) +data DiscriminatorOptions +type instance (R.ReprFor DiscriminatorOptions) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId DiscriminatorOptions) where + typeId = 14049192395069608729 +instance (C.TypedStruct DiscriminatorOptions) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate DiscriminatorOptions) where + type AllocHint DiscriminatorOptions = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc DiscriminatorOptions (C.Parsed DiscriminatorOptions)) +instance (C.AllocateList DiscriminatorOptions) where + type ListAllocHint DiscriminatorOptions = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc DiscriminatorOptions (C.Parsed DiscriminatorOptions)) +data instance C.Parsed DiscriminatorOptions + = DiscriminatorOptions + {name :: (RP.Parsed Basics.Text) + ,valueName :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed DiscriminatorOptions)) +deriving instance (Std_.Eq (C.Parsed DiscriminatorOptions)) +instance (C.Parse DiscriminatorOptions (C.Parsed DiscriminatorOptions)) where + parse raw_ = (DiscriminatorOptions <$> (GH.parseField #name raw_) + <*> (GH.parseField #valueName raw_)) +instance (C.Marshal DiscriminatorOptions (C.Parsed DiscriminatorOptions)) where + marshalInto raw_ DiscriminatorOptions{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #valueName valueName raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot DiscriminatorOptions Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "valueName" GH.Slot DiscriminatorOptions Basics.Text) where + fieldByLabel = (GH.ptrField 1) diff --git a/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs b/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs +++ /dev/null @@ -1,290 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.Compat.Json.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Value -type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Value) where - typeId = 11815888814287216003 -instance (C.TypedStruct Value) where - numStructWords = 2 - numStructPtrs = 1 -instance (C.Allocate Value) where - type AllocHint Value = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Value (C.Parsed Value)) -instance (C.AllocateList Value) where - type ListAllocHint Value = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Value (C.Parsed Value)) -data instance C.Parsed Value - = Value - {union' :: (C.Parsed (GH.Which Value))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Value)) -deriving instance (Std_.Eq (C.Parsed Value)) -instance (C.Parse Value (C.Parsed Value)) where - parse raw_ = (Value <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Value (C.Parsed Value)) where - marshalInto raw_ Value{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Value) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Value mut_ - = RW_Value'null (R.Raw () mut_) - | RW_Value'boolean (R.Raw Std_.Bool mut_) - | RW_Value'number (R.Raw Std_.Double mut_) - | RW_Value'string (R.Raw Basics.Text mut_) - | RW_Value'array (R.Raw (R.List Value) mut_) - | RW_Value'object (R.Raw (R.List Value'Field) mut_) - | RW_Value'call (R.Raw Value'Call mut_) - | RW_Value'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Value'null <$> (GH.readVariant #null struct_)) - 1 -> - (RW_Value'boolean <$> (GH.readVariant #boolean struct_)) - 2 -> - (RW_Value'number <$> (GH.readVariant #number struct_)) - 3 -> - (RW_Value'string <$> (GH.readVariant #string struct_)) - 4 -> - (RW_Value'array <$> (GH.readVariant #array struct_)) - 5 -> - (RW_Value'object <$> (GH.readVariant #object struct_)) - 6 -> - (RW_Value'call <$> (GH.readVariant #call struct_)) - _ -> - (Std_.pure (RW_Value'unknown' tag_)) - data Which Value -instance (GH.HasVariant "null" GH.Slot Value ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "boolean" GH.Slot Value Std_.Bool) where - variantByLabel = (GH.Variant (GH.dataField 16 0 1 0) 1) -instance (GH.HasVariant "number" GH.Slot Value Std_.Double) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 2) -instance (GH.HasVariant "string" GH.Slot Value Basics.Text) where - variantByLabel = (GH.Variant (GH.ptrField 0) 3) -instance (GH.HasVariant "array" GH.Slot Value (R.List Value)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 4) -instance (GH.HasVariant "object" GH.Slot Value (R.List Value'Field)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 5) -instance (GH.HasVariant "call" GH.Slot Value Value'Call) where - variantByLabel = (GH.Variant (GH.ptrField 0) 6) -data instance C.Parsed (GH.Which Value) - = Value'null - | Value'boolean (RP.Parsed Std_.Bool) - | Value'number (RP.Parsed Std_.Double) - | Value'string (RP.Parsed Basics.Text) - | Value'array (RP.Parsed (R.List Value)) - | Value'object (RP.Parsed (R.List Value'Field)) - | Value'call (RP.Parsed Value'Call) - | Value'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Value))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Value))) -instance (C.Parse (GH.Which Value) (C.Parsed (GH.Which Value))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Value'null _) -> - (Std_.pure Value'null) - (RW_Value'boolean rawArg_) -> - (Value'boolean <$> (C.parse rawArg_)) - (RW_Value'number rawArg_) -> - (Value'number <$> (C.parse rawArg_)) - (RW_Value'string rawArg_) -> - (Value'string <$> (C.parse rawArg_)) - (RW_Value'array rawArg_) -> - (Value'array <$> (C.parse rawArg_)) - (RW_Value'object rawArg_) -> - (Value'object <$> (C.parse rawArg_)) - (RW_Value'call rawArg_) -> - (Value'call <$> (C.parse rawArg_)) - (RW_Value'unknown' tag_) -> - (Std_.pure (Value'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Value) (C.Parsed (GH.Which Value))) where - marshalInto raw_ parsed_ = case parsed_ of - (Value'null) -> - (GH.encodeVariant #null () (GH.unionStruct raw_)) - (Value'boolean arg_) -> - (GH.encodeVariant #boolean arg_ (GH.unionStruct raw_)) - (Value'number arg_) -> - (GH.encodeVariant #number arg_ (GH.unionStruct raw_)) - (Value'string arg_) -> - (GH.encodeVariant #string arg_ (GH.unionStruct raw_)) - (Value'array arg_) -> - (GH.encodeVariant #array arg_ (GH.unionStruct raw_)) - (Value'object arg_) -> - (GH.encodeVariant #object arg_ (GH.unionStruct raw_)) - (Value'call arg_) -> - (GH.encodeVariant #call arg_ (GH.unionStruct raw_)) - (Value'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Value'Field -type instance (R.ReprFor Value'Field) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Value'Field) where - typeId = 16361620220719570399 -instance (C.TypedStruct Value'Field) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate Value'Field) where - type AllocHint Value'Field = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Value'Field (C.Parsed Value'Field)) -instance (C.AllocateList Value'Field) where - type ListAllocHint Value'Field = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Value'Field (C.Parsed Value'Field)) -data instance C.Parsed Value'Field - = Value'Field - {name :: (RP.Parsed Basics.Text) - ,value :: (RP.Parsed Value)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Value'Field)) -deriving instance (Std_.Eq (C.Parsed Value'Field)) -instance (C.Parse Value'Field (C.Parsed Value'Field)) where - parse raw_ = (Value'Field <$> (GH.parseField #name raw_) - <*> (GH.parseField #value raw_)) -instance (C.Marshal Value'Field (C.Parsed Value'Field)) where - marshalInto raw_ Value'Field{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot Value'Field Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "value" GH.Slot Value'Field Value) where - fieldByLabel = (GH.ptrField 1) -data Value'Call -type instance (R.ReprFor Value'Call) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Value'Call) where - typeId = 11590566612201717064 -instance (C.TypedStruct Value'Call) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate Value'Call) where - type AllocHint Value'Call = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Value'Call (C.Parsed Value'Call)) -instance (C.AllocateList Value'Call) where - type ListAllocHint Value'Call = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Value'Call (C.Parsed Value'Call)) -data instance C.Parsed Value'Call - = Value'Call - {function :: (RP.Parsed Basics.Text) - ,params :: (RP.Parsed (R.List Value))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Value'Call)) -deriving instance (Std_.Eq (C.Parsed Value'Call)) -instance (C.Parse Value'Call (C.Parsed Value'Call)) where - parse raw_ = (Value'Call <$> (GH.parseField #function raw_) - <*> (GH.parseField #params raw_)) -instance (C.Marshal Value'Call (C.Parsed Value'Call)) where - marshalInto raw_ Value'Call{..} = (do - (GH.encodeField #function function raw_) - (GH.encodeField #params params raw_) - (Std_.pure ()) - ) -instance (GH.HasField "function" GH.Slot Value'Call Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "params" GH.Slot Value'Call (R.List Value)) where - fieldByLabel = (GH.ptrField 1) -data FlattenOptions -type instance (R.ReprFor FlattenOptions) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId FlattenOptions) where - typeId = 14186078402951440993 -instance (C.TypedStruct FlattenOptions) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate FlattenOptions) where - type AllocHint FlattenOptions = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc FlattenOptions (C.Parsed FlattenOptions)) -instance (C.AllocateList FlattenOptions) where - type ListAllocHint FlattenOptions = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc FlattenOptions (C.Parsed FlattenOptions)) -data instance C.Parsed FlattenOptions - = FlattenOptions - {prefix :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed FlattenOptions)) -deriving instance (Std_.Eq (C.Parsed FlattenOptions)) -instance (C.Parse FlattenOptions (C.Parsed FlattenOptions)) where - parse raw_ = (FlattenOptions <$> (GH.parseField #prefix raw_)) -instance (C.Marshal FlattenOptions (C.Parsed FlattenOptions)) where - marshalInto raw_ FlattenOptions{..} = (do - (GH.encodeField #prefix prefix raw_) - (Std_.pure ()) - ) -instance (GH.HasField "prefix" GH.Slot FlattenOptions Basics.Text) where - fieldByLabel = (GH.ptrField 0) -data DiscriminatorOptions -type instance (R.ReprFor DiscriminatorOptions) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId DiscriminatorOptions) where - typeId = 14049192395069608729 -instance (C.TypedStruct DiscriminatorOptions) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate DiscriminatorOptions) where - type AllocHint DiscriminatorOptions = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc DiscriminatorOptions (C.Parsed DiscriminatorOptions)) -instance (C.AllocateList DiscriminatorOptions) where - type ListAllocHint DiscriminatorOptions = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc DiscriminatorOptions (C.Parsed DiscriminatorOptions)) -data instance C.Parsed DiscriminatorOptions - = DiscriminatorOptions - {name :: (RP.Parsed Basics.Text) - ,valueName :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed DiscriminatorOptions)) -deriving instance (Std_.Eq (C.Parsed DiscriminatorOptions)) -instance (C.Parse DiscriminatorOptions (C.Parsed DiscriminatorOptions)) where - parse raw_ = (DiscriminatorOptions <$> (GH.parseField #name raw_) - <*> (GH.parseField #valueName raw_)) -instance (C.Marshal DiscriminatorOptions (C.Parsed DiscriminatorOptions)) where - marshalInto raw_ DiscriminatorOptions{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #valueName valueName raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot DiscriminatorOptions Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "valueName" GH.Slot DiscriminatorOptions Basics.Text) where - fieldByLabel = (GH.ptrField 1) diff --git a/gen/lib/Capnp/Gen/Capnp/Cxx.hs b/gen/lib/Capnp/Gen/Capnp/Cxx.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/Cxx.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.Cxx where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs b/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.Cxx.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/lib/Capnp/Gen/Capnp/Persistent.hs b/gen/lib/Capnp/Gen/Capnp/Persistent.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/Persistent.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.Persistent where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Capnp.GenHelpers.Rpc as GH +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data Persistent sturdyRef owner +type instance (R.ReprFor (Persistent sturdyRef owner)) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId (Persistent sturdyRef owner)) where + typeId = 14468694717054801553 +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Parse (Persistent sturdyRef owner) (GH.Client (Persistent sturdyRef owner))) where + parse = GH.parseCap + encode = GH.encodeCap +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (GH.Export (Persistent sturdyRef owner)) where + type Server (Persistent sturdyRef owner) = (Persistent'server_ sturdyRef owner) + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((Persistent sturdyRef owner))) [(GH.toUntypedMethodHandler ((persistent'save @(sturdyRef) @(owner)) s_))] []) +class (Persistent'server_ sturdyRef owner s_) where + {-# MINIMAL persistent'save #-} + persistent'save :: s_ -> (GH.MethodHandler (Persistent'SaveParams sturdyRef owner) (Persistent'SaveResults sturdyRef owner)) + persistent'save _ = GH.methodUnimplemented +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (GH.HasMethod "save" (Persistent sturdyRef owner) (Persistent'SaveParams sturdyRef owner) (Persistent'SaveResults sturdyRef owner)) where + methodByLabel = (GH.Method 14468694717054801553 0) +data Persistent'SaveParams sturdyRef owner +type instance (R.ReprFor (Persistent'SaveParams sturdyRef owner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Persistent'SaveParams sturdyRef owner)) where + typeId = 17829674341603767205 +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.TypedStruct (Persistent'SaveParams sturdyRef owner)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Allocate (Persistent'SaveParams sturdyRef owner)) where + type AllocHint (Persistent'SaveParams sturdyRef owner) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.EstimateAlloc (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.AllocateList (Persistent'SaveParams sturdyRef owner)) where + type ListAllocHint (Persistent'SaveParams sturdyRef owner) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.EstimateListAlloc (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) +data instance C.Parsed (Persistent'SaveParams sturdyRef owner) + = Persistent'SaveParams + {sealFor :: (RP.Parsed owner)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed sturdyRef)) + ,(Std_.Show (RP.Parsed owner))) => (Std_.Show (C.Parsed (Persistent'SaveParams sturdyRef owner))) +deriving instance ((Std_.Eq (RP.Parsed sturdyRef)) + ,(Std_.Eq (RP.Parsed owner))) => (Std_.Eq (C.Parsed (Persistent'SaveParams sturdyRef owner))) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Parse (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) where + parse raw_ = (Persistent'SaveParams <$> (GH.parseField #sealFor raw_)) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Marshal (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) where + marshalInto raw_ Persistent'SaveParams{..} = (do + (GH.encodeField #sealFor sealFor raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (GH.HasField "sealFor" GH.Slot (Persistent'SaveParams sturdyRef owner) owner) where + fieldByLabel = (GH.ptrField 0) +data Persistent'SaveResults sturdyRef owner +type instance (R.ReprFor (Persistent'SaveResults sturdyRef owner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Persistent'SaveResults sturdyRef owner)) where + typeId = 13215893102637674431 +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.TypedStruct (Persistent'SaveResults sturdyRef owner)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Allocate (Persistent'SaveResults sturdyRef owner)) where + type AllocHint (Persistent'SaveResults sturdyRef owner) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.EstimateAlloc (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.AllocateList (Persistent'SaveResults sturdyRef owner)) where + type ListAllocHint (Persistent'SaveResults sturdyRef owner) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.EstimateListAlloc (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) +data instance C.Parsed (Persistent'SaveResults sturdyRef owner) + = Persistent'SaveResults + {sturdyRef :: (RP.Parsed sturdyRef)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed sturdyRef)) + ,(Std_.Show (RP.Parsed owner))) => (Std_.Show (C.Parsed (Persistent'SaveResults sturdyRef owner))) +deriving instance ((Std_.Eq (RP.Parsed sturdyRef)) + ,(Std_.Eq (RP.Parsed owner))) => (Std_.Eq (C.Parsed (Persistent'SaveResults sturdyRef owner))) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Parse (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) where + parse raw_ = (Persistent'SaveResults <$> (GH.parseField #sturdyRef raw_)) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (C.Marshal (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) where + marshalInto raw_ Persistent'SaveResults{..} = (do + (GH.encodeField #sturdyRef sturdyRef raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (GH.HasField "sturdyRef" GH.Slot (Persistent'SaveResults sturdyRef owner) sturdyRef) where + fieldByLabel = (GH.ptrField 0) +data RealmGateway internalRef externalRef internalOwner externalOwner +type instance (R.ReprFor (RealmGateway internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId (RealmGateway internalRef externalRef internalOwner externalOwner)) where + typeId = 9583422979879616212 +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Parse (RealmGateway internalRef externalRef internalOwner externalOwner) (GH.Client (RealmGateway internalRef externalRef internalOwner externalOwner))) where + parse = GH.parseCap + encode = GH.encodeCap +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.Export (RealmGateway internalRef externalRef internalOwner externalOwner)) where + type Server (RealmGateway internalRef externalRef internalOwner externalOwner) = (RealmGateway'server_ internalRef externalRef internalOwner externalOwner) + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((RealmGateway internalRef externalRef internalOwner externalOwner))) [(GH.toUntypedMethodHandler ((realmGateway'import_ @(internalRef) @(externalRef) @(internalOwner) @(externalOwner)) s_)) + ,(GH.toUntypedMethodHandler ((realmGateway'export @(internalRef) @(externalRef) @(internalOwner) @(externalOwner)) s_))] []) +class (RealmGateway'server_ internalRef externalRef internalOwner externalOwner s_) where + {-# MINIMAL realmGateway'import_,realmGateway'export #-} + realmGateway'import_ :: s_ -> (GH.MethodHandler (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults internalRef internalOwner)) + realmGateway'import_ _ = GH.methodUnimplemented + realmGateway'export :: s_ -> (GH.MethodHandler (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults externalRef externalOwner)) + realmGateway'export _ = GH.methodUnimplemented +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.HasMethod "import_" (RealmGateway internalRef externalRef internalOwner externalOwner) (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults internalRef internalOwner)) where + methodByLabel = (GH.Method 9583422979879616212 0) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.HasMethod "export" (RealmGateway internalRef externalRef internalOwner externalOwner) (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults externalRef externalOwner)) where + methodByLabel = (GH.Method 9583422979879616212 1) +data RealmGateway'import'params internalRef externalRef internalOwner externalOwner +type instance (R.ReprFor (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where + typeId = 17348653140467603277 +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.TypedStruct (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where + numStructWords = 0 + numStructPtrs = 2 +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Allocate (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where + type AllocHint (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.EstimateAlloc (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.AllocateList (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where + type ListAllocHint (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.EstimateListAlloc (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) +data instance C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) + = RealmGateway'import'params + {cap :: (RP.Parsed (Persistent externalRef externalOwner)) + ,params :: (RP.Parsed (Persistent'SaveParams internalRef internalOwner))} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed internalRef)) + ,(Std_.Show (RP.Parsed externalRef)) + ,(Std_.Show (RP.Parsed internalOwner)) + ,(Std_.Show (RP.Parsed externalOwner))) => (Std_.Show (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) +deriving instance ((Std_.Eq (RP.Parsed internalRef)) + ,(Std_.Eq (RP.Parsed externalRef)) + ,(Std_.Eq (RP.Parsed internalOwner)) + ,(Std_.Eq (RP.Parsed externalOwner))) => (Std_.Eq (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Parse (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) where + parse raw_ = (RealmGateway'import'params <$> (GH.parseField #cap raw_) + <*> (GH.parseField #params raw_)) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Marshal (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) where + marshalInto raw_ RealmGateway'import'params{..} = (do + (GH.encodeField #cap cap raw_) + (GH.encodeField #params params raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.HasField "cap" GH.Slot (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent externalRef externalOwner)) where + fieldByLabel = (GH.ptrField 0) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.HasField "params" GH.Slot (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveParams internalRef internalOwner)) where + fieldByLabel = (GH.ptrField 1) +data RealmGateway'export'params internalRef externalRef internalOwner externalOwner +type instance (R.ReprFor (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where + typeId = 17055027933458834346 +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.TypedStruct (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where + numStructWords = 0 + numStructPtrs = 2 +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Allocate (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where + type AllocHint (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.EstimateAlloc (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.AllocateList (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where + type ListAllocHint (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.EstimateListAlloc (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) +data instance C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) + = RealmGateway'export'params + {cap :: (RP.Parsed (Persistent internalRef internalOwner)) + ,params :: (RP.Parsed (Persistent'SaveParams externalRef externalOwner))} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed internalRef)) + ,(Std_.Show (RP.Parsed externalRef)) + ,(Std_.Show (RP.Parsed internalOwner)) + ,(Std_.Show (RP.Parsed externalOwner))) => (Std_.Show (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) +deriving instance ((Std_.Eq (RP.Parsed internalRef)) + ,(Std_.Eq (RP.Parsed externalRef)) + ,(Std_.Eq (RP.Parsed internalOwner)) + ,(Std_.Eq (RP.Parsed externalOwner))) => (Std_.Eq (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Parse (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) where + parse raw_ = (RealmGateway'export'params <$> (GH.parseField #cap raw_) + <*> (GH.parseField #params raw_)) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (C.Marshal (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) where + marshalInto raw_ RealmGateway'export'params{..} = (do + (GH.encodeField #cap cap raw_) + (GH.encodeField #params params raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.HasField "cap" GH.Slot (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent internalRef internalOwner)) where + fieldByLabel = (GH.ptrField 0) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.HasField "params" GH.Slot (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveParams externalRef externalOwner)) where + fieldByLabel = (GH.ptrField 1) diff --git a/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs b/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs +++ /dev/null @@ -1,303 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.Persistent.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Capnp.GenHelpers.New.Rpc as GH -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Persistent sturdyRef owner -type instance (R.ReprFor (Persistent sturdyRef owner)) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId (Persistent sturdyRef owner)) where - typeId = 14468694717054801553 -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Parse (Persistent sturdyRef owner) (GH.Client (Persistent sturdyRef owner))) where - parse = GH.parseCap - encode = GH.encodeCap -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (GH.Export (Persistent sturdyRef owner)) where - type Server (Persistent sturdyRef owner) = (Persistent'server_ sturdyRef owner) - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((Persistent sturdyRef owner))) [(GH.toUntypedMethodHandler ((persistent'save @(sturdyRef) @(owner)) s_))] []) -class (Persistent'server_ sturdyRef owner s_) where - {-# MINIMAL persistent'save #-} - persistent'save :: s_ -> (GH.MethodHandler (Persistent'SaveParams sturdyRef owner) (Persistent'SaveResults sturdyRef owner)) - persistent'save _ = GH.methodUnimplemented -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (GH.HasMethod "save" (Persistent sturdyRef owner) (Persistent'SaveParams sturdyRef owner) (Persistent'SaveResults sturdyRef owner)) where - methodByLabel = (GH.Method 14468694717054801553 0) -data Persistent'SaveParams sturdyRef owner -type instance (R.ReprFor (Persistent'SaveParams sturdyRef owner)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Persistent'SaveParams sturdyRef owner)) where - typeId = 17829674341603767205 -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.TypedStruct (Persistent'SaveParams sturdyRef owner)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Allocate (Persistent'SaveParams sturdyRef owner)) where - type AllocHint (Persistent'SaveParams sturdyRef owner) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.EstimateAlloc (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.AllocateList (Persistent'SaveParams sturdyRef owner)) where - type ListAllocHint (Persistent'SaveParams sturdyRef owner) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.EstimateListAlloc (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) -data instance C.Parsed (Persistent'SaveParams sturdyRef owner) - = Persistent'SaveParams - {sealFor :: (RP.Parsed owner)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed sturdyRef)) - ,(Std_.Show (RP.Parsed owner))) => (Std_.Show (C.Parsed (Persistent'SaveParams sturdyRef owner))) -deriving instance ((Std_.Eq (RP.Parsed sturdyRef)) - ,(Std_.Eq (RP.Parsed owner))) => (Std_.Eq (C.Parsed (Persistent'SaveParams sturdyRef owner))) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Parse (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) where - parse raw_ = (Persistent'SaveParams <$> (GH.parseField #sealFor raw_)) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Marshal (Persistent'SaveParams sturdyRef owner) (C.Parsed (Persistent'SaveParams sturdyRef owner))) where - marshalInto raw_ Persistent'SaveParams{..} = (do - (GH.encodeField #sealFor sealFor raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (GH.HasField "sealFor" GH.Slot (Persistent'SaveParams sturdyRef owner) owner) where - fieldByLabel = (GH.ptrField 0) -data Persistent'SaveResults sturdyRef owner -type instance (R.ReprFor (Persistent'SaveResults sturdyRef owner)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Persistent'SaveResults sturdyRef owner)) where - typeId = 13215893102637674431 -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.TypedStruct (Persistent'SaveResults sturdyRef owner)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Allocate (Persistent'SaveResults sturdyRef owner)) where - type AllocHint (Persistent'SaveResults sturdyRef owner) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.EstimateAlloc (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.AllocateList (Persistent'SaveResults sturdyRef owner)) where - type ListAllocHint (Persistent'SaveResults sturdyRef owner) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.EstimateListAlloc (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) -data instance C.Parsed (Persistent'SaveResults sturdyRef owner) - = Persistent'SaveResults - {sturdyRef :: (RP.Parsed sturdyRef)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed sturdyRef)) - ,(Std_.Show (RP.Parsed owner))) => (Std_.Show (C.Parsed (Persistent'SaveResults sturdyRef owner))) -deriving instance ((Std_.Eq (RP.Parsed sturdyRef)) - ,(Std_.Eq (RP.Parsed owner))) => (Std_.Eq (C.Parsed (Persistent'SaveResults sturdyRef owner))) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Parse (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) where - parse raw_ = (Persistent'SaveResults <$> (GH.parseField #sturdyRef raw_)) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (C.Marshal (Persistent'SaveResults sturdyRef owner) (C.Parsed (Persistent'SaveResults sturdyRef owner))) where - marshalInto raw_ Persistent'SaveResults{..} = (do - (GH.encodeField #sturdyRef sturdyRef raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam sturdyRef) - ,(GH.TypeParam owner)) => (GH.HasField "sturdyRef" GH.Slot (Persistent'SaveResults sturdyRef owner) sturdyRef) where - fieldByLabel = (GH.ptrField 0) -data RealmGateway internalRef externalRef internalOwner externalOwner -type instance (R.ReprFor (RealmGateway internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId (RealmGateway internalRef externalRef internalOwner externalOwner)) where - typeId = 9583422979879616212 -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Parse (RealmGateway internalRef externalRef internalOwner externalOwner) (GH.Client (RealmGateway internalRef externalRef internalOwner externalOwner))) where - parse = GH.parseCap - encode = GH.encodeCap -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.Export (RealmGateway internalRef externalRef internalOwner externalOwner)) where - type Server (RealmGateway internalRef externalRef internalOwner externalOwner) = (RealmGateway'server_ internalRef externalRef internalOwner externalOwner) - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((RealmGateway internalRef externalRef internalOwner externalOwner))) [(GH.toUntypedMethodHandler ((realmGateway'import_ @(internalRef) @(externalRef) @(internalOwner) @(externalOwner)) s_)) - ,(GH.toUntypedMethodHandler ((realmGateway'export @(internalRef) @(externalRef) @(internalOwner) @(externalOwner)) s_))] []) -class (RealmGateway'server_ internalRef externalRef internalOwner externalOwner s_) where - {-# MINIMAL realmGateway'import_,realmGateway'export #-} - realmGateway'import_ :: s_ -> (GH.MethodHandler (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults internalRef internalOwner)) - realmGateway'import_ _ = GH.methodUnimplemented - realmGateway'export :: s_ -> (GH.MethodHandler (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults externalRef externalOwner)) - realmGateway'export _ = GH.methodUnimplemented -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.HasMethod "import_" (RealmGateway internalRef externalRef internalOwner externalOwner) (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults internalRef internalOwner)) where - methodByLabel = (GH.Method 9583422979879616212 0) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.HasMethod "export" (RealmGateway internalRef externalRef internalOwner externalOwner) (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults externalRef externalOwner)) where - methodByLabel = (GH.Method 9583422979879616212 1) -data RealmGateway'import'params internalRef externalRef internalOwner externalOwner -type instance (R.ReprFor (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where - typeId = 17348653140467603277 -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.TypedStruct (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where - numStructWords = 0 - numStructPtrs = 2 -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Allocate (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where - type AllocHint (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.EstimateAlloc (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.AllocateList (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where - type ListAllocHint (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.EstimateListAlloc (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) -data instance C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) - = RealmGateway'import'params - {cap :: (RP.Parsed (Persistent externalRef externalOwner)) - ,params :: (RP.Parsed (Persistent'SaveParams internalRef internalOwner))} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed internalRef)) - ,(Std_.Show (RP.Parsed externalRef)) - ,(Std_.Show (RP.Parsed internalOwner)) - ,(Std_.Show (RP.Parsed externalOwner))) => (Std_.Show (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) -deriving instance ((Std_.Eq (RP.Parsed internalRef)) - ,(Std_.Eq (RP.Parsed externalRef)) - ,(Std_.Eq (RP.Parsed internalOwner)) - ,(Std_.Eq (RP.Parsed externalOwner))) => (Std_.Eq (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Parse (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) where - parse raw_ = (RealmGateway'import'params <$> (GH.parseField #cap raw_) - <*> (GH.parseField #params raw_)) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Marshal (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'import'params internalRef externalRef internalOwner externalOwner))) where - marshalInto raw_ RealmGateway'import'params{..} = (do - (GH.encodeField #cap cap raw_) - (GH.encodeField #params params raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.HasField "cap" GH.Slot (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent externalRef externalOwner)) where - fieldByLabel = (GH.ptrField 0) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.HasField "params" GH.Slot (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveParams internalRef internalOwner)) where - fieldByLabel = (GH.ptrField 1) -data RealmGateway'export'params internalRef externalRef internalOwner externalOwner -type instance (R.ReprFor (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where - typeId = 17055027933458834346 -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.TypedStruct (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where - numStructWords = 0 - numStructPtrs = 2 -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Allocate (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where - type AllocHint (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.EstimateAlloc (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.AllocateList (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where - type ListAllocHint (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.EstimateListAlloc (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) -data instance C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) - = RealmGateway'export'params - {cap :: (RP.Parsed (Persistent internalRef internalOwner)) - ,params :: (RP.Parsed (Persistent'SaveParams externalRef externalOwner))} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed internalRef)) - ,(Std_.Show (RP.Parsed externalRef)) - ,(Std_.Show (RP.Parsed internalOwner)) - ,(Std_.Show (RP.Parsed externalOwner))) => (Std_.Show (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) -deriving instance ((Std_.Eq (RP.Parsed internalRef)) - ,(Std_.Eq (RP.Parsed externalRef)) - ,(Std_.Eq (RP.Parsed internalOwner)) - ,(Std_.Eq (RP.Parsed externalOwner))) => (Std_.Eq (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Parse (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) where - parse raw_ = (RealmGateway'export'params <$> (GH.parseField #cap raw_) - <*> (GH.parseField #params raw_)) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (C.Marshal (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (C.Parsed (RealmGateway'export'params internalRef externalRef internalOwner externalOwner))) where - marshalInto raw_ RealmGateway'export'params{..} = (do - (GH.encodeField #cap cap raw_) - (GH.encodeField #params params raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.HasField "cap" GH.Slot (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent internalRef internalOwner)) where - fieldByLabel = (GH.ptrField 0) -instance ((GH.TypeParam internalRef) - ,(GH.TypeParam externalRef) - ,(GH.TypeParam internalOwner) - ,(GH.TypeParam externalOwner)) => (GH.HasField "params" GH.Slot (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveParams externalRef externalOwner)) where - fieldByLabel = (GH.ptrField 1) diff --git a/gen/lib/Capnp/Gen/Capnp/Rpc.hs b/gen/lib/Capnp/Gen/Capnp/Rpc.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/Rpc.hs @@ -0,0 +1,1372 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.Rpc where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data Message +type instance (R.ReprFor Message) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Message) where + typeId = 10500036013887172658 +instance (C.TypedStruct Message) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Message) where + type AllocHint Message = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Message (C.Parsed Message)) +instance (C.AllocateList Message) where + type ListAllocHint Message = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Message (C.Parsed Message)) +data instance C.Parsed Message + = Message + {union' :: (C.Parsed (GH.Which Message))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Message)) +deriving instance (Std_.Eq (C.Parsed Message)) +instance (C.Parse Message (C.Parsed Message)) where + parse raw_ = (Message <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Message (C.Parsed Message)) where + marshalInto raw_ Message{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Message) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Message mut_ + = RW_Message'unimplemented (R.Raw Message mut_) + | RW_Message'abort (R.Raw Exception mut_) + | RW_Message'call (R.Raw Call mut_) + | RW_Message'return (R.Raw Return mut_) + | RW_Message'finish (R.Raw Finish mut_) + | RW_Message'resolve (R.Raw Resolve mut_) + | RW_Message'release (R.Raw Release mut_) + | RW_Message'obsoleteSave (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Message'bootstrap (R.Raw Bootstrap mut_) + | RW_Message'obsoleteDelete (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Message'provide (R.Raw Provide mut_) + | RW_Message'accept (R.Raw Accept mut_) + | RW_Message'join (R.Raw Join mut_) + | RW_Message'disembargo (R.Raw Disembargo mut_) + | RW_Message'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Message'unimplemented <$> (GH.readVariant #unimplemented struct_)) + 1 -> + (RW_Message'abort <$> (GH.readVariant #abort struct_)) + 2 -> + (RW_Message'call <$> (GH.readVariant #call struct_)) + 3 -> + (RW_Message'return <$> (GH.readVariant #return struct_)) + 4 -> + (RW_Message'finish <$> (GH.readVariant #finish struct_)) + 5 -> + (RW_Message'resolve <$> (GH.readVariant #resolve struct_)) + 6 -> + (RW_Message'release <$> (GH.readVariant #release struct_)) + 7 -> + (RW_Message'obsoleteSave <$> (GH.readVariant #obsoleteSave struct_)) + 8 -> + (RW_Message'bootstrap <$> (GH.readVariant #bootstrap struct_)) + 9 -> + (RW_Message'obsoleteDelete <$> (GH.readVariant #obsoleteDelete struct_)) + 10 -> + (RW_Message'provide <$> (GH.readVariant #provide struct_)) + 11 -> + (RW_Message'accept <$> (GH.readVariant #accept struct_)) + 12 -> + (RW_Message'join <$> (GH.readVariant #join struct_)) + 13 -> + (RW_Message'disembargo <$> (GH.readVariant #disembargo struct_)) + _ -> + (Std_.pure (RW_Message'unknown' tag_)) + data Which Message +instance (GH.HasVariant "unimplemented" GH.Slot Message Message) where + variantByLabel = (GH.Variant (GH.ptrField 0) 0) +instance (GH.HasVariant "abort" GH.Slot Message Exception) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +instance (GH.HasVariant "call" GH.Slot Message Call) where + variantByLabel = (GH.Variant (GH.ptrField 0) 2) +instance (GH.HasVariant "return" GH.Slot Message Return) where + variantByLabel = (GH.Variant (GH.ptrField 0) 3) +instance (GH.HasVariant "finish" GH.Slot Message Finish) where + variantByLabel = (GH.Variant (GH.ptrField 0) 4) +instance (GH.HasVariant "resolve" GH.Slot Message Resolve) where + variantByLabel = (GH.Variant (GH.ptrField 0) 5) +instance (GH.HasVariant "release" GH.Slot Message Release) where + variantByLabel = (GH.Variant (GH.ptrField 0) 6) +instance (GH.HasVariant "obsoleteSave" GH.Slot Message (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 7) +instance (GH.HasVariant "bootstrap" GH.Slot Message Bootstrap) where + variantByLabel = (GH.Variant (GH.ptrField 0) 8) +instance (GH.HasVariant "obsoleteDelete" GH.Slot Message (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 9) +instance (GH.HasVariant "provide" GH.Slot Message Provide) where + variantByLabel = (GH.Variant (GH.ptrField 0) 10) +instance (GH.HasVariant "accept" GH.Slot Message Accept) where + variantByLabel = (GH.Variant (GH.ptrField 0) 11) +instance (GH.HasVariant "join" GH.Slot Message Join) where + variantByLabel = (GH.Variant (GH.ptrField 0) 12) +instance (GH.HasVariant "disembargo" GH.Slot Message Disembargo) where + variantByLabel = (GH.Variant (GH.ptrField 0) 13) +data instance C.Parsed (GH.Which Message) + = Message'unimplemented (RP.Parsed Message) + | Message'abort (RP.Parsed Exception) + | Message'call (RP.Parsed Call) + | Message'return (RP.Parsed Return) + | Message'finish (RP.Parsed Finish) + | Message'resolve (RP.Parsed Resolve) + | Message'release (RP.Parsed Release) + | Message'obsoleteSave (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Message'bootstrap (RP.Parsed Bootstrap) + | Message'obsoleteDelete (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Message'provide (RP.Parsed Provide) + | Message'accept (RP.Parsed Accept) + | Message'join (RP.Parsed Join) + | Message'disembargo (RP.Parsed Disembargo) + | Message'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Message))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Message))) +instance (C.Parse (GH.Which Message) (C.Parsed (GH.Which Message))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Message'unimplemented rawArg_) -> + (Message'unimplemented <$> (C.parse rawArg_)) + (RW_Message'abort rawArg_) -> + (Message'abort <$> (C.parse rawArg_)) + (RW_Message'call rawArg_) -> + (Message'call <$> (C.parse rawArg_)) + (RW_Message'return rawArg_) -> + (Message'return <$> (C.parse rawArg_)) + (RW_Message'finish rawArg_) -> + (Message'finish <$> (C.parse rawArg_)) + (RW_Message'resolve rawArg_) -> + (Message'resolve <$> (C.parse rawArg_)) + (RW_Message'release rawArg_) -> + (Message'release <$> (C.parse rawArg_)) + (RW_Message'obsoleteSave rawArg_) -> + (Message'obsoleteSave <$> (C.parse rawArg_)) + (RW_Message'bootstrap rawArg_) -> + (Message'bootstrap <$> (C.parse rawArg_)) + (RW_Message'obsoleteDelete rawArg_) -> + (Message'obsoleteDelete <$> (C.parse rawArg_)) + (RW_Message'provide rawArg_) -> + (Message'provide <$> (C.parse rawArg_)) + (RW_Message'accept rawArg_) -> + (Message'accept <$> (C.parse rawArg_)) + (RW_Message'join rawArg_) -> + (Message'join <$> (C.parse rawArg_)) + (RW_Message'disembargo rawArg_) -> + (Message'disembargo <$> (C.parse rawArg_)) + (RW_Message'unknown' tag_) -> + (Std_.pure (Message'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Message) (C.Parsed (GH.Which Message))) where + marshalInto raw_ parsed_ = case parsed_ of + (Message'unimplemented arg_) -> + (GH.encodeVariant #unimplemented arg_ (GH.unionStruct raw_)) + (Message'abort arg_) -> + (GH.encodeVariant #abort arg_ (GH.unionStruct raw_)) + (Message'call arg_) -> + (GH.encodeVariant #call arg_ (GH.unionStruct raw_)) + (Message'return arg_) -> + (GH.encodeVariant #return arg_ (GH.unionStruct raw_)) + (Message'finish arg_) -> + (GH.encodeVariant #finish arg_ (GH.unionStruct raw_)) + (Message'resolve arg_) -> + (GH.encodeVariant #resolve arg_ (GH.unionStruct raw_)) + (Message'release arg_) -> + (GH.encodeVariant #release arg_ (GH.unionStruct raw_)) + (Message'obsoleteSave arg_) -> + (GH.encodeVariant #obsoleteSave arg_ (GH.unionStruct raw_)) + (Message'bootstrap arg_) -> + (GH.encodeVariant #bootstrap arg_ (GH.unionStruct raw_)) + (Message'obsoleteDelete arg_) -> + (GH.encodeVariant #obsoleteDelete arg_ (GH.unionStruct raw_)) + (Message'provide arg_) -> + (GH.encodeVariant #provide arg_ (GH.unionStruct raw_)) + (Message'accept arg_) -> + (GH.encodeVariant #accept arg_ (GH.unionStruct raw_)) + (Message'join arg_) -> + (GH.encodeVariant #join arg_ (GH.unionStruct raw_)) + (Message'disembargo arg_) -> + (GH.encodeVariant #disembargo arg_ (GH.unionStruct raw_)) + (Message'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Bootstrap +type instance (R.ReprFor Bootstrap) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bootstrap) where + typeId = 16811039658553601732 +instance (C.TypedStruct Bootstrap) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Bootstrap) where + type AllocHint Bootstrap = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Bootstrap (C.Parsed Bootstrap)) +instance (C.AllocateList Bootstrap) where + type ListAllocHint Bootstrap = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Bootstrap (C.Parsed Bootstrap)) +data instance C.Parsed Bootstrap + = Bootstrap + {questionId :: (RP.Parsed Std_.Word32) + ,deprecatedObjectId :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Bootstrap)) +deriving instance (Std_.Eq (C.Parsed Bootstrap)) +instance (C.Parse Bootstrap (C.Parsed Bootstrap)) where + parse raw_ = (Bootstrap <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #deprecatedObjectId raw_)) +instance (C.Marshal Bootstrap (C.Parsed Bootstrap)) where + marshalInto raw_ Bootstrap{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #deprecatedObjectId deprecatedObjectId raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot Bootstrap Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "deprecatedObjectId" GH.Slot Bootstrap (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 0) +data Call +type instance (R.ReprFor Call) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Call) where + typeId = 9469473312751832276 +instance (C.TypedStruct Call) where + numStructWords = 3 + numStructPtrs = 3 +instance (C.Allocate Call) where + type AllocHint Call = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Call (C.Parsed Call)) +instance (C.AllocateList Call) where + type ListAllocHint Call = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Call (C.Parsed Call)) +data instance C.Parsed Call + = Call + {questionId :: (RP.Parsed Std_.Word32) + ,target :: (RP.Parsed MessageTarget) + ,interfaceId :: (RP.Parsed Std_.Word64) + ,methodId :: (RP.Parsed Std_.Word16) + ,params :: (RP.Parsed Payload) + ,sendResultsTo :: (RP.Parsed Call'sendResultsTo) + ,allowThirdPartyTailCall :: (RP.Parsed Std_.Bool)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Call)) +deriving instance (Std_.Eq (C.Parsed Call)) +instance (C.Parse Call (C.Parsed Call)) where + parse raw_ = (Call <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #target raw_) + <*> (GH.parseField #interfaceId raw_) + <*> (GH.parseField #methodId raw_) + <*> (GH.parseField #params raw_) + <*> (GH.parseField #sendResultsTo raw_) + <*> (GH.parseField #allowThirdPartyTailCall raw_)) +instance (C.Marshal Call (C.Parsed Call)) where + marshalInto raw_ Call{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #target target raw_) + (GH.encodeField #interfaceId interfaceId raw_) + (GH.encodeField #methodId methodId raw_) + (GH.encodeField #params params raw_) + (do + group_ <- (GH.readField #sendResultsTo raw_) + (C.marshalInto group_ sendResultsTo) + ) + (GH.encodeField #allowThirdPartyTailCall allowThirdPartyTailCall raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot Call Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "target" GH.Slot Call MessageTarget) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "interfaceId" GH.Slot Call Std_.Word64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "methodId" GH.Slot Call Std_.Word16) where + fieldByLabel = (GH.dataField 32 0 16 0) +instance (GH.HasField "params" GH.Slot Call Payload) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "sendResultsTo" GH.Group Call Call'sendResultsTo) where + fieldByLabel = GH.groupField +instance (GH.HasField "allowThirdPartyTailCall" GH.Slot Call Std_.Bool) where + fieldByLabel = (GH.dataField 0 2 1 0) +data Call'sendResultsTo +type instance (R.ReprFor Call'sendResultsTo) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Call'sendResultsTo) where + typeId = 15774052265921044377 +instance (C.TypedStruct Call'sendResultsTo) where + numStructWords = 3 + numStructPtrs = 3 +instance (C.Allocate Call'sendResultsTo) where + type AllocHint Call'sendResultsTo = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Call'sendResultsTo (C.Parsed Call'sendResultsTo)) +instance (C.AllocateList Call'sendResultsTo) where + type ListAllocHint Call'sendResultsTo = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Call'sendResultsTo (C.Parsed Call'sendResultsTo)) +data instance C.Parsed Call'sendResultsTo + = Call'sendResultsTo' + {union' :: (C.Parsed (GH.Which Call'sendResultsTo))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Call'sendResultsTo)) +deriving instance (Std_.Eq (C.Parsed Call'sendResultsTo)) +instance (C.Parse Call'sendResultsTo (C.Parsed Call'sendResultsTo)) where + parse raw_ = (Call'sendResultsTo' <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Call'sendResultsTo (C.Parsed Call'sendResultsTo)) where + marshalInto raw_ Call'sendResultsTo'{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Call'sendResultsTo) where + unionField = (GH.dataField 48 0 16 0) + data RawWhich Call'sendResultsTo mut_ + = RW_Call'sendResultsTo'caller (R.Raw () mut_) + | RW_Call'sendResultsTo'yourself (R.Raw () mut_) + | RW_Call'sendResultsTo'thirdParty (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Call'sendResultsTo'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Call'sendResultsTo'caller <$> (GH.readVariant #caller struct_)) + 1 -> + (RW_Call'sendResultsTo'yourself <$> (GH.readVariant #yourself struct_)) + 2 -> + (RW_Call'sendResultsTo'thirdParty <$> (GH.readVariant #thirdParty struct_)) + _ -> + (Std_.pure (RW_Call'sendResultsTo'unknown' tag_)) + data Which Call'sendResultsTo +instance (GH.HasVariant "caller" GH.Slot Call'sendResultsTo ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "yourself" GH.Slot Call'sendResultsTo ()) where + variantByLabel = (GH.Variant GH.voidField 1) +instance (GH.HasVariant "thirdParty" GH.Slot Call'sendResultsTo (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 2) 2) +data instance C.Parsed (GH.Which Call'sendResultsTo) + = Call'sendResultsTo'caller + | Call'sendResultsTo'yourself + | Call'sendResultsTo'thirdParty (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Call'sendResultsTo'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Call'sendResultsTo))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Call'sendResultsTo))) +instance (C.Parse (GH.Which Call'sendResultsTo) (C.Parsed (GH.Which Call'sendResultsTo))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Call'sendResultsTo'caller _) -> + (Std_.pure Call'sendResultsTo'caller) + (RW_Call'sendResultsTo'yourself _) -> + (Std_.pure Call'sendResultsTo'yourself) + (RW_Call'sendResultsTo'thirdParty rawArg_) -> + (Call'sendResultsTo'thirdParty <$> (C.parse rawArg_)) + (RW_Call'sendResultsTo'unknown' tag_) -> + (Std_.pure (Call'sendResultsTo'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Call'sendResultsTo) (C.Parsed (GH.Which Call'sendResultsTo))) where + marshalInto raw_ parsed_ = case parsed_ of + (Call'sendResultsTo'caller) -> + (GH.encodeVariant #caller () (GH.unionStruct raw_)) + (Call'sendResultsTo'yourself) -> + (GH.encodeVariant #yourself () (GH.unionStruct raw_)) + (Call'sendResultsTo'thirdParty arg_) -> + (GH.encodeVariant #thirdParty arg_ (GH.unionStruct raw_)) + (Call'sendResultsTo'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Return +type instance (R.ReprFor Return) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Return) where + typeId = 11392333052105676602 +instance (C.TypedStruct Return) where + numStructWords = 2 + numStructPtrs = 1 +instance (C.Allocate Return) where + type AllocHint Return = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Return (C.Parsed Return)) +instance (C.AllocateList Return) where + type ListAllocHint Return = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Return (C.Parsed Return)) +data instance C.Parsed Return + = Return + {answerId :: (RP.Parsed Std_.Word32) + ,releaseParamCaps :: (RP.Parsed Std_.Bool) + ,union' :: (C.Parsed (GH.Which Return))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Return)) +deriving instance (Std_.Eq (C.Parsed Return)) +instance (C.Parse Return (C.Parsed Return)) where + parse raw_ = (Return <$> (GH.parseField #answerId raw_) + <*> (GH.parseField #releaseParamCaps raw_) + <*> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Return (C.Parsed Return)) where + marshalInto raw_ Return{..} = (do + (GH.encodeField #answerId answerId raw_) + (GH.encodeField #releaseParamCaps releaseParamCaps raw_) + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Return) where + unionField = (GH.dataField 48 0 16 0) + data RawWhich Return mut_ + = RW_Return'results (R.Raw Payload mut_) + | RW_Return'exception (R.Raw Exception mut_) + | RW_Return'canceled (R.Raw () mut_) + | RW_Return'resultsSentElsewhere (R.Raw () mut_) + | RW_Return'takeFromOtherQuestion (R.Raw Std_.Word32 mut_) + | RW_Return'acceptFromThirdParty (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Return'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Return'results <$> (GH.readVariant #results struct_)) + 1 -> + (RW_Return'exception <$> (GH.readVariant #exception struct_)) + 2 -> + (RW_Return'canceled <$> (GH.readVariant #canceled struct_)) + 3 -> + (RW_Return'resultsSentElsewhere <$> (GH.readVariant #resultsSentElsewhere struct_)) + 4 -> + (RW_Return'takeFromOtherQuestion <$> (GH.readVariant #takeFromOtherQuestion struct_)) + 5 -> + (RW_Return'acceptFromThirdParty <$> (GH.readVariant #acceptFromThirdParty struct_)) + _ -> + (Std_.pure (RW_Return'unknown' tag_)) + data Which Return +instance (GH.HasVariant "results" GH.Slot Return Payload) where + variantByLabel = (GH.Variant (GH.ptrField 0) 0) +instance (GH.HasVariant "exception" GH.Slot Return Exception) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +instance (GH.HasVariant "canceled" GH.Slot Return ()) where + variantByLabel = (GH.Variant GH.voidField 2) +instance (GH.HasVariant "resultsSentElsewhere" GH.Slot Return ()) where + variantByLabel = (GH.Variant GH.voidField 3) +instance (GH.HasVariant "takeFromOtherQuestion" GH.Slot Return Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 4) +instance (GH.HasVariant "acceptFromThirdParty" GH.Slot Return (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 5) +data instance C.Parsed (GH.Which Return) + = Return'results (RP.Parsed Payload) + | Return'exception (RP.Parsed Exception) + | Return'canceled + | Return'resultsSentElsewhere + | Return'takeFromOtherQuestion (RP.Parsed Std_.Word32) + | Return'acceptFromThirdParty (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Return'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Return))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Return))) +instance (C.Parse (GH.Which Return) (C.Parsed (GH.Which Return))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Return'results rawArg_) -> + (Return'results <$> (C.parse rawArg_)) + (RW_Return'exception rawArg_) -> + (Return'exception <$> (C.parse rawArg_)) + (RW_Return'canceled _) -> + (Std_.pure Return'canceled) + (RW_Return'resultsSentElsewhere _) -> + (Std_.pure Return'resultsSentElsewhere) + (RW_Return'takeFromOtherQuestion rawArg_) -> + (Return'takeFromOtherQuestion <$> (C.parse rawArg_)) + (RW_Return'acceptFromThirdParty rawArg_) -> + (Return'acceptFromThirdParty <$> (C.parse rawArg_)) + (RW_Return'unknown' tag_) -> + (Std_.pure (Return'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Return) (C.Parsed (GH.Which Return))) where + marshalInto raw_ parsed_ = case parsed_ of + (Return'results arg_) -> + (GH.encodeVariant #results arg_ (GH.unionStruct raw_)) + (Return'exception arg_) -> + (GH.encodeVariant #exception arg_ (GH.unionStruct raw_)) + (Return'canceled) -> + (GH.encodeVariant #canceled () (GH.unionStruct raw_)) + (Return'resultsSentElsewhere) -> + (GH.encodeVariant #resultsSentElsewhere () (GH.unionStruct raw_)) + (Return'takeFromOtherQuestion arg_) -> + (GH.encodeVariant #takeFromOtherQuestion arg_ (GH.unionStruct raw_)) + (Return'acceptFromThirdParty arg_) -> + (GH.encodeVariant #acceptFromThirdParty arg_ (GH.unionStruct raw_)) + (Return'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +instance (GH.HasField "answerId" GH.Slot Return Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "releaseParamCaps" GH.Slot Return Std_.Bool) where + fieldByLabel = (GH.dataField 32 0 1 1) +data Finish +type instance (R.ReprFor Finish) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Finish) where + typeId = 15239388059401719395 +instance (C.TypedStruct Finish) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate Finish) where + type AllocHint Finish = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Finish (C.Parsed Finish)) +instance (C.AllocateList Finish) where + type ListAllocHint Finish = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Finish (C.Parsed Finish)) +data instance C.Parsed Finish + = Finish + {questionId :: (RP.Parsed Std_.Word32) + ,releaseResultCaps :: (RP.Parsed Std_.Bool)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Finish)) +deriving instance (Std_.Eq (C.Parsed Finish)) +instance (C.Parse Finish (C.Parsed Finish)) where + parse raw_ = (Finish <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #releaseResultCaps raw_)) +instance (C.Marshal Finish (C.Parsed Finish)) where + marshalInto raw_ Finish{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #releaseResultCaps releaseResultCaps raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot Finish Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "releaseResultCaps" GH.Slot Finish Std_.Bool) where + fieldByLabel = (GH.dataField 32 0 1 1) +data Resolve +type instance (R.ReprFor Resolve) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Resolve) where + typeId = 13529541526594062446 +instance (C.TypedStruct Resolve) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Resolve) where + type AllocHint Resolve = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Resolve (C.Parsed Resolve)) +instance (C.AllocateList Resolve) where + type ListAllocHint Resolve = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Resolve (C.Parsed Resolve)) +data instance C.Parsed Resolve + = Resolve + {promiseId :: (RP.Parsed Std_.Word32) + ,union' :: (C.Parsed (GH.Which Resolve))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Resolve)) +deriving instance (Std_.Eq (C.Parsed Resolve)) +instance (C.Parse Resolve (C.Parsed Resolve)) where + parse raw_ = (Resolve <$> (GH.parseField #promiseId raw_) + <*> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Resolve (C.Parsed Resolve)) where + marshalInto raw_ Resolve{..} = (do + (GH.encodeField #promiseId promiseId raw_) + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Resolve) where + unionField = (GH.dataField 32 0 16 0) + data RawWhich Resolve mut_ + = RW_Resolve'cap (R.Raw CapDescriptor mut_) + | RW_Resolve'exception (R.Raw Exception mut_) + | RW_Resolve'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Resolve'cap <$> (GH.readVariant #cap struct_)) + 1 -> + (RW_Resolve'exception <$> (GH.readVariant #exception struct_)) + _ -> + (Std_.pure (RW_Resolve'unknown' tag_)) + data Which Resolve +instance (GH.HasVariant "cap" GH.Slot Resolve CapDescriptor) where + variantByLabel = (GH.Variant (GH.ptrField 0) 0) +instance (GH.HasVariant "exception" GH.Slot Resolve Exception) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +data instance C.Parsed (GH.Which Resolve) + = Resolve'cap (RP.Parsed CapDescriptor) + | Resolve'exception (RP.Parsed Exception) + | Resolve'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Resolve))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Resolve))) +instance (C.Parse (GH.Which Resolve) (C.Parsed (GH.Which Resolve))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Resolve'cap rawArg_) -> + (Resolve'cap <$> (C.parse rawArg_)) + (RW_Resolve'exception rawArg_) -> + (Resolve'exception <$> (C.parse rawArg_)) + (RW_Resolve'unknown' tag_) -> + (Std_.pure (Resolve'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Resolve) (C.Parsed (GH.Which Resolve))) where + marshalInto raw_ parsed_ = case parsed_ of + (Resolve'cap arg_) -> + (GH.encodeVariant #cap arg_ (GH.unionStruct raw_)) + (Resolve'exception arg_) -> + (GH.encodeVariant #exception arg_ (GH.unionStruct raw_)) + (Resolve'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +instance (GH.HasField "promiseId" GH.Slot Resolve Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +data Release +type instance (R.ReprFor Release) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Release) where + typeId = 12473400923157197975 +instance (C.TypedStruct Release) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate Release) where + type AllocHint Release = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Release (C.Parsed Release)) +instance (C.AllocateList Release) where + type ListAllocHint Release = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Release (C.Parsed Release)) +data instance C.Parsed Release + = Release + {id :: (RP.Parsed Std_.Word32) + ,referenceCount :: (RP.Parsed Std_.Word32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Release)) +deriving instance (Std_.Eq (C.Parsed Release)) +instance (C.Parse Release (C.Parsed Release)) where + parse raw_ = (Release <$> (GH.parseField #id raw_) + <*> (GH.parseField #referenceCount raw_)) +instance (C.Marshal Release (C.Parsed Release)) where + marshalInto raw_ Release{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #referenceCount referenceCount raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot Release Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "referenceCount" GH.Slot Release Std_.Word32) where + fieldByLabel = (GH.dataField 32 0 32 0) +data Disembargo +type instance (R.ReprFor Disembargo) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Disembargo) where + typeId = 17970548384007534353 +instance (C.TypedStruct Disembargo) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Disembargo) where + type AllocHint Disembargo = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Disembargo (C.Parsed Disembargo)) +instance (C.AllocateList Disembargo) where + type ListAllocHint Disembargo = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Disembargo (C.Parsed Disembargo)) +data instance C.Parsed Disembargo + = Disembargo + {target :: (RP.Parsed MessageTarget) + ,context :: (RP.Parsed Disembargo'context)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Disembargo)) +deriving instance (Std_.Eq (C.Parsed Disembargo)) +instance (C.Parse Disembargo (C.Parsed Disembargo)) where + parse raw_ = (Disembargo <$> (GH.parseField #target raw_) + <*> (GH.parseField #context raw_)) +instance (C.Marshal Disembargo (C.Parsed Disembargo)) where + marshalInto raw_ Disembargo{..} = (do + (GH.encodeField #target target raw_) + (do + group_ <- (GH.readField #context raw_) + (C.marshalInto group_ context) + ) + (Std_.pure ()) + ) +instance (GH.HasField "target" GH.Slot Disembargo MessageTarget) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "context" GH.Group Disembargo Disembargo'context) where + fieldByLabel = GH.groupField +data Disembargo'context +type instance (R.ReprFor Disembargo'context) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Disembargo'context) where + typeId = 15376050949367520589 +instance (C.TypedStruct Disembargo'context) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Disembargo'context) where + type AllocHint Disembargo'context = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Disembargo'context (C.Parsed Disembargo'context)) +instance (C.AllocateList Disembargo'context) where + type ListAllocHint Disembargo'context = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Disembargo'context (C.Parsed Disembargo'context)) +data instance C.Parsed Disembargo'context + = Disembargo'context' + {union' :: (C.Parsed (GH.Which Disembargo'context))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Disembargo'context)) +deriving instance (Std_.Eq (C.Parsed Disembargo'context)) +instance (C.Parse Disembargo'context (C.Parsed Disembargo'context)) where + parse raw_ = (Disembargo'context' <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Disembargo'context (C.Parsed Disembargo'context)) where + marshalInto raw_ Disembargo'context'{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Disembargo'context) where + unionField = (GH.dataField 32 0 16 0) + data RawWhich Disembargo'context mut_ + = RW_Disembargo'context'senderLoopback (R.Raw Std_.Word32 mut_) + | RW_Disembargo'context'receiverLoopback (R.Raw Std_.Word32 mut_) + | RW_Disembargo'context'accept (R.Raw () mut_) + | RW_Disembargo'context'provide (R.Raw Std_.Word32 mut_) + | RW_Disembargo'context'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Disembargo'context'senderLoopback <$> (GH.readVariant #senderLoopback struct_)) + 1 -> + (RW_Disembargo'context'receiverLoopback <$> (GH.readVariant #receiverLoopback struct_)) + 2 -> + (RW_Disembargo'context'accept <$> (GH.readVariant #accept struct_)) + 3 -> + (RW_Disembargo'context'provide <$> (GH.readVariant #provide struct_)) + _ -> + (Std_.pure (RW_Disembargo'context'unknown' tag_)) + data Which Disembargo'context +instance (GH.HasVariant "senderLoopback" GH.Slot Disembargo'context Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 0) +instance (GH.HasVariant "receiverLoopback" GH.Slot Disembargo'context Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 1) +instance (GH.HasVariant "accept" GH.Slot Disembargo'context ()) where + variantByLabel = (GH.Variant GH.voidField 2) +instance (GH.HasVariant "provide" GH.Slot Disembargo'context Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 3) +data instance C.Parsed (GH.Which Disembargo'context) + = Disembargo'context'senderLoopback (RP.Parsed Std_.Word32) + | Disembargo'context'receiverLoopback (RP.Parsed Std_.Word32) + | Disembargo'context'accept + | Disembargo'context'provide (RP.Parsed Std_.Word32) + | Disembargo'context'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Disembargo'context))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Disembargo'context))) +instance (C.Parse (GH.Which Disembargo'context) (C.Parsed (GH.Which Disembargo'context))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Disembargo'context'senderLoopback rawArg_) -> + (Disembargo'context'senderLoopback <$> (C.parse rawArg_)) + (RW_Disembargo'context'receiverLoopback rawArg_) -> + (Disembargo'context'receiverLoopback <$> (C.parse rawArg_)) + (RW_Disembargo'context'accept _) -> + (Std_.pure Disembargo'context'accept) + (RW_Disembargo'context'provide rawArg_) -> + (Disembargo'context'provide <$> (C.parse rawArg_)) + (RW_Disembargo'context'unknown' tag_) -> + (Std_.pure (Disembargo'context'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Disembargo'context) (C.Parsed (GH.Which Disembargo'context))) where + marshalInto raw_ parsed_ = case parsed_ of + (Disembargo'context'senderLoopback arg_) -> + (GH.encodeVariant #senderLoopback arg_ (GH.unionStruct raw_)) + (Disembargo'context'receiverLoopback arg_) -> + (GH.encodeVariant #receiverLoopback arg_ (GH.unionStruct raw_)) + (Disembargo'context'accept) -> + (GH.encodeVariant #accept () (GH.unionStruct raw_)) + (Disembargo'context'provide arg_) -> + (GH.encodeVariant #provide arg_ (GH.unionStruct raw_)) + (Disembargo'context'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Provide +type instance (R.ReprFor Provide) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Provide) where + typeId = 11270825879279873114 +instance (C.TypedStruct Provide) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate Provide) where + type AllocHint Provide = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Provide (C.Parsed Provide)) +instance (C.AllocateList Provide) where + type ListAllocHint Provide = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Provide (C.Parsed Provide)) +data instance C.Parsed Provide + = Provide + {questionId :: (RP.Parsed Std_.Word32) + ,target :: (RP.Parsed MessageTarget) + ,recipient :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Provide)) +deriving instance (Std_.Eq (C.Parsed Provide)) +instance (C.Parse Provide (C.Parsed Provide)) where + parse raw_ = (Provide <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #target raw_) + <*> (GH.parseField #recipient raw_)) +instance (C.Marshal Provide (C.Parsed Provide)) where + marshalInto raw_ Provide{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #target target raw_) + (GH.encodeField #recipient recipient raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot Provide Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "target" GH.Slot Provide MessageTarget) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "recipient" GH.Slot Provide (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 1) +data Accept +type instance (R.ReprFor Accept) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Accept) where + typeId = 15332985841292492822 +instance (C.TypedStruct Accept) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Accept) where + type AllocHint Accept = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Accept (C.Parsed Accept)) +instance (C.AllocateList Accept) where + type ListAllocHint Accept = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Accept (C.Parsed Accept)) +data instance C.Parsed Accept + = Accept + {questionId :: (RP.Parsed Std_.Word32) + ,provision :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + ,embargo :: (RP.Parsed Std_.Bool)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Accept)) +deriving instance (Std_.Eq (C.Parsed Accept)) +instance (C.Parse Accept (C.Parsed Accept)) where + parse raw_ = (Accept <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #provision raw_) + <*> (GH.parseField #embargo raw_)) +instance (C.Marshal Accept (C.Parsed Accept)) where + marshalInto raw_ Accept{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #provision provision raw_) + (GH.encodeField #embargo embargo raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot Accept Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "provision" GH.Slot Accept (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "embargo" GH.Slot Accept Std_.Bool) where + fieldByLabel = (GH.dataField 32 0 1 0) +data Join +type instance (R.ReprFor Join) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Join) where + typeId = 18149955118657700271 +instance (C.TypedStruct Join) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate Join) where + type AllocHint Join = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Join (C.Parsed Join)) +instance (C.AllocateList Join) where + type ListAllocHint Join = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Join (C.Parsed Join)) +data instance C.Parsed Join + = Join + {questionId :: (RP.Parsed Std_.Word32) + ,target :: (RP.Parsed MessageTarget) + ,keyPart :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Join)) +deriving instance (Std_.Eq (C.Parsed Join)) +instance (C.Parse Join (C.Parsed Join)) where + parse raw_ = (Join <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #target raw_) + <*> (GH.parseField #keyPart raw_)) +instance (C.Marshal Join (C.Parsed Join)) where + marshalInto raw_ Join{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #target target raw_) + (GH.encodeField #keyPart keyPart raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot Join Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "target" GH.Slot Join MessageTarget) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "keyPart" GH.Slot Join (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 1) +data MessageTarget +type instance (R.ReprFor MessageTarget) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId MessageTarget) where + typeId = 10789521159760378817 +instance (C.TypedStruct MessageTarget) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate MessageTarget) where + type AllocHint MessageTarget = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc MessageTarget (C.Parsed MessageTarget)) +instance (C.AllocateList MessageTarget) where + type ListAllocHint MessageTarget = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc MessageTarget (C.Parsed MessageTarget)) +data instance C.Parsed MessageTarget + = MessageTarget + {union' :: (C.Parsed (GH.Which MessageTarget))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed MessageTarget)) +deriving instance (Std_.Eq (C.Parsed MessageTarget)) +instance (C.Parse MessageTarget (C.Parsed MessageTarget)) where + parse raw_ = (MessageTarget <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal MessageTarget (C.Parsed MessageTarget)) where + marshalInto raw_ MessageTarget{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion MessageTarget) where + unionField = (GH.dataField 32 0 16 0) + data RawWhich MessageTarget mut_ + = RW_MessageTarget'importedCap (R.Raw Std_.Word32 mut_) + | RW_MessageTarget'promisedAnswer (R.Raw PromisedAnswer mut_) + | RW_MessageTarget'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_MessageTarget'importedCap <$> (GH.readVariant #importedCap struct_)) + 1 -> + (RW_MessageTarget'promisedAnswer <$> (GH.readVariant #promisedAnswer struct_)) + _ -> + (Std_.pure (RW_MessageTarget'unknown' tag_)) + data Which MessageTarget +instance (GH.HasVariant "importedCap" GH.Slot MessageTarget Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 0) +instance (GH.HasVariant "promisedAnswer" GH.Slot MessageTarget PromisedAnswer) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +data instance C.Parsed (GH.Which MessageTarget) + = MessageTarget'importedCap (RP.Parsed Std_.Word32) + | MessageTarget'promisedAnswer (RP.Parsed PromisedAnswer) + | MessageTarget'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which MessageTarget))) +deriving instance (Std_.Eq (C.Parsed (GH.Which MessageTarget))) +instance (C.Parse (GH.Which MessageTarget) (C.Parsed (GH.Which MessageTarget))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_MessageTarget'importedCap rawArg_) -> + (MessageTarget'importedCap <$> (C.parse rawArg_)) + (RW_MessageTarget'promisedAnswer rawArg_) -> + (MessageTarget'promisedAnswer <$> (C.parse rawArg_)) + (RW_MessageTarget'unknown' tag_) -> + (Std_.pure (MessageTarget'unknown' tag_)) + ) +instance (C.Marshal (GH.Which MessageTarget) (C.Parsed (GH.Which MessageTarget))) where + marshalInto raw_ parsed_ = case parsed_ of + (MessageTarget'importedCap arg_) -> + (GH.encodeVariant #importedCap arg_ (GH.unionStruct raw_)) + (MessageTarget'promisedAnswer arg_) -> + (GH.encodeVariant #promisedAnswer arg_ (GH.unionStruct raw_)) + (MessageTarget'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Payload +type instance (R.ReprFor Payload) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Payload) where + typeId = 11100916931204903995 +instance (C.TypedStruct Payload) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate Payload) where + type AllocHint Payload = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Payload (C.Parsed Payload)) +instance (C.AllocateList Payload) where + type ListAllocHint Payload = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Payload (C.Parsed Payload)) +data instance C.Parsed Payload + = Payload + {content :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + ,capTable :: (RP.Parsed (R.List CapDescriptor))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Payload)) +deriving instance (Std_.Eq (C.Parsed Payload)) +instance (C.Parse Payload (C.Parsed Payload)) where + parse raw_ = (Payload <$> (GH.parseField #content raw_) + <*> (GH.parseField #capTable raw_)) +instance (C.Marshal Payload (C.Parsed Payload)) where + marshalInto raw_ Payload{..} = (do + (GH.encodeField #content content raw_) + (GH.encodeField #capTable capTable raw_) + (Std_.pure ()) + ) +instance (GH.HasField "content" GH.Slot Payload (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "capTable" GH.Slot Payload (R.List CapDescriptor)) where + fieldByLabel = (GH.ptrField 1) +data CapDescriptor +type instance (R.ReprFor CapDescriptor) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CapDescriptor) where + typeId = 9593755465305995440 +instance (C.TypedStruct CapDescriptor) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate CapDescriptor) where + type AllocHint CapDescriptor = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CapDescriptor (C.Parsed CapDescriptor)) +instance (C.AllocateList CapDescriptor) where + type ListAllocHint CapDescriptor = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CapDescriptor (C.Parsed CapDescriptor)) +data instance C.Parsed CapDescriptor + = CapDescriptor + {attachedFd :: (RP.Parsed Std_.Word8) + ,union' :: (C.Parsed (GH.Which CapDescriptor))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CapDescriptor)) +deriving instance (Std_.Eq (C.Parsed CapDescriptor)) +instance (C.Parse CapDescriptor (C.Parsed CapDescriptor)) where + parse raw_ = (CapDescriptor <$> (GH.parseField #attachedFd raw_) + <*> (C.parse (GH.structUnion raw_))) +instance (C.Marshal CapDescriptor (C.Parsed CapDescriptor)) where + marshalInto raw_ CapDescriptor{..} = (do + (GH.encodeField #attachedFd attachedFd raw_) + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion CapDescriptor) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich CapDescriptor mut_ + = RW_CapDescriptor'none (R.Raw () mut_) + | RW_CapDescriptor'senderHosted (R.Raw Std_.Word32 mut_) + | RW_CapDescriptor'senderPromise (R.Raw Std_.Word32 mut_) + | RW_CapDescriptor'receiverHosted (R.Raw Std_.Word32 mut_) + | RW_CapDescriptor'receiverAnswer (R.Raw PromisedAnswer mut_) + | RW_CapDescriptor'thirdPartyHosted (R.Raw ThirdPartyCapDescriptor mut_) + | RW_CapDescriptor'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_CapDescriptor'none <$> (GH.readVariant #none struct_)) + 1 -> + (RW_CapDescriptor'senderHosted <$> (GH.readVariant #senderHosted struct_)) + 2 -> + (RW_CapDescriptor'senderPromise <$> (GH.readVariant #senderPromise struct_)) + 3 -> + (RW_CapDescriptor'receiverHosted <$> (GH.readVariant #receiverHosted struct_)) + 4 -> + (RW_CapDescriptor'receiverAnswer <$> (GH.readVariant #receiverAnswer struct_)) + 5 -> + (RW_CapDescriptor'thirdPartyHosted <$> (GH.readVariant #thirdPartyHosted struct_)) + _ -> + (Std_.pure (RW_CapDescriptor'unknown' tag_)) + data Which CapDescriptor +instance (GH.HasVariant "none" GH.Slot CapDescriptor ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "senderHosted" GH.Slot CapDescriptor Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 1) +instance (GH.HasVariant "senderPromise" GH.Slot CapDescriptor Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 2) +instance (GH.HasVariant "receiverHosted" GH.Slot CapDescriptor Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 3) +instance (GH.HasVariant "receiverAnswer" GH.Slot CapDescriptor PromisedAnswer) where + variantByLabel = (GH.Variant (GH.ptrField 0) 4) +instance (GH.HasVariant "thirdPartyHosted" GH.Slot CapDescriptor ThirdPartyCapDescriptor) where + variantByLabel = (GH.Variant (GH.ptrField 0) 5) +data instance C.Parsed (GH.Which CapDescriptor) + = CapDescriptor'none + | CapDescriptor'senderHosted (RP.Parsed Std_.Word32) + | CapDescriptor'senderPromise (RP.Parsed Std_.Word32) + | CapDescriptor'receiverHosted (RP.Parsed Std_.Word32) + | CapDescriptor'receiverAnswer (RP.Parsed PromisedAnswer) + | CapDescriptor'thirdPartyHosted (RP.Parsed ThirdPartyCapDescriptor) + | CapDescriptor'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which CapDescriptor))) +deriving instance (Std_.Eq (C.Parsed (GH.Which CapDescriptor))) +instance (C.Parse (GH.Which CapDescriptor) (C.Parsed (GH.Which CapDescriptor))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_CapDescriptor'none _) -> + (Std_.pure CapDescriptor'none) + (RW_CapDescriptor'senderHosted rawArg_) -> + (CapDescriptor'senderHosted <$> (C.parse rawArg_)) + (RW_CapDescriptor'senderPromise rawArg_) -> + (CapDescriptor'senderPromise <$> (C.parse rawArg_)) + (RW_CapDescriptor'receiverHosted rawArg_) -> + (CapDescriptor'receiverHosted <$> (C.parse rawArg_)) + (RW_CapDescriptor'receiverAnswer rawArg_) -> + (CapDescriptor'receiverAnswer <$> (C.parse rawArg_)) + (RW_CapDescriptor'thirdPartyHosted rawArg_) -> + (CapDescriptor'thirdPartyHosted <$> (C.parse rawArg_)) + (RW_CapDescriptor'unknown' tag_) -> + (Std_.pure (CapDescriptor'unknown' tag_)) + ) +instance (C.Marshal (GH.Which CapDescriptor) (C.Parsed (GH.Which CapDescriptor))) where + marshalInto raw_ parsed_ = case parsed_ of + (CapDescriptor'none) -> + (GH.encodeVariant #none () (GH.unionStruct raw_)) + (CapDescriptor'senderHosted arg_) -> + (GH.encodeVariant #senderHosted arg_ (GH.unionStruct raw_)) + (CapDescriptor'senderPromise arg_) -> + (GH.encodeVariant #senderPromise arg_ (GH.unionStruct raw_)) + (CapDescriptor'receiverHosted arg_) -> + (GH.encodeVariant #receiverHosted arg_ (GH.unionStruct raw_)) + (CapDescriptor'receiverAnswer arg_) -> + (GH.encodeVariant #receiverAnswer arg_ (GH.unionStruct raw_)) + (CapDescriptor'thirdPartyHosted arg_) -> + (GH.encodeVariant #thirdPartyHosted arg_ (GH.unionStruct raw_)) + (CapDescriptor'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +instance (GH.HasField "attachedFd" GH.Slot CapDescriptor Std_.Word8) where + fieldByLabel = (GH.dataField 16 0 8 255) +data PromisedAnswer +type instance (R.ReprFor PromisedAnswer) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId PromisedAnswer) where + typeId = 15564635848320162976 +instance (C.TypedStruct PromisedAnswer) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate PromisedAnswer) where + type AllocHint PromisedAnswer = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc PromisedAnswer (C.Parsed PromisedAnswer)) +instance (C.AllocateList PromisedAnswer) where + type ListAllocHint PromisedAnswer = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc PromisedAnswer (C.Parsed PromisedAnswer)) +data instance C.Parsed PromisedAnswer + = PromisedAnswer + {questionId :: (RP.Parsed Std_.Word32) + ,transform :: (RP.Parsed (R.List PromisedAnswer'Op))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed PromisedAnswer)) +deriving instance (Std_.Eq (C.Parsed PromisedAnswer)) +instance (C.Parse PromisedAnswer (C.Parsed PromisedAnswer)) where + parse raw_ = (PromisedAnswer <$> (GH.parseField #questionId raw_) + <*> (GH.parseField #transform raw_)) +instance (C.Marshal PromisedAnswer (C.Parsed PromisedAnswer)) where + marshalInto raw_ PromisedAnswer{..} = (do + (GH.encodeField #questionId questionId raw_) + (GH.encodeField #transform transform raw_) + (Std_.pure ()) + ) +instance (GH.HasField "questionId" GH.Slot PromisedAnswer Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "transform" GH.Slot PromisedAnswer (R.List PromisedAnswer'Op)) where + fieldByLabel = (GH.ptrField 0) +data PromisedAnswer'Op +type instance (R.ReprFor PromisedAnswer'Op) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId PromisedAnswer'Op) where + typeId = 17516350820840804481 +instance (C.TypedStruct PromisedAnswer'Op) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate PromisedAnswer'Op) where + type AllocHint PromisedAnswer'Op = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) +instance (C.AllocateList PromisedAnswer'Op) where + type ListAllocHint PromisedAnswer'Op = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) +data instance C.Parsed PromisedAnswer'Op + = PromisedAnswer'Op + {union' :: (C.Parsed (GH.Which PromisedAnswer'Op))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed PromisedAnswer'Op)) +deriving instance (Std_.Eq (C.Parsed PromisedAnswer'Op)) +instance (C.Parse PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) where + parse raw_ = (PromisedAnswer'Op <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) where + marshalInto raw_ PromisedAnswer'Op{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion PromisedAnswer'Op) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich PromisedAnswer'Op mut_ + = RW_PromisedAnswer'Op'noop (R.Raw () mut_) + | RW_PromisedAnswer'Op'getPointerField (R.Raw Std_.Word16 mut_) + | RW_PromisedAnswer'Op'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_PromisedAnswer'Op'noop <$> (GH.readVariant #noop struct_)) + 1 -> + (RW_PromisedAnswer'Op'getPointerField <$> (GH.readVariant #getPointerField struct_)) + _ -> + (Std_.pure (RW_PromisedAnswer'Op'unknown' tag_)) + data Which PromisedAnswer'Op +instance (GH.HasVariant "noop" GH.Slot PromisedAnswer'Op ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "getPointerField" GH.Slot PromisedAnswer'Op Std_.Word16) where + variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 1) +data instance C.Parsed (GH.Which PromisedAnswer'Op) + = PromisedAnswer'Op'noop + | PromisedAnswer'Op'getPointerField (RP.Parsed Std_.Word16) + | PromisedAnswer'Op'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which PromisedAnswer'Op))) +deriving instance (Std_.Eq (C.Parsed (GH.Which PromisedAnswer'Op))) +instance (C.Parse (GH.Which PromisedAnswer'Op) (C.Parsed (GH.Which PromisedAnswer'Op))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_PromisedAnswer'Op'noop _) -> + (Std_.pure PromisedAnswer'Op'noop) + (RW_PromisedAnswer'Op'getPointerField rawArg_) -> + (PromisedAnswer'Op'getPointerField <$> (C.parse rawArg_)) + (RW_PromisedAnswer'Op'unknown' tag_) -> + (Std_.pure (PromisedAnswer'Op'unknown' tag_)) + ) +instance (C.Marshal (GH.Which PromisedAnswer'Op) (C.Parsed (GH.Which PromisedAnswer'Op))) where + marshalInto raw_ parsed_ = case parsed_ of + (PromisedAnswer'Op'noop) -> + (GH.encodeVariant #noop () (GH.unionStruct raw_)) + (PromisedAnswer'Op'getPointerField arg_) -> + (GH.encodeVariant #getPointerField arg_ (GH.unionStruct raw_)) + (PromisedAnswer'Op'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data ThirdPartyCapDescriptor +type instance (R.ReprFor ThirdPartyCapDescriptor) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ThirdPartyCapDescriptor) where + typeId = 15235686326393111165 +instance (C.TypedStruct ThirdPartyCapDescriptor) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate ThirdPartyCapDescriptor) where + type AllocHint ThirdPartyCapDescriptor = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) +instance (C.AllocateList ThirdPartyCapDescriptor) where + type ListAllocHint ThirdPartyCapDescriptor = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) +data instance C.Parsed ThirdPartyCapDescriptor + = ThirdPartyCapDescriptor + {id :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + ,vineId :: (RP.Parsed Std_.Word32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed ThirdPartyCapDescriptor)) +deriving instance (Std_.Eq (C.Parsed ThirdPartyCapDescriptor)) +instance (C.Parse ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) where + parse raw_ = (ThirdPartyCapDescriptor <$> (GH.parseField #id raw_) + <*> (GH.parseField #vineId raw_)) +instance (C.Marshal ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) where + marshalInto raw_ ThirdPartyCapDescriptor{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #vineId vineId raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot ThirdPartyCapDescriptor (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "vineId" GH.Slot ThirdPartyCapDescriptor Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +data Exception +type instance (R.ReprFor Exception) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Exception) where + typeId = 15430940935639230746 +instance (C.TypedStruct Exception) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Exception) where + type AllocHint Exception = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Exception (C.Parsed Exception)) +instance (C.AllocateList Exception) where + type ListAllocHint Exception = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Exception (C.Parsed Exception)) +data instance C.Parsed Exception + = Exception + {reason :: (RP.Parsed Basics.Text) + ,obsoleteIsCallersFault :: (RP.Parsed Std_.Bool) + ,obsoleteDurability :: (RP.Parsed Std_.Word16) + ,type_ :: (RP.Parsed Exception'Type)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Exception)) +deriving instance (Std_.Eq (C.Parsed Exception)) +instance (C.Parse Exception (C.Parsed Exception)) where + parse raw_ = (Exception <$> (GH.parseField #reason raw_) + <*> (GH.parseField #obsoleteIsCallersFault raw_) + <*> (GH.parseField #obsoleteDurability raw_) + <*> (GH.parseField #type_ raw_)) +instance (C.Marshal Exception (C.Parsed Exception)) where + marshalInto raw_ Exception{..} = (do + (GH.encodeField #reason reason raw_) + (GH.encodeField #obsoleteIsCallersFault obsoleteIsCallersFault raw_) + (GH.encodeField #obsoleteDurability obsoleteDurability raw_) + (GH.encodeField #type_ type_ raw_) + (Std_.pure ()) + ) +instance (GH.HasField "reason" GH.Slot Exception Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "obsoleteIsCallersFault" GH.Slot Exception Std_.Bool) where + fieldByLabel = (GH.dataField 0 0 1 0) +instance (GH.HasField "obsoleteDurability" GH.Slot Exception Std_.Word16) where + fieldByLabel = (GH.dataField 16 0 16 0) +instance (GH.HasField "type_" GH.Slot Exception Exception'Type) where + fieldByLabel = (GH.dataField 32 0 16 0) +data Exception'Type + = Exception'Type'failed + | Exception'Type'overloaded + | Exception'Type'disconnected + | Exception'Type'unimplemented + | Exception'Type'unknown' Std_.Word16 + deriving(Std_.Eq + ,Std_.Show + ,Generics.Generic) +type instance (R.ReprFor Exception'Type) = (R.Data R.Sz16) +instance (C.HasTypeId Exception'Type) where + typeId = 12865824133959433560 +instance (Std_.Enum Exception'Type) where + toEnum n_ = case n_ of + 0 -> + Exception'Type'failed + 1 -> + Exception'Type'overloaded + 2 -> + Exception'Type'disconnected + 3 -> + Exception'Type'unimplemented + tag_ -> + (Exception'Type'unknown' (Std_.fromIntegral tag_)) + fromEnum value_ = case value_ of + (Exception'Type'failed) -> + 0 + (Exception'Type'overloaded) -> + 1 + (Exception'Type'disconnected) -> + 2 + (Exception'Type'unimplemented) -> + 3 + (Exception'Type'unknown' tag_) -> + (Std_.fromIntegral tag_) +instance (C.IsWord Exception'Type) where + fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) + toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) +instance (C.Parse Exception'Type Exception'Type) where + parse = GH.parseEnum + encode = GH.encodeEnum +instance (C.AllocateList Exception'Type) where + type ListAllocHint Exception'Type = Std_.Int +instance (C.EstimateListAlloc Exception'Type Exception'Type) diff --git a/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs b/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs +++ /dev/null @@ -1,1372 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.Rpc.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Message -type instance (R.ReprFor Message) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Message) where - typeId = 10500036013887172658 -instance (C.TypedStruct Message) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Message) where - type AllocHint Message = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Message (C.Parsed Message)) -instance (C.AllocateList Message) where - type ListAllocHint Message = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Message (C.Parsed Message)) -data instance C.Parsed Message - = Message - {union' :: (C.Parsed (GH.Which Message))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Message)) -deriving instance (Std_.Eq (C.Parsed Message)) -instance (C.Parse Message (C.Parsed Message)) where - parse raw_ = (Message <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Message (C.Parsed Message)) where - marshalInto raw_ Message{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Message) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Message mut_ - = RW_Message'unimplemented (R.Raw Message mut_) - | RW_Message'abort (R.Raw Exception mut_) - | RW_Message'call (R.Raw Call mut_) - | RW_Message'return (R.Raw Return mut_) - | RW_Message'finish (R.Raw Finish mut_) - | RW_Message'resolve (R.Raw Resolve mut_) - | RW_Message'release (R.Raw Release mut_) - | RW_Message'obsoleteSave (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Message'bootstrap (R.Raw Bootstrap mut_) - | RW_Message'obsoleteDelete (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Message'provide (R.Raw Provide mut_) - | RW_Message'accept (R.Raw Accept mut_) - | RW_Message'join (R.Raw Join mut_) - | RW_Message'disembargo (R.Raw Disembargo mut_) - | RW_Message'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Message'unimplemented <$> (GH.readVariant #unimplemented struct_)) - 1 -> - (RW_Message'abort <$> (GH.readVariant #abort struct_)) - 2 -> - (RW_Message'call <$> (GH.readVariant #call struct_)) - 3 -> - (RW_Message'return <$> (GH.readVariant #return struct_)) - 4 -> - (RW_Message'finish <$> (GH.readVariant #finish struct_)) - 5 -> - (RW_Message'resolve <$> (GH.readVariant #resolve struct_)) - 6 -> - (RW_Message'release <$> (GH.readVariant #release struct_)) - 7 -> - (RW_Message'obsoleteSave <$> (GH.readVariant #obsoleteSave struct_)) - 8 -> - (RW_Message'bootstrap <$> (GH.readVariant #bootstrap struct_)) - 9 -> - (RW_Message'obsoleteDelete <$> (GH.readVariant #obsoleteDelete struct_)) - 10 -> - (RW_Message'provide <$> (GH.readVariant #provide struct_)) - 11 -> - (RW_Message'accept <$> (GH.readVariant #accept struct_)) - 12 -> - (RW_Message'join <$> (GH.readVariant #join struct_)) - 13 -> - (RW_Message'disembargo <$> (GH.readVariant #disembargo struct_)) - _ -> - (Std_.pure (RW_Message'unknown' tag_)) - data Which Message -instance (GH.HasVariant "unimplemented" GH.Slot Message Message) where - variantByLabel = (GH.Variant (GH.ptrField 0) 0) -instance (GH.HasVariant "abort" GH.Slot Message Exception) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -instance (GH.HasVariant "call" GH.Slot Message Call) where - variantByLabel = (GH.Variant (GH.ptrField 0) 2) -instance (GH.HasVariant "return" GH.Slot Message Return) where - variantByLabel = (GH.Variant (GH.ptrField 0) 3) -instance (GH.HasVariant "finish" GH.Slot Message Finish) where - variantByLabel = (GH.Variant (GH.ptrField 0) 4) -instance (GH.HasVariant "resolve" GH.Slot Message Resolve) where - variantByLabel = (GH.Variant (GH.ptrField 0) 5) -instance (GH.HasVariant "release" GH.Slot Message Release) where - variantByLabel = (GH.Variant (GH.ptrField 0) 6) -instance (GH.HasVariant "obsoleteSave" GH.Slot Message (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 7) -instance (GH.HasVariant "bootstrap" GH.Slot Message Bootstrap) where - variantByLabel = (GH.Variant (GH.ptrField 0) 8) -instance (GH.HasVariant "obsoleteDelete" GH.Slot Message (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 9) -instance (GH.HasVariant "provide" GH.Slot Message Provide) where - variantByLabel = (GH.Variant (GH.ptrField 0) 10) -instance (GH.HasVariant "accept" GH.Slot Message Accept) where - variantByLabel = (GH.Variant (GH.ptrField 0) 11) -instance (GH.HasVariant "join" GH.Slot Message Join) where - variantByLabel = (GH.Variant (GH.ptrField 0) 12) -instance (GH.HasVariant "disembargo" GH.Slot Message Disembargo) where - variantByLabel = (GH.Variant (GH.ptrField 0) 13) -data instance C.Parsed (GH.Which Message) - = Message'unimplemented (RP.Parsed Message) - | Message'abort (RP.Parsed Exception) - | Message'call (RP.Parsed Call) - | Message'return (RP.Parsed Return) - | Message'finish (RP.Parsed Finish) - | Message'resolve (RP.Parsed Resolve) - | Message'release (RP.Parsed Release) - | Message'obsoleteSave (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Message'bootstrap (RP.Parsed Bootstrap) - | Message'obsoleteDelete (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Message'provide (RP.Parsed Provide) - | Message'accept (RP.Parsed Accept) - | Message'join (RP.Parsed Join) - | Message'disembargo (RP.Parsed Disembargo) - | Message'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Message))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Message))) -instance (C.Parse (GH.Which Message) (C.Parsed (GH.Which Message))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Message'unimplemented rawArg_) -> - (Message'unimplemented <$> (C.parse rawArg_)) - (RW_Message'abort rawArg_) -> - (Message'abort <$> (C.parse rawArg_)) - (RW_Message'call rawArg_) -> - (Message'call <$> (C.parse rawArg_)) - (RW_Message'return rawArg_) -> - (Message'return <$> (C.parse rawArg_)) - (RW_Message'finish rawArg_) -> - (Message'finish <$> (C.parse rawArg_)) - (RW_Message'resolve rawArg_) -> - (Message'resolve <$> (C.parse rawArg_)) - (RW_Message'release rawArg_) -> - (Message'release <$> (C.parse rawArg_)) - (RW_Message'obsoleteSave rawArg_) -> - (Message'obsoleteSave <$> (C.parse rawArg_)) - (RW_Message'bootstrap rawArg_) -> - (Message'bootstrap <$> (C.parse rawArg_)) - (RW_Message'obsoleteDelete rawArg_) -> - (Message'obsoleteDelete <$> (C.parse rawArg_)) - (RW_Message'provide rawArg_) -> - (Message'provide <$> (C.parse rawArg_)) - (RW_Message'accept rawArg_) -> - (Message'accept <$> (C.parse rawArg_)) - (RW_Message'join rawArg_) -> - (Message'join <$> (C.parse rawArg_)) - (RW_Message'disembargo rawArg_) -> - (Message'disembargo <$> (C.parse rawArg_)) - (RW_Message'unknown' tag_) -> - (Std_.pure (Message'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Message) (C.Parsed (GH.Which Message))) where - marshalInto raw_ parsed_ = case parsed_ of - (Message'unimplemented arg_) -> - (GH.encodeVariant #unimplemented arg_ (GH.unionStruct raw_)) - (Message'abort arg_) -> - (GH.encodeVariant #abort arg_ (GH.unionStruct raw_)) - (Message'call arg_) -> - (GH.encodeVariant #call arg_ (GH.unionStruct raw_)) - (Message'return arg_) -> - (GH.encodeVariant #return arg_ (GH.unionStruct raw_)) - (Message'finish arg_) -> - (GH.encodeVariant #finish arg_ (GH.unionStruct raw_)) - (Message'resolve arg_) -> - (GH.encodeVariant #resolve arg_ (GH.unionStruct raw_)) - (Message'release arg_) -> - (GH.encodeVariant #release arg_ (GH.unionStruct raw_)) - (Message'obsoleteSave arg_) -> - (GH.encodeVariant #obsoleteSave arg_ (GH.unionStruct raw_)) - (Message'bootstrap arg_) -> - (GH.encodeVariant #bootstrap arg_ (GH.unionStruct raw_)) - (Message'obsoleteDelete arg_) -> - (GH.encodeVariant #obsoleteDelete arg_ (GH.unionStruct raw_)) - (Message'provide arg_) -> - (GH.encodeVariant #provide arg_ (GH.unionStruct raw_)) - (Message'accept arg_) -> - (GH.encodeVariant #accept arg_ (GH.unionStruct raw_)) - (Message'join arg_) -> - (GH.encodeVariant #join arg_ (GH.unionStruct raw_)) - (Message'disembargo arg_) -> - (GH.encodeVariant #disembargo arg_ (GH.unionStruct raw_)) - (Message'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Bootstrap -type instance (R.ReprFor Bootstrap) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Bootstrap) where - typeId = 16811039658553601732 -instance (C.TypedStruct Bootstrap) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Bootstrap) where - type AllocHint Bootstrap = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Bootstrap (C.Parsed Bootstrap)) -instance (C.AllocateList Bootstrap) where - type ListAllocHint Bootstrap = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Bootstrap (C.Parsed Bootstrap)) -data instance C.Parsed Bootstrap - = Bootstrap - {questionId :: (RP.Parsed Std_.Word32) - ,deprecatedObjectId :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Bootstrap)) -deriving instance (Std_.Eq (C.Parsed Bootstrap)) -instance (C.Parse Bootstrap (C.Parsed Bootstrap)) where - parse raw_ = (Bootstrap <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #deprecatedObjectId raw_)) -instance (C.Marshal Bootstrap (C.Parsed Bootstrap)) where - marshalInto raw_ Bootstrap{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #deprecatedObjectId deprecatedObjectId raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot Bootstrap Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "deprecatedObjectId" GH.Slot Bootstrap (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 0) -data Call -type instance (R.ReprFor Call) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Call) where - typeId = 9469473312751832276 -instance (C.TypedStruct Call) where - numStructWords = 3 - numStructPtrs = 3 -instance (C.Allocate Call) where - type AllocHint Call = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Call (C.Parsed Call)) -instance (C.AllocateList Call) where - type ListAllocHint Call = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Call (C.Parsed Call)) -data instance C.Parsed Call - = Call - {questionId :: (RP.Parsed Std_.Word32) - ,target :: (RP.Parsed MessageTarget) - ,interfaceId :: (RP.Parsed Std_.Word64) - ,methodId :: (RP.Parsed Std_.Word16) - ,params :: (RP.Parsed Payload) - ,sendResultsTo :: (RP.Parsed Call'sendResultsTo) - ,allowThirdPartyTailCall :: (RP.Parsed Std_.Bool)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Call)) -deriving instance (Std_.Eq (C.Parsed Call)) -instance (C.Parse Call (C.Parsed Call)) where - parse raw_ = (Call <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #target raw_) - <*> (GH.parseField #interfaceId raw_) - <*> (GH.parseField #methodId raw_) - <*> (GH.parseField #params raw_) - <*> (GH.parseField #sendResultsTo raw_) - <*> (GH.parseField #allowThirdPartyTailCall raw_)) -instance (C.Marshal Call (C.Parsed Call)) where - marshalInto raw_ Call{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #target target raw_) - (GH.encodeField #interfaceId interfaceId raw_) - (GH.encodeField #methodId methodId raw_) - (GH.encodeField #params params raw_) - (do - group_ <- (GH.readField #sendResultsTo raw_) - (C.marshalInto group_ sendResultsTo) - ) - (GH.encodeField #allowThirdPartyTailCall allowThirdPartyTailCall raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot Call Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "target" GH.Slot Call MessageTarget) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "interfaceId" GH.Slot Call Std_.Word64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "methodId" GH.Slot Call Std_.Word16) where - fieldByLabel = (GH.dataField 32 0 16 0) -instance (GH.HasField "params" GH.Slot Call Payload) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "sendResultsTo" GH.Group Call Call'sendResultsTo) where - fieldByLabel = GH.groupField -instance (GH.HasField "allowThirdPartyTailCall" GH.Slot Call Std_.Bool) where - fieldByLabel = (GH.dataField 0 2 1 0) -data Call'sendResultsTo -type instance (R.ReprFor Call'sendResultsTo) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Call'sendResultsTo) where - typeId = 15774052265921044377 -instance (C.TypedStruct Call'sendResultsTo) where - numStructWords = 3 - numStructPtrs = 3 -instance (C.Allocate Call'sendResultsTo) where - type AllocHint Call'sendResultsTo = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Call'sendResultsTo (C.Parsed Call'sendResultsTo)) -instance (C.AllocateList Call'sendResultsTo) where - type ListAllocHint Call'sendResultsTo = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Call'sendResultsTo (C.Parsed Call'sendResultsTo)) -data instance C.Parsed Call'sendResultsTo - = Call'sendResultsTo' - {union' :: (C.Parsed (GH.Which Call'sendResultsTo))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Call'sendResultsTo)) -deriving instance (Std_.Eq (C.Parsed Call'sendResultsTo)) -instance (C.Parse Call'sendResultsTo (C.Parsed Call'sendResultsTo)) where - parse raw_ = (Call'sendResultsTo' <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Call'sendResultsTo (C.Parsed Call'sendResultsTo)) where - marshalInto raw_ Call'sendResultsTo'{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Call'sendResultsTo) where - unionField = (GH.dataField 48 0 16 0) - data RawWhich Call'sendResultsTo mut_ - = RW_Call'sendResultsTo'caller (R.Raw () mut_) - | RW_Call'sendResultsTo'yourself (R.Raw () mut_) - | RW_Call'sendResultsTo'thirdParty (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Call'sendResultsTo'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Call'sendResultsTo'caller <$> (GH.readVariant #caller struct_)) - 1 -> - (RW_Call'sendResultsTo'yourself <$> (GH.readVariant #yourself struct_)) - 2 -> - (RW_Call'sendResultsTo'thirdParty <$> (GH.readVariant #thirdParty struct_)) - _ -> - (Std_.pure (RW_Call'sendResultsTo'unknown' tag_)) - data Which Call'sendResultsTo -instance (GH.HasVariant "caller" GH.Slot Call'sendResultsTo ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "yourself" GH.Slot Call'sendResultsTo ()) where - variantByLabel = (GH.Variant GH.voidField 1) -instance (GH.HasVariant "thirdParty" GH.Slot Call'sendResultsTo (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 2) 2) -data instance C.Parsed (GH.Which Call'sendResultsTo) - = Call'sendResultsTo'caller - | Call'sendResultsTo'yourself - | Call'sendResultsTo'thirdParty (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Call'sendResultsTo'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Call'sendResultsTo))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Call'sendResultsTo))) -instance (C.Parse (GH.Which Call'sendResultsTo) (C.Parsed (GH.Which Call'sendResultsTo))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Call'sendResultsTo'caller _) -> - (Std_.pure Call'sendResultsTo'caller) - (RW_Call'sendResultsTo'yourself _) -> - (Std_.pure Call'sendResultsTo'yourself) - (RW_Call'sendResultsTo'thirdParty rawArg_) -> - (Call'sendResultsTo'thirdParty <$> (C.parse rawArg_)) - (RW_Call'sendResultsTo'unknown' tag_) -> - (Std_.pure (Call'sendResultsTo'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Call'sendResultsTo) (C.Parsed (GH.Which Call'sendResultsTo))) where - marshalInto raw_ parsed_ = case parsed_ of - (Call'sendResultsTo'caller) -> - (GH.encodeVariant #caller () (GH.unionStruct raw_)) - (Call'sendResultsTo'yourself) -> - (GH.encodeVariant #yourself () (GH.unionStruct raw_)) - (Call'sendResultsTo'thirdParty arg_) -> - (GH.encodeVariant #thirdParty arg_ (GH.unionStruct raw_)) - (Call'sendResultsTo'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Return -type instance (R.ReprFor Return) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Return) where - typeId = 11392333052105676602 -instance (C.TypedStruct Return) where - numStructWords = 2 - numStructPtrs = 1 -instance (C.Allocate Return) where - type AllocHint Return = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Return (C.Parsed Return)) -instance (C.AllocateList Return) where - type ListAllocHint Return = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Return (C.Parsed Return)) -data instance C.Parsed Return - = Return - {answerId :: (RP.Parsed Std_.Word32) - ,releaseParamCaps :: (RP.Parsed Std_.Bool) - ,union' :: (C.Parsed (GH.Which Return))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Return)) -deriving instance (Std_.Eq (C.Parsed Return)) -instance (C.Parse Return (C.Parsed Return)) where - parse raw_ = (Return <$> (GH.parseField #answerId raw_) - <*> (GH.parseField #releaseParamCaps raw_) - <*> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Return (C.Parsed Return)) where - marshalInto raw_ Return{..} = (do - (GH.encodeField #answerId answerId raw_) - (GH.encodeField #releaseParamCaps releaseParamCaps raw_) - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Return) where - unionField = (GH.dataField 48 0 16 0) - data RawWhich Return mut_ - = RW_Return'results (R.Raw Payload mut_) - | RW_Return'exception (R.Raw Exception mut_) - | RW_Return'canceled (R.Raw () mut_) - | RW_Return'resultsSentElsewhere (R.Raw () mut_) - | RW_Return'takeFromOtherQuestion (R.Raw Std_.Word32 mut_) - | RW_Return'acceptFromThirdParty (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Return'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Return'results <$> (GH.readVariant #results struct_)) - 1 -> - (RW_Return'exception <$> (GH.readVariant #exception struct_)) - 2 -> - (RW_Return'canceled <$> (GH.readVariant #canceled struct_)) - 3 -> - (RW_Return'resultsSentElsewhere <$> (GH.readVariant #resultsSentElsewhere struct_)) - 4 -> - (RW_Return'takeFromOtherQuestion <$> (GH.readVariant #takeFromOtherQuestion struct_)) - 5 -> - (RW_Return'acceptFromThirdParty <$> (GH.readVariant #acceptFromThirdParty struct_)) - _ -> - (Std_.pure (RW_Return'unknown' tag_)) - data Which Return -instance (GH.HasVariant "results" GH.Slot Return Payload) where - variantByLabel = (GH.Variant (GH.ptrField 0) 0) -instance (GH.HasVariant "exception" GH.Slot Return Exception) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -instance (GH.HasVariant "canceled" GH.Slot Return ()) where - variantByLabel = (GH.Variant GH.voidField 2) -instance (GH.HasVariant "resultsSentElsewhere" GH.Slot Return ()) where - variantByLabel = (GH.Variant GH.voidField 3) -instance (GH.HasVariant "takeFromOtherQuestion" GH.Slot Return Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 4) -instance (GH.HasVariant "acceptFromThirdParty" GH.Slot Return (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 5) -data instance C.Parsed (GH.Which Return) - = Return'results (RP.Parsed Payload) - | Return'exception (RP.Parsed Exception) - | Return'canceled - | Return'resultsSentElsewhere - | Return'takeFromOtherQuestion (RP.Parsed Std_.Word32) - | Return'acceptFromThirdParty (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Return'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Return))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Return))) -instance (C.Parse (GH.Which Return) (C.Parsed (GH.Which Return))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Return'results rawArg_) -> - (Return'results <$> (C.parse rawArg_)) - (RW_Return'exception rawArg_) -> - (Return'exception <$> (C.parse rawArg_)) - (RW_Return'canceled _) -> - (Std_.pure Return'canceled) - (RW_Return'resultsSentElsewhere _) -> - (Std_.pure Return'resultsSentElsewhere) - (RW_Return'takeFromOtherQuestion rawArg_) -> - (Return'takeFromOtherQuestion <$> (C.parse rawArg_)) - (RW_Return'acceptFromThirdParty rawArg_) -> - (Return'acceptFromThirdParty <$> (C.parse rawArg_)) - (RW_Return'unknown' tag_) -> - (Std_.pure (Return'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Return) (C.Parsed (GH.Which Return))) where - marshalInto raw_ parsed_ = case parsed_ of - (Return'results arg_) -> - (GH.encodeVariant #results arg_ (GH.unionStruct raw_)) - (Return'exception arg_) -> - (GH.encodeVariant #exception arg_ (GH.unionStruct raw_)) - (Return'canceled) -> - (GH.encodeVariant #canceled () (GH.unionStruct raw_)) - (Return'resultsSentElsewhere) -> - (GH.encodeVariant #resultsSentElsewhere () (GH.unionStruct raw_)) - (Return'takeFromOtherQuestion arg_) -> - (GH.encodeVariant #takeFromOtherQuestion arg_ (GH.unionStruct raw_)) - (Return'acceptFromThirdParty arg_) -> - (GH.encodeVariant #acceptFromThirdParty arg_ (GH.unionStruct raw_)) - (Return'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -instance (GH.HasField "answerId" GH.Slot Return Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "releaseParamCaps" GH.Slot Return Std_.Bool) where - fieldByLabel = (GH.dataField 32 0 1 1) -data Finish -type instance (R.ReprFor Finish) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Finish) where - typeId = 15239388059401719395 -instance (C.TypedStruct Finish) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate Finish) where - type AllocHint Finish = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Finish (C.Parsed Finish)) -instance (C.AllocateList Finish) where - type ListAllocHint Finish = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Finish (C.Parsed Finish)) -data instance C.Parsed Finish - = Finish - {questionId :: (RP.Parsed Std_.Word32) - ,releaseResultCaps :: (RP.Parsed Std_.Bool)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Finish)) -deriving instance (Std_.Eq (C.Parsed Finish)) -instance (C.Parse Finish (C.Parsed Finish)) where - parse raw_ = (Finish <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #releaseResultCaps raw_)) -instance (C.Marshal Finish (C.Parsed Finish)) where - marshalInto raw_ Finish{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #releaseResultCaps releaseResultCaps raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot Finish Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "releaseResultCaps" GH.Slot Finish Std_.Bool) where - fieldByLabel = (GH.dataField 32 0 1 1) -data Resolve -type instance (R.ReprFor Resolve) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Resolve) where - typeId = 13529541526594062446 -instance (C.TypedStruct Resolve) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Resolve) where - type AllocHint Resolve = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Resolve (C.Parsed Resolve)) -instance (C.AllocateList Resolve) where - type ListAllocHint Resolve = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Resolve (C.Parsed Resolve)) -data instance C.Parsed Resolve - = Resolve - {promiseId :: (RP.Parsed Std_.Word32) - ,union' :: (C.Parsed (GH.Which Resolve))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Resolve)) -deriving instance (Std_.Eq (C.Parsed Resolve)) -instance (C.Parse Resolve (C.Parsed Resolve)) where - parse raw_ = (Resolve <$> (GH.parseField #promiseId raw_) - <*> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Resolve (C.Parsed Resolve)) where - marshalInto raw_ Resolve{..} = (do - (GH.encodeField #promiseId promiseId raw_) - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Resolve) where - unionField = (GH.dataField 32 0 16 0) - data RawWhich Resolve mut_ - = RW_Resolve'cap (R.Raw CapDescriptor mut_) - | RW_Resolve'exception (R.Raw Exception mut_) - | RW_Resolve'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Resolve'cap <$> (GH.readVariant #cap struct_)) - 1 -> - (RW_Resolve'exception <$> (GH.readVariant #exception struct_)) - _ -> - (Std_.pure (RW_Resolve'unknown' tag_)) - data Which Resolve -instance (GH.HasVariant "cap" GH.Slot Resolve CapDescriptor) where - variantByLabel = (GH.Variant (GH.ptrField 0) 0) -instance (GH.HasVariant "exception" GH.Slot Resolve Exception) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -data instance C.Parsed (GH.Which Resolve) - = Resolve'cap (RP.Parsed CapDescriptor) - | Resolve'exception (RP.Parsed Exception) - | Resolve'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Resolve))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Resolve))) -instance (C.Parse (GH.Which Resolve) (C.Parsed (GH.Which Resolve))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Resolve'cap rawArg_) -> - (Resolve'cap <$> (C.parse rawArg_)) - (RW_Resolve'exception rawArg_) -> - (Resolve'exception <$> (C.parse rawArg_)) - (RW_Resolve'unknown' tag_) -> - (Std_.pure (Resolve'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Resolve) (C.Parsed (GH.Which Resolve))) where - marshalInto raw_ parsed_ = case parsed_ of - (Resolve'cap arg_) -> - (GH.encodeVariant #cap arg_ (GH.unionStruct raw_)) - (Resolve'exception arg_) -> - (GH.encodeVariant #exception arg_ (GH.unionStruct raw_)) - (Resolve'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -instance (GH.HasField "promiseId" GH.Slot Resolve Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -data Release -type instance (R.ReprFor Release) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Release) where - typeId = 12473400923157197975 -instance (C.TypedStruct Release) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate Release) where - type AllocHint Release = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Release (C.Parsed Release)) -instance (C.AllocateList Release) where - type ListAllocHint Release = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Release (C.Parsed Release)) -data instance C.Parsed Release - = Release - {id :: (RP.Parsed Std_.Word32) - ,referenceCount :: (RP.Parsed Std_.Word32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Release)) -deriving instance (Std_.Eq (C.Parsed Release)) -instance (C.Parse Release (C.Parsed Release)) where - parse raw_ = (Release <$> (GH.parseField #id raw_) - <*> (GH.parseField #referenceCount raw_)) -instance (C.Marshal Release (C.Parsed Release)) where - marshalInto raw_ Release{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #referenceCount referenceCount raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot Release Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "referenceCount" GH.Slot Release Std_.Word32) where - fieldByLabel = (GH.dataField 32 0 32 0) -data Disembargo -type instance (R.ReprFor Disembargo) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Disembargo) where - typeId = 17970548384007534353 -instance (C.TypedStruct Disembargo) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Disembargo) where - type AllocHint Disembargo = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Disembargo (C.Parsed Disembargo)) -instance (C.AllocateList Disembargo) where - type ListAllocHint Disembargo = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Disembargo (C.Parsed Disembargo)) -data instance C.Parsed Disembargo - = Disembargo - {target :: (RP.Parsed MessageTarget) - ,context :: (RP.Parsed Disembargo'context)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Disembargo)) -deriving instance (Std_.Eq (C.Parsed Disembargo)) -instance (C.Parse Disembargo (C.Parsed Disembargo)) where - parse raw_ = (Disembargo <$> (GH.parseField #target raw_) - <*> (GH.parseField #context raw_)) -instance (C.Marshal Disembargo (C.Parsed Disembargo)) where - marshalInto raw_ Disembargo{..} = (do - (GH.encodeField #target target raw_) - (do - group_ <- (GH.readField #context raw_) - (C.marshalInto group_ context) - ) - (Std_.pure ()) - ) -instance (GH.HasField "target" GH.Slot Disembargo MessageTarget) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "context" GH.Group Disembargo Disembargo'context) where - fieldByLabel = GH.groupField -data Disembargo'context -type instance (R.ReprFor Disembargo'context) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Disembargo'context) where - typeId = 15376050949367520589 -instance (C.TypedStruct Disembargo'context) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Disembargo'context) where - type AllocHint Disembargo'context = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Disembargo'context (C.Parsed Disembargo'context)) -instance (C.AllocateList Disembargo'context) where - type ListAllocHint Disembargo'context = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Disembargo'context (C.Parsed Disembargo'context)) -data instance C.Parsed Disembargo'context - = Disembargo'context' - {union' :: (C.Parsed (GH.Which Disembargo'context))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Disembargo'context)) -deriving instance (Std_.Eq (C.Parsed Disembargo'context)) -instance (C.Parse Disembargo'context (C.Parsed Disembargo'context)) where - parse raw_ = (Disembargo'context' <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Disembargo'context (C.Parsed Disembargo'context)) where - marshalInto raw_ Disembargo'context'{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Disembargo'context) where - unionField = (GH.dataField 32 0 16 0) - data RawWhich Disembargo'context mut_ - = RW_Disembargo'context'senderLoopback (R.Raw Std_.Word32 mut_) - | RW_Disembargo'context'receiverLoopback (R.Raw Std_.Word32 mut_) - | RW_Disembargo'context'accept (R.Raw () mut_) - | RW_Disembargo'context'provide (R.Raw Std_.Word32 mut_) - | RW_Disembargo'context'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Disembargo'context'senderLoopback <$> (GH.readVariant #senderLoopback struct_)) - 1 -> - (RW_Disembargo'context'receiverLoopback <$> (GH.readVariant #receiverLoopback struct_)) - 2 -> - (RW_Disembargo'context'accept <$> (GH.readVariant #accept struct_)) - 3 -> - (RW_Disembargo'context'provide <$> (GH.readVariant #provide struct_)) - _ -> - (Std_.pure (RW_Disembargo'context'unknown' tag_)) - data Which Disembargo'context -instance (GH.HasVariant "senderLoopback" GH.Slot Disembargo'context Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 0) -instance (GH.HasVariant "receiverLoopback" GH.Slot Disembargo'context Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 1) -instance (GH.HasVariant "accept" GH.Slot Disembargo'context ()) where - variantByLabel = (GH.Variant GH.voidField 2) -instance (GH.HasVariant "provide" GH.Slot Disembargo'context Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 3) -data instance C.Parsed (GH.Which Disembargo'context) - = Disembargo'context'senderLoopback (RP.Parsed Std_.Word32) - | Disembargo'context'receiverLoopback (RP.Parsed Std_.Word32) - | Disembargo'context'accept - | Disembargo'context'provide (RP.Parsed Std_.Word32) - | Disembargo'context'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Disembargo'context))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Disembargo'context))) -instance (C.Parse (GH.Which Disembargo'context) (C.Parsed (GH.Which Disembargo'context))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Disembargo'context'senderLoopback rawArg_) -> - (Disembargo'context'senderLoopback <$> (C.parse rawArg_)) - (RW_Disembargo'context'receiverLoopback rawArg_) -> - (Disembargo'context'receiverLoopback <$> (C.parse rawArg_)) - (RW_Disembargo'context'accept _) -> - (Std_.pure Disembargo'context'accept) - (RW_Disembargo'context'provide rawArg_) -> - (Disembargo'context'provide <$> (C.parse rawArg_)) - (RW_Disembargo'context'unknown' tag_) -> - (Std_.pure (Disembargo'context'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Disembargo'context) (C.Parsed (GH.Which Disembargo'context))) where - marshalInto raw_ parsed_ = case parsed_ of - (Disembargo'context'senderLoopback arg_) -> - (GH.encodeVariant #senderLoopback arg_ (GH.unionStruct raw_)) - (Disembargo'context'receiverLoopback arg_) -> - (GH.encodeVariant #receiverLoopback arg_ (GH.unionStruct raw_)) - (Disembargo'context'accept) -> - (GH.encodeVariant #accept () (GH.unionStruct raw_)) - (Disembargo'context'provide arg_) -> - (GH.encodeVariant #provide arg_ (GH.unionStruct raw_)) - (Disembargo'context'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Provide -type instance (R.ReprFor Provide) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Provide) where - typeId = 11270825879279873114 -instance (C.TypedStruct Provide) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate Provide) where - type AllocHint Provide = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Provide (C.Parsed Provide)) -instance (C.AllocateList Provide) where - type ListAllocHint Provide = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Provide (C.Parsed Provide)) -data instance C.Parsed Provide - = Provide - {questionId :: (RP.Parsed Std_.Word32) - ,target :: (RP.Parsed MessageTarget) - ,recipient :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Provide)) -deriving instance (Std_.Eq (C.Parsed Provide)) -instance (C.Parse Provide (C.Parsed Provide)) where - parse raw_ = (Provide <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #target raw_) - <*> (GH.parseField #recipient raw_)) -instance (C.Marshal Provide (C.Parsed Provide)) where - marshalInto raw_ Provide{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #target target raw_) - (GH.encodeField #recipient recipient raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot Provide Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "target" GH.Slot Provide MessageTarget) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "recipient" GH.Slot Provide (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 1) -data Accept -type instance (R.ReprFor Accept) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Accept) where - typeId = 15332985841292492822 -instance (C.TypedStruct Accept) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Accept) where - type AllocHint Accept = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Accept (C.Parsed Accept)) -instance (C.AllocateList Accept) where - type ListAllocHint Accept = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Accept (C.Parsed Accept)) -data instance C.Parsed Accept - = Accept - {questionId :: (RP.Parsed Std_.Word32) - ,provision :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - ,embargo :: (RP.Parsed Std_.Bool)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Accept)) -deriving instance (Std_.Eq (C.Parsed Accept)) -instance (C.Parse Accept (C.Parsed Accept)) where - parse raw_ = (Accept <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #provision raw_) - <*> (GH.parseField #embargo raw_)) -instance (C.Marshal Accept (C.Parsed Accept)) where - marshalInto raw_ Accept{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #provision provision raw_) - (GH.encodeField #embargo embargo raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot Accept Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "provision" GH.Slot Accept (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "embargo" GH.Slot Accept Std_.Bool) where - fieldByLabel = (GH.dataField 32 0 1 0) -data Join -type instance (R.ReprFor Join) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Join) where - typeId = 18149955118657700271 -instance (C.TypedStruct Join) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate Join) where - type AllocHint Join = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Join (C.Parsed Join)) -instance (C.AllocateList Join) where - type ListAllocHint Join = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Join (C.Parsed Join)) -data instance C.Parsed Join - = Join - {questionId :: (RP.Parsed Std_.Word32) - ,target :: (RP.Parsed MessageTarget) - ,keyPart :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Join)) -deriving instance (Std_.Eq (C.Parsed Join)) -instance (C.Parse Join (C.Parsed Join)) where - parse raw_ = (Join <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #target raw_) - <*> (GH.parseField #keyPart raw_)) -instance (C.Marshal Join (C.Parsed Join)) where - marshalInto raw_ Join{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #target target raw_) - (GH.encodeField #keyPart keyPart raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot Join Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "target" GH.Slot Join MessageTarget) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "keyPart" GH.Slot Join (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 1) -data MessageTarget -type instance (R.ReprFor MessageTarget) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId MessageTarget) where - typeId = 10789521159760378817 -instance (C.TypedStruct MessageTarget) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate MessageTarget) where - type AllocHint MessageTarget = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc MessageTarget (C.Parsed MessageTarget)) -instance (C.AllocateList MessageTarget) where - type ListAllocHint MessageTarget = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc MessageTarget (C.Parsed MessageTarget)) -data instance C.Parsed MessageTarget - = MessageTarget - {union' :: (C.Parsed (GH.Which MessageTarget))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed MessageTarget)) -deriving instance (Std_.Eq (C.Parsed MessageTarget)) -instance (C.Parse MessageTarget (C.Parsed MessageTarget)) where - parse raw_ = (MessageTarget <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal MessageTarget (C.Parsed MessageTarget)) where - marshalInto raw_ MessageTarget{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion MessageTarget) where - unionField = (GH.dataField 32 0 16 0) - data RawWhich MessageTarget mut_ - = RW_MessageTarget'importedCap (R.Raw Std_.Word32 mut_) - | RW_MessageTarget'promisedAnswer (R.Raw PromisedAnswer mut_) - | RW_MessageTarget'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_MessageTarget'importedCap <$> (GH.readVariant #importedCap struct_)) - 1 -> - (RW_MessageTarget'promisedAnswer <$> (GH.readVariant #promisedAnswer struct_)) - _ -> - (Std_.pure (RW_MessageTarget'unknown' tag_)) - data Which MessageTarget -instance (GH.HasVariant "importedCap" GH.Slot MessageTarget Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 0 32 0) 0) -instance (GH.HasVariant "promisedAnswer" GH.Slot MessageTarget PromisedAnswer) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -data instance C.Parsed (GH.Which MessageTarget) - = MessageTarget'importedCap (RP.Parsed Std_.Word32) - | MessageTarget'promisedAnswer (RP.Parsed PromisedAnswer) - | MessageTarget'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which MessageTarget))) -deriving instance (Std_.Eq (C.Parsed (GH.Which MessageTarget))) -instance (C.Parse (GH.Which MessageTarget) (C.Parsed (GH.Which MessageTarget))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_MessageTarget'importedCap rawArg_) -> - (MessageTarget'importedCap <$> (C.parse rawArg_)) - (RW_MessageTarget'promisedAnswer rawArg_) -> - (MessageTarget'promisedAnswer <$> (C.parse rawArg_)) - (RW_MessageTarget'unknown' tag_) -> - (Std_.pure (MessageTarget'unknown' tag_)) - ) -instance (C.Marshal (GH.Which MessageTarget) (C.Parsed (GH.Which MessageTarget))) where - marshalInto raw_ parsed_ = case parsed_ of - (MessageTarget'importedCap arg_) -> - (GH.encodeVariant #importedCap arg_ (GH.unionStruct raw_)) - (MessageTarget'promisedAnswer arg_) -> - (GH.encodeVariant #promisedAnswer arg_ (GH.unionStruct raw_)) - (MessageTarget'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Payload -type instance (R.ReprFor Payload) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Payload) where - typeId = 11100916931204903995 -instance (C.TypedStruct Payload) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate Payload) where - type AllocHint Payload = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Payload (C.Parsed Payload)) -instance (C.AllocateList Payload) where - type ListAllocHint Payload = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Payload (C.Parsed Payload)) -data instance C.Parsed Payload - = Payload - {content :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - ,capTable :: (RP.Parsed (R.List CapDescriptor))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Payload)) -deriving instance (Std_.Eq (C.Parsed Payload)) -instance (C.Parse Payload (C.Parsed Payload)) where - parse raw_ = (Payload <$> (GH.parseField #content raw_) - <*> (GH.parseField #capTable raw_)) -instance (C.Marshal Payload (C.Parsed Payload)) where - marshalInto raw_ Payload{..} = (do - (GH.encodeField #content content raw_) - (GH.encodeField #capTable capTable raw_) - (Std_.pure ()) - ) -instance (GH.HasField "content" GH.Slot Payload (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "capTable" GH.Slot Payload (R.List CapDescriptor)) where - fieldByLabel = (GH.ptrField 1) -data CapDescriptor -type instance (R.ReprFor CapDescriptor) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CapDescriptor) where - typeId = 9593755465305995440 -instance (C.TypedStruct CapDescriptor) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate CapDescriptor) where - type AllocHint CapDescriptor = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CapDescriptor (C.Parsed CapDescriptor)) -instance (C.AllocateList CapDescriptor) where - type ListAllocHint CapDescriptor = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CapDescriptor (C.Parsed CapDescriptor)) -data instance C.Parsed CapDescriptor - = CapDescriptor - {attachedFd :: (RP.Parsed Std_.Word8) - ,union' :: (C.Parsed (GH.Which CapDescriptor))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CapDescriptor)) -deriving instance (Std_.Eq (C.Parsed CapDescriptor)) -instance (C.Parse CapDescriptor (C.Parsed CapDescriptor)) where - parse raw_ = (CapDescriptor <$> (GH.parseField #attachedFd raw_) - <*> (C.parse (GH.structUnion raw_))) -instance (C.Marshal CapDescriptor (C.Parsed CapDescriptor)) where - marshalInto raw_ CapDescriptor{..} = (do - (GH.encodeField #attachedFd attachedFd raw_) - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion CapDescriptor) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich CapDescriptor mut_ - = RW_CapDescriptor'none (R.Raw () mut_) - | RW_CapDescriptor'senderHosted (R.Raw Std_.Word32 mut_) - | RW_CapDescriptor'senderPromise (R.Raw Std_.Word32 mut_) - | RW_CapDescriptor'receiverHosted (R.Raw Std_.Word32 mut_) - | RW_CapDescriptor'receiverAnswer (R.Raw PromisedAnswer mut_) - | RW_CapDescriptor'thirdPartyHosted (R.Raw ThirdPartyCapDescriptor mut_) - | RW_CapDescriptor'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_CapDescriptor'none <$> (GH.readVariant #none struct_)) - 1 -> - (RW_CapDescriptor'senderHosted <$> (GH.readVariant #senderHosted struct_)) - 2 -> - (RW_CapDescriptor'senderPromise <$> (GH.readVariant #senderPromise struct_)) - 3 -> - (RW_CapDescriptor'receiverHosted <$> (GH.readVariant #receiverHosted struct_)) - 4 -> - (RW_CapDescriptor'receiverAnswer <$> (GH.readVariant #receiverAnswer struct_)) - 5 -> - (RW_CapDescriptor'thirdPartyHosted <$> (GH.readVariant #thirdPartyHosted struct_)) - _ -> - (Std_.pure (RW_CapDescriptor'unknown' tag_)) - data Which CapDescriptor -instance (GH.HasVariant "none" GH.Slot CapDescriptor ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "senderHosted" GH.Slot CapDescriptor Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 1) -instance (GH.HasVariant "senderPromise" GH.Slot CapDescriptor Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 2) -instance (GH.HasVariant "receiverHosted" GH.Slot CapDescriptor Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 3) -instance (GH.HasVariant "receiverAnswer" GH.Slot CapDescriptor PromisedAnswer) where - variantByLabel = (GH.Variant (GH.ptrField 0) 4) -instance (GH.HasVariant "thirdPartyHosted" GH.Slot CapDescriptor ThirdPartyCapDescriptor) where - variantByLabel = (GH.Variant (GH.ptrField 0) 5) -data instance C.Parsed (GH.Which CapDescriptor) - = CapDescriptor'none - | CapDescriptor'senderHosted (RP.Parsed Std_.Word32) - | CapDescriptor'senderPromise (RP.Parsed Std_.Word32) - | CapDescriptor'receiverHosted (RP.Parsed Std_.Word32) - | CapDescriptor'receiverAnswer (RP.Parsed PromisedAnswer) - | CapDescriptor'thirdPartyHosted (RP.Parsed ThirdPartyCapDescriptor) - | CapDescriptor'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which CapDescriptor))) -deriving instance (Std_.Eq (C.Parsed (GH.Which CapDescriptor))) -instance (C.Parse (GH.Which CapDescriptor) (C.Parsed (GH.Which CapDescriptor))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_CapDescriptor'none _) -> - (Std_.pure CapDescriptor'none) - (RW_CapDescriptor'senderHosted rawArg_) -> - (CapDescriptor'senderHosted <$> (C.parse rawArg_)) - (RW_CapDescriptor'senderPromise rawArg_) -> - (CapDescriptor'senderPromise <$> (C.parse rawArg_)) - (RW_CapDescriptor'receiverHosted rawArg_) -> - (CapDescriptor'receiverHosted <$> (C.parse rawArg_)) - (RW_CapDescriptor'receiverAnswer rawArg_) -> - (CapDescriptor'receiverAnswer <$> (C.parse rawArg_)) - (RW_CapDescriptor'thirdPartyHosted rawArg_) -> - (CapDescriptor'thirdPartyHosted <$> (C.parse rawArg_)) - (RW_CapDescriptor'unknown' tag_) -> - (Std_.pure (CapDescriptor'unknown' tag_)) - ) -instance (C.Marshal (GH.Which CapDescriptor) (C.Parsed (GH.Which CapDescriptor))) where - marshalInto raw_ parsed_ = case parsed_ of - (CapDescriptor'none) -> - (GH.encodeVariant #none () (GH.unionStruct raw_)) - (CapDescriptor'senderHosted arg_) -> - (GH.encodeVariant #senderHosted arg_ (GH.unionStruct raw_)) - (CapDescriptor'senderPromise arg_) -> - (GH.encodeVariant #senderPromise arg_ (GH.unionStruct raw_)) - (CapDescriptor'receiverHosted arg_) -> - (GH.encodeVariant #receiverHosted arg_ (GH.unionStruct raw_)) - (CapDescriptor'receiverAnswer arg_) -> - (GH.encodeVariant #receiverAnswer arg_ (GH.unionStruct raw_)) - (CapDescriptor'thirdPartyHosted arg_) -> - (GH.encodeVariant #thirdPartyHosted arg_ (GH.unionStruct raw_)) - (CapDescriptor'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -instance (GH.HasField "attachedFd" GH.Slot CapDescriptor Std_.Word8) where - fieldByLabel = (GH.dataField 16 0 8 255) -data PromisedAnswer -type instance (R.ReprFor PromisedAnswer) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId PromisedAnswer) where - typeId = 15564635848320162976 -instance (C.TypedStruct PromisedAnswer) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate PromisedAnswer) where - type AllocHint PromisedAnswer = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc PromisedAnswer (C.Parsed PromisedAnswer)) -instance (C.AllocateList PromisedAnswer) where - type ListAllocHint PromisedAnswer = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc PromisedAnswer (C.Parsed PromisedAnswer)) -data instance C.Parsed PromisedAnswer - = PromisedAnswer - {questionId :: (RP.Parsed Std_.Word32) - ,transform :: (RP.Parsed (R.List PromisedAnswer'Op))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed PromisedAnswer)) -deriving instance (Std_.Eq (C.Parsed PromisedAnswer)) -instance (C.Parse PromisedAnswer (C.Parsed PromisedAnswer)) where - parse raw_ = (PromisedAnswer <$> (GH.parseField #questionId raw_) - <*> (GH.parseField #transform raw_)) -instance (C.Marshal PromisedAnswer (C.Parsed PromisedAnswer)) where - marshalInto raw_ PromisedAnswer{..} = (do - (GH.encodeField #questionId questionId raw_) - (GH.encodeField #transform transform raw_) - (Std_.pure ()) - ) -instance (GH.HasField "questionId" GH.Slot PromisedAnswer Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "transform" GH.Slot PromisedAnswer (R.List PromisedAnswer'Op)) where - fieldByLabel = (GH.ptrField 0) -data PromisedAnswer'Op -type instance (R.ReprFor PromisedAnswer'Op) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId PromisedAnswer'Op) where - typeId = 17516350820840804481 -instance (C.TypedStruct PromisedAnswer'Op) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate PromisedAnswer'Op) where - type AllocHint PromisedAnswer'Op = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) -instance (C.AllocateList PromisedAnswer'Op) where - type ListAllocHint PromisedAnswer'Op = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) -data instance C.Parsed PromisedAnswer'Op - = PromisedAnswer'Op - {union' :: (C.Parsed (GH.Which PromisedAnswer'Op))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed PromisedAnswer'Op)) -deriving instance (Std_.Eq (C.Parsed PromisedAnswer'Op)) -instance (C.Parse PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) where - parse raw_ = (PromisedAnswer'Op <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal PromisedAnswer'Op (C.Parsed PromisedAnswer'Op)) where - marshalInto raw_ PromisedAnswer'Op{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion PromisedAnswer'Op) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich PromisedAnswer'Op mut_ - = RW_PromisedAnswer'Op'noop (R.Raw () mut_) - | RW_PromisedAnswer'Op'getPointerField (R.Raw Std_.Word16 mut_) - | RW_PromisedAnswer'Op'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_PromisedAnswer'Op'noop <$> (GH.readVariant #noop struct_)) - 1 -> - (RW_PromisedAnswer'Op'getPointerField <$> (GH.readVariant #getPointerField struct_)) - _ -> - (Std_.pure (RW_PromisedAnswer'Op'unknown' tag_)) - data Which PromisedAnswer'Op -instance (GH.HasVariant "noop" GH.Slot PromisedAnswer'Op ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "getPointerField" GH.Slot PromisedAnswer'Op Std_.Word16) where - variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 1) -data instance C.Parsed (GH.Which PromisedAnswer'Op) - = PromisedAnswer'Op'noop - | PromisedAnswer'Op'getPointerField (RP.Parsed Std_.Word16) - | PromisedAnswer'Op'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which PromisedAnswer'Op))) -deriving instance (Std_.Eq (C.Parsed (GH.Which PromisedAnswer'Op))) -instance (C.Parse (GH.Which PromisedAnswer'Op) (C.Parsed (GH.Which PromisedAnswer'Op))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_PromisedAnswer'Op'noop _) -> - (Std_.pure PromisedAnswer'Op'noop) - (RW_PromisedAnswer'Op'getPointerField rawArg_) -> - (PromisedAnswer'Op'getPointerField <$> (C.parse rawArg_)) - (RW_PromisedAnswer'Op'unknown' tag_) -> - (Std_.pure (PromisedAnswer'Op'unknown' tag_)) - ) -instance (C.Marshal (GH.Which PromisedAnswer'Op) (C.Parsed (GH.Which PromisedAnswer'Op))) where - marshalInto raw_ parsed_ = case parsed_ of - (PromisedAnswer'Op'noop) -> - (GH.encodeVariant #noop () (GH.unionStruct raw_)) - (PromisedAnswer'Op'getPointerField arg_) -> - (GH.encodeVariant #getPointerField arg_ (GH.unionStruct raw_)) - (PromisedAnswer'Op'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data ThirdPartyCapDescriptor -type instance (R.ReprFor ThirdPartyCapDescriptor) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId ThirdPartyCapDescriptor) where - typeId = 15235686326393111165 -instance (C.TypedStruct ThirdPartyCapDescriptor) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate ThirdPartyCapDescriptor) where - type AllocHint ThirdPartyCapDescriptor = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) -instance (C.AllocateList ThirdPartyCapDescriptor) where - type ListAllocHint ThirdPartyCapDescriptor = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) -data instance C.Parsed ThirdPartyCapDescriptor - = ThirdPartyCapDescriptor - {id :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - ,vineId :: (RP.Parsed Std_.Word32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed ThirdPartyCapDescriptor)) -deriving instance (Std_.Eq (C.Parsed ThirdPartyCapDescriptor)) -instance (C.Parse ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) where - parse raw_ = (ThirdPartyCapDescriptor <$> (GH.parseField #id raw_) - <*> (GH.parseField #vineId raw_)) -instance (C.Marshal ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) where - marshalInto raw_ ThirdPartyCapDescriptor{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #vineId vineId raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot ThirdPartyCapDescriptor (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "vineId" GH.Slot ThirdPartyCapDescriptor Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -data Exception -type instance (R.ReprFor Exception) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Exception) where - typeId = 15430940935639230746 -instance (C.TypedStruct Exception) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Exception) where - type AllocHint Exception = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Exception (C.Parsed Exception)) -instance (C.AllocateList Exception) where - type ListAllocHint Exception = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Exception (C.Parsed Exception)) -data instance C.Parsed Exception - = Exception - {reason :: (RP.Parsed Basics.Text) - ,obsoleteIsCallersFault :: (RP.Parsed Std_.Bool) - ,obsoleteDurability :: (RP.Parsed Std_.Word16) - ,type_ :: (RP.Parsed Exception'Type)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Exception)) -deriving instance (Std_.Eq (C.Parsed Exception)) -instance (C.Parse Exception (C.Parsed Exception)) where - parse raw_ = (Exception <$> (GH.parseField #reason raw_) - <*> (GH.parseField #obsoleteIsCallersFault raw_) - <*> (GH.parseField #obsoleteDurability raw_) - <*> (GH.parseField #type_ raw_)) -instance (C.Marshal Exception (C.Parsed Exception)) where - marshalInto raw_ Exception{..} = (do - (GH.encodeField #reason reason raw_) - (GH.encodeField #obsoleteIsCallersFault obsoleteIsCallersFault raw_) - (GH.encodeField #obsoleteDurability obsoleteDurability raw_) - (GH.encodeField #type_ type_ raw_) - (Std_.pure ()) - ) -instance (GH.HasField "reason" GH.Slot Exception Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "obsoleteIsCallersFault" GH.Slot Exception Std_.Bool) where - fieldByLabel = (GH.dataField 0 0 1 0) -instance (GH.HasField "obsoleteDurability" GH.Slot Exception Std_.Word16) where - fieldByLabel = (GH.dataField 16 0 16 0) -instance (GH.HasField "type_" GH.Slot Exception Exception'Type) where - fieldByLabel = (GH.dataField 32 0 16 0) -data Exception'Type - = Exception'Type'failed - | Exception'Type'overloaded - | Exception'Type'disconnected - | Exception'Type'unimplemented - | Exception'Type'unknown' Std_.Word16 - deriving(Std_.Eq - ,Std_.Show - ,Generics.Generic) -type instance (R.ReprFor Exception'Type) = (R.Data R.Sz16) -instance (C.HasTypeId Exception'Type) where - typeId = 12865824133959433560 -instance (Std_.Enum Exception'Type) where - toEnum n_ = case n_ of - 0 -> - Exception'Type'failed - 1 -> - Exception'Type'overloaded - 2 -> - Exception'Type'disconnected - 3 -> - Exception'Type'unimplemented - tag_ -> - (Exception'Type'unknown' (Std_.fromIntegral tag_)) - fromEnum value_ = case value_ of - (Exception'Type'failed) -> - 0 - (Exception'Type'overloaded) -> - 1 - (Exception'Type'disconnected) -> - 2 - (Exception'Type'unimplemented) -> - 3 - (Exception'Type'unknown' tag_) -> - (Std_.fromIntegral tag_) -instance (C.IsWord Exception'Type) where - fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) - toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) -instance (C.Parse Exception'Type Exception'Type) where - parse = GH.parseEnum - encode = GH.encodeEnum -instance (C.AllocateList Exception'Type) where - type ListAllocHint Exception'Type = Std_.Int -instance (C.EstimateListAlloc Exception'Type Exception'Type) diff --git a/gen/lib/Capnp/Gen/Capnp/RpcTwoparty.hs b/gen/lib/Capnp/Gen/Capnp/RpcTwoparty.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/RpcTwoparty.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.RpcTwoparty where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data Side + = Side'server + | Side'client + | Side'unknown' Std_.Word16 + deriving(Std_.Eq + ,Std_.Show + ,Generics.Generic) +type instance (R.ReprFor Side) = (R.Data R.Sz16) +instance (C.HasTypeId Side) where + typeId = 11517567629614739868 +instance (Std_.Enum Side) where + toEnum n_ = case n_ of + 0 -> + Side'server + 1 -> + Side'client + tag_ -> + (Side'unknown' (Std_.fromIntegral tag_)) + fromEnum value_ = case value_ of + (Side'server) -> + 0 + (Side'client) -> + 1 + (Side'unknown' tag_) -> + (Std_.fromIntegral tag_) +instance (C.IsWord Side) where + fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) + toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) +instance (C.Parse Side Side) where + parse = GH.parseEnum + encode = GH.encodeEnum +instance (C.AllocateList Side) where + type ListAllocHint Side = Std_.Int +instance (C.EstimateListAlloc Side Side) +data VatId +type instance (R.ReprFor VatId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VatId) where + typeId = 15135349989283412622 +instance (C.TypedStruct VatId) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate VatId) where + type AllocHint VatId = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VatId (C.Parsed VatId)) +instance (C.AllocateList VatId) where + type ListAllocHint VatId = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VatId (C.Parsed VatId)) +data instance C.Parsed VatId + = VatId + {side :: (RP.Parsed Side)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VatId)) +deriving instance (Std_.Eq (C.Parsed VatId)) +instance (C.Parse VatId (C.Parsed VatId)) where + parse raw_ = (VatId <$> (GH.parseField #side raw_)) +instance (C.Marshal VatId (C.Parsed VatId)) where + marshalInto raw_ VatId{..} = (do + (GH.encodeField #side side raw_) + (Std_.pure ()) + ) +instance (GH.HasField "side" GH.Slot VatId Side) where + fieldByLabel = (GH.dataField 0 0 16 0) +data ProvisionId +type instance (R.ReprFor ProvisionId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ProvisionId) where + typeId = 13298295899470141463 +instance (C.TypedStruct ProvisionId) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate ProvisionId) where + type AllocHint ProvisionId = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc ProvisionId (C.Parsed ProvisionId)) +instance (C.AllocateList ProvisionId) where + type ListAllocHint ProvisionId = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc ProvisionId (C.Parsed ProvisionId)) +data instance C.Parsed ProvisionId + = ProvisionId + {joinId :: (RP.Parsed Std_.Word32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed ProvisionId)) +deriving instance (Std_.Eq (C.Parsed ProvisionId)) +instance (C.Parse ProvisionId (C.Parsed ProvisionId)) where + parse raw_ = (ProvisionId <$> (GH.parseField #joinId raw_)) +instance (C.Marshal ProvisionId (C.Parsed ProvisionId)) where + marshalInto raw_ ProvisionId{..} = (do + (GH.encodeField #joinId joinId raw_) + (Std_.pure ()) + ) +instance (GH.HasField "joinId" GH.Slot ProvisionId Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +data RecipientId +type instance (R.ReprFor RecipientId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId RecipientId) where + typeId = 9940440221562733249 +instance (C.TypedStruct RecipientId) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate RecipientId) where + type AllocHint RecipientId = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc RecipientId (C.Parsed RecipientId)) +instance (C.AllocateList RecipientId) where + type ListAllocHint RecipientId = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc RecipientId (C.Parsed RecipientId)) +data instance C.Parsed RecipientId + = RecipientId + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed RecipientId)) +deriving instance (Std_.Eq (C.Parsed RecipientId)) +instance (C.Parse RecipientId (C.Parsed RecipientId)) where + parse raw_ = (Std_.pure RecipientId) +instance (C.Marshal RecipientId (C.Parsed RecipientId)) where + marshalInto _raw (RecipientId) = (Std_.pure ()) +data ThirdPartyCapId +type instance (R.ReprFor ThirdPartyCapId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ThirdPartyCapId) where + typeId = 13006195034640135581 +instance (C.TypedStruct ThirdPartyCapId) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate ThirdPartyCapId) where + type AllocHint ThirdPartyCapId = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc ThirdPartyCapId (C.Parsed ThirdPartyCapId)) +instance (C.AllocateList ThirdPartyCapId) where + type ListAllocHint ThirdPartyCapId = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc ThirdPartyCapId (C.Parsed ThirdPartyCapId)) +data instance C.Parsed ThirdPartyCapId + = ThirdPartyCapId + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed ThirdPartyCapId)) +deriving instance (Std_.Eq (C.Parsed ThirdPartyCapId)) +instance (C.Parse ThirdPartyCapId (C.Parsed ThirdPartyCapId)) where + parse raw_ = (Std_.pure ThirdPartyCapId) +instance (C.Marshal ThirdPartyCapId (C.Parsed ThirdPartyCapId)) where + marshalInto _raw (ThirdPartyCapId) = (Std_.pure ()) +data JoinKeyPart +type instance (R.ReprFor JoinKeyPart) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId JoinKeyPart) where + typeId = 10786842769591618179 +instance (C.TypedStruct JoinKeyPart) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate JoinKeyPart) where + type AllocHint JoinKeyPart = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc JoinKeyPart (C.Parsed JoinKeyPart)) +instance (C.AllocateList JoinKeyPart) where + type ListAllocHint JoinKeyPart = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc JoinKeyPart (C.Parsed JoinKeyPart)) +data instance C.Parsed JoinKeyPart + = JoinKeyPart + {joinId :: (RP.Parsed Std_.Word32) + ,partCount :: (RP.Parsed Std_.Word16) + ,partNum :: (RP.Parsed Std_.Word16)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed JoinKeyPart)) +deriving instance (Std_.Eq (C.Parsed JoinKeyPart)) +instance (C.Parse JoinKeyPart (C.Parsed JoinKeyPart)) where + parse raw_ = (JoinKeyPart <$> (GH.parseField #joinId raw_) + <*> (GH.parseField #partCount raw_) + <*> (GH.parseField #partNum raw_)) +instance (C.Marshal JoinKeyPart (C.Parsed JoinKeyPart)) where + marshalInto raw_ JoinKeyPart{..} = (do + (GH.encodeField #joinId joinId raw_) + (GH.encodeField #partCount partCount raw_) + (GH.encodeField #partNum partNum raw_) + (Std_.pure ()) + ) +instance (GH.HasField "joinId" GH.Slot JoinKeyPart Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "partCount" GH.Slot JoinKeyPart Std_.Word16) where + fieldByLabel = (GH.dataField 32 0 16 0) +instance (GH.HasField "partNum" GH.Slot JoinKeyPart Std_.Word16) where + fieldByLabel = (GH.dataField 48 0 16 0) +data JoinResult +type instance (R.ReprFor JoinResult) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId JoinResult) where + typeId = 11323802317489695726 +instance (C.TypedStruct JoinResult) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate JoinResult) where + type AllocHint JoinResult = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc JoinResult (C.Parsed JoinResult)) +instance (C.AllocateList JoinResult) where + type ListAllocHint JoinResult = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc JoinResult (C.Parsed JoinResult)) +data instance C.Parsed JoinResult + = JoinResult + {joinId :: (RP.Parsed Std_.Word32) + ,succeeded :: (RP.Parsed Std_.Bool) + ,cap :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed JoinResult)) +deriving instance (Std_.Eq (C.Parsed JoinResult)) +instance (C.Parse JoinResult (C.Parsed JoinResult)) where + parse raw_ = (JoinResult <$> (GH.parseField #joinId raw_) + <*> (GH.parseField #succeeded raw_) + <*> (GH.parseField #cap raw_)) +instance (C.Marshal JoinResult (C.Parsed JoinResult)) where + marshalInto raw_ JoinResult{..} = (do + (GH.encodeField #joinId joinId raw_) + (GH.encodeField #succeeded succeeded raw_) + (GH.encodeField #cap cap raw_) + (Std_.pure ()) + ) +instance (GH.HasField "joinId" GH.Slot JoinResult Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "succeeded" GH.Slot JoinResult Std_.Bool) where + fieldByLabel = (GH.dataField 32 0 1 0) +instance (GH.HasField "cap" GH.Slot JoinResult (Std_.Maybe Basics.AnyPointer)) where + fieldByLabel = (GH.ptrField 0) diff --git a/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs b/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs +++ /dev/null @@ -1,258 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.RpcTwoparty.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Side - = Side'server - | Side'client - | Side'unknown' Std_.Word16 - deriving(Std_.Eq - ,Std_.Show - ,Generics.Generic) -type instance (R.ReprFor Side) = (R.Data R.Sz16) -instance (C.HasTypeId Side) where - typeId = 11517567629614739868 -instance (Std_.Enum Side) where - toEnum n_ = case n_ of - 0 -> - Side'server - 1 -> - Side'client - tag_ -> - (Side'unknown' (Std_.fromIntegral tag_)) - fromEnum value_ = case value_ of - (Side'server) -> - 0 - (Side'client) -> - 1 - (Side'unknown' tag_) -> - (Std_.fromIntegral tag_) -instance (C.IsWord Side) where - fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) - toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) -instance (C.Parse Side Side) where - parse = GH.parseEnum - encode = GH.encodeEnum -instance (C.AllocateList Side) where - type ListAllocHint Side = Std_.Int -instance (C.EstimateListAlloc Side Side) -data VatId -type instance (R.ReprFor VatId) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VatId) where - typeId = 15135349989283412622 -instance (C.TypedStruct VatId) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate VatId) where - type AllocHint VatId = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VatId (C.Parsed VatId)) -instance (C.AllocateList VatId) where - type ListAllocHint VatId = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VatId (C.Parsed VatId)) -data instance C.Parsed VatId - = VatId - {side :: (RP.Parsed Side)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VatId)) -deriving instance (Std_.Eq (C.Parsed VatId)) -instance (C.Parse VatId (C.Parsed VatId)) where - parse raw_ = (VatId <$> (GH.parseField #side raw_)) -instance (C.Marshal VatId (C.Parsed VatId)) where - marshalInto raw_ VatId{..} = (do - (GH.encodeField #side side raw_) - (Std_.pure ()) - ) -instance (GH.HasField "side" GH.Slot VatId Side) where - fieldByLabel = (GH.dataField 0 0 16 0) -data ProvisionId -type instance (R.ReprFor ProvisionId) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId ProvisionId) where - typeId = 13298295899470141463 -instance (C.TypedStruct ProvisionId) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate ProvisionId) where - type AllocHint ProvisionId = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc ProvisionId (C.Parsed ProvisionId)) -instance (C.AllocateList ProvisionId) where - type ListAllocHint ProvisionId = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc ProvisionId (C.Parsed ProvisionId)) -data instance C.Parsed ProvisionId - = ProvisionId - {joinId :: (RP.Parsed Std_.Word32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed ProvisionId)) -deriving instance (Std_.Eq (C.Parsed ProvisionId)) -instance (C.Parse ProvisionId (C.Parsed ProvisionId)) where - parse raw_ = (ProvisionId <$> (GH.parseField #joinId raw_)) -instance (C.Marshal ProvisionId (C.Parsed ProvisionId)) where - marshalInto raw_ ProvisionId{..} = (do - (GH.encodeField #joinId joinId raw_) - (Std_.pure ()) - ) -instance (GH.HasField "joinId" GH.Slot ProvisionId Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -data RecipientId -type instance (R.ReprFor RecipientId) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId RecipientId) where - typeId = 9940440221562733249 -instance (C.TypedStruct RecipientId) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate RecipientId) where - type AllocHint RecipientId = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc RecipientId (C.Parsed RecipientId)) -instance (C.AllocateList RecipientId) where - type ListAllocHint RecipientId = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc RecipientId (C.Parsed RecipientId)) -data instance C.Parsed RecipientId - = RecipientId - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed RecipientId)) -deriving instance (Std_.Eq (C.Parsed RecipientId)) -instance (C.Parse RecipientId (C.Parsed RecipientId)) where - parse raw_ = (Std_.pure RecipientId) -instance (C.Marshal RecipientId (C.Parsed RecipientId)) where - marshalInto _raw (RecipientId) = (Std_.pure ()) -data ThirdPartyCapId -type instance (R.ReprFor ThirdPartyCapId) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId ThirdPartyCapId) where - typeId = 13006195034640135581 -instance (C.TypedStruct ThirdPartyCapId) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate ThirdPartyCapId) where - type AllocHint ThirdPartyCapId = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc ThirdPartyCapId (C.Parsed ThirdPartyCapId)) -instance (C.AllocateList ThirdPartyCapId) where - type ListAllocHint ThirdPartyCapId = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc ThirdPartyCapId (C.Parsed ThirdPartyCapId)) -data instance C.Parsed ThirdPartyCapId - = ThirdPartyCapId - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed ThirdPartyCapId)) -deriving instance (Std_.Eq (C.Parsed ThirdPartyCapId)) -instance (C.Parse ThirdPartyCapId (C.Parsed ThirdPartyCapId)) where - parse raw_ = (Std_.pure ThirdPartyCapId) -instance (C.Marshal ThirdPartyCapId (C.Parsed ThirdPartyCapId)) where - marshalInto _raw (ThirdPartyCapId) = (Std_.pure ()) -data JoinKeyPart -type instance (R.ReprFor JoinKeyPart) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId JoinKeyPart) where - typeId = 10786842769591618179 -instance (C.TypedStruct JoinKeyPart) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate JoinKeyPart) where - type AllocHint JoinKeyPart = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc JoinKeyPart (C.Parsed JoinKeyPart)) -instance (C.AllocateList JoinKeyPart) where - type ListAllocHint JoinKeyPart = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc JoinKeyPart (C.Parsed JoinKeyPart)) -data instance C.Parsed JoinKeyPart - = JoinKeyPart - {joinId :: (RP.Parsed Std_.Word32) - ,partCount :: (RP.Parsed Std_.Word16) - ,partNum :: (RP.Parsed Std_.Word16)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed JoinKeyPart)) -deriving instance (Std_.Eq (C.Parsed JoinKeyPart)) -instance (C.Parse JoinKeyPart (C.Parsed JoinKeyPart)) where - parse raw_ = (JoinKeyPart <$> (GH.parseField #joinId raw_) - <*> (GH.parseField #partCount raw_) - <*> (GH.parseField #partNum raw_)) -instance (C.Marshal JoinKeyPart (C.Parsed JoinKeyPart)) where - marshalInto raw_ JoinKeyPart{..} = (do - (GH.encodeField #joinId joinId raw_) - (GH.encodeField #partCount partCount raw_) - (GH.encodeField #partNum partNum raw_) - (Std_.pure ()) - ) -instance (GH.HasField "joinId" GH.Slot JoinKeyPart Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "partCount" GH.Slot JoinKeyPart Std_.Word16) where - fieldByLabel = (GH.dataField 32 0 16 0) -instance (GH.HasField "partNum" GH.Slot JoinKeyPart Std_.Word16) where - fieldByLabel = (GH.dataField 48 0 16 0) -data JoinResult -type instance (R.ReprFor JoinResult) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId JoinResult) where - typeId = 11323802317489695726 -instance (C.TypedStruct JoinResult) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate JoinResult) where - type AllocHint JoinResult = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc JoinResult (C.Parsed JoinResult)) -instance (C.AllocateList JoinResult) where - type ListAllocHint JoinResult = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc JoinResult (C.Parsed JoinResult)) -data instance C.Parsed JoinResult - = JoinResult - {joinId :: (RP.Parsed Std_.Word32) - ,succeeded :: (RP.Parsed Std_.Bool) - ,cap :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed JoinResult)) -deriving instance (Std_.Eq (C.Parsed JoinResult)) -instance (C.Parse JoinResult (C.Parsed JoinResult)) where - parse raw_ = (JoinResult <$> (GH.parseField #joinId raw_) - <*> (GH.parseField #succeeded raw_) - <*> (GH.parseField #cap raw_)) -instance (C.Marshal JoinResult (C.Parsed JoinResult)) where - marshalInto raw_ JoinResult{..} = (do - (GH.encodeField #joinId joinId raw_) - (GH.encodeField #succeeded succeeded raw_) - (GH.encodeField #cap cap raw_) - (Std_.pure ()) - ) -instance (GH.HasField "joinId" GH.Slot JoinResult Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "succeeded" GH.Slot JoinResult Std_.Bool) where - fieldByLabel = (GH.dataField 32 0 1 0) -instance (GH.HasField "cap" GH.Slot JoinResult (Std_.Maybe Basics.AnyPointer)) where - fieldByLabel = (GH.ptrField 0) diff --git a/gen/lib/Capnp/Gen/Capnp/Schema.hs b/gen/lib/Capnp/Gen/Capnp/Schema.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/Schema.hs @@ -0,0 +1,2297 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.Schema where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data Node +type instance (R.ReprFor Node) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node) where + typeId = 16610026722781537303 +instance (C.TypedStruct Node) where + numStructWords = 5 + numStructPtrs = 6 +instance (C.Allocate Node) where + type AllocHint Node = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node (C.Parsed Node)) +instance (C.AllocateList Node) where + type ListAllocHint Node = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node (C.Parsed Node)) +data instance C.Parsed Node + = Node + {id :: (RP.Parsed Std_.Word64) + ,displayName :: (RP.Parsed Basics.Text) + ,displayNamePrefixLength :: (RP.Parsed Std_.Word32) + ,scopeId :: (RP.Parsed Std_.Word64) + ,nestedNodes :: (RP.Parsed (R.List Node'NestedNode)) + ,annotations :: (RP.Parsed (R.List Annotation)) + ,parameters :: (RP.Parsed (R.List Node'Parameter)) + ,isGeneric :: (RP.Parsed Std_.Bool) + ,union' :: (C.Parsed (GH.Which Node))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node)) +deriving instance (Std_.Eq (C.Parsed Node)) +instance (C.Parse Node (C.Parsed Node)) where + parse raw_ = (Node <$> (GH.parseField #id raw_) + <*> (GH.parseField #displayName raw_) + <*> (GH.parseField #displayNamePrefixLength raw_) + <*> (GH.parseField #scopeId raw_) + <*> (GH.parseField #nestedNodes raw_) + <*> (GH.parseField #annotations raw_) + <*> (GH.parseField #parameters raw_) + <*> (GH.parseField #isGeneric raw_) + <*> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Node (C.Parsed Node)) where + marshalInto raw_ Node{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #displayName displayName raw_) + (GH.encodeField #displayNamePrefixLength displayNamePrefixLength raw_) + (GH.encodeField #scopeId scopeId raw_) + (GH.encodeField #nestedNodes nestedNodes raw_) + (GH.encodeField #annotations annotations raw_) + (GH.encodeField #parameters parameters raw_) + (GH.encodeField #isGeneric isGeneric raw_) + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Node) where + unionField = (GH.dataField 32 1 16 0) + data RawWhich Node mut_ + = RW_Node'file (R.Raw () mut_) + | RW_Node'struct (R.Raw Node'struct mut_) + | RW_Node'enum (R.Raw Node'enum mut_) + | RW_Node'interface (R.Raw Node'interface mut_) + | RW_Node'const (R.Raw Node'const mut_) + | RW_Node'annotation (R.Raw Node'annotation mut_) + | RW_Node'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Node'file <$> (GH.readVariant #file struct_)) + 1 -> + (RW_Node'struct <$> (GH.readVariant #struct struct_)) + 2 -> + (RW_Node'enum <$> (GH.readVariant #enum struct_)) + 3 -> + (RW_Node'interface <$> (GH.readVariant #interface struct_)) + 4 -> + (RW_Node'const <$> (GH.readVariant #const struct_)) + 5 -> + (RW_Node'annotation <$> (GH.readVariant #annotation struct_)) + _ -> + (Std_.pure (RW_Node'unknown' tag_)) + data Which Node +instance (GH.HasVariant "file" GH.Slot Node ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "struct" GH.Group Node Node'struct) where + variantByLabel = (GH.Variant GH.groupField 1) +instance (GH.HasVariant "enum" GH.Group Node Node'enum) where + variantByLabel = (GH.Variant GH.groupField 2) +instance (GH.HasVariant "interface" GH.Group Node Node'interface) where + variantByLabel = (GH.Variant GH.groupField 3) +instance (GH.HasVariant "const" GH.Group Node Node'const) where + variantByLabel = (GH.Variant GH.groupField 4) +instance (GH.HasVariant "annotation" GH.Group Node Node'annotation) where + variantByLabel = (GH.Variant GH.groupField 5) +data instance C.Parsed (GH.Which Node) + = Node'file + | Node'struct (RP.Parsed Node'struct) + | Node'enum (RP.Parsed Node'enum) + | Node'interface (RP.Parsed Node'interface) + | Node'const (RP.Parsed Node'const) + | Node'annotation (RP.Parsed Node'annotation) + | Node'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Node))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Node))) +instance (C.Parse (GH.Which Node) (C.Parsed (GH.Which Node))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Node'file _) -> + (Std_.pure Node'file) + (RW_Node'struct rawArg_) -> + (Node'struct <$> (C.parse rawArg_)) + (RW_Node'enum rawArg_) -> + (Node'enum <$> (C.parse rawArg_)) + (RW_Node'interface rawArg_) -> + (Node'interface <$> (C.parse rawArg_)) + (RW_Node'const rawArg_) -> + (Node'const <$> (C.parse rawArg_)) + (RW_Node'annotation rawArg_) -> + (Node'annotation <$> (C.parse rawArg_)) + (RW_Node'unknown' tag_) -> + (Std_.pure (Node'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Node) (C.Parsed (GH.Which Node))) where + marshalInto raw_ parsed_ = case parsed_ of + (Node'file) -> + (GH.encodeVariant #file () (GH.unionStruct raw_)) + (Node'struct arg_) -> + (do + rawGroup_ <- (GH.initVariant #struct (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Node'enum arg_) -> + (do + rawGroup_ <- (GH.initVariant #enum (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Node'interface arg_) -> + (do + rawGroup_ <- (GH.initVariant #interface (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Node'const arg_) -> + (do + rawGroup_ <- (GH.initVariant #const (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Node'annotation arg_) -> + (do + rawGroup_ <- (GH.initVariant #annotation (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Node'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +instance (GH.HasField "id" GH.Slot Node Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "displayName" GH.Slot Node Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "displayNamePrefixLength" GH.Slot Node Std_.Word32) where + fieldByLabel = (GH.dataField 0 1 32 0) +instance (GH.HasField "scopeId" GH.Slot Node Std_.Word64) where + fieldByLabel = (GH.dataField 0 2 64 0) +instance (GH.HasField "nestedNodes" GH.Slot Node (R.List Node'NestedNode)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "annotations" GH.Slot Node (R.List Annotation)) where + fieldByLabel = (GH.ptrField 2) +instance (GH.HasField "parameters" GH.Slot Node (R.List Node'Parameter)) where + fieldByLabel = (GH.ptrField 5) +instance (GH.HasField "isGeneric" GH.Slot Node Std_.Bool) where + fieldByLabel = (GH.dataField 32 4 1 0) +data Node'struct +type instance (R.ReprFor Node'struct) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'struct) where + typeId = 11430331134483579957 +instance (C.TypedStruct Node'struct) where + numStructWords = 5 + numStructPtrs = 6 +instance (C.Allocate Node'struct) where + type AllocHint Node'struct = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'struct (C.Parsed Node'struct)) +instance (C.AllocateList Node'struct) where + type ListAllocHint Node'struct = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'struct (C.Parsed Node'struct)) +data instance C.Parsed Node'struct + = Node'struct' + {dataWordCount :: (RP.Parsed Std_.Word16) + ,pointerCount :: (RP.Parsed Std_.Word16) + ,preferredListEncoding :: (RP.Parsed ElementSize) + ,isGroup :: (RP.Parsed Std_.Bool) + ,discriminantCount :: (RP.Parsed Std_.Word16) + ,discriminantOffset :: (RP.Parsed Std_.Word32) + ,fields :: (RP.Parsed (R.List Field))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'struct)) +deriving instance (Std_.Eq (C.Parsed Node'struct)) +instance (C.Parse Node'struct (C.Parsed Node'struct)) where + parse raw_ = (Node'struct' <$> (GH.parseField #dataWordCount raw_) + <*> (GH.parseField #pointerCount raw_) + <*> (GH.parseField #preferredListEncoding raw_) + <*> (GH.parseField #isGroup raw_) + <*> (GH.parseField #discriminantCount raw_) + <*> (GH.parseField #discriminantOffset raw_) + <*> (GH.parseField #fields raw_)) +instance (C.Marshal Node'struct (C.Parsed Node'struct)) where + marshalInto raw_ Node'struct'{..} = (do + (GH.encodeField #dataWordCount dataWordCount raw_) + (GH.encodeField #pointerCount pointerCount raw_) + (GH.encodeField #preferredListEncoding preferredListEncoding raw_) + (GH.encodeField #isGroup isGroup raw_) + (GH.encodeField #discriminantCount discriminantCount raw_) + (GH.encodeField #discriminantOffset discriminantOffset raw_) + (GH.encodeField #fields fields raw_) + (Std_.pure ()) + ) +instance (GH.HasField "dataWordCount" GH.Slot Node'struct Std_.Word16) where + fieldByLabel = (GH.dataField 48 1 16 0) +instance (GH.HasField "pointerCount" GH.Slot Node'struct Std_.Word16) where + fieldByLabel = (GH.dataField 0 3 16 0) +instance (GH.HasField "preferredListEncoding" GH.Slot Node'struct ElementSize) where + fieldByLabel = (GH.dataField 16 3 16 0) +instance (GH.HasField "isGroup" GH.Slot Node'struct Std_.Bool) where + fieldByLabel = (GH.dataField 32 3 1 0) +instance (GH.HasField "discriminantCount" GH.Slot Node'struct Std_.Word16) where + fieldByLabel = (GH.dataField 48 3 16 0) +instance (GH.HasField "discriminantOffset" GH.Slot Node'struct Std_.Word32) where + fieldByLabel = (GH.dataField 0 4 32 0) +instance (GH.HasField "fields" GH.Slot Node'struct (R.List Field)) where + fieldByLabel = (GH.ptrField 3) +data Node'enum +type instance (R.ReprFor Node'enum) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'enum) where + typeId = 13063450714778629528 +instance (C.TypedStruct Node'enum) where + numStructWords = 5 + numStructPtrs = 6 +instance (C.Allocate Node'enum) where + type AllocHint Node'enum = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'enum (C.Parsed Node'enum)) +instance (C.AllocateList Node'enum) where + type ListAllocHint Node'enum = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'enum (C.Parsed Node'enum)) +data instance C.Parsed Node'enum + = Node'enum' + {enumerants :: (RP.Parsed (R.List Enumerant))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'enum)) +deriving instance (Std_.Eq (C.Parsed Node'enum)) +instance (C.Parse Node'enum (C.Parsed Node'enum)) where + parse raw_ = (Node'enum' <$> (GH.parseField #enumerants raw_)) +instance (C.Marshal Node'enum (C.Parsed Node'enum)) where + marshalInto raw_ Node'enum'{..} = (do + (GH.encodeField #enumerants enumerants raw_) + (Std_.pure ()) + ) +instance (GH.HasField "enumerants" GH.Slot Node'enum (R.List Enumerant)) where + fieldByLabel = (GH.ptrField 3) +data Node'interface +type instance (R.ReprFor Node'interface) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'interface) where + typeId = 16728431493453586831 +instance (C.TypedStruct Node'interface) where + numStructWords = 5 + numStructPtrs = 6 +instance (C.Allocate Node'interface) where + type AllocHint Node'interface = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'interface (C.Parsed Node'interface)) +instance (C.AllocateList Node'interface) where + type ListAllocHint Node'interface = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'interface (C.Parsed Node'interface)) +data instance C.Parsed Node'interface + = Node'interface' + {methods :: (RP.Parsed (R.List Method)) + ,superclasses :: (RP.Parsed (R.List Superclass))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'interface)) +deriving instance (Std_.Eq (C.Parsed Node'interface)) +instance (C.Parse Node'interface (C.Parsed Node'interface)) where + parse raw_ = (Node'interface' <$> (GH.parseField #methods raw_) + <*> (GH.parseField #superclasses raw_)) +instance (C.Marshal Node'interface (C.Parsed Node'interface)) where + marshalInto raw_ Node'interface'{..} = (do + (GH.encodeField #methods methods raw_) + (GH.encodeField #superclasses superclasses raw_) + (Std_.pure ()) + ) +instance (GH.HasField "methods" GH.Slot Node'interface (R.List Method)) where + fieldByLabel = (GH.ptrField 3) +instance (GH.HasField "superclasses" GH.Slot Node'interface (R.List Superclass)) where + fieldByLabel = (GH.ptrField 4) +data Node'const +type instance (R.ReprFor Node'const) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'const) where + typeId = 12793219851699983392 +instance (C.TypedStruct Node'const) where + numStructWords = 5 + numStructPtrs = 6 +instance (C.Allocate Node'const) where + type AllocHint Node'const = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'const (C.Parsed Node'const)) +instance (C.AllocateList Node'const) where + type ListAllocHint Node'const = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'const (C.Parsed Node'const)) +data instance C.Parsed Node'const + = Node'const' + {type_ :: (RP.Parsed Type) + ,value :: (RP.Parsed Value)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'const)) +deriving instance (Std_.Eq (C.Parsed Node'const)) +instance (C.Parse Node'const (C.Parsed Node'const)) where + parse raw_ = (Node'const' <$> (GH.parseField #type_ raw_) + <*> (GH.parseField #value raw_)) +instance (C.Marshal Node'const (C.Parsed Node'const)) where + marshalInto raw_ Node'const'{..} = (do + (GH.encodeField #type_ type_ raw_) + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) +instance (GH.HasField "type_" GH.Slot Node'const Type) where + fieldByLabel = (GH.ptrField 3) +instance (GH.HasField "value" GH.Slot Node'const Value) where + fieldByLabel = (GH.ptrField 4) +data Node'annotation +type instance (R.ReprFor Node'annotation) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'annotation) where + typeId = 17011813041836786320 +instance (C.TypedStruct Node'annotation) where + numStructWords = 5 + numStructPtrs = 6 +instance (C.Allocate Node'annotation) where + type AllocHint Node'annotation = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'annotation (C.Parsed Node'annotation)) +instance (C.AllocateList Node'annotation) where + type ListAllocHint Node'annotation = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'annotation (C.Parsed Node'annotation)) +data instance C.Parsed Node'annotation + = Node'annotation' + {type_ :: (RP.Parsed Type) + ,targetsFile :: (RP.Parsed Std_.Bool) + ,targetsConst :: (RP.Parsed Std_.Bool) + ,targetsEnum :: (RP.Parsed Std_.Bool) + ,targetsEnumerant :: (RP.Parsed Std_.Bool) + ,targetsStruct :: (RP.Parsed Std_.Bool) + ,targetsField :: (RP.Parsed Std_.Bool) + ,targetsUnion :: (RP.Parsed Std_.Bool) + ,targetsGroup :: (RP.Parsed Std_.Bool) + ,targetsInterface :: (RP.Parsed Std_.Bool) + ,targetsMethod :: (RP.Parsed Std_.Bool) + ,targetsParam :: (RP.Parsed Std_.Bool) + ,targetsAnnotation :: (RP.Parsed Std_.Bool)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'annotation)) +deriving instance (Std_.Eq (C.Parsed Node'annotation)) +instance (C.Parse Node'annotation (C.Parsed Node'annotation)) where + parse raw_ = (Node'annotation' <$> (GH.parseField #type_ raw_) + <*> (GH.parseField #targetsFile raw_) + <*> (GH.parseField #targetsConst raw_) + <*> (GH.parseField #targetsEnum raw_) + <*> (GH.parseField #targetsEnumerant raw_) + <*> (GH.parseField #targetsStruct raw_) + <*> (GH.parseField #targetsField raw_) + <*> (GH.parseField #targetsUnion raw_) + <*> (GH.parseField #targetsGroup raw_) + <*> (GH.parseField #targetsInterface raw_) + <*> (GH.parseField #targetsMethod raw_) + <*> (GH.parseField #targetsParam raw_) + <*> (GH.parseField #targetsAnnotation raw_)) +instance (C.Marshal Node'annotation (C.Parsed Node'annotation)) where + marshalInto raw_ Node'annotation'{..} = (do + (GH.encodeField #type_ type_ raw_) + (GH.encodeField #targetsFile targetsFile raw_) + (GH.encodeField #targetsConst targetsConst raw_) + (GH.encodeField #targetsEnum targetsEnum raw_) + (GH.encodeField #targetsEnumerant targetsEnumerant raw_) + (GH.encodeField #targetsStruct targetsStruct raw_) + (GH.encodeField #targetsField targetsField raw_) + (GH.encodeField #targetsUnion targetsUnion raw_) + (GH.encodeField #targetsGroup targetsGroup raw_) + (GH.encodeField #targetsInterface targetsInterface raw_) + (GH.encodeField #targetsMethod targetsMethod raw_) + (GH.encodeField #targetsParam targetsParam raw_) + (GH.encodeField #targetsAnnotation targetsAnnotation raw_) + (Std_.pure ()) + ) +instance (GH.HasField "type_" GH.Slot Node'annotation Type) where + fieldByLabel = (GH.ptrField 3) +instance (GH.HasField "targetsFile" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 48 1 1 0) +instance (GH.HasField "targetsConst" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 49 1 1 0) +instance (GH.HasField "targetsEnum" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 50 1 1 0) +instance (GH.HasField "targetsEnumerant" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 51 1 1 0) +instance (GH.HasField "targetsStruct" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 52 1 1 0) +instance (GH.HasField "targetsField" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 53 1 1 0) +instance (GH.HasField "targetsUnion" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 54 1 1 0) +instance (GH.HasField "targetsGroup" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 55 1 1 0) +instance (GH.HasField "targetsInterface" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 56 1 1 0) +instance (GH.HasField "targetsMethod" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 57 1 1 0) +instance (GH.HasField "targetsParam" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 58 1 1 0) +instance (GH.HasField "targetsAnnotation" GH.Slot Node'annotation Std_.Bool) where + fieldByLabel = (GH.dataField 59 1 1 0) +data Node'Parameter +type instance (R.ReprFor Node'Parameter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'Parameter) where + typeId = 13353766412138554289 +instance (C.TypedStruct Node'Parameter) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Node'Parameter) where + type AllocHint Node'Parameter = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'Parameter (C.Parsed Node'Parameter)) +instance (C.AllocateList Node'Parameter) where + type ListAllocHint Node'Parameter = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'Parameter (C.Parsed Node'Parameter)) +data instance C.Parsed Node'Parameter + = Node'Parameter + {name :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'Parameter)) +deriving instance (Std_.Eq (C.Parsed Node'Parameter)) +instance (C.Parse Node'Parameter (C.Parsed Node'Parameter)) where + parse raw_ = (Node'Parameter <$> (GH.parseField #name raw_)) +instance (C.Marshal Node'Parameter (C.Parsed Node'Parameter)) where + marshalInto raw_ Node'Parameter{..} = (do + (GH.encodeField #name name raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot Node'Parameter Basics.Text) where + fieldByLabel = (GH.ptrField 0) +data Node'NestedNode +type instance (R.ReprFor Node'NestedNode) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'NestedNode) where + typeId = 16050641862814319170 +instance (C.TypedStruct Node'NestedNode) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Node'NestedNode) where + type AllocHint Node'NestedNode = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'NestedNode (C.Parsed Node'NestedNode)) +instance (C.AllocateList Node'NestedNode) where + type ListAllocHint Node'NestedNode = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'NestedNode (C.Parsed Node'NestedNode)) +data instance C.Parsed Node'NestedNode + = Node'NestedNode + {name :: (RP.Parsed Basics.Text) + ,id :: (RP.Parsed Std_.Word64)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'NestedNode)) +deriving instance (Std_.Eq (C.Parsed Node'NestedNode)) +instance (C.Parse Node'NestedNode (C.Parsed Node'NestedNode)) where + parse raw_ = (Node'NestedNode <$> (GH.parseField #name raw_) + <*> (GH.parseField #id raw_)) +instance (C.Marshal Node'NestedNode (C.Parsed Node'NestedNode)) where + marshalInto raw_ Node'NestedNode{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #id id raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot Node'NestedNode Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "id" GH.Slot Node'NestedNode Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +data Node'SourceInfo +type instance (R.ReprFor Node'SourceInfo) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'SourceInfo) where + typeId = 17549997658772559790 +instance (C.TypedStruct Node'SourceInfo) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate Node'SourceInfo) where + type AllocHint Node'SourceInfo = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'SourceInfo (C.Parsed Node'SourceInfo)) +instance (C.AllocateList Node'SourceInfo) where + type ListAllocHint Node'SourceInfo = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'SourceInfo (C.Parsed Node'SourceInfo)) +data instance C.Parsed Node'SourceInfo + = Node'SourceInfo + {id :: (RP.Parsed Std_.Word64) + ,docComment :: (RP.Parsed Basics.Text) + ,members :: (RP.Parsed (R.List Node'SourceInfo'Member))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'SourceInfo)) +deriving instance (Std_.Eq (C.Parsed Node'SourceInfo)) +instance (C.Parse Node'SourceInfo (C.Parsed Node'SourceInfo)) where + parse raw_ = (Node'SourceInfo <$> (GH.parseField #id raw_) + <*> (GH.parseField #docComment raw_) + <*> (GH.parseField #members raw_)) +instance (C.Marshal Node'SourceInfo (C.Parsed Node'SourceInfo)) where + marshalInto raw_ Node'SourceInfo{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #docComment docComment raw_) + (GH.encodeField #members members raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot Node'SourceInfo Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "docComment" GH.Slot Node'SourceInfo Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "members" GH.Slot Node'SourceInfo (R.List Node'SourceInfo'Member)) where + fieldByLabel = (GH.ptrField 1) +data Node'SourceInfo'Member +type instance (R.ReprFor Node'SourceInfo'Member) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'SourceInfo'Member) where + typeId = 14031686161526562722 +instance (C.TypedStruct Node'SourceInfo'Member) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Node'SourceInfo'Member) where + type AllocHint Node'SourceInfo'Member = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) +instance (C.AllocateList Node'SourceInfo'Member) where + type ListAllocHint Node'SourceInfo'Member = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) +data instance C.Parsed Node'SourceInfo'Member + = Node'SourceInfo'Member + {docComment :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Node'SourceInfo'Member)) +deriving instance (Std_.Eq (C.Parsed Node'SourceInfo'Member)) +instance (C.Parse Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) where + parse raw_ = (Node'SourceInfo'Member <$> (GH.parseField #docComment raw_)) +instance (C.Marshal Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) where + marshalInto raw_ Node'SourceInfo'Member{..} = (do + (GH.encodeField #docComment docComment raw_) + (Std_.pure ()) + ) +instance (GH.HasField "docComment" GH.Slot Node'SourceInfo'Member Basics.Text) where + fieldByLabel = (GH.ptrField 0) +data Field +type instance (R.ReprFor Field) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field) where + typeId = 11145653318641710175 +instance (C.TypedStruct Field) where + numStructWords = 3 + numStructPtrs = 4 +instance (C.Allocate Field) where + type AllocHint Field = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Field (C.Parsed Field)) +instance (C.AllocateList Field) where + type ListAllocHint Field = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Field (C.Parsed Field)) +data instance C.Parsed Field + = Field + {name :: (RP.Parsed Basics.Text) + ,codeOrder :: (RP.Parsed Std_.Word16) + ,annotations :: (RP.Parsed (R.List Annotation)) + ,discriminantValue :: (RP.Parsed Std_.Word16) + ,ordinal :: (RP.Parsed Field'ordinal) + ,union' :: (C.Parsed (GH.Which Field))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Field)) +deriving instance (Std_.Eq (C.Parsed Field)) +instance (C.Parse Field (C.Parsed Field)) where + parse raw_ = (Field <$> (GH.parseField #name raw_) + <*> (GH.parseField #codeOrder raw_) + <*> (GH.parseField #annotations raw_) + <*> (GH.parseField #discriminantValue raw_) + <*> (GH.parseField #ordinal raw_) + <*> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Field (C.Parsed Field)) where + marshalInto raw_ Field{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #codeOrder codeOrder raw_) + (GH.encodeField #annotations annotations raw_) + (GH.encodeField #discriminantValue discriminantValue raw_) + (do + group_ <- (GH.readField #ordinal raw_) + (C.marshalInto group_ ordinal) + ) + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Field) where + unionField = (GH.dataField 0 1 16 0) + data RawWhich Field mut_ + = RW_Field'slot (R.Raw Field'slot mut_) + | RW_Field'group (R.Raw Field'group mut_) + | RW_Field'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Field'slot <$> (GH.readVariant #slot struct_)) + 1 -> + (RW_Field'group <$> (GH.readVariant #group struct_)) + _ -> + (Std_.pure (RW_Field'unknown' tag_)) + data Which Field +instance (GH.HasVariant "slot" GH.Group Field Field'slot) where + variantByLabel = (GH.Variant GH.groupField 0) +instance (GH.HasVariant "group" GH.Group Field Field'group) where + variantByLabel = (GH.Variant GH.groupField 1) +data instance C.Parsed (GH.Which Field) + = Field'slot (RP.Parsed Field'slot) + | Field'group (RP.Parsed Field'group) + | Field'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Field))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Field))) +instance (C.Parse (GH.Which Field) (C.Parsed (GH.Which Field))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Field'slot rawArg_) -> + (Field'slot <$> (C.parse rawArg_)) + (RW_Field'group rawArg_) -> + (Field'group <$> (C.parse rawArg_)) + (RW_Field'unknown' tag_) -> + (Std_.pure (Field'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Field) (C.Parsed (GH.Which Field))) where + marshalInto raw_ parsed_ = case parsed_ of + (Field'slot arg_) -> + (do + rawGroup_ <- (GH.initVariant #slot (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Field'group arg_) -> + (do + rawGroup_ <- (GH.initVariant #group (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Field'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +instance (GH.HasField "name" GH.Slot Field Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "codeOrder" GH.Slot Field Std_.Word16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "annotations" GH.Slot Field (R.List Annotation)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "discriminantValue" GH.Slot Field Std_.Word16) where + fieldByLabel = (GH.dataField 16 0 16 65535) +instance (GH.HasField "ordinal" GH.Group Field Field'ordinal) where + fieldByLabel = GH.groupField +data Field'slot +type instance (R.ReprFor Field'slot) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field'slot) where + typeId = 14133145859926553711 +instance (C.TypedStruct Field'slot) where + numStructWords = 3 + numStructPtrs = 4 +instance (C.Allocate Field'slot) where + type AllocHint Field'slot = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Field'slot (C.Parsed Field'slot)) +instance (C.AllocateList Field'slot) where + type ListAllocHint Field'slot = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Field'slot (C.Parsed Field'slot)) +data instance C.Parsed Field'slot + = Field'slot' + {offset :: (RP.Parsed Std_.Word32) + ,type_ :: (RP.Parsed Type) + ,defaultValue :: (RP.Parsed Value) + ,hadExplicitDefault :: (RP.Parsed Std_.Bool)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Field'slot)) +deriving instance (Std_.Eq (C.Parsed Field'slot)) +instance (C.Parse Field'slot (C.Parsed Field'slot)) where + parse raw_ = (Field'slot' <$> (GH.parseField #offset raw_) + <*> (GH.parseField #type_ raw_) + <*> (GH.parseField #defaultValue raw_) + <*> (GH.parseField #hadExplicitDefault raw_)) +instance (C.Marshal Field'slot (C.Parsed Field'slot)) where + marshalInto raw_ Field'slot'{..} = (do + (GH.encodeField #offset offset raw_) + (GH.encodeField #type_ type_ raw_) + (GH.encodeField #defaultValue defaultValue raw_) + (GH.encodeField #hadExplicitDefault hadExplicitDefault raw_) + (Std_.pure ()) + ) +instance (GH.HasField "offset" GH.Slot Field'slot Std_.Word32) where + fieldByLabel = (GH.dataField 32 0 32 0) +instance (GH.HasField "type_" GH.Slot Field'slot Type) where + fieldByLabel = (GH.ptrField 2) +instance (GH.HasField "defaultValue" GH.Slot Field'slot Value) where + fieldByLabel = (GH.ptrField 3) +instance (GH.HasField "hadExplicitDefault" GH.Slot Field'slot Std_.Bool) where + fieldByLabel = (GH.dataField 0 2 1 0) +data Field'group +type instance (R.ReprFor Field'group) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field'group) where + typeId = 14626792032033250577 +instance (C.TypedStruct Field'group) where + numStructWords = 3 + numStructPtrs = 4 +instance (C.Allocate Field'group) where + type AllocHint Field'group = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Field'group (C.Parsed Field'group)) +instance (C.AllocateList Field'group) where + type ListAllocHint Field'group = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Field'group (C.Parsed Field'group)) +data instance C.Parsed Field'group + = Field'group' + {typeId :: (RP.Parsed Std_.Word64)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Field'group)) +deriving instance (Std_.Eq (C.Parsed Field'group)) +instance (C.Parse Field'group (C.Parsed Field'group)) where + parse raw_ = (Field'group' <$> (GH.parseField #typeId raw_)) +instance (C.Marshal Field'group (C.Parsed Field'group)) where + marshalInto raw_ Field'group'{..} = (do + (GH.encodeField #typeId typeId raw_) + (Std_.pure ()) + ) +instance (GH.HasField "typeId" GH.Slot Field'group Std_.Word64) where + fieldByLabel = (GH.dataField 0 2 64 0) +data Field'ordinal +type instance (R.ReprFor Field'ordinal) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field'ordinal) where + typeId = 13515537513213004774 +instance (C.TypedStruct Field'ordinal) where + numStructWords = 3 + numStructPtrs = 4 +instance (C.Allocate Field'ordinal) where + type AllocHint Field'ordinal = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Field'ordinal (C.Parsed Field'ordinal)) +instance (C.AllocateList Field'ordinal) where + type ListAllocHint Field'ordinal = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Field'ordinal (C.Parsed Field'ordinal)) +data instance C.Parsed Field'ordinal + = Field'ordinal' + {union' :: (C.Parsed (GH.Which Field'ordinal))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Field'ordinal)) +deriving instance (Std_.Eq (C.Parsed Field'ordinal)) +instance (C.Parse Field'ordinal (C.Parsed Field'ordinal)) where + parse raw_ = (Field'ordinal' <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Field'ordinal (C.Parsed Field'ordinal)) where + marshalInto raw_ Field'ordinal'{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Field'ordinal) where + unionField = (GH.dataField 16 1 16 0) + data RawWhich Field'ordinal mut_ + = RW_Field'ordinal'implicit (R.Raw () mut_) + | RW_Field'ordinal'explicit (R.Raw Std_.Word16 mut_) + | RW_Field'ordinal'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Field'ordinal'implicit <$> (GH.readVariant #implicit struct_)) + 1 -> + (RW_Field'ordinal'explicit <$> (GH.readVariant #explicit struct_)) + _ -> + (Std_.pure (RW_Field'ordinal'unknown' tag_)) + data Which Field'ordinal +instance (GH.HasVariant "implicit" GH.Slot Field'ordinal ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "explicit" GH.Slot Field'ordinal Std_.Word16) where + variantByLabel = (GH.Variant (GH.dataField 32 1 16 0) 1) +data instance C.Parsed (GH.Which Field'ordinal) + = Field'ordinal'implicit + | Field'ordinal'explicit (RP.Parsed Std_.Word16) + | Field'ordinal'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Field'ordinal))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Field'ordinal))) +instance (C.Parse (GH.Which Field'ordinal) (C.Parsed (GH.Which Field'ordinal))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Field'ordinal'implicit _) -> + (Std_.pure Field'ordinal'implicit) + (RW_Field'ordinal'explicit rawArg_) -> + (Field'ordinal'explicit <$> (C.parse rawArg_)) + (RW_Field'ordinal'unknown' tag_) -> + (Std_.pure (Field'ordinal'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Field'ordinal) (C.Parsed (GH.Which Field'ordinal))) where + marshalInto raw_ parsed_ = case parsed_ of + (Field'ordinal'implicit) -> + (GH.encodeVariant #implicit () (GH.unionStruct raw_)) + (Field'ordinal'explicit arg_) -> + (GH.encodeVariant #explicit arg_ (GH.unionStruct raw_)) + (Field'ordinal'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +field'noDiscriminant :: Std_.Word16 +field'noDiscriminant = (C.fromWord 65535) +data Enumerant +type instance (R.ReprFor Enumerant) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Enumerant) where + typeId = 10919677598968879693 +instance (C.TypedStruct Enumerant) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate Enumerant) where + type AllocHint Enumerant = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Enumerant (C.Parsed Enumerant)) +instance (C.AllocateList Enumerant) where + type ListAllocHint Enumerant = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Enumerant (C.Parsed Enumerant)) +data instance C.Parsed Enumerant + = Enumerant + {name :: (RP.Parsed Basics.Text) + ,codeOrder :: (RP.Parsed Std_.Word16) + ,annotations :: (RP.Parsed (R.List Annotation))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Enumerant)) +deriving instance (Std_.Eq (C.Parsed Enumerant)) +instance (C.Parse Enumerant (C.Parsed Enumerant)) where + parse raw_ = (Enumerant <$> (GH.parseField #name raw_) + <*> (GH.parseField #codeOrder raw_) + <*> (GH.parseField #annotations raw_)) +instance (C.Marshal Enumerant (C.Parsed Enumerant)) where + marshalInto raw_ Enumerant{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #codeOrder codeOrder raw_) + (GH.encodeField #annotations annotations raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot Enumerant Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "codeOrder" GH.Slot Enumerant Std_.Word16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "annotations" GH.Slot Enumerant (R.List Annotation)) where + fieldByLabel = (GH.ptrField 1) +data Superclass +type instance (R.ReprFor Superclass) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Superclass) where + typeId = 12220001500510083064 +instance (C.TypedStruct Superclass) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Superclass) where + type AllocHint Superclass = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Superclass (C.Parsed Superclass)) +instance (C.AllocateList Superclass) where + type ListAllocHint Superclass = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Superclass (C.Parsed Superclass)) +data instance C.Parsed Superclass + = Superclass + {id :: (RP.Parsed Std_.Word64) + ,brand :: (RP.Parsed Brand)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Superclass)) +deriving instance (Std_.Eq (C.Parsed Superclass)) +instance (C.Parse Superclass (C.Parsed Superclass)) where + parse raw_ = (Superclass <$> (GH.parseField #id raw_) + <*> (GH.parseField #brand raw_)) +instance (C.Marshal Superclass (C.Parsed Superclass)) where + marshalInto raw_ Superclass{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #brand brand raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot Superclass Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "brand" GH.Slot Superclass Brand) where + fieldByLabel = (GH.ptrField 0) +data Method +type instance (R.ReprFor Method) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Method) where + typeId = 10736806783679155584 +instance (C.TypedStruct Method) where + numStructWords = 3 + numStructPtrs = 5 +instance (C.Allocate Method) where + type AllocHint Method = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Method (C.Parsed Method)) +instance (C.AllocateList Method) where + type ListAllocHint Method = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Method (C.Parsed Method)) +data instance C.Parsed Method + = Method + {name :: (RP.Parsed Basics.Text) + ,codeOrder :: (RP.Parsed Std_.Word16) + ,paramStructType :: (RP.Parsed Std_.Word64) + ,resultStructType :: (RP.Parsed Std_.Word64) + ,annotations :: (RP.Parsed (R.List Annotation)) + ,paramBrand :: (RP.Parsed Brand) + ,resultBrand :: (RP.Parsed Brand) + ,implicitParameters :: (RP.Parsed (R.List Node'Parameter))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Method)) +deriving instance (Std_.Eq (C.Parsed Method)) +instance (C.Parse Method (C.Parsed Method)) where + parse raw_ = (Method <$> (GH.parseField #name raw_) + <*> (GH.parseField #codeOrder raw_) + <*> (GH.parseField #paramStructType raw_) + <*> (GH.parseField #resultStructType raw_) + <*> (GH.parseField #annotations raw_) + <*> (GH.parseField #paramBrand raw_) + <*> (GH.parseField #resultBrand raw_) + <*> (GH.parseField #implicitParameters raw_)) +instance (C.Marshal Method (C.Parsed Method)) where + marshalInto raw_ Method{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #codeOrder codeOrder raw_) + (GH.encodeField #paramStructType paramStructType raw_) + (GH.encodeField #resultStructType resultStructType raw_) + (GH.encodeField #annotations annotations raw_) + (GH.encodeField #paramBrand paramBrand raw_) + (GH.encodeField #resultBrand resultBrand raw_) + (GH.encodeField #implicitParameters implicitParameters raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot Method Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "codeOrder" GH.Slot Method Std_.Word16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "paramStructType" GH.Slot Method Std_.Word64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "resultStructType" GH.Slot Method Std_.Word64) where + fieldByLabel = (GH.dataField 0 2 64 0) +instance (GH.HasField "annotations" GH.Slot Method (R.List Annotation)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "paramBrand" GH.Slot Method Brand) where + fieldByLabel = (GH.ptrField 2) +instance (GH.HasField "resultBrand" GH.Slot Method Brand) where + fieldByLabel = (GH.ptrField 3) +instance (GH.HasField "implicitParameters" GH.Slot Method (R.List Node'Parameter)) where + fieldByLabel = (GH.ptrField 4) +data Type +type instance (R.ReprFor Type) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type) where + typeId = 15020482145304562784 +instance (C.TypedStruct Type) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type) where + type AllocHint Type = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type (C.Parsed Type)) +instance (C.AllocateList Type) where + type ListAllocHint Type = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type (C.Parsed Type)) +data instance C.Parsed Type + = Type + {union' :: (C.Parsed (GH.Which Type))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type)) +deriving instance (Std_.Eq (C.Parsed Type)) +instance (C.Parse Type (C.Parsed Type)) where + parse raw_ = (Type <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Type (C.Parsed Type)) where + marshalInto raw_ Type{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Type) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Type mut_ + = RW_Type'void (R.Raw () mut_) + | RW_Type'bool (R.Raw () mut_) + | RW_Type'int8 (R.Raw () mut_) + | RW_Type'int16 (R.Raw () mut_) + | RW_Type'int32 (R.Raw () mut_) + | RW_Type'int64 (R.Raw () mut_) + | RW_Type'uint8 (R.Raw () mut_) + | RW_Type'uint16 (R.Raw () mut_) + | RW_Type'uint32 (R.Raw () mut_) + | RW_Type'uint64 (R.Raw () mut_) + | RW_Type'float32 (R.Raw () mut_) + | RW_Type'float64 (R.Raw () mut_) + | RW_Type'text (R.Raw () mut_) + | RW_Type'data_ (R.Raw () mut_) + | RW_Type'list (R.Raw Type'list mut_) + | RW_Type'enum (R.Raw Type'enum mut_) + | RW_Type'struct (R.Raw Type'struct mut_) + | RW_Type'interface (R.Raw Type'interface mut_) + | RW_Type'anyPointer (R.Raw Type'anyPointer mut_) + | RW_Type'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Type'void <$> (GH.readVariant #void struct_)) + 1 -> + (RW_Type'bool <$> (GH.readVariant #bool struct_)) + 2 -> + (RW_Type'int8 <$> (GH.readVariant #int8 struct_)) + 3 -> + (RW_Type'int16 <$> (GH.readVariant #int16 struct_)) + 4 -> + (RW_Type'int32 <$> (GH.readVariant #int32 struct_)) + 5 -> + (RW_Type'int64 <$> (GH.readVariant #int64 struct_)) + 6 -> + (RW_Type'uint8 <$> (GH.readVariant #uint8 struct_)) + 7 -> + (RW_Type'uint16 <$> (GH.readVariant #uint16 struct_)) + 8 -> + (RW_Type'uint32 <$> (GH.readVariant #uint32 struct_)) + 9 -> + (RW_Type'uint64 <$> (GH.readVariant #uint64 struct_)) + 10 -> + (RW_Type'float32 <$> (GH.readVariant #float32 struct_)) + 11 -> + (RW_Type'float64 <$> (GH.readVariant #float64 struct_)) + 12 -> + (RW_Type'text <$> (GH.readVariant #text struct_)) + 13 -> + (RW_Type'data_ <$> (GH.readVariant #data_ struct_)) + 14 -> + (RW_Type'list <$> (GH.readVariant #list struct_)) + 15 -> + (RW_Type'enum <$> (GH.readVariant #enum struct_)) + 16 -> + (RW_Type'struct <$> (GH.readVariant #struct struct_)) + 17 -> + (RW_Type'interface <$> (GH.readVariant #interface struct_)) + 18 -> + (RW_Type'anyPointer <$> (GH.readVariant #anyPointer struct_)) + _ -> + (Std_.pure (RW_Type'unknown' tag_)) + data Which Type +instance (GH.HasVariant "void" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "bool" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 1) +instance (GH.HasVariant "int8" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 2) +instance (GH.HasVariant "int16" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 3) +instance (GH.HasVariant "int32" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 4) +instance (GH.HasVariant "int64" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 5) +instance (GH.HasVariant "uint8" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 6) +instance (GH.HasVariant "uint16" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 7) +instance (GH.HasVariant "uint32" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 8) +instance (GH.HasVariant "uint64" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 9) +instance (GH.HasVariant "float32" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 10) +instance (GH.HasVariant "float64" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 11) +instance (GH.HasVariant "text" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 12) +instance (GH.HasVariant "data_" GH.Slot Type ()) where + variantByLabel = (GH.Variant GH.voidField 13) +instance (GH.HasVariant "list" GH.Group Type Type'list) where + variantByLabel = (GH.Variant GH.groupField 14) +instance (GH.HasVariant "enum" GH.Group Type Type'enum) where + variantByLabel = (GH.Variant GH.groupField 15) +instance (GH.HasVariant "struct" GH.Group Type Type'struct) where + variantByLabel = (GH.Variant GH.groupField 16) +instance (GH.HasVariant "interface" GH.Group Type Type'interface) where + variantByLabel = (GH.Variant GH.groupField 17) +instance (GH.HasVariant "anyPointer" GH.Group Type Type'anyPointer) where + variantByLabel = (GH.Variant GH.groupField 18) +data instance C.Parsed (GH.Which Type) + = Type'void + | Type'bool + | Type'int8 + | Type'int16 + | Type'int32 + | Type'int64 + | Type'uint8 + | Type'uint16 + | Type'uint32 + | Type'uint64 + | Type'float32 + | Type'float64 + | Type'text + | Type'data_ + | Type'list (RP.Parsed Type'list) + | Type'enum (RP.Parsed Type'enum) + | Type'struct (RP.Parsed Type'struct) + | Type'interface (RP.Parsed Type'interface) + | Type'anyPointer (RP.Parsed Type'anyPointer) + | Type'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Type))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Type))) +instance (C.Parse (GH.Which Type) (C.Parsed (GH.Which Type))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Type'void _) -> + (Std_.pure Type'void) + (RW_Type'bool _) -> + (Std_.pure Type'bool) + (RW_Type'int8 _) -> + (Std_.pure Type'int8) + (RW_Type'int16 _) -> + (Std_.pure Type'int16) + (RW_Type'int32 _) -> + (Std_.pure Type'int32) + (RW_Type'int64 _) -> + (Std_.pure Type'int64) + (RW_Type'uint8 _) -> + (Std_.pure Type'uint8) + (RW_Type'uint16 _) -> + (Std_.pure Type'uint16) + (RW_Type'uint32 _) -> + (Std_.pure Type'uint32) + (RW_Type'uint64 _) -> + (Std_.pure Type'uint64) + (RW_Type'float32 _) -> + (Std_.pure Type'float32) + (RW_Type'float64 _) -> + (Std_.pure Type'float64) + (RW_Type'text _) -> + (Std_.pure Type'text) + (RW_Type'data_ _) -> + (Std_.pure Type'data_) + (RW_Type'list rawArg_) -> + (Type'list <$> (C.parse rawArg_)) + (RW_Type'enum rawArg_) -> + (Type'enum <$> (C.parse rawArg_)) + (RW_Type'struct rawArg_) -> + (Type'struct <$> (C.parse rawArg_)) + (RW_Type'interface rawArg_) -> + (Type'interface <$> (C.parse rawArg_)) + (RW_Type'anyPointer rawArg_) -> + (Type'anyPointer <$> (C.parse rawArg_)) + (RW_Type'unknown' tag_) -> + (Std_.pure (Type'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Type) (C.Parsed (GH.Which Type))) where + marshalInto raw_ parsed_ = case parsed_ of + (Type'void) -> + (GH.encodeVariant #void () (GH.unionStruct raw_)) + (Type'bool) -> + (GH.encodeVariant #bool () (GH.unionStruct raw_)) + (Type'int8) -> + (GH.encodeVariant #int8 () (GH.unionStruct raw_)) + (Type'int16) -> + (GH.encodeVariant #int16 () (GH.unionStruct raw_)) + (Type'int32) -> + (GH.encodeVariant #int32 () (GH.unionStruct raw_)) + (Type'int64) -> + (GH.encodeVariant #int64 () (GH.unionStruct raw_)) + (Type'uint8) -> + (GH.encodeVariant #uint8 () (GH.unionStruct raw_)) + (Type'uint16) -> + (GH.encodeVariant #uint16 () (GH.unionStruct raw_)) + (Type'uint32) -> + (GH.encodeVariant #uint32 () (GH.unionStruct raw_)) + (Type'uint64) -> + (GH.encodeVariant #uint64 () (GH.unionStruct raw_)) + (Type'float32) -> + (GH.encodeVariant #float32 () (GH.unionStruct raw_)) + (Type'float64) -> + (GH.encodeVariant #float64 () (GH.unionStruct raw_)) + (Type'text) -> + (GH.encodeVariant #text () (GH.unionStruct raw_)) + (Type'data_) -> + (GH.encodeVariant #data_ () (GH.unionStruct raw_)) + (Type'list arg_) -> + (do + rawGroup_ <- (GH.initVariant #list (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'enum arg_) -> + (do + rawGroup_ <- (GH.initVariant #enum (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'struct arg_) -> + (do + rawGroup_ <- (GH.initVariant #struct (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'interface arg_) -> + (do + rawGroup_ <- (GH.initVariant #interface (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'anyPointer arg_) -> + (do + rawGroup_ <- (GH.initVariant #anyPointer (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Type'list +type instance (R.ReprFor Type'list) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'list) where + typeId = 9792858745991129751 +instance (C.TypedStruct Type'list) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'list) where + type AllocHint Type'list = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'list (C.Parsed Type'list)) +instance (C.AllocateList Type'list) where + type ListAllocHint Type'list = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'list (C.Parsed Type'list)) +data instance C.Parsed Type'list + = Type'list' + {elementType :: (RP.Parsed Type)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'list)) +deriving instance (Std_.Eq (C.Parsed Type'list)) +instance (C.Parse Type'list (C.Parsed Type'list)) where + parse raw_ = (Type'list' <$> (GH.parseField #elementType raw_)) +instance (C.Marshal Type'list (C.Parsed Type'list)) where + marshalInto raw_ Type'list'{..} = (do + (GH.encodeField #elementType elementType raw_) + (Std_.pure ()) + ) +instance (GH.HasField "elementType" GH.Slot Type'list Type) where + fieldByLabel = (GH.ptrField 0) +data Type'enum +type instance (R.ReprFor Type'enum) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'enum) where + typeId = 11389172934837766057 +instance (C.TypedStruct Type'enum) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'enum) where + type AllocHint Type'enum = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'enum (C.Parsed Type'enum)) +instance (C.AllocateList Type'enum) where + type ListAllocHint Type'enum = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'enum (C.Parsed Type'enum)) +data instance C.Parsed Type'enum + = Type'enum' + {typeId :: (RP.Parsed Std_.Word64) + ,brand :: (RP.Parsed Brand)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'enum)) +deriving instance (Std_.Eq (C.Parsed Type'enum)) +instance (C.Parse Type'enum (C.Parsed Type'enum)) where + parse raw_ = (Type'enum' <$> (GH.parseField #typeId raw_) + <*> (GH.parseField #brand raw_)) +instance (C.Marshal Type'enum (C.Parsed Type'enum)) where + marshalInto raw_ Type'enum'{..} = (do + (GH.encodeField #typeId typeId raw_) + (GH.encodeField #brand brand raw_) + (Std_.pure ()) + ) +instance (GH.HasField "typeId" GH.Slot Type'enum Std_.Word64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "brand" GH.Slot Type'enum Brand) where + fieldByLabel = (GH.ptrField 0) +data Type'struct +type instance (R.ReprFor Type'struct) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'struct) where + typeId = 12410354185295152851 +instance (C.TypedStruct Type'struct) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'struct) where + type AllocHint Type'struct = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'struct (C.Parsed Type'struct)) +instance (C.AllocateList Type'struct) where + type ListAllocHint Type'struct = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'struct (C.Parsed Type'struct)) +data instance C.Parsed Type'struct + = Type'struct' + {typeId :: (RP.Parsed Std_.Word64) + ,brand :: (RP.Parsed Brand)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'struct)) +deriving instance (Std_.Eq (C.Parsed Type'struct)) +instance (C.Parse Type'struct (C.Parsed Type'struct)) where + parse raw_ = (Type'struct' <$> (GH.parseField #typeId raw_) + <*> (GH.parseField #brand raw_)) +instance (C.Marshal Type'struct (C.Parsed Type'struct)) where + marshalInto raw_ Type'struct'{..} = (do + (GH.encodeField #typeId typeId raw_) + (GH.encodeField #brand brand raw_) + (Std_.pure ()) + ) +instance (GH.HasField "typeId" GH.Slot Type'struct Std_.Word64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "brand" GH.Slot Type'struct Brand) where + fieldByLabel = (GH.ptrField 0) +data Type'interface +type instance (R.ReprFor Type'interface) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'interface) where + typeId = 17116997365232503999 +instance (C.TypedStruct Type'interface) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'interface) where + type AllocHint Type'interface = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'interface (C.Parsed Type'interface)) +instance (C.AllocateList Type'interface) where + type ListAllocHint Type'interface = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'interface (C.Parsed Type'interface)) +data instance C.Parsed Type'interface + = Type'interface' + {typeId :: (RP.Parsed Std_.Word64) + ,brand :: (RP.Parsed Brand)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'interface)) +deriving instance (Std_.Eq (C.Parsed Type'interface)) +instance (C.Parse Type'interface (C.Parsed Type'interface)) where + parse raw_ = (Type'interface' <$> (GH.parseField #typeId raw_) + <*> (GH.parseField #brand raw_)) +instance (C.Marshal Type'interface (C.Parsed Type'interface)) where + marshalInto raw_ Type'interface'{..} = (do + (GH.encodeField #typeId typeId raw_) + (GH.encodeField #brand brand raw_) + (Std_.pure ()) + ) +instance (GH.HasField "typeId" GH.Slot Type'interface Std_.Word64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "brand" GH.Slot Type'interface Brand) where + fieldByLabel = (GH.ptrField 0) +data Type'anyPointer +type instance (R.ReprFor Type'anyPointer) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer) where + typeId = 14003731834718800369 +instance (C.TypedStruct Type'anyPointer) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'anyPointer) where + type AllocHint Type'anyPointer = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'anyPointer (C.Parsed Type'anyPointer)) +instance (C.AllocateList Type'anyPointer) where + type ListAllocHint Type'anyPointer = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'anyPointer (C.Parsed Type'anyPointer)) +data instance C.Parsed Type'anyPointer + = Type'anyPointer' + {union' :: (C.Parsed (GH.Which Type'anyPointer))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'anyPointer)) +deriving instance (Std_.Eq (C.Parsed Type'anyPointer)) +instance (C.Parse Type'anyPointer (C.Parsed Type'anyPointer)) where + parse raw_ = (Type'anyPointer' <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Type'anyPointer (C.Parsed Type'anyPointer)) where + marshalInto raw_ Type'anyPointer'{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Type'anyPointer) where + unionField = (GH.dataField 0 1 16 0) + data RawWhich Type'anyPointer mut_ + = RW_Type'anyPointer'unconstrained (R.Raw Type'anyPointer'unconstrained mut_) + | RW_Type'anyPointer'parameter (R.Raw Type'anyPointer'parameter mut_) + | RW_Type'anyPointer'implicitMethodParameter (R.Raw Type'anyPointer'implicitMethodParameter mut_) + | RW_Type'anyPointer'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Type'anyPointer'unconstrained <$> (GH.readVariant #unconstrained struct_)) + 1 -> + (RW_Type'anyPointer'parameter <$> (GH.readVariant #parameter struct_)) + 2 -> + (RW_Type'anyPointer'implicitMethodParameter <$> (GH.readVariant #implicitMethodParameter struct_)) + _ -> + (Std_.pure (RW_Type'anyPointer'unknown' tag_)) + data Which Type'anyPointer +instance (GH.HasVariant "unconstrained" GH.Group Type'anyPointer Type'anyPointer'unconstrained) where + variantByLabel = (GH.Variant GH.groupField 0) +instance (GH.HasVariant "parameter" GH.Group Type'anyPointer Type'anyPointer'parameter) where + variantByLabel = (GH.Variant GH.groupField 1) +instance (GH.HasVariant "implicitMethodParameter" GH.Group Type'anyPointer Type'anyPointer'implicitMethodParameter) where + variantByLabel = (GH.Variant GH.groupField 2) +data instance C.Parsed (GH.Which Type'anyPointer) + = Type'anyPointer'unconstrained (RP.Parsed Type'anyPointer'unconstrained) + | Type'anyPointer'parameter (RP.Parsed Type'anyPointer'parameter) + | Type'anyPointer'implicitMethodParameter (RP.Parsed Type'anyPointer'implicitMethodParameter) + | Type'anyPointer'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Type'anyPointer))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Type'anyPointer))) +instance (C.Parse (GH.Which Type'anyPointer) (C.Parsed (GH.Which Type'anyPointer))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Type'anyPointer'unconstrained rawArg_) -> + (Type'anyPointer'unconstrained <$> (C.parse rawArg_)) + (RW_Type'anyPointer'parameter rawArg_) -> + (Type'anyPointer'parameter <$> (C.parse rawArg_)) + (RW_Type'anyPointer'implicitMethodParameter rawArg_) -> + (Type'anyPointer'implicitMethodParameter <$> (C.parse rawArg_)) + (RW_Type'anyPointer'unknown' tag_) -> + (Std_.pure (Type'anyPointer'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Type'anyPointer) (C.Parsed (GH.Which Type'anyPointer))) where + marshalInto raw_ parsed_ = case parsed_ of + (Type'anyPointer'unconstrained arg_) -> + (do + rawGroup_ <- (GH.initVariant #unconstrained (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'anyPointer'parameter arg_) -> + (do + rawGroup_ <- (GH.initVariant #parameter (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'anyPointer'implicitMethodParameter arg_) -> + (do + rawGroup_ <- (GH.initVariant #implicitMethodParameter (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Type'anyPointer'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Type'anyPointer'unconstrained +type instance (R.ReprFor Type'anyPointer'unconstrained) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer'unconstrained) where + typeId = 10248890354574636630 +instance (C.TypedStruct Type'anyPointer'unconstrained) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'anyPointer'unconstrained) where + type AllocHint Type'anyPointer'unconstrained = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) +instance (C.AllocateList Type'anyPointer'unconstrained) where + type ListAllocHint Type'anyPointer'unconstrained = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) +data instance C.Parsed Type'anyPointer'unconstrained + = Type'anyPointer'unconstrained' + {union' :: (C.Parsed (GH.Which Type'anyPointer'unconstrained))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'anyPointer'unconstrained)) +deriving instance (Std_.Eq (C.Parsed Type'anyPointer'unconstrained)) +instance (C.Parse Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) where + parse raw_ = (Type'anyPointer'unconstrained' <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) where + marshalInto raw_ Type'anyPointer'unconstrained'{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Type'anyPointer'unconstrained) where + unionField = (GH.dataField 16 1 16 0) + data RawWhich Type'anyPointer'unconstrained mut_ + = RW_Type'anyPointer'unconstrained'anyKind (R.Raw () mut_) + | RW_Type'anyPointer'unconstrained'struct (R.Raw () mut_) + | RW_Type'anyPointer'unconstrained'list (R.Raw () mut_) + | RW_Type'anyPointer'unconstrained'capability (R.Raw () mut_) + | RW_Type'anyPointer'unconstrained'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Type'anyPointer'unconstrained'anyKind <$> (GH.readVariant #anyKind struct_)) + 1 -> + (RW_Type'anyPointer'unconstrained'struct <$> (GH.readVariant #struct struct_)) + 2 -> + (RW_Type'anyPointer'unconstrained'list <$> (GH.readVariant #list struct_)) + 3 -> + (RW_Type'anyPointer'unconstrained'capability <$> (GH.readVariant #capability struct_)) + _ -> + (Std_.pure (RW_Type'anyPointer'unconstrained'unknown' tag_)) + data Which Type'anyPointer'unconstrained +instance (GH.HasVariant "anyKind" GH.Slot Type'anyPointer'unconstrained ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "struct" GH.Slot Type'anyPointer'unconstrained ()) where + variantByLabel = (GH.Variant GH.voidField 1) +instance (GH.HasVariant "list" GH.Slot Type'anyPointer'unconstrained ()) where + variantByLabel = (GH.Variant GH.voidField 2) +instance (GH.HasVariant "capability" GH.Slot Type'anyPointer'unconstrained ()) where + variantByLabel = (GH.Variant GH.voidField 3) +data instance C.Parsed (GH.Which Type'anyPointer'unconstrained) + = Type'anyPointer'unconstrained'anyKind + | Type'anyPointer'unconstrained'struct + | Type'anyPointer'unconstrained'list + | Type'anyPointer'unconstrained'capability + | Type'anyPointer'unconstrained'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Type'anyPointer'unconstrained))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Type'anyPointer'unconstrained))) +instance (C.Parse (GH.Which Type'anyPointer'unconstrained) (C.Parsed (GH.Which Type'anyPointer'unconstrained))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Type'anyPointer'unconstrained'anyKind _) -> + (Std_.pure Type'anyPointer'unconstrained'anyKind) + (RW_Type'anyPointer'unconstrained'struct _) -> + (Std_.pure Type'anyPointer'unconstrained'struct) + (RW_Type'anyPointer'unconstrained'list _) -> + (Std_.pure Type'anyPointer'unconstrained'list) + (RW_Type'anyPointer'unconstrained'capability _) -> + (Std_.pure Type'anyPointer'unconstrained'capability) + (RW_Type'anyPointer'unconstrained'unknown' tag_) -> + (Std_.pure (Type'anyPointer'unconstrained'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Type'anyPointer'unconstrained) (C.Parsed (GH.Which Type'anyPointer'unconstrained))) where + marshalInto raw_ parsed_ = case parsed_ of + (Type'anyPointer'unconstrained'anyKind) -> + (GH.encodeVariant #anyKind () (GH.unionStruct raw_)) + (Type'anyPointer'unconstrained'struct) -> + (GH.encodeVariant #struct () (GH.unionStruct raw_)) + (Type'anyPointer'unconstrained'list) -> + (GH.encodeVariant #list () (GH.unionStruct raw_)) + (Type'anyPointer'unconstrained'capability) -> + (GH.encodeVariant #capability () (GH.unionStruct raw_)) + (Type'anyPointer'unconstrained'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Type'anyPointer'parameter +type instance (R.ReprFor Type'anyPointer'parameter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer'parameter) where + typeId = 11372142272178113157 +instance (C.TypedStruct Type'anyPointer'parameter) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'anyPointer'parameter) where + type AllocHint Type'anyPointer'parameter = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) +instance (C.AllocateList Type'anyPointer'parameter) where + type ListAllocHint Type'anyPointer'parameter = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) +data instance C.Parsed Type'anyPointer'parameter + = Type'anyPointer'parameter' + {scopeId :: (RP.Parsed Std_.Word64) + ,parameterIndex :: (RP.Parsed Std_.Word16)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'anyPointer'parameter)) +deriving instance (Std_.Eq (C.Parsed Type'anyPointer'parameter)) +instance (C.Parse Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) where + parse raw_ = (Type'anyPointer'parameter' <$> (GH.parseField #scopeId raw_) + <*> (GH.parseField #parameterIndex raw_)) +instance (C.Marshal Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) where + marshalInto raw_ Type'anyPointer'parameter'{..} = (do + (GH.encodeField #scopeId scopeId raw_) + (GH.encodeField #parameterIndex parameterIndex raw_) + (Std_.pure ()) + ) +instance (GH.HasField "scopeId" GH.Slot Type'anyPointer'parameter Std_.Word64) where + fieldByLabel = (GH.dataField 0 2 64 0) +instance (GH.HasField "parameterIndex" GH.Slot Type'anyPointer'parameter Std_.Word16) where + fieldByLabel = (GH.dataField 16 1 16 0) +data Type'anyPointer'implicitMethodParameter +type instance (R.ReprFor Type'anyPointer'implicitMethodParameter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer'implicitMethodParameter) where + typeId = 13470206089842057844 +instance (C.TypedStruct Type'anyPointer'implicitMethodParameter) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Type'anyPointer'implicitMethodParameter) where + type AllocHint Type'anyPointer'implicitMethodParameter = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) +instance (C.AllocateList Type'anyPointer'implicitMethodParameter) where + type ListAllocHint Type'anyPointer'implicitMethodParameter = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) +data instance C.Parsed Type'anyPointer'implicitMethodParameter + = Type'anyPointer'implicitMethodParameter' + {parameterIndex :: (RP.Parsed Std_.Word16)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Type'anyPointer'implicitMethodParameter)) +deriving instance (Std_.Eq (C.Parsed Type'anyPointer'implicitMethodParameter)) +instance (C.Parse Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) where + parse raw_ = (Type'anyPointer'implicitMethodParameter' <$> (GH.parseField #parameterIndex raw_)) +instance (C.Marshal Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) where + marshalInto raw_ Type'anyPointer'implicitMethodParameter'{..} = (do + (GH.encodeField #parameterIndex parameterIndex raw_) + (Std_.pure ()) + ) +instance (GH.HasField "parameterIndex" GH.Slot Type'anyPointer'implicitMethodParameter Std_.Word16) where + fieldByLabel = (GH.dataField 16 1 16 0) +data Brand +type instance (R.ReprFor Brand) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Brand) where + typeId = 10391024731148337707 +instance (C.TypedStruct Brand) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Brand) where + type AllocHint Brand = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Brand (C.Parsed Brand)) +instance (C.AllocateList Brand) where + type ListAllocHint Brand = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Brand (C.Parsed Brand)) +data instance C.Parsed Brand + = Brand + {scopes :: (RP.Parsed (R.List Brand'Scope))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Brand)) +deriving instance (Std_.Eq (C.Parsed Brand)) +instance (C.Parse Brand (C.Parsed Brand)) where + parse raw_ = (Brand <$> (GH.parseField #scopes raw_)) +instance (C.Marshal Brand (C.Parsed Brand)) where + marshalInto raw_ Brand{..} = (do + (GH.encodeField #scopes scopes raw_) + (Std_.pure ()) + ) +instance (GH.HasField "scopes" GH.Slot Brand (R.List Brand'Scope)) where + fieldByLabel = (GH.ptrField 0) +data Brand'Scope +type instance (R.ReprFor Brand'Scope) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Brand'Scope) where + typeId = 12382423449155627977 +instance (C.TypedStruct Brand'Scope) where + numStructWords = 2 + numStructPtrs = 1 +instance (C.Allocate Brand'Scope) where + type AllocHint Brand'Scope = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Brand'Scope (C.Parsed Brand'Scope)) +instance (C.AllocateList Brand'Scope) where + type ListAllocHint Brand'Scope = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Brand'Scope (C.Parsed Brand'Scope)) +data instance C.Parsed Brand'Scope + = Brand'Scope + {scopeId :: (RP.Parsed Std_.Word64) + ,union' :: (C.Parsed (GH.Which Brand'Scope))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Brand'Scope)) +deriving instance (Std_.Eq (C.Parsed Brand'Scope)) +instance (C.Parse Brand'Scope (C.Parsed Brand'Scope)) where + parse raw_ = (Brand'Scope <$> (GH.parseField #scopeId raw_) + <*> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Brand'Scope (C.Parsed Brand'Scope)) where + marshalInto raw_ Brand'Scope{..} = (do + (GH.encodeField #scopeId scopeId raw_) + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Brand'Scope) where + unionField = (GH.dataField 0 1 16 0) + data RawWhich Brand'Scope mut_ + = RW_Brand'Scope'bind (R.Raw (R.List Brand'Binding) mut_) + | RW_Brand'Scope'inherit (R.Raw () mut_) + | RW_Brand'Scope'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Brand'Scope'bind <$> (GH.readVariant #bind struct_)) + 1 -> + (RW_Brand'Scope'inherit <$> (GH.readVariant #inherit struct_)) + _ -> + (Std_.pure (RW_Brand'Scope'unknown' tag_)) + data Which Brand'Scope +instance (GH.HasVariant "bind" GH.Slot Brand'Scope (R.List Brand'Binding)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 0) +instance (GH.HasVariant "inherit" GH.Slot Brand'Scope ()) where + variantByLabel = (GH.Variant GH.voidField 1) +data instance C.Parsed (GH.Which Brand'Scope) + = Brand'Scope'bind (RP.Parsed (R.List Brand'Binding)) + | Brand'Scope'inherit + | Brand'Scope'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Brand'Scope))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Brand'Scope))) +instance (C.Parse (GH.Which Brand'Scope) (C.Parsed (GH.Which Brand'Scope))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Brand'Scope'bind rawArg_) -> + (Brand'Scope'bind <$> (C.parse rawArg_)) + (RW_Brand'Scope'inherit _) -> + (Std_.pure Brand'Scope'inherit) + (RW_Brand'Scope'unknown' tag_) -> + (Std_.pure (Brand'Scope'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Brand'Scope) (C.Parsed (GH.Which Brand'Scope))) where + marshalInto raw_ parsed_ = case parsed_ of + (Brand'Scope'bind arg_) -> + (GH.encodeVariant #bind arg_ (GH.unionStruct raw_)) + (Brand'Scope'inherit) -> + (GH.encodeVariant #inherit () (GH.unionStruct raw_)) + (Brand'Scope'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +instance (GH.HasField "scopeId" GH.Slot Brand'Scope Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +data Brand'Binding +type instance (R.ReprFor Brand'Binding) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Brand'Binding) where + typeId = 14439610327179913212 +instance (C.TypedStruct Brand'Binding) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Brand'Binding) where + type AllocHint Brand'Binding = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Brand'Binding (C.Parsed Brand'Binding)) +instance (C.AllocateList Brand'Binding) where + type ListAllocHint Brand'Binding = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Brand'Binding (C.Parsed Brand'Binding)) +data instance C.Parsed Brand'Binding + = Brand'Binding + {union' :: (C.Parsed (GH.Which Brand'Binding))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Brand'Binding)) +deriving instance (Std_.Eq (C.Parsed Brand'Binding)) +instance (C.Parse Brand'Binding (C.Parsed Brand'Binding)) where + parse raw_ = (Brand'Binding <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Brand'Binding (C.Parsed Brand'Binding)) where + marshalInto raw_ Brand'Binding{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Brand'Binding) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Brand'Binding mut_ + = RW_Brand'Binding'unbound (R.Raw () mut_) + | RW_Brand'Binding'type_ (R.Raw Type mut_) + | RW_Brand'Binding'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Brand'Binding'unbound <$> (GH.readVariant #unbound struct_)) + 1 -> + (RW_Brand'Binding'type_ <$> (GH.readVariant #type_ struct_)) + _ -> + (Std_.pure (RW_Brand'Binding'unknown' tag_)) + data Which Brand'Binding +instance (GH.HasVariant "unbound" GH.Slot Brand'Binding ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "type_" GH.Slot Brand'Binding Type) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +data instance C.Parsed (GH.Which Brand'Binding) + = Brand'Binding'unbound + | Brand'Binding'type_ (RP.Parsed Type) + | Brand'Binding'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Brand'Binding))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Brand'Binding))) +instance (C.Parse (GH.Which Brand'Binding) (C.Parsed (GH.Which Brand'Binding))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Brand'Binding'unbound _) -> + (Std_.pure Brand'Binding'unbound) + (RW_Brand'Binding'type_ rawArg_) -> + (Brand'Binding'type_ <$> (C.parse rawArg_)) + (RW_Brand'Binding'unknown' tag_) -> + (Std_.pure (Brand'Binding'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Brand'Binding) (C.Parsed (GH.Which Brand'Binding))) where + marshalInto raw_ parsed_ = case parsed_ of + (Brand'Binding'unbound) -> + (GH.encodeVariant #unbound () (GH.unionStruct raw_)) + (Brand'Binding'type_ arg_) -> + (GH.encodeVariant #type_ arg_ (GH.unionStruct raw_)) + (Brand'Binding'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Value +type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value) where + typeId = 14853958794117909659 +instance (C.TypedStruct Value) where + numStructWords = 2 + numStructPtrs = 1 +instance (C.Allocate Value) where + type AllocHint Value = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Value (C.Parsed Value)) +instance (C.AllocateList Value) where + type ListAllocHint Value = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Value (C.Parsed Value)) +data instance C.Parsed Value + = Value + {union' :: (C.Parsed (GH.Which Value))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Value)) +deriving instance (Std_.Eq (C.Parsed Value)) +instance (C.Parse Value (C.Parsed Value)) where + parse raw_ = (Value <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Value (C.Parsed Value)) where + marshalInto raw_ Value{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Value) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Value mut_ + = RW_Value'void (R.Raw () mut_) + | RW_Value'bool (R.Raw Std_.Bool mut_) + | RW_Value'int8 (R.Raw Std_.Int8 mut_) + | RW_Value'int16 (R.Raw Std_.Int16 mut_) + | RW_Value'int32 (R.Raw Std_.Int32 mut_) + | RW_Value'int64 (R.Raw Std_.Int64 mut_) + | RW_Value'uint8 (R.Raw Std_.Word8 mut_) + | RW_Value'uint16 (R.Raw Std_.Word16 mut_) + | RW_Value'uint32 (R.Raw Std_.Word32 mut_) + | RW_Value'uint64 (R.Raw Std_.Word64 mut_) + | RW_Value'float32 (R.Raw Std_.Float mut_) + | RW_Value'float64 (R.Raw Std_.Double mut_) + | RW_Value'text (R.Raw Basics.Text mut_) + | RW_Value'data_ (R.Raw Basics.Data mut_) + | RW_Value'list (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Value'enum (R.Raw Std_.Word16 mut_) + | RW_Value'struct (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Value'interface (R.Raw () mut_) + | RW_Value'anyPointer (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) + | RW_Value'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Value'void <$> (GH.readVariant #void struct_)) + 1 -> + (RW_Value'bool <$> (GH.readVariant #bool struct_)) + 2 -> + (RW_Value'int8 <$> (GH.readVariant #int8 struct_)) + 3 -> + (RW_Value'int16 <$> (GH.readVariant #int16 struct_)) + 4 -> + (RW_Value'int32 <$> (GH.readVariant #int32 struct_)) + 5 -> + (RW_Value'int64 <$> (GH.readVariant #int64 struct_)) + 6 -> + (RW_Value'uint8 <$> (GH.readVariant #uint8 struct_)) + 7 -> + (RW_Value'uint16 <$> (GH.readVariant #uint16 struct_)) + 8 -> + (RW_Value'uint32 <$> (GH.readVariant #uint32 struct_)) + 9 -> + (RW_Value'uint64 <$> (GH.readVariant #uint64 struct_)) + 10 -> + (RW_Value'float32 <$> (GH.readVariant #float32 struct_)) + 11 -> + (RW_Value'float64 <$> (GH.readVariant #float64 struct_)) + 12 -> + (RW_Value'text <$> (GH.readVariant #text struct_)) + 13 -> + (RW_Value'data_ <$> (GH.readVariant #data_ struct_)) + 14 -> + (RW_Value'list <$> (GH.readVariant #list struct_)) + 15 -> + (RW_Value'enum <$> (GH.readVariant #enum struct_)) + 16 -> + (RW_Value'struct <$> (GH.readVariant #struct struct_)) + 17 -> + (RW_Value'interface <$> (GH.readVariant #interface struct_)) + 18 -> + (RW_Value'anyPointer <$> (GH.readVariant #anyPointer struct_)) + _ -> + (Std_.pure (RW_Value'unknown' tag_)) + data Which Value +instance (GH.HasVariant "void" GH.Slot Value ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "bool" GH.Slot Value Std_.Bool) where + variantByLabel = (GH.Variant (GH.dataField 16 0 1 0) 1) +instance (GH.HasVariant "int8" GH.Slot Value Std_.Int8) where + variantByLabel = (GH.Variant (GH.dataField 16 0 8 0) 2) +instance (GH.HasVariant "int16" GH.Slot Value Std_.Int16) where + variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 3) +instance (GH.HasVariant "int32" GH.Slot Value Std_.Int32) where + variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 4) +instance (GH.HasVariant "int64" GH.Slot Value Std_.Int64) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 5) +instance (GH.HasVariant "uint8" GH.Slot Value Std_.Word8) where + variantByLabel = (GH.Variant (GH.dataField 16 0 8 0) 6) +instance (GH.HasVariant "uint16" GH.Slot Value Std_.Word16) where + variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 7) +instance (GH.HasVariant "uint32" GH.Slot Value Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 8) +instance (GH.HasVariant "uint64" GH.Slot Value Std_.Word64) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 9) +instance (GH.HasVariant "float32" GH.Slot Value Std_.Float) where + variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 10) +instance (GH.HasVariant "float64" GH.Slot Value Std_.Double) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 11) +instance (GH.HasVariant "text" GH.Slot Value Basics.Text) where + variantByLabel = (GH.Variant (GH.ptrField 0) 12) +instance (GH.HasVariant "data_" GH.Slot Value Basics.Data) where + variantByLabel = (GH.Variant (GH.ptrField 0) 13) +instance (GH.HasVariant "list" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 14) +instance (GH.HasVariant "enum" GH.Slot Value Std_.Word16) where + variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 15) +instance (GH.HasVariant "struct" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 16) +instance (GH.HasVariant "interface" GH.Slot Value ()) where + variantByLabel = (GH.Variant GH.voidField 17) +instance (GH.HasVariant "anyPointer" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 18) +data instance C.Parsed (GH.Which Value) + = Value'void + | Value'bool (RP.Parsed Std_.Bool) + | Value'int8 (RP.Parsed Std_.Int8) + | Value'int16 (RP.Parsed Std_.Int16) + | Value'int32 (RP.Parsed Std_.Int32) + | Value'int64 (RP.Parsed Std_.Int64) + | Value'uint8 (RP.Parsed Std_.Word8) + | Value'uint16 (RP.Parsed Std_.Word16) + | Value'uint32 (RP.Parsed Std_.Word32) + | Value'uint64 (RP.Parsed Std_.Word64) + | Value'float32 (RP.Parsed Std_.Float) + | Value'float64 (RP.Parsed Std_.Double) + | Value'text (RP.Parsed Basics.Text) + | Value'data_ (RP.Parsed Basics.Data) + | Value'list (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Value'enum (RP.Parsed Std_.Word16) + | Value'struct (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Value'interface + | Value'anyPointer (RP.Parsed (Std_.Maybe Basics.AnyPointer)) + | Value'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Value))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Value))) +instance (C.Parse (GH.Which Value) (C.Parsed (GH.Which Value))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Value'void _) -> + (Std_.pure Value'void) + (RW_Value'bool rawArg_) -> + (Value'bool <$> (C.parse rawArg_)) + (RW_Value'int8 rawArg_) -> + (Value'int8 <$> (C.parse rawArg_)) + (RW_Value'int16 rawArg_) -> + (Value'int16 <$> (C.parse rawArg_)) + (RW_Value'int32 rawArg_) -> + (Value'int32 <$> (C.parse rawArg_)) + (RW_Value'int64 rawArg_) -> + (Value'int64 <$> (C.parse rawArg_)) + (RW_Value'uint8 rawArg_) -> + (Value'uint8 <$> (C.parse rawArg_)) + (RW_Value'uint16 rawArg_) -> + (Value'uint16 <$> (C.parse rawArg_)) + (RW_Value'uint32 rawArg_) -> + (Value'uint32 <$> (C.parse rawArg_)) + (RW_Value'uint64 rawArg_) -> + (Value'uint64 <$> (C.parse rawArg_)) + (RW_Value'float32 rawArg_) -> + (Value'float32 <$> (C.parse rawArg_)) + (RW_Value'float64 rawArg_) -> + (Value'float64 <$> (C.parse rawArg_)) + (RW_Value'text rawArg_) -> + (Value'text <$> (C.parse rawArg_)) + (RW_Value'data_ rawArg_) -> + (Value'data_ <$> (C.parse rawArg_)) + (RW_Value'list rawArg_) -> + (Value'list <$> (C.parse rawArg_)) + (RW_Value'enum rawArg_) -> + (Value'enum <$> (C.parse rawArg_)) + (RW_Value'struct rawArg_) -> + (Value'struct <$> (C.parse rawArg_)) + (RW_Value'interface _) -> + (Std_.pure Value'interface) + (RW_Value'anyPointer rawArg_) -> + (Value'anyPointer <$> (C.parse rawArg_)) + (RW_Value'unknown' tag_) -> + (Std_.pure (Value'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Value) (C.Parsed (GH.Which Value))) where + marshalInto raw_ parsed_ = case parsed_ of + (Value'void) -> + (GH.encodeVariant #void () (GH.unionStruct raw_)) + (Value'bool arg_) -> + (GH.encodeVariant #bool arg_ (GH.unionStruct raw_)) + (Value'int8 arg_) -> + (GH.encodeVariant #int8 arg_ (GH.unionStruct raw_)) + (Value'int16 arg_) -> + (GH.encodeVariant #int16 arg_ (GH.unionStruct raw_)) + (Value'int32 arg_) -> + (GH.encodeVariant #int32 arg_ (GH.unionStruct raw_)) + (Value'int64 arg_) -> + (GH.encodeVariant #int64 arg_ (GH.unionStruct raw_)) + (Value'uint8 arg_) -> + (GH.encodeVariant #uint8 arg_ (GH.unionStruct raw_)) + (Value'uint16 arg_) -> + (GH.encodeVariant #uint16 arg_ (GH.unionStruct raw_)) + (Value'uint32 arg_) -> + (GH.encodeVariant #uint32 arg_ (GH.unionStruct raw_)) + (Value'uint64 arg_) -> + (GH.encodeVariant #uint64 arg_ (GH.unionStruct raw_)) + (Value'float32 arg_) -> + (GH.encodeVariant #float32 arg_ (GH.unionStruct raw_)) + (Value'float64 arg_) -> + (GH.encodeVariant #float64 arg_ (GH.unionStruct raw_)) + (Value'text arg_) -> + (GH.encodeVariant #text arg_ (GH.unionStruct raw_)) + (Value'data_ arg_) -> + (GH.encodeVariant #data_ arg_ (GH.unionStruct raw_)) + (Value'list arg_) -> + (GH.encodeVariant #list arg_ (GH.unionStruct raw_)) + (Value'enum arg_) -> + (GH.encodeVariant #enum arg_ (GH.unionStruct raw_)) + (Value'struct arg_) -> + (GH.encodeVariant #struct arg_ (GH.unionStruct raw_)) + (Value'interface) -> + (GH.encodeVariant #interface () (GH.unionStruct raw_)) + (Value'anyPointer arg_) -> + (GH.encodeVariant #anyPointer arg_ (GH.unionStruct raw_)) + (Value'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Annotation +type instance (R.ReprFor Annotation) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Annotation) where + typeId = 17422339044421236034 +instance (C.TypedStruct Annotation) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate Annotation) where + type AllocHint Annotation = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Annotation (C.Parsed Annotation)) +instance (C.AllocateList Annotation) where + type ListAllocHint Annotation = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Annotation (C.Parsed Annotation)) +data instance C.Parsed Annotation + = Annotation + {id :: (RP.Parsed Std_.Word64) + ,value :: (RP.Parsed Value) + ,brand :: (RP.Parsed Brand)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Annotation)) +deriving instance (Std_.Eq (C.Parsed Annotation)) +instance (C.Parse Annotation (C.Parsed Annotation)) where + parse raw_ = (Annotation <$> (GH.parseField #id raw_) + <*> (GH.parseField #value raw_) + <*> (GH.parseField #brand raw_)) +instance (C.Marshal Annotation (C.Parsed Annotation)) where + marshalInto raw_ Annotation{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #value value raw_) + (GH.encodeField #brand brand raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot Annotation Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "value" GH.Slot Annotation Value) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "brand" GH.Slot Annotation Brand) where + fieldByLabel = (GH.ptrField 1) +data ElementSize + = ElementSize'empty + | ElementSize'bit + | ElementSize'byte + | ElementSize'twoBytes + | ElementSize'fourBytes + | ElementSize'eightBytes + | ElementSize'pointer + | ElementSize'inlineComposite + | ElementSize'unknown' Std_.Word16 + deriving(Std_.Eq + ,Std_.Show + ,Generics.Generic) +type instance (R.ReprFor ElementSize) = (R.Data R.Sz16) +instance (C.HasTypeId ElementSize) where + typeId = 15102134695616452902 +instance (Std_.Enum ElementSize) where + toEnum n_ = case n_ of + 0 -> + ElementSize'empty + 1 -> + ElementSize'bit + 2 -> + ElementSize'byte + 3 -> + ElementSize'twoBytes + 4 -> + ElementSize'fourBytes + 5 -> + ElementSize'eightBytes + 6 -> + ElementSize'pointer + 7 -> + ElementSize'inlineComposite + tag_ -> + (ElementSize'unknown' (Std_.fromIntegral tag_)) + fromEnum value_ = case value_ of + (ElementSize'empty) -> + 0 + (ElementSize'bit) -> + 1 + (ElementSize'byte) -> + 2 + (ElementSize'twoBytes) -> + 3 + (ElementSize'fourBytes) -> + 4 + (ElementSize'eightBytes) -> + 5 + (ElementSize'pointer) -> + 6 + (ElementSize'inlineComposite) -> + 7 + (ElementSize'unknown' tag_) -> + (Std_.fromIntegral tag_) +instance (C.IsWord ElementSize) where + fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) + toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) +instance (C.Parse ElementSize ElementSize) where + parse = GH.parseEnum + encode = GH.encodeEnum +instance (C.AllocateList ElementSize) where + type ListAllocHint ElementSize = Std_.Int +instance (C.EstimateListAlloc ElementSize ElementSize) +data CapnpVersion +type instance (R.ReprFor CapnpVersion) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CapnpVersion) where + typeId = 15590670654532458851 +instance (C.TypedStruct CapnpVersion) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate CapnpVersion) where + type AllocHint CapnpVersion = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CapnpVersion (C.Parsed CapnpVersion)) +instance (C.AllocateList CapnpVersion) where + type ListAllocHint CapnpVersion = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CapnpVersion (C.Parsed CapnpVersion)) +data instance C.Parsed CapnpVersion + = CapnpVersion + {major :: (RP.Parsed Std_.Word16) + ,minor :: (RP.Parsed Std_.Word8) + ,micro :: (RP.Parsed Std_.Word8)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CapnpVersion)) +deriving instance (Std_.Eq (C.Parsed CapnpVersion)) +instance (C.Parse CapnpVersion (C.Parsed CapnpVersion)) where + parse raw_ = (CapnpVersion <$> (GH.parseField #major raw_) + <*> (GH.parseField #minor raw_) + <*> (GH.parseField #micro raw_)) +instance (C.Marshal CapnpVersion (C.Parsed CapnpVersion)) where + marshalInto raw_ CapnpVersion{..} = (do + (GH.encodeField #major major raw_) + (GH.encodeField #minor minor raw_) + (GH.encodeField #micro micro raw_) + (Std_.pure ()) + ) +instance (GH.HasField "major" GH.Slot CapnpVersion Std_.Word16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "minor" GH.Slot CapnpVersion Std_.Word8) where + fieldByLabel = (GH.dataField 16 0 8 0) +instance (GH.HasField "micro" GH.Slot CapnpVersion Std_.Word8) where + fieldByLabel = (GH.dataField 24 0 8 0) +data CodeGeneratorRequest +type instance (R.ReprFor CodeGeneratorRequest) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CodeGeneratorRequest) where + typeId = 13818529054586492878 +instance (C.TypedStruct CodeGeneratorRequest) where + numStructWords = 0 + numStructPtrs = 4 +instance (C.Allocate CodeGeneratorRequest) where + type AllocHint CodeGeneratorRequest = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) +instance (C.AllocateList CodeGeneratorRequest) where + type ListAllocHint CodeGeneratorRequest = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) +data instance C.Parsed CodeGeneratorRequest + = CodeGeneratorRequest + {nodes :: (RP.Parsed (R.List Node)) + ,requestedFiles :: (RP.Parsed (R.List CodeGeneratorRequest'RequestedFile)) + ,capnpVersion :: (RP.Parsed CapnpVersion) + ,sourceInfo :: (RP.Parsed (R.List Node'SourceInfo))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CodeGeneratorRequest)) +deriving instance (Std_.Eq (C.Parsed CodeGeneratorRequest)) +instance (C.Parse CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) where + parse raw_ = (CodeGeneratorRequest <$> (GH.parseField #nodes raw_) + <*> (GH.parseField #requestedFiles raw_) + <*> (GH.parseField #capnpVersion raw_) + <*> (GH.parseField #sourceInfo raw_)) +instance (C.Marshal CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) where + marshalInto raw_ CodeGeneratorRequest{..} = (do + (GH.encodeField #nodes nodes raw_) + (GH.encodeField #requestedFiles requestedFiles raw_) + (GH.encodeField #capnpVersion capnpVersion raw_) + (GH.encodeField #sourceInfo sourceInfo raw_) + (Std_.pure ()) + ) +instance (GH.HasField "nodes" GH.Slot CodeGeneratorRequest (R.List Node)) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "requestedFiles" GH.Slot CodeGeneratorRequest (R.List CodeGeneratorRequest'RequestedFile)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "capnpVersion" GH.Slot CodeGeneratorRequest CapnpVersion) where + fieldByLabel = (GH.ptrField 2) +instance (GH.HasField "sourceInfo" GH.Slot CodeGeneratorRequest (R.List Node'SourceInfo)) where + fieldByLabel = (GH.ptrField 3) +data CodeGeneratorRequest'RequestedFile +type instance (R.ReprFor CodeGeneratorRequest'RequestedFile) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CodeGeneratorRequest'RequestedFile) where + typeId = 14981803260258615394 +instance (C.TypedStruct CodeGeneratorRequest'RequestedFile) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate CodeGeneratorRequest'RequestedFile) where + type AllocHint CodeGeneratorRequest'RequestedFile = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) +instance (C.AllocateList CodeGeneratorRequest'RequestedFile) where + type ListAllocHint CodeGeneratorRequest'RequestedFile = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) +data instance C.Parsed CodeGeneratorRequest'RequestedFile + = CodeGeneratorRequest'RequestedFile + {id :: (RP.Parsed Std_.Word64) + ,filename :: (RP.Parsed Basics.Text) + ,imports :: (RP.Parsed (R.List CodeGeneratorRequest'RequestedFile'Import))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CodeGeneratorRequest'RequestedFile)) +deriving instance (Std_.Eq (C.Parsed CodeGeneratorRequest'RequestedFile)) +instance (C.Parse CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) where + parse raw_ = (CodeGeneratorRequest'RequestedFile <$> (GH.parseField #id raw_) + <*> (GH.parseField #filename raw_) + <*> (GH.parseField #imports raw_)) +instance (C.Marshal CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) where + marshalInto raw_ CodeGeneratorRequest'RequestedFile{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #filename filename raw_) + (GH.encodeField #imports imports raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot CodeGeneratorRequest'RequestedFile Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "filename" GH.Slot CodeGeneratorRequest'RequestedFile Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "imports" GH.Slot CodeGeneratorRequest'RequestedFile (R.List CodeGeneratorRequest'RequestedFile'Import)) where + fieldByLabel = (GH.ptrField 1) +data CodeGeneratorRequest'RequestedFile'Import +type instance (R.ReprFor CodeGeneratorRequest'RequestedFile'Import) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CodeGeneratorRequest'RequestedFile'Import) where + typeId = 12560611460656617445 +instance (C.TypedStruct CodeGeneratorRequest'RequestedFile'Import) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate CodeGeneratorRequest'RequestedFile'Import) where + type AllocHint CodeGeneratorRequest'RequestedFile'Import = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) +instance (C.AllocateList CodeGeneratorRequest'RequestedFile'Import) where + type ListAllocHint CodeGeneratorRequest'RequestedFile'Import = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) +data instance C.Parsed CodeGeneratorRequest'RequestedFile'Import + = CodeGeneratorRequest'RequestedFile'Import + {id :: (RP.Parsed Std_.Word64) + ,name :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) +deriving instance (Std_.Eq (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) +instance (C.Parse CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) where + parse raw_ = (CodeGeneratorRequest'RequestedFile'Import <$> (GH.parseField #id raw_) + <*> (GH.parseField #name raw_)) +instance (C.Marshal CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) where + marshalInto raw_ CodeGeneratorRequest'RequestedFile'Import{..} = (do + (GH.encodeField #id id raw_) + (GH.encodeField #name name raw_) + (Std_.pure ()) + ) +instance (GH.HasField "id" GH.Slot CodeGeneratorRequest'RequestedFile'Import Std_.Word64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "name" GH.Slot CodeGeneratorRequest'RequestedFile'Import Basics.Text) where + fieldByLabel = (GH.ptrField 0) diff --git a/gen/lib/Capnp/Gen/Capnp/Schema/New.hs b/gen/lib/Capnp/Gen/Capnp/Schema/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/Schema/New.hs +++ /dev/null @@ -1,2297 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.Schema.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Node -type instance (R.ReprFor Node) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node) where - typeId = 16610026722781537303 -instance (C.TypedStruct Node) where - numStructWords = 5 - numStructPtrs = 6 -instance (C.Allocate Node) where - type AllocHint Node = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node (C.Parsed Node)) -instance (C.AllocateList Node) where - type ListAllocHint Node = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node (C.Parsed Node)) -data instance C.Parsed Node - = Node - {id :: (RP.Parsed Std_.Word64) - ,displayName :: (RP.Parsed Basics.Text) - ,displayNamePrefixLength :: (RP.Parsed Std_.Word32) - ,scopeId :: (RP.Parsed Std_.Word64) - ,nestedNodes :: (RP.Parsed (R.List Node'NestedNode)) - ,annotations :: (RP.Parsed (R.List Annotation)) - ,parameters :: (RP.Parsed (R.List Node'Parameter)) - ,isGeneric :: (RP.Parsed Std_.Bool) - ,union' :: (C.Parsed (GH.Which Node))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node)) -deriving instance (Std_.Eq (C.Parsed Node)) -instance (C.Parse Node (C.Parsed Node)) where - parse raw_ = (Node <$> (GH.parseField #id raw_) - <*> (GH.parseField #displayName raw_) - <*> (GH.parseField #displayNamePrefixLength raw_) - <*> (GH.parseField #scopeId raw_) - <*> (GH.parseField #nestedNodes raw_) - <*> (GH.parseField #annotations raw_) - <*> (GH.parseField #parameters raw_) - <*> (GH.parseField #isGeneric raw_) - <*> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Node (C.Parsed Node)) where - marshalInto raw_ Node{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #displayName displayName raw_) - (GH.encodeField #displayNamePrefixLength displayNamePrefixLength raw_) - (GH.encodeField #scopeId scopeId raw_) - (GH.encodeField #nestedNodes nestedNodes raw_) - (GH.encodeField #annotations annotations raw_) - (GH.encodeField #parameters parameters raw_) - (GH.encodeField #isGeneric isGeneric raw_) - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Node) where - unionField = (GH.dataField 32 1 16 0) - data RawWhich Node mut_ - = RW_Node'file (R.Raw () mut_) - | RW_Node'struct (R.Raw Node'struct mut_) - | RW_Node'enum (R.Raw Node'enum mut_) - | RW_Node'interface (R.Raw Node'interface mut_) - | RW_Node'const (R.Raw Node'const mut_) - | RW_Node'annotation (R.Raw Node'annotation mut_) - | RW_Node'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Node'file <$> (GH.readVariant #file struct_)) - 1 -> - (RW_Node'struct <$> (GH.readVariant #struct struct_)) - 2 -> - (RW_Node'enum <$> (GH.readVariant #enum struct_)) - 3 -> - (RW_Node'interface <$> (GH.readVariant #interface struct_)) - 4 -> - (RW_Node'const <$> (GH.readVariant #const struct_)) - 5 -> - (RW_Node'annotation <$> (GH.readVariant #annotation struct_)) - _ -> - (Std_.pure (RW_Node'unknown' tag_)) - data Which Node -instance (GH.HasVariant "file" GH.Slot Node ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "struct" GH.Group Node Node'struct) where - variantByLabel = (GH.Variant GH.groupField 1) -instance (GH.HasVariant "enum" GH.Group Node Node'enum) where - variantByLabel = (GH.Variant GH.groupField 2) -instance (GH.HasVariant "interface" GH.Group Node Node'interface) where - variantByLabel = (GH.Variant GH.groupField 3) -instance (GH.HasVariant "const" GH.Group Node Node'const) where - variantByLabel = (GH.Variant GH.groupField 4) -instance (GH.HasVariant "annotation" GH.Group Node Node'annotation) where - variantByLabel = (GH.Variant GH.groupField 5) -data instance C.Parsed (GH.Which Node) - = Node'file - | Node'struct (RP.Parsed Node'struct) - | Node'enum (RP.Parsed Node'enum) - | Node'interface (RP.Parsed Node'interface) - | Node'const (RP.Parsed Node'const) - | Node'annotation (RP.Parsed Node'annotation) - | Node'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Node))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Node))) -instance (C.Parse (GH.Which Node) (C.Parsed (GH.Which Node))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Node'file _) -> - (Std_.pure Node'file) - (RW_Node'struct rawArg_) -> - (Node'struct <$> (C.parse rawArg_)) - (RW_Node'enum rawArg_) -> - (Node'enum <$> (C.parse rawArg_)) - (RW_Node'interface rawArg_) -> - (Node'interface <$> (C.parse rawArg_)) - (RW_Node'const rawArg_) -> - (Node'const <$> (C.parse rawArg_)) - (RW_Node'annotation rawArg_) -> - (Node'annotation <$> (C.parse rawArg_)) - (RW_Node'unknown' tag_) -> - (Std_.pure (Node'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Node) (C.Parsed (GH.Which Node))) where - marshalInto raw_ parsed_ = case parsed_ of - (Node'file) -> - (GH.encodeVariant #file () (GH.unionStruct raw_)) - (Node'struct arg_) -> - (do - rawGroup_ <- (GH.initVariant #struct (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Node'enum arg_) -> - (do - rawGroup_ <- (GH.initVariant #enum (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Node'interface arg_) -> - (do - rawGroup_ <- (GH.initVariant #interface (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Node'const arg_) -> - (do - rawGroup_ <- (GH.initVariant #const (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Node'annotation arg_) -> - (do - rawGroup_ <- (GH.initVariant #annotation (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Node'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -instance (GH.HasField "id" GH.Slot Node Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "displayName" GH.Slot Node Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "displayNamePrefixLength" GH.Slot Node Std_.Word32) where - fieldByLabel = (GH.dataField 0 1 32 0) -instance (GH.HasField "scopeId" GH.Slot Node Std_.Word64) where - fieldByLabel = (GH.dataField 0 2 64 0) -instance (GH.HasField "nestedNodes" GH.Slot Node (R.List Node'NestedNode)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "annotations" GH.Slot Node (R.List Annotation)) where - fieldByLabel = (GH.ptrField 2) -instance (GH.HasField "parameters" GH.Slot Node (R.List Node'Parameter)) where - fieldByLabel = (GH.ptrField 5) -instance (GH.HasField "isGeneric" GH.Slot Node Std_.Bool) where - fieldByLabel = (GH.dataField 32 4 1 0) -data Node'struct -type instance (R.ReprFor Node'struct) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'struct) where - typeId = 11430331134483579957 -instance (C.TypedStruct Node'struct) where - numStructWords = 5 - numStructPtrs = 6 -instance (C.Allocate Node'struct) where - type AllocHint Node'struct = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'struct (C.Parsed Node'struct)) -instance (C.AllocateList Node'struct) where - type ListAllocHint Node'struct = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'struct (C.Parsed Node'struct)) -data instance C.Parsed Node'struct - = Node'struct' - {dataWordCount :: (RP.Parsed Std_.Word16) - ,pointerCount :: (RP.Parsed Std_.Word16) - ,preferredListEncoding :: (RP.Parsed ElementSize) - ,isGroup :: (RP.Parsed Std_.Bool) - ,discriminantCount :: (RP.Parsed Std_.Word16) - ,discriminantOffset :: (RP.Parsed Std_.Word32) - ,fields :: (RP.Parsed (R.List Field))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'struct)) -deriving instance (Std_.Eq (C.Parsed Node'struct)) -instance (C.Parse Node'struct (C.Parsed Node'struct)) where - parse raw_ = (Node'struct' <$> (GH.parseField #dataWordCount raw_) - <*> (GH.parseField #pointerCount raw_) - <*> (GH.parseField #preferredListEncoding raw_) - <*> (GH.parseField #isGroup raw_) - <*> (GH.parseField #discriminantCount raw_) - <*> (GH.parseField #discriminantOffset raw_) - <*> (GH.parseField #fields raw_)) -instance (C.Marshal Node'struct (C.Parsed Node'struct)) where - marshalInto raw_ Node'struct'{..} = (do - (GH.encodeField #dataWordCount dataWordCount raw_) - (GH.encodeField #pointerCount pointerCount raw_) - (GH.encodeField #preferredListEncoding preferredListEncoding raw_) - (GH.encodeField #isGroup isGroup raw_) - (GH.encodeField #discriminantCount discriminantCount raw_) - (GH.encodeField #discriminantOffset discriminantOffset raw_) - (GH.encodeField #fields fields raw_) - (Std_.pure ()) - ) -instance (GH.HasField "dataWordCount" GH.Slot Node'struct Std_.Word16) where - fieldByLabel = (GH.dataField 48 1 16 0) -instance (GH.HasField "pointerCount" GH.Slot Node'struct Std_.Word16) where - fieldByLabel = (GH.dataField 0 3 16 0) -instance (GH.HasField "preferredListEncoding" GH.Slot Node'struct ElementSize) where - fieldByLabel = (GH.dataField 16 3 16 0) -instance (GH.HasField "isGroup" GH.Slot Node'struct Std_.Bool) where - fieldByLabel = (GH.dataField 32 3 1 0) -instance (GH.HasField "discriminantCount" GH.Slot Node'struct Std_.Word16) where - fieldByLabel = (GH.dataField 48 3 16 0) -instance (GH.HasField "discriminantOffset" GH.Slot Node'struct Std_.Word32) where - fieldByLabel = (GH.dataField 0 4 32 0) -instance (GH.HasField "fields" GH.Slot Node'struct (R.List Field)) where - fieldByLabel = (GH.ptrField 3) -data Node'enum -type instance (R.ReprFor Node'enum) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'enum) where - typeId = 13063450714778629528 -instance (C.TypedStruct Node'enum) where - numStructWords = 5 - numStructPtrs = 6 -instance (C.Allocate Node'enum) where - type AllocHint Node'enum = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'enum (C.Parsed Node'enum)) -instance (C.AllocateList Node'enum) where - type ListAllocHint Node'enum = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'enum (C.Parsed Node'enum)) -data instance C.Parsed Node'enum - = Node'enum' - {enumerants :: (RP.Parsed (R.List Enumerant))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'enum)) -deriving instance (Std_.Eq (C.Parsed Node'enum)) -instance (C.Parse Node'enum (C.Parsed Node'enum)) where - parse raw_ = (Node'enum' <$> (GH.parseField #enumerants raw_)) -instance (C.Marshal Node'enum (C.Parsed Node'enum)) where - marshalInto raw_ Node'enum'{..} = (do - (GH.encodeField #enumerants enumerants raw_) - (Std_.pure ()) - ) -instance (GH.HasField "enumerants" GH.Slot Node'enum (R.List Enumerant)) where - fieldByLabel = (GH.ptrField 3) -data Node'interface -type instance (R.ReprFor Node'interface) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'interface) where - typeId = 16728431493453586831 -instance (C.TypedStruct Node'interface) where - numStructWords = 5 - numStructPtrs = 6 -instance (C.Allocate Node'interface) where - type AllocHint Node'interface = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'interface (C.Parsed Node'interface)) -instance (C.AllocateList Node'interface) where - type ListAllocHint Node'interface = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'interface (C.Parsed Node'interface)) -data instance C.Parsed Node'interface - = Node'interface' - {methods :: (RP.Parsed (R.List Method)) - ,superclasses :: (RP.Parsed (R.List Superclass))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'interface)) -deriving instance (Std_.Eq (C.Parsed Node'interface)) -instance (C.Parse Node'interface (C.Parsed Node'interface)) where - parse raw_ = (Node'interface' <$> (GH.parseField #methods raw_) - <*> (GH.parseField #superclasses raw_)) -instance (C.Marshal Node'interface (C.Parsed Node'interface)) where - marshalInto raw_ Node'interface'{..} = (do - (GH.encodeField #methods methods raw_) - (GH.encodeField #superclasses superclasses raw_) - (Std_.pure ()) - ) -instance (GH.HasField "methods" GH.Slot Node'interface (R.List Method)) where - fieldByLabel = (GH.ptrField 3) -instance (GH.HasField "superclasses" GH.Slot Node'interface (R.List Superclass)) where - fieldByLabel = (GH.ptrField 4) -data Node'const -type instance (R.ReprFor Node'const) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'const) where - typeId = 12793219851699983392 -instance (C.TypedStruct Node'const) where - numStructWords = 5 - numStructPtrs = 6 -instance (C.Allocate Node'const) where - type AllocHint Node'const = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'const (C.Parsed Node'const)) -instance (C.AllocateList Node'const) where - type ListAllocHint Node'const = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'const (C.Parsed Node'const)) -data instance C.Parsed Node'const - = Node'const' - {type_ :: (RP.Parsed Type) - ,value :: (RP.Parsed Value)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'const)) -deriving instance (Std_.Eq (C.Parsed Node'const)) -instance (C.Parse Node'const (C.Parsed Node'const)) where - parse raw_ = (Node'const' <$> (GH.parseField #type_ raw_) - <*> (GH.parseField #value raw_)) -instance (C.Marshal Node'const (C.Parsed Node'const)) where - marshalInto raw_ Node'const'{..} = (do - (GH.encodeField #type_ type_ raw_) - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance (GH.HasField "type_" GH.Slot Node'const Type) where - fieldByLabel = (GH.ptrField 3) -instance (GH.HasField "value" GH.Slot Node'const Value) where - fieldByLabel = (GH.ptrField 4) -data Node'annotation -type instance (R.ReprFor Node'annotation) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'annotation) where - typeId = 17011813041836786320 -instance (C.TypedStruct Node'annotation) where - numStructWords = 5 - numStructPtrs = 6 -instance (C.Allocate Node'annotation) where - type AllocHint Node'annotation = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'annotation (C.Parsed Node'annotation)) -instance (C.AllocateList Node'annotation) where - type ListAllocHint Node'annotation = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'annotation (C.Parsed Node'annotation)) -data instance C.Parsed Node'annotation - = Node'annotation' - {type_ :: (RP.Parsed Type) - ,targetsFile :: (RP.Parsed Std_.Bool) - ,targetsConst :: (RP.Parsed Std_.Bool) - ,targetsEnum :: (RP.Parsed Std_.Bool) - ,targetsEnumerant :: (RP.Parsed Std_.Bool) - ,targetsStruct :: (RP.Parsed Std_.Bool) - ,targetsField :: (RP.Parsed Std_.Bool) - ,targetsUnion :: (RP.Parsed Std_.Bool) - ,targetsGroup :: (RP.Parsed Std_.Bool) - ,targetsInterface :: (RP.Parsed Std_.Bool) - ,targetsMethod :: (RP.Parsed Std_.Bool) - ,targetsParam :: (RP.Parsed Std_.Bool) - ,targetsAnnotation :: (RP.Parsed Std_.Bool)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'annotation)) -deriving instance (Std_.Eq (C.Parsed Node'annotation)) -instance (C.Parse Node'annotation (C.Parsed Node'annotation)) where - parse raw_ = (Node'annotation' <$> (GH.parseField #type_ raw_) - <*> (GH.parseField #targetsFile raw_) - <*> (GH.parseField #targetsConst raw_) - <*> (GH.parseField #targetsEnum raw_) - <*> (GH.parseField #targetsEnumerant raw_) - <*> (GH.parseField #targetsStruct raw_) - <*> (GH.parseField #targetsField raw_) - <*> (GH.parseField #targetsUnion raw_) - <*> (GH.parseField #targetsGroup raw_) - <*> (GH.parseField #targetsInterface raw_) - <*> (GH.parseField #targetsMethod raw_) - <*> (GH.parseField #targetsParam raw_) - <*> (GH.parseField #targetsAnnotation raw_)) -instance (C.Marshal Node'annotation (C.Parsed Node'annotation)) where - marshalInto raw_ Node'annotation'{..} = (do - (GH.encodeField #type_ type_ raw_) - (GH.encodeField #targetsFile targetsFile raw_) - (GH.encodeField #targetsConst targetsConst raw_) - (GH.encodeField #targetsEnum targetsEnum raw_) - (GH.encodeField #targetsEnumerant targetsEnumerant raw_) - (GH.encodeField #targetsStruct targetsStruct raw_) - (GH.encodeField #targetsField targetsField raw_) - (GH.encodeField #targetsUnion targetsUnion raw_) - (GH.encodeField #targetsGroup targetsGroup raw_) - (GH.encodeField #targetsInterface targetsInterface raw_) - (GH.encodeField #targetsMethod targetsMethod raw_) - (GH.encodeField #targetsParam targetsParam raw_) - (GH.encodeField #targetsAnnotation targetsAnnotation raw_) - (Std_.pure ()) - ) -instance (GH.HasField "type_" GH.Slot Node'annotation Type) where - fieldByLabel = (GH.ptrField 3) -instance (GH.HasField "targetsFile" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 48 1 1 0) -instance (GH.HasField "targetsConst" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 49 1 1 0) -instance (GH.HasField "targetsEnum" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 50 1 1 0) -instance (GH.HasField "targetsEnumerant" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 51 1 1 0) -instance (GH.HasField "targetsStruct" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 52 1 1 0) -instance (GH.HasField "targetsField" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 53 1 1 0) -instance (GH.HasField "targetsUnion" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 54 1 1 0) -instance (GH.HasField "targetsGroup" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 55 1 1 0) -instance (GH.HasField "targetsInterface" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 56 1 1 0) -instance (GH.HasField "targetsMethod" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 57 1 1 0) -instance (GH.HasField "targetsParam" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 58 1 1 0) -instance (GH.HasField "targetsAnnotation" GH.Slot Node'annotation Std_.Bool) where - fieldByLabel = (GH.dataField 59 1 1 0) -data Node'Parameter -type instance (R.ReprFor Node'Parameter) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'Parameter) where - typeId = 13353766412138554289 -instance (C.TypedStruct Node'Parameter) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Node'Parameter) where - type AllocHint Node'Parameter = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'Parameter (C.Parsed Node'Parameter)) -instance (C.AllocateList Node'Parameter) where - type ListAllocHint Node'Parameter = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'Parameter (C.Parsed Node'Parameter)) -data instance C.Parsed Node'Parameter - = Node'Parameter - {name :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'Parameter)) -deriving instance (Std_.Eq (C.Parsed Node'Parameter)) -instance (C.Parse Node'Parameter (C.Parsed Node'Parameter)) where - parse raw_ = (Node'Parameter <$> (GH.parseField #name raw_)) -instance (C.Marshal Node'Parameter (C.Parsed Node'Parameter)) where - marshalInto raw_ Node'Parameter{..} = (do - (GH.encodeField #name name raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot Node'Parameter Basics.Text) where - fieldByLabel = (GH.ptrField 0) -data Node'NestedNode -type instance (R.ReprFor Node'NestedNode) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'NestedNode) where - typeId = 16050641862814319170 -instance (C.TypedStruct Node'NestedNode) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Node'NestedNode) where - type AllocHint Node'NestedNode = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'NestedNode (C.Parsed Node'NestedNode)) -instance (C.AllocateList Node'NestedNode) where - type ListAllocHint Node'NestedNode = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'NestedNode (C.Parsed Node'NestedNode)) -data instance C.Parsed Node'NestedNode - = Node'NestedNode - {name :: (RP.Parsed Basics.Text) - ,id :: (RP.Parsed Std_.Word64)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'NestedNode)) -deriving instance (Std_.Eq (C.Parsed Node'NestedNode)) -instance (C.Parse Node'NestedNode (C.Parsed Node'NestedNode)) where - parse raw_ = (Node'NestedNode <$> (GH.parseField #name raw_) - <*> (GH.parseField #id raw_)) -instance (C.Marshal Node'NestedNode (C.Parsed Node'NestedNode)) where - marshalInto raw_ Node'NestedNode{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #id id raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot Node'NestedNode Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "id" GH.Slot Node'NestedNode Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -data Node'SourceInfo -type instance (R.ReprFor Node'SourceInfo) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'SourceInfo) where - typeId = 17549997658772559790 -instance (C.TypedStruct Node'SourceInfo) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate Node'SourceInfo) where - type AllocHint Node'SourceInfo = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'SourceInfo (C.Parsed Node'SourceInfo)) -instance (C.AllocateList Node'SourceInfo) where - type ListAllocHint Node'SourceInfo = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'SourceInfo (C.Parsed Node'SourceInfo)) -data instance C.Parsed Node'SourceInfo - = Node'SourceInfo - {id :: (RP.Parsed Std_.Word64) - ,docComment :: (RP.Parsed Basics.Text) - ,members :: (RP.Parsed (R.List Node'SourceInfo'Member))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'SourceInfo)) -deriving instance (Std_.Eq (C.Parsed Node'SourceInfo)) -instance (C.Parse Node'SourceInfo (C.Parsed Node'SourceInfo)) where - parse raw_ = (Node'SourceInfo <$> (GH.parseField #id raw_) - <*> (GH.parseField #docComment raw_) - <*> (GH.parseField #members raw_)) -instance (C.Marshal Node'SourceInfo (C.Parsed Node'SourceInfo)) where - marshalInto raw_ Node'SourceInfo{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #docComment docComment raw_) - (GH.encodeField #members members raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot Node'SourceInfo Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "docComment" GH.Slot Node'SourceInfo Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "members" GH.Slot Node'SourceInfo (R.List Node'SourceInfo'Member)) where - fieldByLabel = (GH.ptrField 1) -data Node'SourceInfo'Member -type instance (R.ReprFor Node'SourceInfo'Member) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Node'SourceInfo'Member) where - typeId = 14031686161526562722 -instance (C.TypedStruct Node'SourceInfo'Member) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Node'SourceInfo'Member) where - type AllocHint Node'SourceInfo'Member = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) -instance (C.AllocateList Node'SourceInfo'Member) where - type ListAllocHint Node'SourceInfo'Member = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) -data instance C.Parsed Node'SourceInfo'Member - = Node'SourceInfo'Member - {docComment :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Node'SourceInfo'Member)) -deriving instance (Std_.Eq (C.Parsed Node'SourceInfo'Member)) -instance (C.Parse Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) where - parse raw_ = (Node'SourceInfo'Member <$> (GH.parseField #docComment raw_)) -instance (C.Marshal Node'SourceInfo'Member (C.Parsed Node'SourceInfo'Member)) where - marshalInto raw_ Node'SourceInfo'Member{..} = (do - (GH.encodeField #docComment docComment raw_) - (Std_.pure ()) - ) -instance (GH.HasField "docComment" GH.Slot Node'SourceInfo'Member Basics.Text) where - fieldByLabel = (GH.ptrField 0) -data Field -type instance (R.ReprFor Field) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Field) where - typeId = 11145653318641710175 -instance (C.TypedStruct Field) where - numStructWords = 3 - numStructPtrs = 4 -instance (C.Allocate Field) where - type AllocHint Field = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Field (C.Parsed Field)) -instance (C.AllocateList Field) where - type ListAllocHint Field = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Field (C.Parsed Field)) -data instance C.Parsed Field - = Field - {name :: (RP.Parsed Basics.Text) - ,codeOrder :: (RP.Parsed Std_.Word16) - ,annotations :: (RP.Parsed (R.List Annotation)) - ,discriminantValue :: (RP.Parsed Std_.Word16) - ,ordinal :: (RP.Parsed Field'ordinal) - ,union' :: (C.Parsed (GH.Which Field))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Field)) -deriving instance (Std_.Eq (C.Parsed Field)) -instance (C.Parse Field (C.Parsed Field)) where - parse raw_ = (Field <$> (GH.parseField #name raw_) - <*> (GH.parseField #codeOrder raw_) - <*> (GH.parseField #annotations raw_) - <*> (GH.parseField #discriminantValue raw_) - <*> (GH.parseField #ordinal raw_) - <*> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Field (C.Parsed Field)) where - marshalInto raw_ Field{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #codeOrder codeOrder raw_) - (GH.encodeField #annotations annotations raw_) - (GH.encodeField #discriminantValue discriminantValue raw_) - (do - group_ <- (GH.readField #ordinal raw_) - (C.marshalInto group_ ordinal) - ) - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Field) where - unionField = (GH.dataField 0 1 16 0) - data RawWhich Field mut_ - = RW_Field'slot (R.Raw Field'slot mut_) - | RW_Field'group (R.Raw Field'group mut_) - | RW_Field'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Field'slot <$> (GH.readVariant #slot struct_)) - 1 -> - (RW_Field'group <$> (GH.readVariant #group struct_)) - _ -> - (Std_.pure (RW_Field'unknown' tag_)) - data Which Field -instance (GH.HasVariant "slot" GH.Group Field Field'slot) where - variantByLabel = (GH.Variant GH.groupField 0) -instance (GH.HasVariant "group" GH.Group Field Field'group) where - variantByLabel = (GH.Variant GH.groupField 1) -data instance C.Parsed (GH.Which Field) - = Field'slot (RP.Parsed Field'slot) - | Field'group (RP.Parsed Field'group) - | Field'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Field))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Field))) -instance (C.Parse (GH.Which Field) (C.Parsed (GH.Which Field))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Field'slot rawArg_) -> - (Field'slot <$> (C.parse rawArg_)) - (RW_Field'group rawArg_) -> - (Field'group <$> (C.parse rawArg_)) - (RW_Field'unknown' tag_) -> - (Std_.pure (Field'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Field) (C.Parsed (GH.Which Field))) where - marshalInto raw_ parsed_ = case parsed_ of - (Field'slot arg_) -> - (do - rawGroup_ <- (GH.initVariant #slot (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Field'group arg_) -> - (do - rawGroup_ <- (GH.initVariant #group (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Field'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -instance (GH.HasField "name" GH.Slot Field Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "codeOrder" GH.Slot Field Std_.Word16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "annotations" GH.Slot Field (R.List Annotation)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "discriminantValue" GH.Slot Field Std_.Word16) where - fieldByLabel = (GH.dataField 16 0 16 65535) -instance (GH.HasField "ordinal" GH.Group Field Field'ordinal) where - fieldByLabel = GH.groupField -data Field'slot -type instance (R.ReprFor Field'slot) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Field'slot) where - typeId = 14133145859926553711 -instance (C.TypedStruct Field'slot) where - numStructWords = 3 - numStructPtrs = 4 -instance (C.Allocate Field'slot) where - type AllocHint Field'slot = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Field'slot (C.Parsed Field'slot)) -instance (C.AllocateList Field'slot) where - type ListAllocHint Field'slot = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Field'slot (C.Parsed Field'slot)) -data instance C.Parsed Field'slot - = Field'slot' - {offset :: (RP.Parsed Std_.Word32) - ,type_ :: (RP.Parsed Type) - ,defaultValue :: (RP.Parsed Value) - ,hadExplicitDefault :: (RP.Parsed Std_.Bool)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Field'slot)) -deriving instance (Std_.Eq (C.Parsed Field'slot)) -instance (C.Parse Field'slot (C.Parsed Field'slot)) where - parse raw_ = (Field'slot' <$> (GH.parseField #offset raw_) - <*> (GH.parseField #type_ raw_) - <*> (GH.parseField #defaultValue raw_) - <*> (GH.parseField #hadExplicitDefault raw_)) -instance (C.Marshal Field'slot (C.Parsed Field'slot)) where - marshalInto raw_ Field'slot'{..} = (do - (GH.encodeField #offset offset raw_) - (GH.encodeField #type_ type_ raw_) - (GH.encodeField #defaultValue defaultValue raw_) - (GH.encodeField #hadExplicitDefault hadExplicitDefault raw_) - (Std_.pure ()) - ) -instance (GH.HasField "offset" GH.Slot Field'slot Std_.Word32) where - fieldByLabel = (GH.dataField 32 0 32 0) -instance (GH.HasField "type_" GH.Slot Field'slot Type) where - fieldByLabel = (GH.ptrField 2) -instance (GH.HasField "defaultValue" GH.Slot Field'slot Value) where - fieldByLabel = (GH.ptrField 3) -instance (GH.HasField "hadExplicitDefault" GH.Slot Field'slot Std_.Bool) where - fieldByLabel = (GH.dataField 0 2 1 0) -data Field'group -type instance (R.ReprFor Field'group) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Field'group) where - typeId = 14626792032033250577 -instance (C.TypedStruct Field'group) where - numStructWords = 3 - numStructPtrs = 4 -instance (C.Allocate Field'group) where - type AllocHint Field'group = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Field'group (C.Parsed Field'group)) -instance (C.AllocateList Field'group) where - type ListAllocHint Field'group = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Field'group (C.Parsed Field'group)) -data instance C.Parsed Field'group - = Field'group' - {typeId :: (RP.Parsed Std_.Word64)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Field'group)) -deriving instance (Std_.Eq (C.Parsed Field'group)) -instance (C.Parse Field'group (C.Parsed Field'group)) where - parse raw_ = (Field'group' <$> (GH.parseField #typeId raw_)) -instance (C.Marshal Field'group (C.Parsed Field'group)) where - marshalInto raw_ Field'group'{..} = (do - (GH.encodeField #typeId typeId raw_) - (Std_.pure ()) - ) -instance (GH.HasField "typeId" GH.Slot Field'group Std_.Word64) where - fieldByLabel = (GH.dataField 0 2 64 0) -data Field'ordinal -type instance (R.ReprFor Field'ordinal) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Field'ordinal) where - typeId = 13515537513213004774 -instance (C.TypedStruct Field'ordinal) where - numStructWords = 3 - numStructPtrs = 4 -instance (C.Allocate Field'ordinal) where - type AllocHint Field'ordinal = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Field'ordinal (C.Parsed Field'ordinal)) -instance (C.AllocateList Field'ordinal) where - type ListAllocHint Field'ordinal = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Field'ordinal (C.Parsed Field'ordinal)) -data instance C.Parsed Field'ordinal - = Field'ordinal' - {union' :: (C.Parsed (GH.Which Field'ordinal))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Field'ordinal)) -deriving instance (Std_.Eq (C.Parsed Field'ordinal)) -instance (C.Parse Field'ordinal (C.Parsed Field'ordinal)) where - parse raw_ = (Field'ordinal' <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Field'ordinal (C.Parsed Field'ordinal)) where - marshalInto raw_ Field'ordinal'{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Field'ordinal) where - unionField = (GH.dataField 16 1 16 0) - data RawWhich Field'ordinal mut_ - = RW_Field'ordinal'implicit (R.Raw () mut_) - | RW_Field'ordinal'explicit (R.Raw Std_.Word16 mut_) - | RW_Field'ordinal'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Field'ordinal'implicit <$> (GH.readVariant #implicit struct_)) - 1 -> - (RW_Field'ordinal'explicit <$> (GH.readVariant #explicit struct_)) - _ -> - (Std_.pure (RW_Field'ordinal'unknown' tag_)) - data Which Field'ordinal -instance (GH.HasVariant "implicit" GH.Slot Field'ordinal ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "explicit" GH.Slot Field'ordinal Std_.Word16) where - variantByLabel = (GH.Variant (GH.dataField 32 1 16 0) 1) -data instance C.Parsed (GH.Which Field'ordinal) - = Field'ordinal'implicit - | Field'ordinal'explicit (RP.Parsed Std_.Word16) - | Field'ordinal'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Field'ordinal))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Field'ordinal))) -instance (C.Parse (GH.Which Field'ordinal) (C.Parsed (GH.Which Field'ordinal))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Field'ordinal'implicit _) -> - (Std_.pure Field'ordinal'implicit) - (RW_Field'ordinal'explicit rawArg_) -> - (Field'ordinal'explicit <$> (C.parse rawArg_)) - (RW_Field'ordinal'unknown' tag_) -> - (Std_.pure (Field'ordinal'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Field'ordinal) (C.Parsed (GH.Which Field'ordinal))) where - marshalInto raw_ parsed_ = case parsed_ of - (Field'ordinal'implicit) -> - (GH.encodeVariant #implicit () (GH.unionStruct raw_)) - (Field'ordinal'explicit arg_) -> - (GH.encodeVariant #explicit arg_ (GH.unionStruct raw_)) - (Field'ordinal'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -field'noDiscriminant :: Std_.Word16 -field'noDiscriminant = (C.fromWord 65535) -data Enumerant -type instance (R.ReprFor Enumerant) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Enumerant) where - typeId = 10919677598968879693 -instance (C.TypedStruct Enumerant) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate Enumerant) where - type AllocHint Enumerant = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Enumerant (C.Parsed Enumerant)) -instance (C.AllocateList Enumerant) where - type ListAllocHint Enumerant = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Enumerant (C.Parsed Enumerant)) -data instance C.Parsed Enumerant - = Enumerant - {name :: (RP.Parsed Basics.Text) - ,codeOrder :: (RP.Parsed Std_.Word16) - ,annotations :: (RP.Parsed (R.List Annotation))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Enumerant)) -deriving instance (Std_.Eq (C.Parsed Enumerant)) -instance (C.Parse Enumerant (C.Parsed Enumerant)) where - parse raw_ = (Enumerant <$> (GH.parseField #name raw_) - <*> (GH.parseField #codeOrder raw_) - <*> (GH.parseField #annotations raw_)) -instance (C.Marshal Enumerant (C.Parsed Enumerant)) where - marshalInto raw_ Enumerant{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #codeOrder codeOrder raw_) - (GH.encodeField #annotations annotations raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot Enumerant Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "codeOrder" GH.Slot Enumerant Std_.Word16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "annotations" GH.Slot Enumerant (R.List Annotation)) where - fieldByLabel = (GH.ptrField 1) -data Superclass -type instance (R.ReprFor Superclass) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Superclass) where - typeId = 12220001500510083064 -instance (C.TypedStruct Superclass) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Superclass) where - type AllocHint Superclass = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Superclass (C.Parsed Superclass)) -instance (C.AllocateList Superclass) where - type ListAllocHint Superclass = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Superclass (C.Parsed Superclass)) -data instance C.Parsed Superclass - = Superclass - {id :: (RP.Parsed Std_.Word64) - ,brand :: (RP.Parsed Brand)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Superclass)) -deriving instance (Std_.Eq (C.Parsed Superclass)) -instance (C.Parse Superclass (C.Parsed Superclass)) where - parse raw_ = (Superclass <$> (GH.parseField #id raw_) - <*> (GH.parseField #brand raw_)) -instance (C.Marshal Superclass (C.Parsed Superclass)) where - marshalInto raw_ Superclass{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #brand brand raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot Superclass Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "brand" GH.Slot Superclass Brand) where - fieldByLabel = (GH.ptrField 0) -data Method -type instance (R.ReprFor Method) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Method) where - typeId = 10736806783679155584 -instance (C.TypedStruct Method) where - numStructWords = 3 - numStructPtrs = 5 -instance (C.Allocate Method) where - type AllocHint Method = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Method (C.Parsed Method)) -instance (C.AllocateList Method) where - type ListAllocHint Method = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Method (C.Parsed Method)) -data instance C.Parsed Method - = Method - {name :: (RP.Parsed Basics.Text) - ,codeOrder :: (RP.Parsed Std_.Word16) - ,paramStructType :: (RP.Parsed Std_.Word64) - ,resultStructType :: (RP.Parsed Std_.Word64) - ,annotations :: (RP.Parsed (R.List Annotation)) - ,paramBrand :: (RP.Parsed Brand) - ,resultBrand :: (RP.Parsed Brand) - ,implicitParameters :: (RP.Parsed (R.List Node'Parameter))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Method)) -deriving instance (Std_.Eq (C.Parsed Method)) -instance (C.Parse Method (C.Parsed Method)) where - parse raw_ = (Method <$> (GH.parseField #name raw_) - <*> (GH.parseField #codeOrder raw_) - <*> (GH.parseField #paramStructType raw_) - <*> (GH.parseField #resultStructType raw_) - <*> (GH.parseField #annotations raw_) - <*> (GH.parseField #paramBrand raw_) - <*> (GH.parseField #resultBrand raw_) - <*> (GH.parseField #implicitParameters raw_)) -instance (C.Marshal Method (C.Parsed Method)) where - marshalInto raw_ Method{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #codeOrder codeOrder raw_) - (GH.encodeField #paramStructType paramStructType raw_) - (GH.encodeField #resultStructType resultStructType raw_) - (GH.encodeField #annotations annotations raw_) - (GH.encodeField #paramBrand paramBrand raw_) - (GH.encodeField #resultBrand resultBrand raw_) - (GH.encodeField #implicitParameters implicitParameters raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot Method Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "codeOrder" GH.Slot Method Std_.Word16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "paramStructType" GH.Slot Method Std_.Word64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "resultStructType" GH.Slot Method Std_.Word64) where - fieldByLabel = (GH.dataField 0 2 64 0) -instance (GH.HasField "annotations" GH.Slot Method (R.List Annotation)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "paramBrand" GH.Slot Method Brand) where - fieldByLabel = (GH.ptrField 2) -instance (GH.HasField "resultBrand" GH.Slot Method Brand) where - fieldByLabel = (GH.ptrField 3) -instance (GH.HasField "implicitParameters" GH.Slot Method (R.List Node'Parameter)) where - fieldByLabel = (GH.ptrField 4) -data Type -type instance (R.ReprFor Type) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type) where - typeId = 15020482145304562784 -instance (C.TypedStruct Type) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type) where - type AllocHint Type = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type (C.Parsed Type)) -instance (C.AllocateList Type) where - type ListAllocHint Type = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type (C.Parsed Type)) -data instance C.Parsed Type - = Type - {union' :: (C.Parsed (GH.Which Type))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type)) -deriving instance (Std_.Eq (C.Parsed Type)) -instance (C.Parse Type (C.Parsed Type)) where - parse raw_ = (Type <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Type (C.Parsed Type)) where - marshalInto raw_ Type{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Type) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Type mut_ - = RW_Type'void (R.Raw () mut_) - | RW_Type'bool (R.Raw () mut_) - | RW_Type'int8 (R.Raw () mut_) - | RW_Type'int16 (R.Raw () mut_) - | RW_Type'int32 (R.Raw () mut_) - | RW_Type'int64 (R.Raw () mut_) - | RW_Type'uint8 (R.Raw () mut_) - | RW_Type'uint16 (R.Raw () mut_) - | RW_Type'uint32 (R.Raw () mut_) - | RW_Type'uint64 (R.Raw () mut_) - | RW_Type'float32 (R.Raw () mut_) - | RW_Type'float64 (R.Raw () mut_) - | RW_Type'text (R.Raw () mut_) - | RW_Type'data_ (R.Raw () mut_) - | RW_Type'list (R.Raw Type'list mut_) - | RW_Type'enum (R.Raw Type'enum mut_) - | RW_Type'struct (R.Raw Type'struct mut_) - | RW_Type'interface (R.Raw Type'interface mut_) - | RW_Type'anyPointer (R.Raw Type'anyPointer mut_) - | RW_Type'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Type'void <$> (GH.readVariant #void struct_)) - 1 -> - (RW_Type'bool <$> (GH.readVariant #bool struct_)) - 2 -> - (RW_Type'int8 <$> (GH.readVariant #int8 struct_)) - 3 -> - (RW_Type'int16 <$> (GH.readVariant #int16 struct_)) - 4 -> - (RW_Type'int32 <$> (GH.readVariant #int32 struct_)) - 5 -> - (RW_Type'int64 <$> (GH.readVariant #int64 struct_)) - 6 -> - (RW_Type'uint8 <$> (GH.readVariant #uint8 struct_)) - 7 -> - (RW_Type'uint16 <$> (GH.readVariant #uint16 struct_)) - 8 -> - (RW_Type'uint32 <$> (GH.readVariant #uint32 struct_)) - 9 -> - (RW_Type'uint64 <$> (GH.readVariant #uint64 struct_)) - 10 -> - (RW_Type'float32 <$> (GH.readVariant #float32 struct_)) - 11 -> - (RW_Type'float64 <$> (GH.readVariant #float64 struct_)) - 12 -> - (RW_Type'text <$> (GH.readVariant #text struct_)) - 13 -> - (RW_Type'data_ <$> (GH.readVariant #data_ struct_)) - 14 -> - (RW_Type'list <$> (GH.readVariant #list struct_)) - 15 -> - (RW_Type'enum <$> (GH.readVariant #enum struct_)) - 16 -> - (RW_Type'struct <$> (GH.readVariant #struct struct_)) - 17 -> - (RW_Type'interface <$> (GH.readVariant #interface struct_)) - 18 -> - (RW_Type'anyPointer <$> (GH.readVariant #anyPointer struct_)) - _ -> - (Std_.pure (RW_Type'unknown' tag_)) - data Which Type -instance (GH.HasVariant "void" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "bool" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 1) -instance (GH.HasVariant "int8" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 2) -instance (GH.HasVariant "int16" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 3) -instance (GH.HasVariant "int32" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 4) -instance (GH.HasVariant "int64" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 5) -instance (GH.HasVariant "uint8" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 6) -instance (GH.HasVariant "uint16" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 7) -instance (GH.HasVariant "uint32" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 8) -instance (GH.HasVariant "uint64" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 9) -instance (GH.HasVariant "float32" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 10) -instance (GH.HasVariant "float64" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 11) -instance (GH.HasVariant "text" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 12) -instance (GH.HasVariant "data_" GH.Slot Type ()) where - variantByLabel = (GH.Variant GH.voidField 13) -instance (GH.HasVariant "list" GH.Group Type Type'list) where - variantByLabel = (GH.Variant GH.groupField 14) -instance (GH.HasVariant "enum" GH.Group Type Type'enum) where - variantByLabel = (GH.Variant GH.groupField 15) -instance (GH.HasVariant "struct" GH.Group Type Type'struct) where - variantByLabel = (GH.Variant GH.groupField 16) -instance (GH.HasVariant "interface" GH.Group Type Type'interface) where - variantByLabel = (GH.Variant GH.groupField 17) -instance (GH.HasVariant "anyPointer" GH.Group Type Type'anyPointer) where - variantByLabel = (GH.Variant GH.groupField 18) -data instance C.Parsed (GH.Which Type) - = Type'void - | Type'bool - | Type'int8 - | Type'int16 - | Type'int32 - | Type'int64 - | Type'uint8 - | Type'uint16 - | Type'uint32 - | Type'uint64 - | Type'float32 - | Type'float64 - | Type'text - | Type'data_ - | Type'list (RP.Parsed Type'list) - | Type'enum (RP.Parsed Type'enum) - | Type'struct (RP.Parsed Type'struct) - | Type'interface (RP.Parsed Type'interface) - | Type'anyPointer (RP.Parsed Type'anyPointer) - | Type'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Type))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Type))) -instance (C.Parse (GH.Which Type) (C.Parsed (GH.Which Type))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Type'void _) -> - (Std_.pure Type'void) - (RW_Type'bool _) -> - (Std_.pure Type'bool) - (RW_Type'int8 _) -> - (Std_.pure Type'int8) - (RW_Type'int16 _) -> - (Std_.pure Type'int16) - (RW_Type'int32 _) -> - (Std_.pure Type'int32) - (RW_Type'int64 _) -> - (Std_.pure Type'int64) - (RW_Type'uint8 _) -> - (Std_.pure Type'uint8) - (RW_Type'uint16 _) -> - (Std_.pure Type'uint16) - (RW_Type'uint32 _) -> - (Std_.pure Type'uint32) - (RW_Type'uint64 _) -> - (Std_.pure Type'uint64) - (RW_Type'float32 _) -> - (Std_.pure Type'float32) - (RW_Type'float64 _) -> - (Std_.pure Type'float64) - (RW_Type'text _) -> - (Std_.pure Type'text) - (RW_Type'data_ _) -> - (Std_.pure Type'data_) - (RW_Type'list rawArg_) -> - (Type'list <$> (C.parse rawArg_)) - (RW_Type'enum rawArg_) -> - (Type'enum <$> (C.parse rawArg_)) - (RW_Type'struct rawArg_) -> - (Type'struct <$> (C.parse rawArg_)) - (RW_Type'interface rawArg_) -> - (Type'interface <$> (C.parse rawArg_)) - (RW_Type'anyPointer rawArg_) -> - (Type'anyPointer <$> (C.parse rawArg_)) - (RW_Type'unknown' tag_) -> - (Std_.pure (Type'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Type) (C.Parsed (GH.Which Type))) where - marshalInto raw_ parsed_ = case parsed_ of - (Type'void) -> - (GH.encodeVariant #void () (GH.unionStruct raw_)) - (Type'bool) -> - (GH.encodeVariant #bool () (GH.unionStruct raw_)) - (Type'int8) -> - (GH.encodeVariant #int8 () (GH.unionStruct raw_)) - (Type'int16) -> - (GH.encodeVariant #int16 () (GH.unionStruct raw_)) - (Type'int32) -> - (GH.encodeVariant #int32 () (GH.unionStruct raw_)) - (Type'int64) -> - (GH.encodeVariant #int64 () (GH.unionStruct raw_)) - (Type'uint8) -> - (GH.encodeVariant #uint8 () (GH.unionStruct raw_)) - (Type'uint16) -> - (GH.encodeVariant #uint16 () (GH.unionStruct raw_)) - (Type'uint32) -> - (GH.encodeVariant #uint32 () (GH.unionStruct raw_)) - (Type'uint64) -> - (GH.encodeVariant #uint64 () (GH.unionStruct raw_)) - (Type'float32) -> - (GH.encodeVariant #float32 () (GH.unionStruct raw_)) - (Type'float64) -> - (GH.encodeVariant #float64 () (GH.unionStruct raw_)) - (Type'text) -> - (GH.encodeVariant #text () (GH.unionStruct raw_)) - (Type'data_) -> - (GH.encodeVariant #data_ () (GH.unionStruct raw_)) - (Type'list arg_) -> - (do - rawGroup_ <- (GH.initVariant #list (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'enum arg_) -> - (do - rawGroup_ <- (GH.initVariant #enum (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'struct arg_) -> - (do - rawGroup_ <- (GH.initVariant #struct (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'interface arg_) -> - (do - rawGroup_ <- (GH.initVariant #interface (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'anyPointer arg_) -> - (do - rawGroup_ <- (GH.initVariant #anyPointer (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Type'list -type instance (R.ReprFor Type'list) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'list) where - typeId = 9792858745991129751 -instance (C.TypedStruct Type'list) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'list) where - type AllocHint Type'list = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'list (C.Parsed Type'list)) -instance (C.AllocateList Type'list) where - type ListAllocHint Type'list = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'list (C.Parsed Type'list)) -data instance C.Parsed Type'list - = Type'list' - {elementType :: (RP.Parsed Type)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'list)) -deriving instance (Std_.Eq (C.Parsed Type'list)) -instance (C.Parse Type'list (C.Parsed Type'list)) where - parse raw_ = (Type'list' <$> (GH.parseField #elementType raw_)) -instance (C.Marshal Type'list (C.Parsed Type'list)) where - marshalInto raw_ Type'list'{..} = (do - (GH.encodeField #elementType elementType raw_) - (Std_.pure ()) - ) -instance (GH.HasField "elementType" GH.Slot Type'list Type) where - fieldByLabel = (GH.ptrField 0) -data Type'enum -type instance (R.ReprFor Type'enum) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'enum) where - typeId = 11389172934837766057 -instance (C.TypedStruct Type'enum) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'enum) where - type AllocHint Type'enum = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'enum (C.Parsed Type'enum)) -instance (C.AllocateList Type'enum) where - type ListAllocHint Type'enum = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'enum (C.Parsed Type'enum)) -data instance C.Parsed Type'enum - = Type'enum' - {typeId :: (RP.Parsed Std_.Word64) - ,brand :: (RP.Parsed Brand)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'enum)) -deriving instance (Std_.Eq (C.Parsed Type'enum)) -instance (C.Parse Type'enum (C.Parsed Type'enum)) where - parse raw_ = (Type'enum' <$> (GH.parseField #typeId raw_) - <*> (GH.parseField #brand raw_)) -instance (C.Marshal Type'enum (C.Parsed Type'enum)) where - marshalInto raw_ Type'enum'{..} = (do - (GH.encodeField #typeId typeId raw_) - (GH.encodeField #brand brand raw_) - (Std_.pure ()) - ) -instance (GH.HasField "typeId" GH.Slot Type'enum Std_.Word64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "brand" GH.Slot Type'enum Brand) where - fieldByLabel = (GH.ptrField 0) -data Type'struct -type instance (R.ReprFor Type'struct) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'struct) where - typeId = 12410354185295152851 -instance (C.TypedStruct Type'struct) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'struct) where - type AllocHint Type'struct = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'struct (C.Parsed Type'struct)) -instance (C.AllocateList Type'struct) where - type ListAllocHint Type'struct = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'struct (C.Parsed Type'struct)) -data instance C.Parsed Type'struct - = Type'struct' - {typeId :: (RP.Parsed Std_.Word64) - ,brand :: (RP.Parsed Brand)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'struct)) -deriving instance (Std_.Eq (C.Parsed Type'struct)) -instance (C.Parse Type'struct (C.Parsed Type'struct)) where - parse raw_ = (Type'struct' <$> (GH.parseField #typeId raw_) - <*> (GH.parseField #brand raw_)) -instance (C.Marshal Type'struct (C.Parsed Type'struct)) where - marshalInto raw_ Type'struct'{..} = (do - (GH.encodeField #typeId typeId raw_) - (GH.encodeField #brand brand raw_) - (Std_.pure ()) - ) -instance (GH.HasField "typeId" GH.Slot Type'struct Std_.Word64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "brand" GH.Slot Type'struct Brand) where - fieldByLabel = (GH.ptrField 0) -data Type'interface -type instance (R.ReprFor Type'interface) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'interface) where - typeId = 17116997365232503999 -instance (C.TypedStruct Type'interface) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'interface) where - type AllocHint Type'interface = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'interface (C.Parsed Type'interface)) -instance (C.AllocateList Type'interface) where - type ListAllocHint Type'interface = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'interface (C.Parsed Type'interface)) -data instance C.Parsed Type'interface - = Type'interface' - {typeId :: (RP.Parsed Std_.Word64) - ,brand :: (RP.Parsed Brand)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'interface)) -deriving instance (Std_.Eq (C.Parsed Type'interface)) -instance (C.Parse Type'interface (C.Parsed Type'interface)) where - parse raw_ = (Type'interface' <$> (GH.parseField #typeId raw_) - <*> (GH.parseField #brand raw_)) -instance (C.Marshal Type'interface (C.Parsed Type'interface)) where - marshalInto raw_ Type'interface'{..} = (do - (GH.encodeField #typeId typeId raw_) - (GH.encodeField #brand brand raw_) - (Std_.pure ()) - ) -instance (GH.HasField "typeId" GH.Slot Type'interface Std_.Word64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "brand" GH.Slot Type'interface Brand) where - fieldByLabel = (GH.ptrField 0) -data Type'anyPointer -type instance (R.ReprFor Type'anyPointer) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'anyPointer) where - typeId = 14003731834718800369 -instance (C.TypedStruct Type'anyPointer) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'anyPointer) where - type AllocHint Type'anyPointer = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'anyPointer (C.Parsed Type'anyPointer)) -instance (C.AllocateList Type'anyPointer) where - type ListAllocHint Type'anyPointer = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'anyPointer (C.Parsed Type'anyPointer)) -data instance C.Parsed Type'anyPointer - = Type'anyPointer' - {union' :: (C.Parsed (GH.Which Type'anyPointer))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'anyPointer)) -deriving instance (Std_.Eq (C.Parsed Type'anyPointer)) -instance (C.Parse Type'anyPointer (C.Parsed Type'anyPointer)) where - parse raw_ = (Type'anyPointer' <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Type'anyPointer (C.Parsed Type'anyPointer)) where - marshalInto raw_ Type'anyPointer'{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Type'anyPointer) where - unionField = (GH.dataField 0 1 16 0) - data RawWhich Type'anyPointer mut_ - = RW_Type'anyPointer'unconstrained (R.Raw Type'anyPointer'unconstrained mut_) - | RW_Type'anyPointer'parameter (R.Raw Type'anyPointer'parameter mut_) - | RW_Type'anyPointer'implicitMethodParameter (R.Raw Type'anyPointer'implicitMethodParameter mut_) - | RW_Type'anyPointer'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Type'anyPointer'unconstrained <$> (GH.readVariant #unconstrained struct_)) - 1 -> - (RW_Type'anyPointer'parameter <$> (GH.readVariant #parameter struct_)) - 2 -> - (RW_Type'anyPointer'implicitMethodParameter <$> (GH.readVariant #implicitMethodParameter struct_)) - _ -> - (Std_.pure (RW_Type'anyPointer'unknown' tag_)) - data Which Type'anyPointer -instance (GH.HasVariant "unconstrained" GH.Group Type'anyPointer Type'anyPointer'unconstrained) where - variantByLabel = (GH.Variant GH.groupField 0) -instance (GH.HasVariant "parameter" GH.Group Type'anyPointer Type'anyPointer'parameter) where - variantByLabel = (GH.Variant GH.groupField 1) -instance (GH.HasVariant "implicitMethodParameter" GH.Group Type'anyPointer Type'anyPointer'implicitMethodParameter) where - variantByLabel = (GH.Variant GH.groupField 2) -data instance C.Parsed (GH.Which Type'anyPointer) - = Type'anyPointer'unconstrained (RP.Parsed Type'anyPointer'unconstrained) - | Type'anyPointer'parameter (RP.Parsed Type'anyPointer'parameter) - | Type'anyPointer'implicitMethodParameter (RP.Parsed Type'anyPointer'implicitMethodParameter) - | Type'anyPointer'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Type'anyPointer))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Type'anyPointer))) -instance (C.Parse (GH.Which Type'anyPointer) (C.Parsed (GH.Which Type'anyPointer))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Type'anyPointer'unconstrained rawArg_) -> - (Type'anyPointer'unconstrained <$> (C.parse rawArg_)) - (RW_Type'anyPointer'parameter rawArg_) -> - (Type'anyPointer'parameter <$> (C.parse rawArg_)) - (RW_Type'anyPointer'implicitMethodParameter rawArg_) -> - (Type'anyPointer'implicitMethodParameter <$> (C.parse rawArg_)) - (RW_Type'anyPointer'unknown' tag_) -> - (Std_.pure (Type'anyPointer'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Type'anyPointer) (C.Parsed (GH.Which Type'anyPointer))) where - marshalInto raw_ parsed_ = case parsed_ of - (Type'anyPointer'unconstrained arg_) -> - (do - rawGroup_ <- (GH.initVariant #unconstrained (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'anyPointer'parameter arg_) -> - (do - rawGroup_ <- (GH.initVariant #parameter (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'anyPointer'implicitMethodParameter arg_) -> - (do - rawGroup_ <- (GH.initVariant #implicitMethodParameter (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Type'anyPointer'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Type'anyPointer'unconstrained -type instance (R.ReprFor Type'anyPointer'unconstrained) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'anyPointer'unconstrained) where - typeId = 10248890354574636630 -instance (C.TypedStruct Type'anyPointer'unconstrained) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'anyPointer'unconstrained) where - type AllocHint Type'anyPointer'unconstrained = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) -instance (C.AllocateList Type'anyPointer'unconstrained) where - type ListAllocHint Type'anyPointer'unconstrained = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) -data instance C.Parsed Type'anyPointer'unconstrained - = Type'anyPointer'unconstrained' - {union' :: (C.Parsed (GH.Which Type'anyPointer'unconstrained))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'anyPointer'unconstrained)) -deriving instance (Std_.Eq (C.Parsed Type'anyPointer'unconstrained)) -instance (C.Parse Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) where - parse raw_ = (Type'anyPointer'unconstrained' <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Type'anyPointer'unconstrained (C.Parsed Type'anyPointer'unconstrained)) where - marshalInto raw_ Type'anyPointer'unconstrained'{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Type'anyPointer'unconstrained) where - unionField = (GH.dataField 16 1 16 0) - data RawWhich Type'anyPointer'unconstrained mut_ - = RW_Type'anyPointer'unconstrained'anyKind (R.Raw () mut_) - | RW_Type'anyPointer'unconstrained'struct (R.Raw () mut_) - | RW_Type'anyPointer'unconstrained'list (R.Raw () mut_) - | RW_Type'anyPointer'unconstrained'capability (R.Raw () mut_) - | RW_Type'anyPointer'unconstrained'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Type'anyPointer'unconstrained'anyKind <$> (GH.readVariant #anyKind struct_)) - 1 -> - (RW_Type'anyPointer'unconstrained'struct <$> (GH.readVariant #struct struct_)) - 2 -> - (RW_Type'anyPointer'unconstrained'list <$> (GH.readVariant #list struct_)) - 3 -> - (RW_Type'anyPointer'unconstrained'capability <$> (GH.readVariant #capability struct_)) - _ -> - (Std_.pure (RW_Type'anyPointer'unconstrained'unknown' tag_)) - data Which Type'anyPointer'unconstrained -instance (GH.HasVariant "anyKind" GH.Slot Type'anyPointer'unconstrained ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "struct" GH.Slot Type'anyPointer'unconstrained ()) where - variantByLabel = (GH.Variant GH.voidField 1) -instance (GH.HasVariant "list" GH.Slot Type'anyPointer'unconstrained ()) where - variantByLabel = (GH.Variant GH.voidField 2) -instance (GH.HasVariant "capability" GH.Slot Type'anyPointer'unconstrained ()) where - variantByLabel = (GH.Variant GH.voidField 3) -data instance C.Parsed (GH.Which Type'anyPointer'unconstrained) - = Type'anyPointer'unconstrained'anyKind - | Type'anyPointer'unconstrained'struct - | Type'anyPointer'unconstrained'list - | Type'anyPointer'unconstrained'capability - | Type'anyPointer'unconstrained'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Type'anyPointer'unconstrained))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Type'anyPointer'unconstrained))) -instance (C.Parse (GH.Which Type'anyPointer'unconstrained) (C.Parsed (GH.Which Type'anyPointer'unconstrained))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Type'anyPointer'unconstrained'anyKind _) -> - (Std_.pure Type'anyPointer'unconstrained'anyKind) - (RW_Type'anyPointer'unconstrained'struct _) -> - (Std_.pure Type'anyPointer'unconstrained'struct) - (RW_Type'anyPointer'unconstrained'list _) -> - (Std_.pure Type'anyPointer'unconstrained'list) - (RW_Type'anyPointer'unconstrained'capability _) -> - (Std_.pure Type'anyPointer'unconstrained'capability) - (RW_Type'anyPointer'unconstrained'unknown' tag_) -> - (Std_.pure (Type'anyPointer'unconstrained'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Type'anyPointer'unconstrained) (C.Parsed (GH.Which Type'anyPointer'unconstrained))) where - marshalInto raw_ parsed_ = case parsed_ of - (Type'anyPointer'unconstrained'anyKind) -> - (GH.encodeVariant #anyKind () (GH.unionStruct raw_)) - (Type'anyPointer'unconstrained'struct) -> - (GH.encodeVariant #struct () (GH.unionStruct raw_)) - (Type'anyPointer'unconstrained'list) -> - (GH.encodeVariant #list () (GH.unionStruct raw_)) - (Type'anyPointer'unconstrained'capability) -> - (GH.encodeVariant #capability () (GH.unionStruct raw_)) - (Type'anyPointer'unconstrained'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Type'anyPointer'parameter -type instance (R.ReprFor Type'anyPointer'parameter) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'anyPointer'parameter) where - typeId = 11372142272178113157 -instance (C.TypedStruct Type'anyPointer'parameter) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'anyPointer'parameter) where - type AllocHint Type'anyPointer'parameter = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) -instance (C.AllocateList Type'anyPointer'parameter) where - type ListAllocHint Type'anyPointer'parameter = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) -data instance C.Parsed Type'anyPointer'parameter - = Type'anyPointer'parameter' - {scopeId :: (RP.Parsed Std_.Word64) - ,parameterIndex :: (RP.Parsed Std_.Word16)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'anyPointer'parameter)) -deriving instance (Std_.Eq (C.Parsed Type'anyPointer'parameter)) -instance (C.Parse Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) where - parse raw_ = (Type'anyPointer'parameter' <$> (GH.parseField #scopeId raw_) - <*> (GH.parseField #parameterIndex raw_)) -instance (C.Marshal Type'anyPointer'parameter (C.Parsed Type'anyPointer'parameter)) where - marshalInto raw_ Type'anyPointer'parameter'{..} = (do - (GH.encodeField #scopeId scopeId raw_) - (GH.encodeField #parameterIndex parameterIndex raw_) - (Std_.pure ()) - ) -instance (GH.HasField "scopeId" GH.Slot Type'anyPointer'parameter Std_.Word64) where - fieldByLabel = (GH.dataField 0 2 64 0) -instance (GH.HasField "parameterIndex" GH.Slot Type'anyPointer'parameter Std_.Word16) where - fieldByLabel = (GH.dataField 16 1 16 0) -data Type'anyPointer'implicitMethodParameter -type instance (R.ReprFor Type'anyPointer'implicitMethodParameter) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Type'anyPointer'implicitMethodParameter) where - typeId = 13470206089842057844 -instance (C.TypedStruct Type'anyPointer'implicitMethodParameter) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Type'anyPointer'implicitMethodParameter) where - type AllocHint Type'anyPointer'implicitMethodParameter = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) -instance (C.AllocateList Type'anyPointer'implicitMethodParameter) where - type ListAllocHint Type'anyPointer'implicitMethodParameter = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) -data instance C.Parsed Type'anyPointer'implicitMethodParameter - = Type'anyPointer'implicitMethodParameter' - {parameterIndex :: (RP.Parsed Std_.Word16)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Type'anyPointer'implicitMethodParameter)) -deriving instance (Std_.Eq (C.Parsed Type'anyPointer'implicitMethodParameter)) -instance (C.Parse Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) where - parse raw_ = (Type'anyPointer'implicitMethodParameter' <$> (GH.parseField #parameterIndex raw_)) -instance (C.Marshal Type'anyPointer'implicitMethodParameter (C.Parsed Type'anyPointer'implicitMethodParameter)) where - marshalInto raw_ Type'anyPointer'implicitMethodParameter'{..} = (do - (GH.encodeField #parameterIndex parameterIndex raw_) - (Std_.pure ()) - ) -instance (GH.HasField "parameterIndex" GH.Slot Type'anyPointer'implicitMethodParameter Std_.Word16) where - fieldByLabel = (GH.dataField 16 1 16 0) -data Brand -type instance (R.ReprFor Brand) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Brand) where - typeId = 10391024731148337707 -instance (C.TypedStruct Brand) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Brand) where - type AllocHint Brand = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Brand (C.Parsed Brand)) -instance (C.AllocateList Brand) where - type ListAllocHint Brand = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Brand (C.Parsed Brand)) -data instance C.Parsed Brand - = Brand - {scopes :: (RP.Parsed (R.List Brand'Scope))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Brand)) -deriving instance (Std_.Eq (C.Parsed Brand)) -instance (C.Parse Brand (C.Parsed Brand)) where - parse raw_ = (Brand <$> (GH.parseField #scopes raw_)) -instance (C.Marshal Brand (C.Parsed Brand)) where - marshalInto raw_ Brand{..} = (do - (GH.encodeField #scopes scopes raw_) - (Std_.pure ()) - ) -instance (GH.HasField "scopes" GH.Slot Brand (R.List Brand'Scope)) where - fieldByLabel = (GH.ptrField 0) -data Brand'Scope -type instance (R.ReprFor Brand'Scope) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Brand'Scope) where - typeId = 12382423449155627977 -instance (C.TypedStruct Brand'Scope) where - numStructWords = 2 - numStructPtrs = 1 -instance (C.Allocate Brand'Scope) where - type AllocHint Brand'Scope = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Brand'Scope (C.Parsed Brand'Scope)) -instance (C.AllocateList Brand'Scope) where - type ListAllocHint Brand'Scope = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Brand'Scope (C.Parsed Brand'Scope)) -data instance C.Parsed Brand'Scope - = Brand'Scope - {scopeId :: (RP.Parsed Std_.Word64) - ,union' :: (C.Parsed (GH.Which Brand'Scope))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Brand'Scope)) -deriving instance (Std_.Eq (C.Parsed Brand'Scope)) -instance (C.Parse Brand'Scope (C.Parsed Brand'Scope)) where - parse raw_ = (Brand'Scope <$> (GH.parseField #scopeId raw_) - <*> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Brand'Scope (C.Parsed Brand'Scope)) where - marshalInto raw_ Brand'Scope{..} = (do - (GH.encodeField #scopeId scopeId raw_) - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Brand'Scope) where - unionField = (GH.dataField 0 1 16 0) - data RawWhich Brand'Scope mut_ - = RW_Brand'Scope'bind (R.Raw (R.List Brand'Binding) mut_) - | RW_Brand'Scope'inherit (R.Raw () mut_) - | RW_Brand'Scope'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Brand'Scope'bind <$> (GH.readVariant #bind struct_)) - 1 -> - (RW_Brand'Scope'inherit <$> (GH.readVariant #inherit struct_)) - _ -> - (Std_.pure (RW_Brand'Scope'unknown' tag_)) - data Which Brand'Scope -instance (GH.HasVariant "bind" GH.Slot Brand'Scope (R.List Brand'Binding)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 0) -instance (GH.HasVariant "inherit" GH.Slot Brand'Scope ()) where - variantByLabel = (GH.Variant GH.voidField 1) -data instance C.Parsed (GH.Which Brand'Scope) - = Brand'Scope'bind (RP.Parsed (R.List Brand'Binding)) - | Brand'Scope'inherit - | Brand'Scope'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Brand'Scope))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Brand'Scope))) -instance (C.Parse (GH.Which Brand'Scope) (C.Parsed (GH.Which Brand'Scope))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Brand'Scope'bind rawArg_) -> - (Brand'Scope'bind <$> (C.parse rawArg_)) - (RW_Brand'Scope'inherit _) -> - (Std_.pure Brand'Scope'inherit) - (RW_Brand'Scope'unknown' tag_) -> - (Std_.pure (Brand'Scope'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Brand'Scope) (C.Parsed (GH.Which Brand'Scope))) where - marshalInto raw_ parsed_ = case parsed_ of - (Brand'Scope'bind arg_) -> - (GH.encodeVariant #bind arg_ (GH.unionStruct raw_)) - (Brand'Scope'inherit) -> - (GH.encodeVariant #inherit () (GH.unionStruct raw_)) - (Brand'Scope'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -instance (GH.HasField "scopeId" GH.Slot Brand'Scope Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -data Brand'Binding -type instance (R.ReprFor Brand'Binding) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Brand'Binding) where - typeId = 14439610327179913212 -instance (C.TypedStruct Brand'Binding) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Brand'Binding) where - type AllocHint Brand'Binding = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Brand'Binding (C.Parsed Brand'Binding)) -instance (C.AllocateList Brand'Binding) where - type ListAllocHint Brand'Binding = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Brand'Binding (C.Parsed Brand'Binding)) -data instance C.Parsed Brand'Binding - = Brand'Binding - {union' :: (C.Parsed (GH.Which Brand'Binding))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Brand'Binding)) -deriving instance (Std_.Eq (C.Parsed Brand'Binding)) -instance (C.Parse Brand'Binding (C.Parsed Brand'Binding)) where - parse raw_ = (Brand'Binding <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Brand'Binding (C.Parsed Brand'Binding)) where - marshalInto raw_ Brand'Binding{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Brand'Binding) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Brand'Binding mut_ - = RW_Brand'Binding'unbound (R.Raw () mut_) - | RW_Brand'Binding'type_ (R.Raw Type mut_) - | RW_Brand'Binding'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Brand'Binding'unbound <$> (GH.readVariant #unbound struct_)) - 1 -> - (RW_Brand'Binding'type_ <$> (GH.readVariant #type_ struct_)) - _ -> - (Std_.pure (RW_Brand'Binding'unknown' tag_)) - data Which Brand'Binding -instance (GH.HasVariant "unbound" GH.Slot Brand'Binding ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "type_" GH.Slot Brand'Binding Type) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -data instance C.Parsed (GH.Which Brand'Binding) - = Brand'Binding'unbound - | Brand'Binding'type_ (RP.Parsed Type) - | Brand'Binding'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Brand'Binding))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Brand'Binding))) -instance (C.Parse (GH.Which Brand'Binding) (C.Parsed (GH.Which Brand'Binding))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Brand'Binding'unbound _) -> - (Std_.pure Brand'Binding'unbound) - (RW_Brand'Binding'type_ rawArg_) -> - (Brand'Binding'type_ <$> (C.parse rawArg_)) - (RW_Brand'Binding'unknown' tag_) -> - (Std_.pure (Brand'Binding'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Brand'Binding) (C.Parsed (GH.Which Brand'Binding))) where - marshalInto raw_ parsed_ = case parsed_ of - (Brand'Binding'unbound) -> - (GH.encodeVariant #unbound () (GH.unionStruct raw_)) - (Brand'Binding'type_ arg_) -> - (GH.encodeVariant #type_ arg_ (GH.unionStruct raw_)) - (Brand'Binding'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Value -type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Value) where - typeId = 14853958794117909659 -instance (C.TypedStruct Value) where - numStructWords = 2 - numStructPtrs = 1 -instance (C.Allocate Value) where - type AllocHint Value = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Value (C.Parsed Value)) -instance (C.AllocateList Value) where - type ListAllocHint Value = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Value (C.Parsed Value)) -data instance C.Parsed Value - = Value - {union' :: (C.Parsed (GH.Which Value))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Value)) -deriving instance (Std_.Eq (C.Parsed Value)) -instance (C.Parse Value (C.Parsed Value)) where - parse raw_ = (Value <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Value (C.Parsed Value)) where - marshalInto raw_ Value{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Value) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Value mut_ - = RW_Value'void (R.Raw () mut_) - | RW_Value'bool (R.Raw Std_.Bool mut_) - | RW_Value'int8 (R.Raw Std_.Int8 mut_) - | RW_Value'int16 (R.Raw Std_.Int16 mut_) - | RW_Value'int32 (R.Raw Std_.Int32 mut_) - | RW_Value'int64 (R.Raw Std_.Int64 mut_) - | RW_Value'uint8 (R.Raw Std_.Word8 mut_) - | RW_Value'uint16 (R.Raw Std_.Word16 mut_) - | RW_Value'uint32 (R.Raw Std_.Word32 mut_) - | RW_Value'uint64 (R.Raw Std_.Word64 mut_) - | RW_Value'float32 (R.Raw Std_.Float mut_) - | RW_Value'float64 (R.Raw Std_.Double mut_) - | RW_Value'text (R.Raw Basics.Text mut_) - | RW_Value'data_ (R.Raw Basics.Data mut_) - | RW_Value'list (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Value'enum (R.Raw Std_.Word16 mut_) - | RW_Value'struct (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Value'interface (R.Raw () mut_) - | RW_Value'anyPointer (R.Raw (Std_.Maybe Basics.AnyPointer) mut_) - | RW_Value'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Value'void <$> (GH.readVariant #void struct_)) - 1 -> - (RW_Value'bool <$> (GH.readVariant #bool struct_)) - 2 -> - (RW_Value'int8 <$> (GH.readVariant #int8 struct_)) - 3 -> - (RW_Value'int16 <$> (GH.readVariant #int16 struct_)) - 4 -> - (RW_Value'int32 <$> (GH.readVariant #int32 struct_)) - 5 -> - (RW_Value'int64 <$> (GH.readVariant #int64 struct_)) - 6 -> - (RW_Value'uint8 <$> (GH.readVariant #uint8 struct_)) - 7 -> - (RW_Value'uint16 <$> (GH.readVariant #uint16 struct_)) - 8 -> - (RW_Value'uint32 <$> (GH.readVariant #uint32 struct_)) - 9 -> - (RW_Value'uint64 <$> (GH.readVariant #uint64 struct_)) - 10 -> - (RW_Value'float32 <$> (GH.readVariant #float32 struct_)) - 11 -> - (RW_Value'float64 <$> (GH.readVariant #float64 struct_)) - 12 -> - (RW_Value'text <$> (GH.readVariant #text struct_)) - 13 -> - (RW_Value'data_ <$> (GH.readVariant #data_ struct_)) - 14 -> - (RW_Value'list <$> (GH.readVariant #list struct_)) - 15 -> - (RW_Value'enum <$> (GH.readVariant #enum struct_)) - 16 -> - (RW_Value'struct <$> (GH.readVariant #struct struct_)) - 17 -> - (RW_Value'interface <$> (GH.readVariant #interface struct_)) - 18 -> - (RW_Value'anyPointer <$> (GH.readVariant #anyPointer struct_)) - _ -> - (Std_.pure (RW_Value'unknown' tag_)) - data Which Value -instance (GH.HasVariant "void" GH.Slot Value ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "bool" GH.Slot Value Std_.Bool) where - variantByLabel = (GH.Variant (GH.dataField 16 0 1 0) 1) -instance (GH.HasVariant "int8" GH.Slot Value Std_.Int8) where - variantByLabel = (GH.Variant (GH.dataField 16 0 8 0) 2) -instance (GH.HasVariant "int16" GH.Slot Value Std_.Int16) where - variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 3) -instance (GH.HasVariant "int32" GH.Slot Value Std_.Int32) where - variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 4) -instance (GH.HasVariant "int64" GH.Slot Value Std_.Int64) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 5) -instance (GH.HasVariant "uint8" GH.Slot Value Std_.Word8) where - variantByLabel = (GH.Variant (GH.dataField 16 0 8 0) 6) -instance (GH.HasVariant "uint16" GH.Slot Value Std_.Word16) where - variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 7) -instance (GH.HasVariant "uint32" GH.Slot Value Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 8) -instance (GH.HasVariant "uint64" GH.Slot Value Std_.Word64) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 9) -instance (GH.HasVariant "float32" GH.Slot Value Std_.Float) where - variantByLabel = (GH.Variant (GH.dataField 32 0 32 0) 10) -instance (GH.HasVariant "float64" GH.Slot Value Std_.Double) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 11) -instance (GH.HasVariant "text" GH.Slot Value Basics.Text) where - variantByLabel = (GH.Variant (GH.ptrField 0) 12) -instance (GH.HasVariant "data_" GH.Slot Value Basics.Data) where - variantByLabel = (GH.Variant (GH.ptrField 0) 13) -instance (GH.HasVariant "list" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 14) -instance (GH.HasVariant "enum" GH.Slot Value Std_.Word16) where - variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 15) -instance (GH.HasVariant "struct" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 16) -instance (GH.HasVariant "interface" GH.Slot Value ()) where - variantByLabel = (GH.Variant GH.voidField 17) -instance (GH.HasVariant "anyPointer" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 18) -data instance C.Parsed (GH.Which Value) - = Value'void - | Value'bool (RP.Parsed Std_.Bool) - | Value'int8 (RP.Parsed Std_.Int8) - | Value'int16 (RP.Parsed Std_.Int16) - | Value'int32 (RP.Parsed Std_.Int32) - | Value'int64 (RP.Parsed Std_.Int64) - | Value'uint8 (RP.Parsed Std_.Word8) - | Value'uint16 (RP.Parsed Std_.Word16) - | Value'uint32 (RP.Parsed Std_.Word32) - | Value'uint64 (RP.Parsed Std_.Word64) - | Value'float32 (RP.Parsed Std_.Float) - | Value'float64 (RP.Parsed Std_.Double) - | Value'text (RP.Parsed Basics.Text) - | Value'data_ (RP.Parsed Basics.Data) - | Value'list (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Value'enum (RP.Parsed Std_.Word16) - | Value'struct (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Value'interface - | Value'anyPointer (RP.Parsed (Std_.Maybe Basics.AnyPointer)) - | Value'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Value))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Value))) -instance (C.Parse (GH.Which Value) (C.Parsed (GH.Which Value))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Value'void _) -> - (Std_.pure Value'void) - (RW_Value'bool rawArg_) -> - (Value'bool <$> (C.parse rawArg_)) - (RW_Value'int8 rawArg_) -> - (Value'int8 <$> (C.parse rawArg_)) - (RW_Value'int16 rawArg_) -> - (Value'int16 <$> (C.parse rawArg_)) - (RW_Value'int32 rawArg_) -> - (Value'int32 <$> (C.parse rawArg_)) - (RW_Value'int64 rawArg_) -> - (Value'int64 <$> (C.parse rawArg_)) - (RW_Value'uint8 rawArg_) -> - (Value'uint8 <$> (C.parse rawArg_)) - (RW_Value'uint16 rawArg_) -> - (Value'uint16 <$> (C.parse rawArg_)) - (RW_Value'uint32 rawArg_) -> - (Value'uint32 <$> (C.parse rawArg_)) - (RW_Value'uint64 rawArg_) -> - (Value'uint64 <$> (C.parse rawArg_)) - (RW_Value'float32 rawArg_) -> - (Value'float32 <$> (C.parse rawArg_)) - (RW_Value'float64 rawArg_) -> - (Value'float64 <$> (C.parse rawArg_)) - (RW_Value'text rawArg_) -> - (Value'text <$> (C.parse rawArg_)) - (RW_Value'data_ rawArg_) -> - (Value'data_ <$> (C.parse rawArg_)) - (RW_Value'list rawArg_) -> - (Value'list <$> (C.parse rawArg_)) - (RW_Value'enum rawArg_) -> - (Value'enum <$> (C.parse rawArg_)) - (RW_Value'struct rawArg_) -> - (Value'struct <$> (C.parse rawArg_)) - (RW_Value'interface _) -> - (Std_.pure Value'interface) - (RW_Value'anyPointer rawArg_) -> - (Value'anyPointer <$> (C.parse rawArg_)) - (RW_Value'unknown' tag_) -> - (Std_.pure (Value'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Value) (C.Parsed (GH.Which Value))) where - marshalInto raw_ parsed_ = case parsed_ of - (Value'void) -> - (GH.encodeVariant #void () (GH.unionStruct raw_)) - (Value'bool arg_) -> - (GH.encodeVariant #bool arg_ (GH.unionStruct raw_)) - (Value'int8 arg_) -> - (GH.encodeVariant #int8 arg_ (GH.unionStruct raw_)) - (Value'int16 arg_) -> - (GH.encodeVariant #int16 arg_ (GH.unionStruct raw_)) - (Value'int32 arg_) -> - (GH.encodeVariant #int32 arg_ (GH.unionStruct raw_)) - (Value'int64 arg_) -> - (GH.encodeVariant #int64 arg_ (GH.unionStruct raw_)) - (Value'uint8 arg_) -> - (GH.encodeVariant #uint8 arg_ (GH.unionStruct raw_)) - (Value'uint16 arg_) -> - (GH.encodeVariant #uint16 arg_ (GH.unionStruct raw_)) - (Value'uint32 arg_) -> - (GH.encodeVariant #uint32 arg_ (GH.unionStruct raw_)) - (Value'uint64 arg_) -> - (GH.encodeVariant #uint64 arg_ (GH.unionStruct raw_)) - (Value'float32 arg_) -> - (GH.encodeVariant #float32 arg_ (GH.unionStruct raw_)) - (Value'float64 arg_) -> - (GH.encodeVariant #float64 arg_ (GH.unionStruct raw_)) - (Value'text arg_) -> - (GH.encodeVariant #text arg_ (GH.unionStruct raw_)) - (Value'data_ arg_) -> - (GH.encodeVariant #data_ arg_ (GH.unionStruct raw_)) - (Value'list arg_) -> - (GH.encodeVariant #list arg_ (GH.unionStruct raw_)) - (Value'enum arg_) -> - (GH.encodeVariant #enum arg_ (GH.unionStruct raw_)) - (Value'struct arg_) -> - (GH.encodeVariant #struct arg_ (GH.unionStruct raw_)) - (Value'interface) -> - (GH.encodeVariant #interface () (GH.unionStruct raw_)) - (Value'anyPointer arg_) -> - (GH.encodeVariant #anyPointer arg_ (GH.unionStruct raw_)) - (Value'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Annotation -type instance (R.ReprFor Annotation) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Annotation) where - typeId = 17422339044421236034 -instance (C.TypedStruct Annotation) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate Annotation) where - type AllocHint Annotation = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Annotation (C.Parsed Annotation)) -instance (C.AllocateList Annotation) where - type ListAllocHint Annotation = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Annotation (C.Parsed Annotation)) -data instance C.Parsed Annotation - = Annotation - {id :: (RP.Parsed Std_.Word64) - ,value :: (RP.Parsed Value) - ,brand :: (RP.Parsed Brand)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Annotation)) -deriving instance (Std_.Eq (C.Parsed Annotation)) -instance (C.Parse Annotation (C.Parsed Annotation)) where - parse raw_ = (Annotation <$> (GH.parseField #id raw_) - <*> (GH.parseField #value raw_) - <*> (GH.parseField #brand raw_)) -instance (C.Marshal Annotation (C.Parsed Annotation)) where - marshalInto raw_ Annotation{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #value value raw_) - (GH.encodeField #brand brand raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot Annotation Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "value" GH.Slot Annotation Value) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "brand" GH.Slot Annotation Brand) where - fieldByLabel = (GH.ptrField 1) -data ElementSize - = ElementSize'empty - | ElementSize'bit - | ElementSize'byte - | ElementSize'twoBytes - | ElementSize'fourBytes - | ElementSize'eightBytes - | ElementSize'pointer - | ElementSize'inlineComposite - | ElementSize'unknown' Std_.Word16 - deriving(Std_.Eq - ,Std_.Show - ,Generics.Generic) -type instance (R.ReprFor ElementSize) = (R.Data R.Sz16) -instance (C.HasTypeId ElementSize) where - typeId = 15102134695616452902 -instance (Std_.Enum ElementSize) where - toEnum n_ = case n_ of - 0 -> - ElementSize'empty - 1 -> - ElementSize'bit - 2 -> - ElementSize'byte - 3 -> - ElementSize'twoBytes - 4 -> - ElementSize'fourBytes - 5 -> - ElementSize'eightBytes - 6 -> - ElementSize'pointer - 7 -> - ElementSize'inlineComposite - tag_ -> - (ElementSize'unknown' (Std_.fromIntegral tag_)) - fromEnum value_ = case value_ of - (ElementSize'empty) -> - 0 - (ElementSize'bit) -> - 1 - (ElementSize'byte) -> - 2 - (ElementSize'twoBytes) -> - 3 - (ElementSize'fourBytes) -> - 4 - (ElementSize'eightBytes) -> - 5 - (ElementSize'pointer) -> - 6 - (ElementSize'inlineComposite) -> - 7 - (ElementSize'unknown' tag_) -> - (Std_.fromIntegral tag_) -instance (C.IsWord ElementSize) where - fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) - toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) -instance (C.Parse ElementSize ElementSize) where - parse = GH.parseEnum - encode = GH.encodeEnum -instance (C.AllocateList ElementSize) where - type ListAllocHint ElementSize = Std_.Int -instance (C.EstimateListAlloc ElementSize ElementSize) -data CapnpVersion -type instance (R.ReprFor CapnpVersion) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CapnpVersion) where - typeId = 15590670654532458851 -instance (C.TypedStruct CapnpVersion) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate CapnpVersion) where - type AllocHint CapnpVersion = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CapnpVersion (C.Parsed CapnpVersion)) -instance (C.AllocateList CapnpVersion) where - type ListAllocHint CapnpVersion = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CapnpVersion (C.Parsed CapnpVersion)) -data instance C.Parsed CapnpVersion - = CapnpVersion - {major :: (RP.Parsed Std_.Word16) - ,minor :: (RP.Parsed Std_.Word8) - ,micro :: (RP.Parsed Std_.Word8)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CapnpVersion)) -deriving instance (Std_.Eq (C.Parsed CapnpVersion)) -instance (C.Parse CapnpVersion (C.Parsed CapnpVersion)) where - parse raw_ = (CapnpVersion <$> (GH.parseField #major raw_) - <*> (GH.parseField #minor raw_) - <*> (GH.parseField #micro raw_)) -instance (C.Marshal CapnpVersion (C.Parsed CapnpVersion)) where - marshalInto raw_ CapnpVersion{..} = (do - (GH.encodeField #major major raw_) - (GH.encodeField #minor minor raw_) - (GH.encodeField #micro micro raw_) - (Std_.pure ()) - ) -instance (GH.HasField "major" GH.Slot CapnpVersion Std_.Word16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "minor" GH.Slot CapnpVersion Std_.Word8) where - fieldByLabel = (GH.dataField 16 0 8 0) -instance (GH.HasField "micro" GH.Slot CapnpVersion Std_.Word8) where - fieldByLabel = (GH.dataField 24 0 8 0) -data CodeGeneratorRequest -type instance (R.ReprFor CodeGeneratorRequest) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CodeGeneratorRequest) where - typeId = 13818529054586492878 -instance (C.TypedStruct CodeGeneratorRequest) where - numStructWords = 0 - numStructPtrs = 4 -instance (C.Allocate CodeGeneratorRequest) where - type AllocHint CodeGeneratorRequest = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) -instance (C.AllocateList CodeGeneratorRequest) where - type ListAllocHint CodeGeneratorRequest = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) -data instance C.Parsed CodeGeneratorRequest - = CodeGeneratorRequest - {nodes :: (RP.Parsed (R.List Node)) - ,requestedFiles :: (RP.Parsed (R.List CodeGeneratorRequest'RequestedFile)) - ,capnpVersion :: (RP.Parsed CapnpVersion) - ,sourceInfo :: (RP.Parsed (R.List Node'SourceInfo))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CodeGeneratorRequest)) -deriving instance (Std_.Eq (C.Parsed CodeGeneratorRequest)) -instance (C.Parse CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) where - parse raw_ = (CodeGeneratorRequest <$> (GH.parseField #nodes raw_) - <*> (GH.parseField #requestedFiles raw_) - <*> (GH.parseField #capnpVersion raw_) - <*> (GH.parseField #sourceInfo raw_)) -instance (C.Marshal CodeGeneratorRequest (C.Parsed CodeGeneratorRequest)) where - marshalInto raw_ CodeGeneratorRequest{..} = (do - (GH.encodeField #nodes nodes raw_) - (GH.encodeField #requestedFiles requestedFiles raw_) - (GH.encodeField #capnpVersion capnpVersion raw_) - (GH.encodeField #sourceInfo sourceInfo raw_) - (Std_.pure ()) - ) -instance (GH.HasField "nodes" GH.Slot CodeGeneratorRequest (R.List Node)) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "requestedFiles" GH.Slot CodeGeneratorRequest (R.List CodeGeneratorRequest'RequestedFile)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "capnpVersion" GH.Slot CodeGeneratorRequest CapnpVersion) where - fieldByLabel = (GH.ptrField 2) -instance (GH.HasField "sourceInfo" GH.Slot CodeGeneratorRequest (R.List Node'SourceInfo)) where - fieldByLabel = (GH.ptrField 3) -data CodeGeneratorRequest'RequestedFile -type instance (R.ReprFor CodeGeneratorRequest'RequestedFile) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CodeGeneratorRequest'RequestedFile) where - typeId = 14981803260258615394 -instance (C.TypedStruct CodeGeneratorRequest'RequestedFile) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate CodeGeneratorRequest'RequestedFile) where - type AllocHint CodeGeneratorRequest'RequestedFile = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) -instance (C.AllocateList CodeGeneratorRequest'RequestedFile) where - type ListAllocHint CodeGeneratorRequest'RequestedFile = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) -data instance C.Parsed CodeGeneratorRequest'RequestedFile - = CodeGeneratorRequest'RequestedFile - {id :: (RP.Parsed Std_.Word64) - ,filename :: (RP.Parsed Basics.Text) - ,imports :: (RP.Parsed (R.List CodeGeneratorRequest'RequestedFile'Import))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CodeGeneratorRequest'RequestedFile)) -deriving instance (Std_.Eq (C.Parsed CodeGeneratorRequest'RequestedFile)) -instance (C.Parse CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) where - parse raw_ = (CodeGeneratorRequest'RequestedFile <$> (GH.parseField #id raw_) - <*> (GH.parseField #filename raw_) - <*> (GH.parseField #imports raw_)) -instance (C.Marshal CodeGeneratorRequest'RequestedFile (C.Parsed CodeGeneratorRequest'RequestedFile)) where - marshalInto raw_ CodeGeneratorRequest'RequestedFile{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #filename filename raw_) - (GH.encodeField #imports imports raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot CodeGeneratorRequest'RequestedFile Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "filename" GH.Slot CodeGeneratorRequest'RequestedFile Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "imports" GH.Slot CodeGeneratorRequest'RequestedFile (R.List CodeGeneratorRequest'RequestedFile'Import)) where - fieldByLabel = (GH.ptrField 1) -data CodeGeneratorRequest'RequestedFile'Import -type instance (R.ReprFor CodeGeneratorRequest'RequestedFile'Import) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CodeGeneratorRequest'RequestedFile'Import) where - typeId = 12560611460656617445 -instance (C.TypedStruct CodeGeneratorRequest'RequestedFile'Import) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate CodeGeneratorRequest'RequestedFile'Import) where - type AllocHint CodeGeneratorRequest'RequestedFile'Import = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) -instance (C.AllocateList CodeGeneratorRequest'RequestedFile'Import) where - type ListAllocHint CodeGeneratorRequest'RequestedFile'Import = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) -data instance C.Parsed CodeGeneratorRequest'RequestedFile'Import - = CodeGeneratorRequest'RequestedFile'Import - {id :: (RP.Parsed Std_.Word64) - ,name :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) -deriving instance (Std_.Eq (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) -instance (C.Parse CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) where - parse raw_ = (CodeGeneratorRequest'RequestedFile'Import <$> (GH.parseField #id raw_) - <*> (GH.parseField #name raw_)) -instance (C.Marshal CodeGeneratorRequest'RequestedFile'Import (C.Parsed CodeGeneratorRequest'RequestedFile'Import)) where - marshalInto raw_ CodeGeneratorRequest'RequestedFile'Import{..} = (do - (GH.encodeField #id id raw_) - (GH.encodeField #name name raw_) - (Std_.pure ()) - ) -instance (GH.HasField "id" GH.Slot CodeGeneratorRequest'RequestedFile'Import Std_.Word64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "name" GH.Slot CodeGeneratorRequest'RequestedFile'Import Basics.Text) where - fieldByLabel = (GH.ptrField 0) diff --git a/gen/lib/Capnp/Gen/Capnp/Stream.hs b/gen/lib/Capnp/Gen/Capnp/Stream.hs new file mode 100644 --- /dev/null +++ b/gen/lib/Capnp/Gen/Capnp/Stream.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Capnp.Stream where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data StreamResult +type instance (R.ReprFor StreamResult) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StreamResult) where + typeId = 11051721556433613166 +instance (C.TypedStruct StreamResult) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate StreamResult) where + type AllocHint StreamResult = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc StreamResult (C.Parsed StreamResult)) +instance (C.AllocateList StreamResult) where + type ListAllocHint StreamResult = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc StreamResult (C.Parsed StreamResult)) +data instance C.Parsed StreamResult + = StreamResult + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed StreamResult)) +deriving instance (Std_.Eq (C.Parsed StreamResult)) +instance (C.Parse StreamResult (C.Parsed StreamResult)) where + parse raw_ = (Std_.pure StreamResult) +instance (C.Marshal StreamResult (C.Parsed StreamResult)) where + marshalInto _raw (StreamResult) = (Std_.pure ()) diff --git a/gen/lib/Capnp/Gen/Capnp/Stream/New.hs b/gen/lib/Capnp/Gen/Capnp/Stream/New.hs deleted file mode 100644 --- a/gen/lib/Capnp/Gen/Capnp/Stream/New.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Capnp.Stream.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data StreamResult -type instance (R.ReprFor StreamResult) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId StreamResult) where - typeId = 11051721556433613166 -instance (C.TypedStruct StreamResult) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate StreamResult) where - type AllocHint StreamResult = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc StreamResult (C.Parsed StreamResult)) -instance (C.AllocateList StreamResult) where - type ListAllocHint StreamResult = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc StreamResult (C.Parsed StreamResult)) -data instance C.Parsed StreamResult - = StreamResult - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed StreamResult)) -deriving instance (Std_.Eq (C.Parsed StreamResult)) -instance (C.Parse StreamResult (C.Parsed StreamResult)) where - parse raw_ = (Std_.pure StreamResult) -instance (C.Marshal StreamResult (C.Parsed StreamResult)) where - marshalInto _raw (StreamResult) = (Std_.pure ()) diff --git a/gen/tests/Capnp/Gen/Aircraft.hs b/gen/tests/Capnp/Gen/Aircraft.hs new file mode 100644 --- /dev/null +++ b/gen/tests/Capnp/Gen/Aircraft.hs @@ -0,0 +1,2750 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Aircraft where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Capnp.GenHelpers.Rpc as GH +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +constDate :: (R.Raw Zdate GH.Const) +constDate = (GH.getPtrConst ("\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\223\a\b\ESC\NUL\NUL\NUL\NUL" :: GH.ByteString)) +constList :: (R.Raw (R.List Zdate) GH.Const) +constList = (GH.getPtrConst ("\NUL\NUL\NUL\NUL\ENQ\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL\SOH\NUL\NUL\NUL\ETB\NUL\NUL\NUL\b\NUL\NUL\NUL\SOH\NUL\NUL\NUL\223\a\b\ESC\NUL\NUL\NUL\NUL\223\a\b\FS\NUL\NUL\NUL\NUL" :: GH.ByteString)) +constEnum :: Airport +constEnum = (C.fromWord 1) +data Zdate +type instance (R.ReprFor Zdate) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zdate) where + typeId = 16019495995647153309 +instance (C.TypedStruct Zdate) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate Zdate) where + type AllocHint Zdate = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Zdate (C.Parsed Zdate)) +instance (C.AllocateList Zdate) where + type ListAllocHint Zdate = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Zdate (C.Parsed Zdate)) +data instance C.Parsed Zdate + = Zdate + {year :: (RP.Parsed Std_.Int16) + ,month :: (RP.Parsed Std_.Word8) + ,day :: (RP.Parsed Std_.Word8)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Zdate)) +deriving instance (Std_.Eq (C.Parsed Zdate)) +instance (C.Parse Zdate (C.Parsed Zdate)) where + parse raw_ = (Zdate <$> (GH.parseField #year raw_) + <*> (GH.parseField #month raw_) + <*> (GH.parseField #day raw_)) +instance (C.Marshal Zdate (C.Parsed Zdate)) where + marshalInto raw_ Zdate{..} = (do + (GH.encodeField #year year raw_) + (GH.encodeField #month month raw_) + (GH.encodeField #day day raw_) + (Std_.pure ()) + ) +instance (GH.HasField "year" GH.Slot Zdate Std_.Int16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "month" GH.Slot Zdate Std_.Word8) where + fieldByLabel = (GH.dataField 16 0 8 0) +instance (GH.HasField "day" GH.Slot Zdate Std_.Word8) where + fieldByLabel = (GH.dataField 24 0 8 0) +data Zdata +type instance (R.ReprFor Zdata) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zdata) where + typeId = 14400934881325616034 +instance (C.TypedStruct Zdata) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Zdata) where + type AllocHint Zdata = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Zdata (C.Parsed Zdata)) +instance (C.AllocateList Zdata) where + type ListAllocHint Zdata = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Zdata (C.Parsed Zdata)) +data instance C.Parsed Zdata + = Zdata + {data_ :: (RP.Parsed Basics.Data)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Zdata)) +deriving instance (Std_.Eq (C.Parsed Zdata)) +instance (C.Parse Zdata (C.Parsed Zdata)) where + parse raw_ = (Zdata <$> (GH.parseField #data_ raw_)) +instance (C.Marshal Zdata (C.Parsed Zdata)) where + marshalInto raw_ Zdata{..} = (do + (GH.encodeField #data_ data_ raw_) + (Std_.pure ()) + ) +instance (GH.HasField "data_" GH.Slot Zdata Basics.Data) where + fieldByLabel = (GH.ptrField 0) +data Airport + = Airport'none + | Airport'jfk + | Airport'lax + | Airport'sfo + | Airport'luv + | Airport'dfw + | Airport'test + | Airport'unknown' Std_.Word16 + deriving(Std_.Eq + ,Std_.Show + ,Generics.Generic) +type instance (R.ReprFor Airport) = (R.Data R.Sz16) +instance (C.HasTypeId Airport) where + typeId = 16527513525367090977 +instance (Std_.Enum Airport) where + toEnum n_ = case n_ of + 0 -> + Airport'none + 1 -> + Airport'jfk + 2 -> + Airport'lax + 3 -> + Airport'sfo + 4 -> + Airport'luv + 5 -> + Airport'dfw + 6 -> + Airport'test + tag_ -> + (Airport'unknown' (Std_.fromIntegral tag_)) + fromEnum value_ = case value_ of + (Airport'none) -> + 0 + (Airport'jfk) -> + 1 + (Airport'lax) -> + 2 + (Airport'sfo) -> + 3 + (Airport'luv) -> + 4 + (Airport'dfw) -> + 5 + (Airport'test) -> + 6 + (Airport'unknown' tag_) -> + (Std_.fromIntegral tag_) +instance (C.IsWord Airport) where + fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) + toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) +instance (C.Parse Airport Airport) where + parse = GH.parseEnum + encode = GH.encodeEnum +instance (C.AllocateList Airport) where + type ListAllocHint Airport = Std_.Int +instance (C.EstimateListAlloc Airport Airport) +data PlaneBase +type instance (R.ReprFor PlaneBase) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId PlaneBase) where + typeId = 15617585680788961169 +instance (C.TypedStruct PlaneBase) where + numStructWords = 4 + numStructPtrs = 2 +instance (C.Allocate PlaneBase) where + type AllocHint PlaneBase = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc PlaneBase (C.Parsed PlaneBase)) +instance (C.AllocateList PlaneBase) where + type ListAllocHint PlaneBase = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc PlaneBase (C.Parsed PlaneBase)) +data instance C.Parsed PlaneBase + = PlaneBase + {name :: (RP.Parsed Basics.Text) + ,homes :: (RP.Parsed (R.List Airport)) + ,rating :: (RP.Parsed Std_.Int64) + ,canFly :: (RP.Parsed Std_.Bool) + ,capacity :: (RP.Parsed Std_.Int64) + ,maxSpeed :: (RP.Parsed Std_.Double)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed PlaneBase)) +deriving instance (Std_.Eq (C.Parsed PlaneBase)) +instance (C.Parse PlaneBase (C.Parsed PlaneBase)) where + parse raw_ = (PlaneBase <$> (GH.parseField #name raw_) + <*> (GH.parseField #homes raw_) + <*> (GH.parseField #rating raw_) + <*> (GH.parseField #canFly raw_) + <*> (GH.parseField #capacity raw_) + <*> (GH.parseField #maxSpeed raw_)) +instance (C.Marshal PlaneBase (C.Parsed PlaneBase)) where + marshalInto raw_ PlaneBase{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #homes homes raw_) + (GH.encodeField #rating rating raw_) + (GH.encodeField #canFly canFly raw_) + (GH.encodeField #capacity capacity raw_) + (GH.encodeField #maxSpeed maxSpeed raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot PlaneBase Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "homes" GH.Slot PlaneBase (R.List Airport)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "rating" GH.Slot PlaneBase Std_.Int64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "canFly" GH.Slot PlaneBase Std_.Bool) where + fieldByLabel = (GH.dataField 0 1 1 0) +instance (GH.HasField "capacity" GH.Slot PlaneBase Std_.Int64) where + fieldByLabel = (GH.dataField 0 2 64 0) +instance (GH.HasField "maxSpeed" GH.Slot PlaneBase Std_.Double) where + fieldByLabel = (GH.dataField 0 3 64 0) +data B737 +type instance (R.ReprFor B737) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId B737) where + typeId = 14750329894210119392 +instance (C.TypedStruct B737) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate B737) where + type AllocHint B737 = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc B737 (C.Parsed B737)) +instance (C.AllocateList B737) where + type ListAllocHint B737 = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc B737 (C.Parsed B737)) +data instance C.Parsed B737 + = B737 + {base :: (RP.Parsed PlaneBase)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed B737)) +deriving instance (Std_.Eq (C.Parsed B737)) +instance (C.Parse B737 (C.Parsed B737)) where + parse raw_ = (B737 <$> (GH.parseField #base raw_)) +instance (C.Marshal B737 (C.Parsed B737)) where + marshalInto raw_ B737{..} = (do + (GH.encodeField #base base raw_) + (Std_.pure ()) + ) +instance (GH.HasField "base" GH.Slot B737 PlaneBase) where + fieldByLabel = (GH.ptrField 0) +data A320 +type instance (R.ReprFor A320) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId A320) where + typeId = 15676010542212434829 +instance (C.TypedStruct A320) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate A320) where + type AllocHint A320 = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc A320 (C.Parsed A320)) +instance (C.AllocateList A320) where + type ListAllocHint A320 = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc A320 (C.Parsed A320)) +data instance C.Parsed A320 + = A320 + {base :: (RP.Parsed PlaneBase)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed A320)) +deriving instance (Std_.Eq (C.Parsed A320)) +instance (C.Parse A320 (C.Parsed A320)) where + parse raw_ = (A320 <$> (GH.parseField #base raw_)) +instance (C.Marshal A320 (C.Parsed A320)) where + marshalInto raw_ A320{..} = (do + (GH.encodeField #base base raw_) + (Std_.pure ()) + ) +instance (GH.HasField "base" GH.Slot A320 PlaneBase) where + fieldByLabel = (GH.ptrField 0) +data F16 +type instance (R.ReprFor F16) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId F16) where + typeId = 16269793260987437921 +instance (C.TypedStruct F16) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate F16) where + type AllocHint F16 = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc F16 (C.Parsed F16)) +instance (C.AllocateList F16) where + type ListAllocHint F16 = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc F16 (C.Parsed F16)) +data instance C.Parsed F16 + = F16 + {base :: (RP.Parsed PlaneBase)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed F16)) +deriving instance (Std_.Eq (C.Parsed F16)) +instance (C.Parse F16 (C.Parsed F16)) where + parse raw_ = (F16 <$> (GH.parseField #base raw_)) +instance (C.Marshal F16 (C.Parsed F16)) where + marshalInto raw_ F16{..} = (do + (GH.encodeField #base base raw_) + (Std_.pure ()) + ) +instance (GH.HasField "base" GH.Slot F16 PlaneBase) where + fieldByLabel = (GH.ptrField 0) +data Regression +type instance (R.ReprFor Regression) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Regression) where + typeId = 12821810113427682943 +instance (C.TypedStruct Regression) where + numStructWords = 3 + numStructPtrs = 3 +instance (C.Allocate Regression) where + type AllocHint Regression = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Regression (C.Parsed Regression)) +instance (C.AllocateList Regression) where + type ListAllocHint Regression = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Regression (C.Parsed Regression)) +data instance C.Parsed Regression + = Regression + {base :: (RP.Parsed PlaneBase) + ,b0 :: (RP.Parsed Std_.Double) + ,beta :: (RP.Parsed (R.List Std_.Double)) + ,planes :: (RP.Parsed (R.List Aircraft)) + ,ymu :: (RP.Parsed Std_.Double) + ,ysd :: (RP.Parsed Std_.Double)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Regression)) +deriving instance (Std_.Eq (C.Parsed Regression)) +instance (C.Parse Regression (C.Parsed Regression)) where + parse raw_ = (Regression <$> (GH.parseField #base raw_) + <*> (GH.parseField #b0 raw_) + <*> (GH.parseField #beta raw_) + <*> (GH.parseField #planes raw_) + <*> (GH.parseField #ymu raw_) + <*> (GH.parseField #ysd raw_)) +instance (C.Marshal Regression (C.Parsed Regression)) where + marshalInto raw_ Regression{..} = (do + (GH.encodeField #base base raw_) + (GH.encodeField #b0 b0 raw_) + (GH.encodeField #beta beta raw_) + (GH.encodeField #planes planes raw_) + (GH.encodeField #ymu ymu raw_) + (GH.encodeField #ysd ysd raw_) + (Std_.pure ()) + ) +instance (GH.HasField "base" GH.Slot Regression PlaneBase) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "b0" GH.Slot Regression Std_.Double) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "beta" GH.Slot Regression (R.List Std_.Double)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "planes" GH.Slot Regression (R.List Aircraft)) where + fieldByLabel = (GH.ptrField 2) +instance (GH.HasField "ymu" GH.Slot Regression Std_.Double) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "ysd" GH.Slot Regression Std_.Double) where + fieldByLabel = (GH.dataField 0 2 64 0) +data Aircraft +type instance (R.ReprFor Aircraft) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Aircraft) where + typeId = 16523162426109446065 +instance (C.TypedStruct Aircraft) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate Aircraft) where + type AllocHint Aircraft = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Aircraft (C.Parsed Aircraft)) +instance (C.AllocateList Aircraft) where + type ListAllocHint Aircraft = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Aircraft (C.Parsed Aircraft)) +data instance C.Parsed Aircraft + = Aircraft + {union' :: (C.Parsed (GH.Which Aircraft))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Aircraft)) +deriving instance (Std_.Eq (C.Parsed Aircraft)) +instance (C.Parse Aircraft (C.Parsed Aircraft)) where + parse raw_ = (Aircraft <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Aircraft (C.Parsed Aircraft)) where + marshalInto raw_ Aircraft{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Aircraft) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Aircraft mut_ + = RW_Aircraft'void (R.Raw () mut_) + | RW_Aircraft'b737 (R.Raw B737 mut_) + | RW_Aircraft'a320 (R.Raw A320 mut_) + | RW_Aircraft'f16 (R.Raw F16 mut_) + | RW_Aircraft'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Aircraft'void <$> (GH.readVariant #void struct_)) + 1 -> + (RW_Aircraft'b737 <$> (GH.readVariant #b737 struct_)) + 2 -> + (RW_Aircraft'a320 <$> (GH.readVariant #a320 struct_)) + 3 -> + (RW_Aircraft'f16 <$> (GH.readVariant #f16 struct_)) + _ -> + (Std_.pure (RW_Aircraft'unknown' tag_)) + data Which Aircraft +instance (GH.HasVariant "void" GH.Slot Aircraft ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "b737" GH.Slot Aircraft B737) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +instance (GH.HasVariant "a320" GH.Slot Aircraft A320) where + variantByLabel = (GH.Variant (GH.ptrField 0) 2) +instance (GH.HasVariant "f16" GH.Slot Aircraft F16) where + variantByLabel = (GH.Variant (GH.ptrField 0) 3) +data instance C.Parsed (GH.Which Aircraft) + = Aircraft'void + | Aircraft'b737 (RP.Parsed B737) + | Aircraft'a320 (RP.Parsed A320) + | Aircraft'f16 (RP.Parsed F16) + | Aircraft'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Aircraft))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Aircraft))) +instance (C.Parse (GH.Which Aircraft) (C.Parsed (GH.Which Aircraft))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Aircraft'void _) -> + (Std_.pure Aircraft'void) + (RW_Aircraft'b737 rawArg_) -> + (Aircraft'b737 <$> (C.parse rawArg_)) + (RW_Aircraft'a320 rawArg_) -> + (Aircraft'a320 <$> (C.parse rawArg_)) + (RW_Aircraft'f16 rawArg_) -> + (Aircraft'f16 <$> (C.parse rawArg_)) + (RW_Aircraft'unknown' tag_) -> + (Std_.pure (Aircraft'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Aircraft) (C.Parsed (GH.Which Aircraft))) where + marshalInto raw_ parsed_ = case parsed_ of + (Aircraft'void) -> + (GH.encodeVariant #void () (GH.unionStruct raw_)) + (Aircraft'b737 arg_) -> + (GH.encodeVariant #b737 arg_ (GH.unionStruct raw_)) + (Aircraft'a320 arg_) -> + (GH.encodeVariant #a320 arg_ (GH.unionStruct raw_)) + (Aircraft'f16 arg_) -> + (GH.encodeVariant #f16 arg_ (GH.unionStruct raw_)) + (Aircraft'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Z +type instance (R.ReprFor Z) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Z) where + typeId = 16872429889743397081 +instance (C.TypedStruct Z) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Z) where + type AllocHint Z = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Z (C.Parsed Z)) +instance (C.AllocateList Z) where + type ListAllocHint Z = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Z (C.Parsed Z)) +data instance C.Parsed Z + = Z + {union' :: (C.Parsed (GH.Which Z))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Z)) +deriving instance (Std_.Eq (C.Parsed Z)) +instance (C.Parse Z (C.Parsed Z)) where + parse raw_ = (Z <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal Z (C.Parsed Z)) where + marshalInto raw_ Z{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion Z) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich Z mut_ + = RW_Z'void (R.Raw () mut_) + | RW_Z'zz (R.Raw Z mut_) + | RW_Z'f64 (R.Raw Std_.Double mut_) + | RW_Z'f32 (R.Raw Std_.Float mut_) + | RW_Z'i64 (R.Raw Std_.Int64 mut_) + | RW_Z'i32 (R.Raw Std_.Int32 mut_) + | RW_Z'i16 (R.Raw Std_.Int16 mut_) + | RW_Z'i8 (R.Raw Std_.Int8 mut_) + | RW_Z'u64 (R.Raw Std_.Word64 mut_) + | RW_Z'u32 (R.Raw Std_.Word32 mut_) + | RW_Z'u16 (R.Raw Std_.Word16 mut_) + | RW_Z'u8 (R.Raw Std_.Word8 mut_) + | RW_Z'bool (R.Raw Std_.Bool mut_) + | RW_Z'text (R.Raw Basics.Text mut_) + | RW_Z'blob (R.Raw Basics.Data mut_) + | RW_Z'f64vec (R.Raw (R.List Std_.Double) mut_) + | RW_Z'f32vec (R.Raw (R.List Std_.Float) mut_) + | RW_Z'i64vec (R.Raw (R.List Std_.Int64) mut_) + | RW_Z'i32vec (R.Raw (R.List Std_.Int32) mut_) + | RW_Z'i16vec (R.Raw (R.List Std_.Int16) mut_) + | RW_Z'i8vec (R.Raw (R.List Std_.Int8) mut_) + | RW_Z'u64vec (R.Raw (R.List Std_.Word64) mut_) + | RW_Z'u32vec (R.Raw (R.List Std_.Word32) mut_) + | RW_Z'u16vec (R.Raw (R.List Std_.Word16) mut_) + | RW_Z'u8vec (R.Raw (R.List Std_.Word8) mut_) + | RW_Z'zvec (R.Raw (R.List Z) mut_) + | RW_Z'zvecvec (R.Raw (R.List (R.List Z)) mut_) + | RW_Z'zdate (R.Raw Zdate mut_) + | RW_Z'zdata (R.Raw Zdata mut_) + | RW_Z'aircraftvec (R.Raw (R.List Aircraft) mut_) + | RW_Z'aircraft (R.Raw Aircraft mut_) + | RW_Z'regression (R.Raw Regression mut_) + | RW_Z'planebase (R.Raw PlaneBase mut_) + | RW_Z'airport (R.Raw Airport mut_) + | RW_Z'b737 (R.Raw B737 mut_) + | RW_Z'a320 (R.Raw A320 mut_) + | RW_Z'f16 (R.Raw F16 mut_) + | RW_Z'zdatevec (R.Raw (R.List Zdate) mut_) + | RW_Z'zdatavec (R.Raw (R.List Zdata) mut_) + | RW_Z'boolvec (R.Raw (R.List Std_.Bool) mut_) + | RW_Z'datavec (R.Raw (R.List Basics.Data) mut_) + | RW_Z'textvec (R.Raw (R.List Basics.Text) mut_) + | RW_Z'grp (R.Raw Z'grp mut_) + | RW_Z'echo (R.Raw Echo mut_) + | RW_Z'echoBases (R.Raw EchoBases mut_) + | RW_Z'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Z'void <$> (GH.readVariant #void struct_)) + 1 -> + (RW_Z'zz <$> (GH.readVariant #zz struct_)) + 2 -> + (RW_Z'f64 <$> (GH.readVariant #f64 struct_)) + 3 -> + (RW_Z'f32 <$> (GH.readVariant #f32 struct_)) + 4 -> + (RW_Z'i64 <$> (GH.readVariant #i64 struct_)) + 5 -> + (RW_Z'i32 <$> (GH.readVariant #i32 struct_)) + 6 -> + (RW_Z'i16 <$> (GH.readVariant #i16 struct_)) + 7 -> + (RW_Z'i8 <$> (GH.readVariant #i8 struct_)) + 8 -> + (RW_Z'u64 <$> (GH.readVariant #u64 struct_)) + 9 -> + (RW_Z'u32 <$> (GH.readVariant #u32 struct_)) + 10 -> + (RW_Z'u16 <$> (GH.readVariant #u16 struct_)) + 11 -> + (RW_Z'u8 <$> (GH.readVariant #u8 struct_)) + 12 -> + (RW_Z'bool <$> (GH.readVariant #bool struct_)) + 13 -> + (RW_Z'text <$> (GH.readVariant #text struct_)) + 14 -> + (RW_Z'blob <$> (GH.readVariant #blob struct_)) + 15 -> + (RW_Z'f64vec <$> (GH.readVariant #f64vec struct_)) + 16 -> + (RW_Z'f32vec <$> (GH.readVariant #f32vec struct_)) + 17 -> + (RW_Z'i64vec <$> (GH.readVariant #i64vec struct_)) + 18 -> + (RW_Z'i32vec <$> (GH.readVariant #i32vec struct_)) + 19 -> + (RW_Z'i16vec <$> (GH.readVariant #i16vec struct_)) + 20 -> + (RW_Z'i8vec <$> (GH.readVariant #i8vec struct_)) + 21 -> + (RW_Z'u64vec <$> (GH.readVariant #u64vec struct_)) + 22 -> + (RW_Z'u32vec <$> (GH.readVariant #u32vec struct_)) + 23 -> + (RW_Z'u16vec <$> (GH.readVariant #u16vec struct_)) + 24 -> + (RW_Z'u8vec <$> (GH.readVariant #u8vec struct_)) + 25 -> + (RW_Z'zvec <$> (GH.readVariant #zvec struct_)) + 26 -> + (RW_Z'zvecvec <$> (GH.readVariant #zvecvec struct_)) + 27 -> + (RW_Z'zdate <$> (GH.readVariant #zdate struct_)) + 28 -> + (RW_Z'zdata <$> (GH.readVariant #zdata struct_)) + 29 -> + (RW_Z'aircraftvec <$> (GH.readVariant #aircraftvec struct_)) + 30 -> + (RW_Z'aircraft <$> (GH.readVariant #aircraft struct_)) + 31 -> + (RW_Z'regression <$> (GH.readVariant #regression struct_)) + 32 -> + (RW_Z'planebase <$> (GH.readVariant #planebase struct_)) + 33 -> + (RW_Z'airport <$> (GH.readVariant #airport struct_)) + 34 -> + (RW_Z'b737 <$> (GH.readVariant #b737 struct_)) + 35 -> + (RW_Z'a320 <$> (GH.readVariant #a320 struct_)) + 36 -> + (RW_Z'f16 <$> (GH.readVariant #f16 struct_)) + 37 -> + (RW_Z'zdatevec <$> (GH.readVariant #zdatevec struct_)) + 38 -> + (RW_Z'zdatavec <$> (GH.readVariant #zdatavec struct_)) + 39 -> + (RW_Z'boolvec <$> (GH.readVariant #boolvec struct_)) + 40 -> + (RW_Z'datavec <$> (GH.readVariant #datavec struct_)) + 41 -> + (RW_Z'textvec <$> (GH.readVariant #textvec struct_)) + 42 -> + (RW_Z'grp <$> (GH.readVariant #grp struct_)) + 43 -> + (RW_Z'echo <$> (GH.readVariant #echo struct_)) + 44 -> + (RW_Z'echoBases <$> (GH.readVariant #echoBases struct_)) + _ -> + (Std_.pure (RW_Z'unknown' tag_)) + data Which Z +instance (GH.HasVariant "void" GH.Slot Z ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "zz" GH.Slot Z Z) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +instance (GH.HasVariant "f64" GH.Slot Z Std_.Double) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 2) +instance (GH.HasVariant "f32" GH.Slot Z Std_.Float) where + variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 3) +instance (GH.HasVariant "i64" GH.Slot Z Std_.Int64) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 4) +instance (GH.HasVariant "i32" GH.Slot Z Std_.Int32) where + variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 5) +instance (GH.HasVariant "i16" GH.Slot Z Std_.Int16) where + variantByLabel = (GH.Variant (GH.dataField 0 1 16 0) 6) +instance (GH.HasVariant "i8" GH.Slot Z Std_.Int8) where + variantByLabel = (GH.Variant (GH.dataField 0 1 8 0) 7) +instance (GH.HasVariant "u64" GH.Slot Z Std_.Word64) where + variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 8) +instance (GH.HasVariant "u32" GH.Slot Z Std_.Word32) where + variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 9) +instance (GH.HasVariant "u16" GH.Slot Z Std_.Word16) where + variantByLabel = (GH.Variant (GH.dataField 0 1 16 0) 10) +instance (GH.HasVariant "u8" GH.Slot Z Std_.Word8) where + variantByLabel = (GH.Variant (GH.dataField 0 1 8 0) 11) +instance (GH.HasVariant "bool" GH.Slot Z Std_.Bool) where + variantByLabel = (GH.Variant (GH.dataField 0 1 1 0) 12) +instance (GH.HasVariant "text" GH.Slot Z Basics.Text) where + variantByLabel = (GH.Variant (GH.ptrField 0) 13) +instance (GH.HasVariant "blob" GH.Slot Z Basics.Data) where + variantByLabel = (GH.Variant (GH.ptrField 0) 14) +instance (GH.HasVariant "f64vec" GH.Slot Z (R.List Std_.Double)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 15) +instance (GH.HasVariant "f32vec" GH.Slot Z (R.List Std_.Float)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 16) +instance (GH.HasVariant "i64vec" GH.Slot Z (R.List Std_.Int64)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 17) +instance (GH.HasVariant "i32vec" GH.Slot Z (R.List Std_.Int32)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 18) +instance (GH.HasVariant "i16vec" GH.Slot Z (R.List Std_.Int16)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 19) +instance (GH.HasVariant "i8vec" GH.Slot Z (R.List Std_.Int8)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 20) +instance (GH.HasVariant "u64vec" GH.Slot Z (R.List Std_.Word64)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 21) +instance (GH.HasVariant "u32vec" GH.Slot Z (R.List Std_.Word32)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 22) +instance (GH.HasVariant "u16vec" GH.Slot Z (R.List Std_.Word16)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 23) +instance (GH.HasVariant "u8vec" GH.Slot Z (R.List Std_.Word8)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 24) +instance (GH.HasVariant "zvec" GH.Slot Z (R.List Z)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 25) +instance (GH.HasVariant "zvecvec" GH.Slot Z (R.List (R.List Z))) where + variantByLabel = (GH.Variant (GH.ptrField 0) 26) +instance (GH.HasVariant "zdate" GH.Slot Z Zdate) where + variantByLabel = (GH.Variant (GH.ptrField 0) 27) +instance (GH.HasVariant "zdata" GH.Slot Z Zdata) where + variantByLabel = (GH.Variant (GH.ptrField 0) 28) +instance (GH.HasVariant "aircraftvec" GH.Slot Z (R.List Aircraft)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 29) +instance (GH.HasVariant "aircraft" GH.Slot Z Aircraft) where + variantByLabel = (GH.Variant (GH.ptrField 0) 30) +instance (GH.HasVariant "regression" GH.Slot Z Regression) where + variantByLabel = (GH.Variant (GH.ptrField 0) 31) +instance (GH.HasVariant "planebase" GH.Slot Z PlaneBase) where + variantByLabel = (GH.Variant (GH.ptrField 0) 32) +instance (GH.HasVariant "airport" GH.Slot Z Airport) where + variantByLabel = (GH.Variant (GH.dataField 0 1 16 0) 33) +instance (GH.HasVariant "b737" GH.Slot Z B737) where + variantByLabel = (GH.Variant (GH.ptrField 0) 34) +instance (GH.HasVariant "a320" GH.Slot Z A320) where + variantByLabel = (GH.Variant (GH.ptrField 0) 35) +instance (GH.HasVariant "f16" GH.Slot Z F16) where + variantByLabel = (GH.Variant (GH.ptrField 0) 36) +instance (GH.HasVariant "zdatevec" GH.Slot Z (R.List Zdate)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 37) +instance (GH.HasVariant "zdatavec" GH.Slot Z (R.List Zdata)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 38) +instance (GH.HasVariant "boolvec" GH.Slot Z (R.List Std_.Bool)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 39) +instance (GH.HasVariant "datavec" GH.Slot Z (R.List Basics.Data)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 40) +instance (GH.HasVariant "textvec" GH.Slot Z (R.List Basics.Text)) where + variantByLabel = (GH.Variant (GH.ptrField 0) 41) +instance (GH.HasVariant "grp" GH.Group Z Z'grp) where + variantByLabel = (GH.Variant GH.groupField 42) +instance (GH.HasVariant "echo" GH.Slot Z Echo) where + variantByLabel = (GH.Variant (GH.ptrField 0) 43) +instance (GH.HasVariant "echoBases" GH.Slot Z EchoBases) where + variantByLabel = (GH.Variant (GH.ptrField 0) 44) +data instance C.Parsed (GH.Which Z) + = Z'void + | Z'zz (RP.Parsed Z) + | Z'f64 (RP.Parsed Std_.Double) + | Z'f32 (RP.Parsed Std_.Float) + | Z'i64 (RP.Parsed Std_.Int64) + | Z'i32 (RP.Parsed Std_.Int32) + | Z'i16 (RP.Parsed Std_.Int16) + | Z'i8 (RP.Parsed Std_.Int8) + | Z'u64 (RP.Parsed Std_.Word64) + | Z'u32 (RP.Parsed Std_.Word32) + | Z'u16 (RP.Parsed Std_.Word16) + | Z'u8 (RP.Parsed Std_.Word8) + | Z'bool (RP.Parsed Std_.Bool) + | Z'text (RP.Parsed Basics.Text) + | Z'blob (RP.Parsed Basics.Data) + | Z'f64vec (RP.Parsed (R.List Std_.Double)) + | Z'f32vec (RP.Parsed (R.List Std_.Float)) + | Z'i64vec (RP.Parsed (R.List Std_.Int64)) + | Z'i32vec (RP.Parsed (R.List Std_.Int32)) + | Z'i16vec (RP.Parsed (R.List Std_.Int16)) + | Z'i8vec (RP.Parsed (R.List Std_.Int8)) + | Z'u64vec (RP.Parsed (R.List Std_.Word64)) + | Z'u32vec (RP.Parsed (R.List Std_.Word32)) + | Z'u16vec (RP.Parsed (R.List Std_.Word16)) + | Z'u8vec (RP.Parsed (R.List Std_.Word8)) + | Z'zvec (RP.Parsed (R.List Z)) + | Z'zvecvec (RP.Parsed (R.List (R.List Z))) + | Z'zdate (RP.Parsed Zdate) + | Z'zdata (RP.Parsed Zdata) + | Z'aircraftvec (RP.Parsed (R.List Aircraft)) + | Z'aircraft (RP.Parsed Aircraft) + | Z'regression (RP.Parsed Regression) + | Z'planebase (RP.Parsed PlaneBase) + | Z'airport (RP.Parsed Airport) + | Z'b737 (RP.Parsed B737) + | Z'a320 (RP.Parsed A320) + | Z'f16 (RP.Parsed F16) + | Z'zdatevec (RP.Parsed (R.List Zdate)) + | Z'zdatavec (RP.Parsed (R.List Zdata)) + | Z'boolvec (RP.Parsed (R.List Std_.Bool)) + | Z'datavec (RP.Parsed (R.List Basics.Data)) + | Z'textvec (RP.Parsed (R.List Basics.Text)) + | Z'grp (RP.Parsed Z'grp) + | Z'echo (RP.Parsed Echo) + | Z'echoBases (RP.Parsed EchoBases) + | Z'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which Z))) +deriving instance (Std_.Eq (C.Parsed (GH.Which Z))) +instance (C.Parse (GH.Which Z) (C.Parsed (GH.Which Z))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Z'void _) -> + (Std_.pure Z'void) + (RW_Z'zz rawArg_) -> + (Z'zz <$> (C.parse rawArg_)) + (RW_Z'f64 rawArg_) -> + (Z'f64 <$> (C.parse rawArg_)) + (RW_Z'f32 rawArg_) -> + (Z'f32 <$> (C.parse rawArg_)) + (RW_Z'i64 rawArg_) -> + (Z'i64 <$> (C.parse rawArg_)) + (RW_Z'i32 rawArg_) -> + (Z'i32 <$> (C.parse rawArg_)) + (RW_Z'i16 rawArg_) -> + (Z'i16 <$> (C.parse rawArg_)) + (RW_Z'i8 rawArg_) -> + (Z'i8 <$> (C.parse rawArg_)) + (RW_Z'u64 rawArg_) -> + (Z'u64 <$> (C.parse rawArg_)) + (RW_Z'u32 rawArg_) -> + (Z'u32 <$> (C.parse rawArg_)) + (RW_Z'u16 rawArg_) -> + (Z'u16 <$> (C.parse rawArg_)) + (RW_Z'u8 rawArg_) -> + (Z'u8 <$> (C.parse rawArg_)) + (RW_Z'bool rawArg_) -> + (Z'bool <$> (C.parse rawArg_)) + (RW_Z'text rawArg_) -> + (Z'text <$> (C.parse rawArg_)) + (RW_Z'blob rawArg_) -> + (Z'blob <$> (C.parse rawArg_)) + (RW_Z'f64vec rawArg_) -> + (Z'f64vec <$> (C.parse rawArg_)) + (RW_Z'f32vec rawArg_) -> + (Z'f32vec <$> (C.parse rawArg_)) + (RW_Z'i64vec rawArg_) -> + (Z'i64vec <$> (C.parse rawArg_)) + (RW_Z'i32vec rawArg_) -> + (Z'i32vec <$> (C.parse rawArg_)) + (RW_Z'i16vec rawArg_) -> + (Z'i16vec <$> (C.parse rawArg_)) + (RW_Z'i8vec rawArg_) -> + (Z'i8vec <$> (C.parse rawArg_)) + (RW_Z'u64vec rawArg_) -> + (Z'u64vec <$> (C.parse rawArg_)) + (RW_Z'u32vec rawArg_) -> + (Z'u32vec <$> (C.parse rawArg_)) + (RW_Z'u16vec rawArg_) -> + (Z'u16vec <$> (C.parse rawArg_)) + (RW_Z'u8vec rawArg_) -> + (Z'u8vec <$> (C.parse rawArg_)) + (RW_Z'zvec rawArg_) -> + (Z'zvec <$> (C.parse rawArg_)) + (RW_Z'zvecvec rawArg_) -> + (Z'zvecvec <$> (C.parse rawArg_)) + (RW_Z'zdate rawArg_) -> + (Z'zdate <$> (C.parse rawArg_)) + (RW_Z'zdata rawArg_) -> + (Z'zdata <$> (C.parse rawArg_)) + (RW_Z'aircraftvec rawArg_) -> + (Z'aircraftvec <$> (C.parse rawArg_)) + (RW_Z'aircraft rawArg_) -> + (Z'aircraft <$> (C.parse rawArg_)) + (RW_Z'regression rawArg_) -> + (Z'regression <$> (C.parse rawArg_)) + (RW_Z'planebase rawArg_) -> + (Z'planebase <$> (C.parse rawArg_)) + (RW_Z'airport rawArg_) -> + (Z'airport <$> (C.parse rawArg_)) + (RW_Z'b737 rawArg_) -> + (Z'b737 <$> (C.parse rawArg_)) + (RW_Z'a320 rawArg_) -> + (Z'a320 <$> (C.parse rawArg_)) + (RW_Z'f16 rawArg_) -> + (Z'f16 <$> (C.parse rawArg_)) + (RW_Z'zdatevec rawArg_) -> + (Z'zdatevec <$> (C.parse rawArg_)) + (RW_Z'zdatavec rawArg_) -> + (Z'zdatavec <$> (C.parse rawArg_)) + (RW_Z'boolvec rawArg_) -> + (Z'boolvec <$> (C.parse rawArg_)) + (RW_Z'datavec rawArg_) -> + (Z'datavec <$> (C.parse rawArg_)) + (RW_Z'textvec rawArg_) -> + (Z'textvec <$> (C.parse rawArg_)) + (RW_Z'grp rawArg_) -> + (Z'grp <$> (C.parse rawArg_)) + (RW_Z'echo rawArg_) -> + (Z'echo <$> (C.parse rawArg_)) + (RW_Z'echoBases rawArg_) -> + (Z'echoBases <$> (C.parse rawArg_)) + (RW_Z'unknown' tag_) -> + (Std_.pure (Z'unknown' tag_)) + ) +instance (C.Marshal (GH.Which Z) (C.Parsed (GH.Which Z))) where + marshalInto raw_ parsed_ = case parsed_ of + (Z'void) -> + (GH.encodeVariant #void () (GH.unionStruct raw_)) + (Z'zz arg_) -> + (GH.encodeVariant #zz arg_ (GH.unionStruct raw_)) + (Z'f64 arg_) -> + (GH.encodeVariant #f64 arg_ (GH.unionStruct raw_)) + (Z'f32 arg_) -> + (GH.encodeVariant #f32 arg_ (GH.unionStruct raw_)) + (Z'i64 arg_) -> + (GH.encodeVariant #i64 arg_ (GH.unionStruct raw_)) + (Z'i32 arg_) -> + (GH.encodeVariant #i32 arg_ (GH.unionStruct raw_)) + (Z'i16 arg_) -> + (GH.encodeVariant #i16 arg_ (GH.unionStruct raw_)) + (Z'i8 arg_) -> + (GH.encodeVariant #i8 arg_ (GH.unionStruct raw_)) + (Z'u64 arg_) -> + (GH.encodeVariant #u64 arg_ (GH.unionStruct raw_)) + (Z'u32 arg_) -> + (GH.encodeVariant #u32 arg_ (GH.unionStruct raw_)) + (Z'u16 arg_) -> + (GH.encodeVariant #u16 arg_ (GH.unionStruct raw_)) + (Z'u8 arg_) -> + (GH.encodeVariant #u8 arg_ (GH.unionStruct raw_)) + (Z'bool arg_) -> + (GH.encodeVariant #bool arg_ (GH.unionStruct raw_)) + (Z'text arg_) -> + (GH.encodeVariant #text arg_ (GH.unionStruct raw_)) + (Z'blob arg_) -> + (GH.encodeVariant #blob arg_ (GH.unionStruct raw_)) + (Z'f64vec arg_) -> + (GH.encodeVariant #f64vec arg_ (GH.unionStruct raw_)) + (Z'f32vec arg_) -> + (GH.encodeVariant #f32vec arg_ (GH.unionStruct raw_)) + (Z'i64vec arg_) -> + (GH.encodeVariant #i64vec arg_ (GH.unionStruct raw_)) + (Z'i32vec arg_) -> + (GH.encodeVariant #i32vec arg_ (GH.unionStruct raw_)) + (Z'i16vec arg_) -> + (GH.encodeVariant #i16vec arg_ (GH.unionStruct raw_)) + (Z'i8vec arg_) -> + (GH.encodeVariant #i8vec arg_ (GH.unionStruct raw_)) + (Z'u64vec arg_) -> + (GH.encodeVariant #u64vec arg_ (GH.unionStruct raw_)) + (Z'u32vec arg_) -> + (GH.encodeVariant #u32vec arg_ (GH.unionStruct raw_)) + (Z'u16vec arg_) -> + (GH.encodeVariant #u16vec arg_ (GH.unionStruct raw_)) + (Z'u8vec arg_) -> + (GH.encodeVariant #u8vec arg_ (GH.unionStruct raw_)) + (Z'zvec arg_) -> + (GH.encodeVariant #zvec arg_ (GH.unionStruct raw_)) + (Z'zvecvec arg_) -> + (GH.encodeVariant #zvecvec arg_ (GH.unionStruct raw_)) + (Z'zdate arg_) -> + (GH.encodeVariant #zdate arg_ (GH.unionStruct raw_)) + (Z'zdata arg_) -> + (GH.encodeVariant #zdata arg_ (GH.unionStruct raw_)) + (Z'aircraftvec arg_) -> + (GH.encodeVariant #aircraftvec arg_ (GH.unionStruct raw_)) + (Z'aircraft arg_) -> + (GH.encodeVariant #aircraft arg_ (GH.unionStruct raw_)) + (Z'regression arg_) -> + (GH.encodeVariant #regression arg_ (GH.unionStruct raw_)) + (Z'planebase arg_) -> + (GH.encodeVariant #planebase arg_ (GH.unionStruct raw_)) + (Z'airport arg_) -> + (GH.encodeVariant #airport arg_ (GH.unionStruct raw_)) + (Z'b737 arg_) -> + (GH.encodeVariant #b737 arg_ (GH.unionStruct raw_)) + (Z'a320 arg_) -> + (GH.encodeVariant #a320 arg_ (GH.unionStruct raw_)) + (Z'f16 arg_) -> + (GH.encodeVariant #f16 arg_ (GH.unionStruct raw_)) + (Z'zdatevec arg_) -> + (GH.encodeVariant #zdatevec arg_ (GH.unionStruct raw_)) + (Z'zdatavec arg_) -> + (GH.encodeVariant #zdatavec arg_ (GH.unionStruct raw_)) + (Z'boolvec arg_) -> + (GH.encodeVariant #boolvec arg_ (GH.unionStruct raw_)) + (Z'datavec arg_) -> + (GH.encodeVariant #datavec arg_ (GH.unionStruct raw_)) + (Z'textvec arg_) -> + (GH.encodeVariant #textvec arg_ (GH.unionStruct raw_)) + (Z'grp arg_) -> + (do + rawGroup_ <- (GH.initVariant #grp (GH.unionStruct raw_)) + (C.marshalInto rawGroup_ arg_) + ) + (Z'echo arg_) -> + (GH.encodeVariant #echo arg_ (GH.unionStruct raw_)) + (Z'echoBases arg_) -> + (GH.encodeVariant #echoBases arg_ (GH.unionStruct raw_)) + (Z'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Z'grp +type instance (R.ReprFor Z'grp) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Z'grp) where + typeId = 13198763830743312036 +instance (C.TypedStruct Z'grp) where + numStructWords = 3 + numStructPtrs = 1 +instance (C.Allocate Z'grp) where + type AllocHint Z'grp = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Z'grp (C.Parsed Z'grp)) +instance (C.AllocateList Z'grp) where + type ListAllocHint Z'grp = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Z'grp (C.Parsed Z'grp)) +data instance C.Parsed Z'grp + = Z'grp' + {first :: (RP.Parsed Std_.Word64) + ,second :: (RP.Parsed Std_.Word64)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Z'grp)) +deriving instance (Std_.Eq (C.Parsed Z'grp)) +instance (C.Parse Z'grp (C.Parsed Z'grp)) where + parse raw_ = (Z'grp' <$> (GH.parseField #first raw_) + <*> (GH.parseField #second raw_)) +instance (C.Marshal Z'grp (C.Parsed Z'grp)) where + marshalInto raw_ Z'grp'{..} = (do + (GH.encodeField #first first raw_) + (GH.encodeField #second second raw_) + (Std_.pure ()) + ) +instance (GH.HasField "first" GH.Slot Z'grp Std_.Word64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "second" GH.Slot Z'grp Std_.Word64) where + fieldByLabel = (GH.dataField 0 2 64 0) +data Counter +type instance (R.ReprFor Counter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Counter) where + typeId = 9748248141862325085 +instance (C.TypedStruct Counter) where + numStructWords = 1 + numStructPtrs = 2 +instance (C.Allocate Counter) where + type AllocHint Counter = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Counter (C.Parsed Counter)) +instance (C.AllocateList Counter) where + type ListAllocHint Counter = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Counter (C.Parsed Counter)) +data instance C.Parsed Counter + = Counter + {size :: (RP.Parsed Std_.Int64) + ,words :: (RP.Parsed Basics.Text) + ,wordlist :: (RP.Parsed (R.List Basics.Text))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Counter)) +deriving instance (Std_.Eq (C.Parsed Counter)) +instance (C.Parse Counter (C.Parsed Counter)) where + parse raw_ = (Counter <$> (GH.parseField #size raw_) + <*> (GH.parseField #words raw_) + <*> (GH.parseField #wordlist raw_)) +instance (C.Marshal Counter (C.Parsed Counter)) where + marshalInto raw_ Counter{..} = (do + (GH.encodeField #size size raw_) + (GH.encodeField #words words raw_) + (GH.encodeField #wordlist wordlist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "size" GH.Slot Counter Std_.Int64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "words" GH.Slot Counter Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "wordlist" GH.Slot Counter (R.List Basics.Text)) where + fieldByLabel = (GH.ptrField 1) +data Bag +type instance (R.ReprFor Bag) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bag) where + typeId = 15435801458704439998 +instance (C.TypedStruct Bag) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Bag) where + type AllocHint Bag = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Bag (C.Parsed Bag)) +instance (C.AllocateList Bag) where + type ListAllocHint Bag = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Bag (C.Parsed Bag)) +data instance C.Parsed Bag + = Bag + {counter :: (RP.Parsed Counter)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Bag)) +deriving instance (Std_.Eq (C.Parsed Bag)) +instance (C.Parse Bag (C.Parsed Bag)) where + parse raw_ = (Bag <$> (GH.parseField #counter raw_)) +instance (C.Marshal Bag (C.Parsed Bag)) where + marshalInto raw_ Bag{..} = (do + (GH.encodeField #counter counter raw_) + (Std_.pure ()) + ) +instance (GH.HasField "counter" GH.Slot Bag Counter) where + fieldByLabel = (GH.ptrField 0) +data Zserver +type instance (R.ReprFor Zserver) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zserver) where + typeId = 14718909161889449112 +instance (C.TypedStruct Zserver) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Zserver) where + type AllocHint Zserver = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Zserver (C.Parsed Zserver)) +instance (C.AllocateList Zserver) where + type ListAllocHint Zserver = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Zserver (C.Parsed Zserver)) +data instance C.Parsed Zserver + = Zserver + {waitingjobs :: (RP.Parsed (R.List Zjob))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Zserver)) +deriving instance (Std_.Eq (C.Parsed Zserver)) +instance (C.Parse Zserver (C.Parsed Zserver)) where + parse raw_ = (Zserver <$> (GH.parseField #waitingjobs raw_)) +instance (C.Marshal Zserver (C.Parsed Zserver)) where + marshalInto raw_ Zserver{..} = (do + (GH.encodeField #waitingjobs waitingjobs raw_) + (Std_.pure ()) + ) +instance (GH.HasField "waitingjobs" GH.Slot Zserver (R.List Zjob)) where + fieldByLabel = (GH.ptrField 0) +data Zjob +type instance (R.ReprFor Zjob) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zjob) where + typeId = 15983628460635158035 +instance (C.TypedStruct Zjob) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate Zjob) where + type AllocHint Zjob = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Zjob (C.Parsed Zjob)) +instance (C.AllocateList Zjob) where + type ListAllocHint Zjob = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Zjob (C.Parsed Zjob)) +data instance C.Parsed Zjob + = Zjob + {cmd :: (RP.Parsed Basics.Text) + ,args :: (RP.Parsed (R.List Basics.Text))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Zjob)) +deriving instance (Std_.Eq (C.Parsed Zjob)) +instance (C.Parse Zjob (C.Parsed Zjob)) where + parse raw_ = (Zjob <$> (GH.parseField #cmd raw_) + <*> (GH.parseField #args raw_)) +instance (C.Marshal Zjob (C.Parsed Zjob)) where + marshalInto raw_ Zjob{..} = (do + (GH.encodeField #cmd cmd raw_) + (GH.encodeField #args args raw_) + (Std_.pure ()) + ) +instance (GH.HasField "cmd" GH.Slot Zjob Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "args" GH.Slot Zjob (R.List Basics.Text)) where + fieldByLabel = (GH.ptrField 1) +data VerEmpty +type instance (R.ReprFor VerEmpty) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerEmpty) where + typeId = 10649211371004916479 +instance (C.TypedStruct VerEmpty) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate VerEmpty) where + type AllocHint VerEmpty = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerEmpty (C.Parsed VerEmpty)) +instance (C.AllocateList VerEmpty) where + type ListAllocHint VerEmpty = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerEmpty (C.Parsed VerEmpty)) +data instance C.Parsed VerEmpty + = VerEmpty + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerEmpty)) +deriving instance (Std_.Eq (C.Parsed VerEmpty)) +instance (C.Parse VerEmpty (C.Parsed VerEmpty)) where + parse raw_ = (Std_.pure VerEmpty) +instance (C.Marshal VerEmpty (C.Parsed VerEmpty)) where + marshalInto _raw (VerEmpty) = (Std_.pure ()) +data VerOneData +type instance (R.ReprFor VerOneData) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerOneData) where + typeId = 18204521836387912926 +instance (C.TypedStruct VerOneData) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate VerOneData) where + type AllocHint VerOneData = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerOneData (C.Parsed VerOneData)) +instance (C.AllocateList VerOneData) where + type ListAllocHint VerOneData = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerOneData (C.Parsed VerOneData)) +data instance C.Parsed VerOneData + = VerOneData + {val :: (RP.Parsed Std_.Int16)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerOneData)) +deriving instance (Std_.Eq (C.Parsed VerOneData)) +instance (C.Parse VerOneData (C.Parsed VerOneData)) where + parse raw_ = (VerOneData <$> (GH.parseField #val raw_)) +instance (C.Marshal VerOneData (C.Parsed VerOneData)) where + marshalInto raw_ VerOneData{..} = (do + (GH.encodeField #val val raw_) + (Std_.pure ()) + ) +instance (GH.HasField "val" GH.Slot VerOneData Std_.Int16) where + fieldByLabel = (GH.dataField 0 0 16 0) +data VerTwoData +type instance (R.ReprFor VerTwoData) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoData) where + typeId = 17799875294539507453 +instance (C.TypedStruct VerTwoData) where + numStructWords = 2 + numStructPtrs = 0 +instance (C.Allocate VerTwoData) where + type AllocHint VerTwoData = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerTwoData (C.Parsed VerTwoData)) +instance (C.AllocateList VerTwoData) where + type ListAllocHint VerTwoData = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerTwoData (C.Parsed VerTwoData)) +data instance C.Parsed VerTwoData + = VerTwoData + {val :: (RP.Parsed Std_.Int16) + ,duo :: (RP.Parsed Std_.Int64)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerTwoData)) +deriving instance (Std_.Eq (C.Parsed VerTwoData)) +instance (C.Parse VerTwoData (C.Parsed VerTwoData)) where + parse raw_ = (VerTwoData <$> (GH.parseField #val raw_) + <*> (GH.parseField #duo raw_)) +instance (C.Marshal VerTwoData (C.Parsed VerTwoData)) where + marshalInto raw_ VerTwoData{..} = (do + (GH.encodeField #val val raw_) + (GH.encodeField #duo duo raw_) + (Std_.pure ()) + ) +instance (GH.HasField "val" GH.Slot VerTwoData Std_.Int16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "duo" GH.Slot VerTwoData Std_.Int64) where + fieldByLabel = (GH.dataField 0 1 64 0) +data VerOnePtr +type instance (R.ReprFor VerOnePtr) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerOnePtr) where + typeId = 10718424143143379341 +instance (C.TypedStruct VerOnePtr) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate VerOnePtr) where + type AllocHint VerOnePtr = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerOnePtr (C.Parsed VerOnePtr)) +instance (C.AllocateList VerOnePtr) where + type ListAllocHint VerOnePtr = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerOnePtr (C.Parsed VerOnePtr)) +data instance C.Parsed VerOnePtr + = VerOnePtr + {ptr :: (RP.Parsed VerOneData)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerOnePtr)) +deriving instance (Std_.Eq (C.Parsed VerOnePtr)) +instance (C.Parse VerOnePtr (C.Parsed VerOnePtr)) where + parse raw_ = (VerOnePtr <$> (GH.parseField #ptr raw_)) +instance (C.Marshal VerOnePtr (C.Parsed VerOnePtr)) where + marshalInto raw_ VerOnePtr{..} = (do + (GH.encodeField #ptr ptr raw_) + (Std_.pure ()) + ) +instance (GH.HasField "ptr" GH.Slot VerOnePtr VerOneData) where + fieldByLabel = (GH.ptrField 0) +data VerTwoPtr +type instance (R.ReprFor VerTwoPtr) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoPtr) where + typeId = 14509379619124759853 +instance (C.TypedStruct VerTwoPtr) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate VerTwoPtr) where + type AllocHint VerTwoPtr = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerTwoPtr (C.Parsed VerTwoPtr)) +instance (C.AllocateList VerTwoPtr) where + type ListAllocHint VerTwoPtr = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerTwoPtr (C.Parsed VerTwoPtr)) +data instance C.Parsed VerTwoPtr + = VerTwoPtr + {ptr1 :: (RP.Parsed VerOneData) + ,ptr2 :: (RP.Parsed VerOneData)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerTwoPtr)) +deriving instance (Std_.Eq (C.Parsed VerTwoPtr)) +instance (C.Parse VerTwoPtr (C.Parsed VerTwoPtr)) where + parse raw_ = (VerTwoPtr <$> (GH.parseField #ptr1 raw_) + <*> (GH.parseField #ptr2 raw_)) +instance (C.Marshal VerTwoPtr (C.Parsed VerTwoPtr)) where + marshalInto raw_ VerTwoPtr{..} = (do + (GH.encodeField #ptr1 ptr1 raw_) + (GH.encodeField #ptr2 ptr2 raw_) + (Std_.pure ()) + ) +instance (GH.HasField "ptr1" GH.Slot VerTwoPtr VerOneData) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "ptr2" GH.Slot VerTwoPtr VerOneData) where + fieldByLabel = (GH.ptrField 1) +data VerTwoDataTwoPtr +type instance (R.ReprFor VerTwoDataTwoPtr) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoDataTwoPtr) where + typeId = 13123175871726013043 +instance (C.TypedStruct VerTwoDataTwoPtr) where + numStructWords = 2 + numStructPtrs = 2 +instance (C.Allocate VerTwoDataTwoPtr) where + type AllocHint VerTwoDataTwoPtr = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) +instance (C.AllocateList VerTwoDataTwoPtr) where + type ListAllocHint VerTwoDataTwoPtr = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) +data instance C.Parsed VerTwoDataTwoPtr + = VerTwoDataTwoPtr + {val :: (RP.Parsed Std_.Int16) + ,duo :: (RP.Parsed Std_.Int64) + ,ptr1 :: (RP.Parsed VerOneData) + ,ptr2 :: (RP.Parsed VerOneData)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerTwoDataTwoPtr)) +deriving instance (Std_.Eq (C.Parsed VerTwoDataTwoPtr)) +instance (C.Parse VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) where + parse raw_ = (VerTwoDataTwoPtr <$> (GH.parseField #val raw_) + <*> (GH.parseField #duo raw_) + <*> (GH.parseField #ptr1 raw_) + <*> (GH.parseField #ptr2 raw_)) +instance (C.Marshal VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) where + marshalInto raw_ VerTwoDataTwoPtr{..} = (do + (GH.encodeField #val val raw_) + (GH.encodeField #duo duo raw_) + (GH.encodeField #ptr1 ptr1 raw_) + (GH.encodeField #ptr2 ptr2 raw_) + (Std_.pure ()) + ) +instance (GH.HasField "val" GH.Slot VerTwoDataTwoPtr Std_.Int16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "duo" GH.Slot VerTwoDataTwoPtr Std_.Int64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "ptr1" GH.Slot VerTwoDataTwoPtr VerOneData) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "ptr2" GH.Slot VerTwoDataTwoPtr VerOneData) where + fieldByLabel = (GH.ptrField 1) +data HoldsVerEmptyList +type instance (R.ReprFor HoldsVerEmptyList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerEmptyList) where + typeId = 16041492281108738195 +instance (C.TypedStruct HoldsVerEmptyList) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerEmptyList) where + type AllocHint HoldsVerEmptyList = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) +instance (C.AllocateList HoldsVerEmptyList) where + type ListAllocHint HoldsVerEmptyList = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) +data instance C.Parsed HoldsVerEmptyList + = HoldsVerEmptyList + {mylist :: (RP.Parsed (R.List VerEmpty))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerEmptyList)) +deriving instance (Std_.Eq (C.Parsed HoldsVerEmptyList)) +instance (C.Parse HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) where + parse raw_ = (HoldsVerEmptyList <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) where + marshalInto raw_ HoldsVerEmptyList{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerEmptyList (R.List VerEmpty)) where + fieldByLabel = (GH.ptrField 0) +data HoldsVerOneDataList +type instance (R.ReprFor HoldsVerOneDataList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerOneDataList) where + typeId = 12380489118307417585 +instance (C.TypedStruct HoldsVerOneDataList) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerOneDataList) where + type AllocHint HoldsVerOneDataList = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) +instance (C.AllocateList HoldsVerOneDataList) where + type ListAllocHint HoldsVerOneDataList = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) +data instance C.Parsed HoldsVerOneDataList + = HoldsVerOneDataList + {mylist :: (RP.Parsed (R.List VerOneData))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerOneDataList)) +deriving instance (Std_.Eq (C.Parsed HoldsVerOneDataList)) +instance (C.Parse HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) where + parse raw_ = (HoldsVerOneDataList <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) where + marshalInto raw_ HoldsVerOneDataList{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerOneDataList (R.List VerOneData)) where + fieldByLabel = (GH.ptrField 0) +data HoldsVerTwoDataList +type instance (R.ReprFor HoldsVerTwoDataList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoDataList) where + typeId = 14689746238557910970 +instance (C.TypedStruct HoldsVerTwoDataList) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerTwoDataList) where + type AllocHint HoldsVerTwoDataList = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) +instance (C.AllocateList HoldsVerTwoDataList) where + type ListAllocHint HoldsVerTwoDataList = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) +data instance C.Parsed HoldsVerTwoDataList + = HoldsVerTwoDataList + {mylist :: (RP.Parsed (R.List VerTwoData))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerTwoDataList)) +deriving instance (Std_.Eq (C.Parsed HoldsVerTwoDataList)) +instance (C.Parse HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) where + parse raw_ = (HoldsVerTwoDataList <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) where + marshalInto raw_ HoldsVerTwoDataList{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerTwoDataList (R.List VerTwoData)) where + fieldByLabel = (GH.ptrField 0) +data HoldsVerOnePtrList +type instance (R.ReprFor HoldsVerOnePtrList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerOnePtrList) where + typeId = 16503619627606104568 +instance (C.TypedStruct HoldsVerOnePtrList) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerOnePtrList) where + type AllocHint HoldsVerOnePtrList = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) +instance (C.AllocateList HoldsVerOnePtrList) where + type ListAllocHint HoldsVerOnePtrList = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) +data instance C.Parsed HoldsVerOnePtrList + = HoldsVerOnePtrList + {mylist :: (RP.Parsed (R.List VerOnePtr))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerOnePtrList)) +deriving instance (Std_.Eq (C.Parsed HoldsVerOnePtrList)) +instance (C.Parse HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) where + parse raw_ = (HoldsVerOnePtrList <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) where + marshalInto raw_ HoldsVerOnePtrList{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerOnePtrList (R.List VerOnePtr)) where + fieldByLabel = (GH.ptrField 0) +data HoldsVerTwoPtrList +type instance (R.ReprFor HoldsVerTwoPtrList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoPtrList) where + typeId = 14959808741027971272 +instance (C.TypedStruct HoldsVerTwoPtrList) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerTwoPtrList) where + type AllocHint HoldsVerTwoPtrList = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) +instance (C.AllocateList HoldsVerTwoPtrList) where + type ListAllocHint HoldsVerTwoPtrList = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) +data instance C.Parsed HoldsVerTwoPtrList + = HoldsVerTwoPtrList + {mylist :: (RP.Parsed (R.List VerTwoPtr))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerTwoPtrList)) +deriving instance (Std_.Eq (C.Parsed HoldsVerTwoPtrList)) +instance (C.Parse HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) where + parse raw_ = (HoldsVerTwoPtrList <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) where + marshalInto raw_ HoldsVerTwoPtrList{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerTwoPtrList (R.List VerTwoPtr)) where + fieldByLabel = (GH.ptrField 0) +data HoldsVerTwoTwoList +type instance (R.ReprFor HoldsVerTwoTwoList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoTwoList) where + typeId = 10790341304104545899 +instance (C.TypedStruct HoldsVerTwoTwoList) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerTwoTwoList) where + type AllocHint HoldsVerTwoTwoList = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) +instance (C.AllocateList HoldsVerTwoTwoList) where + type ListAllocHint HoldsVerTwoTwoList = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) +data instance C.Parsed HoldsVerTwoTwoList + = HoldsVerTwoTwoList + {mylist :: (RP.Parsed (R.List VerTwoDataTwoPtr))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerTwoTwoList)) +deriving instance (Std_.Eq (C.Parsed HoldsVerTwoTwoList)) +instance (C.Parse HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) where + parse raw_ = (HoldsVerTwoTwoList <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) where + marshalInto raw_ HoldsVerTwoTwoList{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerTwoTwoList (R.List VerTwoDataTwoPtr)) where + fieldByLabel = (GH.ptrField 0) +data HoldsVerTwoTwoPlus +type instance (R.ReprFor HoldsVerTwoTwoPlus) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoTwoPlus) where + typeId = 9782732235957253080 +instance (C.TypedStruct HoldsVerTwoTwoPlus) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate HoldsVerTwoTwoPlus) where + type AllocHint HoldsVerTwoTwoPlus = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) +instance (C.AllocateList HoldsVerTwoTwoPlus) where + type ListAllocHint HoldsVerTwoTwoPlus = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) +data instance C.Parsed HoldsVerTwoTwoPlus + = HoldsVerTwoTwoPlus + {mylist :: (RP.Parsed (R.List VerTwoTwoPlus))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsVerTwoTwoPlus)) +deriving instance (Std_.Eq (C.Parsed HoldsVerTwoTwoPlus)) +instance (C.Parse HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) where + parse raw_ = (HoldsVerTwoTwoPlus <$> (GH.parseField #mylist raw_)) +instance (C.Marshal HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) where + marshalInto raw_ HoldsVerTwoTwoPlus{..} = (do + (GH.encodeField #mylist mylist raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mylist" GH.Slot HoldsVerTwoTwoPlus (R.List VerTwoTwoPlus)) where + fieldByLabel = (GH.ptrField 0) +data VerTwoTwoPlus +type instance (R.ReprFor VerTwoTwoPlus) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoTwoPlus) where + typeId = 14863196959570808905 +instance (C.TypedStruct VerTwoTwoPlus) where + numStructWords = 3 + numStructPtrs = 3 +instance (C.Allocate VerTwoTwoPlus) where + type AllocHint VerTwoTwoPlus = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) +instance (C.AllocateList VerTwoTwoPlus) where + type ListAllocHint VerTwoTwoPlus = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) +data instance C.Parsed VerTwoTwoPlus + = VerTwoTwoPlus + {val :: (RP.Parsed Std_.Int16) + ,duo :: (RP.Parsed Std_.Int64) + ,ptr1 :: (RP.Parsed VerTwoDataTwoPtr) + ,ptr2 :: (RP.Parsed VerTwoDataTwoPtr) + ,tre :: (RP.Parsed Std_.Int64) + ,lst3 :: (RP.Parsed (R.List Std_.Int64))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VerTwoTwoPlus)) +deriving instance (Std_.Eq (C.Parsed VerTwoTwoPlus)) +instance (C.Parse VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) where + parse raw_ = (VerTwoTwoPlus <$> (GH.parseField #val raw_) + <*> (GH.parseField #duo raw_) + <*> (GH.parseField #ptr1 raw_) + <*> (GH.parseField #ptr2 raw_) + <*> (GH.parseField #tre raw_) + <*> (GH.parseField #lst3 raw_)) +instance (C.Marshal VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) where + marshalInto raw_ VerTwoTwoPlus{..} = (do + (GH.encodeField #val val raw_) + (GH.encodeField #duo duo raw_) + (GH.encodeField #ptr1 ptr1 raw_) + (GH.encodeField #ptr2 ptr2 raw_) + (GH.encodeField #tre tre raw_) + (GH.encodeField #lst3 lst3 raw_) + (Std_.pure ()) + ) +instance (GH.HasField "val" GH.Slot VerTwoTwoPlus Std_.Int16) where + fieldByLabel = (GH.dataField 0 0 16 0) +instance (GH.HasField "duo" GH.Slot VerTwoTwoPlus Std_.Int64) where + fieldByLabel = (GH.dataField 0 1 64 0) +instance (GH.HasField "ptr1" GH.Slot VerTwoTwoPlus VerTwoDataTwoPtr) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "ptr2" GH.Slot VerTwoTwoPlus VerTwoDataTwoPtr) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "tre" GH.Slot VerTwoTwoPlus Std_.Int64) where + fieldByLabel = (GH.dataField 0 2 64 0) +instance (GH.HasField "lst3" GH.Slot VerTwoTwoPlus (R.List Std_.Int64)) where + fieldByLabel = (GH.ptrField 2) +data HoldsText +type instance (R.ReprFor HoldsText) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsText) where + typeId = 16537639514277480156 +instance (C.TypedStruct HoldsText) where + numStructWords = 0 + numStructPtrs = 3 +instance (C.Allocate HoldsText) where + type AllocHint HoldsText = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc HoldsText (C.Parsed HoldsText)) +instance (C.AllocateList HoldsText) where + type ListAllocHint HoldsText = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc HoldsText (C.Parsed HoldsText)) +data instance C.Parsed HoldsText + = HoldsText + {txt :: (RP.Parsed Basics.Text) + ,lst :: (RP.Parsed (R.List Basics.Text)) + ,lstlst :: (RP.Parsed (R.List (R.List Basics.Text)))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed HoldsText)) +deriving instance (Std_.Eq (C.Parsed HoldsText)) +instance (C.Parse HoldsText (C.Parsed HoldsText)) where + parse raw_ = (HoldsText <$> (GH.parseField #txt raw_) + <*> (GH.parseField #lst raw_) + <*> (GH.parseField #lstlst raw_)) +instance (C.Marshal HoldsText (C.Parsed HoldsText)) where + marshalInto raw_ HoldsText{..} = (do + (GH.encodeField #txt txt raw_) + (GH.encodeField #lst lst raw_) + (GH.encodeField #lstlst lstlst raw_) + (Std_.pure ()) + ) +instance (GH.HasField "txt" GH.Slot HoldsText Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "lst" GH.Slot HoldsText (R.List Basics.Text)) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "lstlst" GH.Slot HoldsText (R.List (R.List Basics.Text))) where + fieldByLabel = (GH.ptrField 2) +data WrapEmpty +type instance (R.ReprFor WrapEmpty) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId WrapEmpty) where + typeId = 11147985329045285977 +instance (C.TypedStruct WrapEmpty) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate WrapEmpty) where + type AllocHint WrapEmpty = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc WrapEmpty (C.Parsed WrapEmpty)) +instance (C.AllocateList WrapEmpty) where + type ListAllocHint WrapEmpty = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc WrapEmpty (C.Parsed WrapEmpty)) +data instance C.Parsed WrapEmpty + = WrapEmpty + {mightNotBeReallyEmpty :: (RP.Parsed VerEmpty)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed WrapEmpty)) +deriving instance (Std_.Eq (C.Parsed WrapEmpty)) +instance (C.Parse WrapEmpty (C.Parsed WrapEmpty)) where + parse raw_ = (WrapEmpty <$> (GH.parseField #mightNotBeReallyEmpty raw_)) +instance (C.Marshal WrapEmpty (C.Parsed WrapEmpty)) where + marshalInto raw_ WrapEmpty{..} = (do + (GH.encodeField #mightNotBeReallyEmpty mightNotBeReallyEmpty raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mightNotBeReallyEmpty" GH.Slot WrapEmpty VerEmpty) where + fieldByLabel = (GH.ptrField 0) +data Wrap2x2 +type instance (R.ReprFor Wrap2x2) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Wrap2x2) where + typeId = 16258788317804871341 +instance (C.TypedStruct Wrap2x2) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Wrap2x2) where + type AllocHint Wrap2x2 = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Wrap2x2 (C.Parsed Wrap2x2)) +instance (C.AllocateList Wrap2x2) where + type ListAllocHint Wrap2x2 = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Wrap2x2 (C.Parsed Wrap2x2)) +data instance C.Parsed Wrap2x2 + = Wrap2x2 + {mightNotBeReallyEmpty :: (RP.Parsed VerTwoDataTwoPtr)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Wrap2x2)) +deriving instance (Std_.Eq (C.Parsed Wrap2x2)) +instance (C.Parse Wrap2x2 (C.Parsed Wrap2x2)) where + parse raw_ = (Wrap2x2 <$> (GH.parseField #mightNotBeReallyEmpty raw_)) +instance (C.Marshal Wrap2x2 (C.Parsed Wrap2x2)) where + marshalInto raw_ Wrap2x2{..} = (do + (GH.encodeField #mightNotBeReallyEmpty mightNotBeReallyEmpty raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mightNotBeReallyEmpty" GH.Slot Wrap2x2 VerTwoDataTwoPtr) where + fieldByLabel = (GH.ptrField 0) +data Wrap2x2plus +type instance (R.ReprFor Wrap2x2plus) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Wrap2x2plus) where + typeId = 16610659964001347673 +instance (C.TypedStruct Wrap2x2plus) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Wrap2x2plus) where + type AllocHint Wrap2x2plus = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Wrap2x2plus (C.Parsed Wrap2x2plus)) +instance (C.AllocateList Wrap2x2plus) where + type ListAllocHint Wrap2x2plus = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Wrap2x2plus (C.Parsed Wrap2x2plus)) +data instance C.Parsed Wrap2x2plus + = Wrap2x2plus + {mightNotBeReallyEmpty :: (RP.Parsed VerTwoTwoPlus)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Wrap2x2plus)) +deriving instance (Std_.Eq (C.Parsed Wrap2x2plus)) +instance (C.Parse Wrap2x2plus (C.Parsed Wrap2x2plus)) where + parse raw_ = (Wrap2x2plus <$> (GH.parseField #mightNotBeReallyEmpty raw_)) +instance (C.Marshal Wrap2x2plus (C.Parsed Wrap2x2plus)) where + marshalInto raw_ Wrap2x2plus{..} = (do + (GH.encodeField #mightNotBeReallyEmpty mightNotBeReallyEmpty raw_) + (Std_.pure ()) + ) +instance (GH.HasField "mightNotBeReallyEmpty" GH.Slot Wrap2x2plus VerTwoTwoPlus) where + fieldByLabel = (GH.ptrField 0) +data VoidUnion +type instance (R.ReprFor VoidUnion) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VoidUnion) where + typeId = 9809347628687718458 +instance (C.TypedStruct VoidUnion) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate VoidUnion) where + type AllocHint VoidUnion = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc VoidUnion (C.Parsed VoidUnion)) +instance (C.AllocateList VoidUnion) where + type ListAllocHint VoidUnion = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc VoidUnion (C.Parsed VoidUnion)) +data instance C.Parsed VoidUnion + = VoidUnion + {union' :: (C.Parsed (GH.Which VoidUnion))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed VoidUnion)) +deriving instance (Std_.Eq (C.Parsed VoidUnion)) +instance (C.Parse VoidUnion (C.Parsed VoidUnion)) where + parse raw_ = (VoidUnion <$> (C.parse (GH.structUnion raw_))) +instance (C.Marshal VoidUnion (C.Parsed VoidUnion)) where + marshalInto raw_ VoidUnion{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance (GH.HasUnion VoidUnion) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich VoidUnion mut_ + = RW_VoidUnion'a (R.Raw () mut_) + | RW_VoidUnion'b (R.Raw () mut_) + | RW_VoidUnion'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_VoidUnion'a <$> (GH.readVariant #a struct_)) + 1 -> + (RW_VoidUnion'b <$> (GH.readVariant #b struct_)) + _ -> + (Std_.pure (RW_VoidUnion'unknown' tag_)) + data Which VoidUnion +instance (GH.HasVariant "a" GH.Slot VoidUnion ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance (GH.HasVariant "b" GH.Slot VoidUnion ()) where + variantByLabel = (GH.Variant GH.voidField 1) +data instance C.Parsed (GH.Which VoidUnion) + = VoidUnion'a + | VoidUnion'b + | VoidUnion'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed (GH.Which VoidUnion))) +deriving instance (Std_.Eq (C.Parsed (GH.Which VoidUnion))) +instance (C.Parse (GH.Which VoidUnion) (C.Parsed (GH.Which VoidUnion))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_VoidUnion'a _) -> + (Std_.pure VoidUnion'a) + (RW_VoidUnion'b _) -> + (Std_.pure VoidUnion'b) + (RW_VoidUnion'unknown' tag_) -> + (Std_.pure (VoidUnion'unknown' tag_)) + ) +instance (C.Marshal (GH.Which VoidUnion) (C.Parsed (GH.Which VoidUnion))) where + marshalInto raw_ parsed_ = case parsed_ of + (VoidUnion'a) -> + (GH.encodeVariant #a () (GH.unionStruct raw_)) + (VoidUnion'b) -> + (GH.encodeVariant #b () (GH.unionStruct raw_)) + (VoidUnion'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Nester1Capn +type instance (R.ReprFor Nester1Capn) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Nester1Capn) where + typeId = 17388306941580478492 +instance (C.TypedStruct Nester1Capn) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Nester1Capn) where + type AllocHint Nester1Capn = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Nester1Capn (C.Parsed Nester1Capn)) +instance (C.AllocateList Nester1Capn) where + type ListAllocHint Nester1Capn = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Nester1Capn (C.Parsed Nester1Capn)) +data instance C.Parsed Nester1Capn + = Nester1Capn + {strs :: (RP.Parsed (R.List Basics.Text))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Nester1Capn)) +deriving instance (Std_.Eq (C.Parsed Nester1Capn)) +instance (C.Parse Nester1Capn (C.Parsed Nester1Capn)) where + parse raw_ = (Nester1Capn <$> (GH.parseField #strs raw_)) +instance (C.Marshal Nester1Capn (C.Parsed Nester1Capn)) where + marshalInto raw_ Nester1Capn{..} = (do + (GH.encodeField #strs strs raw_) + (Std_.pure ()) + ) +instance (GH.HasField "strs" GH.Slot Nester1Capn (R.List Basics.Text)) where + fieldByLabel = (GH.ptrField 0) +data RWTestCapn +type instance (R.ReprFor RWTestCapn) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId RWTestCapn) where + typeId = 17870076700317718634 +instance (C.TypedStruct RWTestCapn) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate RWTestCapn) where + type AllocHint RWTestCapn = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc RWTestCapn (C.Parsed RWTestCapn)) +instance (C.AllocateList RWTestCapn) where + type ListAllocHint RWTestCapn = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc RWTestCapn (C.Parsed RWTestCapn)) +data instance C.Parsed RWTestCapn + = RWTestCapn + {nestMatrix :: (RP.Parsed (R.List (R.List Nester1Capn)))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed RWTestCapn)) +deriving instance (Std_.Eq (C.Parsed RWTestCapn)) +instance (C.Parse RWTestCapn (C.Parsed RWTestCapn)) where + parse raw_ = (RWTestCapn <$> (GH.parseField #nestMatrix raw_)) +instance (C.Marshal RWTestCapn (C.Parsed RWTestCapn)) where + marshalInto raw_ RWTestCapn{..} = (do + (GH.encodeField #nestMatrix nestMatrix raw_) + (Std_.pure ()) + ) +instance (GH.HasField "nestMatrix" GH.Slot RWTestCapn (R.List (R.List Nester1Capn))) where + fieldByLabel = (GH.ptrField 0) +data ListStructCapn +type instance (R.ReprFor ListStructCapn) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ListStructCapn) where + typeId = 12802613814325702673 +instance (C.TypedStruct ListStructCapn) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate ListStructCapn) where + type AllocHint ListStructCapn = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc ListStructCapn (C.Parsed ListStructCapn)) +instance (C.AllocateList ListStructCapn) where + type ListAllocHint ListStructCapn = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc ListStructCapn (C.Parsed ListStructCapn)) +data instance C.Parsed ListStructCapn + = ListStructCapn + {vec :: (RP.Parsed (R.List Nester1Capn))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed ListStructCapn)) +deriving instance (Std_.Eq (C.Parsed ListStructCapn)) +instance (C.Parse ListStructCapn (C.Parsed ListStructCapn)) where + parse raw_ = (ListStructCapn <$> (GH.parseField #vec raw_)) +instance (C.Marshal ListStructCapn (C.Parsed ListStructCapn)) where + marshalInto raw_ ListStructCapn{..} = (do + (GH.encodeField #vec vec raw_) + (Std_.pure ()) + ) +instance (GH.HasField "vec" GH.Slot ListStructCapn (R.List Nester1Capn)) where + fieldByLabel = (GH.ptrField 0) +data Echo +type instance (R.ReprFor Echo) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Echo) where + typeId = 10255578992688506164 +instance (C.Parse Echo (GH.Client Echo)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export Echo) where + type Server Echo = Echo'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) +class (Echo'server_ s_) where + {-# MINIMAL echo'echo #-} + echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) + echo'echo _ = GH.methodUnimplemented +instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where + methodByLabel = (GH.Method 10255578992688506164 0) +data Echo'echo'params +type instance (R.ReprFor Echo'echo'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Echo'echo'params) where + typeId = 9950245657029374882 +instance (C.TypedStruct Echo'echo'params) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Echo'echo'params) where + type AllocHint Echo'echo'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Echo'echo'params (C.Parsed Echo'echo'params)) +instance (C.AllocateList Echo'echo'params) where + type ListAllocHint Echo'echo'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Echo'echo'params (C.Parsed Echo'echo'params)) +data instance C.Parsed Echo'echo'params + = Echo'echo'params + {in_ :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Echo'echo'params)) +deriving instance (Std_.Eq (C.Parsed Echo'echo'params)) +instance (C.Parse Echo'echo'params (C.Parsed Echo'echo'params)) where + parse raw_ = (Echo'echo'params <$> (GH.parseField #in_ raw_)) +instance (C.Marshal Echo'echo'params (C.Parsed Echo'echo'params)) where + marshalInto raw_ Echo'echo'params{..} = (do + (GH.encodeField #in_ in_ raw_) + (Std_.pure ()) + ) +instance (GH.HasField "in_" GH.Slot Echo'echo'params Basics.Text) where + fieldByLabel = (GH.ptrField 0) +data Echo'echo'results +type instance (R.ReprFor Echo'echo'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Echo'echo'results) where + typeId = 11184644773809847197 +instance (C.TypedStruct Echo'echo'results) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Echo'echo'results) where + type AllocHint Echo'echo'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Echo'echo'results (C.Parsed Echo'echo'results)) +instance (C.AllocateList Echo'echo'results) where + type ListAllocHint Echo'echo'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Echo'echo'results (C.Parsed Echo'echo'results)) +data instance C.Parsed Echo'echo'results + = Echo'echo'results + {out :: (RP.Parsed Basics.Text)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Echo'echo'results)) +deriving instance (Std_.Eq (C.Parsed Echo'echo'results)) +instance (C.Parse Echo'echo'results (C.Parsed Echo'echo'results)) where + parse raw_ = (Echo'echo'results <$> (GH.parseField #out raw_)) +instance (C.Marshal Echo'echo'results (C.Parsed Echo'echo'results)) where + marshalInto raw_ Echo'echo'results{..} = (do + (GH.encodeField #out out raw_) + (Std_.pure ()) + ) +instance (GH.HasField "out" GH.Slot Echo'echo'results Basics.Text) where + fieldByLabel = (GH.ptrField 0) +data Hoth +type instance (R.ReprFor Hoth) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Hoth) where + typeId = 12504202882178935737 +instance (C.TypedStruct Hoth) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate Hoth) where + type AllocHint Hoth = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Hoth (C.Parsed Hoth)) +instance (C.AllocateList Hoth) where + type ListAllocHint Hoth = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Hoth (C.Parsed Hoth)) +data instance C.Parsed Hoth + = Hoth + {base :: (RP.Parsed EchoBase)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Hoth)) +deriving instance (Std_.Eq (C.Parsed Hoth)) +instance (C.Parse Hoth (C.Parsed Hoth)) where + parse raw_ = (Hoth <$> (GH.parseField #base raw_)) +instance (C.Marshal Hoth (C.Parsed Hoth)) where + marshalInto raw_ Hoth{..} = (do + (GH.encodeField #base base raw_) + (Std_.pure ()) + ) +instance (GH.HasField "base" GH.Slot Hoth EchoBase) where + fieldByLabel = (GH.ptrField 0) +data EchoBase +type instance (R.ReprFor EchoBase) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId EchoBase) where + typeId = 12159459504633104486 +instance (C.TypedStruct EchoBase) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate EchoBase) where + type AllocHint EchoBase = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc EchoBase (C.Parsed EchoBase)) +instance (C.AllocateList EchoBase) where + type ListAllocHint EchoBase = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc EchoBase (C.Parsed EchoBase)) +data instance C.Parsed EchoBase + = EchoBase + {echo :: (RP.Parsed Echo)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed EchoBase)) +deriving instance (Std_.Eq (C.Parsed EchoBase)) +instance (C.Parse EchoBase (C.Parsed EchoBase)) where + parse raw_ = (EchoBase <$> (GH.parseField #echo raw_)) +instance (C.Marshal EchoBase (C.Parsed EchoBase)) where + marshalInto raw_ EchoBase{..} = (do + (GH.encodeField #echo echo raw_) + (Std_.pure ()) + ) +instance (GH.HasField "echo" GH.Slot EchoBase Echo) where + fieldByLabel = (GH.ptrField 0) +data EchoBases +type instance (R.ReprFor EchoBases) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId EchoBases) where + typeId = 13848178635387355324 +instance (C.TypedStruct EchoBases) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate EchoBases) where + type AllocHint EchoBases = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc EchoBases (C.Parsed EchoBases)) +instance (C.AllocateList EchoBases) where + type ListAllocHint EchoBases = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc EchoBases (C.Parsed EchoBases)) +data instance C.Parsed EchoBases + = EchoBases + {bases :: (RP.Parsed (R.List EchoBase))} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed EchoBases)) +deriving instance (Std_.Eq (C.Parsed EchoBases)) +instance (C.Parse EchoBases (C.Parsed EchoBases)) where + parse raw_ = (EchoBases <$> (GH.parseField #bases raw_)) +instance (C.Marshal EchoBases (C.Parsed EchoBases)) where + marshalInto raw_ EchoBases{..} = (do + (GH.encodeField #bases bases raw_) + (Std_.pure ()) + ) +instance (GH.HasField "bases" GH.Slot EchoBases (R.List EchoBase)) where + fieldByLabel = (GH.ptrField 0) +data StackingRoot +type instance (R.ReprFor StackingRoot) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StackingRoot) where + typeId = 10353348115798411408 +instance (C.TypedStruct StackingRoot) where + numStructWords = 0 + numStructPtrs = 2 +instance (C.Allocate StackingRoot) where + type AllocHint StackingRoot = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc StackingRoot (C.Parsed StackingRoot)) +instance (C.AllocateList StackingRoot) where + type ListAllocHint StackingRoot = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc StackingRoot (C.Parsed StackingRoot)) +data instance C.Parsed StackingRoot + = StackingRoot + {aWithDefault :: (RP.Parsed StackingA) + ,a :: (RP.Parsed StackingA)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed StackingRoot)) +deriving instance (Std_.Eq (C.Parsed StackingRoot)) +instance (C.Parse StackingRoot (C.Parsed StackingRoot)) where + parse raw_ = (StackingRoot <$> (GH.parseField #aWithDefault raw_) + <*> (GH.parseField #a raw_)) +instance (C.Marshal StackingRoot (C.Parsed StackingRoot)) where + marshalInto raw_ StackingRoot{..} = (do + (GH.encodeField #aWithDefault aWithDefault raw_) + (GH.encodeField #a a raw_) + (Std_.pure ()) + ) +instance (GH.HasField "aWithDefault" GH.Slot StackingRoot StackingA) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "a" GH.Slot StackingRoot StackingA) where + fieldByLabel = (GH.ptrField 1) +data StackingA +type instance (R.ReprFor StackingA) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StackingA) where + typeId = 11326609135883271029 +instance (C.TypedStruct StackingA) where + numStructWords = 1 + numStructPtrs = 1 +instance (C.Allocate StackingA) where + type AllocHint StackingA = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc StackingA (C.Parsed StackingA)) +instance (C.AllocateList StackingA) where + type ListAllocHint StackingA = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc StackingA (C.Parsed StackingA)) +data instance C.Parsed StackingA + = StackingA + {num :: (RP.Parsed Std_.Int32) + ,b :: (RP.Parsed StackingB)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed StackingA)) +deriving instance (Std_.Eq (C.Parsed StackingA)) +instance (C.Parse StackingA (C.Parsed StackingA)) where + parse raw_ = (StackingA <$> (GH.parseField #num raw_) + <*> (GH.parseField #b raw_)) +instance (C.Marshal StackingA (C.Parsed StackingA)) where + marshalInto raw_ StackingA{..} = (do + (GH.encodeField #num num raw_) + (GH.encodeField #b b raw_) + (Std_.pure ()) + ) +instance (GH.HasField "num" GH.Slot StackingA Std_.Int32) where + fieldByLabel = (GH.dataField 0 0 32 0) +instance (GH.HasField "b" GH.Slot StackingA StackingB) where + fieldByLabel = (GH.ptrField 0) +data StackingB +type instance (R.ReprFor StackingB) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StackingB) where + typeId = 9594210030877276357 +instance (C.TypedStruct StackingB) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate StackingB) where + type AllocHint StackingB = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc StackingB (C.Parsed StackingB)) +instance (C.AllocateList StackingB) where + type ListAllocHint StackingB = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc StackingB (C.Parsed StackingB)) +data instance C.Parsed StackingB + = StackingB + {num :: (RP.Parsed Std_.Int32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed StackingB)) +deriving instance (Std_.Eq (C.Parsed StackingB)) +instance (C.Parse StackingB (C.Parsed StackingB)) where + parse raw_ = (StackingB <$> (GH.parseField #num raw_)) +instance (C.Marshal StackingB (C.Parsed StackingB)) where + marshalInto raw_ StackingB{..} = (do + (GH.encodeField #num num raw_) + (Std_.pure ()) + ) +instance (GH.HasField "num" GH.Slot StackingB Std_.Int32) where + fieldByLabel = (GH.dataField 0 0 32 0) +data CallSequence +type instance (R.ReprFor CallSequence) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId CallSequence) where + typeId = 12371070827563042848 +instance (C.Parse CallSequence (GH.Client CallSequence)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export CallSequence) where + type Server CallSequence = CallSequence'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CallSequence)) [(GH.toUntypedMethodHandler ((callSequence'getNumber) s_))] []) +class (CallSequence'server_ s_) where + {-# MINIMAL callSequence'getNumber #-} + callSequence'getNumber :: s_ -> (GH.MethodHandler CallSequence'getNumber'params CallSequence'getNumber'results) + callSequence'getNumber _ = GH.methodUnimplemented +instance (GH.HasMethod "getNumber" CallSequence CallSequence'getNumber'params CallSequence'getNumber'results) where + methodByLabel = (GH.Method 12371070827563042848 0) +data CallSequence'getNumber'params +type instance (R.ReprFor CallSequence'getNumber'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CallSequence'getNumber'params) where + typeId = 17692253647948355992 +instance (C.TypedStruct CallSequence'getNumber'params) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate CallSequence'getNumber'params) where + type AllocHint CallSequence'getNumber'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) +instance (C.AllocateList CallSequence'getNumber'params) where + type ListAllocHint CallSequence'getNumber'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) +data instance C.Parsed CallSequence'getNumber'params + = CallSequence'getNumber'params + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CallSequence'getNumber'params)) +deriving instance (Std_.Eq (C.Parsed CallSequence'getNumber'params)) +instance (C.Parse CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) where + parse raw_ = (Std_.pure CallSequence'getNumber'params) +instance (C.Marshal CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) where + marshalInto _raw (CallSequence'getNumber'params) = (Std_.pure ()) +data CallSequence'getNumber'results +type instance (R.ReprFor CallSequence'getNumber'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CallSequence'getNumber'results) where + typeId = 11846148517662891671 +instance (C.TypedStruct CallSequence'getNumber'results) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate CallSequence'getNumber'results) where + type AllocHint CallSequence'getNumber'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) +instance (C.AllocateList CallSequence'getNumber'results) where + type ListAllocHint CallSequence'getNumber'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) +data instance C.Parsed CallSequence'getNumber'results + = CallSequence'getNumber'results + {n :: (RP.Parsed Std_.Word32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CallSequence'getNumber'results)) +deriving instance (Std_.Eq (C.Parsed CallSequence'getNumber'results)) +instance (C.Parse CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) where + parse raw_ = (CallSequence'getNumber'results <$> (GH.parseField #n raw_)) +instance (C.Marshal CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) where + marshalInto raw_ CallSequence'getNumber'results{..} = (do + (GH.encodeField #n n raw_) + (Std_.pure ()) + ) +instance (GH.HasField "n" GH.Slot CallSequence'getNumber'results Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +data CounterFactory +type instance (R.ReprFor CounterFactory) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId CounterFactory) where + typeId = 15610220054254702620 +instance (C.Parse CounterFactory (GH.Client CounterFactory)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export CounterFactory) where + type Server CounterFactory = CounterFactory'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CounterFactory)) [(GH.toUntypedMethodHandler ((counterFactory'newCounter) s_))] []) +class (CounterFactory'server_ s_) where + {-# MINIMAL counterFactory'newCounter #-} + counterFactory'newCounter :: s_ -> (GH.MethodHandler CounterFactory'newCounter'params CounterFactory'newCounter'results) + counterFactory'newCounter _ = GH.methodUnimplemented +instance (GH.HasMethod "newCounter" CounterFactory CounterFactory'newCounter'params CounterFactory'newCounter'results) where + methodByLabel = (GH.Method 15610220054254702620 0) +data CounterFactory'newCounter'params +type instance (R.ReprFor CounterFactory'newCounter'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterFactory'newCounter'params) where + typeId = 17606593106159030387 +instance (C.TypedStruct CounterFactory'newCounter'params) where + numStructWords = 1 + numStructPtrs = 0 +instance (C.Allocate CounterFactory'newCounter'params) where + type AllocHint CounterFactory'newCounter'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) +instance (C.AllocateList CounterFactory'newCounter'params) where + type ListAllocHint CounterFactory'newCounter'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) +data instance C.Parsed CounterFactory'newCounter'params + = CounterFactory'newCounter'params + {start :: (RP.Parsed Std_.Word32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CounterFactory'newCounter'params)) +deriving instance (Std_.Eq (C.Parsed CounterFactory'newCounter'params)) +instance (C.Parse CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) where + parse raw_ = (CounterFactory'newCounter'params <$> (GH.parseField #start raw_)) +instance (C.Marshal CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) where + marshalInto raw_ CounterFactory'newCounter'params{..} = (do + (GH.encodeField #start start raw_) + (Std_.pure ()) + ) +instance (GH.HasField "start" GH.Slot CounterFactory'newCounter'params Std_.Word32) where + fieldByLabel = (GH.dataField 0 0 32 0) +data CounterFactory'newCounter'results +type instance (R.ReprFor CounterFactory'newCounter'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterFactory'newCounter'results) where + typeId = 14063453475556553460 +instance (C.TypedStruct CounterFactory'newCounter'results) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate CounterFactory'newCounter'results) where + type AllocHint CounterFactory'newCounter'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) +instance (C.AllocateList CounterFactory'newCounter'results) where + type ListAllocHint CounterFactory'newCounter'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) +data instance C.Parsed CounterFactory'newCounter'results + = CounterFactory'newCounter'results + {counter :: (RP.Parsed CallSequence)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CounterFactory'newCounter'results)) +deriving instance (Std_.Eq (C.Parsed CounterFactory'newCounter'results)) +instance (C.Parse CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) where + parse raw_ = (CounterFactory'newCounter'results <$> (GH.parseField #counter raw_)) +instance (C.Marshal CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) where + marshalInto raw_ CounterFactory'newCounter'results{..} = (do + (GH.encodeField #counter counter raw_) + (Std_.pure ()) + ) +instance (GH.HasField "counter" GH.Slot CounterFactory'newCounter'results CallSequence) where + fieldByLabel = (GH.ptrField 0) +data CounterAcceptor +type instance (R.ReprFor CounterAcceptor) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId CounterAcceptor) where + typeId = 14317498215560924065 +instance (C.Parse CounterAcceptor (GH.Client CounterAcceptor)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export CounterAcceptor) where + type Server CounterAcceptor = CounterAcceptor'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CounterAcceptor)) [(GH.toUntypedMethodHandler ((counterAcceptor'accept) s_))] []) +class (CounterAcceptor'server_ s_) where + {-# MINIMAL counterAcceptor'accept #-} + counterAcceptor'accept :: s_ -> (GH.MethodHandler CounterAcceptor'accept'params CounterAcceptor'accept'results) + counterAcceptor'accept _ = GH.methodUnimplemented +instance (GH.HasMethod "accept" CounterAcceptor CounterAcceptor'accept'params CounterAcceptor'accept'results) where + methodByLabel = (GH.Method 14317498215560924065 0) +data CounterAcceptor'accept'params +type instance (R.ReprFor CounterAcceptor'accept'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterAcceptor'accept'params) where + typeId = 9397955985493553485 +instance (C.TypedStruct CounterAcceptor'accept'params) where + numStructWords = 0 + numStructPtrs = 1 +instance (C.Allocate CounterAcceptor'accept'params) where + type AllocHint CounterAcceptor'accept'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) +instance (C.AllocateList CounterAcceptor'accept'params) where + type ListAllocHint CounterAcceptor'accept'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) +data instance C.Parsed CounterAcceptor'accept'params + = CounterAcceptor'accept'params + {counter :: (RP.Parsed CallSequence)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CounterAcceptor'accept'params)) +deriving instance (Std_.Eq (C.Parsed CounterAcceptor'accept'params)) +instance (C.Parse CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) where + parse raw_ = (CounterAcceptor'accept'params <$> (GH.parseField #counter raw_)) +instance (C.Marshal CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) where + marshalInto raw_ CounterAcceptor'accept'params{..} = (do + (GH.encodeField #counter counter raw_) + (Std_.pure ()) + ) +instance (GH.HasField "counter" GH.Slot CounterAcceptor'accept'params CallSequence) where + fieldByLabel = (GH.ptrField 0) +data CounterAcceptor'accept'results +type instance (R.ReprFor CounterAcceptor'accept'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterAcceptor'accept'results) where + typeId = 12945664473818918456 +instance (C.TypedStruct CounterAcceptor'accept'results) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate CounterAcceptor'accept'results) where + type AllocHint CounterAcceptor'accept'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) +instance (C.AllocateList CounterAcceptor'accept'results) where + type ListAllocHint CounterAcceptor'accept'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) +data instance C.Parsed CounterAcceptor'accept'results + = CounterAcceptor'accept'results + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed CounterAcceptor'accept'results)) +deriving instance (Std_.Eq (C.Parsed CounterAcceptor'accept'results)) +instance (C.Parse CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) where + parse raw_ = (Std_.pure CounterAcceptor'accept'results) +instance (C.Marshal CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) where + marshalInto _raw (CounterAcceptor'accept'results) = (Std_.pure ()) +data Top +type instance (R.ReprFor Top) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Top) where + typeId = 17861645508359101525 +instance (C.Parse Top (GH.Client Top)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export Top) where + type Server Top = Top'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Top)) [(GH.toUntypedMethodHandler ((top'top) s_))] []) +class (Top'server_ s_) where + {-# MINIMAL top'top #-} + top'top :: s_ -> (GH.MethodHandler Top'top'params Top'top'results) + top'top _ = GH.methodUnimplemented +instance (GH.HasMethod "top" Top Top'top'params Top'top'results) where + methodByLabel = (GH.Method 17861645508359101525 0) +data Top'top'params +type instance (R.ReprFor Top'top'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Top'top'params) where + typeId = 9393200598485985531 +instance (C.TypedStruct Top'top'params) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Top'top'params) where + type AllocHint Top'top'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Top'top'params (C.Parsed Top'top'params)) +instance (C.AllocateList Top'top'params) where + type ListAllocHint Top'top'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Top'top'params (C.Parsed Top'top'params)) +data instance C.Parsed Top'top'params + = Top'top'params + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Top'top'params)) +deriving instance (Std_.Eq (C.Parsed Top'top'params)) +instance (C.Parse Top'top'params (C.Parsed Top'top'params)) where + parse raw_ = (Std_.pure Top'top'params) +instance (C.Marshal Top'top'params (C.Parsed Top'top'params)) where + marshalInto _raw (Top'top'params) = (Std_.pure ()) +data Top'top'results +type instance (R.ReprFor Top'top'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Top'top'results) where + typeId = 15495666596821516773 +instance (C.TypedStruct Top'top'results) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Top'top'results) where + type AllocHint Top'top'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Top'top'results (C.Parsed Top'top'results)) +instance (C.AllocateList Top'top'results) where + type ListAllocHint Top'top'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Top'top'results (C.Parsed Top'top'results)) +data instance C.Parsed Top'top'results + = Top'top'results + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Top'top'results)) +deriving instance (Std_.Eq (C.Parsed Top'top'results)) +instance (C.Parse Top'top'results (C.Parsed Top'top'results)) where + parse raw_ = (Std_.pure Top'top'results) +instance (C.Marshal Top'top'results (C.Parsed Top'top'results)) where + marshalInto _raw (Top'top'results) = (Std_.pure ()) +data Left +type instance (R.ReprFor Left) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Left) where + typeId = 17679152961798450446 +instance (C.Parse Left (GH.Client Left)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export Left) where + type Server Left = Left'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Left)) [(GH.toUntypedMethodHandler ((left'left) s_))] [(GH.methodHandlerTree (GH.Proxy @(Top)) s_)]) +class ((GH.Server Top s_)) => (Left'server_ s_) where + {-# MINIMAL left'left #-} + left'left :: s_ -> (GH.MethodHandler Left'left'params Left'left'results) + left'left _ = GH.methodUnimplemented +instance (C.Super Top Left) +instance (GH.HasMethod "left" Left Left'left'params Left'left'results) where + methodByLabel = (GH.Method 17679152961798450446 0) +data Left'left'params +type instance (R.ReprFor Left'left'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Left'left'params) where + typeId = 15491006379377963583 +instance (C.TypedStruct Left'left'params) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Left'left'params) where + type AllocHint Left'left'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Left'left'params (C.Parsed Left'left'params)) +instance (C.AllocateList Left'left'params) where + type ListAllocHint Left'left'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Left'left'params (C.Parsed Left'left'params)) +data instance C.Parsed Left'left'params + = Left'left'params + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Left'left'params)) +deriving instance (Std_.Eq (C.Parsed Left'left'params)) +instance (C.Parse Left'left'params (C.Parsed Left'left'params)) where + parse raw_ = (Std_.pure Left'left'params) +instance (C.Marshal Left'left'params (C.Parsed Left'left'params)) where + marshalInto _raw (Left'left'params) = (Std_.pure ()) +data Left'left'results +type instance (R.ReprFor Left'left'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Left'left'results) where + typeId = 14681384339713198083 +instance (C.TypedStruct Left'left'results) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Left'left'results) where + type AllocHint Left'left'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Left'left'results (C.Parsed Left'left'results)) +instance (C.AllocateList Left'left'results) where + type ListAllocHint Left'left'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Left'left'results (C.Parsed Left'left'results)) +data instance C.Parsed Left'left'results + = Left'left'results + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Left'left'results)) +deriving instance (Std_.Eq (C.Parsed Left'left'results)) +instance (C.Parse Left'left'results (C.Parsed Left'left'results)) where + parse raw_ = (Std_.pure Left'left'results) +instance (C.Marshal Left'left'results (C.Parsed Left'left'results)) where + marshalInto _raw (Left'left'results) = (Std_.pure ()) +data Right +type instance (R.ReprFor Right) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Right) where + typeId = 14712639595305348988 +instance (C.Parse Right (GH.Client Right)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export Right) where + type Server Right = Right'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Right)) [(GH.toUntypedMethodHandler ((right'right) s_))] [(GH.methodHandlerTree (GH.Proxy @(Top)) s_)]) +class ((GH.Server Top s_)) => (Right'server_ s_) where + {-# MINIMAL right'right #-} + right'right :: s_ -> (GH.MethodHandler Right'right'params Right'right'results) + right'right _ = GH.methodUnimplemented +instance (C.Super Top Right) +instance (GH.HasMethod "right" Right Right'right'params Right'right'results) where + methodByLabel = (GH.Method 14712639595305348988 0) +data Right'right'params +type instance (R.ReprFor Right'right'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Right'right'params) where + typeId = 17692925949004434588 +instance (C.TypedStruct Right'right'params) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Right'right'params) where + type AllocHint Right'right'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Right'right'params (C.Parsed Right'right'params)) +instance (C.AllocateList Right'right'params) where + type ListAllocHint Right'right'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Right'right'params (C.Parsed Right'right'params)) +data instance C.Parsed Right'right'params + = Right'right'params + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Right'right'params)) +deriving instance (Std_.Eq (C.Parsed Right'right'params)) +instance (C.Parse Right'right'params (C.Parsed Right'right'params)) where + parse raw_ = (Std_.pure Right'right'params) +instance (C.Marshal Right'right'params (C.Parsed Right'right'params)) where + marshalInto _raw (Right'right'params) = (Std_.pure ()) +data Right'right'results +type instance (R.ReprFor Right'right'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Right'right'results) where + typeId = 12438774687365689496 +instance (C.TypedStruct Right'right'results) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Right'right'results) where + type AllocHint Right'right'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Right'right'results (C.Parsed Right'right'results)) +instance (C.AllocateList Right'right'results) where + type ListAllocHint Right'right'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Right'right'results (C.Parsed Right'right'results)) +data instance C.Parsed Right'right'results + = Right'right'results + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Right'right'results)) +deriving instance (Std_.Eq (C.Parsed Right'right'results)) +instance (C.Parse Right'right'results (C.Parsed Right'right'results)) where + parse raw_ = (Std_.pure Right'right'results) +instance (C.Marshal Right'right'results (C.Parsed Right'right'results)) where + marshalInto _raw (Right'right'results) = (Std_.pure ()) +data Bottom +type instance (R.ReprFor Bottom) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Bottom) where + typeId = 18402872613340521775 +instance (C.Parse Bottom (GH.Client Bottom)) where + parse = GH.parseCap + encode = GH.encodeCap +instance (GH.Export Bottom) where + type Server Bottom = Bottom'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Bottom)) [(GH.toUntypedMethodHandler ((bottom'bottom) s_))] [(GH.methodHandlerTree (GH.Proxy @(Left)) s_) + ,(GH.methodHandlerTree (GH.Proxy @(Right)) s_)]) +class ((GH.Server Left s_) + ,(GH.Server Right s_)) => (Bottom'server_ s_) where + {-# MINIMAL bottom'bottom #-} + bottom'bottom :: s_ -> (GH.MethodHandler Bottom'bottom'params Bottom'bottom'results) + bottom'bottom _ = GH.methodUnimplemented +instance (C.Super Left Bottom) +instance (C.Super Right Bottom) +instance (GH.HasMethod "bottom" Bottom Bottom'bottom'params Bottom'bottom'results) where + methodByLabel = (GH.Method 18402872613340521775 0) +data Bottom'bottom'params +type instance (R.ReprFor Bottom'bottom'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bottom'bottom'params) where + typeId = 12919405706404437540 +instance (C.TypedStruct Bottom'bottom'params) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Bottom'bottom'params) where + type AllocHint Bottom'bottom'params = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Bottom'bottom'params (C.Parsed Bottom'bottom'params)) +instance (C.AllocateList Bottom'bottom'params) where + type ListAllocHint Bottom'bottom'params = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Bottom'bottom'params (C.Parsed Bottom'bottom'params)) +data instance C.Parsed Bottom'bottom'params + = Bottom'bottom'params + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Bottom'bottom'params)) +deriving instance (Std_.Eq (C.Parsed Bottom'bottom'params)) +instance (C.Parse Bottom'bottom'params (C.Parsed Bottom'bottom'params)) where + parse raw_ = (Std_.pure Bottom'bottom'params) +instance (C.Marshal Bottom'bottom'params (C.Parsed Bottom'bottom'params)) where + marshalInto _raw (Bottom'bottom'params) = (Std_.pure ()) +data Bottom'bottom'results +type instance (R.ReprFor Bottom'bottom'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bottom'bottom'results) where + typeId = 10197200620860118778 +instance (C.TypedStruct Bottom'bottom'results) where + numStructWords = 0 + numStructPtrs = 0 +instance (C.Allocate Bottom'bottom'results) where + type AllocHint Bottom'bottom'results = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Bottom'bottom'results (C.Parsed Bottom'bottom'results)) +instance (C.AllocateList Bottom'bottom'results) where + type ListAllocHint Bottom'bottom'results = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Bottom'bottom'results (C.Parsed Bottom'bottom'results)) +data instance C.Parsed Bottom'bottom'results + = Bottom'bottom'results + {} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Bottom'bottom'results)) +deriving instance (Std_.Eq (C.Parsed Bottom'bottom'results)) +instance (C.Parse Bottom'bottom'results (C.Parsed Bottom'bottom'results)) where + parse raw_ = (Std_.pure Bottom'bottom'results) +instance (C.Marshal Bottom'bottom'results (C.Parsed Bottom'bottom'results)) where + marshalInto _raw (Bottom'bottom'results) = (Std_.pure ()) +data Defaults +type instance (R.ReprFor Defaults) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Defaults) where + typeId = 10944742465095042957 +instance (C.TypedStruct Defaults) where + numStructWords = 2 + numStructPtrs = 2 +instance (C.Allocate Defaults) where + type AllocHint Defaults = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc Defaults (C.Parsed Defaults)) +instance (C.AllocateList Defaults) where + type ListAllocHint Defaults = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc Defaults (C.Parsed Defaults)) +data instance C.Parsed Defaults + = Defaults + {text :: (RP.Parsed Basics.Text) + ,data_ :: (RP.Parsed Basics.Data) + ,float :: (RP.Parsed Std_.Float) + ,int :: (RP.Parsed Std_.Int32) + ,uint :: (RP.Parsed Std_.Word32)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed Defaults)) +deriving instance (Std_.Eq (C.Parsed Defaults)) +instance (C.Parse Defaults (C.Parsed Defaults)) where + parse raw_ = (Defaults <$> (GH.parseField #text raw_) + <*> (GH.parseField #data_ raw_) + <*> (GH.parseField #float raw_) + <*> (GH.parseField #int raw_) + <*> (GH.parseField #uint raw_)) +instance (C.Marshal Defaults (C.Parsed Defaults)) where + marshalInto raw_ Defaults{..} = (do + (GH.encodeField #text text raw_) + (GH.encodeField #data_ data_ raw_) + (GH.encodeField #float float raw_) + (GH.encodeField #int int raw_) + (GH.encodeField #uint uint raw_) + (Std_.pure ()) + ) +instance (GH.HasField "text" GH.Slot Defaults Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "data_" GH.Slot Defaults Basics.Data) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "float" GH.Slot Defaults Std_.Float) where + fieldByLabel = (GH.dataField 0 0 32 1078523331) +instance (GH.HasField "int" GH.Slot Defaults Std_.Int32) where + fieldByLabel = (GH.dataField 32 0 32 18446744073709551493) +instance (GH.HasField "uint" GH.Slot Defaults Std_.Word32) where + fieldByLabel = (GH.dataField 0 1 32 42) +data BenchmarkA +type instance (R.ReprFor BenchmarkA) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId BenchmarkA) where + typeId = 16008637057130021148 +instance (C.TypedStruct BenchmarkA) where + numStructWords = 3 + numStructPtrs = 2 +instance (C.Allocate BenchmarkA) where + type AllocHint BenchmarkA = () + new _ = C.newTypedStruct +instance (C.EstimateAlloc BenchmarkA (C.Parsed BenchmarkA)) +instance (C.AllocateList BenchmarkA) where + type ListAllocHint BenchmarkA = Std_.Int + newList = C.newTypedStructList +instance (C.EstimateListAlloc BenchmarkA (C.Parsed BenchmarkA)) +data instance C.Parsed BenchmarkA + = BenchmarkA + {name :: (RP.Parsed Basics.Text) + ,birthDay :: (RP.Parsed Std_.Int64) + ,phone :: (RP.Parsed Basics.Text) + ,siblings :: (RP.Parsed Std_.Int32) + ,spouse :: (RP.Parsed Std_.Bool) + ,money :: (RP.Parsed Std_.Double)} + deriving(Generics.Generic) +deriving instance (Std_.Show (C.Parsed BenchmarkA)) +deriving instance (Std_.Eq (C.Parsed BenchmarkA)) +instance (C.Parse BenchmarkA (C.Parsed BenchmarkA)) where + parse raw_ = (BenchmarkA <$> (GH.parseField #name raw_) + <*> (GH.parseField #birthDay raw_) + <*> (GH.parseField #phone raw_) + <*> (GH.parseField #siblings raw_) + <*> (GH.parseField #spouse raw_) + <*> (GH.parseField #money raw_)) +instance (C.Marshal BenchmarkA (C.Parsed BenchmarkA)) where + marshalInto raw_ BenchmarkA{..} = (do + (GH.encodeField #name name raw_) + (GH.encodeField #birthDay birthDay raw_) + (GH.encodeField #phone phone raw_) + (GH.encodeField #siblings siblings raw_) + (GH.encodeField #spouse spouse raw_) + (GH.encodeField #money money raw_) + (Std_.pure ()) + ) +instance (GH.HasField "name" GH.Slot BenchmarkA Basics.Text) where + fieldByLabel = (GH.ptrField 0) +instance (GH.HasField "birthDay" GH.Slot BenchmarkA Std_.Int64) where + fieldByLabel = (GH.dataField 0 0 64 0) +instance (GH.HasField "phone" GH.Slot BenchmarkA Basics.Text) where + fieldByLabel = (GH.ptrField 1) +instance (GH.HasField "siblings" GH.Slot BenchmarkA Std_.Int32) where + fieldByLabel = (GH.dataField 0 1 32 0) +instance (GH.HasField "spouse" GH.Slot BenchmarkA Std_.Bool) where + fieldByLabel = (GH.dataField 32 1 1 0) +instance (GH.HasField "money" GH.Slot BenchmarkA Std_.Double) where + fieldByLabel = (GH.dataField 0 2 64 0) diff --git a/gen/tests/Capnp/Gen/Aircraft/New.hs b/gen/tests/Capnp/Gen/Aircraft/New.hs deleted file mode 100644 --- a/gen/tests/Capnp/Gen/Aircraft/New.hs +++ /dev/null @@ -1,2750 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Aircraft.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Capnp.GenHelpers.New.Rpc as GH -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -constDate :: (R.Raw Zdate GH.Const) -constDate = (GH.getPtrConst ("\NUL\NUL\NUL\NUL\ETX\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\NUL\NUL\SOH\NUL\NUL\NUL\223\a\b\ESC\NUL\NUL\NUL\NUL" :: GH.ByteString)) -constList :: (R.Raw (R.List Zdate) GH.Const) -constList = (GH.getPtrConst ("\NUL\NUL\NUL\NUL\ENQ\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL\SOH\NUL\NUL\NUL\ETB\NUL\NUL\NUL\b\NUL\NUL\NUL\SOH\NUL\NUL\NUL\223\a\b\ESC\NUL\NUL\NUL\NUL\223\a\b\FS\NUL\NUL\NUL\NUL" :: GH.ByteString)) -constEnum :: Airport -constEnum = (C.fromWord 1) -data Zdate -type instance (R.ReprFor Zdate) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Zdate) where - typeId = 16019495995647153309 -instance (C.TypedStruct Zdate) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate Zdate) where - type AllocHint Zdate = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Zdate (C.Parsed Zdate)) -instance (C.AllocateList Zdate) where - type ListAllocHint Zdate = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Zdate (C.Parsed Zdate)) -data instance C.Parsed Zdate - = Zdate - {year :: (RP.Parsed Std_.Int16) - ,month :: (RP.Parsed Std_.Word8) - ,day :: (RP.Parsed Std_.Word8)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Zdate)) -deriving instance (Std_.Eq (C.Parsed Zdate)) -instance (C.Parse Zdate (C.Parsed Zdate)) where - parse raw_ = (Zdate <$> (GH.parseField #year raw_) - <*> (GH.parseField #month raw_) - <*> (GH.parseField #day raw_)) -instance (C.Marshal Zdate (C.Parsed Zdate)) where - marshalInto raw_ Zdate{..} = (do - (GH.encodeField #year year raw_) - (GH.encodeField #month month raw_) - (GH.encodeField #day day raw_) - (Std_.pure ()) - ) -instance (GH.HasField "year" GH.Slot Zdate Std_.Int16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "month" GH.Slot Zdate Std_.Word8) where - fieldByLabel = (GH.dataField 16 0 8 0) -instance (GH.HasField "day" GH.Slot Zdate Std_.Word8) where - fieldByLabel = (GH.dataField 24 0 8 0) -data Zdata -type instance (R.ReprFor Zdata) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Zdata) where - typeId = 14400934881325616034 -instance (C.TypedStruct Zdata) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Zdata) where - type AllocHint Zdata = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Zdata (C.Parsed Zdata)) -instance (C.AllocateList Zdata) where - type ListAllocHint Zdata = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Zdata (C.Parsed Zdata)) -data instance C.Parsed Zdata - = Zdata - {data_ :: (RP.Parsed Basics.Data)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Zdata)) -deriving instance (Std_.Eq (C.Parsed Zdata)) -instance (C.Parse Zdata (C.Parsed Zdata)) where - parse raw_ = (Zdata <$> (GH.parseField #data_ raw_)) -instance (C.Marshal Zdata (C.Parsed Zdata)) where - marshalInto raw_ Zdata{..} = (do - (GH.encodeField #data_ data_ raw_) - (Std_.pure ()) - ) -instance (GH.HasField "data_" GH.Slot Zdata Basics.Data) where - fieldByLabel = (GH.ptrField 0) -data Airport - = Airport'none - | Airport'jfk - | Airport'lax - | Airport'sfo - | Airport'luv - | Airport'dfw - | Airport'test - | Airport'unknown' Std_.Word16 - deriving(Std_.Eq - ,Std_.Show - ,Generics.Generic) -type instance (R.ReprFor Airport) = (R.Data R.Sz16) -instance (C.HasTypeId Airport) where - typeId = 16527513525367090977 -instance (Std_.Enum Airport) where - toEnum n_ = case n_ of - 0 -> - Airport'none - 1 -> - Airport'jfk - 2 -> - Airport'lax - 3 -> - Airport'sfo - 4 -> - Airport'luv - 5 -> - Airport'dfw - 6 -> - Airport'test - tag_ -> - (Airport'unknown' (Std_.fromIntegral tag_)) - fromEnum value_ = case value_ of - (Airport'none) -> - 0 - (Airport'jfk) -> - 1 - (Airport'lax) -> - 2 - (Airport'sfo) -> - 3 - (Airport'luv) -> - 4 - (Airport'dfw) -> - 5 - (Airport'test) -> - 6 - (Airport'unknown' tag_) -> - (Std_.fromIntegral tag_) -instance (C.IsWord Airport) where - fromWord w_ = (Std_.toEnum (Std_.fromIntegral w_)) - toWord v_ = (Std_.fromIntegral (Std_.fromEnum v_)) -instance (C.Parse Airport Airport) where - parse = GH.parseEnum - encode = GH.encodeEnum -instance (C.AllocateList Airport) where - type ListAllocHint Airport = Std_.Int -instance (C.EstimateListAlloc Airport Airport) -data PlaneBase -type instance (R.ReprFor PlaneBase) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId PlaneBase) where - typeId = 15617585680788961169 -instance (C.TypedStruct PlaneBase) where - numStructWords = 4 - numStructPtrs = 2 -instance (C.Allocate PlaneBase) where - type AllocHint PlaneBase = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc PlaneBase (C.Parsed PlaneBase)) -instance (C.AllocateList PlaneBase) where - type ListAllocHint PlaneBase = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc PlaneBase (C.Parsed PlaneBase)) -data instance C.Parsed PlaneBase - = PlaneBase - {name :: (RP.Parsed Basics.Text) - ,homes :: (RP.Parsed (R.List Airport)) - ,rating :: (RP.Parsed Std_.Int64) - ,canFly :: (RP.Parsed Std_.Bool) - ,capacity :: (RP.Parsed Std_.Int64) - ,maxSpeed :: (RP.Parsed Std_.Double)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed PlaneBase)) -deriving instance (Std_.Eq (C.Parsed PlaneBase)) -instance (C.Parse PlaneBase (C.Parsed PlaneBase)) where - parse raw_ = (PlaneBase <$> (GH.parseField #name raw_) - <*> (GH.parseField #homes raw_) - <*> (GH.parseField #rating raw_) - <*> (GH.parseField #canFly raw_) - <*> (GH.parseField #capacity raw_) - <*> (GH.parseField #maxSpeed raw_)) -instance (C.Marshal PlaneBase (C.Parsed PlaneBase)) where - marshalInto raw_ PlaneBase{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #homes homes raw_) - (GH.encodeField #rating rating raw_) - (GH.encodeField #canFly canFly raw_) - (GH.encodeField #capacity capacity raw_) - (GH.encodeField #maxSpeed maxSpeed raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot PlaneBase Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "homes" GH.Slot PlaneBase (R.List Airport)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "rating" GH.Slot PlaneBase Std_.Int64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "canFly" GH.Slot PlaneBase Std_.Bool) where - fieldByLabel = (GH.dataField 0 1 1 0) -instance (GH.HasField "capacity" GH.Slot PlaneBase Std_.Int64) where - fieldByLabel = (GH.dataField 0 2 64 0) -instance (GH.HasField "maxSpeed" GH.Slot PlaneBase Std_.Double) where - fieldByLabel = (GH.dataField 0 3 64 0) -data B737 -type instance (R.ReprFor B737) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId B737) where - typeId = 14750329894210119392 -instance (C.TypedStruct B737) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate B737) where - type AllocHint B737 = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc B737 (C.Parsed B737)) -instance (C.AllocateList B737) where - type ListAllocHint B737 = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc B737 (C.Parsed B737)) -data instance C.Parsed B737 - = B737 - {base :: (RP.Parsed PlaneBase)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed B737)) -deriving instance (Std_.Eq (C.Parsed B737)) -instance (C.Parse B737 (C.Parsed B737)) where - parse raw_ = (B737 <$> (GH.parseField #base raw_)) -instance (C.Marshal B737 (C.Parsed B737)) where - marshalInto raw_ B737{..} = (do - (GH.encodeField #base base raw_) - (Std_.pure ()) - ) -instance (GH.HasField "base" GH.Slot B737 PlaneBase) where - fieldByLabel = (GH.ptrField 0) -data A320 -type instance (R.ReprFor A320) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId A320) where - typeId = 15676010542212434829 -instance (C.TypedStruct A320) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate A320) where - type AllocHint A320 = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc A320 (C.Parsed A320)) -instance (C.AllocateList A320) where - type ListAllocHint A320 = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc A320 (C.Parsed A320)) -data instance C.Parsed A320 - = A320 - {base :: (RP.Parsed PlaneBase)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed A320)) -deriving instance (Std_.Eq (C.Parsed A320)) -instance (C.Parse A320 (C.Parsed A320)) where - parse raw_ = (A320 <$> (GH.parseField #base raw_)) -instance (C.Marshal A320 (C.Parsed A320)) where - marshalInto raw_ A320{..} = (do - (GH.encodeField #base base raw_) - (Std_.pure ()) - ) -instance (GH.HasField "base" GH.Slot A320 PlaneBase) where - fieldByLabel = (GH.ptrField 0) -data F16 -type instance (R.ReprFor F16) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId F16) where - typeId = 16269793260987437921 -instance (C.TypedStruct F16) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate F16) where - type AllocHint F16 = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc F16 (C.Parsed F16)) -instance (C.AllocateList F16) where - type ListAllocHint F16 = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc F16 (C.Parsed F16)) -data instance C.Parsed F16 - = F16 - {base :: (RP.Parsed PlaneBase)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed F16)) -deriving instance (Std_.Eq (C.Parsed F16)) -instance (C.Parse F16 (C.Parsed F16)) where - parse raw_ = (F16 <$> (GH.parseField #base raw_)) -instance (C.Marshal F16 (C.Parsed F16)) where - marshalInto raw_ F16{..} = (do - (GH.encodeField #base base raw_) - (Std_.pure ()) - ) -instance (GH.HasField "base" GH.Slot F16 PlaneBase) where - fieldByLabel = (GH.ptrField 0) -data Regression -type instance (R.ReprFor Regression) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Regression) where - typeId = 12821810113427682943 -instance (C.TypedStruct Regression) where - numStructWords = 3 - numStructPtrs = 3 -instance (C.Allocate Regression) where - type AllocHint Regression = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Regression (C.Parsed Regression)) -instance (C.AllocateList Regression) where - type ListAllocHint Regression = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Regression (C.Parsed Regression)) -data instance C.Parsed Regression - = Regression - {base :: (RP.Parsed PlaneBase) - ,b0 :: (RP.Parsed Std_.Double) - ,beta :: (RP.Parsed (R.List Std_.Double)) - ,planes :: (RP.Parsed (R.List Aircraft)) - ,ymu :: (RP.Parsed Std_.Double) - ,ysd :: (RP.Parsed Std_.Double)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Regression)) -deriving instance (Std_.Eq (C.Parsed Regression)) -instance (C.Parse Regression (C.Parsed Regression)) where - parse raw_ = (Regression <$> (GH.parseField #base raw_) - <*> (GH.parseField #b0 raw_) - <*> (GH.parseField #beta raw_) - <*> (GH.parseField #planes raw_) - <*> (GH.parseField #ymu raw_) - <*> (GH.parseField #ysd raw_)) -instance (C.Marshal Regression (C.Parsed Regression)) where - marshalInto raw_ Regression{..} = (do - (GH.encodeField #base base raw_) - (GH.encodeField #b0 b0 raw_) - (GH.encodeField #beta beta raw_) - (GH.encodeField #planes planes raw_) - (GH.encodeField #ymu ymu raw_) - (GH.encodeField #ysd ysd raw_) - (Std_.pure ()) - ) -instance (GH.HasField "base" GH.Slot Regression PlaneBase) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "b0" GH.Slot Regression Std_.Double) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "beta" GH.Slot Regression (R.List Std_.Double)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "planes" GH.Slot Regression (R.List Aircraft)) where - fieldByLabel = (GH.ptrField 2) -instance (GH.HasField "ymu" GH.Slot Regression Std_.Double) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "ysd" GH.Slot Regression Std_.Double) where - fieldByLabel = (GH.dataField 0 2 64 0) -data Aircraft -type instance (R.ReprFor Aircraft) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Aircraft) where - typeId = 16523162426109446065 -instance (C.TypedStruct Aircraft) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate Aircraft) where - type AllocHint Aircraft = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Aircraft (C.Parsed Aircraft)) -instance (C.AllocateList Aircraft) where - type ListAllocHint Aircraft = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Aircraft (C.Parsed Aircraft)) -data instance C.Parsed Aircraft - = Aircraft - {union' :: (C.Parsed (GH.Which Aircraft))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Aircraft)) -deriving instance (Std_.Eq (C.Parsed Aircraft)) -instance (C.Parse Aircraft (C.Parsed Aircraft)) where - parse raw_ = (Aircraft <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Aircraft (C.Parsed Aircraft)) where - marshalInto raw_ Aircraft{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Aircraft) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Aircraft mut_ - = RW_Aircraft'void (R.Raw () mut_) - | RW_Aircraft'b737 (R.Raw B737 mut_) - | RW_Aircraft'a320 (R.Raw A320 mut_) - | RW_Aircraft'f16 (R.Raw F16 mut_) - | RW_Aircraft'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Aircraft'void <$> (GH.readVariant #void struct_)) - 1 -> - (RW_Aircraft'b737 <$> (GH.readVariant #b737 struct_)) - 2 -> - (RW_Aircraft'a320 <$> (GH.readVariant #a320 struct_)) - 3 -> - (RW_Aircraft'f16 <$> (GH.readVariant #f16 struct_)) - _ -> - (Std_.pure (RW_Aircraft'unknown' tag_)) - data Which Aircraft -instance (GH.HasVariant "void" GH.Slot Aircraft ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "b737" GH.Slot Aircraft B737) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -instance (GH.HasVariant "a320" GH.Slot Aircraft A320) where - variantByLabel = (GH.Variant (GH.ptrField 0) 2) -instance (GH.HasVariant "f16" GH.Slot Aircraft F16) where - variantByLabel = (GH.Variant (GH.ptrField 0) 3) -data instance C.Parsed (GH.Which Aircraft) - = Aircraft'void - | Aircraft'b737 (RP.Parsed B737) - | Aircraft'a320 (RP.Parsed A320) - | Aircraft'f16 (RP.Parsed F16) - | Aircraft'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Aircraft))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Aircraft))) -instance (C.Parse (GH.Which Aircraft) (C.Parsed (GH.Which Aircraft))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Aircraft'void _) -> - (Std_.pure Aircraft'void) - (RW_Aircraft'b737 rawArg_) -> - (Aircraft'b737 <$> (C.parse rawArg_)) - (RW_Aircraft'a320 rawArg_) -> - (Aircraft'a320 <$> (C.parse rawArg_)) - (RW_Aircraft'f16 rawArg_) -> - (Aircraft'f16 <$> (C.parse rawArg_)) - (RW_Aircraft'unknown' tag_) -> - (Std_.pure (Aircraft'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Aircraft) (C.Parsed (GH.Which Aircraft))) where - marshalInto raw_ parsed_ = case parsed_ of - (Aircraft'void) -> - (GH.encodeVariant #void () (GH.unionStruct raw_)) - (Aircraft'b737 arg_) -> - (GH.encodeVariant #b737 arg_ (GH.unionStruct raw_)) - (Aircraft'a320 arg_) -> - (GH.encodeVariant #a320 arg_ (GH.unionStruct raw_)) - (Aircraft'f16 arg_) -> - (GH.encodeVariant #f16 arg_ (GH.unionStruct raw_)) - (Aircraft'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Z -type instance (R.ReprFor Z) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Z) where - typeId = 16872429889743397081 -instance (C.TypedStruct Z) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Z) where - type AllocHint Z = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Z (C.Parsed Z)) -instance (C.AllocateList Z) where - type ListAllocHint Z = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Z (C.Parsed Z)) -data instance C.Parsed Z - = Z - {union' :: (C.Parsed (GH.Which Z))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Z)) -deriving instance (Std_.Eq (C.Parsed Z)) -instance (C.Parse Z (C.Parsed Z)) where - parse raw_ = (Z <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal Z (C.Parsed Z)) where - marshalInto raw_ Z{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion Z) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich Z mut_ - = RW_Z'void (R.Raw () mut_) - | RW_Z'zz (R.Raw Z mut_) - | RW_Z'f64 (R.Raw Std_.Double mut_) - | RW_Z'f32 (R.Raw Std_.Float mut_) - | RW_Z'i64 (R.Raw Std_.Int64 mut_) - | RW_Z'i32 (R.Raw Std_.Int32 mut_) - | RW_Z'i16 (R.Raw Std_.Int16 mut_) - | RW_Z'i8 (R.Raw Std_.Int8 mut_) - | RW_Z'u64 (R.Raw Std_.Word64 mut_) - | RW_Z'u32 (R.Raw Std_.Word32 mut_) - | RW_Z'u16 (R.Raw Std_.Word16 mut_) - | RW_Z'u8 (R.Raw Std_.Word8 mut_) - | RW_Z'bool (R.Raw Std_.Bool mut_) - | RW_Z'text (R.Raw Basics.Text mut_) - | RW_Z'blob (R.Raw Basics.Data mut_) - | RW_Z'f64vec (R.Raw (R.List Std_.Double) mut_) - | RW_Z'f32vec (R.Raw (R.List Std_.Float) mut_) - | RW_Z'i64vec (R.Raw (R.List Std_.Int64) mut_) - | RW_Z'i32vec (R.Raw (R.List Std_.Int32) mut_) - | RW_Z'i16vec (R.Raw (R.List Std_.Int16) mut_) - | RW_Z'i8vec (R.Raw (R.List Std_.Int8) mut_) - | RW_Z'u64vec (R.Raw (R.List Std_.Word64) mut_) - | RW_Z'u32vec (R.Raw (R.List Std_.Word32) mut_) - | RW_Z'u16vec (R.Raw (R.List Std_.Word16) mut_) - | RW_Z'u8vec (R.Raw (R.List Std_.Word8) mut_) - | RW_Z'zvec (R.Raw (R.List Z) mut_) - | RW_Z'zvecvec (R.Raw (R.List (R.List Z)) mut_) - | RW_Z'zdate (R.Raw Zdate mut_) - | RW_Z'zdata (R.Raw Zdata mut_) - | RW_Z'aircraftvec (R.Raw (R.List Aircraft) mut_) - | RW_Z'aircraft (R.Raw Aircraft mut_) - | RW_Z'regression (R.Raw Regression mut_) - | RW_Z'planebase (R.Raw PlaneBase mut_) - | RW_Z'airport (R.Raw Airport mut_) - | RW_Z'b737 (R.Raw B737 mut_) - | RW_Z'a320 (R.Raw A320 mut_) - | RW_Z'f16 (R.Raw F16 mut_) - | RW_Z'zdatevec (R.Raw (R.List Zdate) mut_) - | RW_Z'zdatavec (R.Raw (R.List Zdata) mut_) - | RW_Z'boolvec (R.Raw (R.List Std_.Bool) mut_) - | RW_Z'datavec (R.Raw (R.List Basics.Data) mut_) - | RW_Z'textvec (R.Raw (R.List Basics.Text) mut_) - | RW_Z'grp (R.Raw Z'grp mut_) - | RW_Z'echo (R.Raw Echo mut_) - | RW_Z'echoBases (R.Raw EchoBases mut_) - | RW_Z'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Z'void <$> (GH.readVariant #void struct_)) - 1 -> - (RW_Z'zz <$> (GH.readVariant #zz struct_)) - 2 -> - (RW_Z'f64 <$> (GH.readVariant #f64 struct_)) - 3 -> - (RW_Z'f32 <$> (GH.readVariant #f32 struct_)) - 4 -> - (RW_Z'i64 <$> (GH.readVariant #i64 struct_)) - 5 -> - (RW_Z'i32 <$> (GH.readVariant #i32 struct_)) - 6 -> - (RW_Z'i16 <$> (GH.readVariant #i16 struct_)) - 7 -> - (RW_Z'i8 <$> (GH.readVariant #i8 struct_)) - 8 -> - (RW_Z'u64 <$> (GH.readVariant #u64 struct_)) - 9 -> - (RW_Z'u32 <$> (GH.readVariant #u32 struct_)) - 10 -> - (RW_Z'u16 <$> (GH.readVariant #u16 struct_)) - 11 -> - (RW_Z'u8 <$> (GH.readVariant #u8 struct_)) - 12 -> - (RW_Z'bool <$> (GH.readVariant #bool struct_)) - 13 -> - (RW_Z'text <$> (GH.readVariant #text struct_)) - 14 -> - (RW_Z'blob <$> (GH.readVariant #blob struct_)) - 15 -> - (RW_Z'f64vec <$> (GH.readVariant #f64vec struct_)) - 16 -> - (RW_Z'f32vec <$> (GH.readVariant #f32vec struct_)) - 17 -> - (RW_Z'i64vec <$> (GH.readVariant #i64vec struct_)) - 18 -> - (RW_Z'i32vec <$> (GH.readVariant #i32vec struct_)) - 19 -> - (RW_Z'i16vec <$> (GH.readVariant #i16vec struct_)) - 20 -> - (RW_Z'i8vec <$> (GH.readVariant #i8vec struct_)) - 21 -> - (RW_Z'u64vec <$> (GH.readVariant #u64vec struct_)) - 22 -> - (RW_Z'u32vec <$> (GH.readVariant #u32vec struct_)) - 23 -> - (RW_Z'u16vec <$> (GH.readVariant #u16vec struct_)) - 24 -> - (RW_Z'u8vec <$> (GH.readVariant #u8vec struct_)) - 25 -> - (RW_Z'zvec <$> (GH.readVariant #zvec struct_)) - 26 -> - (RW_Z'zvecvec <$> (GH.readVariant #zvecvec struct_)) - 27 -> - (RW_Z'zdate <$> (GH.readVariant #zdate struct_)) - 28 -> - (RW_Z'zdata <$> (GH.readVariant #zdata struct_)) - 29 -> - (RW_Z'aircraftvec <$> (GH.readVariant #aircraftvec struct_)) - 30 -> - (RW_Z'aircraft <$> (GH.readVariant #aircraft struct_)) - 31 -> - (RW_Z'regression <$> (GH.readVariant #regression struct_)) - 32 -> - (RW_Z'planebase <$> (GH.readVariant #planebase struct_)) - 33 -> - (RW_Z'airport <$> (GH.readVariant #airport struct_)) - 34 -> - (RW_Z'b737 <$> (GH.readVariant #b737 struct_)) - 35 -> - (RW_Z'a320 <$> (GH.readVariant #a320 struct_)) - 36 -> - (RW_Z'f16 <$> (GH.readVariant #f16 struct_)) - 37 -> - (RW_Z'zdatevec <$> (GH.readVariant #zdatevec struct_)) - 38 -> - (RW_Z'zdatavec <$> (GH.readVariant #zdatavec struct_)) - 39 -> - (RW_Z'boolvec <$> (GH.readVariant #boolvec struct_)) - 40 -> - (RW_Z'datavec <$> (GH.readVariant #datavec struct_)) - 41 -> - (RW_Z'textvec <$> (GH.readVariant #textvec struct_)) - 42 -> - (RW_Z'grp <$> (GH.readVariant #grp struct_)) - 43 -> - (RW_Z'echo <$> (GH.readVariant #echo struct_)) - 44 -> - (RW_Z'echoBases <$> (GH.readVariant #echoBases struct_)) - _ -> - (Std_.pure (RW_Z'unknown' tag_)) - data Which Z -instance (GH.HasVariant "void" GH.Slot Z ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "zz" GH.Slot Z Z) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -instance (GH.HasVariant "f64" GH.Slot Z Std_.Double) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 2) -instance (GH.HasVariant "f32" GH.Slot Z Std_.Float) where - variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 3) -instance (GH.HasVariant "i64" GH.Slot Z Std_.Int64) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 4) -instance (GH.HasVariant "i32" GH.Slot Z Std_.Int32) where - variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 5) -instance (GH.HasVariant "i16" GH.Slot Z Std_.Int16) where - variantByLabel = (GH.Variant (GH.dataField 0 1 16 0) 6) -instance (GH.HasVariant "i8" GH.Slot Z Std_.Int8) where - variantByLabel = (GH.Variant (GH.dataField 0 1 8 0) 7) -instance (GH.HasVariant "u64" GH.Slot Z Std_.Word64) where - variantByLabel = (GH.Variant (GH.dataField 0 1 64 0) 8) -instance (GH.HasVariant "u32" GH.Slot Z Std_.Word32) where - variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 9) -instance (GH.HasVariant "u16" GH.Slot Z Std_.Word16) where - variantByLabel = (GH.Variant (GH.dataField 0 1 16 0) 10) -instance (GH.HasVariant "u8" GH.Slot Z Std_.Word8) where - variantByLabel = (GH.Variant (GH.dataField 0 1 8 0) 11) -instance (GH.HasVariant "bool" GH.Slot Z Std_.Bool) where - variantByLabel = (GH.Variant (GH.dataField 0 1 1 0) 12) -instance (GH.HasVariant "text" GH.Slot Z Basics.Text) where - variantByLabel = (GH.Variant (GH.ptrField 0) 13) -instance (GH.HasVariant "blob" GH.Slot Z Basics.Data) where - variantByLabel = (GH.Variant (GH.ptrField 0) 14) -instance (GH.HasVariant "f64vec" GH.Slot Z (R.List Std_.Double)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 15) -instance (GH.HasVariant "f32vec" GH.Slot Z (R.List Std_.Float)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 16) -instance (GH.HasVariant "i64vec" GH.Slot Z (R.List Std_.Int64)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 17) -instance (GH.HasVariant "i32vec" GH.Slot Z (R.List Std_.Int32)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 18) -instance (GH.HasVariant "i16vec" GH.Slot Z (R.List Std_.Int16)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 19) -instance (GH.HasVariant "i8vec" GH.Slot Z (R.List Std_.Int8)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 20) -instance (GH.HasVariant "u64vec" GH.Slot Z (R.List Std_.Word64)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 21) -instance (GH.HasVariant "u32vec" GH.Slot Z (R.List Std_.Word32)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 22) -instance (GH.HasVariant "u16vec" GH.Slot Z (R.List Std_.Word16)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 23) -instance (GH.HasVariant "u8vec" GH.Slot Z (R.List Std_.Word8)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 24) -instance (GH.HasVariant "zvec" GH.Slot Z (R.List Z)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 25) -instance (GH.HasVariant "zvecvec" GH.Slot Z (R.List (R.List Z))) where - variantByLabel = (GH.Variant (GH.ptrField 0) 26) -instance (GH.HasVariant "zdate" GH.Slot Z Zdate) where - variantByLabel = (GH.Variant (GH.ptrField 0) 27) -instance (GH.HasVariant "zdata" GH.Slot Z Zdata) where - variantByLabel = (GH.Variant (GH.ptrField 0) 28) -instance (GH.HasVariant "aircraftvec" GH.Slot Z (R.List Aircraft)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 29) -instance (GH.HasVariant "aircraft" GH.Slot Z Aircraft) where - variantByLabel = (GH.Variant (GH.ptrField 0) 30) -instance (GH.HasVariant "regression" GH.Slot Z Regression) where - variantByLabel = (GH.Variant (GH.ptrField 0) 31) -instance (GH.HasVariant "planebase" GH.Slot Z PlaneBase) where - variantByLabel = (GH.Variant (GH.ptrField 0) 32) -instance (GH.HasVariant "airport" GH.Slot Z Airport) where - variantByLabel = (GH.Variant (GH.dataField 0 1 16 0) 33) -instance (GH.HasVariant "b737" GH.Slot Z B737) where - variantByLabel = (GH.Variant (GH.ptrField 0) 34) -instance (GH.HasVariant "a320" GH.Slot Z A320) where - variantByLabel = (GH.Variant (GH.ptrField 0) 35) -instance (GH.HasVariant "f16" GH.Slot Z F16) where - variantByLabel = (GH.Variant (GH.ptrField 0) 36) -instance (GH.HasVariant "zdatevec" GH.Slot Z (R.List Zdate)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 37) -instance (GH.HasVariant "zdatavec" GH.Slot Z (R.List Zdata)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 38) -instance (GH.HasVariant "boolvec" GH.Slot Z (R.List Std_.Bool)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 39) -instance (GH.HasVariant "datavec" GH.Slot Z (R.List Basics.Data)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 40) -instance (GH.HasVariant "textvec" GH.Slot Z (R.List Basics.Text)) where - variantByLabel = (GH.Variant (GH.ptrField 0) 41) -instance (GH.HasVariant "grp" GH.Group Z Z'grp) where - variantByLabel = (GH.Variant GH.groupField 42) -instance (GH.HasVariant "echo" GH.Slot Z Echo) where - variantByLabel = (GH.Variant (GH.ptrField 0) 43) -instance (GH.HasVariant "echoBases" GH.Slot Z EchoBases) where - variantByLabel = (GH.Variant (GH.ptrField 0) 44) -data instance C.Parsed (GH.Which Z) - = Z'void - | Z'zz (RP.Parsed Z) - | Z'f64 (RP.Parsed Std_.Double) - | Z'f32 (RP.Parsed Std_.Float) - | Z'i64 (RP.Parsed Std_.Int64) - | Z'i32 (RP.Parsed Std_.Int32) - | Z'i16 (RP.Parsed Std_.Int16) - | Z'i8 (RP.Parsed Std_.Int8) - | Z'u64 (RP.Parsed Std_.Word64) - | Z'u32 (RP.Parsed Std_.Word32) - | Z'u16 (RP.Parsed Std_.Word16) - | Z'u8 (RP.Parsed Std_.Word8) - | Z'bool (RP.Parsed Std_.Bool) - | Z'text (RP.Parsed Basics.Text) - | Z'blob (RP.Parsed Basics.Data) - | Z'f64vec (RP.Parsed (R.List Std_.Double)) - | Z'f32vec (RP.Parsed (R.List Std_.Float)) - | Z'i64vec (RP.Parsed (R.List Std_.Int64)) - | Z'i32vec (RP.Parsed (R.List Std_.Int32)) - | Z'i16vec (RP.Parsed (R.List Std_.Int16)) - | Z'i8vec (RP.Parsed (R.List Std_.Int8)) - | Z'u64vec (RP.Parsed (R.List Std_.Word64)) - | Z'u32vec (RP.Parsed (R.List Std_.Word32)) - | Z'u16vec (RP.Parsed (R.List Std_.Word16)) - | Z'u8vec (RP.Parsed (R.List Std_.Word8)) - | Z'zvec (RP.Parsed (R.List Z)) - | Z'zvecvec (RP.Parsed (R.List (R.List Z))) - | Z'zdate (RP.Parsed Zdate) - | Z'zdata (RP.Parsed Zdata) - | Z'aircraftvec (RP.Parsed (R.List Aircraft)) - | Z'aircraft (RP.Parsed Aircraft) - | Z'regression (RP.Parsed Regression) - | Z'planebase (RP.Parsed PlaneBase) - | Z'airport (RP.Parsed Airport) - | Z'b737 (RP.Parsed B737) - | Z'a320 (RP.Parsed A320) - | Z'f16 (RP.Parsed F16) - | Z'zdatevec (RP.Parsed (R.List Zdate)) - | Z'zdatavec (RP.Parsed (R.List Zdata)) - | Z'boolvec (RP.Parsed (R.List Std_.Bool)) - | Z'datavec (RP.Parsed (R.List Basics.Data)) - | Z'textvec (RP.Parsed (R.List Basics.Text)) - | Z'grp (RP.Parsed Z'grp) - | Z'echo (RP.Parsed Echo) - | Z'echoBases (RP.Parsed EchoBases) - | Z'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which Z))) -deriving instance (Std_.Eq (C.Parsed (GH.Which Z))) -instance (C.Parse (GH.Which Z) (C.Parsed (GH.Which Z))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Z'void _) -> - (Std_.pure Z'void) - (RW_Z'zz rawArg_) -> - (Z'zz <$> (C.parse rawArg_)) - (RW_Z'f64 rawArg_) -> - (Z'f64 <$> (C.parse rawArg_)) - (RW_Z'f32 rawArg_) -> - (Z'f32 <$> (C.parse rawArg_)) - (RW_Z'i64 rawArg_) -> - (Z'i64 <$> (C.parse rawArg_)) - (RW_Z'i32 rawArg_) -> - (Z'i32 <$> (C.parse rawArg_)) - (RW_Z'i16 rawArg_) -> - (Z'i16 <$> (C.parse rawArg_)) - (RW_Z'i8 rawArg_) -> - (Z'i8 <$> (C.parse rawArg_)) - (RW_Z'u64 rawArg_) -> - (Z'u64 <$> (C.parse rawArg_)) - (RW_Z'u32 rawArg_) -> - (Z'u32 <$> (C.parse rawArg_)) - (RW_Z'u16 rawArg_) -> - (Z'u16 <$> (C.parse rawArg_)) - (RW_Z'u8 rawArg_) -> - (Z'u8 <$> (C.parse rawArg_)) - (RW_Z'bool rawArg_) -> - (Z'bool <$> (C.parse rawArg_)) - (RW_Z'text rawArg_) -> - (Z'text <$> (C.parse rawArg_)) - (RW_Z'blob rawArg_) -> - (Z'blob <$> (C.parse rawArg_)) - (RW_Z'f64vec rawArg_) -> - (Z'f64vec <$> (C.parse rawArg_)) - (RW_Z'f32vec rawArg_) -> - (Z'f32vec <$> (C.parse rawArg_)) - (RW_Z'i64vec rawArg_) -> - (Z'i64vec <$> (C.parse rawArg_)) - (RW_Z'i32vec rawArg_) -> - (Z'i32vec <$> (C.parse rawArg_)) - (RW_Z'i16vec rawArg_) -> - (Z'i16vec <$> (C.parse rawArg_)) - (RW_Z'i8vec rawArg_) -> - (Z'i8vec <$> (C.parse rawArg_)) - (RW_Z'u64vec rawArg_) -> - (Z'u64vec <$> (C.parse rawArg_)) - (RW_Z'u32vec rawArg_) -> - (Z'u32vec <$> (C.parse rawArg_)) - (RW_Z'u16vec rawArg_) -> - (Z'u16vec <$> (C.parse rawArg_)) - (RW_Z'u8vec rawArg_) -> - (Z'u8vec <$> (C.parse rawArg_)) - (RW_Z'zvec rawArg_) -> - (Z'zvec <$> (C.parse rawArg_)) - (RW_Z'zvecvec rawArg_) -> - (Z'zvecvec <$> (C.parse rawArg_)) - (RW_Z'zdate rawArg_) -> - (Z'zdate <$> (C.parse rawArg_)) - (RW_Z'zdata rawArg_) -> - (Z'zdata <$> (C.parse rawArg_)) - (RW_Z'aircraftvec rawArg_) -> - (Z'aircraftvec <$> (C.parse rawArg_)) - (RW_Z'aircraft rawArg_) -> - (Z'aircraft <$> (C.parse rawArg_)) - (RW_Z'regression rawArg_) -> - (Z'regression <$> (C.parse rawArg_)) - (RW_Z'planebase rawArg_) -> - (Z'planebase <$> (C.parse rawArg_)) - (RW_Z'airport rawArg_) -> - (Z'airport <$> (C.parse rawArg_)) - (RW_Z'b737 rawArg_) -> - (Z'b737 <$> (C.parse rawArg_)) - (RW_Z'a320 rawArg_) -> - (Z'a320 <$> (C.parse rawArg_)) - (RW_Z'f16 rawArg_) -> - (Z'f16 <$> (C.parse rawArg_)) - (RW_Z'zdatevec rawArg_) -> - (Z'zdatevec <$> (C.parse rawArg_)) - (RW_Z'zdatavec rawArg_) -> - (Z'zdatavec <$> (C.parse rawArg_)) - (RW_Z'boolvec rawArg_) -> - (Z'boolvec <$> (C.parse rawArg_)) - (RW_Z'datavec rawArg_) -> - (Z'datavec <$> (C.parse rawArg_)) - (RW_Z'textvec rawArg_) -> - (Z'textvec <$> (C.parse rawArg_)) - (RW_Z'grp rawArg_) -> - (Z'grp <$> (C.parse rawArg_)) - (RW_Z'echo rawArg_) -> - (Z'echo <$> (C.parse rawArg_)) - (RW_Z'echoBases rawArg_) -> - (Z'echoBases <$> (C.parse rawArg_)) - (RW_Z'unknown' tag_) -> - (Std_.pure (Z'unknown' tag_)) - ) -instance (C.Marshal (GH.Which Z) (C.Parsed (GH.Which Z))) where - marshalInto raw_ parsed_ = case parsed_ of - (Z'void) -> - (GH.encodeVariant #void () (GH.unionStruct raw_)) - (Z'zz arg_) -> - (GH.encodeVariant #zz arg_ (GH.unionStruct raw_)) - (Z'f64 arg_) -> - (GH.encodeVariant #f64 arg_ (GH.unionStruct raw_)) - (Z'f32 arg_) -> - (GH.encodeVariant #f32 arg_ (GH.unionStruct raw_)) - (Z'i64 arg_) -> - (GH.encodeVariant #i64 arg_ (GH.unionStruct raw_)) - (Z'i32 arg_) -> - (GH.encodeVariant #i32 arg_ (GH.unionStruct raw_)) - (Z'i16 arg_) -> - (GH.encodeVariant #i16 arg_ (GH.unionStruct raw_)) - (Z'i8 arg_) -> - (GH.encodeVariant #i8 arg_ (GH.unionStruct raw_)) - (Z'u64 arg_) -> - (GH.encodeVariant #u64 arg_ (GH.unionStruct raw_)) - (Z'u32 arg_) -> - (GH.encodeVariant #u32 arg_ (GH.unionStruct raw_)) - (Z'u16 arg_) -> - (GH.encodeVariant #u16 arg_ (GH.unionStruct raw_)) - (Z'u8 arg_) -> - (GH.encodeVariant #u8 arg_ (GH.unionStruct raw_)) - (Z'bool arg_) -> - (GH.encodeVariant #bool arg_ (GH.unionStruct raw_)) - (Z'text arg_) -> - (GH.encodeVariant #text arg_ (GH.unionStruct raw_)) - (Z'blob arg_) -> - (GH.encodeVariant #blob arg_ (GH.unionStruct raw_)) - (Z'f64vec arg_) -> - (GH.encodeVariant #f64vec arg_ (GH.unionStruct raw_)) - (Z'f32vec arg_) -> - (GH.encodeVariant #f32vec arg_ (GH.unionStruct raw_)) - (Z'i64vec arg_) -> - (GH.encodeVariant #i64vec arg_ (GH.unionStruct raw_)) - (Z'i32vec arg_) -> - (GH.encodeVariant #i32vec arg_ (GH.unionStruct raw_)) - (Z'i16vec arg_) -> - (GH.encodeVariant #i16vec arg_ (GH.unionStruct raw_)) - (Z'i8vec arg_) -> - (GH.encodeVariant #i8vec arg_ (GH.unionStruct raw_)) - (Z'u64vec arg_) -> - (GH.encodeVariant #u64vec arg_ (GH.unionStruct raw_)) - (Z'u32vec arg_) -> - (GH.encodeVariant #u32vec arg_ (GH.unionStruct raw_)) - (Z'u16vec arg_) -> - (GH.encodeVariant #u16vec arg_ (GH.unionStruct raw_)) - (Z'u8vec arg_) -> - (GH.encodeVariant #u8vec arg_ (GH.unionStruct raw_)) - (Z'zvec arg_) -> - (GH.encodeVariant #zvec arg_ (GH.unionStruct raw_)) - (Z'zvecvec arg_) -> - (GH.encodeVariant #zvecvec arg_ (GH.unionStruct raw_)) - (Z'zdate arg_) -> - (GH.encodeVariant #zdate arg_ (GH.unionStruct raw_)) - (Z'zdata arg_) -> - (GH.encodeVariant #zdata arg_ (GH.unionStruct raw_)) - (Z'aircraftvec arg_) -> - (GH.encodeVariant #aircraftvec arg_ (GH.unionStruct raw_)) - (Z'aircraft arg_) -> - (GH.encodeVariant #aircraft arg_ (GH.unionStruct raw_)) - (Z'regression arg_) -> - (GH.encodeVariant #regression arg_ (GH.unionStruct raw_)) - (Z'planebase arg_) -> - (GH.encodeVariant #planebase arg_ (GH.unionStruct raw_)) - (Z'airport arg_) -> - (GH.encodeVariant #airport arg_ (GH.unionStruct raw_)) - (Z'b737 arg_) -> - (GH.encodeVariant #b737 arg_ (GH.unionStruct raw_)) - (Z'a320 arg_) -> - (GH.encodeVariant #a320 arg_ (GH.unionStruct raw_)) - (Z'f16 arg_) -> - (GH.encodeVariant #f16 arg_ (GH.unionStruct raw_)) - (Z'zdatevec arg_) -> - (GH.encodeVariant #zdatevec arg_ (GH.unionStruct raw_)) - (Z'zdatavec arg_) -> - (GH.encodeVariant #zdatavec arg_ (GH.unionStruct raw_)) - (Z'boolvec arg_) -> - (GH.encodeVariant #boolvec arg_ (GH.unionStruct raw_)) - (Z'datavec arg_) -> - (GH.encodeVariant #datavec arg_ (GH.unionStruct raw_)) - (Z'textvec arg_) -> - (GH.encodeVariant #textvec arg_ (GH.unionStruct raw_)) - (Z'grp arg_) -> - (do - rawGroup_ <- (GH.initVariant #grp (GH.unionStruct raw_)) - (C.marshalInto rawGroup_ arg_) - ) - (Z'echo arg_) -> - (GH.encodeVariant #echo arg_ (GH.unionStruct raw_)) - (Z'echoBases arg_) -> - (GH.encodeVariant #echoBases arg_ (GH.unionStruct raw_)) - (Z'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Z'grp -type instance (R.ReprFor Z'grp) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Z'grp) where - typeId = 13198763830743312036 -instance (C.TypedStruct Z'grp) where - numStructWords = 3 - numStructPtrs = 1 -instance (C.Allocate Z'grp) where - type AllocHint Z'grp = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Z'grp (C.Parsed Z'grp)) -instance (C.AllocateList Z'grp) where - type ListAllocHint Z'grp = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Z'grp (C.Parsed Z'grp)) -data instance C.Parsed Z'grp - = Z'grp' - {first :: (RP.Parsed Std_.Word64) - ,second :: (RP.Parsed Std_.Word64)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Z'grp)) -deriving instance (Std_.Eq (C.Parsed Z'grp)) -instance (C.Parse Z'grp (C.Parsed Z'grp)) where - parse raw_ = (Z'grp' <$> (GH.parseField #first raw_) - <*> (GH.parseField #second raw_)) -instance (C.Marshal Z'grp (C.Parsed Z'grp)) where - marshalInto raw_ Z'grp'{..} = (do - (GH.encodeField #first first raw_) - (GH.encodeField #second second raw_) - (Std_.pure ()) - ) -instance (GH.HasField "first" GH.Slot Z'grp Std_.Word64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "second" GH.Slot Z'grp Std_.Word64) where - fieldByLabel = (GH.dataField 0 2 64 0) -data Counter -type instance (R.ReprFor Counter) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Counter) where - typeId = 9748248141862325085 -instance (C.TypedStruct Counter) where - numStructWords = 1 - numStructPtrs = 2 -instance (C.Allocate Counter) where - type AllocHint Counter = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Counter (C.Parsed Counter)) -instance (C.AllocateList Counter) where - type ListAllocHint Counter = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Counter (C.Parsed Counter)) -data instance C.Parsed Counter - = Counter - {size :: (RP.Parsed Std_.Int64) - ,words :: (RP.Parsed Basics.Text) - ,wordlist :: (RP.Parsed (R.List Basics.Text))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Counter)) -deriving instance (Std_.Eq (C.Parsed Counter)) -instance (C.Parse Counter (C.Parsed Counter)) where - parse raw_ = (Counter <$> (GH.parseField #size raw_) - <*> (GH.parseField #words raw_) - <*> (GH.parseField #wordlist raw_)) -instance (C.Marshal Counter (C.Parsed Counter)) where - marshalInto raw_ Counter{..} = (do - (GH.encodeField #size size raw_) - (GH.encodeField #words words raw_) - (GH.encodeField #wordlist wordlist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "size" GH.Slot Counter Std_.Int64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "words" GH.Slot Counter Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "wordlist" GH.Slot Counter (R.List Basics.Text)) where - fieldByLabel = (GH.ptrField 1) -data Bag -type instance (R.ReprFor Bag) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Bag) where - typeId = 15435801458704439998 -instance (C.TypedStruct Bag) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Bag) where - type AllocHint Bag = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Bag (C.Parsed Bag)) -instance (C.AllocateList Bag) where - type ListAllocHint Bag = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Bag (C.Parsed Bag)) -data instance C.Parsed Bag - = Bag - {counter :: (RP.Parsed Counter)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Bag)) -deriving instance (Std_.Eq (C.Parsed Bag)) -instance (C.Parse Bag (C.Parsed Bag)) where - parse raw_ = (Bag <$> (GH.parseField #counter raw_)) -instance (C.Marshal Bag (C.Parsed Bag)) where - marshalInto raw_ Bag{..} = (do - (GH.encodeField #counter counter raw_) - (Std_.pure ()) - ) -instance (GH.HasField "counter" GH.Slot Bag Counter) where - fieldByLabel = (GH.ptrField 0) -data Zserver -type instance (R.ReprFor Zserver) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Zserver) where - typeId = 14718909161889449112 -instance (C.TypedStruct Zserver) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Zserver) where - type AllocHint Zserver = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Zserver (C.Parsed Zserver)) -instance (C.AllocateList Zserver) where - type ListAllocHint Zserver = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Zserver (C.Parsed Zserver)) -data instance C.Parsed Zserver - = Zserver - {waitingjobs :: (RP.Parsed (R.List Zjob))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Zserver)) -deriving instance (Std_.Eq (C.Parsed Zserver)) -instance (C.Parse Zserver (C.Parsed Zserver)) where - parse raw_ = (Zserver <$> (GH.parseField #waitingjobs raw_)) -instance (C.Marshal Zserver (C.Parsed Zserver)) where - marshalInto raw_ Zserver{..} = (do - (GH.encodeField #waitingjobs waitingjobs raw_) - (Std_.pure ()) - ) -instance (GH.HasField "waitingjobs" GH.Slot Zserver (R.List Zjob)) where - fieldByLabel = (GH.ptrField 0) -data Zjob -type instance (R.ReprFor Zjob) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Zjob) where - typeId = 15983628460635158035 -instance (C.TypedStruct Zjob) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate Zjob) where - type AllocHint Zjob = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Zjob (C.Parsed Zjob)) -instance (C.AllocateList Zjob) where - type ListAllocHint Zjob = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Zjob (C.Parsed Zjob)) -data instance C.Parsed Zjob - = Zjob - {cmd :: (RP.Parsed Basics.Text) - ,args :: (RP.Parsed (R.List Basics.Text))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Zjob)) -deriving instance (Std_.Eq (C.Parsed Zjob)) -instance (C.Parse Zjob (C.Parsed Zjob)) where - parse raw_ = (Zjob <$> (GH.parseField #cmd raw_) - <*> (GH.parseField #args raw_)) -instance (C.Marshal Zjob (C.Parsed Zjob)) where - marshalInto raw_ Zjob{..} = (do - (GH.encodeField #cmd cmd raw_) - (GH.encodeField #args args raw_) - (Std_.pure ()) - ) -instance (GH.HasField "cmd" GH.Slot Zjob Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "args" GH.Slot Zjob (R.List Basics.Text)) where - fieldByLabel = (GH.ptrField 1) -data VerEmpty -type instance (R.ReprFor VerEmpty) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerEmpty) where - typeId = 10649211371004916479 -instance (C.TypedStruct VerEmpty) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate VerEmpty) where - type AllocHint VerEmpty = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerEmpty (C.Parsed VerEmpty)) -instance (C.AllocateList VerEmpty) where - type ListAllocHint VerEmpty = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerEmpty (C.Parsed VerEmpty)) -data instance C.Parsed VerEmpty - = VerEmpty - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerEmpty)) -deriving instance (Std_.Eq (C.Parsed VerEmpty)) -instance (C.Parse VerEmpty (C.Parsed VerEmpty)) where - parse raw_ = (Std_.pure VerEmpty) -instance (C.Marshal VerEmpty (C.Parsed VerEmpty)) where - marshalInto _raw (VerEmpty) = (Std_.pure ()) -data VerOneData -type instance (R.ReprFor VerOneData) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerOneData) where - typeId = 18204521836387912926 -instance (C.TypedStruct VerOneData) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate VerOneData) where - type AllocHint VerOneData = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerOneData (C.Parsed VerOneData)) -instance (C.AllocateList VerOneData) where - type ListAllocHint VerOneData = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerOneData (C.Parsed VerOneData)) -data instance C.Parsed VerOneData - = VerOneData - {val :: (RP.Parsed Std_.Int16)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerOneData)) -deriving instance (Std_.Eq (C.Parsed VerOneData)) -instance (C.Parse VerOneData (C.Parsed VerOneData)) where - parse raw_ = (VerOneData <$> (GH.parseField #val raw_)) -instance (C.Marshal VerOneData (C.Parsed VerOneData)) where - marshalInto raw_ VerOneData{..} = (do - (GH.encodeField #val val raw_) - (Std_.pure ()) - ) -instance (GH.HasField "val" GH.Slot VerOneData Std_.Int16) where - fieldByLabel = (GH.dataField 0 0 16 0) -data VerTwoData -type instance (R.ReprFor VerTwoData) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerTwoData) where - typeId = 17799875294539507453 -instance (C.TypedStruct VerTwoData) where - numStructWords = 2 - numStructPtrs = 0 -instance (C.Allocate VerTwoData) where - type AllocHint VerTwoData = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerTwoData (C.Parsed VerTwoData)) -instance (C.AllocateList VerTwoData) where - type ListAllocHint VerTwoData = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerTwoData (C.Parsed VerTwoData)) -data instance C.Parsed VerTwoData - = VerTwoData - {val :: (RP.Parsed Std_.Int16) - ,duo :: (RP.Parsed Std_.Int64)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerTwoData)) -deriving instance (Std_.Eq (C.Parsed VerTwoData)) -instance (C.Parse VerTwoData (C.Parsed VerTwoData)) where - parse raw_ = (VerTwoData <$> (GH.parseField #val raw_) - <*> (GH.parseField #duo raw_)) -instance (C.Marshal VerTwoData (C.Parsed VerTwoData)) where - marshalInto raw_ VerTwoData{..} = (do - (GH.encodeField #val val raw_) - (GH.encodeField #duo duo raw_) - (Std_.pure ()) - ) -instance (GH.HasField "val" GH.Slot VerTwoData Std_.Int16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "duo" GH.Slot VerTwoData Std_.Int64) where - fieldByLabel = (GH.dataField 0 1 64 0) -data VerOnePtr -type instance (R.ReprFor VerOnePtr) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerOnePtr) where - typeId = 10718424143143379341 -instance (C.TypedStruct VerOnePtr) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate VerOnePtr) where - type AllocHint VerOnePtr = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerOnePtr (C.Parsed VerOnePtr)) -instance (C.AllocateList VerOnePtr) where - type ListAllocHint VerOnePtr = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerOnePtr (C.Parsed VerOnePtr)) -data instance C.Parsed VerOnePtr - = VerOnePtr - {ptr :: (RP.Parsed VerOneData)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerOnePtr)) -deriving instance (Std_.Eq (C.Parsed VerOnePtr)) -instance (C.Parse VerOnePtr (C.Parsed VerOnePtr)) where - parse raw_ = (VerOnePtr <$> (GH.parseField #ptr raw_)) -instance (C.Marshal VerOnePtr (C.Parsed VerOnePtr)) where - marshalInto raw_ VerOnePtr{..} = (do - (GH.encodeField #ptr ptr raw_) - (Std_.pure ()) - ) -instance (GH.HasField "ptr" GH.Slot VerOnePtr VerOneData) where - fieldByLabel = (GH.ptrField 0) -data VerTwoPtr -type instance (R.ReprFor VerTwoPtr) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerTwoPtr) where - typeId = 14509379619124759853 -instance (C.TypedStruct VerTwoPtr) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate VerTwoPtr) where - type AllocHint VerTwoPtr = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerTwoPtr (C.Parsed VerTwoPtr)) -instance (C.AllocateList VerTwoPtr) where - type ListAllocHint VerTwoPtr = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerTwoPtr (C.Parsed VerTwoPtr)) -data instance C.Parsed VerTwoPtr - = VerTwoPtr - {ptr1 :: (RP.Parsed VerOneData) - ,ptr2 :: (RP.Parsed VerOneData)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerTwoPtr)) -deriving instance (Std_.Eq (C.Parsed VerTwoPtr)) -instance (C.Parse VerTwoPtr (C.Parsed VerTwoPtr)) where - parse raw_ = (VerTwoPtr <$> (GH.parseField #ptr1 raw_) - <*> (GH.parseField #ptr2 raw_)) -instance (C.Marshal VerTwoPtr (C.Parsed VerTwoPtr)) where - marshalInto raw_ VerTwoPtr{..} = (do - (GH.encodeField #ptr1 ptr1 raw_) - (GH.encodeField #ptr2 ptr2 raw_) - (Std_.pure ()) - ) -instance (GH.HasField "ptr1" GH.Slot VerTwoPtr VerOneData) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "ptr2" GH.Slot VerTwoPtr VerOneData) where - fieldByLabel = (GH.ptrField 1) -data VerTwoDataTwoPtr -type instance (R.ReprFor VerTwoDataTwoPtr) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerTwoDataTwoPtr) where - typeId = 13123175871726013043 -instance (C.TypedStruct VerTwoDataTwoPtr) where - numStructWords = 2 - numStructPtrs = 2 -instance (C.Allocate VerTwoDataTwoPtr) where - type AllocHint VerTwoDataTwoPtr = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) -instance (C.AllocateList VerTwoDataTwoPtr) where - type ListAllocHint VerTwoDataTwoPtr = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) -data instance C.Parsed VerTwoDataTwoPtr - = VerTwoDataTwoPtr - {val :: (RP.Parsed Std_.Int16) - ,duo :: (RP.Parsed Std_.Int64) - ,ptr1 :: (RP.Parsed VerOneData) - ,ptr2 :: (RP.Parsed VerOneData)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerTwoDataTwoPtr)) -deriving instance (Std_.Eq (C.Parsed VerTwoDataTwoPtr)) -instance (C.Parse VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) where - parse raw_ = (VerTwoDataTwoPtr <$> (GH.parseField #val raw_) - <*> (GH.parseField #duo raw_) - <*> (GH.parseField #ptr1 raw_) - <*> (GH.parseField #ptr2 raw_)) -instance (C.Marshal VerTwoDataTwoPtr (C.Parsed VerTwoDataTwoPtr)) where - marshalInto raw_ VerTwoDataTwoPtr{..} = (do - (GH.encodeField #val val raw_) - (GH.encodeField #duo duo raw_) - (GH.encodeField #ptr1 ptr1 raw_) - (GH.encodeField #ptr2 ptr2 raw_) - (Std_.pure ()) - ) -instance (GH.HasField "val" GH.Slot VerTwoDataTwoPtr Std_.Int16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "duo" GH.Slot VerTwoDataTwoPtr Std_.Int64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "ptr1" GH.Slot VerTwoDataTwoPtr VerOneData) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "ptr2" GH.Slot VerTwoDataTwoPtr VerOneData) where - fieldByLabel = (GH.ptrField 1) -data HoldsVerEmptyList -type instance (R.ReprFor HoldsVerEmptyList) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerEmptyList) where - typeId = 16041492281108738195 -instance (C.TypedStruct HoldsVerEmptyList) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerEmptyList) where - type AllocHint HoldsVerEmptyList = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) -instance (C.AllocateList HoldsVerEmptyList) where - type ListAllocHint HoldsVerEmptyList = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) -data instance C.Parsed HoldsVerEmptyList - = HoldsVerEmptyList - {mylist :: (RP.Parsed (R.List VerEmpty))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerEmptyList)) -deriving instance (Std_.Eq (C.Parsed HoldsVerEmptyList)) -instance (C.Parse HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) where - parse raw_ = (HoldsVerEmptyList <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerEmptyList (C.Parsed HoldsVerEmptyList)) where - marshalInto raw_ HoldsVerEmptyList{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerEmptyList (R.List VerEmpty)) where - fieldByLabel = (GH.ptrField 0) -data HoldsVerOneDataList -type instance (R.ReprFor HoldsVerOneDataList) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerOneDataList) where - typeId = 12380489118307417585 -instance (C.TypedStruct HoldsVerOneDataList) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerOneDataList) where - type AllocHint HoldsVerOneDataList = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) -instance (C.AllocateList HoldsVerOneDataList) where - type ListAllocHint HoldsVerOneDataList = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) -data instance C.Parsed HoldsVerOneDataList - = HoldsVerOneDataList - {mylist :: (RP.Parsed (R.List VerOneData))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerOneDataList)) -deriving instance (Std_.Eq (C.Parsed HoldsVerOneDataList)) -instance (C.Parse HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) where - parse raw_ = (HoldsVerOneDataList <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerOneDataList (C.Parsed HoldsVerOneDataList)) where - marshalInto raw_ HoldsVerOneDataList{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerOneDataList (R.List VerOneData)) where - fieldByLabel = (GH.ptrField 0) -data HoldsVerTwoDataList -type instance (R.ReprFor HoldsVerTwoDataList) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerTwoDataList) where - typeId = 14689746238557910970 -instance (C.TypedStruct HoldsVerTwoDataList) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerTwoDataList) where - type AllocHint HoldsVerTwoDataList = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) -instance (C.AllocateList HoldsVerTwoDataList) where - type ListAllocHint HoldsVerTwoDataList = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) -data instance C.Parsed HoldsVerTwoDataList - = HoldsVerTwoDataList - {mylist :: (RP.Parsed (R.List VerTwoData))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerTwoDataList)) -deriving instance (Std_.Eq (C.Parsed HoldsVerTwoDataList)) -instance (C.Parse HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) where - parse raw_ = (HoldsVerTwoDataList <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerTwoDataList (C.Parsed HoldsVerTwoDataList)) where - marshalInto raw_ HoldsVerTwoDataList{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerTwoDataList (R.List VerTwoData)) where - fieldByLabel = (GH.ptrField 0) -data HoldsVerOnePtrList -type instance (R.ReprFor HoldsVerOnePtrList) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerOnePtrList) where - typeId = 16503619627606104568 -instance (C.TypedStruct HoldsVerOnePtrList) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerOnePtrList) where - type AllocHint HoldsVerOnePtrList = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) -instance (C.AllocateList HoldsVerOnePtrList) where - type ListAllocHint HoldsVerOnePtrList = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) -data instance C.Parsed HoldsVerOnePtrList - = HoldsVerOnePtrList - {mylist :: (RP.Parsed (R.List VerOnePtr))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerOnePtrList)) -deriving instance (Std_.Eq (C.Parsed HoldsVerOnePtrList)) -instance (C.Parse HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) where - parse raw_ = (HoldsVerOnePtrList <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerOnePtrList (C.Parsed HoldsVerOnePtrList)) where - marshalInto raw_ HoldsVerOnePtrList{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerOnePtrList (R.List VerOnePtr)) where - fieldByLabel = (GH.ptrField 0) -data HoldsVerTwoPtrList -type instance (R.ReprFor HoldsVerTwoPtrList) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerTwoPtrList) where - typeId = 14959808741027971272 -instance (C.TypedStruct HoldsVerTwoPtrList) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerTwoPtrList) where - type AllocHint HoldsVerTwoPtrList = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) -instance (C.AllocateList HoldsVerTwoPtrList) where - type ListAllocHint HoldsVerTwoPtrList = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) -data instance C.Parsed HoldsVerTwoPtrList - = HoldsVerTwoPtrList - {mylist :: (RP.Parsed (R.List VerTwoPtr))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerTwoPtrList)) -deriving instance (Std_.Eq (C.Parsed HoldsVerTwoPtrList)) -instance (C.Parse HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) where - parse raw_ = (HoldsVerTwoPtrList <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerTwoPtrList (C.Parsed HoldsVerTwoPtrList)) where - marshalInto raw_ HoldsVerTwoPtrList{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerTwoPtrList (R.List VerTwoPtr)) where - fieldByLabel = (GH.ptrField 0) -data HoldsVerTwoTwoList -type instance (R.ReprFor HoldsVerTwoTwoList) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerTwoTwoList) where - typeId = 10790341304104545899 -instance (C.TypedStruct HoldsVerTwoTwoList) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerTwoTwoList) where - type AllocHint HoldsVerTwoTwoList = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) -instance (C.AllocateList HoldsVerTwoTwoList) where - type ListAllocHint HoldsVerTwoTwoList = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) -data instance C.Parsed HoldsVerTwoTwoList - = HoldsVerTwoTwoList - {mylist :: (RP.Parsed (R.List VerTwoDataTwoPtr))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerTwoTwoList)) -deriving instance (Std_.Eq (C.Parsed HoldsVerTwoTwoList)) -instance (C.Parse HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) where - parse raw_ = (HoldsVerTwoTwoList <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerTwoTwoList (C.Parsed HoldsVerTwoTwoList)) where - marshalInto raw_ HoldsVerTwoTwoList{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerTwoTwoList (R.List VerTwoDataTwoPtr)) where - fieldByLabel = (GH.ptrField 0) -data HoldsVerTwoTwoPlus -type instance (R.ReprFor HoldsVerTwoTwoPlus) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsVerTwoTwoPlus) where - typeId = 9782732235957253080 -instance (C.TypedStruct HoldsVerTwoTwoPlus) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate HoldsVerTwoTwoPlus) where - type AllocHint HoldsVerTwoTwoPlus = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) -instance (C.AllocateList HoldsVerTwoTwoPlus) where - type ListAllocHint HoldsVerTwoTwoPlus = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) -data instance C.Parsed HoldsVerTwoTwoPlus - = HoldsVerTwoTwoPlus - {mylist :: (RP.Parsed (R.List VerTwoTwoPlus))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsVerTwoTwoPlus)) -deriving instance (Std_.Eq (C.Parsed HoldsVerTwoTwoPlus)) -instance (C.Parse HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) where - parse raw_ = (HoldsVerTwoTwoPlus <$> (GH.parseField #mylist raw_)) -instance (C.Marshal HoldsVerTwoTwoPlus (C.Parsed HoldsVerTwoTwoPlus)) where - marshalInto raw_ HoldsVerTwoTwoPlus{..} = (do - (GH.encodeField #mylist mylist raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mylist" GH.Slot HoldsVerTwoTwoPlus (R.List VerTwoTwoPlus)) where - fieldByLabel = (GH.ptrField 0) -data VerTwoTwoPlus -type instance (R.ReprFor VerTwoTwoPlus) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VerTwoTwoPlus) where - typeId = 14863196959570808905 -instance (C.TypedStruct VerTwoTwoPlus) where - numStructWords = 3 - numStructPtrs = 3 -instance (C.Allocate VerTwoTwoPlus) where - type AllocHint VerTwoTwoPlus = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) -instance (C.AllocateList VerTwoTwoPlus) where - type ListAllocHint VerTwoTwoPlus = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) -data instance C.Parsed VerTwoTwoPlus - = VerTwoTwoPlus - {val :: (RP.Parsed Std_.Int16) - ,duo :: (RP.Parsed Std_.Int64) - ,ptr1 :: (RP.Parsed VerTwoDataTwoPtr) - ,ptr2 :: (RP.Parsed VerTwoDataTwoPtr) - ,tre :: (RP.Parsed Std_.Int64) - ,lst3 :: (RP.Parsed (R.List Std_.Int64))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VerTwoTwoPlus)) -deriving instance (Std_.Eq (C.Parsed VerTwoTwoPlus)) -instance (C.Parse VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) where - parse raw_ = (VerTwoTwoPlus <$> (GH.parseField #val raw_) - <*> (GH.parseField #duo raw_) - <*> (GH.parseField #ptr1 raw_) - <*> (GH.parseField #ptr2 raw_) - <*> (GH.parseField #tre raw_) - <*> (GH.parseField #lst3 raw_)) -instance (C.Marshal VerTwoTwoPlus (C.Parsed VerTwoTwoPlus)) where - marshalInto raw_ VerTwoTwoPlus{..} = (do - (GH.encodeField #val val raw_) - (GH.encodeField #duo duo raw_) - (GH.encodeField #ptr1 ptr1 raw_) - (GH.encodeField #ptr2 ptr2 raw_) - (GH.encodeField #tre tre raw_) - (GH.encodeField #lst3 lst3 raw_) - (Std_.pure ()) - ) -instance (GH.HasField "val" GH.Slot VerTwoTwoPlus Std_.Int16) where - fieldByLabel = (GH.dataField 0 0 16 0) -instance (GH.HasField "duo" GH.Slot VerTwoTwoPlus Std_.Int64) where - fieldByLabel = (GH.dataField 0 1 64 0) -instance (GH.HasField "ptr1" GH.Slot VerTwoTwoPlus VerTwoDataTwoPtr) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "ptr2" GH.Slot VerTwoTwoPlus VerTwoDataTwoPtr) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "tre" GH.Slot VerTwoTwoPlus Std_.Int64) where - fieldByLabel = (GH.dataField 0 2 64 0) -instance (GH.HasField "lst3" GH.Slot VerTwoTwoPlus (R.List Std_.Int64)) where - fieldByLabel = (GH.ptrField 2) -data HoldsText -type instance (R.ReprFor HoldsText) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId HoldsText) where - typeId = 16537639514277480156 -instance (C.TypedStruct HoldsText) where - numStructWords = 0 - numStructPtrs = 3 -instance (C.Allocate HoldsText) where - type AllocHint HoldsText = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc HoldsText (C.Parsed HoldsText)) -instance (C.AllocateList HoldsText) where - type ListAllocHint HoldsText = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc HoldsText (C.Parsed HoldsText)) -data instance C.Parsed HoldsText - = HoldsText - {txt :: (RP.Parsed Basics.Text) - ,lst :: (RP.Parsed (R.List Basics.Text)) - ,lstlst :: (RP.Parsed (R.List (R.List Basics.Text)))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed HoldsText)) -deriving instance (Std_.Eq (C.Parsed HoldsText)) -instance (C.Parse HoldsText (C.Parsed HoldsText)) where - parse raw_ = (HoldsText <$> (GH.parseField #txt raw_) - <*> (GH.parseField #lst raw_) - <*> (GH.parseField #lstlst raw_)) -instance (C.Marshal HoldsText (C.Parsed HoldsText)) where - marshalInto raw_ HoldsText{..} = (do - (GH.encodeField #txt txt raw_) - (GH.encodeField #lst lst raw_) - (GH.encodeField #lstlst lstlst raw_) - (Std_.pure ()) - ) -instance (GH.HasField "txt" GH.Slot HoldsText Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "lst" GH.Slot HoldsText (R.List Basics.Text)) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "lstlst" GH.Slot HoldsText (R.List (R.List Basics.Text))) where - fieldByLabel = (GH.ptrField 2) -data WrapEmpty -type instance (R.ReprFor WrapEmpty) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId WrapEmpty) where - typeId = 11147985329045285977 -instance (C.TypedStruct WrapEmpty) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate WrapEmpty) where - type AllocHint WrapEmpty = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc WrapEmpty (C.Parsed WrapEmpty)) -instance (C.AllocateList WrapEmpty) where - type ListAllocHint WrapEmpty = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc WrapEmpty (C.Parsed WrapEmpty)) -data instance C.Parsed WrapEmpty - = WrapEmpty - {mightNotBeReallyEmpty :: (RP.Parsed VerEmpty)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed WrapEmpty)) -deriving instance (Std_.Eq (C.Parsed WrapEmpty)) -instance (C.Parse WrapEmpty (C.Parsed WrapEmpty)) where - parse raw_ = (WrapEmpty <$> (GH.parseField #mightNotBeReallyEmpty raw_)) -instance (C.Marshal WrapEmpty (C.Parsed WrapEmpty)) where - marshalInto raw_ WrapEmpty{..} = (do - (GH.encodeField #mightNotBeReallyEmpty mightNotBeReallyEmpty raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mightNotBeReallyEmpty" GH.Slot WrapEmpty VerEmpty) where - fieldByLabel = (GH.ptrField 0) -data Wrap2x2 -type instance (R.ReprFor Wrap2x2) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Wrap2x2) where - typeId = 16258788317804871341 -instance (C.TypedStruct Wrap2x2) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Wrap2x2) where - type AllocHint Wrap2x2 = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Wrap2x2 (C.Parsed Wrap2x2)) -instance (C.AllocateList Wrap2x2) where - type ListAllocHint Wrap2x2 = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Wrap2x2 (C.Parsed Wrap2x2)) -data instance C.Parsed Wrap2x2 - = Wrap2x2 - {mightNotBeReallyEmpty :: (RP.Parsed VerTwoDataTwoPtr)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Wrap2x2)) -deriving instance (Std_.Eq (C.Parsed Wrap2x2)) -instance (C.Parse Wrap2x2 (C.Parsed Wrap2x2)) where - parse raw_ = (Wrap2x2 <$> (GH.parseField #mightNotBeReallyEmpty raw_)) -instance (C.Marshal Wrap2x2 (C.Parsed Wrap2x2)) where - marshalInto raw_ Wrap2x2{..} = (do - (GH.encodeField #mightNotBeReallyEmpty mightNotBeReallyEmpty raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mightNotBeReallyEmpty" GH.Slot Wrap2x2 VerTwoDataTwoPtr) where - fieldByLabel = (GH.ptrField 0) -data Wrap2x2plus -type instance (R.ReprFor Wrap2x2plus) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Wrap2x2plus) where - typeId = 16610659964001347673 -instance (C.TypedStruct Wrap2x2plus) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Wrap2x2plus) where - type AllocHint Wrap2x2plus = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Wrap2x2plus (C.Parsed Wrap2x2plus)) -instance (C.AllocateList Wrap2x2plus) where - type ListAllocHint Wrap2x2plus = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Wrap2x2plus (C.Parsed Wrap2x2plus)) -data instance C.Parsed Wrap2x2plus - = Wrap2x2plus - {mightNotBeReallyEmpty :: (RP.Parsed VerTwoTwoPlus)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Wrap2x2plus)) -deriving instance (Std_.Eq (C.Parsed Wrap2x2plus)) -instance (C.Parse Wrap2x2plus (C.Parsed Wrap2x2plus)) where - parse raw_ = (Wrap2x2plus <$> (GH.parseField #mightNotBeReallyEmpty raw_)) -instance (C.Marshal Wrap2x2plus (C.Parsed Wrap2x2plus)) where - marshalInto raw_ Wrap2x2plus{..} = (do - (GH.encodeField #mightNotBeReallyEmpty mightNotBeReallyEmpty raw_) - (Std_.pure ()) - ) -instance (GH.HasField "mightNotBeReallyEmpty" GH.Slot Wrap2x2plus VerTwoTwoPlus) where - fieldByLabel = (GH.ptrField 0) -data VoidUnion -type instance (R.ReprFor VoidUnion) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId VoidUnion) where - typeId = 9809347628687718458 -instance (C.TypedStruct VoidUnion) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate VoidUnion) where - type AllocHint VoidUnion = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc VoidUnion (C.Parsed VoidUnion)) -instance (C.AllocateList VoidUnion) where - type ListAllocHint VoidUnion = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc VoidUnion (C.Parsed VoidUnion)) -data instance C.Parsed VoidUnion - = VoidUnion - {union' :: (C.Parsed (GH.Which VoidUnion))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed VoidUnion)) -deriving instance (Std_.Eq (C.Parsed VoidUnion)) -instance (C.Parse VoidUnion (C.Parsed VoidUnion)) where - parse raw_ = (VoidUnion <$> (C.parse (GH.structUnion raw_))) -instance (C.Marshal VoidUnion (C.Parsed VoidUnion)) where - marshalInto raw_ VoidUnion{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance (GH.HasUnion VoidUnion) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich VoidUnion mut_ - = RW_VoidUnion'a (R.Raw () mut_) - | RW_VoidUnion'b (R.Raw () mut_) - | RW_VoidUnion'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_VoidUnion'a <$> (GH.readVariant #a struct_)) - 1 -> - (RW_VoidUnion'b <$> (GH.readVariant #b struct_)) - _ -> - (Std_.pure (RW_VoidUnion'unknown' tag_)) - data Which VoidUnion -instance (GH.HasVariant "a" GH.Slot VoidUnion ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance (GH.HasVariant "b" GH.Slot VoidUnion ()) where - variantByLabel = (GH.Variant GH.voidField 1) -data instance C.Parsed (GH.Which VoidUnion) - = VoidUnion'a - | VoidUnion'b - | VoidUnion'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed (GH.Which VoidUnion))) -deriving instance (Std_.Eq (C.Parsed (GH.Which VoidUnion))) -instance (C.Parse (GH.Which VoidUnion) (C.Parsed (GH.Which VoidUnion))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_VoidUnion'a _) -> - (Std_.pure VoidUnion'a) - (RW_VoidUnion'b _) -> - (Std_.pure VoidUnion'b) - (RW_VoidUnion'unknown' tag_) -> - (Std_.pure (VoidUnion'unknown' tag_)) - ) -instance (C.Marshal (GH.Which VoidUnion) (C.Parsed (GH.Which VoidUnion))) where - marshalInto raw_ parsed_ = case parsed_ of - (VoidUnion'a) -> - (GH.encodeVariant #a () (GH.unionStruct raw_)) - (VoidUnion'b) -> - (GH.encodeVariant #b () (GH.unionStruct raw_)) - (VoidUnion'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Nester1Capn -type instance (R.ReprFor Nester1Capn) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Nester1Capn) where - typeId = 17388306941580478492 -instance (C.TypedStruct Nester1Capn) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Nester1Capn) where - type AllocHint Nester1Capn = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Nester1Capn (C.Parsed Nester1Capn)) -instance (C.AllocateList Nester1Capn) where - type ListAllocHint Nester1Capn = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Nester1Capn (C.Parsed Nester1Capn)) -data instance C.Parsed Nester1Capn - = Nester1Capn - {strs :: (RP.Parsed (R.List Basics.Text))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Nester1Capn)) -deriving instance (Std_.Eq (C.Parsed Nester1Capn)) -instance (C.Parse Nester1Capn (C.Parsed Nester1Capn)) where - parse raw_ = (Nester1Capn <$> (GH.parseField #strs raw_)) -instance (C.Marshal Nester1Capn (C.Parsed Nester1Capn)) where - marshalInto raw_ Nester1Capn{..} = (do - (GH.encodeField #strs strs raw_) - (Std_.pure ()) - ) -instance (GH.HasField "strs" GH.Slot Nester1Capn (R.List Basics.Text)) where - fieldByLabel = (GH.ptrField 0) -data RWTestCapn -type instance (R.ReprFor RWTestCapn) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId RWTestCapn) where - typeId = 17870076700317718634 -instance (C.TypedStruct RWTestCapn) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate RWTestCapn) where - type AllocHint RWTestCapn = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc RWTestCapn (C.Parsed RWTestCapn)) -instance (C.AllocateList RWTestCapn) where - type ListAllocHint RWTestCapn = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc RWTestCapn (C.Parsed RWTestCapn)) -data instance C.Parsed RWTestCapn - = RWTestCapn - {nestMatrix :: (RP.Parsed (R.List (R.List Nester1Capn)))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed RWTestCapn)) -deriving instance (Std_.Eq (C.Parsed RWTestCapn)) -instance (C.Parse RWTestCapn (C.Parsed RWTestCapn)) where - parse raw_ = (RWTestCapn <$> (GH.parseField #nestMatrix raw_)) -instance (C.Marshal RWTestCapn (C.Parsed RWTestCapn)) where - marshalInto raw_ RWTestCapn{..} = (do - (GH.encodeField #nestMatrix nestMatrix raw_) - (Std_.pure ()) - ) -instance (GH.HasField "nestMatrix" GH.Slot RWTestCapn (R.List (R.List Nester1Capn))) where - fieldByLabel = (GH.ptrField 0) -data ListStructCapn -type instance (R.ReprFor ListStructCapn) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId ListStructCapn) where - typeId = 12802613814325702673 -instance (C.TypedStruct ListStructCapn) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate ListStructCapn) where - type AllocHint ListStructCapn = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc ListStructCapn (C.Parsed ListStructCapn)) -instance (C.AllocateList ListStructCapn) where - type ListAllocHint ListStructCapn = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc ListStructCapn (C.Parsed ListStructCapn)) -data instance C.Parsed ListStructCapn - = ListStructCapn - {vec :: (RP.Parsed (R.List Nester1Capn))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed ListStructCapn)) -deriving instance (Std_.Eq (C.Parsed ListStructCapn)) -instance (C.Parse ListStructCapn (C.Parsed ListStructCapn)) where - parse raw_ = (ListStructCapn <$> (GH.parseField #vec raw_)) -instance (C.Marshal ListStructCapn (C.Parsed ListStructCapn)) where - marshalInto raw_ ListStructCapn{..} = (do - (GH.encodeField #vec vec raw_) - (Std_.pure ()) - ) -instance (GH.HasField "vec" GH.Slot ListStructCapn (R.List Nester1Capn)) where - fieldByLabel = (GH.ptrField 0) -data Echo -type instance (R.ReprFor Echo) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Echo) where - typeId = 10255578992688506164 -instance (C.Parse Echo (GH.Client Echo)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Echo) where - type Server Echo = Echo'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) -class (Echo'server_ s_) where - {-# MINIMAL echo'echo #-} - echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) - echo'echo _ = GH.methodUnimplemented -instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where - methodByLabel = (GH.Method 10255578992688506164 0) -data Echo'echo'params -type instance (R.ReprFor Echo'echo'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Echo'echo'params) where - typeId = 9950245657029374882 -instance (C.TypedStruct Echo'echo'params) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Echo'echo'params) where - type AllocHint Echo'echo'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Echo'echo'params (C.Parsed Echo'echo'params)) -instance (C.AllocateList Echo'echo'params) where - type ListAllocHint Echo'echo'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Echo'echo'params (C.Parsed Echo'echo'params)) -data instance C.Parsed Echo'echo'params - = Echo'echo'params - {in_ :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Echo'echo'params)) -deriving instance (Std_.Eq (C.Parsed Echo'echo'params)) -instance (C.Parse Echo'echo'params (C.Parsed Echo'echo'params)) where - parse raw_ = (Echo'echo'params <$> (GH.parseField #in_ raw_)) -instance (C.Marshal Echo'echo'params (C.Parsed Echo'echo'params)) where - marshalInto raw_ Echo'echo'params{..} = (do - (GH.encodeField #in_ in_ raw_) - (Std_.pure ()) - ) -instance (GH.HasField "in_" GH.Slot Echo'echo'params Basics.Text) where - fieldByLabel = (GH.ptrField 0) -data Echo'echo'results -type instance (R.ReprFor Echo'echo'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Echo'echo'results) where - typeId = 11184644773809847197 -instance (C.TypedStruct Echo'echo'results) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Echo'echo'results) where - type AllocHint Echo'echo'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Echo'echo'results (C.Parsed Echo'echo'results)) -instance (C.AllocateList Echo'echo'results) where - type ListAllocHint Echo'echo'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Echo'echo'results (C.Parsed Echo'echo'results)) -data instance C.Parsed Echo'echo'results - = Echo'echo'results - {out :: (RP.Parsed Basics.Text)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Echo'echo'results)) -deriving instance (Std_.Eq (C.Parsed Echo'echo'results)) -instance (C.Parse Echo'echo'results (C.Parsed Echo'echo'results)) where - parse raw_ = (Echo'echo'results <$> (GH.parseField #out raw_)) -instance (C.Marshal Echo'echo'results (C.Parsed Echo'echo'results)) where - marshalInto raw_ Echo'echo'results{..} = (do - (GH.encodeField #out out raw_) - (Std_.pure ()) - ) -instance (GH.HasField "out" GH.Slot Echo'echo'results Basics.Text) where - fieldByLabel = (GH.ptrField 0) -data Hoth -type instance (R.ReprFor Hoth) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Hoth) where - typeId = 12504202882178935737 -instance (C.TypedStruct Hoth) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate Hoth) where - type AllocHint Hoth = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Hoth (C.Parsed Hoth)) -instance (C.AllocateList Hoth) where - type ListAllocHint Hoth = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Hoth (C.Parsed Hoth)) -data instance C.Parsed Hoth - = Hoth - {base :: (RP.Parsed EchoBase)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Hoth)) -deriving instance (Std_.Eq (C.Parsed Hoth)) -instance (C.Parse Hoth (C.Parsed Hoth)) where - parse raw_ = (Hoth <$> (GH.parseField #base raw_)) -instance (C.Marshal Hoth (C.Parsed Hoth)) where - marshalInto raw_ Hoth{..} = (do - (GH.encodeField #base base raw_) - (Std_.pure ()) - ) -instance (GH.HasField "base" GH.Slot Hoth EchoBase) where - fieldByLabel = (GH.ptrField 0) -data EchoBase -type instance (R.ReprFor EchoBase) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId EchoBase) where - typeId = 12159459504633104486 -instance (C.TypedStruct EchoBase) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate EchoBase) where - type AllocHint EchoBase = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc EchoBase (C.Parsed EchoBase)) -instance (C.AllocateList EchoBase) where - type ListAllocHint EchoBase = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc EchoBase (C.Parsed EchoBase)) -data instance C.Parsed EchoBase - = EchoBase - {echo :: (RP.Parsed Echo)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed EchoBase)) -deriving instance (Std_.Eq (C.Parsed EchoBase)) -instance (C.Parse EchoBase (C.Parsed EchoBase)) where - parse raw_ = (EchoBase <$> (GH.parseField #echo raw_)) -instance (C.Marshal EchoBase (C.Parsed EchoBase)) where - marshalInto raw_ EchoBase{..} = (do - (GH.encodeField #echo echo raw_) - (Std_.pure ()) - ) -instance (GH.HasField "echo" GH.Slot EchoBase Echo) where - fieldByLabel = (GH.ptrField 0) -data EchoBases -type instance (R.ReprFor EchoBases) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId EchoBases) where - typeId = 13848178635387355324 -instance (C.TypedStruct EchoBases) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate EchoBases) where - type AllocHint EchoBases = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc EchoBases (C.Parsed EchoBases)) -instance (C.AllocateList EchoBases) where - type ListAllocHint EchoBases = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc EchoBases (C.Parsed EchoBases)) -data instance C.Parsed EchoBases - = EchoBases - {bases :: (RP.Parsed (R.List EchoBase))} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed EchoBases)) -deriving instance (Std_.Eq (C.Parsed EchoBases)) -instance (C.Parse EchoBases (C.Parsed EchoBases)) where - parse raw_ = (EchoBases <$> (GH.parseField #bases raw_)) -instance (C.Marshal EchoBases (C.Parsed EchoBases)) where - marshalInto raw_ EchoBases{..} = (do - (GH.encodeField #bases bases raw_) - (Std_.pure ()) - ) -instance (GH.HasField "bases" GH.Slot EchoBases (R.List EchoBase)) where - fieldByLabel = (GH.ptrField 0) -data StackingRoot -type instance (R.ReprFor StackingRoot) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId StackingRoot) where - typeId = 10353348115798411408 -instance (C.TypedStruct StackingRoot) where - numStructWords = 0 - numStructPtrs = 2 -instance (C.Allocate StackingRoot) where - type AllocHint StackingRoot = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc StackingRoot (C.Parsed StackingRoot)) -instance (C.AllocateList StackingRoot) where - type ListAllocHint StackingRoot = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc StackingRoot (C.Parsed StackingRoot)) -data instance C.Parsed StackingRoot - = StackingRoot - {aWithDefault :: (RP.Parsed StackingA) - ,a :: (RP.Parsed StackingA)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed StackingRoot)) -deriving instance (Std_.Eq (C.Parsed StackingRoot)) -instance (C.Parse StackingRoot (C.Parsed StackingRoot)) where - parse raw_ = (StackingRoot <$> (GH.parseField #aWithDefault raw_) - <*> (GH.parseField #a raw_)) -instance (C.Marshal StackingRoot (C.Parsed StackingRoot)) where - marshalInto raw_ StackingRoot{..} = (do - (GH.encodeField #aWithDefault aWithDefault raw_) - (GH.encodeField #a a raw_) - (Std_.pure ()) - ) -instance (GH.HasField "aWithDefault" GH.Slot StackingRoot StackingA) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "a" GH.Slot StackingRoot StackingA) where - fieldByLabel = (GH.ptrField 1) -data StackingA -type instance (R.ReprFor StackingA) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId StackingA) where - typeId = 11326609135883271029 -instance (C.TypedStruct StackingA) where - numStructWords = 1 - numStructPtrs = 1 -instance (C.Allocate StackingA) where - type AllocHint StackingA = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc StackingA (C.Parsed StackingA)) -instance (C.AllocateList StackingA) where - type ListAllocHint StackingA = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc StackingA (C.Parsed StackingA)) -data instance C.Parsed StackingA - = StackingA - {num :: (RP.Parsed Std_.Int32) - ,b :: (RP.Parsed StackingB)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed StackingA)) -deriving instance (Std_.Eq (C.Parsed StackingA)) -instance (C.Parse StackingA (C.Parsed StackingA)) where - parse raw_ = (StackingA <$> (GH.parseField #num raw_) - <*> (GH.parseField #b raw_)) -instance (C.Marshal StackingA (C.Parsed StackingA)) where - marshalInto raw_ StackingA{..} = (do - (GH.encodeField #num num raw_) - (GH.encodeField #b b raw_) - (Std_.pure ()) - ) -instance (GH.HasField "num" GH.Slot StackingA Std_.Int32) where - fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "b" GH.Slot StackingA StackingB) where - fieldByLabel = (GH.ptrField 0) -data StackingB -type instance (R.ReprFor StackingB) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId StackingB) where - typeId = 9594210030877276357 -instance (C.TypedStruct StackingB) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate StackingB) where - type AllocHint StackingB = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc StackingB (C.Parsed StackingB)) -instance (C.AllocateList StackingB) where - type ListAllocHint StackingB = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc StackingB (C.Parsed StackingB)) -data instance C.Parsed StackingB - = StackingB - {num :: (RP.Parsed Std_.Int32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed StackingB)) -deriving instance (Std_.Eq (C.Parsed StackingB)) -instance (C.Parse StackingB (C.Parsed StackingB)) where - parse raw_ = (StackingB <$> (GH.parseField #num raw_)) -instance (C.Marshal StackingB (C.Parsed StackingB)) where - marshalInto raw_ StackingB{..} = (do - (GH.encodeField #num num raw_) - (Std_.pure ()) - ) -instance (GH.HasField "num" GH.Slot StackingB Std_.Int32) where - fieldByLabel = (GH.dataField 0 0 32 0) -data CallSequence -type instance (R.ReprFor CallSequence) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId CallSequence) where - typeId = 12371070827563042848 -instance (C.Parse CallSequence (GH.Client CallSequence)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export CallSequence) where - type Server CallSequence = CallSequence'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CallSequence)) [(GH.toUntypedMethodHandler ((callSequence'getNumber) s_))] []) -class (CallSequence'server_ s_) where - {-# MINIMAL callSequence'getNumber #-} - callSequence'getNumber :: s_ -> (GH.MethodHandler CallSequence'getNumber'params CallSequence'getNumber'results) - callSequence'getNumber _ = GH.methodUnimplemented -instance (GH.HasMethod "getNumber" CallSequence CallSequence'getNumber'params CallSequence'getNumber'results) where - methodByLabel = (GH.Method 12371070827563042848 0) -data CallSequence'getNumber'params -type instance (R.ReprFor CallSequence'getNumber'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CallSequence'getNumber'params) where - typeId = 17692253647948355992 -instance (C.TypedStruct CallSequence'getNumber'params) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate CallSequence'getNumber'params) where - type AllocHint CallSequence'getNumber'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) -instance (C.AllocateList CallSequence'getNumber'params) where - type ListAllocHint CallSequence'getNumber'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) -data instance C.Parsed CallSequence'getNumber'params - = CallSequence'getNumber'params - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CallSequence'getNumber'params)) -deriving instance (Std_.Eq (C.Parsed CallSequence'getNumber'params)) -instance (C.Parse CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) where - parse raw_ = (Std_.pure CallSequence'getNumber'params) -instance (C.Marshal CallSequence'getNumber'params (C.Parsed CallSequence'getNumber'params)) where - marshalInto _raw (CallSequence'getNumber'params) = (Std_.pure ()) -data CallSequence'getNumber'results -type instance (R.ReprFor CallSequence'getNumber'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CallSequence'getNumber'results) where - typeId = 11846148517662891671 -instance (C.TypedStruct CallSequence'getNumber'results) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate CallSequence'getNumber'results) where - type AllocHint CallSequence'getNumber'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) -instance (C.AllocateList CallSequence'getNumber'results) where - type ListAllocHint CallSequence'getNumber'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) -data instance C.Parsed CallSequence'getNumber'results - = CallSequence'getNumber'results - {n :: (RP.Parsed Std_.Word32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CallSequence'getNumber'results)) -deriving instance (Std_.Eq (C.Parsed CallSequence'getNumber'results)) -instance (C.Parse CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) where - parse raw_ = (CallSequence'getNumber'results <$> (GH.parseField #n raw_)) -instance (C.Marshal CallSequence'getNumber'results (C.Parsed CallSequence'getNumber'results)) where - marshalInto raw_ CallSequence'getNumber'results{..} = (do - (GH.encodeField #n n raw_) - (Std_.pure ()) - ) -instance (GH.HasField "n" GH.Slot CallSequence'getNumber'results Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -data CounterFactory -type instance (R.ReprFor CounterFactory) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId CounterFactory) where - typeId = 15610220054254702620 -instance (C.Parse CounterFactory (GH.Client CounterFactory)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export CounterFactory) where - type Server CounterFactory = CounterFactory'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CounterFactory)) [(GH.toUntypedMethodHandler ((counterFactory'newCounter) s_))] []) -class (CounterFactory'server_ s_) where - {-# MINIMAL counterFactory'newCounter #-} - counterFactory'newCounter :: s_ -> (GH.MethodHandler CounterFactory'newCounter'params CounterFactory'newCounter'results) - counterFactory'newCounter _ = GH.methodUnimplemented -instance (GH.HasMethod "newCounter" CounterFactory CounterFactory'newCounter'params CounterFactory'newCounter'results) where - methodByLabel = (GH.Method 15610220054254702620 0) -data CounterFactory'newCounter'params -type instance (R.ReprFor CounterFactory'newCounter'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CounterFactory'newCounter'params) where - typeId = 17606593106159030387 -instance (C.TypedStruct CounterFactory'newCounter'params) where - numStructWords = 1 - numStructPtrs = 0 -instance (C.Allocate CounterFactory'newCounter'params) where - type AllocHint CounterFactory'newCounter'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) -instance (C.AllocateList CounterFactory'newCounter'params) where - type ListAllocHint CounterFactory'newCounter'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) -data instance C.Parsed CounterFactory'newCounter'params - = CounterFactory'newCounter'params - {start :: (RP.Parsed Std_.Word32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CounterFactory'newCounter'params)) -deriving instance (Std_.Eq (C.Parsed CounterFactory'newCounter'params)) -instance (C.Parse CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) where - parse raw_ = (CounterFactory'newCounter'params <$> (GH.parseField #start raw_)) -instance (C.Marshal CounterFactory'newCounter'params (C.Parsed CounterFactory'newCounter'params)) where - marshalInto raw_ CounterFactory'newCounter'params{..} = (do - (GH.encodeField #start start raw_) - (Std_.pure ()) - ) -instance (GH.HasField "start" GH.Slot CounterFactory'newCounter'params Std_.Word32) where - fieldByLabel = (GH.dataField 0 0 32 0) -data CounterFactory'newCounter'results -type instance (R.ReprFor CounterFactory'newCounter'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CounterFactory'newCounter'results) where - typeId = 14063453475556553460 -instance (C.TypedStruct CounterFactory'newCounter'results) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate CounterFactory'newCounter'results) where - type AllocHint CounterFactory'newCounter'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) -instance (C.AllocateList CounterFactory'newCounter'results) where - type ListAllocHint CounterFactory'newCounter'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) -data instance C.Parsed CounterFactory'newCounter'results - = CounterFactory'newCounter'results - {counter :: (RP.Parsed CallSequence)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CounterFactory'newCounter'results)) -deriving instance (Std_.Eq (C.Parsed CounterFactory'newCounter'results)) -instance (C.Parse CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) where - parse raw_ = (CounterFactory'newCounter'results <$> (GH.parseField #counter raw_)) -instance (C.Marshal CounterFactory'newCounter'results (C.Parsed CounterFactory'newCounter'results)) where - marshalInto raw_ CounterFactory'newCounter'results{..} = (do - (GH.encodeField #counter counter raw_) - (Std_.pure ()) - ) -instance (GH.HasField "counter" GH.Slot CounterFactory'newCounter'results CallSequence) where - fieldByLabel = (GH.ptrField 0) -data CounterAcceptor -type instance (R.ReprFor CounterAcceptor) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId CounterAcceptor) where - typeId = 14317498215560924065 -instance (C.Parse CounterAcceptor (GH.Client CounterAcceptor)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export CounterAcceptor) where - type Server CounterAcceptor = CounterAcceptor'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CounterAcceptor)) [(GH.toUntypedMethodHandler ((counterAcceptor'accept) s_))] []) -class (CounterAcceptor'server_ s_) where - {-# MINIMAL counterAcceptor'accept #-} - counterAcceptor'accept :: s_ -> (GH.MethodHandler CounterAcceptor'accept'params CounterAcceptor'accept'results) - counterAcceptor'accept _ = GH.methodUnimplemented -instance (GH.HasMethod "accept" CounterAcceptor CounterAcceptor'accept'params CounterAcceptor'accept'results) where - methodByLabel = (GH.Method 14317498215560924065 0) -data CounterAcceptor'accept'params -type instance (R.ReprFor CounterAcceptor'accept'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CounterAcceptor'accept'params) where - typeId = 9397955985493553485 -instance (C.TypedStruct CounterAcceptor'accept'params) where - numStructWords = 0 - numStructPtrs = 1 -instance (C.Allocate CounterAcceptor'accept'params) where - type AllocHint CounterAcceptor'accept'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) -instance (C.AllocateList CounterAcceptor'accept'params) where - type ListAllocHint CounterAcceptor'accept'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) -data instance C.Parsed CounterAcceptor'accept'params - = CounterAcceptor'accept'params - {counter :: (RP.Parsed CallSequence)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CounterAcceptor'accept'params)) -deriving instance (Std_.Eq (C.Parsed CounterAcceptor'accept'params)) -instance (C.Parse CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) where - parse raw_ = (CounterAcceptor'accept'params <$> (GH.parseField #counter raw_)) -instance (C.Marshal CounterAcceptor'accept'params (C.Parsed CounterAcceptor'accept'params)) where - marshalInto raw_ CounterAcceptor'accept'params{..} = (do - (GH.encodeField #counter counter raw_) - (Std_.pure ()) - ) -instance (GH.HasField "counter" GH.Slot CounterAcceptor'accept'params CallSequence) where - fieldByLabel = (GH.ptrField 0) -data CounterAcceptor'accept'results -type instance (R.ReprFor CounterAcceptor'accept'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId CounterAcceptor'accept'results) where - typeId = 12945664473818918456 -instance (C.TypedStruct CounterAcceptor'accept'results) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate CounterAcceptor'accept'results) where - type AllocHint CounterAcceptor'accept'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) -instance (C.AllocateList CounterAcceptor'accept'results) where - type ListAllocHint CounterAcceptor'accept'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) -data instance C.Parsed CounterAcceptor'accept'results - = CounterAcceptor'accept'results - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed CounterAcceptor'accept'results)) -deriving instance (Std_.Eq (C.Parsed CounterAcceptor'accept'results)) -instance (C.Parse CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) where - parse raw_ = (Std_.pure CounterAcceptor'accept'results) -instance (C.Marshal CounterAcceptor'accept'results (C.Parsed CounterAcceptor'accept'results)) where - marshalInto _raw (CounterAcceptor'accept'results) = (Std_.pure ()) -data Top -type instance (R.ReprFor Top) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Top) where - typeId = 17861645508359101525 -instance (C.Parse Top (GH.Client Top)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Top) where - type Server Top = Top'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Top)) [(GH.toUntypedMethodHandler ((top'top) s_))] []) -class (Top'server_ s_) where - {-# MINIMAL top'top #-} - top'top :: s_ -> (GH.MethodHandler Top'top'params Top'top'results) - top'top _ = GH.methodUnimplemented -instance (GH.HasMethod "top" Top Top'top'params Top'top'results) where - methodByLabel = (GH.Method 17861645508359101525 0) -data Top'top'params -type instance (R.ReprFor Top'top'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Top'top'params) where - typeId = 9393200598485985531 -instance (C.TypedStruct Top'top'params) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Top'top'params) where - type AllocHint Top'top'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Top'top'params (C.Parsed Top'top'params)) -instance (C.AllocateList Top'top'params) where - type ListAllocHint Top'top'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Top'top'params (C.Parsed Top'top'params)) -data instance C.Parsed Top'top'params - = Top'top'params - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Top'top'params)) -deriving instance (Std_.Eq (C.Parsed Top'top'params)) -instance (C.Parse Top'top'params (C.Parsed Top'top'params)) where - parse raw_ = (Std_.pure Top'top'params) -instance (C.Marshal Top'top'params (C.Parsed Top'top'params)) where - marshalInto _raw (Top'top'params) = (Std_.pure ()) -data Top'top'results -type instance (R.ReprFor Top'top'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Top'top'results) where - typeId = 15495666596821516773 -instance (C.TypedStruct Top'top'results) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Top'top'results) where - type AllocHint Top'top'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Top'top'results (C.Parsed Top'top'results)) -instance (C.AllocateList Top'top'results) where - type ListAllocHint Top'top'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Top'top'results (C.Parsed Top'top'results)) -data instance C.Parsed Top'top'results - = Top'top'results - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Top'top'results)) -deriving instance (Std_.Eq (C.Parsed Top'top'results)) -instance (C.Parse Top'top'results (C.Parsed Top'top'results)) where - parse raw_ = (Std_.pure Top'top'results) -instance (C.Marshal Top'top'results (C.Parsed Top'top'results)) where - marshalInto _raw (Top'top'results) = (Std_.pure ()) -data Left -type instance (R.ReprFor Left) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Left) where - typeId = 17679152961798450446 -instance (C.Parse Left (GH.Client Left)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Left) where - type Server Left = Left'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Left)) [(GH.toUntypedMethodHandler ((left'left) s_))] [(GH.methodHandlerTree (GH.Proxy @(Top)) s_)]) -class ((GH.Server Top s_)) => (Left'server_ s_) where - {-# MINIMAL left'left #-} - left'left :: s_ -> (GH.MethodHandler Left'left'params Left'left'results) - left'left _ = GH.methodUnimplemented -instance (C.Super Top Left) -instance (GH.HasMethod "left" Left Left'left'params Left'left'results) where - methodByLabel = (GH.Method 17679152961798450446 0) -data Left'left'params -type instance (R.ReprFor Left'left'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Left'left'params) where - typeId = 15491006379377963583 -instance (C.TypedStruct Left'left'params) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Left'left'params) where - type AllocHint Left'left'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Left'left'params (C.Parsed Left'left'params)) -instance (C.AllocateList Left'left'params) where - type ListAllocHint Left'left'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Left'left'params (C.Parsed Left'left'params)) -data instance C.Parsed Left'left'params - = Left'left'params - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Left'left'params)) -deriving instance (Std_.Eq (C.Parsed Left'left'params)) -instance (C.Parse Left'left'params (C.Parsed Left'left'params)) where - parse raw_ = (Std_.pure Left'left'params) -instance (C.Marshal Left'left'params (C.Parsed Left'left'params)) where - marshalInto _raw (Left'left'params) = (Std_.pure ()) -data Left'left'results -type instance (R.ReprFor Left'left'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Left'left'results) where - typeId = 14681384339713198083 -instance (C.TypedStruct Left'left'results) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Left'left'results) where - type AllocHint Left'left'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Left'left'results (C.Parsed Left'left'results)) -instance (C.AllocateList Left'left'results) where - type ListAllocHint Left'left'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Left'left'results (C.Parsed Left'left'results)) -data instance C.Parsed Left'left'results - = Left'left'results - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Left'left'results)) -deriving instance (Std_.Eq (C.Parsed Left'left'results)) -instance (C.Parse Left'left'results (C.Parsed Left'left'results)) where - parse raw_ = (Std_.pure Left'left'results) -instance (C.Marshal Left'left'results (C.Parsed Left'left'results)) where - marshalInto _raw (Left'left'results) = (Std_.pure ()) -data Right -type instance (R.ReprFor Right) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Right) where - typeId = 14712639595305348988 -instance (C.Parse Right (GH.Client Right)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Right) where - type Server Right = Right'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Right)) [(GH.toUntypedMethodHandler ((right'right) s_))] [(GH.methodHandlerTree (GH.Proxy @(Top)) s_)]) -class ((GH.Server Top s_)) => (Right'server_ s_) where - {-# MINIMAL right'right #-} - right'right :: s_ -> (GH.MethodHandler Right'right'params Right'right'results) - right'right _ = GH.methodUnimplemented -instance (C.Super Top Right) -instance (GH.HasMethod "right" Right Right'right'params Right'right'results) where - methodByLabel = (GH.Method 14712639595305348988 0) -data Right'right'params -type instance (R.ReprFor Right'right'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Right'right'params) where - typeId = 17692925949004434588 -instance (C.TypedStruct Right'right'params) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Right'right'params) where - type AllocHint Right'right'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Right'right'params (C.Parsed Right'right'params)) -instance (C.AllocateList Right'right'params) where - type ListAllocHint Right'right'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Right'right'params (C.Parsed Right'right'params)) -data instance C.Parsed Right'right'params - = Right'right'params - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Right'right'params)) -deriving instance (Std_.Eq (C.Parsed Right'right'params)) -instance (C.Parse Right'right'params (C.Parsed Right'right'params)) where - parse raw_ = (Std_.pure Right'right'params) -instance (C.Marshal Right'right'params (C.Parsed Right'right'params)) where - marshalInto _raw (Right'right'params) = (Std_.pure ()) -data Right'right'results -type instance (R.ReprFor Right'right'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Right'right'results) where - typeId = 12438774687365689496 -instance (C.TypedStruct Right'right'results) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Right'right'results) where - type AllocHint Right'right'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Right'right'results (C.Parsed Right'right'results)) -instance (C.AllocateList Right'right'results) where - type ListAllocHint Right'right'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Right'right'results (C.Parsed Right'right'results)) -data instance C.Parsed Right'right'results - = Right'right'results - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Right'right'results)) -deriving instance (Std_.Eq (C.Parsed Right'right'results)) -instance (C.Parse Right'right'results (C.Parsed Right'right'results)) where - parse raw_ = (Std_.pure Right'right'results) -instance (C.Marshal Right'right'results (C.Parsed Right'right'results)) where - marshalInto _raw (Right'right'results) = (Std_.pure ()) -data Bottom -type instance (R.ReprFor Bottom) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId Bottom) where - typeId = 18402872613340521775 -instance (C.Parse Bottom (GH.Client Bottom)) where - parse = GH.parseCap - encode = GH.encodeCap -instance (GH.Export Bottom) where - type Server Bottom = Bottom'server_ - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Bottom)) [(GH.toUntypedMethodHandler ((bottom'bottom) s_))] [(GH.methodHandlerTree (GH.Proxy @(Left)) s_) - ,(GH.methodHandlerTree (GH.Proxy @(Right)) s_)]) -class ((GH.Server Left s_) - ,(GH.Server Right s_)) => (Bottom'server_ s_) where - {-# MINIMAL bottom'bottom #-} - bottom'bottom :: s_ -> (GH.MethodHandler Bottom'bottom'params Bottom'bottom'results) - bottom'bottom _ = GH.methodUnimplemented -instance (C.Super Left Bottom) -instance (C.Super Right Bottom) -instance (GH.HasMethod "bottom" Bottom Bottom'bottom'params Bottom'bottom'results) where - methodByLabel = (GH.Method 18402872613340521775 0) -data Bottom'bottom'params -type instance (R.ReprFor Bottom'bottom'params) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Bottom'bottom'params) where - typeId = 12919405706404437540 -instance (C.TypedStruct Bottom'bottom'params) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Bottom'bottom'params) where - type AllocHint Bottom'bottom'params = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Bottom'bottom'params (C.Parsed Bottom'bottom'params)) -instance (C.AllocateList Bottom'bottom'params) where - type ListAllocHint Bottom'bottom'params = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Bottom'bottom'params (C.Parsed Bottom'bottom'params)) -data instance C.Parsed Bottom'bottom'params - = Bottom'bottom'params - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Bottom'bottom'params)) -deriving instance (Std_.Eq (C.Parsed Bottom'bottom'params)) -instance (C.Parse Bottom'bottom'params (C.Parsed Bottom'bottom'params)) where - parse raw_ = (Std_.pure Bottom'bottom'params) -instance (C.Marshal Bottom'bottom'params (C.Parsed Bottom'bottom'params)) where - marshalInto _raw (Bottom'bottom'params) = (Std_.pure ()) -data Bottom'bottom'results -type instance (R.ReprFor Bottom'bottom'results) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Bottom'bottom'results) where - typeId = 10197200620860118778 -instance (C.TypedStruct Bottom'bottom'results) where - numStructWords = 0 - numStructPtrs = 0 -instance (C.Allocate Bottom'bottom'results) where - type AllocHint Bottom'bottom'results = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Bottom'bottom'results (C.Parsed Bottom'bottom'results)) -instance (C.AllocateList Bottom'bottom'results) where - type ListAllocHint Bottom'bottom'results = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Bottom'bottom'results (C.Parsed Bottom'bottom'results)) -data instance C.Parsed Bottom'bottom'results - = Bottom'bottom'results - {} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Bottom'bottom'results)) -deriving instance (Std_.Eq (C.Parsed Bottom'bottom'results)) -instance (C.Parse Bottom'bottom'results (C.Parsed Bottom'bottom'results)) where - parse raw_ = (Std_.pure Bottom'bottom'results) -instance (C.Marshal Bottom'bottom'results (C.Parsed Bottom'bottom'results)) where - marshalInto _raw (Bottom'bottom'results) = (Std_.pure ()) -data Defaults -type instance (R.ReprFor Defaults) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId Defaults) where - typeId = 10944742465095042957 -instance (C.TypedStruct Defaults) where - numStructWords = 2 - numStructPtrs = 2 -instance (C.Allocate Defaults) where - type AllocHint Defaults = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc Defaults (C.Parsed Defaults)) -instance (C.AllocateList Defaults) where - type ListAllocHint Defaults = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc Defaults (C.Parsed Defaults)) -data instance C.Parsed Defaults - = Defaults - {text :: (RP.Parsed Basics.Text) - ,data_ :: (RP.Parsed Basics.Data) - ,float :: (RP.Parsed Std_.Float) - ,int :: (RP.Parsed Std_.Int32) - ,uint :: (RP.Parsed Std_.Word32)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed Defaults)) -deriving instance (Std_.Eq (C.Parsed Defaults)) -instance (C.Parse Defaults (C.Parsed Defaults)) where - parse raw_ = (Defaults <$> (GH.parseField #text raw_) - <*> (GH.parseField #data_ raw_) - <*> (GH.parseField #float raw_) - <*> (GH.parseField #int raw_) - <*> (GH.parseField #uint raw_)) -instance (C.Marshal Defaults (C.Parsed Defaults)) where - marshalInto raw_ Defaults{..} = (do - (GH.encodeField #text text raw_) - (GH.encodeField #data_ data_ raw_) - (GH.encodeField #float float raw_) - (GH.encodeField #int int raw_) - (GH.encodeField #uint uint raw_) - (Std_.pure ()) - ) -instance (GH.HasField "text" GH.Slot Defaults Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "data_" GH.Slot Defaults Basics.Data) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "float" GH.Slot Defaults Std_.Float) where - fieldByLabel = (GH.dataField 0 0 32 1078523331) -instance (GH.HasField "int" GH.Slot Defaults Std_.Int32) where - fieldByLabel = (GH.dataField 32 0 32 18446744073709551493) -instance (GH.HasField "uint" GH.Slot Defaults Std_.Word32) where - fieldByLabel = (GH.dataField 0 1 32 42) -data BenchmarkA -type instance (R.ReprFor BenchmarkA) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId BenchmarkA) where - typeId = 16008637057130021148 -instance (C.TypedStruct BenchmarkA) where - numStructWords = 3 - numStructPtrs = 2 -instance (C.Allocate BenchmarkA) where - type AllocHint BenchmarkA = () - new _ = C.newTypedStruct -instance (C.EstimateAlloc BenchmarkA (C.Parsed BenchmarkA)) -instance (C.AllocateList BenchmarkA) where - type ListAllocHint BenchmarkA = Std_.Int - newList = C.newTypedStructList -instance (C.EstimateListAlloc BenchmarkA (C.Parsed BenchmarkA)) -data instance C.Parsed BenchmarkA - = BenchmarkA - {name :: (RP.Parsed Basics.Text) - ,birthDay :: (RP.Parsed Std_.Int64) - ,phone :: (RP.Parsed Basics.Text) - ,siblings :: (RP.Parsed Std_.Int32) - ,spouse :: (RP.Parsed Std_.Bool) - ,money :: (RP.Parsed Std_.Double)} - deriving(Generics.Generic) -deriving instance (Std_.Show (C.Parsed BenchmarkA)) -deriving instance (Std_.Eq (C.Parsed BenchmarkA)) -instance (C.Parse BenchmarkA (C.Parsed BenchmarkA)) where - parse raw_ = (BenchmarkA <$> (GH.parseField #name raw_) - <*> (GH.parseField #birthDay raw_) - <*> (GH.parseField #phone raw_) - <*> (GH.parseField #siblings raw_) - <*> (GH.parseField #spouse raw_) - <*> (GH.parseField #money raw_)) -instance (C.Marshal BenchmarkA (C.Parsed BenchmarkA)) where - marshalInto raw_ BenchmarkA{..} = (do - (GH.encodeField #name name raw_) - (GH.encodeField #birthDay birthDay raw_) - (GH.encodeField #phone phone raw_) - (GH.encodeField #siblings siblings raw_) - (GH.encodeField #spouse spouse raw_) - (GH.encodeField #money money raw_) - (Std_.pure ()) - ) -instance (GH.HasField "name" GH.Slot BenchmarkA Basics.Text) where - fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "birthDay" GH.Slot BenchmarkA Std_.Int64) where - fieldByLabel = (GH.dataField 0 0 64 0) -instance (GH.HasField "phone" GH.Slot BenchmarkA Basics.Text) where - fieldByLabel = (GH.ptrField 1) -instance (GH.HasField "siblings" GH.Slot BenchmarkA Std_.Int32) where - fieldByLabel = (GH.dataField 0 1 32 0) -instance (GH.HasField "spouse" GH.Slot BenchmarkA Std_.Bool) where - fieldByLabel = (GH.dataField 32 1 1 0) -instance (GH.HasField "money" GH.Slot BenchmarkA Std_.Double) where - fieldByLabel = (GH.dataField 0 2 64 0) diff --git a/gen/tests/Capnp/Gen/ById/X832bcc6686a26d56.hs b/gen/tests/Capnp/Gen/ById/X832bcc6686a26d56.hs new file mode 100644 --- /dev/null +++ b/gen/tests/Capnp/Gen/ById/X832bcc6686a26d56.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.X832bcc6686a26d56(module Capnp.Gen.Aircraft) where +import Capnp.Gen.Aircraft +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/tests/Capnp/Gen/ById/X832bcc6686a26d56/New.hs b/gen/tests/Capnp/Gen/ById/X832bcc6686a26d56/New.hs deleted file mode 100644 --- a/gen/tests/Capnp/Gen/ById/X832bcc6686a26d56/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.X832bcc6686a26d56.New(module Capnp.Gen.Aircraft.New) where -import Capnp.Gen.Aircraft.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144.hs b/gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144.hs new file mode 100644 --- /dev/null +++ b/gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.ById.Xb6421fb8e478d144(module Capnp.Gen.Generics) where +import Capnp.Gen.Generics +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144/New.hs b/gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144/New.hs deleted file mode 100644 --- a/gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144/New.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.ById.Xb6421fb8e478d144.New(module Capnp.Gen.Generics.New) where -import Capnp.Gen.Generics.New -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) diff --git a/gen/tests/Capnp/Gen/Generics.hs b/gen/tests/Capnp/Gen/Generics.hs new file mode 100644 --- /dev/null +++ b/gen/tests/Capnp/Gen/Generics.hs @@ -0,0 +1,468 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -Wno-dodgy-exports #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} +{-# OPTIONS_GHC -Wno-name-shadowing #-} +module Capnp.Gen.Generics where +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP +import qualified Capnp.Basics as Basics +import qualified GHC.OverloadedLabels as OL +import qualified Capnp.GenHelpers as GH +import qualified Capnp.Classes as C +import qualified GHC.Generics as Generics +import qualified Capnp.GenHelpers.Rpc as GH +import qualified Prelude as Std_ +import qualified Data.Word as Std_ +import qualified Data.Int as Std_ +import Prelude ((<$>), (<*>), (>>=)) +data Maybe t +type instance (R.ReprFor (Maybe t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Maybe t)) where + typeId = 12834113532530355529 +instance ((GH.TypeParam t)) => (C.TypedStruct (Maybe t)) where + numStructWords = 1 + numStructPtrs = 1 +instance ((GH.TypeParam t)) => (C.Allocate (Maybe t)) where + type AllocHint (Maybe t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (Maybe t) (C.Parsed (Maybe t))) +instance ((GH.TypeParam t)) => (C.AllocateList (Maybe t)) where + type ListAllocHint (Maybe t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Maybe t) (C.Parsed (Maybe t))) +data instance C.Parsed (Maybe t) + = Maybe + {union' :: (C.Parsed (GH.Which (Maybe t)))} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Maybe t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Maybe t))) +instance ((GH.TypeParam t)) => (C.Parse (Maybe t) (C.Parsed (Maybe t))) where + parse raw_ = (Maybe <$> (C.parse (GH.structUnion raw_))) +instance ((GH.TypeParam t)) => (C.Marshal (Maybe t) (C.Parsed (Maybe t))) where + marshalInto raw_ Maybe{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance ((GH.TypeParam t)) => (GH.HasUnion (Maybe t)) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich (Maybe t) mut_ + = RW_Maybe'nothing (R.Raw () mut_) + | RW_Maybe'just (R.Raw t mut_) + | RW_Maybe'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Maybe'nothing <$> (GH.readVariant #nothing struct_)) + 1 -> + (RW_Maybe'just <$> (GH.readVariant #just struct_)) + _ -> + (Std_.pure (RW_Maybe'unknown' tag_)) + data Which (Maybe t) +instance ((GH.TypeParam t)) => (GH.HasVariant "nothing" GH.Slot (Maybe t) ()) where + variantByLabel = (GH.Variant GH.voidField 0) +instance ((GH.TypeParam t)) => (GH.HasVariant "just" GH.Slot (Maybe t) t) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +data instance C.Parsed (GH.Which (Maybe t)) + = Maybe'nothing + | Maybe'just (RP.Parsed t) + | Maybe'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (GH.Which (Maybe t)))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (GH.Which (Maybe t)))) +instance ((GH.TypeParam t)) => (C.Parse (GH.Which (Maybe t)) (C.Parsed (GH.Which (Maybe t)))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Maybe'nothing _) -> + (Std_.pure Maybe'nothing) + (RW_Maybe'just rawArg_) -> + (Maybe'just <$> (C.parse rawArg_)) + (RW_Maybe'unknown' tag_) -> + (Std_.pure (Maybe'unknown' tag_)) + ) +instance ((GH.TypeParam t)) => (C.Marshal (GH.Which (Maybe t)) (C.Parsed (GH.Which (Maybe t)))) where + marshalInto raw_ parsed_ = case parsed_ of + (Maybe'nothing) -> + (GH.encodeVariant #nothing () (GH.unionStruct raw_)) + (Maybe'just arg_) -> + (GH.encodeVariant #just arg_ (GH.unionStruct raw_)) + (Maybe'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Either a b +type instance (R.ReprFor (Either a b)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Either a b)) where + typeId = 16016919828037144358 +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.TypedStruct (Either a b)) where + numStructWords = 1 + numStructPtrs = 1 +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Allocate (Either a b)) where + type AllocHint (Either a b) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.EstimateAlloc (Either a b) (C.Parsed (Either a b))) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.AllocateList (Either a b)) where + type ListAllocHint (Either a b) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.EstimateListAlloc (Either a b) (C.Parsed (Either a b))) +data instance C.Parsed (Either a b) + = Either + {union' :: (C.Parsed (GH.Which (Either a b)))} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed a)) + ,(Std_.Show (RP.Parsed b))) => (Std_.Show (C.Parsed (Either a b))) +deriving instance ((Std_.Eq (RP.Parsed a)) + ,(Std_.Eq (RP.Parsed b))) => (Std_.Eq (C.Parsed (Either a b))) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Parse (Either a b) (C.Parsed (Either a b))) where + parse raw_ = (Either <$> (C.parse (GH.structUnion raw_))) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Marshal (Either a b) (C.Parsed (Either a b))) where + marshalInto raw_ Either{..} = (do + (C.marshalInto (GH.structUnion raw_) union') + ) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (GH.HasUnion (Either a b)) where + unionField = (GH.dataField 0 0 16 0) + data RawWhich (Either a b) mut_ + = RW_Either'left (R.Raw a mut_) + | RW_Either'right (R.Raw b mut_) + | RW_Either'unknown' Std_.Word16 + internalWhich tag_ struct_ = case tag_ of + 0 -> + (RW_Either'left <$> (GH.readVariant #left struct_)) + 1 -> + (RW_Either'right <$> (GH.readVariant #right struct_)) + _ -> + (Std_.pure (RW_Either'unknown' tag_)) + data Which (Either a b) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (GH.HasVariant "left" GH.Slot (Either a b) a) where + variantByLabel = (GH.Variant (GH.ptrField 0) 0) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (GH.HasVariant "right" GH.Slot (Either a b) b) where + variantByLabel = (GH.Variant (GH.ptrField 0) 1) +data instance C.Parsed (GH.Which (Either a b)) + = Either'left (RP.Parsed a) + | Either'right (RP.Parsed b) + | Either'unknown' Std_.Word16 + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed a)) + ,(Std_.Show (RP.Parsed b))) => (Std_.Show (C.Parsed (GH.Which (Either a b)))) +deriving instance ((Std_.Eq (RP.Parsed a)) + ,(Std_.Eq (RP.Parsed b))) => (Std_.Eq (C.Parsed (GH.Which (Either a b)))) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Parse (GH.Which (Either a b)) (C.Parsed (GH.Which (Either a b)))) where + parse raw_ = (do + rawWhich_ <- (GH.unionWhich raw_) + case rawWhich_ of + (RW_Either'left rawArg_) -> + (Either'left <$> (C.parse rawArg_)) + (RW_Either'right rawArg_) -> + (Either'right <$> (C.parse rawArg_)) + (RW_Either'unknown' tag_) -> + (Std_.pure (Either'unknown' tag_)) + ) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Marshal (GH.Which (Either a b)) (C.Parsed (GH.Which (Either a b)))) where + marshalInto raw_ parsed_ = case parsed_ of + (Either'left arg_) -> + (GH.encodeVariant #left arg_ (GH.unionStruct raw_)) + (Either'right arg_) -> + (GH.encodeVariant #right arg_ (GH.unionStruct raw_)) + (Either'unknown' tag_) -> + (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) +data Pair a b +type instance (R.ReprFor (Pair a b)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Pair a b)) where + typeId = 18425972019411955385 +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.TypedStruct (Pair a b)) where + numStructWords = 0 + numStructPtrs = 2 +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Allocate (Pair a b)) where + type AllocHint (Pair a b) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.EstimateAlloc (Pair a b) (C.Parsed (Pair a b))) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.AllocateList (Pair a b)) where + type ListAllocHint (Pair a b) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.EstimateListAlloc (Pair a b) (C.Parsed (Pair a b))) +data instance C.Parsed (Pair a b) + = Pair + {fst :: (RP.Parsed a) + ,snd :: (RP.Parsed b)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed a)) + ,(Std_.Show (RP.Parsed b))) => (Std_.Show (C.Parsed (Pair a b))) +deriving instance ((Std_.Eq (RP.Parsed a)) + ,(Std_.Eq (RP.Parsed b))) => (Std_.Eq (C.Parsed (Pair a b))) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Parse (Pair a b) (C.Parsed (Pair a b))) where + parse raw_ = (Pair <$> (GH.parseField #fst raw_) + <*> (GH.parseField #snd raw_)) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (C.Marshal (Pair a b) (C.Parsed (Pair a b))) where + marshalInto raw_ Pair{..} = (do + (GH.encodeField #fst fst raw_) + (GH.encodeField #snd snd raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (GH.HasField "fst" GH.Slot (Pair a b) a) where + fieldByLabel = (GH.ptrField 0) +instance ((GH.TypeParam a) + ,(GH.TypeParam b)) => (GH.HasField "snd" GH.Slot (Pair a b) b) where + fieldByLabel = (GH.ptrField 1) +data Nested t +type instance (R.ReprFor (Nested t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested t)) where + typeId = 17472990467641505320 +instance ((GH.TypeParam t)) => (C.TypedStruct (Nested t)) where + numStructWords = 0 + numStructPtrs = 0 +instance ((GH.TypeParam t)) => (C.Allocate (Nested t)) where + type AllocHint (Nested t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested t) (C.Parsed (Nested t))) +instance ((GH.TypeParam t)) => (C.AllocateList (Nested t)) where + type ListAllocHint (Nested t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested t) (C.Parsed (Nested t))) +data instance C.Parsed (Nested t) + = Nested + {} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested t))) +instance ((GH.TypeParam t)) => (C.Parse (Nested t) (C.Parsed (Nested t))) where + parse raw_ = (Std_.pure Nested) +instance ((GH.TypeParam t)) => (C.Marshal (Nested t) (C.Parsed (Nested t))) where + marshalInto _raw (Nested) = (Std_.pure ()) +data Nested'SomeStruct t +type instance (R.ReprFor (Nested'SomeStruct t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested'SomeStruct t)) where + typeId = 10581732449597785397 +instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeStruct t)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam t)) => (C.Allocate (Nested'SomeStruct t)) where + type AllocHint (Nested'SomeStruct t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) +instance ((GH.TypeParam t)) => (C.AllocateList (Nested'SomeStruct t)) where + type ListAllocHint (Nested'SomeStruct t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) +data instance C.Parsed (Nested'SomeStruct t) + = Nested'SomeStruct + {value :: (RP.Parsed t)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested'SomeStruct t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested'SomeStruct t))) +instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) where + parse raw_ = (Nested'SomeStruct <$> (GH.parseField #value raw_)) +instance ((GH.TypeParam t)) => (C.Marshal (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) where + marshalInto raw_ Nested'SomeStruct{..} = (do + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam t)) => (GH.HasField "value" GH.Slot (Nested'SomeStruct t) t) where + fieldByLabel = (GH.ptrField 0) +data Nested'SomeInterface t +type instance (R.ReprFor (Nested'SomeInterface t)) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId (Nested'SomeInterface t)) where + typeId = 17400383877992806407 +instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface t) (GH.Client (Nested'SomeInterface t))) where + parse = GH.parseCap + encode = GH.encodeCap +instance ((GH.TypeParam t)) => (GH.Export (Nested'SomeInterface t)) where + type Server (Nested'SomeInterface t) = (Nested'SomeInterface'server_ t) + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((Nested'SomeInterface t))) [(GH.toUntypedMethodHandler ((nested'SomeInterface'method @(t)) s_))] []) +class (Nested'SomeInterface'server_ t s_) where + {-# MINIMAL nested'SomeInterface'method #-} + nested'SomeInterface'method :: s_ -> (GH.MethodHandler (Nested'SomeInterface'method'params t) (Nested'SomeInterface'method'results t)) + nested'SomeInterface'method _ = GH.methodUnimplemented +instance ((GH.TypeParam t)) => (GH.HasMethod "method" (Nested'SomeInterface t) (Nested'SomeInterface'method'params t) (Nested'SomeInterface'method'results t)) where + methodByLabel = (GH.Method 17400383877992806407 0) +data Nested'SomeInterface'method'params t +type instance (R.ReprFor (Nested'SomeInterface'method'params t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested'SomeInterface'method'params t)) where + typeId = 13278839458779198088 +instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeInterface'method'params t)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam t)) => (C.Allocate (Nested'SomeInterface'method'params t)) where + type AllocHint (Nested'SomeInterface'method'params t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) +instance ((GH.TypeParam t)) => (C.AllocateList (Nested'SomeInterface'method'params t)) where + type ListAllocHint (Nested'SomeInterface'method'params t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) +data instance C.Parsed (Nested'SomeInterface'method'params t) + = Nested'SomeInterface'method'params + {arg :: (RP.Parsed t)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested'SomeInterface'method'params t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested'SomeInterface'method'params t))) +instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) where + parse raw_ = (Nested'SomeInterface'method'params <$> (GH.parseField #arg raw_)) +instance ((GH.TypeParam t)) => (C.Marshal (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) where + marshalInto raw_ Nested'SomeInterface'method'params{..} = (do + (GH.encodeField #arg arg raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam t)) => (GH.HasField "arg" GH.Slot (Nested'SomeInterface'method'params t) t) where + fieldByLabel = (GH.ptrField 0) +data Nested'SomeInterface'method'results t +type instance (R.ReprFor (Nested'SomeInterface'method'results t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested'SomeInterface'method'results t)) where + typeId = 9305012847082487733 +instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeInterface'method'results t)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam t)) => (C.Allocate (Nested'SomeInterface'method'results t)) where + type AllocHint (Nested'SomeInterface'method'results t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) +instance ((GH.TypeParam t)) => (C.AllocateList (Nested'SomeInterface'method'results t)) where + type ListAllocHint (Nested'SomeInterface'method'results t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) +data instance C.Parsed (Nested'SomeInterface'method'results t) + = Nested'SomeInterface'method'results + {result :: (RP.Parsed t)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested'SomeInterface'method'results t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested'SomeInterface'method'results t))) +instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) where + parse raw_ = (Nested'SomeInterface'method'results <$> (GH.parseField #result raw_)) +instance ((GH.TypeParam t)) => (C.Marshal (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) where + marshalInto raw_ Nested'SomeInterface'method'results{..} = (do + (GH.encodeField #result result raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam t)) => (GH.HasField "result" GH.Slot (Nested'SomeInterface'method'results t) t) where + fieldByLabel = (GH.ptrField 0) +data Specialized t +type instance (R.ReprFor (Specialized t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Specialized t)) where + typeId = 11111346635683596512 +instance ((GH.TypeParam t)) => (C.TypedStruct (Specialized t)) where + numStructWords = 0 + numStructPtrs = 2 +instance ((GH.TypeParam t)) => (C.Allocate (Specialized t)) where + type AllocHint (Specialized t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (Specialized t) (C.Parsed (Specialized t))) +instance ((GH.TypeParam t)) => (C.AllocateList (Specialized t)) where + type ListAllocHint (Specialized t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Specialized t) (C.Parsed (Specialized t))) +data instance C.Parsed (Specialized t) + = Specialized + {either :: (RP.Parsed (Either Basics.Text t)) + ,nestedStruct :: (RP.Parsed (Nested'SomeStruct Basics.Data))} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Specialized t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Specialized t))) +instance ((GH.TypeParam t)) => (C.Parse (Specialized t) (C.Parsed (Specialized t))) where + parse raw_ = (Specialized <$> (GH.parseField #either raw_) + <*> (GH.parseField #nestedStruct raw_)) +instance ((GH.TypeParam t)) => (C.Marshal (Specialized t) (C.Parsed (Specialized t))) where + marshalInto raw_ Specialized{..} = (do + (GH.encodeField #either either raw_) + (GH.encodeField #nestedStruct nestedStruct raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam t)) => (GH.HasField "either" GH.Slot (Specialized t) (Either Basics.Text t)) where + fieldByLabel = (GH.ptrField 0) +instance ((GH.TypeParam t)) => (GH.HasField "nestedStruct" GH.Slot (Specialized t) (Nested'SomeStruct Basics.Data)) where + fieldByLabel = (GH.ptrField 1) +data HasGroup t +type instance (R.ReprFor (HasGroup t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (HasGroup t)) where + typeId = 10809380793126616697 +instance ((GH.TypeParam t)) => (C.TypedStruct (HasGroup t)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam t)) => (C.Allocate (HasGroup t)) where + type AllocHint (HasGroup t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (HasGroup t) (C.Parsed (HasGroup t))) +instance ((GH.TypeParam t)) => (C.AllocateList (HasGroup t)) where + type ListAllocHint (HasGroup t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (HasGroup t) (C.Parsed (HasGroup t))) +data instance C.Parsed (HasGroup t) + = HasGroup + {theGroup :: (RP.Parsed (HasGroup'theGroup t))} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (HasGroup t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (HasGroup t))) +instance ((GH.TypeParam t)) => (C.Parse (HasGroup t) (C.Parsed (HasGroup t))) where + parse raw_ = (HasGroup <$> (GH.parseField #theGroup raw_)) +instance ((GH.TypeParam t)) => (C.Marshal (HasGroup t) (C.Parsed (HasGroup t))) where + marshalInto raw_ HasGroup{..} = (do + (do + group_ <- (GH.readField #theGroup raw_) + (C.marshalInto group_ theGroup) + ) + (Std_.pure ()) + ) +instance ((GH.TypeParam t)) => (GH.HasField "theGroup" GH.Group (HasGroup t) (HasGroup'theGroup t)) where + fieldByLabel = GH.groupField +data HasGroup'theGroup t +type instance (R.ReprFor (HasGroup'theGroup t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (HasGroup'theGroup t)) where + typeId = 13022770763187353254 +instance ((GH.TypeParam t)) => (C.TypedStruct (HasGroup'theGroup t)) where + numStructWords = 0 + numStructPtrs = 1 +instance ((GH.TypeParam t)) => (C.Allocate (HasGroup'theGroup t)) where + type AllocHint (HasGroup'theGroup t) = () + new _ = C.newTypedStruct +instance ((GH.TypeParam t)) => (C.EstimateAlloc (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) +instance ((GH.TypeParam t)) => (C.AllocateList (HasGroup'theGroup t)) where + type ListAllocHint (HasGroup'theGroup t) = Std_.Int + newList = C.newTypedStructList +instance ((GH.TypeParam t)) => (C.EstimateListAlloc (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) +data instance C.Parsed (HasGroup'theGroup t) + = HasGroup'theGroup' + {value :: (RP.Parsed t)} + deriving(Generics.Generic) +deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (HasGroup'theGroup t))) +deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (HasGroup'theGroup t))) +instance ((GH.TypeParam t)) => (C.Parse (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) where + parse raw_ = (HasGroup'theGroup' <$> (GH.parseField #value raw_)) +instance ((GH.TypeParam t)) => (C.Marshal (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) where + marshalInto raw_ HasGroup'theGroup'{..} = (do + (GH.encodeField #value value raw_) + (Std_.pure ()) + ) +instance ((GH.TypeParam t)) => (GH.HasField "value" GH.Slot (HasGroup'theGroup t) t) where + fieldByLabel = (GH.ptrField 0) diff --git a/gen/tests/Capnp/Gen/Generics/New.hs b/gen/tests/Capnp/Gen/Generics/New.hs deleted file mode 100644 --- a/gen/tests/Capnp/Gen/Generics/New.hs +++ /dev/null @@ -1,468 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unused-imports #-} -{-# OPTIONS_GHC -Wno-dodgy-exports #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-} -{-# OPTIONS_GHC -Wno-name-shadowing #-} -module Capnp.Gen.Generics.New where -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP -import qualified Capnp.New.Basics as Basics -import qualified GHC.OverloadedLabels as OL -import qualified Capnp.GenHelpers.New as GH -import qualified Capnp.New.Classes as C -import qualified GHC.Generics as Generics -import qualified Capnp.GenHelpers.New.Rpc as GH -import qualified Prelude as Std_ -import qualified Data.Word as Std_ -import qualified Data.Int as Std_ -import Prelude ((<$>), (<*>), (>>=)) -data Maybe t -type instance (R.ReprFor (Maybe t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Maybe t)) where - typeId = 12834113532530355529 -instance ((GH.TypeParam t)) => (C.TypedStruct (Maybe t)) where - numStructWords = 1 - numStructPtrs = 1 -instance ((GH.TypeParam t)) => (C.Allocate (Maybe t)) where - type AllocHint (Maybe t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (Maybe t) (C.Parsed (Maybe t))) -instance ((GH.TypeParam t)) => (C.AllocateList (Maybe t)) where - type ListAllocHint (Maybe t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Maybe t) (C.Parsed (Maybe t))) -data instance C.Parsed (Maybe t) - = Maybe - {union' :: (C.Parsed (GH.Which (Maybe t)))} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Maybe t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Maybe t))) -instance ((GH.TypeParam t)) => (C.Parse (Maybe t) (C.Parsed (Maybe t))) where - parse raw_ = (Maybe <$> (C.parse (GH.structUnion raw_))) -instance ((GH.TypeParam t)) => (C.Marshal (Maybe t) (C.Parsed (Maybe t))) where - marshalInto raw_ Maybe{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance ((GH.TypeParam t)) => (GH.HasUnion (Maybe t)) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich (Maybe t) mut_ - = RW_Maybe'nothing (R.Raw () mut_) - | RW_Maybe'just (R.Raw t mut_) - | RW_Maybe'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Maybe'nothing <$> (GH.readVariant #nothing struct_)) - 1 -> - (RW_Maybe'just <$> (GH.readVariant #just struct_)) - _ -> - (Std_.pure (RW_Maybe'unknown' tag_)) - data Which (Maybe t) -instance ((GH.TypeParam t)) => (GH.HasVariant "nothing" GH.Slot (Maybe t) ()) where - variantByLabel = (GH.Variant GH.voidField 0) -instance ((GH.TypeParam t)) => (GH.HasVariant "just" GH.Slot (Maybe t) t) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -data instance C.Parsed (GH.Which (Maybe t)) - = Maybe'nothing - | Maybe'just (RP.Parsed t) - | Maybe'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (GH.Which (Maybe t)))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (GH.Which (Maybe t)))) -instance ((GH.TypeParam t)) => (C.Parse (GH.Which (Maybe t)) (C.Parsed (GH.Which (Maybe t)))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Maybe'nothing _) -> - (Std_.pure Maybe'nothing) - (RW_Maybe'just rawArg_) -> - (Maybe'just <$> (C.parse rawArg_)) - (RW_Maybe'unknown' tag_) -> - (Std_.pure (Maybe'unknown' tag_)) - ) -instance ((GH.TypeParam t)) => (C.Marshal (GH.Which (Maybe t)) (C.Parsed (GH.Which (Maybe t)))) where - marshalInto raw_ parsed_ = case parsed_ of - (Maybe'nothing) -> - (GH.encodeVariant #nothing () (GH.unionStruct raw_)) - (Maybe'just arg_) -> - (GH.encodeVariant #just arg_ (GH.unionStruct raw_)) - (Maybe'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Either a b -type instance (R.ReprFor (Either a b)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Either a b)) where - typeId = 16016919828037144358 -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.TypedStruct (Either a b)) where - numStructWords = 1 - numStructPtrs = 1 -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Allocate (Either a b)) where - type AllocHint (Either a b) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.EstimateAlloc (Either a b) (C.Parsed (Either a b))) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.AllocateList (Either a b)) where - type ListAllocHint (Either a b) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.EstimateListAlloc (Either a b) (C.Parsed (Either a b))) -data instance C.Parsed (Either a b) - = Either - {union' :: (C.Parsed (GH.Which (Either a b)))} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed a)) - ,(Std_.Show (RP.Parsed b))) => (Std_.Show (C.Parsed (Either a b))) -deriving instance ((Std_.Eq (RP.Parsed a)) - ,(Std_.Eq (RP.Parsed b))) => (Std_.Eq (C.Parsed (Either a b))) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Parse (Either a b) (C.Parsed (Either a b))) where - parse raw_ = (Either <$> (C.parse (GH.structUnion raw_))) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Marshal (Either a b) (C.Parsed (Either a b))) where - marshalInto raw_ Either{..} = (do - (C.marshalInto (GH.structUnion raw_) union') - ) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (GH.HasUnion (Either a b)) where - unionField = (GH.dataField 0 0 16 0) - data RawWhich (Either a b) mut_ - = RW_Either'left (R.Raw a mut_) - | RW_Either'right (R.Raw b mut_) - | RW_Either'unknown' Std_.Word16 - internalWhich tag_ struct_ = case tag_ of - 0 -> - (RW_Either'left <$> (GH.readVariant #left struct_)) - 1 -> - (RW_Either'right <$> (GH.readVariant #right struct_)) - _ -> - (Std_.pure (RW_Either'unknown' tag_)) - data Which (Either a b) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (GH.HasVariant "left" GH.Slot (Either a b) a) where - variantByLabel = (GH.Variant (GH.ptrField 0) 0) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (GH.HasVariant "right" GH.Slot (Either a b) b) where - variantByLabel = (GH.Variant (GH.ptrField 0) 1) -data instance C.Parsed (GH.Which (Either a b)) - = Either'left (RP.Parsed a) - | Either'right (RP.Parsed b) - | Either'unknown' Std_.Word16 - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed a)) - ,(Std_.Show (RP.Parsed b))) => (Std_.Show (C.Parsed (GH.Which (Either a b)))) -deriving instance ((Std_.Eq (RP.Parsed a)) - ,(Std_.Eq (RP.Parsed b))) => (Std_.Eq (C.Parsed (GH.Which (Either a b)))) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Parse (GH.Which (Either a b)) (C.Parsed (GH.Which (Either a b)))) where - parse raw_ = (do - rawWhich_ <- (GH.unionWhich raw_) - case rawWhich_ of - (RW_Either'left rawArg_) -> - (Either'left <$> (C.parse rawArg_)) - (RW_Either'right rawArg_) -> - (Either'right <$> (C.parse rawArg_)) - (RW_Either'unknown' tag_) -> - (Std_.pure (Either'unknown' tag_)) - ) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Marshal (GH.Which (Either a b)) (C.Parsed (GH.Which (Either a b)))) where - marshalInto raw_ parsed_ = case parsed_ of - (Either'left arg_) -> - (GH.encodeVariant #left arg_ (GH.unionStruct raw_)) - (Either'right arg_) -> - (GH.encodeVariant #right arg_ (GH.unionStruct raw_)) - (Either'unknown' tag_) -> - (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) -data Pair a b -type instance (R.ReprFor (Pair a b)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Pair a b)) where - typeId = 18425972019411955385 -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.TypedStruct (Pair a b)) where - numStructWords = 0 - numStructPtrs = 2 -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Allocate (Pair a b)) where - type AllocHint (Pair a b) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.EstimateAlloc (Pair a b) (C.Parsed (Pair a b))) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.AllocateList (Pair a b)) where - type ListAllocHint (Pair a b) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.EstimateListAlloc (Pair a b) (C.Parsed (Pair a b))) -data instance C.Parsed (Pair a b) - = Pair - {fst :: (RP.Parsed a) - ,snd :: (RP.Parsed b)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed a)) - ,(Std_.Show (RP.Parsed b))) => (Std_.Show (C.Parsed (Pair a b))) -deriving instance ((Std_.Eq (RP.Parsed a)) - ,(Std_.Eq (RP.Parsed b))) => (Std_.Eq (C.Parsed (Pair a b))) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Parse (Pair a b) (C.Parsed (Pair a b))) where - parse raw_ = (Pair <$> (GH.parseField #fst raw_) - <*> (GH.parseField #snd raw_)) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (C.Marshal (Pair a b) (C.Parsed (Pair a b))) where - marshalInto raw_ Pair{..} = (do - (GH.encodeField #fst fst raw_) - (GH.encodeField #snd snd raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (GH.HasField "fst" GH.Slot (Pair a b) a) where - fieldByLabel = (GH.ptrField 0) -instance ((GH.TypeParam a) - ,(GH.TypeParam b)) => (GH.HasField "snd" GH.Slot (Pair a b) b) where - fieldByLabel = (GH.ptrField 1) -data Nested t -type instance (R.ReprFor (Nested t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Nested t)) where - typeId = 17472990467641505320 -instance ((GH.TypeParam t)) => (C.TypedStruct (Nested t)) where - numStructWords = 0 - numStructPtrs = 0 -instance ((GH.TypeParam t)) => (C.Allocate (Nested t)) where - type AllocHint (Nested t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested t) (C.Parsed (Nested t))) -instance ((GH.TypeParam t)) => (C.AllocateList (Nested t)) where - type ListAllocHint (Nested t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested t) (C.Parsed (Nested t))) -data instance C.Parsed (Nested t) - = Nested - {} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested t))) -instance ((GH.TypeParam t)) => (C.Parse (Nested t) (C.Parsed (Nested t))) where - parse raw_ = (Std_.pure Nested) -instance ((GH.TypeParam t)) => (C.Marshal (Nested t) (C.Parsed (Nested t))) where - marshalInto _raw (Nested) = (Std_.pure ()) -data Nested'SomeStruct t -type instance (R.ReprFor (Nested'SomeStruct t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Nested'SomeStruct t)) where - typeId = 10581732449597785397 -instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeStruct t)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam t)) => (C.Allocate (Nested'SomeStruct t)) where - type AllocHint (Nested'SomeStruct t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) -instance ((GH.TypeParam t)) => (C.AllocateList (Nested'SomeStruct t)) where - type ListAllocHint (Nested'SomeStruct t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) -data instance C.Parsed (Nested'SomeStruct t) - = Nested'SomeStruct - {value :: (RP.Parsed t)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested'SomeStruct t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested'SomeStruct t))) -instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) where - parse raw_ = (Nested'SomeStruct <$> (GH.parseField #value raw_)) -instance ((GH.TypeParam t)) => (C.Marshal (Nested'SomeStruct t) (C.Parsed (Nested'SomeStruct t))) where - marshalInto raw_ Nested'SomeStruct{..} = (do - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam t)) => (GH.HasField "value" GH.Slot (Nested'SomeStruct t) t) where - fieldByLabel = (GH.ptrField 0) -data Nested'SomeInterface t -type instance (R.ReprFor (Nested'SomeInterface t)) = (R.Ptr (Std_.Just R.Cap)) -instance (C.HasTypeId (Nested'SomeInterface t)) where - typeId = 17400383877992806407 -instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface t) (GH.Client (Nested'SomeInterface t))) where - parse = GH.parseCap - encode = GH.encodeCap -instance ((GH.TypeParam t)) => (GH.Export (Nested'SomeInterface t)) where - type Server (Nested'SomeInterface t) = (Nested'SomeInterface'server_ t) - methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((Nested'SomeInterface t))) [(GH.toUntypedMethodHandler ((nested'SomeInterface'method @(t)) s_))] []) -class (Nested'SomeInterface'server_ t s_) where - {-# MINIMAL nested'SomeInterface'method #-} - nested'SomeInterface'method :: s_ -> (GH.MethodHandler (Nested'SomeInterface'method'params t) (Nested'SomeInterface'method'results t)) - nested'SomeInterface'method _ = GH.methodUnimplemented -instance ((GH.TypeParam t)) => (GH.HasMethod "method" (Nested'SomeInterface t) (Nested'SomeInterface'method'params t) (Nested'SomeInterface'method'results t)) where - methodByLabel = (GH.Method 17400383877992806407 0) -data Nested'SomeInterface'method'params t -type instance (R.ReprFor (Nested'SomeInterface'method'params t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Nested'SomeInterface'method'params t)) where - typeId = 13278839458779198088 -instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeInterface'method'params t)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam t)) => (C.Allocate (Nested'SomeInterface'method'params t)) where - type AllocHint (Nested'SomeInterface'method'params t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) -instance ((GH.TypeParam t)) => (C.AllocateList (Nested'SomeInterface'method'params t)) where - type ListAllocHint (Nested'SomeInterface'method'params t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) -data instance C.Parsed (Nested'SomeInterface'method'params t) - = Nested'SomeInterface'method'params - {arg :: (RP.Parsed t)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested'SomeInterface'method'params t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested'SomeInterface'method'params t))) -instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) where - parse raw_ = (Nested'SomeInterface'method'params <$> (GH.parseField #arg raw_)) -instance ((GH.TypeParam t)) => (C.Marshal (Nested'SomeInterface'method'params t) (C.Parsed (Nested'SomeInterface'method'params t))) where - marshalInto raw_ Nested'SomeInterface'method'params{..} = (do - (GH.encodeField #arg arg raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam t)) => (GH.HasField "arg" GH.Slot (Nested'SomeInterface'method'params t) t) where - fieldByLabel = (GH.ptrField 0) -data Nested'SomeInterface'method'results t -type instance (R.ReprFor (Nested'SomeInterface'method'results t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Nested'SomeInterface'method'results t)) where - typeId = 9305012847082487733 -instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeInterface'method'results t)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam t)) => (C.Allocate (Nested'SomeInterface'method'results t)) where - type AllocHint (Nested'SomeInterface'method'results t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) -instance ((GH.TypeParam t)) => (C.AllocateList (Nested'SomeInterface'method'results t)) where - type ListAllocHint (Nested'SomeInterface'method'results t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) -data instance C.Parsed (Nested'SomeInterface'method'results t) - = Nested'SomeInterface'method'results - {result :: (RP.Parsed t)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Nested'SomeInterface'method'results t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Nested'SomeInterface'method'results t))) -instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) where - parse raw_ = (Nested'SomeInterface'method'results <$> (GH.parseField #result raw_)) -instance ((GH.TypeParam t)) => (C.Marshal (Nested'SomeInterface'method'results t) (C.Parsed (Nested'SomeInterface'method'results t))) where - marshalInto raw_ Nested'SomeInterface'method'results{..} = (do - (GH.encodeField #result result raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam t)) => (GH.HasField "result" GH.Slot (Nested'SomeInterface'method'results t) t) where - fieldByLabel = (GH.ptrField 0) -data Specialized t -type instance (R.ReprFor (Specialized t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (Specialized t)) where - typeId = 11111346635683596512 -instance ((GH.TypeParam t)) => (C.TypedStruct (Specialized t)) where - numStructWords = 0 - numStructPtrs = 2 -instance ((GH.TypeParam t)) => (C.Allocate (Specialized t)) where - type AllocHint (Specialized t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (Specialized t) (C.Parsed (Specialized t))) -instance ((GH.TypeParam t)) => (C.AllocateList (Specialized t)) where - type ListAllocHint (Specialized t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (Specialized t) (C.Parsed (Specialized t))) -data instance C.Parsed (Specialized t) - = Specialized - {either :: (RP.Parsed (Either Basics.Text t)) - ,nestedStruct :: (RP.Parsed (Nested'SomeStruct Basics.Data))} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (Specialized t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (Specialized t))) -instance ((GH.TypeParam t)) => (C.Parse (Specialized t) (C.Parsed (Specialized t))) where - parse raw_ = (Specialized <$> (GH.parseField #either raw_) - <*> (GH.parseField #nestedStruct raw_)) -instance ((GH.TypeParam t)) => (C.Marshal (Specialized t) (C.Parsed (Specialized t))) where - marshalInto raw_ Specialized{..} = (do - (GH.encodeField #either either raw_) - (GH.encodeField #nestedStruct nestedStruct raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam t)) => (GH.HasField "either" GH.Slot (Specialized t) (Either Basics.Text t)) where - fieldByLabel = (GH.ptrField 0) -instance ((GH.TypeParam t)) => (GH.HasField "nestedStruct" GH.Slot (Specialized t) (Nested'SomeStruct Basics.Data)) where - fieldByLabel = (GH.ptrField 1) -data HasGroup t -type instance (R.ReprFor (HasGroup t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (HasGroup t)) where - typeId = 10809380793126616697 -instance ((GH.TypeParam t)) => (C.TypedStruct (HasGroup t)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam t)) => (C.Allocate (HasGroup t)) where - type AllocHint (HasGroup t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (HasGroup t) (C.Parsed (HasGroup t))) -instance ((GH.TypeParam t)) => (C.AllocateList (HasGroup t)) where - type ListAllocHint (HasGroup t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (HasGroup t) (C.Parsed (HasGroup t))) -data instance C.Parsed (HasGroup t) - = HasGroup - {theGroup :: (RP.Parsed (HasGroup'theGroup t))} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (HasGroup t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (HasGroup t))) -instance ((GH.TypeParam t)) => (C.Parse (HasGroup t) (C.Parsed (HasGroup t))) where - parse raw_ = (HasGroup <$> (GH.parseField #theGroup raw_)) -instance ((GH.TypeParam t)) => (C.Marshal (HasGroup t) (C.Parsed (HasGroup t))) where - marshalInto raw_ HasGroup{..} = (do - (do - group_ <- (GH.readField #theGroup raw_) - (C.marshalInto group_ theGroup) - ) - (Std_.pure ()) - ) -instance ((GH.TypeParam t)) => (GH.HasField "theGroup" GH.Group (HasGroup t) (HasGroup'theGroup t)) where - fieldByLabel = GH.groupField -data HasGroup'theGroup t -type instance (R.ReprFor (HasGroup'theGroup t)) = (R.Ptr (Std_.Just R.Struct)) -instance (C.HasTypeId (HasGroup'theGroup t)) where - typeId = 13022770763187353254 -instance ((GH.TypeParam t)) => (C.TypedStruct (HasGroup'theGroup t)) where - numStructWords = 0 - numStructPtrs = 1 -instance ((GH.TypeParam t)) => (C.Allocate (HasGroup'theGroup t)) where - type AllocHint (HasGroup'theGroup t) = () - new _ = C.newTypedStruct -instance ((GH.TypeParam t)) => (C.EstimateAlloc (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) -instance ((GH.TypeParam t)) => (C.AllocateList (HasGroup'theGroup t)) where - type ListAllocHint (HasGroup'theGroup t) = Std_.Int - newList = C.newTypedStructList -instance ((GH.TypeParam t)) => (C.EstimateListAlloc (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) -data instance C.Parsed (HasGroup'theGroup t) - = HasGroup'theGroup' - {value :: (RP.Parsed t)} - deriving(Generics.Generic) -deriving instance ((Std_.Show (RP.Parsed t))) => (Std_.Show (C.Parsed (HasGroup'theGroup t))) -deriving instance ((Std_.Eq (RP.Parsed t))) => (Std_.Eq (C.Parsed (HasGroup'theGroup t))) -instance ((GH.TypeParam t)) => (C.Parse (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) where - parse raw_ = (HasGroup'theGroup' <$> (GH.parseField #value raw_)) -instance ((GH.TypeParam t)) => (C.Marshal (HasGroup'theGroup t) (C.Parsed (HasGroup'theGroup t))) where - marshalInto raw_ HasGroup'theGroup'{..} = (do - (GH.encodeField #value value raw_) - (Std_.pure ()) - ) -instance ((GH.TypeParam t)) => (GH.HasField "value" GH.Slot (HasGroup'theGroup t) t) where - fieldByLabel = (GH.ptrField 0) diff --git a/lib/Capnp.hs b/lib/Capnp.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp.hs @@ -0,0 +1,76 @@ +-- | Module: Capnp +-- Description: Re-export commonly used things from elsewhere in the library. +module Capnp + ( module X, + Parsed, + + -- * Working with raw values + R.Raw (..), + + -- ** Working with raw lists + R.List, + R.index, + R.setIndex, + R.length, + + -- * Working with fields + F.Field, + F.FieldKind, + F.HasField (..), + F.HasUnion (..), + F.HasVariant (..), + + -- * Working with messages + Message.Message, + Message.Segment, + Message.Mutability (..), + Message.MonadReadMessage (..), + Message.newMessage, + Message.fromByteString, + Message.toByteString, + + -- * Building messages in pure code + PureBuilder, + createPure, + + -- * Canonicalizing messages + canonicalize, + + -- * Implementing RPC servers + MethodHandler, + SomeServer (..), + Export (Server), + export, + handleParsed, + handleRaw, + methodUnimplemented, + + -- * Shorthands for types + R.IsStruct, + R.IsCap, + R.IsPtr, + + -- * Re-exported from "Data.Default", for convienence. + def, + ) +where + +-- TODO: be more intentional about the ordering of the stuff we're +-- currently exposing as X, so the haddocks are clearer. + +import Capnp.Accessors as X +import Capnp.Basics as X hiding (Parsed) +import Capnp.Canonicalize (canonicalize) +import Capnp.Classes as X hiding (Parsed) +import Capnp.Constraints as X +import Capnp.Convert as X +import qualified Capnp.Fields as F +import Capnp.IO as X +import qualified Capnp.Message as Message +import Capnp.New.Rpc.Server +import qualified Capnp.Repr as R +import Capnp.Repr.Methods as X +import Capnp.Repr.Parsed (Parsed) +import Capnp.TraversalLimit as X +import Data.Default (def) +import Internal.BuildPure (PureBuilder, createPure) diff --git a/lib/Capnp/Accessors.hs b/lib/Capnp/Accessors.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Accessors.hs @@ -0,0 +1,266 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Module: Capnp.Accessors +-- Description: Functions for accessing parts of messaages. +module Capnp.Accessors + ( readField, + getField, + setField, + newField, + hasField, + encodeField, + parseField, + setVariant, + initVariant, + encodeVariant, + structWhich, + unionWhich, + structUnion, + unionStruct, + ) +where + +import qualified Capnp.Classes as C +import qualified Capnp.Fields as F +import Capnp.Message (Mutability (..)) +import qualified Capnp.Repr as R +import Capnp.TraversalLimit (evalLimitT) +import qualified Capnp.Untyped as U +import Data.Bits +import Data.Maybe (fromJust, isJust) +import Data.Word +import GHC.Prim (coerce) + +{-# INLINE readField #-} + +-- | Read the value of a field of a struct. +readField :: + forall k a b mut m. + ( R.IsStruct a, + U.ReadCtx m mut + ) => + F.Field k a b -> + R.Raw a mut -> + m (R.Raw b mut) +readField (F.Field field) (R.Raw struct) = + case field of + F.DataField F.DataFieldLoc {shift, index, mask, defaultValue} -> do + word <- U.getData (fromIntegral index) struct + pure $ R.Raw $ C.fromWord $ ((word .&. mask) `shiftR` fromIntegral shift) `xor` defaultValue + F.PtrField index -> + U.getPtr (fromIntegral index) struct >>= readPtrField + F.GroupField -> + pure $ R.Raw struct + F.VoidField -> + pure $ R.Raw () + where + -- This is broken out because the type checker needs some extra help: + readPtrField :: + forall pr. + ( R.ReprFor b ~ 'R.Ptr pr, + R.IsPtrRepr pr + ) => + Maybe (U.Ptr mut) -> + m (R.Raw b mut) + readPtrField ptr = + R.Raw <$> R.fromPtr @pr (U.message @U.Struct struct) ptr + +-- | Return whether the specified field is present. Only applicable for pointer +-- fields. +hasField :: + ( U.ReadCtx m mut, + R.IsStruct a, + R.IsPtr b + ) => + F.Field 'F.Slot a b -> + R.Raw a mut -> + m Bool +hasField (F.Field (F.PtrField index)) (R.Raw struct) = + isJust <$> U.getPtr (fromIntegral index) struct + +{-# INLINE getField #-} + +-- | Like 'readField', but: +-- +-- * Doesn't need the monadic context; can be used in pure code. +-- * Only works for immutable values. +-- * Only works for fields in the struct's data section. +getField :: + ( R.IsStruct a, + R.ReprFor b ~ 'R.Data sz, + C.Parse b bp + ) => + F.Field 'F.Slot a b -> + R.Raw a 'Const -> + bp +getField field struct = + fromJust $ + evalLimitT maxBound $ + readField field struct >>= C.parse + +{-# INLINE setField #-} + +-- | Set a struct field to a value. Not usable for group fields. +setField :: + forall a b m s. + ( R.IsStruct a, + U.RWCtx m s + ) => + F.Field 'F.Slot a b -> + R.Raw b ('Mut s) -> + R.Raw a ('Mut s) -> + m () +setField (F.Field field) (R.Raw value) (R.Raw struct) = + case field of + F.DataField fieldLoc -> + setDataField fieldLoc + F.PtrField index -> + setPtrField index value struct + F.VoidField -> + pure () + where + -- This was originally broken out because the type checker needs some extra + -- help, but it's probably more readable this way anyway. + setPtrField :: + forall pr. + ( R.ReprFor b ~ 'R.Ptr pr, + R.IsPtrRepr pr + ) => + Word16 -> + U.Unwrapped (R.UntypedPtr pr ('Mut s)) -> + U.Struct ('Mut s) -> + m () + setPtrField index value struct = + U.setPtr (R.toPtr @pr value) (fromIntegral index) struct + + setDataField :: + forall sz. + ( R.ReprFor b ~ 'R.Data sz, + C.IsWord (R.UntypedData sz) + ) => + F.DataFieldLoc sz -> + m () + setDataField F.DataFieldLoc {shift, index, mask, defaultValue} = do + oldWord <- U.getData (fromIntegral index) struct + let valueWord = C.toWord value `xor` defaultValue + newWord = + (oldWord .&. complement mask) + .|. (valueWord `shiftL` fromIntegral shift) + U.setData newWord (fromIntegral index) struct + +-- | Allocate space for the value of a field, and return it. +newField :: + forall a b m s. + ( R.IsStruct a, + C.Allocate b, + U.RWCtx m s + ) => + F.Field 'F.Slot a b -> + C.AllocHint b -> + R.Raw a ('Mut s) -> + m (R.Raw b ('Mut s)) +newField field hint parent = do + value <- C.new @b hint (U.message @(R.Raw a) parent) + setField field value parent + pure value + +-- | Marshal a parsed value into a struct's field. +encodeField :: + forall a b m s bp. + ( R.IsStruct a, + C.Parse b bp, + U.RWCtx m s + ) => + F.Field 'F.Slot a b -> + bp -> + R.Raw a ('Mut s) -> + m () +encodeField field parsed struct = do + encoded <- C.encode (U.message @(R.Raw a) struct) parsed + setField field encoded struct + +-- | parse a struct's field and return its parsed form. +parseField :: + ( R.IsStruct a, + C.Parse b bp, + U.ReadCtx m 'Const + ) => + F.Field k a b -> + R.Raw a 'Const -> + m bp +parseField field raw = + readField field raw >>= C.parse + +-- | Set the struct's anonymous union to the given variant, with the +-- supplied value as its argument. Not applicable for variants whose +-- argument is a group; use 'initVariant' instead. +setVariant :: + forall a b m s. + ( F.HasUnion a, + U.RWCtx m s + ) => + F.Variant 'F.Slot a b -> + R.Raw a ('Mut s) -> + R.Raw b ('Mut s) -> + m () +setVariant F.Variant {field, tagValue} struct value = do + setField (F.unionField @a) (R.Raw tagValue) struct + setField field value struct + +-- | Set the struct's anonymous union to the given variant, marshalling +-- the supplied value into the message to be its argument. Not applicable +-- for variants whose argument is a group; use 'initVariant' instead. +encodeVariant :: + forall a b m s bp. + ( F.HasUnion a, + C.Parse b bp, + U.RWCtx m s + ) => + F.Variant 'F.Slot a b -> + bp -> + R.Raw a ('Mut s) -> + m () +encodeVariant F.Variant {field, tagValue} value struct = do + setField (F.unionField @a) (R.Raw tagValue) struct + encodeField field value struct + +-- | Set the struct's anonymous union to the given variant, returning +-- the variant's argument, which must be a group (for non-group fields, +-- use 'setVariant' or 'encodeVariant'. +initVariant :: + forall a b m s. + (F.HasUnion a, U.RWCtx m s) => + F.Variant 'F.Group a b -> + R.Raw a ('Mut s) -> + m (R.Raw b ('Mut s)) +initVariant F.Variant {field, tagValue} struct = do + setField (F.unionField @a) (R.Raw tagValue) struct + readField field struct + +-- | Get the anonymous union for a struct. +structUnion :: F.HasUnion a => R.Raw a mut -> R.Raw (F.Which a) mut +structUnion = coerce + +-- | Get the struct enclosing an anonymous union. +unionStruct :: F.HasUnion a => R.Raw (F.Which a) mut -> R.Raw a mut +unionStruct = coerce + +-- | Get a non-opaque view on the struct's anonymous union, which +-- can be used to pattern match on. +structWhich :: forall a mut m. (U.ReadCtx m mut, F.HasUnion a) => R.Raw a mut -> m (F.RawWhich a mut) +structWhich struct = do + R.Raw tagValue <- readField (F.unionField @a) struct + F.internalWhich tagValue struct + +-- | Get a non-opaque view on the anonymous union, which can be +-- used to pattern match on. +unionWhich :: forall a mut m. (U.ReadCtx m mut, F.HasUnion a) => R.Raw (F.Which a) mut -> m (F.RawWhich a mut) +unionWhich = structWhich . unionStruct diff --git a/lib/Capnp/Address.hs b/lib/Capnp/Address.hs --- a/lib/Capnp/Address.hs +++ b/lib/Capnp/Address.hs @@ -1,59 +1,60 @@ -{-| -Module: Capnp.Address -Description: Utilities for manipulating addresses within capnproto messages. - -This module provides facilities for manipulating raw addresses within -Cap'N Proto messages. - -This is a low level module that very few users will need to use directly. --} {-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: Capnp.Address +-- Description: Utilities for manipulating addresses within capnproto messages. +-- +-- This module provides facilities for manipulating raw addresses within +-- Cap'N Proto messages. +-- +-- This is a low level module that very few users will need to use directly. module Capnp.Address - ( WordAddr(..) - , CapAddr(..) - , Addr(..) - , OffsetError(..) - , computeOffset - , pointerFrom - , resolveOffset - ) - where + ( WordAddr (..), + CapAddr (..), + Addr (..), + OffsetError (..), + computeOffset, + pointerFrom, + resolveOffset, + ) +where +import Capnp.Bits (WordCount) +import qualified Capnp.Pointer as P import Data.Bits import Data.Int import Data.Word -import Capnp.Bits (WordCount) - -import qualified Capnp.Pointer as P - -- | The address of a word within a message data WordAddr = WordAt - { segIndex :: !Int -- ^ Segment number - , wordIndex :: !WordCount -- ^ offset in words from the start of the segment. - } deriving(Show, Eq) + { -- | Segment number + segIndex :: !Int, + -- | offset in words from the start of the segment. + wordIndex :: !WordCount + } + deriving (Show, Eq) -- | The "address" of a capability -newtype CapAddr = Cap Word32 deriving(Show, Eq) +newtype CapAddr = Cap Word32 deriving (Show, Eq) -- | An address, i.e. a location that a pointer may point at. data Addr - -- | The address of some data in the message. - = WordAddr !WordAddr - -- | The "address" of a capability. - | CapAddr !CapAddr - deriving(Show, Eq) + = -- | The address of some data in the message. + WordAddr !WordAddr + | -- | The "address" of a capability. + CapAddr !CapAddr + deriving (Show, Eq) -- | An error returned by 'computeOffset'; this describes the reason why a -- value cannot be directly addressed from a given location. data OffsetError - -- | The pointer and the value are in different segments. - = DifferentSegments - -- | The pointer is in the correct segment, but too far away to encode the + = -- | The pointer and the value are in different segments. + DifferentSegments + | -- | The pointer is in the correct segment, but too far away to encode the -- offset. (more than 30 bits would be required). This can only happen with -- segments that are > 8 GiB, which this library refuses to either decode -- or generate, so this should not come up in practice. - | OutOfRange + OutOfRange -- | @'computeOffset' ptrAddr valueAddr@ computes the offset that should be -- stored in a struct or list pointer located at @ptrAddr@, in order to point @@ -62,10 +63,10 @@ -- describing the problem. computeOffset :: WordAddr -> WordAddr -> Either OffsetError WordCount computeOffset ptrAddr valueAddr - | segIndex ptrAddr /= segIndex valueAddr = Left DifferentSegments - | otherwise = - let offset = wordIndex valueAddr - (wordIndex ptrAddr + 1) - in if offset >= 1 `shiftL` 30 + | segIndex ptrAddr /= segIndex valueAddr = Left DifferentSegments + | otherwise = + let offset = wordIndex valueAddr - (wordIndex ptrAddr + 1) + in if offset >= 1 `shiftL` 30 then Left OutOfRange else Right offset @@ -79,16 +80,16 @@ -- rather than the final value. pointerFrom :: WordAddr -> WordAddr -> P.Ptr -> Either OffsetError P.Ptr pointerFrom _ _ (P.CapPtr _) = error "pointerFrom called on a capability pointer." -pointerFrom _ WordAt{..} (P.FarPtr twoWords _ _) = - Right $ P.FarPtr twoWords (fromIntegral wordIndex) (fromIntegral segIndex) +pointerFrom _ WordAt {..} (P.FarPtr twoWords _ _) = + Right $ P.FarPtr twoWords (fromIntegral wordIndex) (fromIntegral segIndex) pointerFrom ptrAddr targetAddr (P.StructPtr _ dataSz ptrSz) = - flip fmap (computeOffset ptrAddr targetAddr) $ - \off -> P.StructPtr (fromIntegral off) dataSz ptrSz + flip fmap (computeOffset ptrAddr targetAddr) $ + \off -> P.StructPtr (fromIntegral off) dataSz ptrSz pointerFrom ptrAddr targetAddr (P.ListPtr _ eltSpec) = - flip fmap (computeOffset ptrAddr targetAddr) $ - \off -> P.ListPtr (fromIntegral off) eltSpec + flip fmap (computeOffset ptrAddr targetAddr) $ + \off -> P.ListPtr (fromIntegral off) eltSpec -- | Add an offset to a WordAddr. resolveOffset :: WordAddr -> Int32 -> WordAddr -resolveOffset addr@WordAt{..} off = - addr { wordIndex = wordIndex + fromIntegral off + 1 } +resolveOffset addr@WordAt {..} off = + addr {wordIndex = wordIndex + fromIntegral off + 1} diff --git a/lib/Capnp/Basics.hs b/lib/Capnp/Basics.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Basics.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE EmptyDataDeriving #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Capnp.Basics +-- Description: Handling of "basic" capnp datatypes. +-- +-- This module contains phantom types for built-in Cap'n Proto +-- types, analogous to the phantom types generated for structs +-- by the code generator. It also defines applicable type class +-- instances. +module Capnp.Basics where + +-- XXX: I(zenhack) don't know how to supply an explicit +-- export list here, since we have instances of data families +-- and I don't know what to call the instances to get all of the +-- constructors. + +import qualified Capnp.Classes as C +import qualified Capnp.Errors as E +import qualified Capnp.Message as M +import qualified Capnp.Repr as R +import qualified Capnp.Untyped as U +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow, throwM) +import qualified Data.ByteString as BS +import Data.Default (Default (..)) +import Data.Foldable (foldl', for_) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Vector as V +import Data.Word +import GHC.Generics (Generic) +import GHC.Prim (coerce) + +-- | The Cap'n Proto @Text@ type. +data Text + +-- | The Cap'n Proto @Data@ type. +data Data + +-- | A Cap'n Proto @AnyPointer@, i.e. an arbitrary pointer with unknown schema. +data AnyPointer + +-- | A Cap'n Proto @List@ with unknown element type. +data AnyList + +-- | A Cap'n Proto struct of unknown type. +data AnyStruct + +-- | A Cap'n Proto capability with unknown interfaces. +data Capability + +type instance R.ReprFor Data = R.ReprFor (R.List Word8) + +type instance R.ReprFor Text = R.ReprFor (R.List Word8) + +type instance R.ReprFor AnyPointer = 'R.Ptr 'Nothing + +type instance R.ReprFor (Maybe AnyPointer) = 'R.Ptr 'Nothing + +type instance R.ReprFor AnyList = 'R.Ptr ('Just ('R.List 'Nothing)) + +type instance R.ReprFor AnyStruct = 'R.Ptr ('Just 'R.Struct) + +type instance R.ReprFor Capability = 'R.Ptr ('Just 'R.Cap) + +data instance C.Parsed AnyPointer + = PtrStruct (C.Parsed AnyStruct) + | PtrList (C.Parsed AnyList) + | PtrCap M.Client + deriving (Show, Eq, Generic) + +instance C.Parse (Maybe AnyPointer) (Maybe (C.Parsed AnyPointer)) where + parse (R.Raw ptr) = case ptr of + Nothing -> pure Nothing + Just _ -> Just <$> C.parse (R.Raw ptr :: R.Raw AnyPointer 'M.Const) + + encode msg value = + R.Raw <$> case value of + Nothing -> pure Nothing + Just v -> coerce <$> C.encode msg v + +instance C.Parse AnyPointer (C.Parsed AnyPointer) where + parse (R.Raw ptr) = case ptr of + Just (U.PtrCap cap) -> PtrCap <$> C.parse (R.Raw cap) + Just (U.PtrList list) -> PtrList <$> C.parse (R.Raw list) + Just (U.PtrStruct struct) -> PtrStruct <$> C.parse (R.Raw struct) + Nothing -> + throwM $ E.SchemaViolationError "Non-nullable AnyPointer was null" + + encode msg value = + R.Raw <$> case value of + PtrCap cap -> Just . U.PtrCap . R.fromRaw <$> C.encode msg cap + PtrList list -> Just . U.PtrList . R.fromRaw <$> C.encode msg list + PtrStruct struct -> Just . U.PtrStruct . R.fromRaw <$> C.encode msg struct + +instance C.AllocateList AnyPointer where + type ListAllocHint AnyPointer = Int + +instance C.EstimateListAlloc AnyPointer (C.Parsed AnyPointer) + +instance C.AllocateList (Maybe AnyPointer) where + type ListAllocHint (Maybe AnyPointer) = Int + +instance C.EstimateListAlloc (Maybe AnyPointer) (Maybe (C.Parsed AnyPointer)) + +data instance C.Parsed AnyStruct = Struct + { structData :: V.Vector Word64, + structPtrs :: V.Vector (Maybe (C.Parsed AnyPointer)) + } + deriving (Show, Generic) + +instance Eq (C.Parsed AnyStruct) where + -- We define equality specially (rather than just deriving), such that + -- slices are padded out with the default values of their elements. + (Struct dl pl) == (Struct dr pr) = sectionEq dl dr && sectionEq pl pr + where + sectionEq :: (Eq a, Default a) => V.Vector a -> V.Vector a -> Bool + sectionEq l r = go 0 + where + go i + | i >= length = True + | otherwise = indexDef i l == indexDef i r && go (i + 1) + length = max (V.length l) (V.length r) + indexDef i vec + | i < V.length vec = vec V.! i + | otherwise = def + +instance C.Parse AnyStruct (C.Parsed AnyStruct) where + parse (R.Raw s) = + Struct + <$> V.generateM + (fromIntegral $ U.structWordCount s) + (`U.getData` s) + <*> V.generateM + (fromIntegral $ U.structPtrCount s) + (\i -> U.getPtr i s >>= C.parse . R.Raw) + +instance C.AllocateList AnyStruct where + type ListAllocHint AnyStruct = (Int, R.AllocHint 'R.Struct) + +instance C.EstimateListAlloc AnyStruct (C.Parsed AnyStruct) where + estimateListAlloc structs = + let len = V.length structs + !nWords = foldl' max 0 $ map (V.length . structData) $ V.toList structs + !nPtrs = foldl' max 0 $ map (V.length . structPtrs) $ V.toList structs + in (len, (fromIntegral nWords, fromIntegral nPtrs)) + +instance C.EstimateAlloc AnyStruct (C.Parsed AnyStruct) where + estimateAlloc s = + ( fromIntegral $ V.length $ structData s, + fromIntegral $ V.length $ structPtrs s + ) + +instance C.Marshal AnyStruct (C.Parsed AnyStruct) where + marshalInto (R.Raw raw) s = do + V.iforM_ (structData s) $ \i value -> do + U.setData value i raw + V.iforM_ (structPtrs s) $ \i value -> do + R.Raw ptr <- C.encode (U.message @U.Struct raw) value + U.setPtr ptr i raw + +-- TODO(cleanup): It would be nice if we could reuse Capnp.Repr.Parsed.Parsed +-- here, but that would cause a circular import dependency. +type ParsedList a = V.Vector a + +data instance C.Parsed AnyList + = ListPtr (ParsedList (Maybe (C.Parsed AnyPointer))) + | ListStruct (ParsedList (C.Parsed AnyStruct)) + | List0 (ParsedList ()) + | List1 (ParsedList Bool) + | List8 (ParsedList Word8) + | List16 (ParsedList Word16) + | List32 (ParsedList Word32) + | List64 (ParsedList Word64) + deriving (Show, Eq, Generic) + +instance C.Parse AnyList (C.Parsed AnyList) where + parse (R.Raw list) = case list of + U.List0 l -> List0 <$> C.parse (R.Raw l) + U.List1 l -> List1 <$> C.parse (R.Raw l) + U.List8 l -> List8 <$> C.parse (R.Raw l) + U.List16 l -> List16 <$> C.parse (R.Raw l) + U.List32 l -> List32 <$> C.parse (R.Raw l) + U.List64 l -> List64 <$> C.parse (R.Raw l) + U.ListPtr l -> ListPtr <$> C.parse (R.Raw l) + U.ListStruct l -> ListStruct <$> C.parse (R.Raw l) + + encode msg list = + R.Raw <$> case list of + List0 l -> U.List0 . R.fromRaw <$> C.encode msg l + List1 l -> U.List1 . R.fromRaw <$> C.encode msg l + List8 l -> U.List8 . R.fromRaw <$> C.encode msg l + List16 l -> U.List16 . R.fromRaw <$> C.encode msg l + List32 l -> U.List32 . R.fromRaw <$> C.encode msg l + List64 l -> U.List64 . R.fromRaw <$> C.encode msg l + ListPtr l -> U.ListPtr . R.fromRaw <$> C.encode msg l + ListStruct l -> U.ListStruct . R.fromRaw <$> C.encode msg l + +instance C.Parse Capability M.Client where + parse (R.Raw cap) = U.getClient cap + encode msg client = R.Raw <$> U.appendCap msg client + +instance C.Allocate Text where + type AllocHint Text = Int + new len msg = R.Raw <$> U.allocList8 msg (len + 1) + +instance C.AllocateList Text where + type ListAllocHint Text = Int + +instance C.EstimateListAlloc Text T.Text + +instance C.Parse Text T.Text where + parse (R.Raw list) = + let len = U.length list + in if len == 0 + then -- We are somewhat lenient here; technically this is invalid, as there is + -- no null terminator (see logic below, which is dead code because of + -- this check. But to avoid this we really need to expose nullability + -- in the API, so for now we just fudge it. + pure "" + else + ( do + when (len == 0) $ + throwM $ + E.SchemaViolationError + "Text is not NUL-terminated (list of bytes has length 0)" + lastByte <- U.index (len - 1) list + when (lastByte /= 0) $ + throwM $ + E.SchemaViolationError $ + "Text is not NUL-terminated (last byte is " ++ show lastByte ++ ")" + bytes <- BS.take (len - 1) <$> U.rawBytes list + case TE.decodeUtf8' bytes of + Left e -> throwM $ E.InvalidUtf8Error e + Right v -> pure v + ) + encode msg value = do + let bytes = TE.encodeUtf8 value + raw@(R.Raw untyped) <- C.new @Text (BS.length bytes) msg + C.marshalInto @Data (R.Raw untyped) bytes + pure raw + +-- Instances for Data +instance C.Parse Data BS.ByteString where + parse = U.rawBytes . R.fromRaw + +instance C.Allocate Data where + type AllocHint Data = Int + new len msg = R.Raw <$> U.allocList8 msg len + +instance C.EstimateAlloc Data BS.ByteString where + estimateAlloc = BS.length + +instance C.AllocateList Data where + type ListAllocHint Data = Int + +instance C.EstimateListAlloc Data BS.ByteString + +instance C.Marshal Data BS.ByteString where + marshalInto (R.Raw list) bytes = + for_ [0 .. BS.length bytes - 1] $ \i -> + U.setIndex (BS.index bytes i) i list + +-- Instances for AnyStruct +instance C.Allocate AnyStruct where + type AllocHint AnyStruct = (Word16, Word16) + new (nWords, nPtrs) msg = R.Raw <$> U.allocStruct msg nWords nPtrs + +-- | Return the underlying buffer containing the text. This does not include the +-- null terminator. +textBuffer :: MonadThrow m => R.Raw Text mut -> m (R.Raw Data mut) +textBuffer (R.Raw list) = R.Raw <$> U.take (U.length list - 1) list + +-- | Convert a 'Text' to a 'BS.ByteString', comprising the raw bytes of the text +-- (not counting the NUL terminator). +textBytes :: U.ReadCtx m 'M.Const => R.Raw Text 'M.Const -> m BS.ByteString +textBytes text = do + R.Raw raw <- textBuffer text + U.rawBytes raw diff --git a/lib/Capnp/Bits.hs b/lib/Capnp/Bits.hs --- a/lib/Capnp/Bits.hs +++ b/lib/Capnp/Bits.hs @@ -1,31 +1,37 @@ -{-| -Module: Capnp.Bits -Description: Utilities for bitwhacking useful for capnproto. - -This module provides misc. utilities for bitwhacking that are useful -in dealing with low-level details of the Cap'N Proto wire format. - -This is mostly an implementation detail; users are unlikely to need -to use this module directly. --} {-# LANGUAGE GeneralizedNewtypeDeriving #-} + +-- | +-- Module: Capnp.Bits +-- Description: Utilities for bitwhacking useful for capnproto. +-- +-- This module provides misc. utilities for bitwhacking that are useful +-- in dealing with low-level details of the Cap'N Proto wire format. +-- +-- This is mostly an implementation detail; users are unlikely to need +-- to use this module directly. module Capnp.Bits - ( BitCount(..) - , ByteCount(..) - , WordCount(..) - , Word1(..) - , bitsToBytesCeil - , bytesToWordsCeil - , bytesToWordsFloor - , wordsToBytes - , lo, hi - , i32, i30, i29 - , fromLo, fromHi - , fromI32, fromI30, fromI29 - , bitRange - , replaceBits - ) - where + ( BitCount (..), + ByteCount (..), + WordCount (..), + Word1 (..), + bitsToBytesCeil, + bytesToWordsCeil, + bytesToWordsFloor, + wordsToBytes, + lo, + hi, + i32, + i30, + i29, + fromLo, + fromHi, + fromI32, + fromI30, + fromI29, + bitRange, + replaceBits, + ) +where import Data.Bits import Data.Int @@ -34,15 +40,15 @@ -- | Wrapper type for a quantity of bits. This along with 'ByteCount' and -- 'WordCount' are helpful for avoiding mixing up units newtype BitCount = BitCount Int - deriving(Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) + deriving (Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) -- | A quantity of bytes newtype ByteCount = ByteCount Int - deriving(Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) + deriving (Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) -- | A quantity of 64-bit words newtype WordCount = WordCount Int - deriving(Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) + deriving (Num, Real, Integral, Bits, Ord, Eq, Enum, Show, Bounded) -- | Convert bits to bytes. Rounds up. bitsToBytesCeil :: BitCount -> ByteCount @@ -75,57 +81,72 @@ -- a 32-bit word, returning the word. If @w < 2 ** N@ then @fromIN (iN w) == w@. fromI32, fromI30, fromI29 :: Int32 -> Word32 -lo w = fromIntegral (w `shiftR` 0) +lo w = fromIntegral (w `shiftR` 0) + hi w = fromIntegral (w `shiftR` 32) + i32 = fromIntegral + i30 w = i32 w `shiftR` 2 + i29 w = i32 w `shiftR` 3 -fromLo w = fromIntegral w `shiftL` 0 +fromLo w = fromIntegral w `shiftL` 0 + fromHi w = fromIntegral w `shiftL` 32 + fromI32 = fromIntegral + fromI30 w = fromI32 (w `shiftL` 2) + fromI29 w = fromI32 (w `shiftL` 3) -- | @bitRange word lo hi@ is the unsigned integer represented by the -- bits of @word@ in the range [lo, hi) bitRange :: (Integral a => Word64 -> Int -> Int -> a) -bitRange word lo hi = fromIntegral $ +bitRange word lo hi = + fromIntegral $ (word .&. ((1 `shiftL` hi) - 1)) `shiftR` lo -- | @replaceBits new orig shift@ replaces the bits [shift, shift+N) in -- @orig@ with the N bit integer @new@. -replaceBits :: (Bounded a, Integral a) - => a -> Word64 -> Int -> Word64 +replaceBits :: + (Bounded a, Integral a) => + a -> + Word64 -> + Int -> + Word64 replaceBits new orig shift = - (orig .&. mask) .|. (fromIntegral new `shiftL` shift) + (orig .&. mask) .|. (fromIntegral new `shiftL` shift) where mask = complement $ fromIntegral (maxBound `asTypeOf` new) `shiftL` shift {-# INLINE replaceBits #-} -- | 1 bit datatype, in the tradition of Word8, Word16 et al. -newtype Word1 = Word1 { word1ToBool :: Bool } - deriving(Ord, Eq, Enum, Bounded, Bits, FiniteBits) +newtype Word1 = Word1 {word1ToBool :: Bool} + deriving (Ord, Eq, Enum, Bounded, Bits, FiniteBits) instance Num Word1 where - (+) = w1ThruEnum (+) - (*) = w1ThruEnum (*) - abs = id - signum = id - negate = id - fromInteger x = toEnum (fromIntegral x `mod` 2) + (+) = w1ThruEnum (+) + (*) = w1ThruEnum (*) + abs = id + signum = id + negate = id + fromInteger x = toEnum (fromIntegral x `mod` 2) instance Real Word1 where - toRational = fromIntegral . fromEnum + toRational = fromIntegral . fromEnum instance Integral Word1 where - toInteger = toInteger . fromEnum - quotRem x y = let (x', y') = quotRem (fromEnum x) (fromEnum y) - in (toEnum x', toEnum y') + toInteger = toInteger . fromEnum + quotRem x y = + let (x', y') = quotRem (fromEnum x) (fromEnum y) + in (toEnum x', toEnum y') instance Show Word1 where - show = show . fromEnum - -- TODO: implement Read? + show = show . fromEnum + +-- TODO: implement Read? w1ThruEnum :: (Int -> Int -> Int) -> Word1 -> Word1 -> Word1 w1ThruEnum op l r = toEnum $ (fromEnum l `op` fromEnum r) `mod` 2 diff --git a/lib/Capnp/Canonicalize.hs b/lib/Capnp/Canonicalize.hs --- a/lib/Capnp/Canonicalize.hs +++ b/lib/Capnp/Canonicalize.hs @@ -1,15 +1,17 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + -- | Capnproto message canonicalization, per: -- -- https://capnproto.org/encoding.html#canonicalization -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} module Capnp.Canonicalize - ( canonicalize - , canonicalizeMut - ) where + ( canonicalize, + canonicalizeMut, + ) +where -- Note [Allocation strategy] -- @@ -27,20 +29,19 @@ -- canonicalization of zero-sized struct pointers for us; see the comments there -- for more details. -import Data.Word - -import Data.Foldable (for_) -import Data.Maybe (isNothing) -import Data.Traversable (for) -- import qualified Language.Haskell.TH as TH -import Capnp.Bits (WordCount) -import qualified Capnp.Message as M -import Capnp.Mutability (Mutability(..), unsafeThaw) -import Capnp.TraversalLimit (LimitT) -import qualified Capnp.Untyped as U -import Control.Monad.ST (RealWorld) -import Internal.BuildPure (PureBuilder) +import Capnp.Bits (WordCount) +import qualified Capnp.Message as M +import Capnp.Mutability (Mutability (..), unsafeThaw) +import Capnp.TraversalLimit (LimitT) +import qualified Capnp.Untyped as U +import Control.Monad.ST (RealWorld) +import Data.Foldable (for_) +import Data.Maybe (isNothing) +import Data.Traversable (for) +import Data.Word +import Internal.BuildPure (PureBuilder) -- | Return a canonicalized message with a copy of the given struct as its -- root. returns a (message, segment) pair, where the segment is the first @@ -56,180 +57,181 @@ canonicalizeMut :: U.RWCtx m s => U.Struct ('Mut s) -> m (M.Message ('Mut s), M.Segment ('Mut s)) canonicalizeMut rootStructIn = do - let msgIn = U.message @U.Struct rootStructIn - -- Note [Allocation strategy] - words <- totalWords msgIn - msgOut <- M.newMessage $ Just words - rootStructOut <- cloneCanonicalStruct rootStructIn msgOut - U.setRoot rootStructOut - segOut <- M.getSegment msgOut 0 - pure (msgOut, segOut) + let msgIn = U.message @U.Struct rootStructIn + -- Note [Allocation strategy] + words <- totalWords msgIn + msgOut <- M.newMessage $ Just words + rootStructOut <- cloneCanonicalStruct rootStructIn msgOut + U.setRoot rootStructOut + segOut <- M.getSegment msgOut 0 + pure (msgOut, segOut) {-# SPECIALIZE canonicalizeMut :: U.Struct ('Mut RealWorld) -> LimitT IO (M.Message ('Mut RealWorld), M.Segment ('Mut RealWorld)) #-} {-# SPECIALIZE canonicalizeMut :: U.Struct ('Mut s) -> PureBuilder s (M.Message ('Mut s), M.Segment ('Mut s)) #-} totalWords :: U.ReadCtx m mut => M.Message mut -> m WordCount totalWords msg = do - -- Note [Allocation strategy] - segCount <- M.numSegs msg - sizes <- for [0..segCount - 1] $ \i -> do - seg <- M.getSegment msg i - M.numWords seg - pure $ sum sizes + -- Note [Allocation strategy] + segCount <- M.numSegs msg + sizes <- for [0 .. segCount - 1] $ \i -> do + seg <- M.getSegment msg i + M.numWords seg + pure $ sum sizes cloneCanonicalStruct :: U.RWCtx m s => U.Struct ('Mut s) -> M.Message ('Mut s) -> m (U.Struct ('Mut s)) {-# SPECIALIZE cloneCanonicalStruct :: U.Struct ('Mut RealWorld) -> M.Message ('Mut RealWorld) -> LimitT IO (U.Struct ('Mut RealWorld)) #-} {-# SPECIALIZE cloneCanonicalStruct :: U.Struct ('Mut s) -> M.Message ('Mut s) -> PureBuilder s (U.Struct ('Mut s)) #-} cloneCanonicalStruct structIn msgOut = do - (nWords, nPtrs) <- findCanonicalSectionCounts structIn - structOut <- U.allocStruct msgOut (fromIntegral nWords) (fromIntegral nPtrs) - copyCanonicalStruct structIn structOut - pure structOut + (nWords, nPtrs) <- findCanonicalSectionCounts structIn + structOut <- U.allocStruct msgOut (fromIntegral nWords) (fromIntegral nPtrs) + copyCanonicalStruct structIn structOut + pure structOut copyCanonicalStruct :: U.RWCtx m s => U.Struct ('Mut s) -> U.Struct ('Mut s) -> m () {-# SPECIALIZE copyCanonicalStruct :: U.Struct ('Mut RealWorld) -> U.Struct ('Mut RealWorld) -> LimitT IO () #-} {-# SPECIALIZE copyCanonicalStruct :: U.Struct ('Mut s) -> U.Struct ('Mut s) -> PureBuilder s () #-} copyCanonicalStruct structIn structOut = do - let nWords = fromIntegral $ U.structWordCount structOut - nPtrs = fromIntegral $ U.structPtrCount structOut - for_ [0..nWords - 1] $ \i -> do - word <- U.getData i structIn - U.setData word i structOut - for_ [0..nPtrs - 1] $ \i -> do - ptrIn <- U.getPtr i structIn - ptrOut <- cloneCanonicalPtr ptrIn (U.message @U.Struct structOut) - U.setPtr ptrOut i structOut + let nWords = fromIntegral $ U.structWordCount structOut + nPtrs = fromIntegral $ U.structPtrCount structOut + for_ [0 .. nWords - 1] $ \i -> do + word <- U.getData i structIn + U.setData word i structOut + for_ [0 .. nPtrs - 1] $ \i -> do + ptrIn <- U.getPtr i structIn + ptrOut <- cloneCanonicalPtr ptrIn (U.message @U.Struct structOut) + U.setPtr ptrOut i structOut findCanonicalSectionCounts :: U.ReadCtx m mut => U.Struct mut -> m (Word16, Word16) {-# SPECIALIZE findCanonicalSectionCounts :: U.Struct ('Mut RealWorld) -> LimitT IO (Word16, Word16) #-} {-# SPECIALIZE findCanonicalSectionCounts :: U.Struct ('Mut s) -> PureBuilder s (Word16, Word16) #-} findCanonicalSectionCounts struct = do - nWords <- canonicalSectionCount (== 0) (`U.getData` struct) (fromIntegral $ U.structWordCount struct) - nPtrs <- canonicalSectionCount isNothing (`U.getPtr` struct) (fromIntegral $ U.structPtrCount struct) - pure (nWords, nPtrs) + nWords <- canonicalSectionCount (== 0) (`U.getData` struct) (fromIntegral $ U.structWordCount struct) + nPtrs <- canonicalSectionCount isNothing (`U.getPtr` struct) (fromIntegral $ U.structPtrCount struct) + pure (nWords, nPtrs) canonicalSectionCount :: Monad m => (a -> Bool) -> (Int -> m a) -> Int -> m Word16 canonicalSectionCount _ _ 0 = pure 0 canonicalSectionCount isDefault getIndex total = do - value <- getIndex (total - 1) - if isDefault value - then canonicalSectionCount isDefault getIndex (total - 1) - else pure $ fromIntegral total + value <- getIndex (total - 1) + if isDefault value + then canonicalSectionCount isDefault getIndex (total - 1) + else pure $ fromIntegral total cloneCanonicalPtr :: U.RWCtx m s => Maybe (U.Ptr ('Mut s)) -> M.Message ('Mut s) -> m (Maybe (U.Ptr ('Mut s))) {-# SPECIALIZE cloneCanonicalPtr :: Maybe (U.Ptr ('Mut RealWorld)) -> M.Message ('Mut RealWorld) -> LimitT IO (Maybe (U.Ptr ('Mut RealWorld))) #-} {-# SPECIALIZE cloneCanonicalPtr :: Maybe (U.Ptr ('Mut s)) -> M.Message ('Mut s) -> PureBuilder s (Maybe (U.Ptr ('Mut s))) #-} cloneCanonicalPtr ptrIn msgOut = - case ptrIn of - Nothing -> - pure Nothing - Just (U.PtrCap cap) -> do - client <- U.getClient cap - Just . U.PtrCap <$> U.appendCap msgOut client - Just (U.PtrStruct struct) -> - Just . U.PtrStruct <$> cloneCanonicalStruct struct msgOut - Just (U.PtrList list) -> - Just . U.PtrList <$> cloneCanonicalList list msgOut + case ptrIn of + Nothing -> + pure Nothing + Just (U.PtrCap cap) -> do + client <- U.getClient cap + Just . U.PtrCap <$> U.appendCap msgOut client + Just (U.PtrStruct struct) -> + Just . U.PtrStruct <$> cloneCanonicalStruct struct msgOut + Just (U.PtrList list) -> + Just . U.PtrList <$> cloneCanonicalList list msgOut cloneCanonicalList :: U.RWCtx m s => U.List ('Mut s) -> M.Message ('Mut s) -> m (U.List ('Mut s)) {-# SPECIALIZE cloneCanonicalList :: U.List ('Mut RealWorld) -> M.Message ('Mut RealWorld) -> LimitT IO (U.List ('Mut RealWorld)) #-} {-# SPECIALIZE cloneCanonicalList :: U.List ('Mut s) -> M.Message ('Mut s) -> PureBuilder s (U.List ('Mut s)) #-} cloneCanonicalList listIn msgOut = - case listIn of - U.List0 l -> U.List0 <$> U.allocList0 msgOut (U.length l) - U.List1 l -> U.List1 <$> (U.allocList1 msgOut (U.length l) >>= copyCanonicalDataList l) - U.List8 l -> U.List8 <$> (U.allocList8 msgOut (U.length l) >>= copyCanonicalDataList l) - U.List16 l -> U.List16 <$> (U.allocList16 msgOut (U.length l) >>= copyCanonicalDataList l) - U.List32 l -> U.List32 <$> (U.allocList32 msgOut (U.length l) >>= copyCanonicalDataList l) - U.List64 l -> U.List64 <$> (U.allocList64 msgOut (U.length l) >>= copyCanonicalDataList l) - U.ListPtr l -> U.ListPtr <$> (U.allocListPtr msgOut (U.length l) >>= copyCanonicalPtrList l) - U.ListStruct l -> U.ListStruct <$> cloneCanonicalStructList l msgOut + case listIn of + U.List0 l -> U.List0 <$> U.allocList0 msgOut (U.length l) + U.List1 l -> U.List1 <$> (U.allocList1 msgOut (U.length l) >>= copyCanonicalDataList l) + U.List8 l -> U.List8 <$> (U.allocList8 msgOut (U.length l) >>= copyCanonicalDataList l) + U.List16 l -> U.List16 <$> (U.allocList16 msgOut (U.length l) >>= copyCanonicalDataList l) + U.List32 l -> U.List32 <$> (U.allocList32 msgOut (U.length l) >>= copyCanonicalDataList l) + U.List64 l -> U.List64 <$> (U.allocList64 msgOut (U.length l) >>= copyCanonicalDataList l) + U.ListPtr l -> U.ListPtr <$> (U.allocListPtr msgOut (U.length l) >>= copyCanonicalPtrList l) + U.ListStruct l -> U.ListStruct <$> cloneCanonicalStructList l msgOut copyCanonicalDataList lin lout = do - U.copyListOf lout lin - pure lout + U.copyListOf lout lin + pure lout -copyCanonicalPtrList - :: U.RWCtx m s - => U.ListOf ('U.Ptr 'Nothing) ('Mut s) - -> U.ListOf ('U.Ptr 'Nothing) ('Mut s) - -> m (U.ListOf ('U.Ptr 'Nothing) ('Mut s)) -{-# SPECIALIZE copyCanonicalPtrList - :: U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld) - -> U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld) - -> LimitT IO (U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld)) - #-} -{-# SPECIALIZE copyCanonicalPtrList - :: U.ListOf ('U.Ptr 'Nothing) ('Mut s) - -> U.ListOf ('U.Ptr 'Nothing) ('Mut s) - -> PureBuilder s (U.ListOf ('U.Ptr 'Nothing) ('Mut s)) - #-} +copyCanonicalPtrList :: + U.RWCtx m s => + U.ListOf ('U.Ptr 'Nothing) ('Mut s) -> + U.ListOf ('U.Ptr 'Nothing) ('Mut s) -> + m (U.ListOf ('U.Ptr 'Nothing) ('Mut s)) +{-# SPECIALIZE copyCanonicalPtrList :: + U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld) -> + U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld) -> + LimitT IO (U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld)) + #-} +{-# SPECIALIZE copyCanonicalPtrList :: + U.ListOf ('U.Ptr 'Nothing) ('Mut s) -> + U.ListOf ('U.Ptr 'Nothing) ('Mut s) -> + PureBuilder s (U.ListOf ('U.Ptr 'Nothing) ('Mut s)) + #-} copyCanonicalPtrList listIn listOut = do - for_ [0..U.length listIn - 1] $ \i -> do - ptrIn <- U.index i listIn - ptrOut <- cloneCanonicalPtr ptrIn (U.message @(U.ListOf ('U.Ptr 'Nothing)) listOut) - U.setIndex ptrOut i listOut - pure listOut + for_ [0 .. U.length listIn - 1] $ \i -> do + ptrIn <- U.index i listIn + ptrOut <- cloneCanonicalPtr ptrIn (U.message @(U.ListOf ('U.Ptr 'Nothing)) listOut) + U.setIndex ptrOut i listOut + pure listOut -cloneCanonicalStructList - :: U.RWCtx m s - => U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) - -> M.Message ('Mut s) - -> m (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s)) -{-# SPECIALIZE cloneCanonicalStructList - :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) - -> M.Message ('Mut RealWorld) - -> LimitT IO (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld)) - #-} -{-# SPECIALIZE cloneCanonicalStructList - :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) - -> M.Message ('Mut s) - -> PureBuilder s (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s)) - #-} +cloneCanonicalStructList :: + U.RWCtx m s => + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> + M.Message ('Mut s) -> + m (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s)) +{-# SPECIALIZE cloneCanonicalStructList :: + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> + M.Message ('Mut RealWorld) -> + LimitT IO (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld)) + #-} +{-# SPECIALIZE cloneCanonicalStructList :: + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> + M.Message ('Mut s) -> + PureBuilder s (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s)) + #-} cloneCanonicalStructList listIn msgOut = do - (nWords, nPtrs) <- findCanonicalListSectionCounts listIn - listOut <- U.allocCompositeList msgOut nWords nPtrs (U.length listIn) - copyCanonicalStructList listIn listOut - pure listOut + (nWords, nPtrs) <- findCanonicalListSectionCounts listIn + listOut <- U.allocCompositeList msgOut nWords nPtrs (U.length listIn) + copyCanonicalStructList listIn listOut + pure listOut -copyCanonicalStructList - :: U.RWCtx m s - => U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) - -> U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) - -> m () -{-# SPECIALIZE copyCanonicalStructList - :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) - -> U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) - -> LimitT IO () - #-} -{-# SPECIALIZE copyCanonicalStructList - :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) - -> U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) - -> PureBuilder s () - #-} +copyCanonicalStructList :: + U.RWCtx m s => + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> + m () +{-# SPECIALIZE copyCanonicalStructList :: + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> + LimitT IO () + #-} +{-# SPECIALIZE copyCanonicalStructList :: + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> + PureBuilder s () + #-} copyCanonicalStructList listIn listOut = - for_ [0..U.length listIn - 1] $ \i -> do - structIn <- U.index i listIn - structOut <- U.index i listOut - copyCanonicalStruct structIn structOut + for_ [0 .. U.length listIn - 1] $ \i -> do + structIn <- U.index i listIn + structOut <- U.index i listOut + copyCanonicalStruct structIn structOut -findCanonicalListSectionCounts - :: U.ReadCtx m mut - => U.ListOf ('U.Ptr ('Just 'U.Struct)) mut -> m (Word16, Word16) -{-# SPECIALIZE findCanonicalListSectionCounts - :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> LimitT IO (Word16, Word16) - #-} -{-# SPECIALIZE findCanonicalListSectionCounts - :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> PureBuilder s (Word16, Word16) - #-} -findCanonicalListSectionCounts list = go 0 0 0 where +findCanonicalListSectionCounts :: + U.ReadCtx m mut => + U.ListOf ('U.Ptr ('Just 'U.Struct)) mut -> + m (Word16, Word16) +{-# SPECIALIZE findCanonicalListSectionCounts :: + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> LimitT IO (Word16, Word16) + #-} +{-# SPECIALIZE findCanonicalListSectionCounts :: + U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s) -> PureBuilder s (Word16, Word16) + #-} +findCanonicalListSectionCounts list = go 0 0 0 + where go i !nWords !nPtrs - | i >= U.length list = - pure (nWords, nPtrs) - | otherwise = do - struct <- U.index i list - (nWords', nPtrs') <- findCanonicalSectionCounts struct - go (i+1) (max nWords nWords') (max nPtrs nPtrs') - + | i >= U.length list = + pure (nWords, nPtrs) + | otherwise = do + struct <- U.index i list + (nWords', nPtrs') <- findCanonicalSectionCounts struct + go (i + 1) (max nWords nWords') (max nPtrs nPtrs') {- do diff --git a/lib/Capnp/Classes.hs b/lib/Capnp/Classes.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Classes.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Module: Capnp.Classes +-- Description: Misc. type classes +-- +-- This module contains several type classes (and related utilities) +-- useful for operating over Cap'n Proto values. +module Capnp.Classes + ( -- * Encoding and decoding parsed forms of values + Parse (..), + Parsed, + Marshal (..), + MarshalElement, + + -- * Allocating values in messages + Allocate (..), + newRoot, + AllocateList (..), + EstimateAlloc (..), + EstimateListAlloc (..), + newFromRepr, + + -- * Setting the root of a message + setRoot, + + -- * Working with Cap'n Proto types + HasTypeId (..), + + -- ** Typed Structs + TypedStruct (..), + newTypedStruct, + newTypedStructList, + structSizes, + + -- ** Inheritance + Super, + + -- * Values that go in a struct's data section + IsWord (..), + ) +where + +import Capnp.Bits +import Capnp.Message (Mutability (..)) +import qualified Capnp.Message as M +import qualified Capnp.Repr as R +import Capnp.TraversalLimit (evalLimitT) +import qualified Capnp.Untyped as U +import Data.Bits +import Data.Default (Default (..)) +import Data.Foldable (for_) +import Data.Int +import qualified Data.Vector as V +import Data.Word +import qualified GHC.Float as F +import qualified Language.Haskell.TH as TH + +-- | Capnp types that can be parsed into a more "natural" Haskell form. +-- +-- * @t@ is the capnproto type. +-- * @p@ is the type of the parsed value. +class Parse t p | t -> p, p -> t where + parse :: U.ReadCtx m 'Const => R.Raw t 'Const -> m p + -- ^ Parse a value from a constant message + + encode :: U.RWCtx m s => M.Message ('Mut s) -> p -> m (R.Raw t ('Mut s)) + -- ^ Encode a value into 'R.Raw' form, using the message as storage. + default encode :: + (U.RWCtx m s, EstimateAlloc t p, Marshal t p) => + M.Message ('Mut s) -> + p -> + m (R.Raw t ('Mut s)) + encode msg value = do + raw <- new (estimateAlloc value) msg + marshalInto raw value + pure raw + {-# INLINEABLE encode #-} + +-- | Types where the necessary allocation is inferrable from the parsed form. +-- +-- ...this is most types. +class (Parse t p, Allocate t) => EstimateAlloc t p where + -- | Determine the appropriate hint needed to allocate space + -- for the serialied form of the value. + estimateAlloc :: p -> AllocHint t + default estimateAlloc :: AllocHint t ~ () => p -> AllocHint t + estimateAlloc _ = () + {-# INLINEABLE estimateAlloc #-} + +-- | Implementation of 'new' valid for types whose 'AllocHint' is +-- the same as that of their underlying representation. +newFromRepr :: + forall a r m s. + ( R.Allocate r, + 'R.Ptr ('Just r) ~ R.ReprFor a, + U.RWCtx m s + ) => + R.AllocHint r -> + M.Message ('Mut s) -> + m (R.Raw a ('Mut s)) +{-# INLINEABLE newFromRepr #-} +newFromRepr hint msg = R.Raw <$> R.alloc @r msg hint + +-- TODO(cleanup): new and alloc really ought to have the same argument order... + +-- | Types which may be allocated directly inside a message. +class Allocate a where + type AllocHint a + -- ^ Extra information needed to allocate a value of this type, e.g. the + -- length for a list. May be () if no extra info is needed. + + new :: U.RWCtx m s => AllocHint a -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) + -- ^ @'new' hint msg@ allocates a new value of type @a@ inside @msg@. + default new :: + ( R.ReprFor a ~ 'R.Ptr ('Just pr), + R.Allocate pr, + AllocHint a ~ R.AllocHint pr, + U.RWCtx m s + ) => + AllocHint a -> + M.Message ('Mut s) -> + m (R.Raw a ('Mut s)) + -- If the AllocHint is the same as that of the underlying Repr, then + -- we can just use that implementation. + new = newFromRepr @a + {-# INLINEABLE new #-} + +-- | Like 'Allocate', but for allocating *lists* of @a@. +class AllocateList a where + type ListAllocHint a + -- ^ Extra information needed to allocate a list of @a@s. + + newList :: U.RWCtx m s => ListAllocHint a -> M.Message ('Mut s) -> m (R.Raw (R.List a) ('Mut s)) + default newList :: + forall m s lr r. + ( U.RWCtx m s, + lr ~ R.ListReprFor (R.ReprFor a), + r ~ 'R.List ('Just lr), + R.Allocate r, + R.AllocHint r ~ ListAllocHint a + ) => + ListAllocHint a -> + M.Message ('Mut s) -> + m (R.Raw (R.List a) ('Mut s)) + newList hint msg = R.Raw <$> R.alloc @r msg hint + {-# INLINEABLE newList #-} + +instance AllocateList a => Allocate (R.List a) where + type AllocHint (R.List a) = ListAllocHint a + new = newList @a + {-# INLINEABLE new #-} + +instance AllocateList (R.List a) where + type ListAllocHint (R.List a) = Int + +instance + ( Parse (R.List a) (V.Vector ap), + Allocate (R.List a) + ) => + EstimateListAlloc (R.List a) (V.Vector ap) + +-- | Allocate a new typed struct. Mainly used as the value for 'new' for in generated +-- instances of 'Allocate'. +newTypedStruct :: forall a m s. (TypedStruct a, U.RWCtx m s) => M.Message ('Mut s) -> m (R.Raw a ('Mut s)) +{-# INLINEABLE newTypedStruct #-} +newTypedStruct = newFromRepr (structSizes @a) + +-- | Like 'newTypedStruct', but for lists. +newTypedStructList :: + forall a m s. + (TypedStruct a, U.RWCtx m s) => + Int -> + M.Message ('Mut s) -> + m (R.Raw (R.List a) ('Mut s)) +{-# INLINEABLE newTypedStructList #-} +newTypedStructList i msg = + R.Raw + <$> R.alloc + @('R.List ('Just 'R.ListComposite)) + msg + (i, structSizes @a) + +-- | An instance of marshal allows a parsed value to be inserted into +-- pre-allocated space in a message. +class Parse t p => Marshal t p where + marshalInto :: U.RWCtx m s => R.Raw t ('Mut s) -> p -> m () + -- ^ Marshal a value into the pre-allocated object inside the message. + -- + -- Note that caller must arrange for the object to be of the correct size. + -- This is is not necessarily guaranteed; for example, list types must + -- coordinate the length of the list. + +-- | Get the maximum word and pointer counts needed for a struct type's fields. +structSizes :: forall a. TypedStruct a => (Word16, Word16) +{-# INLINEABLE structSizes #-} +structSizes = (numStructWords @a, numStructPtrs @a) + +-- | Types which have a numeric type-id defined in a capnp schema. +class HasTypeId a where + -- | The node id for this type. You will generally want to use the + -- @TypeApplications@ extension to specify the type. + typeId :: Word64 + +-- | Operations on typed structs. +class (R.IsStruct a, Allocate a, HasTypeId a, AllocHint a ~ ()) => TypedStruct a where + -- Get the size of the struct's word and pointer sections, respectively. + numStructWords :: Word16 + numStructPtrs :: Word16 + +-- | Like 'new', but also sets the value as the root of the message. +newRoot :: + forall a m s. + (U.RWCtx m s, R.IsStruct a, Allocate a) => + AllocHint a -> + M.Message ('Mut s) -> + m (R.Raw a ('Mut s)) +{-# INLINEABLE newRoot #-} +newRoot hint msg = do + raw <- new @a hint msg + setRoot raw + pure raw + +-- | Sets the struct to be the root of its containing message. +setRoot :: (U.RWCtx m s, R.IsStruct a) => R.Raw a ('Mut s) -> m () +{-# INLINEABLE setRoot #-} +setRoot (R.Raw struct) = U.setRoot struct + +------ Instances for basic types ------- + +parseId :: (R.Untyped (R.ReprFor a) mut ~ U.IgnoreMut a mut, U.ReadCtx m mut) => R.Raw a mut -> m a +{-# INLINEABLE parseId #-} +parseId (R.Raw v) = pure v + +parseInt :: + ( Integral a, + Integral (U.Unwrapped (R.Untyped (R.ReprFor a) mut)), + U.ReadCtx m mut + ) => + R.Raw a mut -> + m a +{-# INLINEABLE parseInt #-} +parseInt = pure . fromIntegral . R.fromRaw + +instance Parse Float Float where + parse = pure . F.castWord32ToFloat . R.fromRaw + encode _ = pure . R.Raw . F.castFloatToWord32 + +instance Parse Double Double where + parse = pure . F.castWord64ToDouble . R.fromRaw + encode _ = pure . R.Raw . F.castDoubleToWord64 + +instance MarshalElement a ap => Marshal (R.List a) (V.Vector ap) where + marshalInto raw value = + for_ [0 .. V.length value - 1] $ \i -> + marshalElement raw i (value V.! i) + +instance MarshalElement a ap => Parse (R.List a) (V.Vector ap) where + parse rawV = + V.generateM (R.length rawV) $ \i -> + R.index i rawV >>= parse + +-- | Type alias capturing the constraints on a type needed by +-- 'marshalElement' +type MarshalElement a ap = + ( Parse a ap, + EstimateListAlloc a ap, + R.Element (R.ReprFor a), + U.ListItem (R.ElemRepr (R.ListReprFor (R.ReprFor a))), + U.HasMessage (U.ListOf (R.ElemRepr (R.ListReprFor (R.ReprFor a)))), + MarshalElementByRepr (R.ListReprFor (R.ReprFor a)), + MarshalElementReprConstraints (R.ListReprFor (R.ReprFor a)) a ap + ) + +-- | Constraints needed by marshalElement that are specific to a list repr. +type family MarshalElementReprConstraints (lr :: R.ListRepr) a ap where + MarshalElementReprConstraints 'R.ListComposite a ap = Marshal a ap + MarshalElementReprConstraints ('R.ListNormal r) a ap = Parse a ap + +class + U.HasMessage (U.ListOf ('R.Ptr ('Just ('R.List ('Just lr))))) => + MarshalElementByRepr (lr :: R.ListRepr) + where + marshalElementByRepr :: + ( U.RWCtx m s, + R.ListReprFor (R.ReprFor a) ~ lr, + MarshalElement a ap + ) => + R.Raw (R.List a) ('Mut s) -> + Int -> + ap -> + m () + +-- | An instance @'Super' p c@ indicates that the interface @c@ extends +-- the interface @p@. +class (R.IsCap p, R.IsCap c) => Super p c + +instance MarshalElementByRepr 'R.ListComposite where + marshalElementByRepr rawList i parsed = do + rawElt <- R.index i rawList + marshalInto rawElt parsed + {-# INLINEABLE marshalElementByRepr #-} + +instance + ( U.HasMessage (U.ListOf (R.ElemRepr ('R.ListNormal l))), + U.ListItem (R.ElemRepr ('R.ListNormal l)) + ) => + MarshalElementByRepr ('R.ListNormal l) + where + marshalElementByRepr rawList@(R.Raw ulist) i parsed = do + rawElt <- + encode + (U.message @(U.Untyped ('R.Ptr ('Just ('R.List ('Just ('R.ListNormal l)))))) ulist) + parsed + R.setIndex rawElt i rawList + {-# INLINEABLE marshalElementByRepr #-} + +marshalElement :: + forall a ap m s. + ( U.RWCtx m s, + MarshalElement a ap + ) => + R.Raw (R.List a) ('Mut s) -> + Int -> + ap -> + m () +{-# INLINEABLE marshalElement #-} +marshalElement = marshalElementByRepr @(R.ListReprFor (R.ReprFor a)) + +class (Parse a ap, Allocate (R.List a)) => EstimateListAlloc a ap where + estimateListAlloc :: V.Vector ap -> AllocHint (R.List a) + default estimateListAlloc :: (AllocHint (R.List a) ~ Int) => V.Vector ap -> AllocHint (R.List a) + estimateListAlloc = V.length + {-# INLINEABLE estimateListAlloc #-} + +instance MarshalElement a ap => EstimateAlloc (R.List a) (V.Vector ap) where + estimateAlloc = estimateListAlloc @a + {-# INLINEABLE estimateAlloc #-} + +-- | If @a@ is a capnproto type, then @Parsed a@ is an ADT representation of that +-- type. If this is defined for a type @a@ then there should also be an instance +-- @'Parse' a ('Parsed' a)@, but note that the converse is not true: if there is +-- an instance @'Parse' a b@, then @'Parsed' a@ needn't be defined, and @b@ can +-- be something else. +data family Parsed a + +instance (Default (R.Raw a 'Const), Parse a (Parsed a)) => Default (Parsed a) where + def = case evalLimitT maxBound (parse @a def) of + Just v -> v + Nothing -> error "Parsing default value failed." + {-# INLINEABLE def #-} + +do + let mkId ty = + [d| + instance Parse $ty $ty where + parse = parseId + {-# INLINEABLE parse #-} + encode _ = pure . R.Raw + {-# INLINEABLE encode #-} + |] + mkInt ty = + [d| + instance Parse $ty $ty where + parse = parseInt + {-# INLINEABLE parse #-} + encode _ = pure . R.Raw . fromIntegral + {-# INLINEABLE encode #-} + |] + mkAll ty = + [d| + instance AllocateList $ty where + type ListAllocHint $ty = Int + + instance EstimateListAlloc $ty $ty where + estimateListAlloc = V.length + {-# INLINEABLE estimateListAlloc #-} + |] + + nameTy name = pure (TH.ConT name) + + ids = [t|()|] : map nameTy [''Bool, ''Word8, ''Word16, ''Word32, ''Word64] + ints = map nameTy [''Int8, ''Int16, ''Int32, ''Int64] + floats = map nameTy [''Float, ''Double] + allTys = ids ++ ints ++ floats + + merge :: [TH.Q [a]] -> TH.Q [a] + merge xs = concat <$> sequenceA xs + merge + [ merge $ map mkId ids, + merge $ map mkInt ints, + merge $ map mkAll allTys + ] + +-- | Types that can be converted to and from a 64-bit word. +-- +-- Anything that goes in the data section of a struct will have +-- an instance of this. +class IsWord a where + -- | Convert from a 64-bit words Truncates the word if the + -- type has less than 64 bits. + fromWord :: Word64 -> a + + -- | Convert to a 64-bit word. + toWord :: a -> Word64 + +------- IsWord instances. TODO: fold into TH above. ------- + +instance IsWord Bool where + fromWord n = (n .&. 1) == 1 + {-# INLINEABLE fromWord #-} + toWord True = 1 + toWord False = 0 + {-# INLINEABLE toWord #-} + +instance IsWord Word1 where + fromWord = Word1 . fromWord + {-# INLINEABLE fromWord #-} + toWord = toWord . word1ToBool + {-# INLINEABLE toWord #-} + +-- IsWord instances for integral types; they're all the same. +do + let mkInstance t = + [d| + instance IsWord $t where + fromWord = fromIntegral + {-# INLINEABLE fromWord #-} + toWord = fromIntegral + {-# INLINEABLE toWord #-} + |] + concat + <$> traverse + mkInstance + [ [t|Int8|], + [t|Int16|], + [t|Int32|], + [t|Int64|], + [t|Word8|], + [t|Word16|], + [t|Word32|], + [t|Word64|] + ] + +instance IsWord Float where + fromWord = F.castWord32ToFloat . fromIntegral + {-# INLINEABLE fromWord #-} + toWord = fromIntegral . F.castFloatToWord32 + {-# INLINEABLE toWord #-} + +instance IsWord Double where + fromWord = F.castWord64ToDouble + {-# INLINEABLE fromWord #-} + toWord = F.castDoubleToWord64 + {-# INLINEABLE toWord #-} diff --git a/lib/Capnp/Constraints.hs b/lib/Capnp/Constraints.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Constraints.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +-- | Module: Capnp.Constraints +-- Description: convenience shorthands for various constraints. +module Capnp.Constraints where + +import qualified Capnp.Classes as C +import qualified Capnp.Repr as R +import qualified Capnp.Repr.Parsed as RP + +-- | Constraints needed for @a@ to be a capnproto type parameter. +type TypeParam a = + ( R.IsPtr a, + C.Parse a (RP.Parsed a) + ) diff --git a/lib/Capnp/Convert.hs b/lib/Capnp/Convert.hs --- a/lib/Capnp/Convert.hs +++ b/lib/Capnp/Convert.hs @@ -1,56 +1,53 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitForAll #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-| -Module: Capnp.Convert -Description: Convert between messages, typed capnproto values, and (lazy)bytestring(builders). - -This module provides various helper functions to convert between messages, types defined -in capnproto schema (called "values" in the rest of this module's documentation), -bytestrings (both lazy and strict), and bytestring builders. - -Note that most of the functions which decode messages or raw bytes do *not* need to be -run inside of an instance of 'MonadLimit'; they choose an appropriate limit based on the -size of the input. +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -Note that not all conversions exist or necessarily make sense. --} +-- | +-- Module: Capnp.Convert +-- Description: Convert between messages, typed capnproto values, and (lazy)bytestring(builders). +-- +-- This module provides various helper functions to convert between messages, types defined +-- in capnproto schema (called "values" in the rest of this module's documentation), +-- bytestrings (both lazy and strict), and bytestring builders. +-- +-- Note that most of the functions which decode messages or raw bytes do *not* need to be +-- run inside of an instance of 'MonadLimit'; they choose an appropriate limit based on the +-- size of the input. +-- +-- Note that not all conversions exist or necessarily make sense. module Capnp.Convert - ( msgToBuilder - , msgToLBS - , msgToBS - , bsToMsg - , lbsToMsg - + ( msgToBuilder, + msgToLBS, + msgToBS, + bsToMsg, + lbsToMsg, -- new API - , msgToRaw - , msgToParsed - , bsToRaw - , bsToParsed - , lbsToRaw - , lbsToParsed - , parsedToRaw - , parsedToMsg - , parsedToBuilder - , parsedToBS - , parsedToLBS - ) where - -import Control.Monad.Catch (MonadThrow) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as LBS - -import Capnp.Mutability (Mutability(..), freeze) -import Capnp.New.Classes (Parse(encode, parse)) + msgToRaw, + msgToParsed, + bsToRaw, + bsToParsed, + lbsToRaw, + lbsToParsed, + parsedToRaw, + parsedToMsg, + parsedToBuilder, + parsedToBS, + parsedToLBS, + ) +where +import Capnp.Classes (Parse (encode, parse)) import qualified Capnp.Message as M -import qualified Capnp.Repr as R +import Capnp.Mutability (Mutability (..), freeze) +import qualified Capnp.Repr as R import qualified Capnp.Untyped as U +import Control.Monad.Catch (MonadThrow) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LBS {- TODO: unused currently, but we should put it back into service for things like msgToParsed. @@ -125,17 +122,17 @@ -- of its message. parsedToRaw :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m (R.Raw a ('Mut s)) parsedToRaw p = do - msg <- M.newMessage Nothing - value@(R.Raw struct) <- encode msg p - U.setRoot struct - pure value + msg <- M.newMessage Nothing + value@(R.Raw struct) <- encode msg p + U.setRoot struct + pure value -- | Serialize the parsed form of a struct into a message with that value as its -- root, returning the message. parsedToMsg :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m (M.Message ('Mut s)) parsedToMsg p = do - root <- parsedToRaw p - pure $ U.message @(R.Raw a) root + root <- parsedToRaw p + pure $ U.message @(R.Raw a) root -- | Serialize the parsed form of a struct and return it as a 'BB.Builder' parsedToBuilder :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m BB.Builder diff --git a/lib/Capnp/Errors.hs b/lib/Capnp/Errors.hs --- a/lib/Capnp/Errors.hs +++ b/lib/Capnp/Errors.hs @@ -1,54 +1,54 @@ -{-| -Module: Capnp.Errors -Description: Error handling utilities --} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module: Capnp.Errors +-- Description: Error handling utilities module Capnp.Errors - ( Error(..) - ) - where + ( Error (..), + ) +where -import Control.Monad.Catch (Exception) +import Control.Monad.Catch (Exception) import Data.Text.Encoding.Error (UnicodeException) -- | An error that may occur when processing a capnproto message. data Error - -- | A 'BoundsError' indicates an attempt to access an illegal + = -- | A 'BoundsError' indicates an attempt to access an illegal -- index 'index' within a sequence of length 'maxIndex'. - = BoundsError - { index :: !Int - , maxIndex :: !Int + BoundsError + { index :: !Int, + maxIndex :: !Int -- TODO: choose a better name than maxIndex; this is confusing -- since it's supposed to be the length, rather than the maximum -- legal index. The latter would make it impossible to represent -- an error for an empty sequence. I(zenhack) also think there may -- be places in the library where we are misusing this field. - } - -- | A 'RecursionLimitError' indicates that the recursion depth limit + } + | -- | A 'RecursionLimitError' indicates that the recursion depth limit -- was exceeded. - | RecursionLimitError - -- | A 'TraversalLimitError' indicates that the traversal limit was + RecursionLimitError + | -- | A 'TraversalLimitError' indicates that the traversal limit was -- exceeded. - | TraversalLimitError - -- | An 'InvalidDataError' indicates that a part of a message being + TraversalLimitError + | -- | An 'InvalidDataError' indicates that a part of a message being -- parsed was malformed. The argument to the data constructor is a -- human-readable error message. - | InvalidDataError String - -- | A 'SizeError' indicates that an operation would have resulted in + InvalidDataError String + | -- | A 'SizeError' indicates that an operation would have resulted in -- a message that violated the library's limit on either segment size -- or number of segments. - | SizeError - -- | A 'SchemaViolationError' indicates that part of the message does + SizeError + | -- | A 'SchemaViolationError' indicates that part of the message does -- not match the schema. The argument to the data construtor is a -- human-readable error message. - | SchemaViolationError String - -- | An 'InvalidUtf8Error' indicates that a text value in the message + SchemaViolationError String + | -- | An 'InvalidUtf8Error' indicates that a text value in the message -- was invalid utf8. -- -- Note well: Most parts of the library don't actually check for valid -- utf8 -- don't assume the check is made unless an interface says it is. - | InvalidUtf8Error UnicodeException - deriving(Show, Eq) + InvalidUtf8Error UnicodeException + deriving (Show, Eq) instance Exception Error diff --git a/lib/Capnp/Fields.hs b/lib/Capnp/Fields.hs --- a/lib/Capnp/Fields.hs +++ b/lib/Capnp/Fields.hs @@ -1,37 +1,37 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + -- | Module: Capnp.Fields -- Description: Support for working with struct fields module Capnp.Fields - ( HasField(..) - , Field(..) - , FieldLoc(..) - , DataFieldLoc(..) - , FieldKind(..) - , HasUnion(..) - , Variant(..) - , HasVariant(..) - ) where - + ( HasField (..), + Field (..), + FieldLoc (..), + DataFieldLoc (..), + FieldKind (..), + HasUnion (..), + Variant (..), + HasVariant (..), + ) +where import Capnp.Bits +import qualified Capnp.Classes as C +import qualified Capnp.Message as M +import qualified Capnp.Repr as R +import qualified Capnp.Untyped as U import Data.Word - -import GHC.OverloadedLabels (IsLabel(..)) -import GHC.TypeLits (Symbol) - -import qualified Capnp.Message as M -import qualified Capnp.New.Classes as NC -import qualified Capnp.Repr as R -import qualified Capnp.Untyped as U +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.TypeLits (Symbol) -- | What sort of field is this? This corresponds to the slot/group variants -- in the @Field@ type in schema.capnp. Mostly used at the type level with @@ -40,13 +40,13 @@ -- (Note that this has nothing to do with kinds in the usual type system sense -- of the word). data FieldKind - = Slot - -- ^ The field is a normal slot; it can be read and written as an + = -- | The field is a normal slot; it can be read and written as an -- individual value. - | Group - -- ^ The field is a group. Since this shares space with its parent struct + Slot + | -- | The field is a group. Since this shares space with its parent struct -- access patterns are a bit different. - deriving(Show, Read, Eq) + Group + deriving (Show, Read, Eq) -- | @'Field' k a b@ is a first-class representation of a field of type @b@ within -- an @a@, where @a@ must be a struct type. @@ -54,74 +54,75 @@ -- | The location of a field within a message. data FieldLoc (k :: FieldKind) (r :: R.Repr) where - GroupField :: FieldLoc 'Group ('R.Ptr ('Just 'R.Struct)) - PtrField :: R.IsPtrRepr a => Word16 -> FieldLoc 'Slot ('R.Ptr a) - DataField :: NC.IsWord (R.UntypedData a) => DataFieldLoc a -> FieldLoc 'Slot ('R.Data a) - VoidField :: FieldLoc 'Slot ('R.Data 'R.Sz0) + GroupField :: FieldLoc 'Group ('R.Ptr ('Just 'R.Struct)) + PtrField :: R.IsPtrRepr a => Word16 -> FieldLoc 'Slot ('R.Ptr a) + DataField :: C.IsWord (R.UntypedData a) => DataFieldLoc a -> FieldLoc 'Slot ('R.Data a) + VoidField :: FieldLoc 'Slot ('R.Data 'R.Sz0) -- | The location of a data (non-pointer) field. data DataFieldLoc (sz :: R.DataSz) = DataFieldLoc - { shift :: !BitCount - , index :: !Word16 - , mask :: !Word64 - , defaultValue :: !Word64 - } + { shift :: !BitCount, + index :: !Word16, + mask :: !Word64, + defaultValue :: !Word64 + } -- | An instance of 'HasUnion' indicates that the given type is a capnproto struct -- (or group) with an anonymous union. class R.IsStruct a => HasUnion a where - -- | 'unionField' is a field holding the union's tag. - unionField :: Field 'Slot a Word16 + -- | 'unionField' is a field holding the union's tag. + unionField :: Field 'Slot a Word16 - -- | 'Which' is the abstract capnproto type of the union itself. Like - -- generated struct types (in this case @a@), this is typically - -- uninhabitied, and used to define instances and/or act as a phantom type. - data Which a + -- | 'Which' is the abstract capnproto type of the union itself. Like + -- generated struct types (in this case @a@), this is typically + -- uninhabitied, and used to define instances and/or act as a phantom type. + data Which a - -- | Concrete view into a union embedded in a message. This will be a sum - -- type with other 'Raw' values as arguments. - data RawWhich a (mut :: M.Mutability) + -- | Concrete view into a union embedded in a message. This will be a sum + -- type with other 'Raw' values as arguments. + data RawWhich a (mut :: M.Mutability) - -- | Helper used in generated code to extract a 'RawWhich' from its - -- surrounding struct. - internalWhich :: U.ReadCtx m mut => Word16 -> R.Raw a mut -> m (RawWhich a mut) + -- | Helper used in generated code to extract a 'RawWhich' from its + -- surrounding struct. + internalWhich :: U.ReadCtx m mut => Word16 -> R.Raw a mut -> m (RawWhich a mut) type instance R.ReprFor (Which a) = 'R.Ptr ('Just 'R.Struct) -instance (NC.Allocate a, HasUnion a, R.IsStruct (Which a)) => NC.Allocate (Which a) where - type AllocHint (Which a) = NC.AllocHint a - new hint msg = do - R.Raw struct <- NC.new @a hint msg - pure (R.Raw struct) +instance (C.Allocate a, HasUnion a, R.IsStruct (Which a)) => C.Allocate (Which a) where + type AllocHint (Which a) = C.AllocHint a + new hint msg = do + R.Raw struct <- C.new @a hint msg + pure (R.Raw struct) instance - ( NC.Allocate (Which a) - , NC.AllocHint (Which a) ~ () - , NC.Parse (Which a) p - ) => NC.EstimateAlloc (Which a) p + ( C.Allocate (Which a), + C.AllocHint (Which a) ~ (), + C.Parse (Which a) p + ) => + C.EstimateAlloc (Which a) p -- | @'Variant' k a b@ is a first-class representation of a variant of @a@'s -- anonymous union, whose argument is of type @b@. data Variant (k :: FieldKind) a b = Variant - { field :: !(Field k a b) - , tagValue :: !Word16 - } + { field :: !(Field k a b), + tagValue :: !Word16 + } -- | An instance @'HasField' name k a b@ indicates that the struct type @a@ -- has a field named @name@ with type @b@ (with @k@ being the 'FieldKind' for -- the field). The generated code includes instances of this for each field -- in the schema. class R.IsStruct a => HasField (name :: Symbol) k a b | a name -> k b where - fieldByLabel :: Field k a b + fieldByLabel :: Field k a b instance HasField name k a b => IsLabel name (Field k a b) where - fromLabel = fieldByLabel @name @k @a @b + fromLabel = fieldByLabel @name @k @a @b -- | An instance @'HasVariant name k a b@ indicates that the struct type @a@ -- has an anonymous union with a variant named @name@, whose argument is of type -- @b@. class HasUnion a => HasVariant (name :: Symbol) k a b | a name -> k b where - variantByLabel :: Variant k a b + variantByLabel :: Variant k a b instance HasVariant name k a b => IsLabel name (Variant k a b) where - fromLabel = variantByLabel @name @k @a @b + fromLabel = variantByLabel @name @k @a @b diff --git a/lib/Capnp/Gen.hs b/lib/Capnp/Gen.hs --- a/lib/Capnp/Gen.hs +++ b/lib/Capnp/Gen.hs @@ -1,9 +1,8 @@ -{- | -Module: Capnp.Gen -Description: Code generated by the schema compiler. - -The @Capnp.Gen@ module hierarchy contains code generated by the schema compiler. -See "Capnp.Tutorial" for a description of what code is generated for -each schema, as well as a general introduction to the library. --} +-- | +-- Module: Capnp.Gen +-- Description: Code generated by the schema compiler. +-- +-- The @Capnp.Gen@ module hierarchy contains code generated by the schema compiler. +-- See "Capnp.Tutorial" for a description of what code is generated for +-- each schema, as well as a general introduction to the library. module Capnp.Gen () where diff --git a/lib/Capnp/Gen/Capnp.hs b/lib/Capnp/Gen/Capnp.hs --- a/lib/Capnp/Gen/Capnp.hs +++ b/lib/Capnp/Gen/Capnp.hs @@ -1,8 +1,7 @@ -{-| -Module: Capnp.Gen.Capnp -Description: Generated modules for the schema that ship with Cap'N Proto - -The modules under 'Capnp.Gen.Capnp' are generated code for the schema files that -ship with the Cap'N Proto reference implementation. --} +-- | +-- Module: Capnp.Gen.Capnp +-- Description: Generated modules for the schema that ship with Cap'N Proto +-- +-- The modules under 'Capnp.Gen.Capnp' are generated code for the schema files that +-- ship with the Cap'N Proto reference implementation. module Capnp.Gen.Capnp () where diff --git a/lib/Capnp/GenHelpers.hs b/lib/Capnp/GenHelpers.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/GenHelpers.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Capnp.GenHelpers + ( dataField, + ptrField, + groupField, + voidField, + readVariant, + Mutability (..), + TypeParam, + newStruct, + parseEnum, + encodeEnum, + getPtrConst, + BS.ByteString, + module F, + module Capnp.Accessors, + + -- * Re-exports from the standard library. + Proxy (..), + ) +where + +import Capnp.Accessors +import qualified Capnp.Basics as NB +import Capnp.Bits +import qualified Capnp.Classes as NC +import Capnp.Constraints (TypeParam) +import Capnp.Convert (bsToRaw) +import Capnp.Fields as F +import Capnp.Message (Mutability (..)) +import qualified Capnp.Message as M +import qualified Capnp.Repr as R +import Capnp.TraversalLimit (evalLimitT) +import qualified Capnp.Untyped as U +import Data.Bits +import qualified Data.ByteString as BS +import Data.Functor ((<&>)) +import Data.Maybe (fromJust) +import Data.Proxy (Proxy (..)) +import Data.Word + +dataField :: + forall b a sz. + ( R.ReprFor b ~ 'R.Data sz, + NC.IsWord (R.UntypedData sz) + ) => + BitCount -> + Word16 -> + BitCount -> + Word64 -> + F.Field 'F.Slot a b +dataField shift index nbits defaultValue = + F.Field $ + F.DataField @sz + F.DataFieldLoc + { shift, + index, + mask = ((1 `shiftL` fromIntegral nbits) - 1) `shiftL` fromIntegral shift, + defaultValue + } + +ptrField :: forall a b. R.IsPtr b => Word16 -> F.Field 'F.Slot a b +ptrField = F.Field . F.PtrField @(R.PtrReprFor (R.ReprFor b)) + +groupField :: (R.ReprFor b ~ 'R.Ptr ('Just 'R.Struct)) => F.Field 'F.Group a b +groupField = F.Field F.GroupField + +voidField :: (R.ReprFor b ~ 'R.Data 'R.Sz0) => F.Field 'F.Slot a b +voidField = F.Field F.VoidField + +-- | Like 'readField', but accepts a variant. Warning: *DOES NOT CHECK* that the +-- variant is the one that is set. This should only be used by generated code. +readVariant :: + forall k a b mut m. + ( R.IsStruct a, + U.ReadCtx m mut + ) => + F.Variant k a b -> + R.Raw a mut -> + m (R.Raw b mut) +readVariant F.Variant {field} = readField field + +newStruct :: forall a m s. (U.RWCtx m s, NC.TypedStruct a) => () -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) +newStruct () msg = R.Raw . R.fromRaw <$> NC.new @NB.AnyStruct (NC.numStructWords @a, NC.numStructPtrs @a) msg + +parseEnum :: + (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, Applicative m) => + R.Raw a 'Const -> + m a +parseEnum (R.Raw n) = pure $ toEnum $ fromIntegral n + +encodeEnum :: + forall a m s. + (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, U.RWCtx m s) => + M.Message ('Mut s) -> + a -> + m (R.Raw a ('Mut s)) +encodeEnum _msg value = pure $ R.Raw $ fromIntegral $ fromEnum @a value + +-- | Get a pointer from a ByteString, where the root object is a struct with +-- one pointer, which is the pointer we will retrieve. This is only safe for +-- trusted inputs; it reads the message with a traversal limit of 'maxBound' +-- (and so is suseptable to denial of service attacks), and it calls 'error' +-- if decoding is not successful. +-- +-- The purpose of this is for defining constants of pointer type from a schema. +getPtrConst :: forall a. R.IsPtr a => BS.ByteString -> R.Raw a 'Const +getPtrConst bytes = fromJust $ evalLimitT maxBound $ do + R.Raw root <- bsToRaw @NB.AnyStruct bytes + U.getPtr 0 root + >>= R.fromPtr @(R.PtrReprFor (R.ReprFor a)) (U.message @U.Struct root) + <&> R.Raw diff --git a/lib/Capnp/GenHelpers/New.hs b/lib/Capnp/GenHelpers/New.hs deleted file mode 100644 --- a/lib/Capnp/GenHelpers/New.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -module Capnp.GenHelpers.New - ( dataField - , ptrField - , groupField - , voidField - , readVariant - , Mutability(..) - , TypeParam - , newStruct - , parseEnum - , encodeEnum - , getPtrConst - , BS.ByteString - , module F - , module Capnp.New.Accessors - - -- * Re-exports from the standard library. - , Proxy(..) - ) where - - - -import Capnp.Bits -import Capnp.Convert (bsToRaw) -import Capnp.Fields as F -import Capnp.Message (Mutability(..)) -import qualified Capnp.Message as M -import Capnp.New.Accessors -import qualified Capnp.New.Basics as NB -import qualified Capnp.New.Classes as NC -import Capnp.New.Constraints (TypeParam) -import qualified Capnp.Repr as R -import Capnp.TraversalLimit (evalLimitT) -import qualified Capnp.Untyped as U -import Data.Bits -import qualified Data.ByteString as BS -import Data.Functor ((<&>)) -import Data.Maybe (fromJust) -import Data.Proxy (Proxy(..)) -import Data.Word - -dataField - :: forall b a sz. - ( R.ReprFor b ~ 'R.Data sz - , NC.IsWord (R.UntypedData sz) - ) - => BitCount -> Word16 -> BitCount -> Word64 -> F.Field 'F.Slot a b -dataField shift index nbits defaultValue = F.Field $ F.DataField @sz F.DataFieldLoc - { shift - , index - , mask = ((1 `shiftL` fromIntegral nbits) - 1) `shiftL` fromIntegral shift - , defaultValue - } - -ptrField :: forall a b. R.IsPtr b => Word16 -> F.Field 'F.Slot a b -ptrField = F.Field . F.PtrField @(R.PtrReprFor (R.ReprFor b)) - -groupField :: (R.ReprFor b ~ 'R.Ptr ('Just 'R.Struct)) => F.Field 'F.Group a b -groupField = F.Field F.GroupField - -voidField :: (R.ReprFor b ~ 'R.Data 'R.Sz0) => F.Field 'F.Slot a b -voidField = F.Field F.VoidField - --- | Like 'readField', but accepts a variant. Warning: *DOES NOT CHECK* that the --- variant is the one that is set. This should only be used by generated code. -readVariant - :: forall k a b mut m. - ( R.IsStruct a - , U.ReadCtx m mut - ) - => F.Variant k a b -> R.Raw a mut -> m (R.Raw b mut) -readVariant F.Variant{field} = readField field - -newStruct :: forall a m s. (U.RWCtx m s, NC.TypedStruct a) => () -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) -newStruct () msg = R.Raw . R.fromRaw <$> NC.new @NB.AnyStruct (NC.numStructWords @a, NC.numStructPtrs @a) msg - - -parseEnum :: (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, Applicative m) - => R.Raw a 'Const -> m a -parseEnum (R.Raw n) = pure $ toEnum $ fromIntegral n - -encodeEnum :: forall a m s. (R.ReprFor a ~ 'R.Data 'R.Sz16, Enum a, U.RWCtx m s) - => M.Message ('Mut s) -> a -> m (R.Raw a ('Mut s)) -encodeEnum _msg value = pure $ R.Raw $ fromIntegral $ fromEnum @a value - --- | Get a pointer from a ByteString, where the root object is a struct with --- one pointer, which is the pointer we will retrieve. This is only safe for --- trusted inputs; it reads the message with a traversal limit of 'maxBound' --- (and so is suseptable to denial of service attacks), and it calls 'error' --- if decoding is not successful. --- --- The purpose of this is for defining constants of pointer type from a schema. -getPtrConst :: forall a. R.IsPtr a => BS.ByteString -> R.Raw a 'Const -getPtrConst bytes = fromJust $ evalLimitT maxBound $ do - R.Raw root <- bsToRaw @NB.AnyStruct bytes - U.getPtr 0 root - >>= R.fromPtr @(R.PtrReprFor (R.ReprFor a)) (U.message @U.Struct root) - <&> R.Raw diff --git a/lib/Capnp/GenHelpers/New/Rpc.hs b/lib/Capnp/GenHelpers/New/Rpc.hs deleted file mode 100644 --- a/lib/Capnp/GenHelpers/New/Rpc.hs +++ /dev/null @@ -1,22 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -module Capnp.GenHelpers.New.Rpc - ( module Capnp.New.Rpc.Server - , module Capnp.Repr.Methods - , parseCap - , encodeCap - ) where - -import Capnp.Message (Mutability(..)) -import qualified Capnp.Message as M -import Capnp.New.Rpc.Server -import qualified Capnp.Repr as R -import Capnp.Repr.Methods -import qualified Capnp.Untyped as U - -parseCap :: (R.IsCap a, U.ReadCtx m 'Const) => R.Raw a 'Const -> m (Client a) -parseCap (R.Raw cap) = Client <$> U.getClient cap - -encodeCap :: (R.IsCap a, U.RWCtx m s) => M.Message ('Mut s) -> Client a -> m (R.Raw a ('Mut s)) -encodeCap msg (Client c) = R.Raw <$> U.appendCap msg c diff --git a/lib/Capnp/GenHelpers/Rpc.hs b/lib/Capnp/GenHelpers/Rpc.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/GenHelpers/Rpc.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} + +module Capnp.GenHelpers.Rpc + ( module Capnp.New.Rpc.Server, + module Capnp.Repr.Methods, + parseCap, + encodeCap, + ) +where + +import Capnp.Message (Mutability (..)) +import qualified Capnp.Message as M +import Capnp.New.Rpc.Server +import qualified Capnp.Repr as R +import Capnp.Repr.Methods +import qualified Capnp.Untyped as U + +parseCap :: (R.IsCap a, U.ReadCtx m 'Const) => R.Raw a 'Const -> m (Client a) +parseCap (R.Raw cap) = Client <$> U.getClient cap + +encodeCap :: (R.IsCap a, U.RWCtx m s) => M.Message ('Mut s) -> Client a -> m (R.Raw a ('Mut s)) +encodeCap msg (Client c) = R.Raw <$> U.appendCap msg c diff --git a/lib/Capnp/IO.hs b/lib/Capnp/IO.hs --- a/lib/Capnp/IO.hs +++ b/lib/Capnp/IO.hs @@ -1,85 +1,86 @@ -{- | -Module: Capnp.IO -Description: Utilities for reading and writing values to handles. - -This module provides utilities for reading and writing values to and -from file 'Handle's. --} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -module Capnp.IO - ( sGetMsg - , sPutMsg - , M.hGetMsg - , M.getMsg - , M.hPutMsg - , M.putMsg - - , hGetParsed - , sGetParsed - , getParsed - , hPutParsed - , sPutParsed - , putParsed - , hGetRaw - , getRaw - , sGetRaw - ) where - -import Data.Bits - -import Control.Exception (throwIO) -import Control.Monad.Trans.Class (lift) -import Network.Simple.TCP (Socket, recv, sendLazy) -import System.IO (Handle, stdin, stdout) -import System.IO.Error (eofErrorType, mkIOError) +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BB +-- | +-- Module: Capnp.IO +-- Description: Utilities for reading and writing values to handles. +-- +-- This module provides utilities for reading and writing values to and +-- from file 'Handle's. +module Capnp.IO + ( sGetMsg, + sPutMsg, + M.hGetMsg, + M.getMsg, + M.hPutMsg, + M.putMsg, + hGetParsed, + sGetParsed, + getParsed, + hPutParsed, + sPutParsed, + putParsed, + hGetRaw, + getRaw, + sGetRaw, + ) +where -import Capnp.Bits (WordCount, wordsToBytes) +import Capnp.Bits (WordCount, wordsToBytes) +import Capnp.Classes (Parse) import Capnp.Convert - (msgToLBS, msgToParsed, msgToRaw, parsedToBuilder, parsedToLBS) -import Capnp.Message (Mutability(..)) -import Capnp.New.Classes (Parse) -import Capnp.TraversalLimit (evalLimitT) - + ( msgToLBS, + msgToParsed, + msgToRaw, + parsedToBuilder, + parsedToLBS, + ) +import Capnp.Message (Mutability (..)) import qualified Capnp.Message as M -import qualified Capnp.Repr as R +import qualified Capnp.Repr as R +import Capnp.TraversalLimit (evalLimitT) +import Control.Exception (throwIO) +import Control.Monad.Trans.Class (lift) +import Data.Bits +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import Network.Simple.TCP (Socket, recv, sendLazy) +import System.IO (Handle, stdin, stdout) +import System.IO.Error (eofErrorType, mkIOError) -- | Like 'hGetMsg', except that it takes a socket instead of a 'Handle'. sGetMsg :: Socket -> WordCount -> IO (M.Message 'Const) sGetMsg socket limit = - evalLimitT limit $ M.readMessage (lift read32) (lift . readSegment) + evalLimitT limit $ M.readMessage (lift read32) (lift . readSegment) where read32 = do - bytes <- recvFull 4 - pure $ - (fromIntegral (bytes `BS.index` 0) `shiftL` 0) .|. - (fromIntegral (bytes `BS.index` 1) `shiftL` 8) .|. - (fromIntegral (bytes `BS.index` 2) `shiftL` 16) .|. - (fromIntegral (bytes `BS.index` 3) `shiftL` 24) + bytes <- recvFull 4 + pure $ + (fromIntegral (bytes `BS.index` 0) `shiftL` 0) + .|. (fromIntegral (bytes `BS.index` 1) `shiftL` 8) + .|. (fromIntegral (bytes `BS.index` 2) `shiftL` 16) + .|. (fromIntegral (bytes `BS.index` 3) `shiftL` 24) readSegment !words = - M.fromByteString <$> recvFull (fromIntegral $ wordsToBytes words) + M.fromByteString <$> recvFull (fromIntegral $ wordsToBytes words) - -- | Like recv, but (1) never returns less than `count` bytes, (2) + -- \| Like recv, but (1) never returns less than `count` bytes, (2) -- uses `socket`, rather than taking the socket as an argument, and (3) -- throws an EOF exception when the connection is closed. recvFull :: Int -> IO BS.ByteString recvFull !count = do - maybeBytes <- recv socket count - case maybeBytes of - Nothing -> - throwIO $ mkIOError eofErrorType "Remote socket closed" Nothing Nothing - Just bytes - | BS.length bytes == count -> - pure bytes - | otherwise -> - (bytes <>) <$> recvFull (count - BS.length bytes) + maybeBytes <- recv socket count + case maybeBytes of + Nothing -> + throwIO $ mkIOError eofErrorType "Remote socket closed" Nothing Nothing + Just bytes + | BS.length bytes == count -> + pure bytes + | otherwise -> + (bytes <>) <$> recvFull (count - BS.length bytes) -- | Like 'hPutMsg', except that it takes a 'Socket' instead of a 'Handle'. sPutMsg :: Socket -> M.Message 'Const -> IO () @@ -89,15 +90,15 @@ -- read limit. hGetParsed :: forall a pa. (R.IsStruct a, Parse a pa) => Handle -> WordCount -> IO pa hGetParsed handle limit = do - msg <- M.hGetMsg handle limit - evalLimitT limit $ msgToParsed @a msg + msg <- M.hGetMsg handle limit + evalLimitT limit $ msgToParsed @a msg -- | Read a struct from the socket in its parsed form, using the supplied -- read limit. sGetParsed :: forall a pa. (R.IsStruct a, Parse a pa) => Socket -> WordCount -> IO pa sGetParsed socket limit = do - msg <- sGetMsg socket limit - evalLimitT limit $ msgToParsed @a msg + msg <- sGetMsg socket limit + evalLimitT limit $ msgToParsed @a msg -- | Read a struct from stdin in its parsed form, using the supplied -- read limit. @@ -107,8 +108,8 @@ -- | Write the parsed form of a struct to the handle hPutParsed :: (R.IsStruct a, Parse a pa) => Handle -> pa -> IO () hPutParsed h value = do - bb <- evalLimitT maxBound $ parsedToBuilder value - BB.hPutBuilder h bb + bb <- evalLimitT maxBound $ parsedToBuilder value + BB.hPutBuilder h bb -- | Write the parsed form of a struct to stdout putParsed :: (R.IsStruct a, Parse a pa) => pa -> IO () @@ -116,16 +117,16 @@ -- | Write the parsed form of a struct to the socket. sPutParsed :: (R.IsStruct a, Parse a pa) => Socket -> pa -> IO () -sPutParsed socket value = do - lbs <- evalLimitT maxBound $ parsedToLBS value - sendLazy socket lbs +sPutParsed socket value = do + lbs <- evalLimitT maxBound $ parsedToLBS value + sendLazy socket lbs -- | Read a struct from the handle using the supplied read limit, -- and return its root pointer. hGetRaw :: R.IsStruct a => Handle -> WordCount -> IO (R.Raw a 'Const) hGetRaw h limit = do - msg <- M.hGetMsg h limit - evalLimitT limit $ msgToRaw msg + msg <- M.hGetMsg h limit + evalLimitT limit $ msgToRaw msg -- | Read a struct from stdin using the supplied read limit, -- and return its root pointer. @@ -136,5 +137,5 @@ -- and return its root pointer. sGetRaw :: R.IsStruct a => Socket -> WordCount -> IO (R.Raw a 'Const) sGetRaw socket limit = do - msg <- sGetMsg socket limit - evalLimitT limit $ msgToRaw msg + msg <- sGetMsg socket limit + evalLimitT limit $ msgToRaw msg diff --git a/lib/Capnp/Message.hs b/lib/Capnp/Message.hs --- a/lib/Capnp/Message.hs +++ b/lib/Capnp/Message.hs @@ -1,122 +1,114 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{-| -Module: Capnp.Message -Description: Cap'N Proto messages +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} -This module provides support for working directly with Cap'N Proto messages. --} -module Capnp.Message ( - Message - , Segment - , Mutability(..) +-- | +-- Module: Capnp.Message +-- Description: Cap'N Proto messages +-- +-- This module provides support for working directly with Cap'N Proto messages. +module Capnp.Message + ( Message, + Segment, + Mutability (..), -- * Reading and writing messages - , hPutMsg - , hGetMsg - , putMsg - , getMsg - - , readMessage - , writeMessage + hPutMsg, + hGetMsg, + putMsg, + getMsg, + readMessage, + writeMessage, -- * Limits on message size - , maxSegmentSize - , maxSegments - , maxCaps + maxSegmentSize, + maxSegments, + maxCaps, -- * Converting between messages and 'ByteString's - , encode - , decode - , toByteString - , fromByteString + encode, + decode, + toByteString, + fromByteString, -- * Accessing underlying storage - , segToVecMut + segToVecMut, -- * Immutable messages - , empty - , singleSegment + empty, + singleSegment, -- * Reading data from messages - , MonadReadMessage(..) - , getCap - , getCapTable - , getWord - , totalNumWords + MonadReadMessage (..), + getCap, + getCapTable, + getWord, + totalNumWords, -- * Mutable Messages - , newMessage + newMessage, -- ** Allocating space in messages - , WordPtr(..) - , alloc - , allocInSeg - , newSegment + WordPtr (..), + alloc, + allocInSeg, + newSegment, -- ** Modifying messages - , setSegment - , write - , setCap - , appendCap - - , WriteCtx - - , Client - , nullClient - , withCapTable - ) where - -import {-# SOURCE #-} Capnp.Rpc.Untyped (Client, nullClient) - -import Prelude hiding (read) + setSegment, + write, + setCap, + appendCap, + WriteCtx, + Client, + nullClient, + withCapTable, + ) +where -import Control.Monad (void, when, (>=>)) -import Control.Monad.Catch (MonadThrow(..)) -import Control.Monad.Primitive (PrimMonad, PrimState, stToPrim) -import Control.Monad.State (evalStateT, get, put) +import Capnp.Address (WordAddr (..)) +import Capnp.Bits (WordCount (..), hi, lo) +import qualified Capnp.Errors as E +import Capnp.Mutability (MaybeMutable (..), Mutability (..)) +import Capnp.TraversalLimit (LimitT, MonadLimit (invoice), evalLimitT) +import Control.Monad (void, when, (>=>)) +import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Primitive (PrimMonad, PrimState, stToPrim) +import Control.Monad.State (evalStateT, get, put) import Control.Monad.Trans.Class (lift) -import Control.Monad.Writer (execWriterT, tell) -import Data.Bits (shiftL) -import Data.ByteString.Internal (ByteString(..)) -import Data.Bytes.Get (getWord32le, runGetS) -import Data.Maybe (fromJust) -import Data.Primitive (MutVar, newMutVar, readMutVar, writeMutVar) -import Data.Word (Word32, Word64, byteSwap64) -import GHC.ByteOrder (ByteOrder(..), targetByteOrder) -import System.IO (Handle, stdin, stdout) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BB -import qualified Data.Vector as V -import qualified Data.Vector.Generic.Mutable as GMV -import qualified Data.Vector.Mutable as MV -import qualified Data.Vector.Storable as SV +import Control.Monad.Writer (execWriterT, tell) +import Data.Bits (shiftL) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import Data.ByteString.Internal (ByteString (..)) +import Data.Bytes.Get (getWord32le, runGetS) +import Data.Maybe (fromJust) +import Data.Primitive (MutVar, newMutVar, readMutVar, writeMutVar) +import qualified Data.Vector as V +import qualified Data.Vector.Generic.Mutable as GMV +import qualified Data.Vector.Mutable as MV +import qualified Data.Vector.Storable as SV import qualified Data.Vector.Storable.Mutable as SMV - -import Capnp.Address (WordAddr(..)) -import Capnp.Bits (WordCount(..), hi, lo) -import Capnp.Mutability (MaybeMutable(..), Mutability(..)) -import Capnp.TraversalLimit (LimitT, MonadLimit(invoice), evalLimitT) -import Internal.AppendVec (AppendVec) - -import qualified Capnp.Errors as E +import Data.Word (Word32, Word64, byteSwap64) +import GHC.ByteOrder (ByteOrder (..), targetByteOrder) +import Internal.AppendVec (AppendVec) import qualified Internal.AppendVec as AppendVec +import Internal.Rpc.Breaker (Client, nullClient) +import System.IO (Handle, stdin, stdout) +import Prelude hiding (read) swapIfBE64, fromLE64, toLE64 :: Word64 -> Word64 swapIfBE64 = case targetByteOrder of - LittleEndian -> id - BigEndian -> byteSwap64 + LittleEndian -> id + BigEndian -> byteSwap64 fromLE64 = swapIfBE64 toLE64 = swapIfBE64 - -- | The maximum size of a segment supported by this libarary, in words. maxSegmentSize :: WordCount maxSegmentSize = WordCount $ 1 `shiftL` 28 -- 2 GiB. @@ -134,156 +126,164 @@ -- to the segment and message, which can improve performance in very -- low-level code. data WordPtr mut = WordPtr - -- invariants: - -- - -- - pAddr's segment index refers to pSegment. - -- - pSegment is in pMessage. - { pMessage :: !(Message mut) - , pSegment :: !(Segment mut) - , pAddr :: {-# UNPACK #-} !WordAddr - } + -- invariants: + -- + -- - pAddr's segment index refers to pSegment. + -- - pSegment is in pMessage. + { pMessage :: !(Message mut), + pSegment :: !(Segment mut), + pAddr :: {-# UNPACK #-} !WordAddr + } -- | A Cap'n Proto message, parametrized over its mutability. data family Message (mut :: Mutability) newtype instance Message 'Const = MsgConst ConstMsg - deriving(Eq) + deriving (Eq) + newtype instance Message ('Mut s) = MsgMut (MutMsg s) - deriving(Eq) + deriving (Eq) -- | A segment in a Cap'n Proto message. data family Segment (mut :: Mutability) newtype instance Segment 'Const = SegConst ConstSegment - deriving(Eq) + deriving (Eq) + newtype instance Segment ('Mut s) = SegMut (MutSegment s) - deriving(Eq) + deriving (Eq) data MutSegment s = MutSegment - { vec :: SMV.MVector s Word64 - , used :: MutVar s WordCount - } + { vec :: SMV.MVector s Word64, + used :: MutVar s WordCount + } -- | Return the underlying storage of a mutable segment, as a vector. -- -- Note that the elements of the vector will be stored in little-endian form, regardless of -- CPU endianness. This is a low level function that you should probably not use. segToVecMut :: (PrimMonad m, PrimState m ~ s) => Segment ('Mut s) -> m (SMV.MVector s Word64) -segToVecMut (SegMut MutSegment{vec, used}) = do - count <- readMutVar used - pure $ SMV.take (fromIntegral count) vec +segToVecMut (SegMut MutSegment {vec, used}) = do + count <- readMutVar used + pure $ SMV.take (fromIntegral count) vec instance Eq (MutSegment s) where - MutSegment{used=x} == MutSegment{used=y} = x == y + MutSegment {used = x} == MutSegment {used = y} = x == y newtype ConstSegment = ConstSegment (SV.Vector Word64) - deriving(Eq) + deriving (Eq) -- | A 'Message' is a (possibly read-only) capnproto message. It is -- parameterized over a monad in which operations are performed. class Monad m => MonadReadMessage mut m where - -- | 'numSegs' gets the number of segments in a message. - numSegs :: Message mut -> m Int - -- | 'numWords' gets the number of words in a segment. - numWords :: Segment mut -> m WordCount - -- | 'numCaps' gets the number of capabilities in a message's capability - -- table. - numCaps :: Message mut -> m Int - -- | @'getSegment' message index@ gets the segment at index 'index' - -- in 'message'. - getSegment :: Message mut -> Int -> m (Segment mut) - -- | @'internalGetCap' cap index@ reads a capability from the message's - -- capability table, returning the client. does not check bounds. Callers - -- should use getCap instead. - internalGetCap :: Message mut -> Int -> m Client - -- | @'slice' start length segment@ extracts a sub-section of the segment, - -- starting at index @start@, of length @length@. - slice :: WordCount -> WordCount -> Segment mut -> m (Segment mut) - -- | @'read' segment index@ reads a 64-bit word from the segement at the - -- given index. Consider using 'getWord' on the message, instead of - -- calling this directly. - read :: Segment mut -> WordCount -> m Word64 + -- | 'numSegs' gets the number of segments in a message. + numSegs :: Message mut -> m Int + -- | 'numWords' gets the number of words in a segment. + numWords :: Segment mut -> m WordCount + + -- | 'numCaps' gets the number of capabilities in a message's capability + -- table. + numCaps :: Message mut -> m Int + + -- | @'getSegment' message index@ gets the segment at index 'index' + -- in 'message'. + getSegment :: Message mut -> Int -> m (Segment mut) + + -- | @'internalGetCap' cap index@ reads a capability from the message's + -- capability table, returning the client. does not check bounds. Callers + -- should use getCap instead. + internalGetCap :: Message mut -> Int -> m Client + + -- | @'slice' start length segment@ extracts a sub-section of the segment, + -- starting at index @start@, of length @length@. + slice :: WordCount -> WordCount -> Segment mut -> m (Segment mut) + + -- | @'read' segment index@ reads a 64-bit word from the segement at the + -- given index. Consider using 'getWord' on the message, instead of + -- calling this directly. + read :: Segment mut -> WordCount -> m Word64 + -- | Convert a ByteString to a segment. O(1) fromByteString :: ByteString -> Segment 'Const -- FIXME: Verify that the pointer is actually 64-bit aligned before casting. fromByteString (PS fptr offset len) = - SegConst $ ConstSegment (SV.unsafeCast $ SV.unsafeFromForeignPtr fptr offset len) + SegConst $ ConstSegment (SV.unsafeCast $ SV.unsafeFromForeignPtr fptr offset len) -- | Convert a segment to a byte string. O(1) toByteString :: Segment 'Const -> ByteString -toByteString (SegConst (ConstSegment vec)) = PS fptr offset len where +toByteString (SegConst (ConstSegment vec)) = PS fptr offset len + where (fptr, offset, len) = SV.unsafeToForeignPtr (SV.unsafeCast vec) -- | @'withCapTable'@ replaces the capability table in the message. withCapTable :: V.Vector Client -> Message 'Const -> Message 'Const -withCapTable newCaps (MsgConst msg) = MsgConst $ msg { constCaps = newCaps } +withCapTable newCaps (MsgConst msg) = MsgConst $ msg {constCaps = newCaps} -- | 'getCapTable' gets the capability table from a 'ConstMsg'. getCapTable :: Message 'Const -> V.Vector Client -getCapTable (MsgConst ConstMsg{constCaps}) = constCaps +getCapTable (MsgConst ConstMsg {constCaps}) = constCaps -- | 'getWord' gets the word referred to by the 'WordPtr' getWord :: MonadReadMessage mut m => WordPtr mut -> m Word64 -getWord WordPtr{pSegment, pAddr=WordAt{wordIndex}} = read pSegment wordIndex +getWord WordPtr {pSegment, pAddr = WordAt {wordIndex}} = read pSegment wordIndex -- | @'getCap' message index@ gets the capability with the given index from -- the message. throws 'E.BoundsError' if the index is out -- of bounds. getCap :: (MonadThrow m, MonadReadMessage mut m) => Message mut -> Int -> m Client getCap msg i = do - ncaps <- numCaps msg - if i >= ncaps || i < 0 - then pure nullClient - else msg `internalGetCap` i + ncaps <- numCaps msg + if i >= ncaps || i < 0 + then pure nullClient + else msg `internalGetCap` i -- | @'setSegment' message index segment@ sets the segment at the given index -- in the message. setSegment :: WriteCtx m s => Message ('Mut s) -> Int -> Segment ('Mut s) -> m () -setSegment (MsgMut MutMsg{mutSegs}) segIndex seg = do - segs <- AppendVec.getVector <$> readMutVar mutSegs - MV.write segs segIndex seg +setSegment (MsgMut MutMsg {mutSegs}) segIndex seg = do + segs <- AppendVec.getVector <$> readMutVar mutSegs + MV.write segs segIndex seg -- | @'setCap' message index cap@ sets the sets the capability at @index@ in -- the message's capability table to @cap@. If the index is out of bounds, a -- 'E.BoundsError' will be thrown. setCap :: WriteCtx m s => Message ('Mut s) -> Int -> Client -> m () -setCap msg@(MsgMut MutMsg{mutCaps}) i cap = do - checkIndex i =<< numCaps msg - capTable <- AppendVec.getVector <$> readMutVar mutCaps - MV.write capTable i cap +setCap msg@(MsgMut MutMsg {mutCaps}) i cap = do + checkIndex i =<< numCaps msg + capTable <- AppendVec.getVector <$> readMutVar mutCaps + MV.write capTable i cap -- | 'appendCap' appends a new capabilty to the end of a message's capability -- table, returning its index. appendCap :: WriteCtx m s => Message ('Mut s) -> Client -> m Int -appendCap msg@(MsgMut MutMsg{mutCaps}) cap = do - i <- numCaps msg - capTable <- readMutVar mutCaps - capTable <- AppendVec.grow capTable 1 maxCaps - writeMutVar mutCaps capTable - setCap msg i cap - pure i +appendCap msg@(MsgMut MutMsg {mutCaps}) cap = do + i <- numCaps msg + capTable <- readMutVar mutCaps + capTable <- AppendVec.grow capTable 1 maxCaps + writeMutVar mutCaps capTable + setCap msg i cap + pure i -- | A read-only capnproto message. -- -- 'ConstMsg' is an instance of the generic 'Message' type class. data ConstMsg = ConstMsg - { constSegs :: V.Vector (Segment 'Const) - , constCaps :: V.Vector Client - } - deriving(Eq) + { constSegs :: V.Vector (Segment 'Const), + constCaps :: V.Vector Client + } + deriving (Eq) instance Monad m => MonadReadMessage 'Const m where - numSegs (MsgConst ConstMsg{constSegs}) = pure $ V.length constSegs - numCaps (MsgConst ConstMsg{constCaps}) = pure $ V.length constCaps - getSegment (MsgConst ConstMsg{constSegs}) i = constSegs `V.indexM` i - internalGetCap (MsgConst ConstMsg{constCaps}) i = constCaps `V.indexM` i - - numWords (SegConst (ConstSegment vec)) = pure $ WordCount $ SV.length vec - slice (WordCount start) (WordCount len) (SegConst (ConstSegment vec)) = - pure $ SegConst $ ConstSegment (SV.slice start len vec) - read (SegConst (ConstSegment vec)) i = pure $! fromLE64 $! vec SV.! fromIntegral i + numSegs (MsgConst ConstMsg {constSegs}) = pure $ V.length constSegs + numCaps (MsgConst ConstMsg {constCaps}) = pure $ V.length constCaps + getSegment (MsgConst ConstMsg {constSegs}) i = constSegs `V.indexM` i + internalGetCap (MsgConst ConstMsg {constCaps}) i = constCaps `V.indexM` i + numWords (SegConst (ConstSegment vec)) = pure $ WordCount $ SV.length vec + slice (WordCount start) (WordCount len) (SegConst (ConstSegment vec)) = + pure $ SegConst $ ConstSegment (SV.slice start len vec) + read (SegConst (ConstSegment vec)) i = pure $! fromLE64 $! vec SV.! fromIntegral i -- | 'decode' decodes a message from a bytestring. -- @@ -295,10 +295,12 @@ -- | 'encode' encodes a message as a bytestring builder. encode :: Message 'Const -> BB.Builder encode msg = - -- We use Maybe as the MonadThrow instance required by - -- writeMessage/toByteString, but we know this can't actually fail, - -- so we ignore errors. - fromJust $ execWriterT $ writeMessage + -- We use Maybe as the MonadThrow instance required by + -- writeMessage/toByteString, but we know this can't actually fail, + -- so we ignore errors. + fromJust $ + execWriterT $ + writeMessage msg (tell . BB.word32LE) (tell . BB.byteString . toByteString) @@ -309,30 +311,31 @@ -- this is mostly here as a helper for 'decode'. decodeSeg :: MonadThrow m => Segment 'Const -> m (Message 'Const) decodeSeg seg = do - len <- numWords seg - flip evalStateT (Nothing, 0) $ evalLimitT len $ - -- Note: we use the traversal limit to avoid needing to do bounds checking - -- here; since readMessage invoices the limit before reading, we can rely - -- on it not to read past the end of the blob. - -- - -- TODO: while this works, it means that we throw 'TraversalLimitError' - -- on failure, which makes for a confusing API. - readMessage read32 readSegment + len <- numWords seg + flip evalStateT (Nothing, 0) $ + evalLimitT len $ + -- Note: we use the traversal limit to avoid needing to do bounds checking + -- here; since readMessage invoices the limit before reading, we can rely + -- on it not to read past the end of the blob. + -- + -- TODO: while this works, it means that we throw 'TraversalLimitError' + -- on failure, which makes for a confusing API. + readMessage read32 readSegment where read32 = do - (cur, idx) <- get - case cur of - Just n -> do - put (Nothing, idx) - return n - Nothing -> do - word <- lift $ lift $ read seg idx - put (Just $ hi word, idx + 1) - return (lo word) + (cur, idx) <- get + case cur of + Just n -> do + put (Nothing, idx) + return n + Nothing -> do + word <- lift $ lift $ read seg idx + put (Just $ hi word, idx + 1) + return (lo word) readSegment len = do - (cur, idx) <- get - put (cur, idx + len) - lift $ lift $ slice idx len seg + (cur, idx) <- get + put (cur, idx + len) + lift $ lift $ slice idx len seg -- | @'readMessage' read32 readSegment@ reads in a message using the -- monadic context, which should manage the current read position, @@ -342,27 +345,26 @@ -- limit which can be used to set the maximum message size. readMessage :: (MonadThrow m, MonadLimit m) => m Word32 -> (WordCount -> m (Segment 'Const)) -> m (Message 'Const) readMessage read32 readSegment = do - invoice 1 - numSegs' <- read32 - let numSegs = numSegs' + 1 - invoice (fromIntegral numSegs `div` 2) - segSizes <- V.replicateM (fromIntegral numSegs) read32 - when (even numSegs) $ void read32 - V.mapM_ (invoice . fromIntegral) segSizes - constSegs <- V.mapM (readSegment . fromIntegral) segSizes - pure $ MsgConst ConstMsg{constSegs, constCaps = V.empty} + invoice 1 + numSegs' <- read32 + let numSegs = numSegs' + 1 + invoice (fromIntegral numSegs `div` 2) + segSizes <- V.replicateM (fromIntegral numSegs) read32 + when (even numSegs) $ void read32 + V.mapM_ (invoice . fromIntegral) segSizes + constSegs <- V.mapM (readSegment . fromIntegral) segSizes + pure $ MsgConst ConstMsg {constSegs, constCaps = V.empty} -- | @'writeMesage' write32 writeSegment@ writes out the message. @write32@ -- should write a 32-bit word in little-endian format to the output stream. -- @writeSegment@ should write a blob. writeMessage :: MonadThrow m => Message 'Const -> (Word32 -> m ()) -> (Segment 'Const -> m ()) -> m () -writeMessage (MsgConst ConstMsg{constSegs}) write32 writeSegment = do - let numSegs = V.length constSegs - write32 (fromIntegral numSegs - 1) - V.forM_ constSegs $ \seg -> write32 . fromIntegral =<< numWords seg - when (even numSegs) $ write32 0 - V.forM_ constSegs writeSegment - +writeMessage (MsgConst ConstMsg {constSegs}) write32 writeSegment = do + let numSegs = V.length constSegs + write32 (fromIntegral numSegs - 1) + V.forM_ constSegs $ \seg -> write32 . fromIntegral =<< numWords seg + when (even numSegs) $ write32 0 + V.forM_ constSegs writeSegment -- | @'hPutMsg' handle msg@ writes @msg@ to @handle@. If there is an exception, -- it will be an 'IOError' raised by the underlying IO libraries. @@ -377,19 +379,19 @@ -- @limit@ 64-bit words in length. hGetMsg :: Handle -> WordCount -> IO (Message 'Const) hGetMsg handle size = - evalLimitT size $ readMessage read32 readSegment + evalLimitT size $ readMessage read32 readSegment where read32 :: LimitT IO Word32 read32 = lift $ do - bytes <- BS.hGet handle 4 - case runGetS getWord32le bytes of - Left _ -> - -- the only way this can happen is if we get < 4 bytes. - throwM $ E.InvalidDataError "Unexpected end of input" - Right result -> - pure result + bytes <- BS.hGet handle 4 + case runGetS getWord32le bytes of + Left _ -> + -- the only way this can happen is if we get < 4 bytes. + throwM $ E.InvalidDataError "Unexpected end of input" + Right result -> + pure result readSegment n = - lift (fromByteString <$> BS.hGet handle (fromIntegral n * 8)) + lift (fromByteString <$> BS.hGet handle (fromIntegral n * 8)) -- | Equivalent to @'hGetMsg' 'stdin'@ getMsg :: WordCount -> IO (Message 'Const) @@ -399,65 +401,68 @@ -- state token for the instance of 'PrimMonad' in which the message may be -- modified. data MutMsg s = MutMsg - { mutSegs :: MutVar s (AppendVec MV.MVector s (Segment ('Mut s))) - , mutCaps :: MutVar s (AppendVec MV.MVector s Client) - } - deriving(Eq) + { mutSegs :: MutVar s (AppendVec MV.MVector s (Segment ('Mut s))), + mutCaps :: MutVar s (AppendVec MV.MVector s Client) + } + deriving (Eq) -- | 'WriteCtx' is the context needed for most write operations. type WriteCtx m s = (PrimMonad m, s ~ PrimState m, MonadThrow m) instance (PrimMonad m, s ~ PrimState m) => MonadReadMessage ('Mut s) m where - numWords (SegMut MutSegment{used}) = stToPrim $ readMutVar used - slice (WordCount start) (WordCount len) (SegMut MutSegment{vec, used}) = stToPrim $ do - WordCount end <- readMutVar used - let len' = min (end - start) len - used' <- newMutVar $ WordCount len' - pure $ SegMut MutSegment - { vec = SMV.slice start len' vec - , used = used' - } - read (SegMut MutSegment{vec}) i = stToPrim $ - fromLE64 <$> SMV.read vec (fromIntegral i) - numSegs (MsgMut MutMsg{mutSegs}) = - stToPrim $ GMV.length . AppendVec.getVector <$> readMutVar mutSegs - numCaps (MsgMut MutMsg{mutCaps}) = - stToPrim $ GMV.length . AppendVec.getVector <$> readMutVar mutCaps - getSegment (MsgMut MutMsg{mutSegs}) i = stToPrim $ do - segs <- AppendVec.getVector <$> readMutVar mutSegs - MV.read segs i - internalGetCap (MsgMut MutMsg{mutCaps}) i = stToPrim $ do - caps <- AppendVec.getVector <$> readMutVar mutCaps - MV.read caps i + numWords (SegMut MutSegment {used}) = stToPrim $ readMutVar used + slice (WordCount start) (WordCount len) (SegMut MutSegment {vec, used}) = stToPrim $ do + WordCount end <- readMutVar used + let len' = min (end - start) len + used' <- newMutVar $ WordCount len' + pure $ + SegMut + MutSegment + { vec = SMV.slice start len' vec, + used = used' + } + read (SegMut MutSegment {vec}) i = + stToPrim $ + fromLE64 <$> SMV.read vec (fromIntegral i) + numSegs (MsgMut MutMsg {mutSegs}) = + stToPrim $ GMV.length . AppendVec.getVector <$> readMutVar mutSegs + numCaps (MsgMut MutMsg {mutCaps}) = + stToPrim $ GMV.length . AppendVec.getVector <$> readMutVar mutCaps + getSegment (MsgMut MutMsg {mutSegs}) i = stToPrim $ do + segs <- AppendVec.getVector <$> readMutVar mutSegs + MV.read segs i + internalGetCap (MsgMut MutMsg {mutCaps}) i = stToPrim $ do + caps <- AppendVec.getVector <$> readMutVar mutCaps + MV.read caps i -- | @'write' segment index value@ writes a value to the 64-bit word -- at the provided index. Consider using 'setWord' on the message, -- instead of calling this directly. write :: WriteCtx m s => Segment ('Mut s) -> WordCount -> Word64 -> m () {-# INLINE write #-} -write (SegMut MutSegment{vec}) (WordCount i) val = do - SMV.write vec i (toLE64 val) +write (SegMut MutSegment {vec}) (WordCount i) val = do + SMV.write vec i (toLE64 val) -- | @'newSegment' msg sizeHint@ allocates a new, initially empty segment in -- @msg@ with a capacity of @sizeHint@ words. It returns the a pair of the -- segment number and the segment itself. Amortized O(1). newSegment :: WriteCtx m s => Message ('Mut s) -> WordCount -> m (Int, Segment ('Mut s)) -newSegment msg@(MsgMut MutMsg{mutSegs}) sizeHint = do - when (sizeHint > maxSegmentSize) $ throwM E.SizeError - -- the next segment number will be equal to the *current* number of - -- segments: - segIndex <- numSegs msg +newSegment msg@(MsgMut MutMsg {mutSegs}) sizeHint = do + when (sizeHint > maxSegmentSize) $ throwM E.SizeError + -- the next segment number will be equal to the *current* number of + -- segments: + segIndex <- numSegs msg - -- make space for th new segment - segs <- readMutVar mutSegs - segs <- AppendVec.grow segs 1 maxSegments - writeMutVar mutSegs segs + -- make space for th new segment + segs <- readMutVar mutSegs + segs <- AppendVec.grow segs 1 maxSegments + writeMutVar mutSegs segs - vec <- SMV.new (fromIntegral sizeHint) - used <- newMutVar 0 - let newSeg = SegMut MutSegment{vec, used} - setSegment msg segIndex newSeg - pure (segIndex, newSeg) + vec <- SMV.new (fromIntegral sizeHint) + used <- newMutVar 0 + let newSeg = SegMut MutSegment {vec, used} + setSegment msg segIndex newSeg + pure (segIndex, newSeg) -- | Like 'alloc', but the second argument allows the caller to specify the -- index of the segment in which to allocate the data. Returns 'Nothing' if there is @@ -465,146 +470,159 @@ allocInSeg :: WriteCtx m s => Message ('Mut s) -> Int -> WordCount -> m (Maybe (WordPtr ('Mut s))) {-# INLINE allocInSeg #-} allocInSeg msg segIndex size = do - -- GHC's type inference aparently isn't smart enough to figure - -- out that the pattern irrefutable if we do seg@(SegMut ...) <- ... - -- but this works: - seg <- getSegment msg segIndex - case seg of - SegMut MutSegment{vec, used} -> do - nextAlloc <- readMutVar used - if WordCount (SMV.length vec) - nextAlloc < size - then pure Nothing - else (do - writeMutVar used $! nextAlloc + size - pure $ Just WordPtr - { pAddr = WordAt - { segIndex - , wordIndex = nextAlloc - } - , pSegment = seg - , pMessage = msg - }) + -- GHC's type inference aparently isn't smart enough to figure + -- out that the pattern irrefutable if we do seg@(SegMut ...) <- ... + -- but this works: + seg <- getSegment msg segIndex + case seg of + SegMut MutSegment {vec, used} -> do + nextAlloc <- readMutVar used + if WordCount (SMV.length vec) - nextAlloc < size + then pure Nothing + else + ( do + writeMutVar used $! nextAlloc + size + pure $ + Just + WordPtr + { pAddr = + WordAt + { segIndex, + wordIndex = nextAlloc + }, + pSegment = seg, + pMessage = msg + } + ) -- | @'alloc' size@ allocates 'size' words within a message. it returns the -- starting address of the allocated memory, as well as a direct reference -- to the segment. The latter is redundant information, but this is used -- in low-level code where this can improve performance. alloc :: WriteCtx m s => Message ('Mut s) -> WordCount -> m (WordPtr ('Mut s)) -{-# INLINABLE alloc #-} +{-# INLINEABLE alloc #-} alloc msg size = do - when (size > maxSegmentSize) $ - throwM E.SizeError - segIndex <- pred <$> numSegs msg - existing <- allocInSeg msg segIndex size - case existing of - Just res -> pure res - Nothing -> do - -- Not enough space in the current segment; allocate a new one. - -- the new segment's size should match the total size of existing segments - -- but `maxSegmentSize` bounds how large it can get. - totalAllocation <- totalNumWords msg - ( newSegIndex, _ ) <- newSegment msg (min (max totalAllocation size) maxSegmentSize) - -- This is guaranteed to succeed, since we just made a segment with - -- at least size available space: - fromJust <$> allocInSeg msg newSegIndex size + when (size > maxSegmentSize) $ + throwM E.SizeError + segIndex <- pred <$> numSegs msg + existing <- allocInSeg msg segIndex size + case existing of + Just res -> pure res + Nothing -> do + -- Not enough space in the current segment; allocate a new one. + -- the new segment's size should match the total size of existing segments + -- but `maxSegmentSize` bounds how large it can get. + totalAllocation <- totalNumWords msg + (newSegIndex, _) <- newSegment msg (min (max totalAllocation size) maxSegmentSize) + -- This is guaranteed to succeed, since we just made a segment with + -- at least size available space: + fromJust <$> allocInSeg msg newSegIndex size -- | Return the total number of words in the message, i.e. the sum of -- the results of `numWords` on all segments. totalNumWords :: MonadReadMessage mut m => Message mut -> m WordCount totalNumWords msg = do - lastSegIndex <- pred <$> numSegs msg - sum <$> traverse (getSegment msg >=> numWords) [0..lastSegIndex] + lastSegIndex <- pred <$> numSegs msg + sum <$> traverse (getSegment msg >=> numWords) [0 .. lastSegIndex] -- | 'empty' is an empty message, i.e. a minimal message with a null pointer as -- its root object. empty :: Message 'Const -empty = MsgConst ConstMsg - { constSegs = V.fromList [ SegConst $ ConstSegment $ SV.fromList [0] ] - , constCaps = V.empty - } +empty = + MsgConst + ConstMsg + { constSegs = V.fromList [SegConst $ ConstSegment $ SV.fromList [0]], + constCaps = V.empty + } -- | @'newMessage' sizeHint@ allocates a new empty message, with a single segment -- having capacity @sizeHint@. If @sizeHint@ is 'Nothing', defaults to a sensible -- value. newMessage :: WriteCtx m s => Maybe WordCount -> m (Message ('Mut s)) newMessage Nothing = newMessage (Just 32) - -- The default value above is somewhat arbitrary, and just a guess -- we - -- should do some profiling to figure out what a good value is here. +-- The default value above is somewhat arbitrary, and just a guess -- we +-- should do some profiling to figure out what a good value is here. newMessage (Just sizeHint) = do - mutSegs <- MV.new 1 >>= newMutVar . AppendVec.makeEmpty - mutCaps <- MV.new 0 >>= newMutVar . AppendVec.makeEmpty - let msg = MsgMut MutMsg{mutSegs,mutCaps} - -- allocte the first segment, and make space for the root pointer: - _ <- newSegment msg sizeHint - _ <- alloc msg 1 - pure msg + mutSegs <- MV.new 1 >>= newMutVar . AppendVec.makeEmpty + mutCaps <- MV.new 0 >>= newMutVar . AppendVec.makeEmpty + let msg = MsgMut MutMsg {mutSegs, mutCaps} + -- allocte the first segment, and make space for the root pointer: + _ <- newSegment msg sizeHint + _ <- alloc msg 1 + pure msg -- | Create a message from a single segment. singleSegment :: Segment 'Const -> Message 'Const -singleSegment seg = MsgConst ConstMsg - { constSegs = V.singleton seg - , constCaps = V.empty - } +singleSegment seg = + MsgConst + ConstMsg + { constSegs = V.singleton seg, + constCaps = V.empty + } instance MaybeMutable Segment where - thaw = thawSeg SV.thaw - unsafeThaw = thawSeg SV.unsafeThaw - freeze = freezeSeg SV.freeze - unsafeFreeze = freezeSeg SV.unsafeFreeze + thaw = thawSeg SV.thaw + unsafeThaw = thawSeg SV.unsafeThaw + freeze = freezeSeg SV.freeze + unsafeFreeze = freezeSeg SV.unsafeFreeze -- Helpers for @Segment ConstMsg@'s Thaw instance. -thawSeg - :: (PrimMonad m, s ~ PrimState m) - => (SV.Vector Word64 -> m (SMV.MVector s Word64)) - -> Segment 'Const - -> m (Segment ('Mut s)) +thawSeg :: + (PrimMonad m, s ~ PrimState m) => + (SV.Vector Word64 -> m (SMV.MVector s Word64)) -> + Segment 'Const -> + m (Segment ('Mut s)) thawSeg thaw (SegConst (ConstSegment vec)) = do - mvec <- thaw vec - used <- newMutVar $ WordCount $ SV.length vec - pure $ SegMut MutSegment { vec = mvec, used } + mvec <- thaw vec + used <- newMutVar $ WordCount $ SV.length vec + pure $ SegMut MutSegment {vec = mvec, used} -freezeSeg - :: (PrimMonad m, s ~ PrimState m) - => (SMV.MVector s Word64 -> m (SV.Vector Word64)) - -> Segment ('Mut s) - -> m (Segment 'Const) -freezeSeg freeze (SegMut MutSegment{vec, used}) = do - WordCount len <- readMutVar used - SegConst .ConstSegment <$> freeze (SMV.take len vec) +freezeSeg :: + (PrimMonad m, s ~ PrimState m) => + (SMV.MVector s Word64 -> m (SV.Vector Word64)) -> + Segment ('Mut s) -> + m (Segment 'Const) +freezeSeg freeze (SegMut MutSegment {vec, used}) = do + WordCount len <- readMutVar used + SegConst . ConstSegment <$> freeze (SMV.take len vec) instance MaybeMutable Message where - thaw = thawMsg thaw V.thaw - unsafeThaw = thawMsg unsafeThaw V.unsafeThaw - freeze = freezeMsg freeze V.freeze - unsafeFreeze = freezeMsg unsafeFreeze V.unsafeFreeze + thaw = thawMsg thaw V.thaw + unsafeThaw = thawMsg unsafeThaw V.unsafeThaw + freeze = freezeMsg freeze V.freeze + unsafeFreeze = freezeMsg unsafeFreeze V.unsafeFreeze -- Helpers for ConstMsg's Thaw instance. -thawMsg :: (PrimMonad m, s ~ PrimState m) - => (Segment 'Const -> m (Segment ('Mut s))) - -> (V.Vector Client -> m (MV.MVector s Client)) - -> Message 'Const - -> m (Message ('Mut s)) -thawMsg thawSeg thawCaps (MsgConst ConstMsg{constSegs, constCaps}) = do - mutSegs <- newMutVar . AppendVec.fromVector =<< (V.mapM thawSeg constSegs >>= V.unsafeThaw) - mutCaps <- newMutVar . AppendVec.fromVector =<< thawCaps constCaps - pure $ MsgMut MutMsg{mutSegs, mutCaps} -freezeMsg :: (PrimMonad m, s ~ PrimState m) - => (Segment ('Mut s) -> m (Segment 'Const)) - -> (MV.MVector s Client -> m (V.Vector Client)) - -> Message ('Mut s) - -> m (Message 'Const) -freezeMsg freezeSeg freezeCaps msg@(MsgMut MutMsg{mutCaps}) = do - len <- numSegs msg - constSegs <- V.generateM len (getSegment msg >=> freezeSeg) - constCaps <- freezeCaps . AppendVec.getVector =<< readMutVar mutCaps - pure $ MsgConst ConstMsg{constSegs, constCaps} +thawMsg :: + (PrimMonad m, s ~ PrimState m) => + (Segment 'Const -> m (Segment ('Mut s))) -> + (V.Vector Client -> m (MV.MVector s Client)) -> + Message 'Const -> + m (Message ('Mut s)) +thawMsg thawSeg thawCaps (MsgConst ConstMsg {constSegs, constCaps}) = do + mutSegs <- newMutVar . AppendVec.fromVector =<< (V.mapM thawSeg constSegs >>= V.unsafeThaw) + mutCaps <- newMutVar . AppendVec.fromVector =<< thawCaps constCaps + pure $ MsgMut MutMsg {mutSegs, mutCaps} +freezeMsg :: + (PrimMonad m, s ~ PrimState m) => + (Segment ('Mut s) -> m (Segment 'Const)) -> + (MV.MVector s Client -> m (V.Vector Client)) -> + Message ('Mut s) -> + m (Message 'Const) +freezeMsg freezeSeg freezeCaps msg@(MsgMut MutMsg {mutCaps}) = do + len <- numSegs msg + constSegs <- V.generateM len (getSegment msg >=> freezeSeg) + constCaps <- freezeCaps . AppendVec.getVector =<< readMutVar mutCaps + pure $ MsgConst ConstMsg {constSegs, constCaps} + -- | @'checkIndex' index length@ checkes that 'index' is in the range -- [0, length), throwing a 'BoundsError' if not. checkIndex :: MonadThrow m => Int -> Int -> m () checkIndex i len = - when (i < 0 || i >= len) $ - throwM E.BoundsError - { E.index = i - , E.maxIndex = len - } + when (i < 0 || i >= len) $ + throwM + E.BoundsError + { E.index = i, + E.maxIndex = len + } diff --git a/lib/Capnp/Mutability.hs b/lib/Capnp/Mutability.hs --- a/lib/Capnp/Mutability.hs +++ b/lib/Capnp/Mutability.hs @@ -1,17 +1,19 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} + module Capnp.Mutability - ( Mutability(..) - , MaybeMutable(..) - , create - , createT - ) where + ( Mutability (..), + MaybeMutable (..), + create, + createT, + ) +where -import Control.Monad.Primitive (PrimMonad(PrimState)) -import Control.Monad.ST (ST, runST) -import Data.Kind (Type) +import Control.Monad.Primitive (PrimMonad (PrimState)) +import Control.Monad.ST (ST, runST) +import Data.Kind (Type) -- | 'Mutability' is used as a type parameter (with the DataKinds extension) -- to indicate the mutability of some values in this library; 'Const' denotes @@ -21,26 +23,26 @@ -- | 'MaybeMutable' relates mutable and immutable versions of a type. class MaybeMutable (f :: Mutability -> Type) where - -- | Convert an immutable value to a mutable one. - thaw :: (PrimMonad m, PrimState m ~ s) => f 'Const -> m (f ('Mut s)) + -- | Convert an immutable value to a mutable one. + thaw :: (PrimMonad m, PrimState m ~ s) => f 'Const -> m (f ('Mut s)) - -- | Convert a mutable value to an immutable one. - freeze :: (PrimMonad m, PrimState m ~ s) => f ('Mut s) -> m (f 'Const) + -- | Convert a mutable value to an immutable one. + freeze :: (PrimMonad m, PrimState m ~ s) => f ('Mut s) -> m (f 'Const) - -- | Like 'thaw', except that the caller is responsible for ensuring that - -- the original value is not subsequently used; doing so may violate - -- referential transparency. - -- - -- The default implementation of this is just the same as 'thaw', but - -- typically an instance will override this with a trivial (unsafe) cast, - -- hence the obligation described above. - unsafeThaw :: (PrimMonad m, PrimState m ~ s) => f 'Const -> m (f ('Mut s)) - unsafeThaw = thaw + -- | Like 'thaw', except that the caller is responsible for ensuring that + -- the original value is not subsequently used; doing so may violate + -- referential transparency. + -- + -- The default implementation of this is just the same as 'thaw', but + -- typically an instance will override this with a trivial (unsafe) cast, + -- hence the obligation described above. + unsafeThaw :: (PrimMonad m, PrimState m ~ s) => f 'Const -> m (f ('Mut s)) + unsafeThaw = thaw - -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must - -- ensure that the original value is not used after this call. - unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => f ('Mut s) -> m (f 'Const) - unsafeFreeze = freeze + -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must + -- ensure that the original value is not used after this call. + unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => f ('Mut s) -> m (f 'Const) + unsafeFreeze = freeze -- | Create and freeze a mutable value, safely, without doing a full copy. -- internally, 'create' calls unsafeFreeze, but it cannot be directly used to diff --git a/lib/Capnp/New.hs b/lib/Capnp/New.hs deleted file mode 100644 --- a/lib/Capnp/New.hs +++ /dev/null @@ -1,75 +0,0 @@ --- | Module: Capnp.New --- Description: Re-export commonly used things from elsewhere in the library. -module Capnp.New - ( module X - , Parsed - - -- * Working with raw values - , R.Raw(..) - - -- ** Working with raw lists - , R.List - , R.index - , R.setIndex - , R.length - - -- * Working with fields - , F.Field - , F.FieldKind - , F.HasField(..) - , F.HasUnion(..) - , F.HasVariant(..) - - -- * Working with messages - , Message.Message - , Message.Segment - , Message.Mutability(..) - , Message.MonadReadMessage(..) - , Message.newMessage - , Message.fromByteString - , Message.toByteString - - -- * Building messages in pure code - , PureBuilder - , createPure - - -- * Canonicalizing messages - , canonicalize - - -- * Implementing RPC servers - , MethodHandler - , SomeServer(..) - , Export(Server) - , export - , handleParsed - , handleRaw - , methodUnimplemented - - -- * Shorthands for types - , R.IsStruct - , R.IsCap - , R.IsPtr - - -- * Re-exported from "Data.Default", for convienence. - , def - ) where - --- TODO: be more intentional about the ordering of the stuff we're --- currently exposing as X, so the haddocks are clearer. - -import Capnp.Canonicalize (canonicalize) -import Capnp.Convert as X -import qualified Capnp.Fields as F -import Capnp.IO as X -import qualified Capnp.Message as Message -import Capnp.New.Accessors as X -import Capnp.New.Basics as X hiding (Parsed) -import Capnp.New.Classes as X hiding (Parsed) -import Capnp.New.Constraints as X -import Capnp.New.Rpc.Server -import qualified Capnp.Repr as R -import Capnp.Repr.Methods as X -import Capnp.Repr.Parsed (Parsed) -import Capnp.TraversalLimit as X -import Data.Default (def) -import Internal.BuildPure (PureBuilder, createPure) diff --git a/lib/Capnp/New/Accessors.hs b/lib/Capnp/New/Accessors.hs deleted file mode 100644 --- a/lib/Capnp/New/Accessors.hs +++ /dev/null @@ -1,223 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} --- | Module: Capnp.New.Accessors --- Description: Functions for accessing parts of messaages. -module Capnp.New.Accessors - ( readField - , getField - , setField - , newField - , hasField - , encodeField - , parseField - , setVariant - , initVariant - , encodeVariant - , structWhich - , unionWhich - , structUnion - , unionStruct - ) where - - -import qualified Capnp.Fields as F -import Capnp.Message (Mutability(..)) -import qualified Capnp.New.Classes as C -import qualified Capnp.Repr as R -import Capnp.TraversalLimit (evalLimitT) -import qualified Capnp.Untyped as U -import Data.Bits -import Data.Maybe (fromJust, isJust) -import Data.Word -import GHC.Prim (coerce) - -{-# INLINE readField #-} --- | Read the value of a field of a struct. -readField - :: forall k a b mut m. - ( R.IsStruct a - , U.ReadCtx m mut - ) - => F.Field k a b - -> R.Raw a mut - -> m (R.Raw b mut) -readField (F.Field field) (R.Raw struct) = - case field of - F.DataField F.DataFieldLoc{ shift, index, mask, defaultValue } -> do - word <- U.getData (fromIntegral index) struct - pure $ R.Raw $ C.fromWord $ ((word .&. mask) `shiftR` fromIntegral shift) `xor` defaultValue - F.PtrField index -> - U.getPtr (fromIntegral index) struct >>= readPtrField - F.GroupField -> - pure $ R.Raw struct - F.VoidField -> - pure $ R.Raw () - where - -- This is broken out because the type checker needs some extra help: - readPtrField - :: forall pr. - ( R.ReprFor b ~ 'R.Ptr pr - , R.IsPtrRepr pr - ) => Maybe (U.Ptr mut) -> m (R.Raw b mut) - readPtrField ptr = - R.Raw <$> R.fromPtr @pr (U.message @U.Struct struct) ptr - --- | Return whether the specified field is present. Only applicable for pointer --- fields. -hasField :: - ( U.ReadCtx m mut - , R.IsStruct a - , R.IsPtr b - ) => F.Field 'F.Slot a b -> R.Raw a mut -> m Bool -hasField (F.Field (F.PtrField index)) (R.Raw struct) = - isJust <$> U.getPtr (fromIntegral index) struct - -{-# INLINE getField #-} --- | Like 'readField', but: --- --- * Doesn't need the monadic context; can be used in pure code. --- * Only works for immutable values. --- * Only works for fields in the struct's data section. -getField - :: ( R.IsStruct a - , R.ReprFor b ~ 'R.Data sz - , C.Parse b bp - ) - => F.Field 'F.Slot a b - -> R.Raw a 'Const - -> bp -getField field struct = - fromJust $ evalLimitT maxBound $ - readField field struct >>= C.parse - -{-# INLINE setField #-} --- | Set a struct field to a value. Not usable for group fields. -setField :: - forall a b m s. - ( R.IsStruct a - , U.RWCtx m s - ) => F.Field 'F.Slot a b -> R.Raw b ('Mut s) -> R.Raw a ('Mut s) -> m () -setField (F.Field field) (R.Raw value) (R.Raw struct) = - case field of - F.DataField fieldLoc -> - setDataField fieldLoc - F.PtrField index -> - setPtrField index value struct - F.VoidField -> - pure () - where - -- This was originally broken out because the type checker needs some extra - -- help, but it's probably more readable this way anyway. - setPtrField - :: forall pr. - ( R.ReprFor b ~ 'R.Ptr pr - , R.IsPtrRepr pr - ) => Word16 -> U.Unwrapped (R.UntypedPtr pr ('Mut s)) -> U.Struct ('Mut s) -> m () - setPtrField index value struct = - U.setPtr (R.toPtr @pr value) (fromIntegral index) struct - - setDataField - :: forall sz. - ( R.ReprFor b ~ 'R.Data sz - , C.IsWord (R.UntypedData sz) - ) => F.DataFieldLoc sz -> m () - setDataField F.DataFieldLoc{ shift, index, mask, defaultValue } = do - oldWord <- U.getData (fromIntegral index) struct - let valueWord = C.toWord value `xor` defaultValue - newWord = (oldWord .&. complement mask) - .|. (valueWord `shiftL` fromIntegral shift) - U.setData newWord (fromIntegral index) struct - --- | Allocate space for the value of a field, and return it. -newField :: - forall a b m s. - ( R.IsStruct a - , C.Allocate b - , U.RWCtx m s - ) => F.Field 'F.Slot a b -> C.AllocHint b -> R.Raw a ('Mut s) -> m (R.Raw b ('Mut s)) -newField field hint parent = do - value <- C.new @b hint (U.message @(R.Raw a) parent) - setField field value parent - pure value - --- | Marshal a parsed value into a struct's field. -encodeField :: - forall a b m s bp. - ( R.IsStruct a - , C.Parse b bp - , U.RWCtx m s - ) => F.Field 'F.Slot a b -> bp -> R.Raw a ('Mut s) -> m () -encodeField field parsed struct = do - encoded <- C.encode (U.message @(R.Raw a) struct) parsed - setField field encoded struct - --- | parse a struct's field and return its parsed form. -parseField :: - ( R.IsStruct a - , C.Parse b bp - , U.ReadCtx m 'Const - ) => F.Field k a b -> R.Raw a 'Const -> m bp -parseField field raw = - readField field raw >>= C.parse - --- | Set the struct's anonymous union to the given variant, with the --- supplied value as its argument. Not applicable for variants whose --- argument is a group; use 'initVariant' instead. -setVariant - :: forall a b m s. - ( F.HasUnion a - , U.RWCtx m s - ) => F.Variant 'F.Slot a b -> R.Raw a ('Mut s) -> R.Raw b ('Mut s) -> m () -setVariant F.Variant{field, tagValue} struct value = do - setField (F.unionField @a) (R.Raw tagValue) struct - setField field value struct - --- | Set the struct's anonymous union to the given variant, marshalling --- the supplied value into the message to be its argument. Not applicable --- for variants whose argument is a group; use 'initVariant' instead. -encodeVariant - :: forall a b m s bp. - ( F.HasUnion a - , C.Parse b bp - , U.RWCtx m s - ) => F.Variant 'F.Slot a b -> bp -> R.Raw a ('Mut s) -> m () -encodeVariant F.Variant{field, tagValue} value struct = do - setField (F.unionField @a) (R.Raw tagValue) struct - encodeField field value struct - --- | Set the struct's anonymous union to the given variant, returning --- the variant's argument, which must be a group (for non-group fields, --- use 'setVariant' or 'encodeVariant'. -initVariant - :: forall a b m s. (F.HasUnion a, U.RWCtx m s) - => F.Variant 'F.Group a b -> R.Raw a ('Mut s) -> m (R.Raw b ('Mut s)) -initVariant F.Variant{field, tagValue} struct = do - setField (F.unionField @a) (R.Raw tagValue) struct - readField field struct - --- | Get the anonymous union for a struct. -structUnion :: F.HasUnion a => R.Raw a mut -> R.Raw (F.Which a) mut -structUnion = coerce - --- | Get the struct enclosing an anonymous union. -unionStruct :: F.HasUnion a => R.Raw (F.Which a) mut -> R.Raw a mut -unionStruct = coerce - --- | Get a non-opaque view on the struct's anonymous union, which --- can be used to pattern match on. -structWhich :: forall a mut m. (U.ReadCtx m mut, F.HasUnion a) => R.Raw a mut -> m (F.RawWhich a mut) -structWhich struct = do - R.Raw tagValue <- readField (F.unionField @a) struct - F.internalWhich tagValue struct - --- | Get a non-opaque view on the anonymous union, which can be --- used to pattern match on. -unionWhich :: forall a mut m. (U.ReadCtx m mut, F.HasUnion a) => R.Raw (F.Which a) mut -> m (F.RawWhich a mut) -unionWhich = structWhich . unionStruct diff --git a/lib/Capnp/New/Basics.hs b/lib/Capnp/New/Basics.hs deleted file mode 100644 --- a/lib/Capnp/New/Basics.hs +++ /dev/null @@ -1,272 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | --- Module: Capnp.New.Basics --- Description: Handling of "basic" capnp datatypes. --- --- This module contains phantom types for built-in Cap'n Proto --- types, analogous to the phantom types generated for structs --- by the code generator. It also defines applicable type class --- instances. -module Capnp.New.Basics where - --- XXX: I(zenhack) don't know how to supply an explicit --- export list here, since we have instances of data families --- and I don't know what to call the instances to get all of the --- constructors. - -import qualified Capnp.Errors as E -import qualified Capnp.Message as M -import qualified Capnp.New.Classes as C -import qualified Capnp.Repr as R -import qualified Capnp.Untyped as U -import Control.Monad (when) -import Control.Monad.Catch (MonadThrow, throwM) -import qualified Data.ByteString as BS -import Data.Default (Default(..)) -import Data.Foldable (foldl', for_) -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Vector as V -import Data.Word -import GHC.Generics (Generic) -import GHC.Prim (coerce) - --- | The Cap'n Proto @Text@ type. -data Text - --- | The Cap'n Proto @Data@ type. -data Data - --- | A Cap'n Proto @AnyPointer@, i.e. an arbitrary pointer with unknown schema. -data AnyPointer - --- | A Cap'n Proto @List@ with unknown element type. -data AnyList - --- | A Cap'n Proto struct of unknown type. -data AnyStruct - --- | A Cap'n Proto capability with unknown interfaces. -data Capability - -type instance R.ReprFor Data = R.ReprFor (R.List Word8) -type instance R.ReprFor Text = R.ReprFor (R.List Word8) -type instance R.ReprFor AnyPointer = 'R.Ptr 'Nothing -type instance R.ReprFor (Maybe AnyPointer) = 'R.Ptr 'Nothing -type instance R.ReprFor AnyList = 'R.Ptr ('Just ('R.List 'Nothing)) -type instance R.ReprFor AnyStruct = 'R.Ptr ('Just 'R.Struct) -type instance R.ReprFor Capability = 'R.Ptr ('Just 'R.Cap) - -data instance C.Parsed AnyPointer - = PtrStruct (C.Parsed AnyStruct) - | PtrList (C.Parsed AnyList) - | PtrCap M.Client - deriving(Show, Eq, Generic) - -instance C.Parse (Maybe AnyPointer) (Maybe (C.Parsed AnyPointer)) where - parse (R.Raw ptr) = case ptr of - Nothing -> pure Nothing - Just _ -> Just <$> C.parse (R.Raw ptr :: R.Raw AnyPointer 'M.Const) - - encode msg value = R.Raw <$> case value of - Nothing -> pure Nothing - Just v -> coerce <$> C.encode msg v - -instance C.Parse AnyPointer (C.Parsed AnyPointer) where - parse (R.Raw ptr) = case ptr of - Just (U.PtrCap cap) -> PtrCap <$> C.parse (R.Raw cap) - Just (U.PtrList list) -> PtrList <$> C.parse (R.Raw list) - Just (U.PtrStruct struct) -> PtrStruct <$> C.parse (R.Raw struct) - Nothing -> - throwM $ E.SchemaViolationError "Non-nullable AnyPointer was null" - - encode msg value = R.Raw <$> case value of - PtrCap cap -> Just . U.PtrCap . R.fromRaw <$> C.encode msg cap - PtrList list -> Just . U.PtrList . R.fromRaw <$> C.encode msg list - PtrStruct struct -> Just . U.PtrStruct . R.fromRaw <$> C.encode msg struct - -instance C.AllocateList AnyPointer where - type ListAllocHint AnyPointer = Int - -instance C.EstimateListAlloc AnyPointer (C.Parsed AnyPointer) - -instance C.AllocateList (Maybe AnyPointer) where - type ListAllocHint (Maybe AnyPointer) = Int - -instance C.EstimateListAlloc (Maybe AnyPointer) (Maybe (C.Parsed AnyPointer)) - -data instance C.Parsed AnyStruct = Struct - { structData :: V.Vector Word64 - , structPtrs :: V.Vector (Maybe (C.Parsed AnyPointer)) - } - deriving(Show, Generic) - -instance Eq (C.Parsed AnyStruct) where - -- We define equality specially (rather than just deriving), such that - -- slices are padded out with the default values of their elements. - (Struct dl pl) == (Struct dr pr) = sectionEq dl dr && sectionEq pl pr - where - sectionEq :: (Eq a, Default a) => V.Vector a -> V.Vector a -> Bool - sectionEq l r = go 0 - where - go i - | i >= length = True - | otherwise = indexDef i l == indexDef i r && go (i+1) - length = max (V.length l) (V.length r) - indexDef i vec - | i < V.length vec = vec V.! i - | otherwise = def - -instance C.Parse AnyStruct (C.Parsed AnyStruct) where - parse (R.Raw s) = Struct - <$> V.generateM - (fromIntegral $ U.structWordCount s) - (`U.getData` s) - <*> V.generateM - (fromIntegral $ U.structPtrCount s) - (\i -> U.getPtr i s >>= C.parse . R.Raw) - -instance C.AllocateList AnyStruct where - type ListAllocHint AnyStruct = (Int, R.AllocHint 'R.Struct) - -instance C.EstimateListAlloc AnyStruct (C.Parsed AnyStruct) where - estimateListAlloc structs = - let len = V.length structs - !nWords = foldl' max 0 $ map (V.length . structData) $ V.toList structs - !nPtrs = foldl' max 0 $ map (V.length . structPtrs) $ V.toList structs - in - (len, (fromIntegral nWords, fromIntegral nPtrs)) - -instance C.EstimateAlloc AnyStruct (C.Parsed AnyStruct) where - estimateAlloc s = - ( fromIntegral $ V.length $ structData s - , fromIntegral $ V.length $ structPtrs s - ) - -instance C.Marshal AnyStruct (C.Parsed AnyStruct) where - marshalInto (R.Raw raw) s = do - V.iforM_ (structData s) $ \i value -> do - U.setData value i raw - V.iforM_ (structPtrs s) $ \i value -> do - R.Raw ptr <- C.encode (U.message @U.Struct raw) value - U.setPtr ptr i raw - --- TODO(cleanup): It would be nice if we could reuse Capnp.Repr.Parsed.Parsed --- here, but that would cause a circular import dependency. -type ParsedList a = V.Vector a - -data instance C.Parsed AnyList - = ListPtr (ParsedList (Maybe (C.Parsed AnyPointer))) - | ListStruct (ParsedList (C.Parsed AnyStruct)) - | List0 (ParsedList ()) - | List1 (ParsedList Bool) - | List8 (ParsedList Word8) - | List16 (ParsedList Word16) - | List32 (ParsedList Word32) - | List64 (ParsedList Word64) - deriving(Show, Eq, Generic) - -instance C.Parse AnyList (C.Parsed AnyList) where - parse (R.Raw list) = case list of - U.List0 l -> List0 <$> C.parse (R.Raw l) - U.List1 l -> List1 <$> C.parse (R.Raw l) - U.List8 l -> List8 <$> C.parse (R.Raw l) - U.List16 l -> List16 <$> C.parse (R.Raw l) - U.List32 l -> List32 <$> C.parse (R.Raw l) - U.List64 l -> List64 <$> C.parse (R.Raw l) - U.ListPtr l -> ListPtr <$> C.parse (R.Raw l) - U.ListStruct l -> ListStruct <$> C.parse (R.Raw l) - - encode msg list = R.Raw <$> case list of - List0 l -> U.List0 . R.fromRaw <$> C.encode msg l - List1 l -> U.List1 . R.fromRaw <$> C.encode msg l - List8 l -> U.List8 . R.fromRaw <$> C.encode msg l - List16 l -> U.List16 . R.fromRaw <$> C.encode msg l - List32 l -> U.List32 . R.fromRaw <$> C.encode msg l - List64 l -> U.List64 . R.fromRaw <$> C.encode msg l - ListPtr l -> U.ListPtr . R.fromRaw <$> C.encode msg l - ListStruct l -> U.ListStruct . R.fromRaw <$> C.encode msg l - -instance C.Parse Capability M.Client where - parse (R.Raw cap) = U.getClient cap - encode msg client = R.Raw <$> U.appendCap msg client - -instance C.Allocate Text where - type AllocHint Text = Int - new len msg = R.Raw <$> U.allocList8 msg (len + 1) - -instance C.AllocateList Text where - type ListAllocHint Text = Int -instance C.EstimateListAlloc Text T.Text - -instance C.Parse Text T.Text where - parse (R.Raw list) = - let len = U.length list in - if len == 0 then - -- We are somewhat lenient here; technically this is invalid, as there is - -- no null terminator (see logic below, which is dead code because of - -- this check. But to avoid this we really need to expose nullability - -- in the API, so for now we just fudge it. - pure "" - else (do - when (len == 0) $ throwM $ E.SchemaViolationError - "Text is not NUL-terminated (list of bytes has length 0)" - lastByte <- U.index (len - 1) list - when (lastByte /= 0) $ throwM $ E.SchemaViolationError $ - "Text is not NUL-terminated (last byte is " ++ show lastByte ++ ")" - bytes <- BS.take (len - 1) <$> U.rawBytes list - case TE.decodeUtf8' bytes of - Left e -> throwM $ E.InvalidUtf8Error e - Right v -> pure v) - encode msg value = do - let bytes = TE.encodeUtf8 value - raw@(R.Raw untyped) <- C.new @Text (BS.length bytes) msg - C.marshalInto @Data (R.Raw untyped) bytes - pure raw - --- Instances for Data -instance C.Parse Data BS.ByteString where - parse = U.rawBytes . R.fromRaw - -instance C.Allocate Data where - type AllocHint Data = Int - new len msg = R.Raw <$> U.allocList8 msg len - -instance C.EstimateAlloc Data BS.ByteString where - estimateAlloc = BS.length - -instance C.AllocateList Data where - type ListAllocHint Data = Int -instance C.EstimateListAlloc Data BS.ByteString - -instance C.Marshal Data BS.ByteString where - marshalInto (R.Raw list) bytes = - for_ [0..BS.length bytes - 1] $ \i -> - U.setIndex (BS.index bytes i) i list - --- Instances for AnyStruct -instance C.Allocate AnyStruct where - type AllocHint AnyStruct = (Word16, Word16) - new (nWords, nPtrs) msg = R.Raw <$> U.allocStruct msg nWords nPtrs - --- | Return the underlying buffer containing the text. This does not include the --- null terminator. -textBuffer :: MonadThrow m => R.Raw Text mut -> m (R.Raw Data mut) -textBuffer (R.Raw list) = R.Raw <$> U.take (U.length list - 1) list - --- | Convert a 'Text' to a 'BS.ByteString', comprising the raw bytes of the text --- (not counting the NUL terminator). -textBytes :: U.ReadCtx m 'M.Const => R.Raw Text 'M.Const -> m BS.ByteString -textBytes text = do - R.Raw raw <- textBuffer text - U.rawBytes raw diff --git a/lib/Capnp/New/Classes.hs b/lib/Capnp/New/Classes.hs deleted file mode 100644 --- a/lib/Capnp/New/Classes.hs +++ /dev/null @@ -1,430 +0,0 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} --- | Module: Capnp.New.Classes --- Description: Misc. type classes --- --- This module contains several type classes (and related utilities) --- useful for operating over Cap'n Proto values. -module Capnp.New.Classes - ( -- * Encoding and decoding parsed forms of values - Parse(..) - , Parsed - , Marshal(..) - , MarshalElement - - -- * Allocating values in messages - , Allocate(..) - , newRoot - , AllocateList(..) - , EstimateAlloc(..) - , EstimateListAlloc(..) - , newFromRepr - - -- * Setting the root of a message - , setRoot - - -- * Working with Cap'n Proto types - , HasTypeId(..) - - -- ** Typed Structs - , TypedStruct(..) - , newTypedStruct - , newTypedStructList - , structSizes - - -- ** Inheritance - , Super - - -- * Values that go in a struct's data section - , IsWord(..) - ) where - -import Capnp.Bits -import Capnp.Message (Mutability(..)) -import qualified Capnp.Message as M -import qualified Capnp.Repr as R -import Capnp.TraversalLimit (evalLimitT) -import qualified Capnp.Untyped as U -import Data.Bits -import Data.Default (Default(..)) -import Data.Foldable (for_) -import Data.Int -import qualified Data.Vector as V -import Data.Word -import qualified GHC.Float as F -import qualified Language.Haskell.TH as TH - --- | Capnp types that can be parsed into a more "natural" Haskell form. --- --- * @t@ is the capnproto type. --- * @p@ is the type of the parsed value. -class Parse t p | t -> p, p -> t where - parse :: U.ReadCtx m 'Const => R.Raw t 'Const -> m p - -- ^ Parse a value from a constant message - encode :: U.RWCtx m s => M.Message ('Mut s) -> p -> m (R.Raw t ('Mut s)) - -- ^ Encode a value into 'R.Raw' form, using the message as storage. - - default encode - :: (U.RWCtx m s, EstimateAlloc t p, Marshal t p) - => M.Message ('Mut s) -> p -> m (R.Raw t ('Mut s)) - encode msg value = do - raw <- new (estimateAlloc value) msg - marshalInto raw value - pure raw - {-# INLINABLE encode #-} - --- | Types where the necessary allocation is inferrable from the parsed form. --- --- ...this is most types. -class (Parse t p, Allocate t) => EstimateAlloc t p where - -- | Determine the appropriate hint needed to allocate space - -- for the serialied form of the value. - estimateAlloc :: p -> AllocHint t - - default estimateAlloc :: AllocHint t ~ () => p -> AllocHint t - estimateAlloc _ = () - {-# INLINABLE estimateAlloc #-} - --- | Implementation of 'new' valid for types whose 'AllocHint' is --- the same as that of their underlying representation. -newFromRepr - :: forall a r m s. - ( R.Allocate r - , 'R.Ptr ('Just r) ~ R.ReprFor a - , U.RWCtx m s - ) - => R.AllocHint r -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) -{-# INLINABLE newFromRepr #-} -newFromRepr hint msg = R.Raw <$> R.alloc @r msg hint - -- TODO(cleanup): new and alloc really ought to have the same argument order... - - --- | Types which may be allocated directly inside a message. -class Allocate a where - type AllocHint a - -- ^ Extra information needed to allocate a value of this type, e.g. the - -- length for a list. May be () if no extra info is needed. - - new :: U.RWCtx m s => AllocHint a -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) - -- ^ @'new' hint msg@ allocates a new value of type @a@ inside @msg@. - - default new :: - ( R.ReprFor a ~ 'R.Ptr ('Just pr) - , R.Allocate pr - , AllocHint a ~ R.AllocHint pr - , U.RWCtx m s - ) => AllocHint a -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) - -- If the AllocHint is the same as that of the underlying Repr, then - -- we can just use that implementation. - new = newFromRepr @a - {-# INLINABLE new #-} - --- | Like 'Allocate', but for allocating *lists* of @a@. -class AllocateList a where - type ListAllocHint a - -- ^ Extra information needed to allocate a list of @a@s. - - newList :: U.RWCtx m s => ListAllocHint a -> M.Message ('Mut s) -> m (R.Raw (R.List a) ('Mut s)) - default newList :: - forall m s lr r. - ( U.RWCtx m s - , lr ~ R.ListReprFor (R.ReprFor a) - , r ~ 'R.List ('Just lr) - , R.Allocate r - , R.AllocHint r ~ ListAllocHint a - ) => ListAllocHint a -> M.Message ('Mut s) -> m (R.Raw (R.List a) ('Mut s)) - newList hint msg = R.Raw <$> R.alloc @r msg hint - {-# INLINABLE newList #-} - -instance AllocateList a => Allocate (R.List a) where - type AllocHint (R.List a) = ListAllocHint a - new = newList @a - {-# INLINABLE new #-} - -instance AllocateList (R.List a) where - type ListAllocHint (R.List a) = Int - -instance - ( Parse (R.List a) (V.Vector ap) - , Allocate (R.List a) - ) => EstimateListAlloc (R.List a) (V.Vector ap) - --- | Allocate a new typed struct. Mainly used as the value for 'new' for in generated --- instances of 'Allocate'. -newTypedStruct :: forall a m s. (TypedStruct a, U.RWCtx m s) => M.Message ('Mut s) -> m (R.Raw a ('Mut s)) -{-# INLINABLE newTypedStruct #-} -newTypedStruct = newFromRepr (structSizes @a) - --- | Like 'newTypedStruct', but for lists. -newTypedStructList - :: forall a m s. (TypedStruct a, U.RWCtx m s) - => Int -> M.Message ('Mut s) -> m (R.Raw (R.List a) ('Mut s)) -{-# INLINABLE newTypedStructList #-} -newTypedStructList i msg = R.Raw <$> R.alloc - @('R.List ('Just 'R.ListComposite)) - msg - (i, structSizes @a) - --- | An instance of marshal allows a parsed value to be inserted into --- pre-allocated space in a message. -class Parse t p => Marshal t p where - marshalInto :: U.RWCtx m s => R.Raw t ('Mut s) -> p -> m () - -- ^ Marshal a value into the pre-allocated object inside the message. - -- - -- Note that caller must arrange for the object to be of the correct size. - -- This is is not necessarily guaranteed; for example, list types must - -- coordinate the length of the list. - --- | Get the maximum word and pointer counts needed for a struct type's fields. -structSizes :: forall a. TypedStruct a => (Word16, Word16) -{-# INLINABLE structSizes #-} -structSizes = (numStructWords @a, numStructPtrs @a) - --- | Types which have a numeric type-id defined in a capnp schema. -class HasTypeId a where - -- | The node id for this type. You will generally want to use the - -- @TypeApplications@ extension to specify the type. - typeId :: Word64 - --- | Operations on typed structs. -class (R.IsStruct a, Allocate a, HasTypeId a, AllocHint a ~ ()) => TypedStruct a where - -- Get the size of the struct's word and pointer sections, respectively. - numStructWords :: Word16 - numStructPtrs :: Word16 - - --- | Like 'new', but also sets the value as the root of the message. -newRoot - :: forall a m s. (U.RWCtx m s, R.IsStruct a, Allocate a) - => AllocHint a -> M.Message ('Mut s) -> m (R.Raw a ('Mut s)) -{-# INLINABLE newRoot #-} -newRoot hint msg = do - raw <- new @a hint msg - setRoot raw - pure raw - --- | Sets the struct to be the root of its containing message. -setRoot :: (U.RWCtx m s, R.IsStruct a) => R.Raw a ('Mut s) -> m () -{-# INLINABLE setRoot #-} -setRoot (R.Raw struct) = U.setRoot struct - - ------- Instances for basic types ------- - -parseId :: (R.Untyped (R.ReprFor a) mut ~ U.IgnoreMut a mut, U.ReadCtx m mut) => R.Raw a mut -> m a -{-# INLINABLE parseId #-} -parseId (R.Raw v) = pure v - -parseInt :: - ( Integral a - , Integral (U.Unwrapped (R.Untyped (R.ReprFor a) mut)) - , U.ReadCtx m mut - ) => R.Raw a mut -> m a -{-# INLINABLE parseInt #-} -parseInt = pure . fromIntegral . R.fromRaw - -instance Parse Float Float where - parse = pure . F.castWord32ToFloat . R.fromRaw - encode _ = pure . R.Raw . F.castFloatToWord32 - -instance Parse Double Double where - parse = pure . F.castWord64ToDouble . R.fromRaw - encode _ = pure . R.Raw . F.castDoubleToWord64 - -instance MarshalElement a ap => Marshal (R.List a) (V.Vector ap) where - marshalInto raw value = - for_ [0..V.length value - 1] $ \i -> - marshalElement raw i (value V.! i) - -instance MarshalElement a ap => Parse (R.List a) (V.Vector ap) where - parse rawV = - V.generateM (R.length rawV) $ \i -> - R.index i rawV >>= parse - --- | Type alias capturing the constraints on a type needed by --- 'marshalElement' -type MarshalElement a ap = - ( Parse a ap - , EstimateListAlloc a ap - , R.Element (R.ReprFor a) - , U.ListItem (R.ElemRepr (R.ListReprFor (R.ReprFor a))) - , U.HasMessage (U.ListOf (R.ElemRepr (R.ListReprFor (R.ReprFor a)))) - , MarshalElementByRepr (R.ListReprFor (R.ReprFor a)) - , MarshalElementReprConstraints (R.ListReprFor (R.ReprFor a)) a ap - ) - --- | Constraints needed by marshalElement that are specific to a list repr. -type family MarshalElementReprConstraints (lr :: R.ListRepr) a ap where - MarshalElementReprConstraints 'R.ListComposite a ap = Marshal a ap - MarshalElementReprConstraints ('R.ListNormal r) a ap = Parse a ap - -class - U.HasMessage (U.ListOf ('R.Ptr ('Just ('R.List ('Just lr))))) - => MarshalElementByRepr (lr :: R.ListRepr) - where - marshalElementByRepr :: - ( U.RWCtx m s - , R.ListReprFor (R.ReprFor a) ~ lr - , MarshalElement a ap - ) => R.Raw (R.List a) ('Mut s) -> Int -> ap -> m () - --- | An instance @'Super' p c@ indicates that the interface @c@ extends --- the interface @p@. -class (R.IsCap p, R.IsCap c) => Super p c - -instance MarshalElementByRepr 'R.ListComposite where - marshalElementByRepr rawList i parsed = do - rawElt <- R.index i rawList - marshalInto rawElt parsed - {-# INLINABLE marshalElementByRepr #-} - -instance - ( U.HasMessage (U.ListOf (R.ElemRepr ('R.ListNormal l))) - , U.ListItem (R.ElemRepr ('R.ListNormal l)) - ) => MarshalElementByRepr ('R.ListNormal l) - where - marshalElementByRepr rawList@(R.Raw ulist) i parsed = do - rawElt <- encode - (U.message @(U.Untyped ('R.Ptr ('Just ('R.List ('Just ('R.ListNormal l)))))) ulist) - parsed - R.setIndex rawElt i rawList - {-# INLINABLE marshalElementByRepr #-} - -marshalElement :: - forall a ap m s. - ( U.RWCtx m s - , MarshalElement a ap - ) => R.Raw (R.List a) ('Mut s) -> Int -> ap -> m () -{-# INLINABLE marshalElement #-} -marshalElement = marshalElementByRepr @(R.ListReprFor (R.ReprFor a)) - -class (Parse a ap, Allocate (R.List a)) => EstimateListAlloc a ap where - estimateListAlloc :: V.Vector ap -> AllocHint (R.List a) - - default estimateListAlloc :: (AllocHint (R.List a) ~ Int) => V.Vector ap -> AllocHint (R.List a) - estimateListAlloc = V.length - {-# INLINABLE estimateListAlloc #-} - -instance MarshalElement a ap => EstimateAlloc (R.List a) (V.Vector ap) where - estimateAlloc = estimateListAlloc @a - {-# INLINABLE estimateAlloc #-} - --- | If @a@ is a capnproto type, then @Parsed a@ is an ADT representation of that --- type. If this is defined for a type @a@ then there should also be an instance --- @'Parse' a ('Parsed' a)@, but note that the converse is not true: if there is --- an instance @'Parse' a b@, then @'Parsed' a@ needn't be defined, and @b@ can --- be something else. -data family Parsed a - -instance (Default (R.Raw a 'Const), Parse a (Parsed a)) => Default (Parsed a) where - def = case evalLimitT maxBound (parse @a def) of - Just v -> v - Nothing -> error "Parsing default value failed." - {-# INLINABLE def #-} - -do - let mkId ty = - [d| instance Parse $ty $ty where - parse = parseId - {-# INLINABLE parse #-} - encode _ = pure . R.Raw - {-# INLINABLE encode #-} - |] - mkInt ty = - [d| instance Parse $ty $ty where - parse = parseInt - {-# INLINABLE parse #-} - encode _ = pure . R.Raw . fromIntegral - {-# INLINABLE encode #-} - |] - mkAll ty = - [d| instance AllocateList $ty where - type ListAllocHint $ty = Int - - instance EstimateListAlloc $ty $ty where - estimateListAlloc = V.length - {-# INLINABLE estimateListAlloc #-} - |] - - nameTy name = pure (TH.ConT name) - - ids = [t| () |] : map nameTy [''Bool, ''Word8, ''Word16, ''Word32, ''Word64] - ints = map nameTy [''Int8, ''Int16, ''Int32, ''Int64] - floats = map nameTy [''Float, ''Double] - allTys = ids ++ ints ++ floats - - merge :: [TH.Q [a]] -> TH.Q [a] - merge xs = concat <$> sequenceA xs - merge - [ merge $ map mkId ids - , merge $ map mkInt ints - , merge $ map mkAll allTys - ] - --- | Types that can be converted to and from a 64-bit word. --- --- Anything that goes in the data section of a struct will have --- an instance of this. -class IsWord a where - -- | Convert from a 64-bit words Truncates the word if the - -- type has less than 64 bits. - fromWord :: Word64 -> a - - -- | Convert to a 64-bit word. - toWord :: a -> Word64 - -------- IsWord instances. TODO: fold into TH above. ------- - -instance IsWord Bool where - fromWord n = (n .&. 1) == 1 - {-# INLINABLE fromWord #-} - toWord True = 1 - toWord False = 0 - {-# INLINABLE toWord #-} - -instance IsWord Word1 where - fromWord = Word1 . fromWord - {-# INLINABLE fromWord #-} - toWord = toWord . word1ToBool - {-# INLINABLE toWord #-} - --- IsWord instances for integral types; they're all the same. -do - let mkInstance t = - [d|instance IsWord $t where - fromWord = fromIntegral - {-# INLINABLE fromWord #-} - toWord = fromIntegral - {-# INLINABLE toWord #-} - |] - concat <$> traverse mkInstance - [ [t|Int8|] - , [t|Int16|] - , [t|Int32|] - , [t|Int64|] - , [t|Word8|] - , [t|Word16|] - , [t|Word32|] - , [t|Word64|] - ] - -instance IsWord Float where - fromWord = F.castWord32ToFloat . fromIntegral - {-# INLINABLE fromWord #-} - toWord = fromIntegral . F.castFloatToWord32 - {-# INLINABLE toWord #-} -instance IsWord Double where - fromWord = F.castWord64ToDouble - {-# INLINABLE fromWord #-} - toWord = F.castDoubleToWord64 - {-# INLINABLE toWord #-} diff --git a/lib/Capnp/New/Constraints.hs b/lib/Capnp/New/Constraints.hs deleted file mode 100644 --- a/lib/Capnp/New/Constraints.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | Module: Capnp.New.Constraints --- Description: convenience shorthands for various constraints. -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeFamilies #-} -module Capnp.New.Constraints where - -import qualified Capnp.New.Classes as C -import qualified Capnp.Repr as R -import qualified Capnp.Repr.Parsed as RP - --- | Constraints needed for @a@ to be a capnproto type parameter. -type TypeParam a = - ( R.IsPtr a - , C.Parse a (RP.Parsed a) - ) - diff --git a/lib/Capnp/New/Rpc/Common.hs b/lib/Capnp/New/Rpc/Common.hs deleted file mode 100644 --- a/lib/Capnp/New/Rpc/Common.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Capnp.New.Rpc.Common - ( Client(..) - , Pipeline(..) - ) where - -import {-# SOURCE #-} qualified Capnp.Rpc.Untyped as Rpc - --- | A @'Pipeline' a@ is a reference to possibly-not-resolved result from --- a method call. -newtype Pipeline a = Pipeline Rpc.Pipeline - -newtype Client a = Client Rpc.Client - deriving(Show, Eq) diff --git a/lib/Capnp/New/Rpc/Server.hs b/lib/Capnp/New/Rpc/Server.hs --- a/lib/Capnp/New/Rpc/Server.hs +++ b/lib/Capnp/New/Rpc/Server.hs @@ -1,181 +1,191 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -module Capnp.New.Rpc.Server - ( CallHandler - , MethodHandler - , UntypedMethodHandler - , Export(..) - , export - , findMethod +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} - , SomeServer(..) +module Capnp.New.Rpc.Server + ( CallHandler, + MethodHandler, + UntypedMethodHandler, + Export (..), + export, + findMethod, + SomeServer (..), -- * Helpers for writing method handlers - , handleParsed - , handleRaw - , methodUnimplemented - - , toUntypedMethodHandler + handleParsed, + handleRaw, + methodUnimplemented, + toUntypedMethodHandler, -- * Internals; exposed only for use by generated code. - , MethodHandlerTree(..) - ) where + MethodHandlerTree (..), + ) +where -import Capnp.Convert (parsedToRaw) -import Capnp.Message (Mutability(..)) -import qualified Capnp.New.Basics as B -import qualified Capnp.New.Classes as C -import qualified Capnp.Repr as R -import Capnp.Repr.Methods (Client(..)) -import Capnp.Rpc.Errors - (eFailed, eMethodUnimplemented, wrapException) -import Capnp.Rpc.Promise - (Fulfiller, breakPromise, fulfill, newCallback) -import qualified Capnp.Rpc.Server as Legacy -import qualified Capnp.Rpc.Untyped as URpc -import Capnp.TraversalLimit (defaultLimit, evalLimitT) -import qualified Capnp.Untyped as U -import Control.Exception.Safe (withException) -import Control.Monad.STM.Class (MonadSTM(..)) -import Data.Function ((&)) -import Data.Kind (Constraint, Type) -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe) -import Data.Proxy (Proxy(..)) -import Data.Typeable (Typeable) -import qualified Data.Vector as V -import Data.Word -import GHC.Prim (coerce) -import Internal.BuildPure (createPure) -import Supervisors (Supervisor) +import qualified Capnp.Basics as B +import qualified Capnp.Classes as C +import Capnp.Convert (parsedToRaw) +import Capnp.Message (Mutability (..)) +import qualified Capnp.Repr as R +import Capnp.Repr.Methods (Client (..)) +import Capnp.Rpc.Errors + ( eFailed, + eMethodUnimplemented, + wrapException, + ) +import Capnp.Rpc.Promise + ( Fulfiller, + breakPromise, + fulfill, + newCallback, + ) +import qualified Capnp.Rpc.Server as Legacy +import qualified Capnp.Rpc.Untyped as URpc +import Capnp.TraversalLimit (defaultLimit, evalLimitT) +import qualified Capnp.Untyped as U +import Control.Exception.Safe (withException) +import Control.Monad.STM.Class (MonadSTM (..)) +import Data.Function ((&)) +import Data.Kind (Constraint, Type) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import Data.Word +import GHC.Prim (coerce) +import Internal.BuildPure (createPure) +import Supervisors (Supervisor) -- | A handler for arbitrary RPC calls. Maps (interfaceId, methodId) pairs to -- 'UntypedMethodHandler's. type CallHandler = M.Map Word64 (V.Vector UntypedMethodHandler) -- | Type alias for a handler for a particular rpc method. -type MethodHandler p r - = R.Raw p 'Const - -> Fulfiller (R.Raw r 'Const) - -> IO () +type MethodHandler p r = + R.Raw p 'Const -> + Fulfiller (R.Raw r 'Const) -> + IO () -- | Type alias for a handler for an untyped RPC method. type UntypedMethodHandler = MethodHandler B.AnyStruct B.AnyStruct -- | Base class for things that can act as capnproto servers. class SomeServer a where - -- | Called when the last live reference to a server is dropped. - shutdown :: a -> IO () - shutdown _ = pure () + -- | Called when the last live reference to a server is dropped. + shutdown :: a -> IO () + shutdown _ = pure () - -- | Try to extract a value of a given type. The default implementation - -- always fails (returns 'Nothing'). If an instance chooses to implement - -- this, it will be possible to use "reflection" on clients that point - -- at local servers to dynamically unwrap the server value. A typical - -- implementation will just call Typeable's @cast@ method, but this - -- needn't be the case -- a server may wish to allow local peers to - -- unwrap some value that is not exactly the data the server has access - -- to. - unwrap :: Typeable b => a -> Maybe b - unwrap _ = Nothing + -- | Try to extract a value of a given type. The default implementation + -- always fails (returns 'Nothing'). If an instance chooses to implement + -- this, it will be possible to use "reflection" on clients that point + -- at local servers to dynamically unwrap the server value. A typical + -- implementation will just call Typeable's @cast@ method, but this + -- needn't be the case -- a server may wish to allow local peers to + -- unwrap some value that is not exactly the data the server has access + -- to. + unwrap :: Typeable b => a -> Maybe b + unwrap _ = Nothing -- | Generated interface types have instances of 'Export', which allows a server -- for that interface to be exported as a 'Client'. class (R.IsCap i, C.HasTypeId i) => Export i where - -- | The constraint needed for a server to implement an interface; - -- if @'Server' i s@ is satisfied, @s@ is a server for interface @i@. - -- The code generator generates a type class for each interface, and - -- this will aways be an alias for that type class. - type Server i :: Type -> Constraint + -- | The constraint needed for a server to implement an interface; + -- if @'Server' i s@ is satisfied, @s@ is a server for interface @i@. + -- The code generator generates a type class for each interface, and + -- this will aways be an alias for that type class. + type Server i :: Type -> Constraint - -- | Convert the server to a 'MethodHandlerTree' populated with appropriate - -- 'MethodHandler's for the interface. This is really only exported for use - -- by generated code; users of the library will generally prefer to use - -- 'export'. - methodHandlerTree :: Server i s => Proxy i -> s -> MethodHandlerTree - -- NB: the proxy helps disambiguate types; for some reason TypeApplications - -- doesn't seem to be enough in the face of a type alias of kind 'Constraint'. - -- the inconsistency is a bit ugly, but this method isn't intended to called - -- by users directly, only by generated code and our helper in this module, - -- so it's less of a big deal. + -- | Convert the server to a 'MethodHandlerTree' populated with appropriate + -- 'MethodHandler's for the interface. This is really only exported for use + -- by generated code; users of the library will generally prefer to use + -- 'export'. + methodHandlerTree :: Server i s => Proxy i -> s -> MethodHandlerTree +-- NB: the proxy helps disambiguate types; for some reason TypeApplications +-- doesn't seem to be enough in the face of a type alias of kind 'Constraint'. +-- the inconsistency is a bit ugly, but this method isn't intended to called +-- by users directly, only by generated code and our helper in this module, +-- so it's less of a big deal. + -- | Lazily computed tree of the method handlers exposed by an interface. Only -- of interest to generated code. data MethodHandlerTree = MethodHandlerTree - { mhtId :: Word64 - -- ^ type id for the primary interface - , mhtHandlers :: [UntypedMethodHandler] - -- ^ method handlers for methods of the primary interface. - , mhtParents :: [MethodHandlerTree] - -- ^ Trees for parent interfaces. In the case of diamond dependencies, + { -- | type id for the primary interface + mhtId :: Word64, + -- | method handlers for methods of the primary interface. + mhtHandlers :: [UntypedMethodHandler], + -- | Trees for parent interfaces. In the case of diamond dependencies, -- there may be duplicates, which are eliminated by 'mhtToCallHandler'. - } + mhtParents :: [MethodHandlerTree] + } mhtToCallHandler :: MethodHandlerTree -> CallHandler -mhtToCallHandler = go M.empty . pure where +mhtToCallHandler = go M.empty . pure + where go accum [] = accum go accum (t : ts) - | mhtId t `M.member` accum = go accum ts -- dedup diamond dependencies - | otherwise = - go (M.insert (mhtId t) (V.fromList (mhtHandlers t)) accum) (mhtParents t ++ ts) + | mhtId t `M.member` accum = go accum ts -- dedup diamond dependencies + | otherwise = + go (M.insert (mhtId t) (V.fromList (mhtHandlers t)) accum) (mhtParents t ++ ts) -- | Export the server as a client for interface @i@. Spawns a server thread -- with its lifetime bound to the supervisor. export :: forall i s m. (MonadSTM m, Export i, Server i s, SomeServer s) => Supervisor -> s -> m (Client i) export sup srv = - let h = mhtToCallHandler (methodHandlerTree (Proxy @i) srv) in - liftSTM $ Client <$> URpc.export sup (toLegacyServerOps srv h) + let h = mhtToCallHandler (methodHandlerTree (Proxy @i) srv) + in liftSTM $ Client <$> URpc.export sup (toLegacyServerOps srv h) -- | Look up a particlar 'MethodHandler' in the 'CallHandler'. findMethod :: Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler findMethod interfaceId methodId handler = do - iface <- M.lookup interfaceId handler - iface V.!? fromIntegral methodId + iface <- M.lookup interfaceId handler + iface V.!? fromIntegral methodId -toLegacyCallHandler - :: CallHandler - -> Word64 - -> Word16 - -> Legacy.MethodHandler IO (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) +toLegacyCallHandler :: + CallHandler -> + Word64 -> + Word16 -> + Legacy.MethodHandler (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) toLegacyCallHandler callHandler interfaceId methodId = - findMethod interfaceId methodId callHandler + findMethod interfaceId methodId callHandler & fromMaybe methodUnimplemented & toLegacyMethodHandler - -- | Convert a typed method handler to an untyped one. Mostly intended for -- use by generated code. -toUntypedMethodHandler - :: forall p r. (R.IsStruct p, R.IsStruct r) - => MethodHandler p r - -> UntypedMethodHandler +toUntypedMethodHandler :: + forall p r. + (R.IsStruct p, R.IsStruct r) => + MethodHandler p r -> + UntypedMethodHandler toUntypedMethodHandler = coerce -toLegacyMethodHandler :: UntypedMethodHandler -> Legacy.MethodHandler IO (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) +toLegacyMethodHandler :: UntypedMethodHandler -> Legacy.MethodHandler (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) toLegacyMethodHandler handler = - Legacy.untypedHandler $ \args respond -> do - respond' <- newCallback $ \case - Left e -> - breakPromise respond e - Right (R.Raw s) -> - fulfill respond (Just (U.PtrStruct s)) - case args of - Just (U.PtrStruct argStruct) -> - handler (R.Raw argStruct) respond' - _ -> - breakPromise respond $ eFailed "Argument was not a struct" + Legacy.untypedHandler $ \args respond -> do + respond' <- newCallback $ \case + Left e -> + breakPromise respond e + Right (R.Raw s) -> + fulfill respond (Just (U.PtrStruct s)) + case args of + Just (U.PtrStruct argStruct) -> + handler (R.Raw argStruct) respond' + _ -> + breakPromise respond $ eFailed "Argument was not a struct" -toLegacyServerOps :: SomeServer a => a -> CallHandler -> Legacy.ServerOps IO -toLegacyServerOps srv callHandler = Legacy.ServerOps - { handleStop = shutdown srv - , handleCast = unwrap srv - , handleCall = toLegacyCallHandler callHandler +toLegacyServerOps :: SomeServer a => a -> CallHandler -> Legacy.ServerOps +toLegacyServerOps srv callHandler = + Legacy.ServerOps + { handleStop = shutdown srv, + handleCast = unwrap srv, + handleCall = toLegacyCallHandler callHandler } -- Helpers for writing method handlers @@ -183,29 +193,34 @@ -- | Handle a method, working with the parsed form of parameters and -- results. handleParsed :: - ( C.Parse p pp, R.IsStruct p - , C.Parse r rr, R.IsStruct r - ) => (pp -> IO rr) -> MethodHandler p r + ( C.Parse p pp, + R.IsStruct p, + C.Parse r pr, + R.IsStruct r + ) => + (pp -> IO pr) -> + MethodHandler p r handleParsed handler param = propagateExceptions $ \f -> do - p <- evalLimitT defaultLimit $ C.parse param - r <- handler p - -- TODO: Figure out how to add an instance of Thaw for - -- Raw so we can skip the (un)wrapping here. - struct <- createPure maxBound $ R.fromRaw <$> parsedToRaw r - fulfill f (R.Raw struct) + p <- evalLimitT defaultLimit $ C.parse param + r <- handler p + -- TODO: Figure out how to add an instance of Thaw for + -- Raw so we can skip the (un)wrapping here. + struct <- createPure maxBound $ R.fromRaw <$> parsedToRaw r + fulfill f (R.Raw struct) -- | Handle a method, working with the raw (unparsed) form of -- parameters and results. -handleRaw - :: (R.IsStruct p, R.IsStruct r) - => (R.Raw p 'Const -> IO (R.Raw r 'Const)) -> MethodHandler p r +handleRaw :: + (R.IsStruct p, R.IsStruct r) => + (R.Raw p 'Const -> IO (R.Raw r 'Const)) -> + MethodHandler p r handleRaw handler param = propagateExceptions $ \f -> - handler param >>= fulfill f + handler param >>= fulfill f -- Helper for handle*; breaks the promise if the handler throws. propagateExceptions :: (Fulfiller a -> IO b) -> Fulfiller a -> IO b propagateExceptions h f = - h f `withException` (breakPromise f . wrapException False) + h f `withException` (breakPromise f . wrapException False) -- | 'MethodHandler' that always throws unimplemented. methodUnimplemented :: MethodHandler p r diff --git a/lib/Capnp/Pointer.hs b/lib/Capnp/Pointer.hs --- a/lib/Capnp/Pointer.hs +++ b/lib/Capnp/Pointer.hs @@ -1,79 +1,76 @@ -{- | -Module: Capnp.Pointer -Description: Support for parsing/serializing capnproto pointers - -This module provides support for parsing and serializing capnproto pointers. -This is a low-level module; most users will not need to call it directly. --} +-- | +-- Module: Capnp.Pointer +-- Description: Support for parsing/serializing capnproto pointers +-- +-- This module provides support for parsing and serializing capnproto pointers. +-- This is a low-level module; most users will not need to call it directly. module Capnp.Pointer - ( Ptr(..) - , ElementSize(..) - , EltSpec(..) - , parsePtr - , parsePtr' - , serializePtr - , serializePtr' - , parseEltSpec - , serializeEltSpec - ) - where + ( Ptr (..), + ElementSize (..), + EltSpec (..), + parsePtr, + parsePtr', + serializePtr, + serializePtr', + parseEltSpec, + serializeEltSpec, + ) +where +import Capnp.Bits import Data.Bits import Data.Int import Data.Word -import Capnp.Bits - -- | A 'Ptr' represents the information in a capnproto pointer. data Ptr - = StructPtr !Int32 !Word16 !Word16 - -- ^ @'StructPtr' off dataSz ptrSz@ is a pointer to a struct - -- at offset @off@ in words from the end of the pointer, with - -- a data section of size @dataSz@ words, and a pointer section - -- of size @ptrSz@ words. - -- - -- Note that the value @'StructPtr' 0 0 0@ is illegal, since - -- its encoding is reserved for the "null" pointer. - | ListPtr !Int32 !EltSpec - -- ^ @'ListPtr' off eltSpec@ is a pointer to a list starting at - -- offset @off@ in words from the end of the pointer. @eltSpec@ - -- encodes the C and D fields in the encoding spec; see 'EltSpec' - -- for details - | FarPtr !Bool !Word32 !Word32 - -- ^ @'FarPtr' twoWords off segment@ is a far pointer, whose landing - -- pad is: - -- - -- * two words iff @twoWords@, - -- * @off@ words from the start of the target segment, and - -- * in segment id @segment@. - | CapPtr !Word32 - -- ^ @'CapPtr' id@ is a pointer to the capability with the id @id@. - deriving(Show, Eq) - + = -- | @'StructPtr' off dataSz ptrSz@ is a pointer to a struct + -- at offset @off@ in words from the end of the pointer, with + -- a data section of size @dataSz@ words, and a pointer section + -- of size @ptrSz@ words. + -- + -- Note that the value @'StructPtr' 0 0 0@ is illegal, since + -- its encoding is reserved for the "null" pointer. + StructPtr !Int32 !Word16 !Word16 + | -- | @'ListPtr' off eltSpec@ is a pointer to a list starting at + -- offset @off@ in words from the end of the pointer. @eltSpec@ + -- encodes the C and D fields in the encoding spec; see 'EltSpec' + -- for details + ListPtr !Int32 !EltSpec + | -- | @'FarPtr' twoWords off segment@ is a far pointer, whose landing + -- pad is: + -- + -- * two words iff @twoWords@, + -- * @off@ words from the start of the target segment, and + -- * in segment id @segment@. + FarPtr !Bool !Word32 !Word32 + | -- | @'CapPtr' id@ is a pointer to the capability with the id @id@. + CapPtr !Word32 + deriving (Show, Eq) -- | The element size field in a list pointer. data ElementSize - = Sz0 - | Sz1 - | Sz8 - | Sz16 - | Sz32 - | Sz64 - | SzPtr - deriving(Show, Eq, Enum) + = Sz0 + | Sz1 + | Sz8 + | Sz16 + | Sz32 + | Sz64 + | SzPtr + deriving (Show, Eq, Enum) -- | A combination of the C and D fields in a list pointer, i.e. the element -- size, and either the number of elements in the list, or the total number -- of /words/ in the list (if size is composite). data EltSpec - = EltNormal !ElementSize !Word32 - -- ^ @'EltNormal' size len@ is a normal (non-composite) element type + = -- | @'EltNormal' size len@ is a normal (non-composite) element type -- (C /= 7). @size@ is the size of the elements, and @len@ is the -- number of elements in the list. - | EltComposite !Int32 - -- ^ @EltComposite len@ is a composite element (C == 7). @len@ is the + EltNormal !ElementSize !Word32 + | -- | @EltComposite len@ is a composite element (C == 7). @len@ is the -- length of the list in words. - deriving(Show, Eq) + EltComposite !Int32 + deriving (Show, Eq) -- | @'parsePtr' word@ parses word as a capnproto pointer. A null pointer is -- parsed as 'Nothing'. @@ -85,20 +82,23 @@ -- nulls, returning them the same as @(StructPtr 0 0 0)@. parsePtr' :: Word64 -> Ptr parsePtr' word = - case bitRange word 0 2 :: Word64 of - 0 -> StructPtr - (i30 (lo word)) - (bitRange word 32 48) - (bitRange word 48 64) - 1 -> ListPtr - (i30 (lo word)) - (parseEltSpec word) - 2 -> FarPtr - (toEnum (bitRange word 2 3)) - (bitRange word 3 32) - (bitRange word 32 64) - 3 -> CapPtr (bitRange word 32 64) - _ -> error "unreachable" + case bitRange word 0 2 :: Word64 of + 0 -> + StructPtr + (i30 (lo word)) + (bitRange word 32 48) + (bitRange word 48 64) + 1 -> + ListPtr + (i30 (lo word)) + (parseEltSpec word) + 2 -> + FarPtr + (toEnum (bitRange word 2 3)) + (bitRange word 3 32) + (bitRange word 32 64) + 3 -> CapPtr (bitRange word 32 64) + _ -> error "unreachable" -- | @'serializePtr' ptr@ serializes the pointer as a 'Word64', translating -- 'Nothing' to a null pointer. @@ -106,23 +106,23 @@ -- This also changes the offset of zero-sized struct pointers to -1, to avoid -- them being interpreted as null. serializePtr :: Maybe Ptr -> Word64 -serializePtr Nothing = 0 +serializePtr Nothing = 0 serializePtr (Just p@(StructPtr (-1) 0 0)) = - serializePtr' p + serializePtr' p serializePtr (Just (StructPtr _ 0 0)) = - -- We need to handle this specially, for two reasons. - -- - -- First, if the offset is zero, the the normal encoding would be interpreted - -- as null. We can get around this by changing the offset to -1, which will - -- point immediately before the pointer, which is always a valid position -- - -- and since the size is zero, we can stick it at any valid position. - -- - -- Second, the canonicalization algorithm requires that *all* zero size structs - -- are encoded this way, and doing this for all offsets, rather than only zero - -- offsets, avoids needing extra logic elsewhere. - serializePtr' (StructPtr (-1) 0 0) + -- We need to handle this specially, for two reasons. + -- + -- First, if the offset is zero, the the normal encoding would be interpreted + -- as null. We can get around this by changing the offset to -1, which will + -- point immediately before the pointer, which is always a valid position -- + -- and since the size is zero, we can stick it at any valid position. + -- + -- Second, the canonicalization algorithm requires that *all* zero size structs + -- are encoded this way, and doing this for all offsets, rather than only zero + -- offsets, avoids needing extra logic elsewhere. + serializePtr' (StructPtr (-1) 0 0) serializePtr (Just p) = - serializePtr' p + serializePtr' p -- | @'serializePtr'' ptr@ serializes the pointer as a Word64. -- @@ -130,21 +130,23 @@ -- @(StructPtr 0 0 0)@, rather than adjusting the offset. serializePtr' :: Ptr -> Word64 serializePtr' (StructPtr off dataSz ptrSz) = - -- 0 .|. - fromLo (fromI30 off) .|. - (fromIntegral dataSz `shiftL` 32) .|. - (fromIntegral ptrSz `shiftL` 48) -serializePtr' (ListPtr off eltSpec) = -- eltSz numElts) = - 1 .|. - fromLo (fromI30 off) .|. - serializeEltSpec eltSpec + -- 0 .|. + fromLo (fromI30 off) + .|. (fromIntegral dataSz `shiftL` 32) + .|. (fromIntegral ptrSz `shiftL` 48) +serializePtr' (ListPtr off eltSpec) = + -- eltSz numElts) = + 1 + .|. fromLo (fromI30 off) + .|. serializeEltSpec eltSpec serializePtr' (FarPtr twoWords off segId) = - 2 .|. - (fromIntegral (fromEnum twoWords) `shiftL` 2) .|. - (fromIntegral off `shiftL` 3) .|. - (fromIntegral segId `shiftL` 32) + 2 + .|. (fromIntegral (fromEnum twoWords) `shiftL` 2) + .|. (fromIntegral off `shiftL` 3) + .|. (fromIntegral segId `shiftL` 32) serializePtr' (CapPtr index) = - 3 .|. + 3 + .|. -- (fromIntegral 0 `shiftL` 2) .|. (fromIntegral index `shiftL` 32) @@ -152,15 +154,15 @@ -- encoding of a list pointer (this is not verified). parseEltSpec :: Word64 -> EltSpec parseEltSpec word = case bitRange word 32 35 of - 7 -> EltComposite (i29 (hi word)) - sz -> EltNormal (toEnum sz) (bitRange word 35 64) + 7 -> EltComposite (i29 (hi word)) + sz -> EltNormal (toEnum sz) (bitRange word 35 64) -- | @'serializeEltSpec' eltSpec@ serializes @eltSpec@ as a 'Word64'. all bits -- which are not determined by the 'EltSpec' are zero. serializeEltSpec :: EltSpec -> Word64 serializeEltSpec (EltNormal sz len) = - (fromIntegral (fromEnum sz) `shiftL` 32) .|. - (fromIntegral len `shiftL` 35) + (fromIntegral (fromEnum sz) `shiftL` 32) + .|. (fromIntegral len `shiftL` 35) serializeEltSpec (EltComposite words) = - (7 `shiftL` 32) .|. - fromHi (fromI29 words) + (7 `shiftL` 32) + .|. fromHi (fromI29 words) diff --git a/lib/Capnp/Repr.hs b/lib/Capnp/Repr.hs --- a/lib/Capnp/Repr.hs +++ b/lib/Capnp/Repr.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- | Module: Capnp.Repr -- Description: Type-level plumbing for wire-representations. -- @@ -22,109 +23,123 @@ -- -- Recommended reading: https://capnproto.org/encoding.html module Capnp.Repr - ( - -- * Type-level descriptions of wire representations. - Repr(..) - , PtrRepr(..) - , ListRepr(..) - , NormalListRepr(..) - , DataSz(..) + ( -- * Type-level descriptions of wire representations. + Repr (..), + PtrRepr (..), + ListRepr (..), + NormalListRepr (..), + DataSz (..), -- * Mapping representations to value types from "Capnp.Untyped" - , Untyped - , UntypedData - , UntypedPtr - , UntypedSomePtr - , UntypedList - , UntypedSomeList + Untyped, + UntypedData, + UntypedPtr, + UntypedSomePtr, + UntypedList, + UntypedSomeList, -- * Mapping types to their wire representations. - , ReprFor - , PtrReprFor + ReprFor, + PtrReprFor, -- * Relating the representations of lists & their elements. - , Element(..) - , ElemRepr - , ListReprFor + Element (..), + ElemRepr, + ListReprFor, -- * Working with pointers - , IsPtrRepr(..) - , IsListPtrRepr(..) + IsPtrRepr (..), + IsListPtrRepr (..), -- * Working with wire-encoded values - , Raw(..) + Raw (..), -- * Working with lists - , List - , length - , index - , setIndex + List, + length, + index, + setIndex, -- * Allocating values - , Allocate(..) + Allocate (..), -- * Shorthands for types - , IsStruct - , IsCap - , IsPtr - ) where + IsStruct, + IsCap, + IsPtr, + ) +where +import qualified Capnp.Message as M +import Capnp.Mutability (MaybeMutable (..), Mutability (..)) +import Capnp.TraversalLimit (evalLimitT) +import Capnp.Untyped + ( Allocate (..), + DataSz (..), + ElemRepr, + Element (..), + IsListPtrRepr (..), + IsPtrRepr (..), + ListRepr (..), + ListReprFor, + MaybePtr (..), + NormalListRepr (..), + PtrRepr (..), + Repr (..), + Untyped, + UntypedData, + UntypedList, + UntypedPtr, + UntypedSomeList, + UntypedSomePtr, + Unwrapped, + ) +import qualified Capnp.Untyped as U +import Control.Monad.Primitive (PrimMonad, PrimState) +import Data.Default (Default (..)) +import Data.Int +import Data.Kind (Type) +import Data.Maybe (fromJust) +import Data.Traversable (for) +import Data.Word +import GHC.Generics (Generic) import Prelude hiding (length) -import qualified Capnp.Message as M -import Capnp.Mutability (MaybeMutable(..), Mutability(..)) -import Capnp.TraversalLimit (evalLimitT) -import Capnp.Untyped - ( Allocate(..) - , DataSz(..) - , ElemRepr - , Element(..) - , IsListPtrRepr(..) - , IsPtrRepr(..) - , ListRepr(..) - , ListReprFor - , MaybePtr(..) - , NormalListRepr(..) - , PtrRepr(..) - , Repr(..) - , Untyped - , UntypedData - , UntypedList - , UntypedPtr - , UntypedSomeList - , UntypedSomePtr - , Unwrapped - ) -import qualified Capnp.Untyped as U -import Control.Monad.Primitive (PrimMonad, PrimState) -import Data.Default (Default(..)) -import Data.Int -import Data.Kind (Type) -import Data.Maybe (fromJust) -import Data.Traversable (for) -import Data.Word -import GHC.Generics (Generic) - -- | @'ReprFor' a@ denotes the Cap'n Proto wire represent of the type @a@. type family ReprFor (a :: Type) :: Repr type instance ReprFor () = 'Data 'Sz0 + type instance ReprFor Bool = 'Data 'Sz1 + type instance ReprFor Word8 = 'Data 'Sz8 + type instance ReprFor Word16 = 'Data 'Sz16 + type instance ReprFor Word32 = 'Data 'Sz32 + type instance ReprFor Word64 = 'Data 'Sz64 + type instance ReprFor Int8 = 'Data 'Sz8 + type instance ReprFor Int16 = 'Data 'Sz16 + type instance ReprFor Int32 = 'Data 'Sz32 + type instance ReprFor Int64 = 'Data 'Sz64 + type instance ReprFor Float = 'Data 'Sz32 + type instance ReprFor Double = 'Data 'Sz64 type instance ReprFor (U.Struct mut) = 'Ptr ('Just 'Struct) + type instance ReprFor (U.Cap mut) = 'Ptr ('Just 'Cap) + type instance ReprFor (U.Ptr mut) = 'Ptr 'Nothing + type instance ReprFor (U.List mut) = 'Ptr ('Just ('List 'Nothing)) + type instance ReprFor (U.ListOf r mut) = 'Ptr ('Just ('List ('Just (ListReprFor r)))) type instance ReprFor (List a) = 'Ptr ('Just ('List ('Just (ListReprFor (ReprFor a))))) @@ -132,25 +147,27 @@ -- | @PtrReprFor r@ extracts the pointer represnetation in r; undefined if -- r is not a pointer representation. type family PtrReprFor (r :: Repr) :: Maybe PtrRepr where - PtrReprFor ('Ptr pr) = pr + PtrReprFor ('Ptr pr) = pr -- | A @'Raw' mut a@ is an @a@ embedded in a capnproto message with mutability -- @mut@. -newtype Raw (a :: Type ) (mut :: Mutability) - = Raw { fromRaw :: U.Unwrapped (Untyped (ReprFor a) mut) } +newtype Raw (a :: Type) (mut :: Mutability) = Raw {fromRaw :: U.Unwrapped (Untyped (ReprFor a) mut)} deriving instance Show (U.Unwrapped (Untyped (ReprFor a) mut)) => Show (Raw a mut) + deriving instance Read (U.Unwrapped (Untyped (ReprFor a) mut)) => Read (Raw a mut) + deriving instance Eq (U.Unwrapped (Untyped (ReprFor a) mut)) => Eq (Raw a mut) + deriving instance Generic (U.Unwrapped (Untyped (ReprFor a) mut)) => Generic (Raw a mut) -- | A phantom type denoting capnproto lists of type @a@. data List a type ListElem a = - ( U.Element (ReprFor a) - , U.ListItem (ElemRepr (ListReprFor (ReprFor a))) - ) + ( U.Element (ReprFor a), + U.ListItem (ElemRepr (ListReprFor (ReprFor a))) + ) -- | Get the length of a capnproto list. length :: ListElem a => Raw (List a) mut -> Int @@ -158,97 +175,113 @@ length (Raw l) = U.length l -- | @'index' i list@ gets the @i@th element of the list. -index :: forall a m mut. - ( U.ReadCtx m mut - , U.HasMessage (U.ListOf (ElemRepr (ListReprFor (ReprFor a)))) - , ListElem a - ) => Int -> Raw (List a) mut -> m (Raw a mut) +index :: + forall a m mut. + ( U.ReadCtx m mut, + U.HasMessage (U.ListOf (ElemRepr (ListReprFor (ReprFor a)))), + ListElem a + ) => + Int -> + Raw (List a) mut -> + m (Raw a mut) {-# INLINE index #-} -index i (Raw l) = Raw <$> do +index i (Raw l) = + Raw <$> do elt <- U.index i l fromElement - @(ReprFor a) - @m - @mut - (U.message @(U.ListOf (ElemRepr (ListReprFor (ReprFor a)))) l) - elt + @(ReprFor a) + @m + @mut + (U.message @(U.ListOf (ElemRepr (ListReprFor (ReprFor a)))) l) + elt -- | @'setIndex' value i list@ sets the @i@th element of @list@ to @value@. -setIndex :: forall a m s. - ( U.RWCtx m s - , U.ListItem (ElemRepr (ListReprFor (ReprFor a))) - , U.Element (ReprFor a) - ) => Raw a ('Mut s) -> Int -> Raw (List a) ('Mut s) -> m () +setIndex :: + forall a m s. + ( U.RWCtx m s, + U.ListItem (ElemRepr (ListReprFor (ReprFor a))), + U.Element (ReprFor a) + ) => + Raw a ('Mut s) -> + Int -> + Raw (List a) ('Mut s) -> + m () {-# INLINE setIndex #-} setIndex (Raw v) i (Raw l) = U.setIndex (toElement @(ReprFor a) @('Mut s) v) i l instance U.HasMessage (Untyped (ReprFor a)) => U.HasMessage (Raw a) where - message (Raw r) = U.message @(Untyped (ReprFor a)) r + message (Raw r) = U.message @(Untyped (ReprFor a)) r + instance U.MessageDefault (Untyped (ReprFor a)) => U.MessageDefault (Raw a) where - messageDefault msg = Raw <$> U.messageDefault @(Untyped (ReprFor a)) msg + messageDefault msg = Raw <$> U.messageDefault @(Untyped (ReprFor a)) msg instance U.MessageDefault (Raw a) => Default (Raw a 'Const) where - def = fromJust $ evalLimitT maxBound $ U.messageDefault @(Raw a) M.empty + def = fromJust $ evalLimitT maxBound $ U.messageDefault @(Raw a) M.empty instance ReprMaybeMutable (ReprFor a) => MaybeMutable (Raw a) where - thaw (Raw v) = Raw <$> rThaw @(ReprFor a) v - freeze (Raw v) = Raw <$> rFreeze @(ReprFor a) v - unsafeThaw (Raw v) = Raw <$> rUnsafeThaw @(ReprFor a) v - unsafeFreeze (Raw v) = Raw <$> rUnsafeFreeze @(ReprFor a) v - {-# INLINE thaw #-} - {-# INLINE freeze #-} - {-# INLINE unsafeThaw #-} - {-# INLINE unsafeFreeze #-} + thaw (Raw v) = Raw <$> rThaw @(ReprFor a) v + freeze (Raw v) = Raw <$> rFreeze @(ReprFor a) v + unsafeThaw (Raw v) = Raw <$> rUnsafeThaw @(ReprFor a) v + unsafeFreeze (Raw v) = Raw <$> rUnsafeFreeze @(ReprFor a) v + {-# INLINE thaw #-} + {-# INLINE freeze #-} + {-# INLINE unsafeThaw #-} + {-# INLINE unsafeFreeze #-} -- | Like MaybeMutable, but defined on the repr. Helper for implementing -- MaybeMutable (Raw a) class ReprMaybeMutable (r :: Repr) where - rThaw :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r 'Const) -> m (Unwrapped (Untyped r ('Mut s))) - rUnsafeThaw :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r 'Const) -> m (Unwrapped (Untyped r ('Mut s))) - rFreeze :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r ('Mut s)) -> m (Unwrapped (Untyped r 'Const)) - rUnsafeFreeze :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r ('Mut s)) -> m (Unwrapped (Untyped r 'Const)) + rThaw :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r 'Const) -> m (Unwrapped (Untyped r ('Mut s))) + rUnsafeThaw :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r 'Const) -> m (Unwrapped (Untyped r ('Mut s))) + rFreeze :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r ('Mut s)) -> m (Unwrapped (Untyped r 'Const)) + rUnsafeFreeze :: (PrimMonad m, PrimState m ~ s) => Unwrapped (Untyped r ('Mut s)) -> m (Unwrapped (Untyped r 'Const)) instance ReprMaybeMutable ('Ptr 'Nothing) where - rThaw p = do - MaybePtr p' <- thaw (MaybePtr p) - pure p' - rFreeze p = do - MaybePtr p' <- freeze (MaybePtr p) - pure p' - rUnsafeThaw p = do - MaybePtr p' <- unsafeThaw (MaybePtr p) - pure p' - rUnsafeFreeze p = do - MaybePtr p' <- unsafeFreeze (MaybePtr p) - pure p' + rThaw p = do + MaybePtr p' <- thaw (MaybePtr p) + pure p' + rFreeze p = do + MaybePtr p' <- freeze (MaybePtr p) + pure p' + rUnsafeThaw p = do + MaybePtr p' <- unsafeThaw (MaybePtr p) + pure p' + rUnsafeFreeze p = do + MaybePtr p' <- unsafeFreeze (MaybePtr p) + pure p' do - let types = - [ [t|'Just 'Struct|] - , [t|'Just 'Cap|] - , [t|'Just ('List 'Nothing)|] - , [t|'Just ('List ('Just 'ListComposite))|] - , [t|'Just ('List ('Just ('ListNormal 'NormalListPtr)))|] - ] - concat <$> for types (\t -> do - [d|instance ReprMaybeMutable ('Ptr $t) where - rThaw = thaw - rFreeze = freeze - rUnsafeThaw = thaw - rUnsafeFreeze = freeze - |]) + let types = + [ [t|'Just 'Struct|], + [t|'Just 'Cap|], + [t|'Just ('List 'Nothing)|], + [t|'Just ('List ('Just 'ListComposite))|], + [t|'Just ('List ('Just ('ListNormal 'NormalListPtr)))|] + ] + concat + <$> for + types + ( \t -> do + [d| + instance ReprMaybeMutable ('Ptr $t) where + rThaw = thaw + rFreeze = freeze + rUnsafeThaw = thaw + rUnsafeFreeze = freeze + |] + ) instance ReprMaybeMutable ('Ptr ('Just ('List ('Just ('ListNormal ('NormalListData sz)))))) where - rThaw = thaw - rFreeze = freeze - rUnsafeThaw = thaw - rUnsafeFreeze = freeze + rThaw = thaw + rFreeze = freeze + rUnsafeThaw = thaw + rUnsafeFreeze = freeze instance ReprMaybeMutable ('Data sz) where - rThaw = pure - rFreeze = pure - rUnsafeThaw = pure - rUnsafeFreeze = pure + rThaw = pure + rFreeze = pure + rUnsafeThaw = pure + rUnsafeFreeze = pure -- | Constraint that @a@ is a struct type. type IsStruct a = ReprFor a ~ 'Ptr ('Just 'Struct) @@ -256,14 +289,13 @@ -- | Constraint that @a@ is a capability type. type IsCap a = ReprFor a ~ 'Ptr ('Just 'Cap) - -- | Constraint that @a@ is a pointer type. type IsPtr a = - ( ReprFor a ~ 'Ptr (PtrReprFor (ReprFor a)) + ( ReprFor a ~ 'Ptr (PtrReprFor (ReprFor a)), -- N.B. prior to ghc 9.2.x, this next constraint wasn't necessary, -- because it could be inferred from the first. I(zenhack) don't -- fully understand what changed, but some call sites need this -- extra help now... - , Untyped (ReprFor a) ~ UntypedPtr (PtrReprFor (ReprFor a)) - , IsPtrRepr (PtrReprFor (ReprFor a)) - ) + Untyped (ReprFor a) ~ UntypedPtr (PtrReprFor (ReprFor a)), + IsPtrRepr (PtrReprFor (ReprFor a)) + ) diff --git a/lib/Capnp/Repr/Methods.hs b/lib/Capnp/Repr/Methods.hs --- a/lib/Capnp/Repr/Methods.hs +++ b/lib/Capnp/Repr/Methods.hs @@ -1,168 +1,183 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + -- | Module: Capnp.Repr.Methods -- Description: Support for working with methods module Capnp.Repr.Methods - ( Method(..) - , HasMethod(..) - - , Pipeline(..) - , Client(..) - , pipe - , pipelineClient - , waitPipeline - - , AsClient(..) - , upcast + ( Method (..), + HasMethod (..), + Pipeline (..), + Client (..), + pipe, + pipelineClient, + waitPipeline, + AsClient (..), + upcast, -- * Calling methods. - , callB - , callR - , callP - ) where + callB, + callR, + callP, + ) +where -import qualified Capnp.Fields as F -import Capnp.Message (Mutability(..), newMessage) -import qualified Capnp.Message as M -import qualified Capnp.New.Classes as NC -import Capnp.New.Rpc.Common (Client(..), Pipeline(..)) -import qualified Capnp.Repr as R -import Capnp.Rpc.Promise (Promise, newPromise, wait) -import qualified Capnp.Rpc.Server as Server -import qualified Capnp.Rpc.Untyped as Rpc -import Capnp.TraversalLimit (evalLimitT) -import qualified Capnp.Untyped as U -import Control.Concurrent.STM (STM, atomically) -import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad.STM.Class (MonadSTM(..)) -import Data.Word -import GHC.OverloadedLabels (IsLabel(..)) -import GHC.Prim (coerce) -import GHC.TypeLits (Symbol) -import GHC.Types (Coercible) -import Internal.BuildPure (PureBuilder, createPure) +import qualified Capnp.Classes as C +import qualified Capnp.Fields as F +import Capnp.Message (Mutability (..), newMessage) +import qualified Capnp.Message as M +import qualified Capnp.Repr as R +import Capnp.Rpc.Common (Client (..), Pipeline (..)) +import Capnp.Rpc.Promise (Promise, newPromise, wait) +import qualified Capnp.Rpc.Server as Server +import qualified Capnp.Rpc.Untyped as Rpc +import Capnp.TraversalLimit (evalLimitT) +import qualified Capnp.Untyped as U +import Control.Concurrent.STM (STM, atomically) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.STM.Class (MonadSTM (..)) +import Data.Word +import GHC.OverloadedLabels (IsLabel (..)) +import GHC.Prim (coerce) +import GHC.TypeLits (Symbol) +import GHC.Types (Coercible) +import Internal.BuildPure (PureBuilder, createPure) -- | Represents a method on the interface type @c@ with parameter -- type @p@ and return type @r@. data Method c p r = Method - { interfaceId :: !Word64 - , methodId :: !Word16 - } + { interfaceId :: !Word64, + methodId :: !Word16 + } -- | An instance @'HasMethod' name c p r@ indicates that the interface -- type @c@ has a method named @name@ with parameter type @p@ and -- return type @r@. The generated code includes instances of this -- for each method in the schema. class (R.IsCap c, R.IsStruct p, R.IsStruct r) => HasMethod (name :: Symbol) c p r | name c -> p r where - methodByLabel :: Method c p r + methodByLabel :: Method c p r instance HasMethod name c p r => IsLabel name (Method c p r) where - fromLabel = methodByLabel @name @c @p @r + fromLabel = methodByLabel @name @c @p @r -- | The 'AsClient' class allows callers of rpc methods to abstract over 'Client's -- and 'Pipeline's. @'asClient'@ converts either of those to a client so that -- methods can be invoked on it. class AsClient f where - asClient :: MonadSTM m => R.IsCap c => f c -> m (Client c) + asClient :: MonadSTM m => R.IsCap c => f c -> m (Client c) instance AsClient Pipeline where - asClient = pipelineClient + asClient = pipelineClient instance AsClient Client where - asClient = liftSTM . pure + asClient = liftSTM . pure -- | Upcast is a (safe) cast from an interface to one of its superclasses. -upcast :: (AsClient f, Coercible (f p) (f c), NC.Super p c) => f c -> f p +upcast :: (AsClient f, Coercible (f p) (f c), C.Super p c) => f c -> f p upcast = coerce -- | Call a method. Use the provided 'PureBuilder' to construct the parameters. -callB - :: (AsClient f, R.IsCap c, R.IsStruct p, MonadIO m) - => Method c p r - -> (forall s. PureBuilder s (R.Raw p ('Mut s))) - -> f c - -> m (Pipeline r) +callB :: + (AsClient f, R.IsCap c, R.IsStruct p, MonadIO m) => + Method c p r -> + (forall s. PureBuilder s (R.Raw p ('Mut s))) -> + f c -> + m (Pipeline r) callB method buildRaw c = liftIO $ do - (params :: R.Raw a 'Const) <- R.Raw <$> createPure maxBound (R.fromRaw <$> buildRaw) - callR method params c + (params :: R.Raw a 'Const) <- R.Raw <$> createPure maxBound (R.fromRaw <$> buildRaw) + callR method params c -- | Call a method, supplying the parameters as a 'Raw' struct. -callR - :: (AsClient f, R.IsCap c, R.IsStruct p, MonadIO m) - => Method c p r -> R.Raw p 'Const -> f c -> m (Pipeline r) +callR :: + (AsClient f, R.IsCap c, R.IsStruct p, MonadIO m) => + Method c p r -> + R.Raw p 'Const -> + f c -> + m (Pipeline r) callR method arg c = liftIO $ do - p <- atomically (startCallR method arg c) - Pipeline <$> wait p + p <- atomically (startCallR method arg c) + Pipeline <$> wait p -startCallR - :: (AsClient f, R.IsCap c, R.IsStruct p) - => Method c p r -> R.Raw p 'Const -> f c -> STM (Promise Rpc.Pipeline) -startCallR Method{interfaceId, methodId} (R.Raw arg) c = do - Client client <- asClient c - (_, f) <- newPromise - Rpc.call - Server.CallInfo - { interfaceId - , methodId - , arguments = Just (U.PtrStruct arg) - , response = f - } - client +startCallR :: + (AsClient f, R.IsCap c, R.IsStruct p) => + Method c p r -> + R.Raw p 'Const -> + f c -> + STM (Promise Rpc.Pipeline) +startCallR Method {interfaceId, methodId} (R.Raw arg) c = do + Client client <- asClient c + (_, f) <- newPromise + Rpc.call + Server.CallInfo + { interfaceId, + methodId, + arguments = Just (U.PtrStruct arg), + response = f + } + client -- | Call a method, supplying the parmaeters in parsed form. -callP - :: forall c p r f m pp. - ( AsClient f - , R.IsCap c - , R.IsStruct p - , NC.Parse p pp - , MonadIO m - ) - => Method c p r -> pp -> f c -> m (Pipeline r) +callP :: + forall c p r f m pp. + ( AsClient f, + R.IsCap c, + R.IsStruct p, + C.Parse p pp, + MonadIO m + ) => + Method c p r -> + pp -> + f c -> + m (Pipeline r) callP method parsed client = liftIO $ do - struct <- createPure maxBound $ do - msg <- newMessage Nothing - R.fromRaw <$> NC.encode msg parsed - callR method (R.Raw struct) client + struct <- createPure maxBound $ do + msg <- newMessage Nothing + R.fromRaw <$> C.encode msg parsed + callR method (R.Raw struct) client -- | Project a pipeline to a struct onto one of its pointer fields. -pipe :: ( R.IsStruct a - , R.ReprFor b ~ 'R.Ptr pr - ) => F.Field k a b -> Pipeline a -> Pipeline b +pipe :: + ( R.IsStruct a, + R.ReprFor b ~ 'R.Ptr pr + ) => + F.Field k a b -> + Pipeline a -> + Pipeline b pipe (F.Field field) (Pipeline p) = - case field of - F.GroupField -> Pipeline p - F.PtrField idx -> Pipeline (Rpc.walkPipelinePtr p idx) + case field of + F.GroupField -> Pipeline p + F.PtrField idx -> Pipeline (Rpc.walkPipelinePtr p idx) -- | Convert a 'Pipeline' for a capability into a 'Client'. pipelineClient :: (R.IsCap a, MonadSTM m) => Pipeline a -> m (Client a) pipelineClient (Pipeline p) = - liftSTM $ Client <$> Rpc.pipelineClient p + liftSTM $ Client <$> Rpc.pipelineClient p -- | Wait for the result of a pipeline, and return its value. waitPipeline :: - forall a m pr. - ( 'R.Ptr pr ~ R.ReprFor a - , R.IsPtrRepr pr - , MonadSTM m - ) => Pipeline a -> m (R.Raw a 'Const) + forall a m pr. + ( 'R.Ptr pr ~ R.ReprFor a, + R.IsPtrRepr pr, + MonadSTM m + ) => + Pipeline a -> + m (R.Raw a 'Const) waitPipeline (Pipeline p) = - -- We need an instance of MonadLimit for IsPtrRepr's ReadCtx requirement, - -- but none of the relevant instances do a lot of reading, so we just - -- supply a low-ish arbitrary bound. - liftSTM $ evalLimitT 100 $ do - ptr <- Rpc.waitPipeline p - R.Raw <$> R.fromPtr @pr M.empty ptr + -- We need an instance of MonadLimit for IsPtrRepr's ReadCtx requirement, + -- but none of the relevant instances do a lot of reading, so we just + -- supply a low-ish arbitrary bound. + liftSTM $ evalLimitT 100 $ do + ptr <- Rpc.waitPipeline p + R.Raw <$> R.fromPtr @pr M.empty ptr instance R.ReprFor a ~ 'R.Ptr ('Just 'R.Cap) => Rpc.IsClient (Client a) where - toClient (Client c) = c - fromClient = Client + toClient (Client c) = c + fromClient = Client diff --git a/lib/Capnp/Repr/Parsed.hs b/lib/Capnp/Repr/Parsed.hs --- a/lib/Capnp/Repr/Parsed.hs +++ b/lib/Capnp/Repr/Parsed.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} + module Capnp.Repr.Parsed (Parsed) where +import qualified Capnp.Basics as B +import qualified Capnp.Classes as C +import Capnp.Repr (List, PtrRepr (..), Repr (..), ReprFor) +import Capnp.Rpc.Common (Client) import qualified Data.ByteString as BS -import Data.Kind (Type) -import qualified Data.Text as T -import qualified Data.Vector as V - -import qualified Capnp.New.Basics as B -import qualified Capnp.New.Classes as C - -import Capnp.New.Rpc.Common (Client) -import Capnp.Repr (List, PtrRepr(..), Repr(..), ReprFor) +import Data.Kind (Type) +import qualified Data.Text as T +import qualified Data.Vector as V -- | @'Parsed' a@ is the high-level/ADT representation of the capnproto -- type @a@. For struct types this is equivalent to @'C.Parsed' a@, but @@ -22,10 +21,10 @@ -- Helper for 'Parsed' type family ParsedByRepr (r :: Repr) (a :: Type) where - ParsedByRepr ('Data _) a = a - ParsedByRepr ('Ptr ('Just 'Cap)) a = Client a - ParsedByRepr _ B.Data = BS.ByteString - ParsedByRepr _ B.Text = T.Text - ParsedByRepr _ (List a) = V.Vector (Parsed a) - ParsedByRepr _ (Maybe B.AnyPointer) = Maybe (C.Parsed B.AnyPointer) - ParsedByRepr _ a = C.Parsed a + ParsedByRepr ('Data _) a = a + ParsedByRepr ('Ptr ('Just 'Cap)) a = Client a + ParsedByRepr _ B.Data = BS.ByteString + ParsedByRepr _ B.Text = T.Text + ParsedByRepr _ (List a) = V.Vector (Parsed a) + ParsedByRepr _ (Maybe B.AnyPointer) = Maybe (C.Parsed B.AnyPointer) + ParsedByRepr _ a = C.Parsed a diff --git a/lib/Capnp/Rpc.hs b/lib/Capnp/Rpc.hs --- a/lib/Capnp/Rpc.hs +++ b/lib/Capnp/Rpc.hs @@ -4,52 +4,53 @@ -- -- This module exposes the most commonly used parts of the RPC subsystem. module Capnp.Rpc - ( - -- * Establishing connections - handleConn - , ConnConfig(..) + ( -- * Establishing connections + handleConn, + ConnConfig (..), -- * throwing errors - , throwFailed + throwFailed, -- * Transmitting messages - , Transport(..) - , socketTransport - , handleTransport - , tracingTransport + Transport (..), + socketTransport, + handleTransport, + tracingTransport, -- * Promises - , module Capnp.Rpc.Promise + module Capnp.Rpc.Promise, -- * Clients - , Client - , IsClient(..) - , newPromiseClient - , waitClient + Client, + IsClient (..), + newPromiseClient, + waitClient, -- ** Reflection - , Untyped.unwrapServer + Untyped.unwrapServer, -- * Supervisors - , module Supervisors + module Supervisors, -- * Misc. - ) where - -import Supervisors + ) +where -import Capnp.Rpc.Errors (throwFailed) +import Capnp.Rpc.Errors (throwFailed) import Capnp.Rpc.Promise - import Capnp.Rpc.Transport - (Transport(..), handleTransport, socketTransport, tracingTransport) + ( Transport (..), + handleTransport, + socketTransport, + tracingTransport, + ) import Capnp.Rpc.Untyped - ( Client - , ConnConfig(..) - , IsClient(..) - , handleConn - , newPromiseClient - , waitClient - ) - + ( Client, + ConnConfig (..), + IsClient (..), + handleConn, + newPromiseClient, + waitClient, + ) import qualified Capnp.Rpc.Untyped as Untyped +import Supervisors diff --git a/lib/Capnp/Rpc/Common.hs b/lib/Capnp/Rpc/Common.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Rpc/Common.hs @@ -0,0 +1,14 @@ +module Capnp.Rpc.Common + ( Client (..), + Pipeline (..), + ) +where + +import qualified Internal.Rpc.Breaker as Rpc + +-- | A @'Pipeline' a@ is a reference to possibly-not-resolved result from +-- a method call. +newtype Pipeline a = Pipeline Rpc.Pipeline + +newtype Client a = Client Rpc.Client + deriving (Show, Eq) diff --git a/lib/Capnp/Rpc/Errors.hs b/lib/Capnp/Rpc/Errors.hs --- a/lib/Capnp/Rpc/Errors.hs +++ b/lib/Capnp/Rpc/Errors.hs @@ -1,59 +1,61 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-| -Module: Capnp.Rpc.Errors -Description: helpers for working with capnproto exceptions. -In addition to the values exposed in the API, this module also -defines an instance of Haskell's 'E.Exception' type class, for -Cap'n Proto's 'Exception'. --} +-- | +-- Module: Capnp.Rpc.Errors +-- Description: helpers for working with capnproto exceptions. +-- +-- In addition to the values exposed in the API, this module also +-- defines an instance of Haskell's 'E.Exception' type class, for +-- Cap'n Proto's 'Exception'. module Capnp.Rpc.Errors - ( - -- * Converting arbitrary exceptions to capnproto exceptions - wrapException - -- * Helpers for constructing exceptions - , eMethodUnimplemented - , eUnimplemented - , eDisconnected - , eFailed - , throwFailed - ) where + ( -- * Converting arbitrary exceptions to capnproto exceptions + wrapException, -import Data.Default (Default(def)) -import Data.Maybe (fromMaybe) -import Data.String (fromString) -import Data.Text (Text) + -- * Helpers for constructing exceptions + eMethodUnimplemented, + eUnimplemented, + eDisconnected, + eFailed, + throwFailed, + ) +where +import Capnp.Gen.Capnp.Rpc import qualified Control.Exception.Safe as E - -import Capnp.Gen.Capnp.Rpc.New +import Data.Default (Default (def)) +import Data.Maybe (fromMaybe) +import Data.String (fromString) +import Data.Text (Text) -- | Construct an exception with a type field of failed and the -- given text as its reason. eFailed :: Text -> Parsed Exception -eFailed reason = def - { type_ = Exception'Type'failed - , reason = reason +eFailed reason = + def + { type_ = Exception'Type'failed, + reason = reason } -- | An exception with type = disconnected eDisconnected :: Parsed Exception -eDisconnected = def - { type_ = Exception'Type'disconnected - , reason = "Disconnected" +eDisconnected = + def + { type_ = Exception'Type'disconnected, + reason = "Disconnected" } -- | An exception indicating an unimplemented method. eMethodUnimplemented :: Parsed Exception eMethodUnimplemented = - eUnimplemented "Method unimplemented" + eUnimplemented "Method unimplemented" -- | An @unimplemented@ exception with a custom reason message. eUnimplemented :: Text -> Parsed Exception -eUnimplemented reason = def - { type_ = Exception'Type'unimplemented - , reason = reason +eUnimplemented reason = + def + { type_ = Exception'Type'unimplemented, + reason = reason } instance E.Exception (Parsed Exception) @@ -63,14 +65,15 @@ -- If @debugMode@ is true, the returned exception's reason field will include -- the text of @show e@. wrapException :: Bool -> E.SomeException -> Parsed Exception -wrapException debugMode e = fromMaybe - def { type_ = Exception'Type'failed - , reason = - if debugMode then - "Unhandled exception: " <> fromString (show e) - else - "Unhandled exception" - } +wrapException debugMode e = + fromMaybe + def + { type_ = Exception'Type'failed, + reason = + if debugMode + then "Unhandled exception: " <> fromString (show e) + else "Unhandled exception" + } (E.fromException e) -- | Throw an exception with a type field of 'Exception'Type'failed' and diff --git a/lib/Capnp/Rpc/Membrane.hs b/lib/Capnp/Rpc/Membrane.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Rpc/Membrane.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Module: Capnp.Rpc.Membrane +-- Descritpion: Helpers for working with membranes. +-- +-- Membranes are common in object-capability design. Think of it like a +-- proxy on steroids: a membrane inserts itself in front of another capability, +-- and can intercept and modify method calls. Unlike a simple proxy though, +-- the membrane will also be applied to any objects returned by method calls, +-- or passed in arguments, transitively, so it can sit in front of entire +-- object graphs. +module Capnp.Rpc.Membrane + ( enclose, + exclude, + Policy, + Action (..), + Direction (..), + Call (..), + ) +where + +import qualified Capnp.Message as M +import Capnp.Mutability (Mutability (..)) +import Capnp.Rpc.Promise (breakOrFulfill, newCallback) +import qualified Capnp.Rpc.Server as Server +import qualified Capnp.Rpc.Untyped as URpc +import qualified Capnp.Untyped as U +import Control.Concurrent.STM +import Control.Monad (void) +import Control.Monad.STM.Class +import Data.Typeable (Typeable, cast) +import Data.Word +import Supervisors (Supervisor) + +-- | An action indicates what to do with an incoming method call. +data Action + = -- | Handle the method using the provided method handler, instead of + -- letting it through the membrane. Arguments and return values will not + -- be wrapped/unwraped, so be careful when delegating to objects inside + -- the membrane. + Handle Server.UntypedMethodHandler + | -- | Forward the method call on to its original destination, wrapping + -- and unwrapping arguments & return values as normal. + Forward + +-- | A Direction indicates which direction a method call is traveling: +-- into or out of the membrane. +data Direction = In | Out + deriving (Show, Read, Eq) + +flipDir :: Direction -> Direction +flipDir In = Out +flipDir Out = In + +-- | Alias for direction; somtimes it is convienent to think about capabilities +-- from the standpoint of which side they is _on_, rather than where it is going +-- as with methods. +type Side = Direction + +-- | A 'Call' represents a method call that is crossing the membrane. +data Call = Call + { -- | Which direction is the call going? if this is 'In', the call was made + -- by something outside the membrane to something inside it. If it is 'Out', + -- something inside the membrane is making a call to something outside the + -- membrane. + direction :: Direction, + -- | The interface id of the method being called. + interfaceId :: Word64, + -- | The ordinal of the method being called. + methodId :: Word16, + -- | The target of the method call. + target :: URpc.Client + } + +-- | A 'Policy' decides what to do when a call crosses the membrane. +type Policy = Call -> STM Action + +-- | @'enclose' sup cap policy@ wraps @cap@ in a membrane whose behavior is +-- goverend by @policy@. +enclose :: (URpc.IsClient c, MonadSTM m) => Supervisor -> c -> Policy -> m c +enclose = newMembrane In + +-- | 'exclude' is like 'enclose', except that the capability is treated as +-- being *outside* of a membrane that wraps the rest of the world. +exclude :: (URpc.IsClient c, MonadSTM m) => Supervisor -> c -> Policy -> m c +exclude = newMembrane Out + +newMembrane :: (URpc.IsClient c, MonadSTM m) => Direction -> Supervisor -> c -> Policy -> m c +newMembrane dir sup toWrap policy = liftSTM $ do + identity <- newTVar () + let mem = Membrane {policy, identity} + URpc.fromClient <$> pass dir sup mem (URpc.toClient toWrap) + +data MembraneWrapped = MembraneWrapped + { client :: URpc.Client, + membrane :: Membrane, + side :: Direction + } + deriving (Typeable) + +data Membrane = Membrane + { policy :: Policy, + -- | an object with identity, for comparison purposes: + identity :: TVar () + } + +instance Eq Membrane where + x == y = identity x == identity y + +wrapHandler :: Side -> Supervisor -> Membrane -> Server.UntypedMethodHandler -> Server.UntypedMethodHandler +wrapHandler receiverSide sup mem handler = Server.untypedHandler $ \arguments response -> do + (args, resp) <- atomically $ do + args' <- passPtr receiverSide sup mem arguments + resp' <- newCallback $ \result -> + traverse (passPtr (flipDir receiverSide) sup mem) result + >>= breakOrFulfill response + pure (args', resp') + Server.handleUntypedMethod handler args resp + +passPtr :: MonadSTM m => Direction -> Supervisor -> Membrane -> Maybe (U.Ptr 'Const) -> m (Maybe (U.Ptr 'Const)) +passPtr dir sup mem = liftSTM . traverse (U.tMsg $ passMessage dir sup mem) + +passMessage :: MonadSTM m => Direction -> Supervisor -> Membrane -> M.Message 'Const -> m (M.Message 'Const) +passMessage dir sup mem msg = liftSTM $ do + caps' <- traverse (pass dir sup mem) (M.getCapTable msg) + pure $ M.withCapTable caps' msg + +pass :: MonadSTM m => Direction -> Supervisor -> Membrane -> URpc.Client -> m URpc.Client +pass dir sup mem inClient = liftSTM $ + case URpc.unwrapServer inClient :: Maybe MembraneWrapped of + Just mw | onSide dir mw mem -> pure $ client mw + _ -> + URpc.export + sup + Server.ServerOps + { Server.handleCast = + cast $ + MembraneWrapped + { client = inClient, + membrane = mem, + side = dir + }, + -- Once we're gc'd, the downstream client will be as well + -- and then the relevant shutdown logic will still be called. + -- This introduces latency unfortuantely, but nothing is broken. + Server.handleStop = pure (), + Server.handleCall = \interfaceId methodId -> + Server.untypedHandler $ \arguments response -> + do + action <- atomically $ policy mem Call {interfaceId, methodId, direction = dir, target = inClient} + case action of + Handle h -> Server.handleUntypedMethod h arguments response + Forward -> + Server.handleUntypedMethod + ( wrapHandler dir sup mem $ Server.untypedHandler $ \arguments response -> + void $ URpc.call Server.CallInfo {..} inClient + ) + arguments + response + } + +onSide :: Direction -> MembraneWrapped -> Membrane -> Bool +onSide dir mw mem = + membrane mw == mem && dir == side mw diff --git a/lib/Capnp/Rpc/Promise.hs b/lib/Capnp/Rpc/Promise.hs --- a/lib/Capnp/Rpc/Promise.hs +++ b/lib/Capnp/Rpc/Promise.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} + -- | -- Module: Capnp.Rpc.Promise -- Description: Promises @@ -7,43 +8,43 @@ -- This module defines a 'Promise' type, represents a value which is not yet -- available, and related utilities. module Capnp.Rpc.Promise - ( Promise - , Fulfiller + ( Promise, + Fulfiller, -- * Creating promises - , newPromise - , newReadyPromise - , newPromiseWithCallback - , newCallback + newPromise, + newReadyPromise, + newPromiseWithCallback, + newCallback, -- * Fulfilling or breaking promises - , fulfill - , breakPromise - , breakOrFulfill - , ErrAlreadyResolved(..) + fulfill, + breakPromise, + breakOrFulfill, + ErrAlreadyResolved (..), -- * Getting the value of a promise - , wait - ) where - -import Control.Concurrent.STM -import Control.Monad.STM.Class - -import qualified Control.Exception.Safe as HsExn + wait, + ) +where -import Capnp.Gen.Capnp.Rpc.New +import Capnp.Gen.Capnp.Rpc -- For exception instance: import Capnp.Rpc.Errors () +import Control.Concurrent.STM +import qualified Control.Exception.Safe as HsExn +import Control.Monad.STM.Class -- | An exception thrown if 'breakPromise' or 'fulfill' is called on an -- already-resolved fulfiller. -data ErrAlreadyResolved = ErrAlreadyResolved deriving(Show) +data ErrAlreadyResolved = ErrAlreadyResolved deriving (Show) + instance HsExn.Exception ErrAlreadyResolved -- | A 'Fulfiller' is used to fulfill a promise. newtype Fulfiller a = Fulfiller - { callback :: Either (Parsed Exception) a -> STM () - } + { callback :: Either (Parsed Exception) a -> STM () + } -- | Fulfill a promise by supplying the specified value. It is an error to -- call 'fulfill' if the promise has already been fulfilled (or broken). @@ -59,20 +60,20 @@ -- | 'breakOrFulfill' calls either 'breakPromise' or 'fulfill', depending -- on the argument. breakOrFulfill :: MonadSTM m => Fulfiller a -> Either (Parsed Exception) a -> m () -breakOrFulfill Fulfiller{callback} result = liftSTM $ callback result +breakOrFulfill Fulfiller {callback} result = liftSTM $ callback result -- | Wait for a promise to resolve, and return the result. If the promise -- is broken, this raises an exception instead (see 'breakPromise'). wait :: MonadSTM m => Promise a -> m a -wait Promise{var} = liftSTM $ do - val <- readTVar var - case val of - Nothing -> - retry - Just (Right result) -> - pure result - Just (Left exn) -> - throwSTM exn +wait Promise {var} = liftSTM $ do + val <- readTVar var + case val of + Nothing -> + retry + Just (Right result) -> + pure result + Just (Left exn) -> + throwSTM exn -- | Create a promise that is already fulfilled, with the given value. newReadyPromise :: MonadSTM m => a -> m (Promise a) @@ -81,30 +82,30 @@ -- | Create a new promise and an associated fulfiller. newPromise :: MonadSTM m => m (Promise a, Fulfiller a) newPromise = liftSTM $ do - var <- newTVar Nothing - pure - ( Promise{var} - , Fulfiller - { callback = \result -> do - val <- readTVar var - case val of - Nothing -> - writeTVar var (Just result) - Just _ -> - throwSTM ErrAlreadyResolved - } - ) + var <- newTVar Nothing + pure + ( Promise {var}, + Fulfiller + { callback = \result -> do + val <- readTVar var + case val of + Nothing -> + writeTVar var (Just result) + Just _ -> + throwSTM ErrAlreadyResolved + } + ) -- | Create a new promise which also excecutes an STM action when it is resolved. newPromiseWithCallback :: MonadSTM m => (Either (Parsed Exception) a -> STM ()) -> m (Promise a, Fulfiller a) newPromiseWithCallback callback = liftSTM $ do - (promise, Fulfiller{callback=oldCallback}) <- newPromise - pure - ( promise - , Fulfiller - { callback = \result -> oldCallback result >> callback result - } - ) + (promise, Fulfiller {callback = oldCallback}) <- newPromise + pure + ( promise, + Fulfiller + { callback = \result -> oldCallback result >> callback result + } + ) -- | Like 'newPromiseWithCallback', but doesn't return the promise. newCallback :: MonadSTM m => (Either (Parsed Exception) a -> STM ()) -> m (Fulfiller a) @@ -112,6 +113,6 @@ -- | A promise is a value that may not be ready yet. newtype Promise a = Promise - { var :: TVar (Maybe (Either (Parsed Exception) a)) - } - deriving(Eq) + { var :: TVar (Maybe (Either (Parsed Exception) a)) + } + deriving (Eq) diff --git a/lib/Capnp/Rpc/Revoke.hs b/lib/Capnp/Rpc/Revoke.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/Rpc/Revoke.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Module: Capnp.Rpc.Revoke +-- Description: support for revocable capababilities +module Capnp.Rpc.Revoke + ( makeRevocable, + ) +where + +import Capnp.Rpc.Errors (eFailed) +import qualified Capnp.Rpc.Membrane as Membrane +import Capnp.Rpc.Promise (breakPromise) +import qualified Capnp.Rpc.Server as Server +import Capnp.Rpc.Untyped (IsClient) +import Control.Concurrent.STM +import Control.Monad.STM.Class (MonadSTM, liftSTM) +import Supervisors (Supervisor) + +-- | @'makeRevocable' sup cap@ returns a pair @(wrappedCap, revoke)@, such that +-- @wrappedCap@ is @cap@ wrapped by a membrane which forwards all method invocations +-- along until @revoke@ is executed, after which all methods that cross the membrane +-- (in either direction) will return errors. +-- +-- Note that, as per usual with membranes, the membrane will wrap any objects returned +-- by method calls. So revoke cuts off access to the entire object graph reached through +-- @cap@. +makeRevocable :: (MonadSTM m, IsClient c) => Supervisor -> c -> m (c, STM ()) +makeRevocable sup client = liftSTM $ do + isRevoked <- newTVar False + wrappedClient <- Membrane.enclose sup client (revokerPolicy isRevoked) + pure (wrappedClient, writeTVar isRevoked True) + +revokerPolicy :: TVar Bool -> Membrane.Policy +revokerPolicy isRevoked _call = do + revoked <- readTVar isRevoked + pure $ + if revoked + then Membrane.Handle revokedHandler + else Membrane.Forward + +revokedHandler :: Server.UntypedMethodHandler +revokedHandler = Server.untypedHandler $ \_ response -> breakPromise response (eFailed "revoked") diff --git a/lib/Capnp/Rpc/Server.hs b/lib/Capnp/Rpc/Server.hs --- a/lib/Capnp/Rpc/Server.hs +++ b/lib/Capnp/Rpc/Server.hs @@ -1,47 +1,48 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-| -Module: Capnp.Rpc.Server -Description: handlers for incoming method calls. +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -The term server in this context refers to a thread that handles method calls for -a particular capability (The capnproto rpc protocol itself has no concept of -clients and servers). --} +-- | +-- Module: Capnp.Rpc.Server +-- Description: handlers for incoming method calls. +-- +-- The term server in this context refers to a thread that handles method calls for +-- a particular capability (The capnproto rpc protocol itself has no concept of +-- clients and servers). module Capnp.Rpc.Server - ( Server(..) - , ServerOps(..) - , CallInfo(..) - , runServer + ( Server (..), + ServerOps (..), + CallInfo (..), + runServer, -- * Handling methods - , MethodHandler + MethodHandler, + UntypedMethodHandler, + handleUntypedMethod, + -- ** Working with untyped data - , untypedHandler - , toUntypedHandler - , fromUntypedHandler - ) where + untypedHandler, + toUntypedHandler, + fromUntypedHandler, + ) +where +import Capnp.Message (Mutability (..)) +import Capnp.Rpc.Promise (Fulfiller) +import Capnp.Untyped (Ptr) import Control.Concurrent.STM -import Data.Word - import Data.Typeable (Typeable) - -import Capnp.Message (Mutability(..)) -import Capnp.Rpc.Promise (Fulfiller) -import Capnp.Untyped (Ptr) - +import Data.Word import qualified Internal.TCloseQ as TCloseQ --- | a @'MethodHandler' m p r@ handles a method call with parameters @p@ --- and return type @r@, in monad @m@. +-- | a @'MethodHandler' p r@ handles a method call with parameters @p@ +-- and return type @r@. -- -- The library represents method handlers via an abstract type -- 'MethodHandler', parametrized over parameter (@p@) and return (@r@) @@ -54,93 +55,97 @@ -- * Working directly with the low-level data types. -- * Replying to the method call asynchronously, allowing later method -- calls to be serviced before the current one is finished. -newtype MethodHandler m p r = MethodHandler - { handleMethod - :: Maybe (Ptr 'Const) - -> Fulfiller (Maybe (Ptr 'Const)) - -> m () - } +newtype MethodHandler p r = MethodHandler + { handleMethod :: + Maybe (Ptr 'Const) -> + Fulfiller (Maybe (Ptr 'Const)) -> + IO () + } +-- | Alias for a 'MethodHandler' whose parameter and return types are +-- untyped pointers. +type UntypedMethodHandler = MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) + +handleUntypedMethod :: UntypedMethodHandler -> Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO () +handleUntypedMethod = handleMethod + -- | Convert a 'MethodHandler' for any parameter and return types into -- one that deals with untyped pointers. -toUntypedHandler - :: MethodHandler m p r - -> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) -toUntypedHandler MethodHandler{..} = MethodHandler{..} +toUntypedHandler :: MethodHandler p r -> UntypedMethodHandler +toUntypedHandler MethodHandler {..} = MethodHandler {..} -- | Inverse of 'toUntypedHandler' -fromUntypedHandler - :: MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) - -> MethodHandler m p r -fromUntypedHandler MethodHandler{..} = MethodHandler{..} +fromUntypedHandler :: UntypedMethodHandler -> MethodHandler p r +fromUntypedHandler MethodHandler {..} = MethodHandler {..} -- | Construct a method handler from a function accepting an untyped -- pointer for the method's parameter, and a 'Fulfiller' which accepts -- an untyped pointer for the method's return value. -untypedHandler - :: (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> m ()) - -> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) +untypedHandler :: + (Maybe (Ptr 'Const) -> Fulfiller (Maybe (Ptr 'Const)) -> IO ()) -> + MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) untypedHandler = MethodHandler -- | Base class for things that can act as capnproto servers. -class Monad m => Server m a | a -> m where - -- | Called when the last live reference to a server is dropped. - shutdown :: a -> m () - shutdown _ = pure () +class Server a where + -- | Called when the last live reference to a server is dropped. + shutdown :: a -> IO () + shutdown _ = pure () - -- | Try to extract a value of a given type. The default implementation - -- always fails (returns 'Nothing'). If an instance chooses to implement - -- this, it will be possible to use "reflection" on clients that point - -- at local servers to dynamically unwrap the server value. A typical - -- implementation will just call Typeable's @cast@ method, but this - -- needn't be the case -- a server may wish to allow local peers to - -- unwrap some value that is not exactly the data the server has access - -- to. - unwrap :: Typeable b => a -> Maybe b - unwrap _ = Nothing + -- | Try to extract a value of a given type. The default implementation + -- always fails (returns 'Nothing'). If an instance chooses to implement + -- this, it will be possible to use "reflection" on clients that point + -- at local servers to dynamically unwrap the server value. A typical + -- implementation will just call Typeable's @cast@ method, but this + -- needn't be the case -- a server may wish to allow local peers to + -- unwrap some value that is not exactly the data the server has access + -- to. + unwrap :: Typeable b => a -> Maybe b + unwrap _ = Nothing -- | The operations necessary to receive and handle method calls, i.e. -- to implement an object. It is parametrized over the monadic context -- in which methods are serviced. -data ServerOps m = ServerOps - { handleCall - :: Word64 - -> Word16 - -> MethodHandler m (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)) - -- ^ Handle a method call; takes the interface and method id and returns +data ServerOps = ServerOps + { -- | Handle a method call; takes the interface and method id and returns -- a handler for the specific method. - , handleStop :: m () - -- ^ Handle shutting-down the receiver; this is called when the last + handleCall :: + Word64 -> + Word16 -> + MethodHandler (Maybe (Ptr 'Const)) (Maybe (Ptr 'Const)), + -- | Handle shutting-down the receiver; this is called when the last -- reference to the capability is dropped. - , handleCast :: forall a. Typeable a => Maybe a - -- ^ used to unwrap the server when reflecting on a local client. - } + handleStop :: IO (), + -- | used to unwrap the server when reflecting on a local client. + handleCast :: forall a. Typeable a => Maybe a + } -- | A 'CallInfo' contains information about a method call. data CallInfo = CallInfo - { interfaceId :: !Word64 - -- ^ The id of the interface whose method is being called. - , methodId :: !Word16 - -- ^ The method id of the method being called. - , arguments :: Maybe (Ptr 'Const) - -- ^ The arguments to the method call. - , response :: Fulfiller (Maybe (Ptr 'Const)) - -- ^ A 'Fulfiller' which accepts the method's return value. - } + { -- | The id of the interface whose method is being called. + interfaceId :: !Word64, + -- | The method id of the method being called. + methodId :: !Word16, + -- | The arguments to the method call. + arguments :: Maybe (Ptr 'Const), + -- | A 'Fulfiller' which accepts the method's return value. + response :: Fulfiller (Maybe (Ptr 'Const)) + } -- | Handle incoming messages for a given object. -- -- Accepts a queue of messages to handle, and 'ServerOps' used to handle them. -- returns when it receives a 'Stop' message. -runServer :: TCloseQ.Q CallInfo -> ServerOps IO -> IO () +runServer :: TCloseQ.Q CallInfo -> ServerOps -> IO () runServer q ops = go where - go = atomically (TCloseQ.read q) >>= \case + go = + atomically (TCloseQ.read q) >>= \case Nothing -> - pure () - Just CallInfo{interfaceId, methodId, arguments, response} -> do - handleMethod - (handleCall ops interfaceId methodId) - arguments - response - go + pure () + Just CallInfo {interfaceId, methodId, arguments, response} -> do + handleMethod + (handleCall ops interfaceId methodId) + arguments + response + go diff --git a/lib/Capnp/Rpc/Transport.hs b/lib/Capnp/Rpc/Transport.hs --- a/lib/Capnp/Rpc/Transport.hs +++ b/lib/Capnp/Rpc/Transport.hs @@ -1,79 +1,80 @@ -{-| -Module: Capnp.Rpc.Transport -Description: Support for exchanging messages with remote vats. - -This module provides a 'Transport' type, which provides operations -used to transmit messages between vats in the RPC protocol. --} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -module Capnp.Rpc.Transport - ( Transport(..) - , handleTransport - , socketTransport - , tracingTransport - , TraceConfig(..) - ) where - -import Prelude hiding (log) +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -import Network.Socket (Socket) -import System.IO (Handle) +-- | +-- Module: Capnp.Rpc.Transport +-- Description: Support for exchanging messages with remote vats. +-- +-- This module provides a 'Transport' type, which provides operations +-- used to transmit messages between vats in the RPC protocol. +module Capnp.Rpc.Transport + ( Transport (..), + handleTransport, + socketTransport, + tracingTransport, + TraceConfig (..), + ) +where -import Capnp.Bits (WordCount) -import Capnp.Convert (msgToParsed) -import Capnp.IO (hGetMsg, hPutMsg, sGetMsg, sPutMsg) -import Capnp.Message (Message, Mutability(Const)) -import Capnp.New.Classes (Parsed) +import Capnp.Bits (WordCount) +import Capnp.Classes (Parsed) +import Capnp.Convert (msgToParsed) +import qualified Capnp.Gen.Capnp.Rpc as R +import Capnp.IO (hGetMsg, hPutMsg, sGetMsg, sPutMsg) +import Capnp.Message (Message, Mutability (Const)) import Capnp.TraversalLimit (evalLimitT) -import Data.Default (def) -import Text.Show.Pretty (ppShow) - -import qualified Capnp.Gen.Capnp.Rpc.New as R +import Data.Default (def) +import Network.Socket (Socket) +import System.IO (Handle) +import Text.Show.Pretty (ppShow) +import Prelude hiding (log) -- | A @'Transport'@ handles transmitting RPC messages. data Transport = Transport - { sendMsg :: Message 'Const -> IO () - -- ^ Send a message - , recvMsg :: IO (Message 'Const) - -- ^ Receive a message - } + { -- | Send a message + sendMsg :: Message 'Const -> IO (), + -- | Receive a message + recvMsg :: IO (Message 'Const) + } -- | @'handleTransport' handle limit@ is a transport which reads and writes -- messages from/to @handle@. It uses @limit@ as the traversal limit when -- reading messages and decoding. handleTransport :: Handle -> WordCount -> Transport -handleTransport handle limit = Transport - { sendMsg = hPutMsg handle - , recvMsg = hGetMsg handle limit +handleTransport handle limit = + Transport + { sendMsg = hPutMsg handle, + recvMsg = hGetMsg handle limit } -- | @'socketTransport' socket limit@ is a transport which reads and writes -- messages to/from a socket. It uses @limit@ as the traversal limit when -- reading messages and decoing. socketTransport :: Socket -> WordCount -> Transport -socketTransport socket limit = Transport - { sendMsg = sPutMsg socket - , recvMsg = sGetMsg socket limit +socketTransport socket limit = + Transport + { sendMsg = sPutMsg socket, + recvMsg = sGetMsg socket limit } data TraceConfig = TraceConfig - { log :: String -> IO () - , showPayloads :: !Bool - } + { log :: String -> IO (), + showPayloads :: !Bool + } -- | @'tracingTransport' log trans@ wraps another transport @trans@, loging -- messages when they are sent or received (using the @log@ function). This -- can be useful for debugging. tracingTransport :: TraceConfig -> Transport -> Transport -tracingTransport tcfg trans = Transport +tracingTransport tcfg trans = + Transport { sendMsg = \msg -> do rpcMsg <- evalLimitT maxBound $ msgToParsed @R.Message msg log tcfg $ "sending message: " ++ ppShow (editForTrace tcfg rpcMsg) - sendMsg trans msg - , recvMsg = do + sendMsg trans msg, + recvMsg = do msg <- recvMsg trans rpcMsg <- evalLimitT maxBound $ msgToParsed @R.Message msg log tcfg $ "received message: " ++ ppShow (editForTrace tcfg rpcMsg) @@ -82,16 +83,18 @@ editForTrace :: TraceConfig -> Parsed R.Message -> Parsed R.Message editForTrace tcfg rpcMsg = - if showPayloads tcfg then - rpcMsg + if showPayloads tcfg + then rpcMsg else - (case rpcMsg of - R.Message (R.Message'call call) -> - R.Message $ R.Message'call $ - call { R.params = def } - R.Message (R.Message'return R.Return{union' = R.Return'results _, .. }) -> - R.Message $ R.Message'return $ - R.Return { R.union' = R.Return'results def, .. } - _ -> - rpcMsg - ) + ( case rpcMsg of + R.Message (R.Message'call call) -> + R.Message $ + R.Message'call $ + call {R.params = def} + R.Message (R.Message'return R.Return {union' = R.Return'results _, ..}) -> + R.Message $ + R.Message'return $ + R.Return {R.union' = R.Return'results def, ..} + _ -> + rpcMsg + ) diff --git a/lib/Capnp/Rpc/Untyped.hs b/lib/Capnp/Rpc/Untyped.hs --- a/lib/Capnp/Rpc/Untyped.hs +++ b/lib/Capnp/Rpc/Untyped.hs @@ -1,2360 +1,2560 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module: Capnp.Rpc.Untyped --- Description: Core of the RPC subsystem. --- --- This module does not deal with schema-level concepts; all capabilities, --- methods etc. as used here are untyped. -module Capnp.Rpc.Untyped - ( - -- * Connections to other vats - ConnConfig(..) - , handleConn - - -- * Clients for capabilities - , Client - , call - , nullClient - , newPromiseClient - - , IsClient(..) - - -- * Promise pipelining - , Pipeline - , walkPipelinePtr - , pipelineClient - , waitPipeline - - -- * Exporting local objects - , export - , clientMethodHandler - - -- * Unwrapping local clients - , unwrapServer - - -- * Waiting for resolution - , waitClient - - -- * Errors - , RpcError(..) - - -- * Shutting down the connection - ) where - -import Control.Concurrent.STM -import Control.Monad.STM.Class -import Control.Monad.Trans.Class -import Data.Word - -import Capnp.Bits (WordCount, bytesToWordsFloor) -import Capnp.New.Accessors -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (concurrently_, race_) -import Control.Concurrent.MVar (MVar, newEmptyMVar) -import Control.Exception.Safe - ( Exception - , MonadThrow - , SomeException - , bracket - , finally - , fromException - , throwIO - , throwM - , try - ) -import Control.Monad (forever, void, when) -import Data.Default (Default(def)) -import Data.Foldable (for_, toList, traverse_) -import Data.Function ((&)) -import Data.Hashable (Hashable, hash, hashWithSalt) -import Data.Maybe (catMaybes, fromMaybe) -import Data.String (fromString) -import Data.Text (Text) -import Data.Typeable (Typeable) -import GHC.Generics (Generic) -import Supervisors (Supervisor, superviseSTM, withSupervisor) -import System.Mem.StableName (StableName, hashStableName, makeStableName) -import System.Timeout (timeout) - -import qualified Data.Vector as V -import qualified Focus -import qualified ListT -import qualified StmContainers.Map as M - -import Capnp.Convert (msgToRaw, parsedToMsg) -import Capnp.Fields (Which) -import Capnp.Message (Message) -import Capnp.Mutability (Mutability(..), thaw) -import Capnp.New.Classes (new, newRoot, parse) -import Capnp.Repr (Raw(..)) -import Capnp.Rpc.Errors - ( eDisconnected - , eFailed - , eMethodUnimplemented - , eUnimplemented - , wrapException - ) -import Capnp.Rpc.Promise - ( Fulfiller - , Promise - , breakOrFulfill - , breakPromise - , fulfill - , newCallback - , newPromise - , newReadyPromise - ) -import Capnp.Rpc.Transport (Transport(recvMsg, sendMsg)) -import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT) -import Internal.BuildPure (createPure) -import Internal.Rc (Rc) -import Internal.SnocList (SnocList) - -import qualified Capnp.Gen.Capnp.Rpc.New as R -import qualified Capnp.Message as Message -import qualified Capnp.New.Basics as B -import qualified Capnp.Rpc.Server as Server -import qualified Capnp.Untyped as UntypedRaw -import qualified Internal.Rc as Rc -import qualified Internal.SnocList as SnocList -import qualified Internal.TCloseQ as TCloseQ -import qualified Lifetimes.Gc as Fin - --- Note [Organization] --- =================== --- --- As much as possible, the logic in this module is centralized according to --- type types of objects it concerns. --- --- As an example, consider how we handle embargos: The 'Conn' type's 'embargos' --- table has values that are just 'Fulfiller's. This allows the code which triggers --- sending embargoes to have full control over what happens when they return, --- while the code that routes incoming messages (in 'recvLoop') doesn't need --- to concern itself with the details of embargos -- it just needs to route them --- to the right place. --- --- This approach generally results in better separation of concerns. - --- Note [Level 3] --- --- This is currently a level 1 implementation, so use of most level 3 features --- results in sending abort messages. However, to make adding this support --- easier later, we mark such places with a cross-reference back to this note. --- --- In addition to filling in those spots, the following will need to be dealt --- with: --- --- * The "Tribble 4-way Race Condition" as documented in rpc.capnp. This --- doesn't affect level 1 implementations, but right now we shorten N-hop --- paths of promises to 1-hop, (calls on Ready PromiseClients just --- immediately call the target), which is unsafe in a level 3 --- implementation. See the protocol documentation for more info. - --- | We use this type often enough that the types get noisy without a shorthand: -type RawMPtr = Maybe (UntypedRaw.Ptr 'Const) - - --- | Errors which can be thrown by the rpc system. -data RpcError - = ReceivedAbort (R.Parsed R.Exception) - -- ^ The remote vat sent us an abort message. - | SentAbort (R.Parsed R.Exception) - -- ^ We sent an abort to the remote vat. - deriving(Show, Eq, Generic) - -makeAbortExn :: Bool -> SomeException -> RpcError -makeAbortExn debugMode e = - fromMaybe - (SentAbort (wrapException debugMode e)) - (fromException e) - -instance Exception RpcError - -newtype EmbargoId = EmbargoId { embargoWord :: Word32 } deriving(Eq, Hashable) -newtype QAId = QAId { qaWord :: Word32 } deriving(Eq, Hashable) -newtype IEId = IEId { ieWord :: Word32 } deriving(Eq, Hashable) - --- We define these to just show the number; the derived instances would include --- data constructors, which is a bit weird since these show up in output that --- is sometimes shown to users. -instance Show QAId where - show = show . qaWord -instance Show IEId where - show = show . ieWord - --- | A connection to a remote vat -data Conn = Conn - { stableName :: StableName (MVar ()) - -- So we can use the connection as a map key. The MVar used to create - -- this is just an arbitrary value; the only property we care about - -- is that it is distinct for each 'Conn', so we use something with - -- reference semantics to guarantee this. - - , debugMode :: !Bool - -- whether to include extra (possibly sensitive) info in error messages. - - , liveState :: TVar LiveState - } - -data LiveState - = Live Conn' - | Dead - -data Conn' = Conn' - { sendQ :: TChan (Message 'Const, Fulfiller ()) - -- queue of messages to send sent to the remote vat; these are actually - -- sent by a dedicated thread (see 'sendLoop'). - -- - -- The fulfiller is fulfilled after the message actually hits the transport. - -- - -- The queue mainly exists for the sake of messages that are sent *while - -- processing incomming messages*, since we cannot block in those cases, - -- but it is used for all message sends to enforce ordering. The fulfiller - -- is used by parts of the code (basically just calls) that want to block - -- until their message is actually written to the socket. - - , availableCallWords :: TVar WordCount - -- Semaphore used to limit the memory that can be used by in-progress - -- calls originating from this connection. We don't just use a TSem - -- because waitTSem doesn't let us wait for more than one token with a - -- single call. - - , supervisor :: Supervisor - -- Supervisor managing the lifetimes of threads bound to this connection. - - , questionIdPool :: IdPool - , exportIdPool :: IdPool - -- Pools of identifiers for new questions and exports - - , questions :: M.Map QAId EntryQA - , answers :: M.Map QAId EntryQA - , exports :: M.Map IEId EntryE - , imports :: M.Map IEId EntryI - - , embargos :: M.Map EmbargoId (Fulfiller ()) - -- Outstanding embargos. When we receive a 'Disembargo' message with its - -- context field set to receiverLoopback, we look up the embargo id in - -- this table, and fulfill the promise. - - , pendingCallbacks :: TQueue (IO ()) - -- See Note [callbacks] - - , bootstrap :: Maybe Client - -- The capability which should be served as this connection's bootstrap - -- interface (if any). - } - -instance Eq Conn where - x == y = stableName x == stableName y - -instance Hashable Conn where - hash Conn{stableName} = hashStableName stableName - hashWithSalt _ = hash - --- | Configuration information for a connection. -data ConnConfig = ConnConfig - { maxQuestions :: !Word32 - -- ^ The maximum number of simultanious outstanding requests to the peer - -- vat. Once this limit is reached, further questsions will block until - -- some of the existing questions have been answered. - -- - -- Defaults to 128. - - , maxExports :: !Word32 - -- ^ The maximum number of objects which may be exported on this connection. - -- - -- Defaults to 8192. - - , maxCallWords :: !WordCount - -- ^ The maximum total size of outstanding call messages that will be - -- accepted; if this limit is reached, the implementation will not read - -- more messages from the connection until some calls have completed - -- and freed up enough space. - -- - -- Defaults to 32MiB in words. - - , debugMode :: !Bool - -- ^ In debug mode, errors reported by the RPC system to its peers will - -- contain extra information. This should not be used in production, as - -- it is possible for these messages to contain sensitive information, - -- but it can be useful for debugging. - -- - -- Defaults to 'False'. - - , getBootstrap :: Supervisor -> STM (Maybe Client) - -- ^ Get the bootstrap interface we should serve for this connection. - -- the argument is a supervisor whose lifetime is bound to the - -- connection. If 'getBootstrap' returns 'Nothing', we will respond - -- to bootstrap messages with an exception. - -- - -- The default always returns 'Nothing'. - -- - -- 'getBootstrap' MUST NOT block; the connection will not be serviced - -- and 'withBootstrap' will not be run until this returns. If you need - -- to supply the bootstrap interface later, use 'newPromiseClient'. - - , withBootstrap :: Maybe (Supervisor -> Client -> IO ()) - -- ^ An action to perform with access to the remote vat's bootstrap - -- interface. The supervisor argument is bound to the lifetime of the - -- connection. If this is 'Nothing' (the default), the bootstrap - -- interface will not be requested. - } - -instance Default ConnConfig where - def = ConnConfig - { maxQuestions = 128 - , maxExports = 8192 - , maxCallWords = bytesToWordsFloor $ 32 * 1024 * 1024 - , debugMode = False - , getBootstrap = \_ -> pure Nothing - , withBootstrap = Nothing - } - --- | Queue an IO action to be run some time after this transaction commits. --- See Note [callbacks]. -queueIO :: Conn' -> IO () -> STM () -queueIO Conn'{pendingCallbacks} = writeTQueue pendingCallbacks - --- | Queue another transaction to be run some time after this transaction --- commits, in a thread bound to the lifetime of the connection. If this is --- called multiple times within the same transaction, each of the --- transactions will be run separately, in the order they were queued. --- --- See Note [callbacks] -queueSTM :: Conn' -> STM () -> STM () -queueSTM conn = queueIO conn . atomically - --- | @'mapQueueSTM' conn fs val@ queues the list of transactions obtained --- by applying each element of @fs@ to @val@. -mapQueueSTM :: Conn' -> SnocList (a -> STM ()) -> a -> STM () -mapQueueSTM conn fs x = traverse_ (\f -> queueSTM conn (f x)) fs - --- Note [callbacks] --- ================ --- --- There are many places where we want to register some code to run after --- some later event has happened -- for exmaple: --- --- * We send a Call to the remote vat, and when a corresponding Return message --- is received, we want to fulfill (or break) the local promise for the --- result. --- * We send a Disembargo (with senderLoopback set), and want to actually lift --- the embargo when the corresponding (receiverLoopback) message arrives. --- --- Keeping the two parts of these patterns together tends to result in better --- separation of concerns, and is easier to maintain. --- --- To achieve this, the four tables and other connection state have fields in --- which callbacks can be registered -- for example, an outstanding question has --- fields containing transactions to run when the return and/or finish messages --- arrive. --- --- When it is time to actually run these, we want to make sure that each of them --- runs as their own transaction. If, for example, when registering a callback to --- run when a return message is received, we find that the return message is --- already available, it might be tempting to just run the transaction immediately. --- But this means that the synchronization semantics are totally different from the --- case where the callback really does get run later! --- --- In addition, we sometimes want to register a finalizer inside a transaction, --- but this can only be done in IO. --- --- To solve these issues, the connection maintains a queue of all callback actions --- that are ready to run, and when the event a callback is waiting for occurs, we --- simply move the callback to the queue, using 'queueIO' or 'queueSTM'. When the --- connection starts up, it creates a thread running 'callbacksLoop', which just --- continually flushes the queue, running the actions in the queue. - --- | Get a new question id. retries if we are out of available question ids. -newQuestion :: Conn' -> STM QAId -newQuestion = fmap QAId . newId . questionIdPool - --- | Return a question id to the pool of available ids. -freeQuestion :: Conn' -> QAId -> STM () -freeQuestion conn = freeId (questionIdPool conn) . qaWord - --- | Get a new export id. retries if we are out of available export ids. -newExport :: Conn' -> STM IEId -newExport = fmap IEId . newId . exportIdPool - --- | Return a export id to the pool of available ids. -freeExport :: Conn' -> IEId -> STM () -freeExport conn = freeId (exportIdPool conn) . ieWord - --- | Get a new embargo id. This shares the same pool as questions. -newEmbargo :: Conn' -> STM EmbargoId -newEmbargo = fmap EmbargoId . newId . questionIdPool - --- | Return an embargo id. to the available pool. -freeEmbargo :: Conn' -> EmbargoId -> STM () -freeEmbargo conn = freeId (exportIdPool conn) . embargoWord - --- | Handle a connection to another vat. Returns when the connection is closed. -handleConn :: Transport -> ConnConfig -> IO () -handleConn - transport - cfg@ConnConfig - { maxQuestions - , maxExports - , maxCallWords - , withBootstrap - , debugMode - } - = withSupervisor $ \sup -> - bracket - (newConn sup) - stopConn - runConn - where - newConn sup = do - stableName <- makeStableName =<< newEmptyMVar - atomically $ do - bootstrap <- getBootstrap cfg sup - questionIdPool <- newIdPool maxQuestions - exportIdPool <- newIdPool maxExports - - sendQ <- newTChan - - availableCallWords <- newTVar maxCallWords - - questions <- M.new - answers <- M.new - exports <- M.new - imports <- M.new - - embargos <- M.new - pendingCallbacks <- newTQueue - - let conn' = Conn' - { supervisor = sup - , questionIdPool - , exportIdPool - , sendQ - , availableCallWords - , questions - , answers - , exports - , imports - , embargos - , pendingCallbacks - , bootstrap - } - liveState <- newTVar (Live conn') - let conn = Conn - { stableName - , debugMode - , liveState - } - pure (conn, conn') - runConn (conn, conn') = do - result <- try $ - ( recvLoop transport conn - `concurrently_` sendLoop transport conn' - `concurrently_` callbacksLoop conn' - ) `race_` - useBootstrap conn conn' - case result of - Left (SentAbort e) -> do - -- We need to actually send it: - rawMsg <- createPure maxBound $ parsedToMsg $ R.Message'abort e - void $ timeout 1000000 $ sendMsg transport rawMsg - throwIO $ SentAbort e - Left e -> - throwIO e - Right _ -> - pure () - stopConn - ( conn@Conn{liveState} - , conn'@Conn'{questions, exports, embargos} - ) = do - atomically $ do - let walk table = flip ListT.traverse_ (M.listT table) - -- drop the bootstrap interface: - case bootstrap conn' of - Just (Client (Just client')) -> dropConnExport conn client' - _ -> pure () - -- Remove everything from the exports table: - walk exports $ \(_, EntryE{client}) -> - dropConnExport conn client - -- Outstanding questions should all throw disconnected: - walk questions $ \(qid, entry) -> - let raiseDisconnected onReturn = - mapQueueSTM conn' onReturn $ Return - { answerId = qid - , releaseParamCaps = False - , union' = Return'exception eDisconnected - } - in case entry of - NewQA{onReturn} -> raiseDisconnected onReturn - HaveFinish{onReturn} -> raiseDisconnected onReturn - _ -> pure () - -- same thing with embargos: - walk embargos $ \(_, fulfiller) -> - breakPromise fulfiller eDisconnected - -- mark the connection as dead, making the live state inaccessible: - writeTVar liveState Dead - useBootstrap conn conn' = case withBootstrap of - Nothing -> - forever $ threadDelay maxBound - Just f -> - atomically (requestBootstrap conn) >>= f (supervisor conn') - - --- | A pool of ids; used when choosing identifiers for questions and exports. -newtype IdPool = IdPool (TVar [Word32]) - --- | @'newIdPool' size@ creates a new pool of ids, with @size@ available ids. -newIdPool :: Word32 -> STM IdPool -newIdPool size = IdPool <$> newTVar [0..size-1] - --- | Get a new id from the pool. Retries if the pool is empty. -newId :: IdPool -> STM Word32 -newId (IdPool pool) = readTVar pool >>= \case - [] -> retry - (id:ids) -> do - writeTVar pool $! ids - pure id - --- | Return an id to the pool. -freeId :: IdPool -> Word32 -> STM () -freeId (IdPool pool) id = modifyTVar' pool (id:) - --- | An entry in our questions or answers table. -data EntryQA - -- | An entry for which we have neither sent/received a finish, nor - -- a return. Contains two sets of callbacks, one to invoke on each - -- type of message. - = NewQA - { onFinish :: SnocList (R.Parsed R.Finish -> STM ()) - , onReturn :: SnocList (Return -> STM ()) - } - -- | An entry for which we've sent/received a return, but not a finish. - -- Contains the return message, and a set of callbacks to invoke on the - -- finish. - | HaveReturn - { returnMsg :: Return - , onFinish :: SnocList (R.Parsed R.Finish -> STM ()) - } - -- | An entry for which we've sent/received a finish, but not a return. - -- Contains the finish message, and a set of callbacks to invoke on the - -- return. - | HaveFinish - { finishMsg :: R.Parsed R.Finish - , onReturn :: SnocList (Return -> STM ()) - } - - --- | An entry in our imports table. -data EntryI = EntryI - { localRc :: Rc () - -- ^ A refcount cell with a finalizer attached to it; when the finalizer - -- runs it will remove this entry from the table and send a release - -- message to the remote vat. - , remoteRc :: !Word32 - -- ^ The reference count for this object as understood by the remote - -- vat. This tells us what to send in the release message's count field. - , proxies :: ExportMap - -- ^ See Note [proxies] - -- - , promiseState :: Maybe - ( TVar PromiseState - , TmpDest -- origTarget field. TODO(cleanup): clean this up a bit. - ) - -- ^ If this entry is a promise, this will contain the state of that - -- promise, so that it may be used to create PromiseClients and - -- update the promise when it resolves. - } - --- | An entry in our exports table. -data EntryE = EntryE - { client :: Client' - -- ^ The client. We cache it in the table so there's only one object - -- floating around, which lets us attach a finalizer without worrying - -- about it being run more than once. - , refCount :: !Word32 - -- ^ The refcount for this entry. This lets us know when we can drop - -- the entry from the table. - } - --- | Types which may be converted to and from 'Client's. Typically these --- will be simple type wrappers for capabilities. -class IsClient a where - -- | Convert a value to a client. - toClient :: a -> Client - -- | Convert a client to a value. - fromClient :: Client -> a - -instance IsClient Client where - toClient = id - fromClient = id - -instance Show Client where - show (Client Nothing) = "nullClient" - show _ = "({- capability; not statically representable -})" - --- | A reference to a capability, which may be live either in the current vat --- or elsewhere. Holding a client affords making method calls on a capability --- or modifying the local vat's reference count to it. -newtype Client = - -- We wrap the real client in a Maybe, with Nothing representing a 'null' - -- capability. - Client (Maybe Client') - deriving(Eq) - --- | A non-null client. -data Client' - -- | A client pointing at a capability local to our own vat. - = LocalClient - { exportMap :: ExportMap - -- ^ Record of what export IDs this client has on different remote - -- connections. - , qCall :: Rc (Server.CallInfo -> STM ()) - -- ^ Queue a call for the local capability to handle. This is wrapped - -- in a reference counted cell, whose finalizer stops the server. - , finalizerKey :: Fin.Cell () - -- ^ Finalizer key; when this is collected, qCall will be released. - , unwrapper :: forall a. Typeable a => Maybe a - } - -- | A client which will resolve to some other capability at - -- some point. - | PromiseClient - { pState :: TVar PromiseState - -- ^ The current state of the promise; the indirection allows - -- the promise to be updated. - , exportMap :: ExportMap - - , origTarget :: TmpDest - -- ^ The original target of this promise, before it was resolved. - -- (if it is still in the pending state, it will match the TmpDest - -- stored there). - -- - -- FIXME: if this is an ImportDest, by holding on to this we actually - -- leak the cap. - } - -- | A client which points to a (resolved) capability in a remote vat. - | ImportClient (Fin.Cell ImportRef) - --- | A 'Pipeline' is a reference to a value within a message that has not yet arrived. -data Pipeline = Pipeline - { state :: TVar PipelineState - , steps :: SnocList Word16 - } - -data PipelineState - = PendingRemotePipeline - { answerId :: !QAId - , clientMap :: M.Map (SnocList Word16) Client - , conn :: Conn - } - | PendingLocalPipeline (SnocList (Fulfiller RawMPtr)) - | ReadyPipeline (Either (R.Parsed R.Exception) RawMPtr) - --- | 'walkPipleinePtr' follows a pointer starting from the object referred to by the --- 'Pipeline'. The 'Pipeline' must refer to a struct, and the pointer is referred to --- by its index into the struct's pointer section. -walkPipelinePtr :: Pipeline -> Word16 -> Pipeline -walkPipelinePtr p@Pipeline{steps} step = - p { steps = SnocList.snoc steps step } - --- | Convert a 'Pipeline' into a 'Client', which can be used to send messages to the --- referant of the 'Pipeline', using promise pipelining. -pipelineClient :: MonadSTM m => Pipeline -> m Client -pipelineClient Pipeline{state, steps} = liftSTM $ do - readTVar state >>= \case - PendingRemotePipeline{answerId, clientMap, conn} -> do - maybeClient <- M.lookup steps clientMap - case maybeClient of - Nothing -> do - client <- promisedAnswerClient - conn - PromisedAnswer { answerId, transform = steps } - M.insert client steps clientMap - pure client - Just client -> - pure client - PendingLocalPipeline subscribers -> do - (ret, retFulfiller) <- newPromiseClient - ptrFulfiller <- newCallback $ \r -> do - writeTVar state (ReadyPipeline r) - case r of - Left e -> - breakPromise retFulfiller e - Right v -> - (ptrPathClient (toList steps) v >>= fulfill retFulfiller) - `catchSTM` - (breakPromise retFulfiller . wrapException False) - writeTVar state $ PendingLocalPipeline $ SnocList.snoc subscribers ptrFulfiller - pure ret - ReadyPipeline r -> do - -- TODO(cleanup): factor out the commonalities between this and the above case. - (p, f) <- newPromiseClient - case r of - Left e -> breakPromise f e >> pure p - Right v -> - ptrPathClient (toList steps) v - `catchSTM` (\e -> do - breakPromise f (wrapException False e) - pure p) - --- | Wait for the pipeline's target to resolve, and return the corresponding --- pointer. -waitPipeline :: MonadSTM m => Pipeline -> m RawMPtr -waitPipeline Pipeline{state, steps} = liftSTM $ do - s <- readTVar state - case s of - ReadyPipeline (Left e) -> - throwM e - ReadyPipeline (Right v) -> - evalLimitT defaultLimit $ followPtrs (toList steps) v - _ -> - retry - -promisedAnswerClient :: Conn -> PromisedAnswer -> STM Client -promisedAnswerClient conn answer@PromisedAnswer{answerId, transform} = do - let tmpDest = RemoteDest AnswerDest { conn, answer } - pState <- newTVar Pending { tmpDest } - exportMap <- ExportMap <$> M.new - let client = Client $ Just PromiseClient - { pState - , exportMap - , origTarget = tmpDest - } - readTVar (liveState conn) >>= \case - Dead -> - resolveClientExn tmpDest (writeTVar pState) eDisconnected - Live conn'@Conn'{questions} -> - subscribeReturn "questions" conn' questions answerId $ - resolveClientReturn tmpDest (writeTVar pState) conn' (toList transform) - pure client - --- | The current state of a 'PromiseClient'. -data PromiseState - -- | The promise is fully resolved. - = Ready - { target :: Client - -- ^ Capability to which the promise resolved. - } - -- | The promise has resolved, but is waiting on a Disembargo message - -- before it is safe to send it messages. - | Embargo - { callBuffer :: TQueue Server.CallInfo - -- ^ A queue in which to buffer calls while waiting for the - -- disembargo. - } - -- | The promise has not yet resolved. - | Pending - { tmpDest :: TmpDest - -- ^ A temporary destination to send calls, while we wait for the - -- promise to resolve. - } - -- | The promise resolved to an exception. - | Error (R.Parsed R.Exception) - --- | A temporary destination for calls on an unresolved promise. -data TmpDest - -- | A destination that is local to this vat. - = LocalDest LocalDest - -- | A destination in another vat. - | RemoteDest RemoteDest - -newtype LocalDest - -- | Queue the calls in a buffer. - = LocalBuffer { callBuffer :: TQueue Server.CallInfo } - -data RemoteDest - -- | Send call messages to a remote vat, targeting the results - -- of an outstanding question. - = AnswerDest - { conn :: Conn - -- ^ The connection to the remote vat. - , answer :: PromisedAnswer - -- ^ The answer to target. - } - -- | Send call messages to a remote vat, targeting an entry in our - -- imports table. - | ImportDest (Fin.Cell ImportRef) - --- | A reference to a capability in our import table/a remote vat's export --- table. -data ImportRef = ImportRef - { conn :: Conn - -- ^ The connection to the remote vat. - , importId :: !IEId - -- ^ The import id for this capability. - , proxies :: ExportMap - -- ^ Export ids to use when this client is passed to a vat other than - -- the one identified by 'conn'. See Note [proxies] - } - --- Ideally we could just derive these, but stm-containers doesn't have Eq --- instances, so neither does ExportMap. not all of the fields are actually --- necessary to check equality though. See also --- https://github.com/nikita-volkov/stm-hamt/pull/1 -instance Eq ImportRef where - ImportRef { conn=cx, importId=ix } == ImportRef { conn=cy, importId=iy } = - cx == cy && ix == iy -instance Eq Client' where - LocalClient { qCall = x } == LocalClient { qCall = y } = - x == y - PromiseClient { pState = x } == PromiseClient { pState = y } = - x == y - ImportClient x == ImportClient y = - x == y - _ == _ = - False - - --- | an 'ExportMap' tracks a mapping from connections to export IDs; it is --- used to ensure that we re-use export IDs for capabilities when passing --- them to remote vats. This used for locally hosted capabilities, but also --- by proxied imports (see Note [proxies]). -newtype ExportMap = ExportMap (M.Map Conn IEId) - --- The below correspond to the similarly named types in --- rpc.capnp, except: --- --- * They use our newtype wrappers for ids --- * They don't have unknown variants --- * AnyPointers are left un-parsed --- * PromisedAnswer's transform field is just a list of pointer offsets, --- rather than a union with no other actually-useful variants. --- * PromisedAnswer's transform field is a SnocList, for efficient appending. -data MsgTarget - = ImportTgt !IEId - | AnswerTgt PromisedAnswer -data PromisedAnswer = PromisedAnswer - { answerId :: !QAId - , transform :: SnocList Word16 - } -data Call = Call - { questionId :: !QAId - , target :: !MsgTarget - , interfaceId :: !Word64 - , methodId :: !Word16 - , params :: !Payload - } -data Return = Return - { answerId :: !QAId - , releaseParamCaps :: !Bool - , union' :: Return' - } -data Return' - = Return'results Payload - | Return'exception (R.Parsed R.Exception) - | Return'canceled - | Return'resultsSentElsewhere - | Return'takeFromOtherQuestion QAId - | Return'acceptFromThirdParty RawMPtr -data Payload = Payload - { content :: RawMPtr - , capTable :: V.Vector (R.Parsed R.CapDescriptor) - } - --- Note [proxies] --- ============== --- --- It is possible to have multiple connections open at once, and pass around --- clients freely between them. Without level 3 support, this means that when --- we pass a capability pointing into Vat A to another Vat B, we must proxy it. --- --- To achieve this, capabilities pointing into a remote vat hold an 'ExportMap', --- which tracks which export IDs we should be using to proxy the client on each --- connection. - --- | Queue a call on a client. -call :: MonadSTM m => Server.CallInfo -> Client -> m (Promise Pipeline) -call Server.CallInfo { response } (Client Nothing) = liftSTM $ do - breakPromise response eMethodUnimplemented - state <- newTVar $ ReadyPipeline (Left eMethodUnimplemented) - newReadyPromise Pipeline{state, steps = mempty} -call info@Server.CallInfo { response } (Client (Just client')) = liftSTM $ do - (localPipeline, response') <- makeLocalPipeline response - let info' = info { Server.response = response' } - case client' of - LocalClient { qCall } -> do - Rc.get qCall >>= \case - Just q -> do - q info' - Nothing -> - breakPromise response' eDisconnected - newReadyPromise localPipeline - - PromiseClient { pState } -> readTVar pState >>= \case - Ready { target } -> - call info target - - Embargo { callBuffer } -> do - writeTQueue callBuffer info' - newReadyPromise localPipeline - - Pending { tmpDest } -> case tmpDest of - LocalDest LocalBuffer { callBuffer } -> do - writeTQueue callBuffer info' - newReadyPromise localPipeline - - RemoteDest AnswerDest { conn, answer } -> - callRemote conn info $ AnswerTgt answer - - RemoteDest (ImportDest cell) -> do - ImportRef { conn, importId } <- Fin.readCell cell - callRemote conn info $ ImportTgt importId - - Error exn -> do - breakPromise response' exn - newReadyPromise localPipeline - - ImportClient cell -> do - ImportRef { conn, importId } <- Fin.readCell cell - callRemote conn info (ImportTgt importId) - -makeLocalPipeline :: Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr) -makeLocalPipeline f = do - state <- newTVar $ PendingLocalPipeline mempty - f' <- newCallback $ \r -> do - s <- readTVar state - case s of - PendingLocalPipeline fs -> do - writeTVar state (ReadyPipeline r) - breakOrFulfill f r - traverse_ (`breakOrFulfill` r) fs - _ -> - -- TODO(cleanup): refactor so we don't need this case. - error "impossible" - pure (Pipeline{state, steps = mempty}, f') - --- | Send a call to a remote capability. -callRemote :: Conn -> Server.CallInfo -> MsgTarget -> STM (Promise Pipeline) -callRemote - conn - Server.CallInfo{ interfaceId, methodId, arguments, response } - target = do - conn'@Conn'{questions} <- getLive conn - qid <- newQuestion conn' - payload@Payload{capTable} <- makeOutgoingPayload conn arguments - -- save these in case the callee sends back releaseParamCaps = True in the return - -- message: - let paramCaps = catMaybes $ flip map (V.toList capTable) $ \R.CapDescriptor{union'} -> case union' of - R.CapDescriptor'senderHosted eid -> Just (IEId eid) - R.CapDescriptor'senderPromise eid -> Just (IEId eid) - _ -> Nothing - - clientMap <- M.new - rp <- newTVar PendingRemotePipeline - { answerId = qid - , clientMap - , conn - } - - response' <- newCallback $ \r -> do - breakOrFulfill response r - case r of - Left e -> writeTVar rp $ ReadyPipeline (Left e) - Right v -> - writeTVar rp $ ReadyPipeline (Right v) - - M.insert - NewQA - { onReturn = SnocList.singleton $ cbCallReturn paramCaps conn response' - , onFinish = SnocList.empty - } - qid - questions - (p, f) <- newPromise - f <- newCallback $ \r -> - breakOrFulfill f (Pipeline { state = rp, steps = mempty } <$ r) - sendCall conn' Call - { questionId = qid - , target = target - , params = payload - , interfaceId - , methodId - } - f - pure p - --- | Callback to run when a return comes in that corresponds to a call --- we sent. Registered in callRemote. The first argument is a list of --- export IDs to release if the return message has releaseParamCaps = true. -cbCallReturn :: [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM () -cbCallReturn - paramCaps - conn - response - Return{ answerId, union', releaseParamCaps } = do - conn'@Conn'{answers} <- getLive conn - when releaseParamCaps $ - traverse_ (releaseExport conn 1) paramCaps - case union' of - Return'exception exn -> - breakPromise response exn - Return'results Payload{ content } -> - fulfill response content - Return'canceled -> - breakPromise response $ eFailed "Canceled" - - Return'resultsSentElsewhere -> - -- This should never happen, since we always set - -- sendResultsTo = caller - abortConn conn' $ eFailed $ mconcat - [ "Received Return.resultsSentElswhere for a call " - , "with sendResultsTo = caller." - ] - - Return'takeFromOtherQuestion qid -> - -- TODO(cleanup): we should be a little stricter; the protocol - -- requires that (1) each answer is only used this way once, and - -- (2) The question was sent with sendResultsTo set to 'yourself', - -- but we don't enforce either of these requirements. - subscribeReturn "answer" conn' answers qid $ - cbCallReturn [] conn response - - Return'acceptFromThirdParty _ -> - -- Note [Level 3] - abortConn conn' $ eUnimplemented - "This vat does not support level 3." - -- Defer this until after any other callbacks run, in case disembargos - -- need to be sent due to promise resolutions that we triggered: - queueSTM conn' $ finishQuestion conn' def - { R.questionId = qaWord answerId - , R.releaseResultCaps = False - } - - -marshalMsgTarget :: MsgTarget -> R.Parsed R.MessageTarget -marshalMsgTarget = \case - ImportTgt importId -> - R.MessageTarget $ R.MessageTarget'importedCap (ieWord importId) - AnswerTgt tgt -> - R.MessageTarget $ R.MessageTarget'promisedAnswer $ marshalPromisedAnswer tgt - -marshalPromisedAnswer :: PromisedAnswer -> R.Parsed R.PromisedAnswer -marshalPromisedAnswer PromisedAnswer{ answerId, transform } = - R.PromisedAnswer - { R.questionId = qaWord answerId - , R.transform = - V.fromList $ map - (R.PromisedAnswer'Op . R.PromisedAnswer'Op'getPointerField) - (toList transform) - } - -unmarshalPromisedAnswer :: MonadThrow m => R.Parsed R.PromisedAnswer -> m PromisedAnswer -unmarshalPromisedAnswer R.PromisedAnswer { questionId, transform } = do - idxes <- unmarshalOps (toList transform) - pure PromisedAnswer - { answerId = QAId questionId - , transform = SnocList.fromList idxes - } - -unmarshalOps :: MonadThrow m => [R.Parsed R.PromisedAnswer'Op] -> m [Word16] -unmarshalOps [] = pure [] -unmarshalOps (R.PromisedAnswer'Op { union' = R.PromisedAnswer'Op'noop }:ops) = - unmarshalOps ops -unmarshalOps (R.PromisedAnswer'Op { union' = R.PromisedAnswer'Op'getPointerField i }:ops) = - (i:) <$> unmarshalOps ops -unmarshalOps (R.PromisedAnswer'Op { union' = R.PromisedAnswer'Op'unknown' tag }:_) = - throwM $ eFailed $ "Unknown PromisedAnswer.Op: " <> fromString (show tag) - - --- | A null client. This is the only client value that can be represented --- statically. Throws exceptions in response to all method calls. -nullClient :: Client -nullClient = Client Nothing - --- | Create a new client based on a promise. The fulfiller can be used to --- supply the final client. -newPromiseClient :: (MonadSTM m, IsClient c) => m (c, Fulfiller c) -newPromiseClient = liftSTM $ do - callBuffer <- newTQueue - let tmpDest = LocalDest LocalBuffer { callBuffer } - pState <- newTVar Pending { tmpDest } - exportMap <- ExportMap <$> M.new - f <- newCallback $ \case - Left e -> resolveClientExn tmpDest (writeTVar pState) e - Right v -> resolveClientClient tmpDest (writeTVar pState) (toClient v) - let p = Client $ Just $ PromiseClient - { pState - , exportMap - , origTarget = tmpDest - } - pure (fromClient p, f) - - --- | Attempt to unwrap a client, to get at an underlying value from the --- server. Returns 'Nothing' on failure. --- --- This shells out to the underlying server's implementation of --- 'Server.unwrap'. It will fail with 'Nothing' if any of these are true: --- --- * The client is a promise. --- * The client points to an object in a remote vat. --- * The underlying Server's 'unwrap' method returns 'Nothing' for type 'a'. -unwrapServer :: (IsClient c, Typeable a) => c -> Maybe a -unwrapServer c = case toClient c of - Client (Just LocalClient { unwrapper }) -> unwrapper - _ -> Nothing - - --- | Wait for the client to be fully resolved, and then return a client --- pointing directly to the destination. --- --- If the argument is null, a local client, or a (permanent) remote client, --- this returns the argument immediately. If the argument is a promise client, --- then this waits for the promise to resolve and returns the result of --- the resolution. If the promise resolves to *another* promise, then this waits --- for that promise to also resolve. --- --- If the promise is rejected, then this throws the corresponding exception. -waitClient :: (IsClient c, MonadSTM m) => c -> m c -waitClient client = liftSTM $ case toClient client of - Client Nothing -> pure client - Client (Just LocalClient{}) -> pure client - Client (Just ImportClient{}) -> pure client - Client (Just PromiseClient{pState}) -> do - state <- readTVar pState - case state of - Ready{target} -> fromClient <$> waitClient target - Error e -> throwSTM e - Pending{} -> retry - Embargo{} -> retry - - --- | Spawn a local server with its lifetime bound to the supervisor, --- and return a client for it. When the client is garbage collected, --- the server will be stopped (if it is still running). -export :: MonadSTM m => Supervisor -> Server.ServerOps IO -> m Client -export sup ops = liftSTM $ do - q <- TCloseQ.new - qCall <- Rc.new (TCloseQ.write q) (TCloseQ.close q) - exportMap <- ExportMap <$> M.new - finalizerKey <- Fin.newCell () - let client' = LocalClient - { qCall - , exportMap - , finalizerKey - , unwrapper = Server.handleCast ops - } - superviseSTM sup ((do - Fin.addFinalizer finalizerKey $ atomically $ Rc.release qCall - Server.runServer q ops) - `finally` Server.handleStop ops) - pure $ Client (Just client') - -clientMethodHandler :: Word64 -> Word16 -> Client -> Server.MethodHandler IO p r -clientMethodHandler interfaceId methodId client = - Server.fromUntypedHandler $ Server.untypedHandler $ - \arguments response -> atomically $ void $ call Server.CallInfo{..} client - --- | See Note [callbacks] -callbacksLoop :: Conn' -> IO () -callbacksLoop Conn'{pendingCallbacks} = - loop `finally` cleanup - where - loop = forever $ doCallbacks $ - atomically $ flushTQueue pendingCallbacks >>= \case - -- We need to make sure to block if there weren't any jobs, since - -- otherwise we'll busy loop, pegging the CPU. - [] -> retry - cbs -> pure cbs - cleanup = - -- Make sure any pending callbacks get run. This is important, since - -- some of these do things like raise disconnected exceptions. - doCallbacks $ atomically $ flushTQueue pendingCallbacks - doCallbacks getCbs = - -- We need to be careful not to lose any callbacks in the event - -- of an exception (even an async one): - bracket - getCbs - (foldr finally (pure ())) - (\_ -> pure ()) - --- | 'sendLoop' shunts messages from the send queue into the transport. -sendLoop :: Transport -> Conn' -> IO () -sendLoop transport Conn'{sendQ} = - forever $ do - (msg, f) <- atomically $ readTChan sendQ - sendMsg transport msg - atomically $ fulfill f () - --- | 'recvLoop' processes incoming messages. -recvLoop :: Transport -> Conn -> IO () --- The logic here mostly routes messages to other parts of the code that know --- more about the objects in question; See Note [Organization] for more info. -recvLoop transport conn@Conn{debugMode} = forever $ do - capnpMsg <- recvMsg transport - atomically $ do - flip catchSTM (throwSTM . makeAbortExn debugMode) $ do - evalLimitT defaultLimit $ do - rpcMsg <- msgToRaw capnpMsg - which <- structWhich rpcMsg - case which of - R.RW_Message'abort exn -> - parse exn >>= lift . handleAbortMsg conn - R.RW_Message'unimplemented oldMsg -> - parse oldMsg >>= lift . handleUnimplementedMsg conn - R.RW_Message'bootstrap bs -> - parse bs >>= lift . handleBootstrapMsg conn - R.RW_Message'call call -> do - handleCallMsg conn call - R.RW_Message'return ret -> do - ret' <- acceptReturn conn ret - lift $ handleReturnMsg conn ret' - R.RW_Message'finish finish -> - parse finish >>= lift . handleFinishMsg conn - R.RW_Message'resolve res -> - parse res >>= lift . handleResolveMsg conn - R.RW_Message'release release -> - parse release >>= lift . handleReleaseMsg conn - R.RW_Message'disembargo disembargo -> - parse disembargo >>= lift . handleDisembargoMsg conn - _ -> do - msg <- parse rpcMsg - lift $ do - (_, onSent) <- newPromise - conn' <- getLive conn - sendPureMsg conn' (R.Message'unimplemented msg) onSent - --- Each function handle*Msg handles a message of a particular type; --- 'recvLoop' dispatches to these. - -handleAbortMsg :: Conn -> R.Parsed R.Exception -> STM () -handleAbortMsg _ exn = - throwSTM (ReceivedAbort exn) - -handleUnimplementedMsg :: Conn -> R.Parsed R.Message -> STM () -handleUnimplementedMsg conn (R.Message msg) = getLive conn >>= \conn' -> case msg of - R.Message'unimplemented _ -> - -- If the client itself doesn't handle unimplemented messages, that's - -- weird, but ultimately their problem. - pure () - R.Message'abort _ -> - abortConn conn' $ eFailed $ - "Your vat sent an 'unimplemented' message for an abort message " <> - "that its remote peer never sent. This is likely a bug in your " <> - "capnproto library." - _ -> - abortConn conn' $ - eFailed "Received unimplemented response for required message." - -handleBootstrapMsg :: Conn -> R.Parsed R.Bootstrap -> STM () -handleBootstrapMsg conn R.Bootstrap{ questionId } = getLive conn >>= \conn' -> do - ret <- case bootstrap conn' of - Nothing -> - pure Return - { answerId = QAId questionId - , releaseParamCaps = True -- Not really meaningful for bootstrap, but... - , union' = - Return'exception $ - eFailed "No bootstrap interface for this connection." - } - Just client -> do - capDesc <- emitCap conn client - content <- fmap Just $ createPure defaultLimit $ do - msg <- Message.newMessage Nothing - UntypedRaw.PtrCap <$> UntypedRaw.appendCap msg client - pure Return - { answerId = QAId questionId - , releaseParamCaps = True -- Not really meaningful for bootstrap, but... - , union' = - Return'results Payload - { content - , capTable = V.singleton - (def { R.union' = capDesc } :: R.Parsed R.CapDescriptor) - } - } - M.focus - (Focus.alterM $ insertBootstrap conn' ret) - (QAId questionId) - (answers conn') - sendReturn conn' ret - where - insertBootstrap _ ret Nothing = - pure $ Just HaveReturn - { returnMsg = ret - , onFinish = SnocList.fromList - [ \R.Finish{releaseResultCaps} -> - case ret of - Return - { union' = Return'results Payload - { capTable = (V.toList -> [ R.CapDescriptor { union' = R.CapDescriptor'receiverHosted (IEId -> eid) } ]) - } - } -> - when releaseResultCaps $ - releaseExport conn 1 eid - _ -> - pure () - ] - - } - insertBootstrap conn' _ (Just _) = - abortConn conn' $ eFailed "Duplicate question ID" - -handleCallMsg :: Conn -> Raw R.Call 'Const -> LimitT STM () -handleCallMsg conn callMsg = do - conn'@Conn'{exports, answers, availableCallWords} <- lift $ getLive conn - let capnpMsg = UntypedRaw.message @(Raw R.Call) callMsg - - -- Apply backpressure, by limiting the memory usage of outstanding call - -- messages. - msgWords <- Message.totalNumWords capnpMsg - lift $ do - available <- readTVar availableCallWords - when (msgWords > available) - retry - writeTVar availableCallWords $! available - msgWords - - questionId <- parseField #questionId callMsg - R.MessageTarget target <- parseField #target callMsg - interfaceId <- parseField #interfaceId callMsg - methodId <- parseField #methodId callMsg - payload <- readField #params callMsg - - Payload{content = callParams, capTable} <- acceptPayload conn payload - - lift $ do - -- First, add an entry in our answers table: - insertNewAbort - "answer" - conn' - (QAId questionId) - NewQA - { onReturn = SnocList.fromList - [ \_ -> - modifyTVar' availableCallWords (msgWords +) - ] - , onFinish = SnocList.fromList - [ \R.Finish{releaseResultCaps} -> - when releaseResultCaps $ - for_ capTable $ \R.CapDescriptor{union'} -> case union' of - R.CapDescriptor'receiverHosted (IEId -> importId) -> - releaseExport conn 1 importId - _ -> - pure () - ] - } - answers - - -- Set up a callback for when the call is finished, to - -- send the return message: - fulfiller <- newCallback $ \case - Left e -> - returnAnswer conn' Return - { answerId = QAId questionId - , releaseParamCaps = False - , union' = Return'exception e - } - Right content -> do - capTable <- genSendableCapTableRaw conn content - returnAnswer conn' Return - { answerId = QAId questionId - , releaseParamCaps = False - , union' = Return'results Payload - { content = content - , capTable = capTable - } - } - -- Package up the info for the call: - let callInfo = Server.CallInfo - { interfaceId - , methodId - , arguments = callParams - , response = fulfiller - } - -- Finally, figure out where to send it: - case target of - R.MessageTarget'importedCap exportId -> - lookupAbort "export" conn' exports (IEId exportId) $ - \EntryE{client} -> void $ call callInfo $ Client $ Just client - R.MessageTarget'promisedAnswer R.PromisedAnswer { questionId = targetQid, transform } -> - let onReturn ret@Return{union'} = - case union' of - Return'exception _ -> - returnAnswer conn' ret { answerId = QAId questionId } - Return'canceled -> - returnAnswer conn' ret { answerId = QAId questionId } - Return'results Payload{content} -> - void $ transformClient transform content conn' >>= call callInfo - Return'resultsSentElsewhere -> - -- our implementation should never actually do this, but - -- this way we don't have to change this if/when we - -- support the feature: - abortConn conn' $ eFailed $ - "Tried to call a method on a promised answer that " <> - "returned resultsSentElsewhere" - Return'takeFromOtherQuestion otherQid -> - subscribeReturn "answer" conn' answers otherQid onReturn - Return'acceptFromThirdParty _ -> - -- Note [Level 3] - error "BUG: our implementation unexpectedly used a level 3 feature" - in - subscribeReturn "answer" conn' answers (QAId targetQid) onReturn - R.MessageTarget'unknown' ordinal -> - abortConn conn' $ eUnimplemented $ - "Unknown MessageTarget ordinal #" <> fromString (show ordinal) - -ptrPathClient :: MonadThrow m => [Word16] -> RawMPtr -> m Client -ptrPathClient is ptr = - evalLimitT defaultLimit $ followPtrs is ptr >>= ptrClient - -transformClient :: V.Vector (R.Parsed R.PromisedAnswer'Op) -> RawMPtr -> Conn' -> STM Client -transformClient transform ptr conn = - (unmarshalOps (V.toList transform) >>= flip ptrPathClient ptr) - `catchSTM` abortConn conn - -ptrClient :: UntypedRaw.ReadCtx m 'Const => RawMPtr -> m Client -ptrClient Nothing = pure nullClient -ptrClient (Just (UntypedRaw.PtrCap cap)) = UntypedRaw.getClient cap -ptrClient (Just _) = throwM $ eFailed "Tried to call method on non-capability." - --- | Follow a series of pointer indicies, returning the final value, or 'Left' --- with an error if any of the pointers in the chain (except the last one) is --- a non-null non struct. -followPtrs :: UntypedRaw.ReadCtx m 'Const => [Word16] -> RawMPtr -> m RawMPtr -followPtrs [] ptr = - pure ptr -followPtrs (_:_) Nothing = - pure Nothing -followPtrs (i:is) (Just (UntypedRaw.PtrStruct struct)) = - UntypedRaw.getPtr (fromIntegral i) struct >>= followPtrs is -followPtrs (_:_) (Just _) = - throwM $ eFailed "Tried to access pointer field of non-struct." - -sendRawMsg :: Conn' -> Message 'Const -> Fulfiller () -> STM () -sendRawMsg conn' msg onSent = writeTChan (sendQ conn') (msg, onSent) - -sendCall :: Conn' -> Call -> Fulfiller () -> STM () -sendCall - conn' - Call{questionId, target, interfaceId, methodId, params=Payload{content, capTable}} - onSent = do - msg <- createPure defaultLimit $ do - mcontent <- traverse thaw content - msg <- case mcontent of - Just v -> pure $ UntypedRaw.message @UntypedRaw.Ptr v - Nothing -> Message.newMessage Nothing - payload <- new @R.Payload () msg - payload & setField #content (Raw mcontent) - payload & encodeField #capTable capTable - call <- new @R.Call () msg - setField #params payload call - call & encodeField #questionId (qaWord questionId) - call & encodeField #interfaceId interfaceId - call & encodeField #methodId methodId - call & encodeField #target (marshalMsgTarget target) - rpcMsg <- newRoot @R.Message () msg - setVariant #call rpcMsg call - pure msg - sendRawMsg conn' msg onSent - -sendReturn :: Conn' -> Return -> STM () -sendReturn conn' Return{answerId, releaseParamCaps, union'} = do - (_, onSent) <- newPromise - case union' of - Return'results Payload{content, capTable} -> do - msg <- createPure defaultLimit $ do - mcontent <- traverse thaw content - msg <- case mcontent of - Just v -> pure $ UntypedRaw.message @UntypedRaw.Ptr v - Nothing -> Message.newMessage Nothing - payload <- new @R.Payload () msg - payload & setField #content (Raw mcontent) - payload & encodeField #capTable capTable - ret <- new @R.Return () msg - setVariant #results ret payload - ret & encodeField #answerId (qaWord answerId) - ret & encodeField #releaseParamCaps releaseParamCaps - rpcMsg <- newRoot @R.Message () msg - setVariant #return rpcMsg ret - pure msg - sendRawMsg conn' msg onSent - Return'exception exn -> - sendPureMsg conn' (R.Message'return R.Return - { answerId = qaWord answerId - , releaseParamCaps - , union' = R.Return'exception exn - }) - onSent - Return'canceled -> - sendPureMsg conn' (R.Message'return R.Return - { answerId = qaWord answerId - , releaseParamCaps - , union' = R.Return'canceled - }) - onSent - Return'resultsSentElsewhere -> - sendPureMsg conn' (R.Message'return R.Return - { answerId = qaWord answerId - , releaseParamCaps - , union' = R.Return'resultsSentElsewhere - }) - onSent - Return'takeFromOtherQuestion (QAId qid) -> - sendPureMsg conn' (R.Message'return R.Return - { answerId = qaWord answerId - , releaseParamCaps - , union' = R.Return'takeFromOtherQuestion qid - }) - onSent - Return'acceptFromThirdParty ptr -> do - msg <- createPure defaultLimit $ do - mptr <- traverse thaw ptr - msg <- case mptr of - Just v -> pure $ UntypedRaw.message @UntypedRaw.Ptr v - Nothing -> Message.newMessage Nothing - ret <- new @R.Return () msg - ret & encodeField #answerId (qaWord answerId) - ret & encodeField #releaseParamCaps releaseParamCaps - setVariant #acceptFromThirdParty ret (Raw @(Maybe B.AnyPointer) mptr) - rpcMsg <- newRoot @R.Message () msg - setVariant #return rpcMsg ret - pure msg - sendRawMsg conn' msg onSent - -acceptReturn :: Conn -> Raw R.Return 'Const -> LimitT STM Return -acceptReturn conn ret = do - let answerId = QAId (getField #answerId ret) - releaseParamCaps = getField #releaseParamCaps ret - which <- structWhich ret - union' <- case which of - R.RW_Return'results payload -> - Return'results <$> acceptPayload conn payload - R.RW_Return'exception exn -> - Return'exception <$> parse exn - R.RW_Return'canceled _ -> - pure Return'canceled - R.RW_Return'resultsSentElsewhere _ -> - pure Return'resultsSentElsewhere - R.RW_Return'takeFromOtherQuestion id -> - Return'takeFromOtherQuestion . QAId <$> parse id - R.RW_Return'acceptFromThirdParty (Raw ptr) -> - pure $ Return'acceptFromThirdParty ptr - R.RW_Return'unknown' ordinal -> - lift $ throwSTM $ eFailed $ "Unknown return variant #" <> fromString (show ordinal) - pure Return { answerId, releaseParamCaps, union' } - -handleReturnMsg :: Conn -> Return -> STM () -handleReturnMsg conn ret = getLive conn >>= \conn'@Conn'{questions} -> - updateQAReturn conn' questions "question" ret - -handleFinishMsg :: Conn -> R.Parsed R.Finish -> STM () -handleFinishMsg conn finish = getLive conn >>= \conn'@Conn'{answers} -> - updateQAFinish conn' answers "answer" finish - -handleResolveMsg :: Conn -> R.Parsed R.Resolve -> STM () -handleResolveMsg conn R.Resolve{promiseId, union'} = - getLive conn >>= \conn'@Conn'{imports} -> do - entry <- M.lookup (IEId promiseId) imports - case entry of - Nothing -> - -- This can happen if we dropped the promise, but the release - -- message is still in flight when the resolve message is sent. - case union' of - R.Resolve'cap R.CapDescriptor{union' = R.CapDescriptor'receiverHosted importId} -> do - (_, onSent) <- newPromise - -- Send a release message for the resolved cap, since - -- we're not going to use it: - sendPureMsg conn' (R.Message'release def - { R.id = importId - , R.referenceCount = 1 - }) - onSent - -- Note [Level 3]: do we need to do something with - -- thirdPartyHosted here? - _ -> pure () - Just EntryI{ promiseState = Nothing } -> - -- This wasn't a promise! The remote vat has done something wrong; - -- abort the connection. - abortConn conn' $ eFailed $ mconcat - [ "Received a resolve message for export id #", fromString (show promiseId) - , ", but that capability is not a promise!" - ] - Just EntryI { promiseState = Just (tvar, tmpDest) } -> - case union' of - R.Resolve'cap R.CapDescriptor{union' = cap} -> do - client <- acceptCap conn cap - resolveClientClient tmpDest (writeTVar tvar) client - R.Resolve'exception exn -> - resolveClientExn tmpDest (writeTVar tvar) exn - R.Resolve'unknown' tag -> - abortConn conn' $ eUnimplemented $ mconcat - [ "Resolve variant #" - , fromString (show tag) - , " not understood" - ] - -handleReleaseMsg :: Conn -> R.Parsed R.Release -> STM () -handleReleaseMsg - conn - R.Release - { id=(IEId -> eid) - , referenceCount=refCountDiff - } = - releaseExport conn refCountDiff eid - -releaseExport :: Conn -> Word32 -> IEId -> STM () -releaseExport conn refCountDiff eid = - getLive conn >>= \conn'@Conn'{exports} -> - lookupAbort "export" conn' exports eid $ - \EntryE{client, refCount=oldRefCount} -> - case compare oldRefCount refCountDiff of - LT -> - abortConn conn' $ eFailed $ - "Received release for export with referenceCount " <> - "greater than our recorded total ref count." - EQ -> - dropConnExport conn client - GT -> - M.insert - EntryE - { client - , refCount = oldRefCount - refCountDiff - } - eid - exports - -handleDisembargoMsg :: Conn -> R.Parsed R.Disembargo -> STM () -handleDisembargoMsg conn d = getLive conn >>= go d - where - go - R.Disembargo - { context = R.Disembargo'context' - (R.Disembargo'context'receiverLoopback (EmbargoId -> eid)) - } - conn'@Conn'{embargos} - = do - result <- M.lookup eid embargos - case result of - Nothing -> - abortConn conn' $ eFailed $ - "No such embargo: " <> fromString (show $ embargoWord eid) - Just fulfiller -> do - queueSTM conn' (fulfill fulfiller ()) - M.delete eid embargos - freeEmbargo conn' eid - go - R.Disembargo - { target = R.MessageTarget target - , context = R.Disembargo'context' (R.Disembargo'context'senderLoopback embargoId) - } - conn'@Conn'{exports, answers} - = case target of - R.MessageTarget'importedCap exportId -> - lookupAbort "export" conn' exports (IEId exportId) $ \EntryE{ client } -> - disembargoPromise client - R.MessageTarget'promisedAnswer R.PromisedAnswer{ questionId, transform } -> - lookupAbort "answer" conn' answers (QAId questionId) $ \case - HaveReturn { returnMsg=Return{union'=Return'results Payload{content} } } -> - transformClient transform content conn' >>= \case - Client (Just client') -> disembargoClient client' - Client Nothing -> abortDisembargo "targets a null capability" - _ -> - abortDisembargo $ - "does not target an answer which has resolved to a value hosted by" - <> " the sender." - R.MessageTarget'unknown' ordinal -> - abortConn conn' $ eUnimplemented $ - "Unknown MessageTarget ordinal #" <> fromString (show ordinal) - where - disembargoPromise PromiseClient{ pState } = readTVar pState >>= \case - Ready (Client (Just client)) -> - disembargoClient client - Ready (Client Nothing) -> - abortDisembargo "targets a promise which resolved to null." - _ -> - abortDisembargo "targets a promise which has not resolved." - disembargoPromise _ = - abortDisembargo "targets something that is not a promise." - - disembargoClient (ImportClient cell) = do - client <- Fin.readCell cell - case client of - ImportRef {conn=targetConn, importId} - | conn == targetConn -> do - (_, onSent) <- newPromise - sendPureMsg conn' (R.Message'disembargo R.Disembargo - { context = R.Disembargo'context' $ - R.Disembargo'context'receiverLoopback embargoId - , target = R.MessageTarget $ - R.MessageTarget'importedCap (ieWord importId) - }) - onSent - _ -> - abortDisembargoClient - disembargoClient _ = abortDisembargoClient - - abortDisembargoClient = - abortDisembargo $ - "targets a promise which has not resolved to a capability" - <> " hosted by the sender." - - abortDisembargo info = - abortConn conn' $ eFailed $ mconcat - [ "Disembargo #" - , fromString (show embargoId) - , " with context = senderLoopback " - , info - ] --- Note [Level 3] - go d conn' = do - (_, onSent) <- newPromise - sendPureMsg conn' - (R.Message'unimplemented $ R.Message $ R.Message'disembargo d) - onSent - -lookupAbort - :: (Eq k, Hashable k, Show k) - => Text -> Conn' -> M.Map k v -> k -> (v -> STM a) -> STM a -lookupAbort keyTypeName conn m key f = do - result <- M.lookup key m - case result of - Just val -> - f val - Nothing -> - abortConn conn $ eFailed $ mconcat - [ "No such " - , keyTypeName - , ": " - , fromString (show key) - ] - --- | @'insertNewAbort' keyTypeName conn key value stmMap@ inserts a key into a --- map, aborting the connection if it is already present. @keyTypeName@ will be --- used in the error message sent to the remote vat. -insertNewAbort :: (Eq k, Hashable k) => Text -> Conn' -> k -> v -> M.Map k v -> STM () -insertNewAbort keyTypeName conn key value = - M.focus - (Focus.alterM $ \case - Just _ -> - abortConn conn $ eFailed $ - "duplicate entry in " <> keyTypeName <> " table." - Nothing -> - pure (Just value) - ) - key - --- | Generate a cap table describing the capabilities reachable from the given --- pointer. The capability table will be correct for any message where all of --- the capabilities are within the subtree under the pointer. -genSendableCapTableRaw - :: Conn - -> Maybe (UntypedRaw.Ptr 'Const) - -> STM (V.Vector (R.Parsed R.CapDescriptor)) -genSendableCapTableRaw _ Nothing = pure V.empty -genSendableCapTableRaw conn (Just ptr) = - traverse - (\c -> do - union' <- emitCap conn c - pure (def :: R.Parsed R.CapDescriptor) { R.union' = union' } - ) - (Message.getCapTable (UntypedRaw.message @UntypedRaw.Ptr ptr)) - --- | Convert the pointer into a Payload, including a capability table for --- the clients in the pointer's cap table. -makeOutgoingPayload :: Conn -> RawMPtr -> STM Payload -makeOutgoingPayload conn content = do - capTable <- genSendableCapTableRaw conn content - pure Payload { content, capTable } - -sendPureMsg :: Conn' -> R.Parsed (Which R.Message) -> Fulfiller () -> STM () -sendPureMsg Conn'{sendQ} msg onSent = do - msg <- createPure maxBound (parsedToMsg (R.Message msg)) - writeTChan sendQ (msg, onSent) - --- | Send a finish message, updating connection state and triggering --- callbacks as necessary. -finishQuestion :: Conn' -> R.Parsed R.Finish -> STM () -finishQuestion conn@Conn'{questions} finish@R.Finish{questionId} = do - -- arrange for the question ID to be returned to the pool once - -- the return has also been received: - subscribeReturn "question" conn questions (QAId questionId) $ \_ -> - freeQuestion conn (QAId questionId) - (_, onSent) <- newPromise - sendPureMsg conn (R.Message'finish finish) onSent - updateQAFinish conn questions "question" finish - --- | Send a return message, update the corresponding entry in our --- answers table, and queue any registered callbacks. Calls 'error' --- if the answerId is not in the table, or if we've already sent a --- return for this answer. -returnAnswer :: Conn' -> Return -> STM () -returnAnswer conn@Conn'{answers} ret = do - sendReturn conn ret - updateQAReturn conn answers "answer" ret - --- TODO(cleanup): updateQAReturn/Finish have a lot in common; can we refactor? - -updateQAReturn :: Conn' -> M.Map QAId EntryQA -> Text -> Return -> STM () -updateQAReturn conn table tableName ret@Return{answerId} = - lookupAbort tableName conn table answerId $ \case - NewQA{onFinish, onReturn} -> do - M.insert - HaveReturn - { returnMsg = ret - , onFinish - } - answerId - table - traverse_ ($ ret) onReturn - HaveFinish{onReturn} -> do - M.delete answerId table - traverse_ ($ ret) onReturn - HaveReturn{} -> - abortConn conn $ eFailed $ - "Duplicate return message for " <> tableName <> " #" - <> fromString (show answerId) - -updateQAFinish :: Conn' -> M.Map QAId EntryQA -> Text -> R.Parsed R.Finish -> STM () -updateQAFinish conn table tableName finish@R.Finish{questionId} = - lookupAbort tableName conn table (QAId questionId) $ \case - NewQA{onFinish, onReturn} -> do - traverse_ ($ finish) onFinish - M.insert - HaveFinish - { finishMsg = finish - , onReturn - } - (QAId questionId) - table - HaveReturn{onFinish} -> do - traverse_ ($ finish) onFinish - M.delete (QAId questionId) table - HaveFinish{} -> - abortConn conn $ eFailed $ - "Duplicate finish message for " <> tableName <> " #" - <> fromString (show questionId) - --- | Update an entry in the questions or answers table to queue the given --- callback when the return message for that answer comes in. If the return --- has already arrived, the callback is queued immediately. --- --- If the entry already has other callbacks registered, this callback is --- run *after* the others (see Note [callbacks]). Note that this is an --- important property, as it is necessary to preserve E-order if the --- callbacks are successive method calls on the returned object. -subscribeReturn :: Text -> Conn' -> M.Map QAId EntryQA -> QAId -> (Return -> STM ()) -> STM () -subscribeReturn tableName conn table qaId onRet = - lookupAbort tableName conn table qaId $ \qa -> do - new <- go qa - M.insert new qaId table - where - go = \case - NewQA{onFinish, onReturn} -> - pure NewQA - { onFinish - , onReturn = SnocList.snoc onReturn onRet - } - - HaveFinish{finishMsg, onReturn} -> - pure HaveFinish - { finishMsg - , onReturn = SnocList.snoc onReturn onRet - } - - val@HaveReturn{returnMsg} -> do - onRet returnMsg - pure val - --- | Abort the connection, sending an abort message. This is only safe to call --- from within either the thread running the receieve loop or the callback loop. -abortConn :: Conn' -> R.Parsed R.Exception -> STM a -abortConn _ e = throwSTM (SentAbort e) - --- | Gets the live connection state, or throws disconnected if it is not live. -getLive :: Conn -> STM Conn' -getLive Conn{liveState} = readTVar liveState >>= \case - Live conn' -> pure conn' - Dead -> throwSTM eDisconnected - --- | Performs an action with the live connection state. Does nothing if the --- connection is dead. -whenLive :: Conn -> (Conn' -> STM ()) -> STM () -whenLive Conn{liveState} f = readTVar liveState >>= \case - Live conn' -> f conn' - Dead -> pure () - --- | Request the remote vat's bootstrap interface. -requestBootstrap :: Conn -> STM Client -requestBootstrap conn@Conn{liveState} = readTVar liveState >>= \case - Dead -> - pure nullClient - Live conn'@Conn'{questions} -> do - qid <- newQuestion conn' - let tmpDest = RemoteDest AnswerDest - { conn - , answer = PromisedAnswer - { answerId = qid - , transform = SnocList.empty - } - } - pState <- newTVar Pending { tmpDest } - - -- Arguably, we should wait for this promise, since it's analagous - -- to a call in terms of operation, but we only send one of these - -- per connection, so whatever. - (_, onSent) <- newPromise - sendPureMsg conn' - (R.Message'bootstrap (def { R.questionId = qaWord qid } :: R.Parsed R.Bootstrap)) - onSent - - M.insert - NewQA - { onReturn = SnocList.fromList - [ resolveClientReturn tmpDest (writeTVar pState) conn' [] - , \_ -> finishQuestion conn' R.Finish - { questionId = qaWord qid - , releaseResultCaps = False - } - ] - , onFinish = SnocList.empty - } - qid - questions - exportMap <- ExportMap <$> M.new - pure $ Client $ Just PromiseClient - { pState - , exportMap - , origTarget = tmpDest - } - --- Note [resolveClient] --- ==================== --- --- There are several functions resolveClient*, each of which resolves a --- 'PromiseClient', which will previously have been in the 'Pending' state. --- Each function accepts three parameters: the 'TmpDest' that the --- pending promise had been targeting, a function for setting the new state, --- and a thing to resolve the promise to. The type of the latter is specific --- to each function. - --- | Resolve a promised client to an exception. See Note [resolveClient] -resolveClientExn :: TmpDest -> (PromiseState -> STM ()) -> R.Parsed R.Exception -> STM () -resolveClientExn tmpDest resolve exn = do - case tmpDest of - LocalDest LocalBuffer { callBuffer } -> do - calls <- flushTQueue callBuffer - traverse_ - (\Server.CallInfo{response} -> - breakPromise response exn) - calls - RemoteDest AnswerDest {} -> - pure () - RemoteDest (ImportDest _) -> - pure () - resolve $ Error exn - --- Resolve a promised client to a pointer. If it is a non-null non-capability --- pointer, it resolves to an exception. See Note [resolveClient] -resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM () -resolveClientPtr tmpDest resolve ptr = case ptr of - Nothing -> - resolveClientClient tmpDest resolve nullClient - Just (UntypedRaw.PtrCap c) -> do - c' <- evalLimitT defaultLimit $ UntypedRaw.getClient c - resolveClientClient tmpDest resolve c' - Just _ -> - resolveClientExn tmpDest resolve $ - eFailed "Promise resolved to non-capability pointer" - --- | Resolve a promised client to another client. See Note [resolveClient] -resolveClientClient :: TmpDest -> (PromiseState -> STM ()) -> Client -> STM () -resolveClientClient tmpDest resolve (Client client) = - case (client, tmpDest) of - -- Remote resolved to local; we need to embargo: - ( Just LocalClient{}, RemoteDest dest ) -> - disembargoAndResolve dest - ( Just PromiseClient { origTarget=LocalDest _ }, RemoteDest dest) -> - disembargoAndResolve dest - - ( Nothing, RemoteDest _ ) -> - -- If it resolves to a null client, then we can't send a disembargo. - -- Note that this may result in futrther calls throwing exceptions - -- /before/ the outstanding calls, which is a bit weird. But all - -- calls will throw at some point, so it's probably fine. - resolveNow - - -- Local promises never need embargos; we can just forward: - ( _, LocalDest LocalBuffer { callBuffer } ) -> - flushAndResolve callBuffer - - -- These cases are slightly subtle; despite resolving to a - -- client that points at a "remote" target, if it points into a - -- _different_ connection, we must be proxying it, so we treat - -- it as local and do a disembargo like above. We may need to - -- change this when we implement level 3, since third-party - -- handoff is a possibility; see Note [Level 3]. - -- - -- If it's pointing into the same connection, we don't need to - -- do a disembargo. - ( Just PromiseClient { origTarget=RemoteDest newDest }, RemoteDest oldDest ) -> do - newConn <- destConn newDest - oldConn <- destConn oldDest - if newConn == oldConn - then resolveNow - else disembargoAndResolve oldDest - ( Just (ImportClient cell), RemoteDest oldDest ) -> do - ImportRef { conn=newConn } <- Fin.readCell cell - oldConn <- destConn oldDest - if newConn == oldConn - then resolveNow - else disembargoAndResolve oldDest - where - destConn AnswerDest { conn } = pure conn - destConn (ImportDest cell) = do - ImportRef { conn } <- Fin.readCell cell - pure conn - destTarget AnswerDest { answer } = pure $ AnswerTgt answer - destTarget (ImportDest cell) = do - ImportRef { importId } <- Fin.readCell cell - pure $ ImportTgt importId - - resolveNow = do - resolve $ Ready (Client client) - - -- Flush the call buffer into the client's queue, and then pass the client - -- to resolve. - flushAndResolve callBuffer = do - flushTQueue callBuffer >>= traverse_ (`call` Client client) - resolve $ Ready (Client client) - flushAndRaise callBuffer e = - flushTQueue callBuffer >>= - traverse_ (\Server.CallInfo{response} -> breakPromise response e) - disembargoAndResolve dest = do - Conn{liveState} <- destConn dest - readTVar liveState >>= \case - Live conn' -> do - callBuffer <- newTQueue - target <- destTarget dest - disembargo conn' target $ \case - Right () -> - flushAndResolve callBuffer - Left e -> - flushAndRaise callBuffer e - resolve $ Embargo { callBuffer } - Dead -> - resolveClientExn tmpDest resolve eDisconnected - --- | Send a (senderLoopback) disembargo to the given message target, and --- register the transaction to run when the corresponding receiverLoopback --- message is received. --- --- The callback may be handed a 'Left' with a disconnected exception if --- the connection is dropped before the disembargo is echoed. -disembargo :: Conn' -> MsgTarget -> (Either (R.Parsed R.Exception) () -> STM ()) -> STM () -disembargo conn@Conn'{embargos} tgt onEcho = do - callback <- newCallback onEcho - eid <- newEmbargo conn - M.insert callback eid embargos - (_, onSent) <- newPromise - sendPureMsg conn (R.Message'disembargo R.Disembargo - { target = marshalMsgTarget tgt - , context = R.Disembargo'context' $ - R.Disembargo'context'senderLoopback (embargoWord eid) - }) - onSent - --- | Resolve a promised client to the result of a return. See Note [resolveClient] --- --- The [Word16] is a list of pointer indexes to follow from the result. -resolveClientReturn :: TmpDest -> (PromiseState -> STM ()) -> Conn' -> [Word16] -> Return -> STM () -resolveClientReturn tmpDest resolve conn@Conn'{answers} transform Return { union' } = case union' of - -- TODO(cleanup) there is a lot of redundency betwen this and cbCallReturn; can - -- we refactor? - Return'exception exn -> - resolveClientExn tmpDest resolve exn - Return'results Payload{ content } -> do - res <- try $ evalLimitT defaultLimit $ followPtrs transform content - case res of - Right v -> - resolveClientPtr tmpDest resolve v - Left e -> - resolveClientExn tmpDest resolve e - - Return'canceled -> - resolveClientExn tmpDest resolve $ eFailed "Canceled" - - Return'resultsSentElsewhere -> - -- Should never happen; we don't set sendResultsTo to anything other than - -- caller. - abortConn conn $ eFailed $ mconcat - [ "Received Return.resultsSentElsewhere for a call " - , "with sendResultsTo = caller." - ] - - Return'takeFromOtherQuestion qid -> - subscribeReturn "answer" conn answers qid $ - resolveClientReturn tmpDest resolve conn transform - - Return'acceptFromThirdParty _ -> - -- Note [Level 3] - abortConn conn $ eUnimplemented - "This vat does not support level 3." - --- | Get the client's export ID for this connection, or allocate a new one if needed. --- If this is the first time this client has been exported on this connection, --- bump the refcount. -getConnExport :: Conn -> Client' -> STM IEId -getConnExport conn client = getLive conn >>= \conn'@Conn'{exports} -> do - ExportMap m <- clientExportMap client - val <- M.lookup conn m - case val of - Just eid -> do - addBumpExport eid client exports - pure eid - - Nothing -> do - eid <- newExport conn' - addBumpExport eid client exports - M.insert eid conn m - pure eid - --- | Remove export of the client on the connection. This entails removing it --- from the export id, removing the connection from the client's ExportMap, --- freeing the export id, and dropping the client's refcount. -dropConnExport :: Conn -> Client' -> STM () -dropConnExport conn client' = do - ExportMap eMap <- clientExportMap client' - val <- M.lookup conn eMap - case val of - Just eid -> do - M.delete conn eMap - whenLive conn $ \conn'@Conn'{exports} -> do - M.delete eid exports - freeExport conn' eid - Nothing -> - error "BUG: tried to drop an export that doesn't exist." - -clientExportMap :: Client' -> STM ExportMap -clientExportMap LocalClient{exportMap} = pure exportMap -clientExportMap PromiseClient{exportMap} = pure exportMap -clientExportMap (ImportClient cell) = do - ImportRef{proxies} <- Fin.readCell cell - pure proxies - --- | insert the client into the exports table, bumping the refcount if it is --- already there. If a different client is already in the table at the same --- id, call 'error'. -addBumpExport :: IEId -> Client' -> M.Map IEId EntryE -> STM () -addBumpExport exportId client = - M.focus (Focus.alter go) exportId - where - go Nothing = Just EntryE { client, refCount = 1 } - go (Just EntryE{ client = oldClient, refCount } ) - | client /= oldClient = - error $ - "BUG: addExportRef called with a client that is different " ++ - "from what is already in our exports table." - | otherwise = - Just EntryE { client, refCount = refCount + 1 } - --- | Generate a CapDescriptor', which we can send to the connection's remote --- vat to identify client. In the process, this may allocate export ids, update --- reference counts, and so forth. -emitCap :: Conn -> Client -> STM (R.Parsed (Which R.CapDescriptor)) -emitCap _targetConn (Client Nothing) = - pure R.CapDescriptor'none -emitCap targetConn (Client (Just client')) = case client' of - LocalClient{} -> - R.CapDescriptor'senderHosted . ieWord <$> getConnExport targetConn client' - PromiseClient{ pState } -> readTVar pState >>= \case - Pending { tmpDest = RemoteDest AnswerDest { conn, answer } } - | conn == targetConn -> - pure $ R.CapDescriptor'receiverAnswer (marshalPromisedAnswer answer) - Pending { tmpDest = RemoteDest (ImportDest cell) } -> do - ImportRef { conn, importId = IEId iid } <- Fin.readCell cell - if conn == targetConn - then pure (R.CapDescriptor'receiverHosted iid) - else newSenderPromise - _ -> - newSenderPromise - ImportClient cell -> do - ImportRef { conn=hostConn, importId } <- Fin.readCell cell - if hostConn == targetConn - then pure (R.CapDescriptor'receiverHosted (ieWord importId)) - else R.CapDescriptor'senderHosted . ieWord <$> getConnExport targetConn client' - where - newSenderPromise = R.CapDescriptor'senderPromise . ieWord <$> getConnExport targetConn client' - -acceptPayload :: Conn -> Raw R.Payload 'Const -> LimitT STM Payload -acceptPayload conn payload = do - capTable <- parseField #capTable payload - clients <- lift $ traverse (\R.CapDescriptor{union'} -> acceptCap conn union') capTable - Raw rawContent <- readField #content payload - content <- traverse (UntypedRaw.tMsg (pure . Message.withCapTable clients)) rawContent - pure Payload {content, capTable} - --- | 'acceptCap' is a dual of 'emitCap'; it derives a Client from a CapDescriptor' --- received via the connection. May update connection state as necessary. -acceptCap :: Conn -> R.Parsed (Which R.CapDescriptor) -> STM Client -acceptCap conn cap = getLive conn >>= \conn' -> go conn' cap - where - go _ R.CapDescriptor'none = pure (Client Nothing) - go conn'@Conn'{imports} (R.CapDescriptor'senderHosted (IEId -> importId)) = do - entry <- M.lookup importId imports - case entry of - Just EntryI{ promiseState=Just _ } -> - let imp = fromString (show importId) - in abortConn conn' $ eFailed $ - "received senderHosted capability #" <> imp <> - ", but the imports table says #" <> imp <> " is senderPromise." - Just ent@EntryI{ localRc, remoteRc, proxies } -> do - Rc.incr localRc - M.insert ent { localRc, remoteRc = remoteRc + 1 } importId imports - cell <- Fin.newCell ImportRef - { conn - , importId - , proxies - } - queueIO conn' $ Fin.addFinalizer cell $ atomically $ Rc.decr localRc - pure $ Client $ Just $ ImportClient cell - - Nothing -> - Client . Just . ImportClient <$> newImport importId conn Nothing - go conn'@Conn'{imports} (R.CapDescriptor'senderPromise (IEId -> importId)) = do - entry <- M.lookup importId imports - case entry of - Just EntryI { promiseState=Nothing } -> - let imp = fromString (show importId) - in abortConn conn' $ eFailed $ - "received senderPromise capability #" <> imp <> - ", but the imports table says #" <> imp <> " is senderHosted." - Just ent@EntryI { remoteRc, proxies, promiseState=Just (pState, origTarget) } -> do - M.insert ent { remoteRc = remoteRc + 1 } importId imports - pure $ Client $ Just PromiseClient - { pState - , exportMap = proxies - , origTarget - } - Nothing -> do - rec imp <- newImport importId conn (Just (pState, tmpDest)) - ImportRef{proxies} <- Fin.readCell imp - let tmpDest = RemoteDest (ImportDest imp) - pState <- newTVar Pending { tmpDest } - pure $ Client $ Just PromiseClient - { pState - , exportMap = proxies - , origTarget = tmpDest - } - go conn'@Conn'{exports} (R.CapDescriptor'receiverHosted exportId) = - lookupAbort "export" conn' exports (IEId exportId) $ - \EntryE{client} -> - pure $ Client $ Just client - go conn' (R.CapDescriptor'receiverAnswer pa) = do - pa <- unmarshalPromisedAnswer pa `catchSTM` abortConn conn' - newLocalAnswerClient conn' pa - go conn' (R.CapDescriptor'thirdPartyHosted _) = - -- Note [Level 3] - abortConn conn' $ eUnimplemented - "thirdPartyHosted unimplemented; level 3 is not supported." - go conn' (R.CapDescriptor'unknown' tag) = - abortConn conn' $ eUnimplemented $ - "Unimplemented CapDescriptor variant #" <> fromString (show tag) - --- | Create a new entry in the imports table, with the given import id and --- 'promiseState', and return a corresponding ImportRef. When the ImportRef is --- garbage collected, the refcount in the table will be decremented. -newImport :: IEId -> Conn -> Maybe (TVar PromiseState, TmpDest) -> STM (Fin.Cell ImportRef) -newImport importId conn promiseState = getLive conn >>= \conn'@Conn'{imports} -> do - localRc <- Rc.new () $ releaseImport importId conn' - proxies <- ExportMap <$> M.new - let importRef = ImportRef - { conn - , importId - , proxies - } - M.insert EntryI - { localRc - , remoteRc = 1 - , proxies - , promiseState - } - importId - imports - cell <- Fin.newCell importRef - queueIO conn' $ Fin.addFinalizer cell $ atomically $ Rc.decr localRc - pure cell - --- | Release the identified import. Removes it from the table and sends a release --- message with the correct count. -releaseImport :: IEId -> Conn' -> STM () -releaseImport importId conn'@Conn'{imports} = do - (_, onSent) <- newPromise - lookupAbort "imports" conn' imports importId $ \EntryI { remoteRc } -> - sendPureMsg conn' (R.Message'release - R.Release - { id = ieWord importId - , referenceCount = remoteRc - }) - onSent - M.delete importId imports - --- | Create a new client targeting an object in our answers table. --- Important: in this case the 'PromisedAnswer' refers to a question we --- have recevied, not sent. -newLocalAnswerClient :: Conn' -> PromisedAnswer -> STM Client -newLocalAnswerClient conn@Conn'{answers} PromisedAnswer{ answerId, transform } = do - callBuffer <- newTQueue - let tmpDest = LocalDest $ LocalBuffer { callBuffer } - pState <- newTVar Pending { tmpDest } - subscribeReturn "answer" conn answers answerId $ - resolveClientReturn - tmpDest - (writeTVar pState) - conn - (toList transform) - exportMap <- ExportMap <$> M.new - pure $ Client $ Just PromiseClient - { pState - , exportMap - , origTarget = tmpDest - } - - --- Note [Limiting resource usage] --- ============================== --- --- N.B. much of this Note is future tense; the library is not yet robust against --- resource useage attacks. --- --- We employ various strategies to prevent remote vats from causing excessive --- resource usage. In particular: --- --- * We set a maximum size for incoming messages; this is in keeping with how --- we mitigate these concerns when dealing with plain capnp data (i.e. not --- rpc). --- * We set a limit on the total *size* of all messages from the remote vat that --- are currently being serviced. For example, if a Call message comes in, --- we note its size, and deduct it from the quota. Once we have sent a return --- and received a finish for this call, and thus can safely forget about it, --- we remove it from our answers table, and add its size back to the available --- quota. --- --- Still TBD: --- --- * We should come up with some way of guarding against too many intra-vat calls; --- depending on the object graph, it may be possible for an attacker to get us --- to "eat our own tail" so to speak. --- --- Ideas: --- * Per-object bounded queues for messages --- * Global limit on intra-vat calls. --- --- Right now I(zenhack) am more fond of the former. --- --- * What should we actually do when limits are exceeded? +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- Module: Capnp.Rpc.Untyped +-- Description: Core of the RPC subsystem. +-- +-- This module does not deal with schema-level concepts; all capabilities, +-- methods etc. as used here are untyped. +module Capnp.Rpc.Untyped + ( -- * Connections to other vats + ConnConfig (..), + handleConn, + + -- * Clients for capabilities + Client, + call, + nullClient, + newPromiseClient, + IsClient (..), + + -- * Promise pipelining + Pipeline, + walkPipelinePtr, + pipelineClient, + waitPipeline, + + -- * Exporting local objects + export, + clientMethodHandler, + + -- * Unwrapping local clients + unwrapServer, + + -- * Waiting for resolution + waitClient, + + -- * Errors + RpcError (..), + + -- * Shutting down the connection + ) +where + +import Capnp.Accessors +import qualified Capnp.Basics as B +import Capnp.Bits (WordCount, bytesToWordsFloor) +import Capnp.Classes (new, newRoot, parse) +import Capnp.Convert (msgToRaw, parsedToMsg) +import Capnp.Fields (Which) +import qualified Capnp.Gen.Capnp.Rpc as R +import Capnp.Message (Message) +import qualified Capnp.Message as Message +import Capnp.Mutability (Mutability (..), thaw) +import Capnp.Repr (Raw (..)) +import Capnp.Rpc.Errors + ( eDisconnected, + eFailed, + eMethodUnimplemented, + eUnimplemented, + wrapException, + ) +import Capnp.Rpc.Promise + ( Fulfiller, + Promise, + breakOrFulfill, + breakPromise, + fulfill, + newCallback, + newPromise, + newReadyPromise, + ) +import qualified Capnp.Rpc.Server as Server +import Capnp.Rpc.Transport (Transport (recvMsg, sendMsg)) +import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT) +import qualified Capnp.Untyped as UntypedRaw +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (concurrently_, race_) +import Control.Concurrent.MVar (MVar, newEmptyMVar) +import Control.Concurrent.STM +import Control.Exception.Safe + ( Exception, + MonadThrow, + SomeException, + bracket, + finally, + fromException, + throwIO, + throwM, + try, + ) +import Control.Monad (forever, join, void, when) +import Control.Monad.STM.Class +import Control.Monad.Trans.Class +import Data.Default (Default (def)) +import Data.Dynamic (fromDynamic) +import Data.Foldable (for_, toList, traverse_) +import Data.Function ((&)) +import Data.Hashable (Hashable, hash, hashWithSalt) +import Data.Maybe (catMaybes, fromMaybe) +import Data.String (fromString) +import Data.Text (Text) +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import Data.Word +import qualified Focus +import GHC.Generics (Generic) +import Internal.BuildPure (createPure) +import Internal.Rc (Rc) +import qualified Internal.Rc as Rc +import Internal.Rpc.Breaker +import Internal.SnocList (SnocList) +import qualified Internal.SnocList as SnocList +import qualified Internal.TCloseQ as TCloseQ +import qualified Lifetimes.Gc as Fin +import qualified ListT +import qualified StmContainers.Map as M +import Supervisors (Supervisor, superviseSTM, withSupervisor) +import System.Mem.StableName (StableName, hashStableName, makeStableName) +import System.Timeout (timeout) + +-- Note [Organization] +-- =================== +-- +-- As much as possible, the logic in this module is centralized according to +-- type types of objects it concerns. +-- +-- As an example, consider how we handle embargos: The 'Conn' type's 'embargos' +-- table has values that are just 'Fulfiller's. This allows the code which triggers +-- sending embargoes to have full control over what happens when they return, +-- while the code that routes incoming messages (in 'recvLoop') doesn't need +-- to concern itself with the details of embargos -- it just needs to route them +-- to the right place. +-- +-- This approach generally results in better separation of concerns. + +-- Note [Level 3] +-- +-- This is currently a level 1 implementation, so use of most level 3 features +-- results in sending abort messages. However, to make adding this support +-- easier later, we mark such places with a cross-reference back to this note. +-- +-- In addition to filling in those spots, the following will need to be dealt +-- with: +-- + +-- * The "Tribble 4-way Race Condition" as documented in rpc.capnp. This + +-- doesn't affect level 1 implementations, but right now we shorten N-hop +-- paths of promises to 1-hop, (calls on Ready PromiseClients just +-- immediately call the target), which is unsafe in a level 3 +-- implementation. See the protocol documentation for more info. + +-- Note [Breaker] +-- ============== +-- +-- Since capabilities can be stored in messages, it is somewhat challenging +-- to design a module structure that avoids low-level capnp serialization code +-- depending on the rpc system, simply because it needs to pass the 'Client' +-- type around, even if it doesn't do much else with it. +-- +-- Earlier versions of this library capitulated and introduced a cyclic +-- dependency; there was a .hs-boot file for this module exposing 'Client' +-- and a couple other things, and "Capnp.Message" and a few other +-- serialization modules imported it. +-- +-- This was a problem for a couple reasons: +-- + +-- * Not only was there a cyclic dependency, the path it took went through + +-- a large fraction of the library, meaning whenever any of those modules +-- changes most of the library had to be rebuilt. + +-- * It precluded doing things like splitting rpc support into a separate + +-- package, for consumers who only want serialization and want a more +-- minimal dependency footprint. +-- +-- Instead, the current solution is the "Internal.Rpc.Breaker" module; it +-- defines the few things needed by serialization code, but it does so +-- in a way that avoids depending on this module, sacrificing a small +-- amount of type safety by using "Data.Dynamic" instead of referencing +-- the types in this module directly. While in principle a caller could +-- supply some other type, we expect that: +-- + +-- * 'Client' will always wrap a @Maybe Client'@. + +-- * 'Pipeline' will always wrap a @Pipeline'@. + +-- +-- we provide wrap/unwrap helper functions for each of these, to keep +-- the type-unsafety that comes with this as localized as possible. + +-- | We use this type often enough that the types get noisy without a shorthand: +type RawMPtr = Maybe (UntypedRaw.Ptr 'Const) + +-- | Errors which can be thrown by the rpc system. +data RpcError + = -- | The remote vat sent us an abort message. + ReceivedAbort (R.Parsed R.Exception) + | -- | We sent an abort to the remote vat. + SentAbort (R.Parsed R.Exception) + deriving (Show, Eq, Generic) + +makeAbortExn :: Bool -> SomeException -> RpcError +makeAbortExn debugMode e = + fromMaybe + (SentAbort (wrapException debugMode e)) + (fromException e) + +instance Exception RpcError + +newtype EmbargoId = EmbargoId {embargoWord :: Word32} deriving (Eq, Hashable) + +newtype QAId = QAId {qaWord :: Word32} deriving (Eq, Hashable) + +newtype IEId = IEId {ieWord :: Word32} deriving (Eq, Hashable) + +-- We define these to just show the number; the derived instances would include +-- data constructors, which is a bit weird since these show up in output that +-- is sometimes shown to users. +instance Show QAId where + show = show . qaWord + +instance Show IEId where + show = show . ieWord + +-- | A connection to a remote vat +data Conn = Conn + { stableName :: StableName (MVar ()), + -- So we can use the connection as a map key. The MVar used to create + -- this is just an arbitrary value; the only property we care about + -- is that it is distinct for each 'Conn', so we use something with + -- reference semantics to guarantee this. + + debugMode :: !Bool, + -- whether to include extra (possibly sensitive) info in error messages. + + liveState :: TVar LiveState + } + +data LiveState + = Live Conn' + | Dead + +data Conn' = Conn' + { sendQ :: TChan (Message 'Const, Fulfiller ()), + -- queue of messages to send sent to the remote vat; these are actually + -- sent by a dedicated thread (see 'sendLoop'). + -- + -- The fulfiller is fulfilled after the message actually hits the transport. + -- + -- The queue mainly exists for the sake of messages that are sent *while + -- processing incomming messages*, since we cannot block in those cases, + -- but it is used for all message sends to enforce ordering. The fulfiller + -- is used by parts of the code (basically just calls) that want to block + -- until their message is actually written to the socket. + + availableCallWords :: TVar WordCount, + -- Semaphore used to limit the memory that can be used by in-progress + -- calls originating from this connection. We don't just use a TSem + -- because waitTSem doesn't let us wait for more than one token with a + -- single call. + + supervisor :: Supervisor, + -- Supervisor managing the lifetimes of threads bound to this connection. + + questionIdPool :: IdPool, + exportIdPool :: IdPool, + -- Pools of identifiers for new questions and exports + + questions :: M.Map QAId EntryQA, + answers :: M.Map QAId EntryQA, + exports :: M.Map IEId EntryE, + imports :: M.Map IEId EntryI, + embargos :: M.Map EmbargoId (Fulfiller ()), + -- Outstanding embargos. When we receive a 'Disembargo' message with its + -- context field set to receiverLoopback, we look up the embargo id in + -- this table, and fulfill the promise. + + pendingCallbacks :: TQueue (IO ()), + -- See Note [callbacks] + + bootstrap :: Maybe Client + -- The capability which should be served as this connection's bootstrap + -- interface (if any). + } + +instance Eq Conn where + x == y = stableName x == stableName y + +instance Hashable Conn where + hash Conn {stableName} = hashStableName stableName + hashWithSalt _ = hash + +-- | Configuration information for a connection. +data ConnConfig = ConnConfig + { -- | The maximum number of simultanious outstanding requests to the peer + -- vat. Once this limit is reached, further questsions will block until + -- some of the existing questions have been answered. + -- + -- Defaults to 128. + maxQuestions :: !Word32, + -- | The maximum number of objects which may be exported on this connection. + -- + -- Defaults to 8192. + maxExports :: !Word32, + -- | The maximum total size of outstanding call messages that will be + -- accepted; if this limit is reached, the implementation will not read + -- more messages from the connection until some calls have completed + -- and freed up enough space. + -- + -- Defaults to 32MiB in words. + maxCallWords :: !WordCount, + -- | In debug mode, errors reported by the RPC system to its peers will + -- contain extra information. This should not be used in production, as + -- it is possible for these messages to contain sensitive information, + -- but it can be useful for debugging. + -- + -- Defaults to 'False'. + debugMode :: !Bool, + -- | Get the bootstrap interface we should serve for this connection. + -- the argument is a supervisor whose lifetime is bound to the + -- connection. If 'getBootstrap' returns 'Nothing', we will respond + -- to bootstrap messages with an exception. + -- + -- The default always returns 'Nothing'. + -- + -- 'getBootstrap' MUST NOT block; the connection will not be serviced + -- and 'withBootstrap' will not be run until this returns. If you need + -- to supply the bootstrap interface later, use 'newPromiseClient'. + getBootstrap :: Supervisor -> STM (Maybe Client), + -- | An action to perform with access to the remote vat's bootstrap + -- interface. The supervisor argument is bound to the lifetime of the + -- connection. If this is 'Nothing' (the default), the bootstrap + -- interface will not be requested. + withBootstrap :: Maybe (Supervisor -> Client -> IO ()) + } + +instance Default ConnConfig where + def = + ConnConfig + { maxQuestions = 128, + maxExports = 8192, + maxCallWords = bytesToWordsFloor $ 32 * 1024 * 1024, + debugMode = False, + getBootstrap = \_ -> pure Nothing, + withBootstrap = Nothing + } + +-- | Queue an IO action to be run some time after this transaction commits. +-- See Note [callbacks]. +queueIO :: Conn' -> IO () -> STM () +queueIO Conn' {pendingCallbacks} = writeTQueue pendingCallbacks + +-- | Queue another transaction to be run some time after this transaction +-- commits, in a thread bound to the lifetime of the connection. If this is +-- called multiple times within the same transaction, each of the +-- transactions will be run separately, in the order they were queued. +-- +-- See Note [callbacks] +queueSTM :: Conn' -> STM () -> STM () +queueSTM conn = queueIO conn . atomically + +-- | @'mapQueueSTM' conn fs val@ queues the list of transactions obtained +-- by applying each element of @fs@ to @val@. +mapQueueSTM :: Conn' -> SnocList (a -> STM ()) -> a -> STM () +mapQueueSTM conn fs x = traverse_ (\f -> queueSTM conn (f x)) fs + +-- Note [callbacks] +-- ================ +-- +-- There are many places where we want to register some code to run after +-- some later event has happened -- for exmaple: +-- + +-- * We send a Call to the remote vat, and when a corresponding Return message + +-- is received, we want to fulfill (or break) the local promise for the +-- result. + +-- * We send a Disembargo (with senderLoopback set), and want to actually lift + +-- the embargo when the corresponding (receiverLoopback) message arrives. +-- +-- Keeping the two parts of these patterns together tends to result in better +-- separation of concerns, and is easier to maintain. +-- +-- To achieve this, the four tables and other connection state have fields in +-- which callbacks can be registered -- for example, an outstanding question has +-- fields containing transactions to run when the return and/or finish messages +-- arrive. +-- +-- When it is time to actually run these, we want to make sure that each of them +-- runs as their own transaction. If, for example, when registering a callback to +-- run when a return message is received, we find that the return message is +-- already available, it might be tempting to just run the transaction immediately. +-- But this means that the synchronization semantics are totally different from the +-- case where the callback really does get run later! +-- +-- In addition, we sometimes want to register a finalizer inside a transaction, +-- but this can only be done in IO. +-- +-- To solve these issues, the connection maintains a queue of all callback actions +-- that are ready to run, and when the event a callback is waiting for occurs, we +-- simply move the callback to the queue, using 'queueIO' or 'queueSTM'. When the +-- connection starts up, it creates a thread running 'callbacksLoop', which just +-- continually flushes the queue, running the actions in the queue. + +-- | Get a new question id. retries if we are out of available question ids. +newQuestion :: Conn' -> STM QAId +newQuestion = fmap QAId . newId . questionIdPool + +-- | Return a question id to the pool of available ids. +freeQuestion :: Conn' -> QAId -> STM () +freeQuestion conn = freeId (questionIdPool conn) . qaWord + +-- | Get a new export id. retries if we are out of available export ids. +newExport :: Conn' -> STM IEId +newExport = fmap IEId . newId . exportIdPool + +-- | Return a export id to the pool of available ids. +freeExport :: Conn' -> IEId -> STM () +freeExport conn = freeId (exportIdPool conn) . ieWord + +-- | Get a new embargo id. This shares the same pool as questions. +newEmbargo :: Conn' -> STM EmbargoId +newEmbargo = fmap EmbargoId . newId . questionIdPool + +-- | Return an embargo id. to the available pool. +freeEmbargo :: Conn' -> EmbargoId -> STM () +freeEmbargo conn = freeId (exportIdPool conn) . embargoWord + +-- | Handle a connection to another vat. Returns when the connection is closed. +handleConn :: Transport -> ConnConfig -> IO () +handleConn + transport + cfg@ConnConfig + { maxQuestions, + maxExports, + maxCallWords, + withBootstrap, + debugMode + } = + withSupervisor $ \sup -> + bracket + (newConn sup) + stopConn + runConn + where + newConn sup = do + stableName <- makeStableName =<< newEmptyMVar + atomically $ do + bootstrap <- getBootstrap cfg sup + questionIdPool <- newIdPool maxQuestions + exportIdPool <- newIdPool maxExports + + sendQ <- newTChan + + availableCallWords <- newTVar maxCallWords + + questions <- M.new + answers <- M.new + exports <- M.new + imports <- M.new + + embargos <- M.new + pendingCallbacks <- newTQueue + + let conn' = + Conn' + { supervisor = sup, + questionIdPool, + exportIdPool, + sendQ, + availableCallWords, + questions, + answers, + exports, + imports, + embargos, + pendingCallbacks, + bootstrap + } + liveState <- newTVar (Live conn') + let conn = + Conn + { stableName, + debugMode, + liveState + } + pure (conn, conn') + runConn (conn, conn') = do + result <- + try $ + ( recvLoop transport conn + `concurrently_` sendLoop transport conn' + `concurrently_` callbacksLoop conn' + ) + `race_` useBootstrap conn conn' + case result of + Left (SentAbort e) -> do + -- We need to actually send it: + rawMsg <- createPure maxBound $ parsedToMsg $ R.Message'abort e + void $ timeout 1000000 $ sendMsg transport rawMsg + throwIO $ SentAbort e + Left e -> + throwIO e + Right _ -> + pure () + stopConn + ( conn@Conn {liveState}, + conn'@Conn' {questions, exports, embargos} + ) = do + atomically $ do + let walk table = flip ListT.traverse_ (M.listT table) + -- drop the bootstrap interface: + case bootstrap conn' of + Just (unwrapClient -> Just client') -> dropConnExport conn client' + _ -> pure () + -- Remove everything from the exports table: + walk exports $ \(_, EntryE {client}) -> + dropConnExport conn client + -- Outstanding questions should all throw disconnected: + walk questions $ \(qid, entry) -> + let raiseDisconnected onReturn = + mapQueueSTM conn' onReturn $ + Return + { answerId = qid, + releaseParamCaps = False, + union' = Return'exception eDisconnected + } + in case entry of + NewQA {onReturn} -> raiseDisconnected onReturn + HaveFinish {onReturn} -> raiseDisconnected onReturn + _ -> pure () + -- same thing with embargos: + walk embargos $ \(_, fulfiller) -> + breakPromise fulfiller eDisconnected + -- mark the connection as dead, making the live state inaccessible: + writeTVar liveState Dead + useBootstrap conn conn' = case withBootstrap of + Nothing -> + forever $ threadDelay maxBound + Just f -> + atomically (requestBootstrap conn) >>= f (supervisor conn') + +-- | A pool of ids; used when choosing identifiers for questions and exports. +newtype IdPool = IdPool (TVar [Word32]) + +-- | @'newIdPool' size@ creates a new pool of ids, with @size@ available ids. +newIdPool :: Word32 -> STM IdPool +newIdPool size = IdPool <$> newTVar [0 .. size - 1] + +-- | Get a new id from the pool. Retries if the pool is empty. +newId :: IdPool -> STM Word32 +newId (IdPool pool) = + readTVar pool >>= \case + [] -> retry + (id : ids) -> do + writeTVar pool $! ids + pure id + +-- | Return an id to the pool. +freeId :: IdPool -> Word32 -> STM () +freeId (IdPool pool) id = modifyTVar' pool (id :) + +-- | An entry in our questions or answers table. +data EntryQA + = -- | An entry for which we have neither sent/received a finish, nor + -- a return. Contains two sets of callbacks, one to invoke on each + -- type of message. + NewQA + { onFinish :: SnocList (R.Parsed R.Finish -> STM ()), + onReturn :: SnocList (Return -> STM ()) + } + | -- | An entry for which we've sent/received a return, but not a finish. + -- Contains the return message, and a set of callbacks to invoke on the + -- finish. + HaveReturn + { returnMsg :: Return, + onFinish :: SnocList (R.Parsed R.Finish -> STM ()) + } + | -- | An entry for which we've sent/received a finish, but not a return. + -- Contains the finish message, and a set of callbacks to invoke on the + -- return. + HaveFinish + { finishMsg :: R.Parsed R.Finish, + onReturn :: SnocList (Return -> STM ()) + } + +-- | An entry in our imports table. +data EntryI = EntryI + { -- | A refcount cell with a finalizer attached to it; when the finalizer + -- runs it will remove this entry from the table and send a release + -- message to the remote vat. + localRc :: Rc (), + -- | The reference count for this object as understood by the remote + -- vat. This tells us what to send in the release message's count field. + remoteRc :: !Word32, + -- | See Note [proxies] + proxies :: ExportMap, + -- | If this entry is a promise, this will contain the state of that + -- promise, so that it may be used to create PromiseClients and + -- update the promise when it resolves. + promiseState :: + Maybe + ( TVar PromiseState, + TmpDest -- origTarget field. TODO(cleanup): clean this up a bit. + ) + } + +-- | An entry in our exports table. +data EntryE = EntryE + { -- | The client. We cache it in the table so there's only one object + -- floating around, which lets us attach a finalizer without worrying + -- about it being run more than once. + client :: Client', + -- | The refcount for this entry. This lets us know when we can drop + -- the entry from the table. + refCount :: !Word32 + } + +-- | Types which may be converted to and from 'Client's. Typically these +-- will be simple type wrappers for capabilities. +class IsClient a where + -- | Convert a value to a client. + toClient :: a -> Client + + -- | Convert a client to a value. + fromClient :: Client -> a + +instance IsClient Client where + toClient = id + fromClient = id + +-- | See Note [Breaker] +wrapClient :: Maybe Client' -> Client +wrapClient = Client . makeOpaque + +-- | See Note [Breaker] +unwrapClient :: Client -> Maybe Client' +unwrapClient (Client o) = + join $ fromDynamic $ reflectOpaque o + +data Client' + = -- | A client pointing at a capability local to our own vat. + LocalClient + { -- | Record of what export IDs this client has on different remote + -- connections. + exportMap :: ExportMap, + -- | Queue a call for the local capability to handle. This is wrapped + -- in a reference counted cell, whose finalizer stops the server. + qCall :: Rc (Server.CallInfo -> STM ()), + -- | Finalizer key; when this is collected, qCall will be released. + finalizerKey :: Fin.Cell (), + unwrapper :: forall a. Typeable a => Maybe a + } + | -- | A client which will resolve to some other capability at + -- some point. + PromiseClient + { -- | The current state of the promise; the indirection allows + -- the promise to be updated. + pState :: TVar PromiseState, + exportMap :: ExportMap, + -- | The original target of this promise, before it was resolved. + -- (if it is still in the pending state, it will match the TmpDest + -- stored there). + -- + -- FIXME: if this is an ImportDest, by holding on to this we actually + -- leak the cap. + origTarget :: TmpDest + } + | -- | A client which points to a (resolved) capability in a remote vat. + ImportClient (Fin.Cell ImportRef) + +data Pipeline' = Pipeline' + { state :: TVar PipelineState, + steps :: SnocList Word16 + } + deriving (Eq) + +-- | See Note [Breaker] +wrapPipeline :: Pipeline' -> Pipeline +wrapPipeline = Pipeline . makeOpaque + +-- | See Note [Breaker] +unwrapPipeline :: Pipeline -> Pipeline' +unwrapPipeline (Pipeline o) = + case fromDynamic (reflectOpaque o) of + Nothing -> error "invalid pipeline; dynamic unwrap failed" + Just p -> p + +data PipelineState + = PendingRemotePipeline + { answerId :: !QAId, + clientMap :: M.Map (SnocList Word16) Client, + conn :: Conn + } + | PendingLocalPipeline (SnocList (Fulfiller RawMPtr)) + | ReadyPipeline (Either (R.Parsed R.Exception) RawMPtr) + +-- | 'walkPipleinePtr' follows a pointer starting from the object referred to by the +-- 'Pipeline'. The 'Pipeline' must refer to a struct, and the pointer is referred to +-- by its index into the struct's pointer section. +walkPipelinePtr :: Pipeline -> Word16 -> Pipeline +walkPipelinePtr (unwrapPipeline -> p@Pipeline' {steps}) step = + wrapPipeline $ p {steps = SnocList.snoc steps step} + +-- | Convert a 'Pipeline' into a 'Client', which can be used to send messages to the +-- referant of the 'Pipeline', using promise pipelining. +pipelineClient :: MonadSTM m => Pipeline -> m Client +pipelineClient (unwrapPipeline -> Pipeline' {state, steps}) = liftSTM $ do + readTVar state >>= \case + PendingRemotePipeline {answerId, clientMap, conn} -> do + maybeClient <- M.lookup steps clientMap + case maybeClient of + Nothing -> do + client <- + promisedAnswerClient + conn + PromisedAnswer {answerId, transform = steps} + M.insert client steps clientMap + pure client + Just client -> + pure client + PendingLocalPipeline subscribers -> do + (ret, retFulfiller) <- newPromiseClient + ptrFulfiller <- newCallback $ \r -> do + writeTVar state (ReadyPipeline r) + case r of + Left e -> + breakPromise retFulfiller e + Right v -> + (ptrPathClient (toList steps) v >>= fulfill retFulfiller) + `catchSTM` (breakPromise retFulfiller . wrapException False) + writeTVar state $ PendingLocalPipeline $ SnocList.snoc subscribers ptrFulfiller + pure ret + ReadyPipeline r -> do + -- TODO(cleanup): factor out the commonalities between this and the above case. + (p, f) <- newPromiseClient + case r of + Left e -> breakPromise f e >> pure p + Right v -> + ptrPathClient (toList steps) v + `catchSTM` ( \e -> do + breakPromise f (wrapException False e) + pure p + ) + +-- | Wait for the pipeline's target to resolve, and return the corresponding +-- pointer. +waitPipeline :: MonadSTM m => Pipeline -> m RawMPtr +waitPipeline (unwrapPipeline -> Pipeline' {state, steps}) = liftSTM $ do + s <- readTVar state + case s of + ReadyPipeline (Left e) -> + throwM e + ReadyPipeline (Right v) -> + evalLimitT defaultLimit $ followPtrs (toList steps) v + _ -> + retry + +promisedAnswerClient :: Conn -> PromisedAnswer -> STM Client +promisedAnswerClient conn answer@PromisedAnswer {answerId, transform} = do + let tmpDest = RemoteDest AnswerDest {conn, answer} + pState <- newTVar Pending {tmpDest} + exportMap <- ExportMap <$> M.new + let client = + wrapClient $ + Just + PromiseClient + { pState, + exportMap, + origTarget = tmpDest + } + readTVar (liveState conn) >>= \case + Dead -> + resolveClientExn tmpDest (writeTVar pState) eDisconnected + Live conn'@Conn' {questions} -> + subscribeReturn "questions" conn' questions answerId $ + resolveClientReturn tmpDest (writeTVar pState) conn' (toList transform) + pure client + +-- | The current state of a 'PromiseClient'. +data PromiseState + = -- | The promise is fully resolved. + Ready + { -- | Capability to which the promise resolved. + target :: Client + } + | -- | The promise has resolved, but is waiting on a Disembargo message + -- before it is safe to send it messages. + Embargo + { -- | A queue in which to buffer calls while waiting for the + -- disembargo. + callBuffer :: TQueue Server.CallInfo + } + | -- | The promise has not yet resolved. + Pending + { -- | A temporary destination to send calls, while we wait for the + -- promise to resolve. + tmpDest :: TmpDest + } + | -- | The promise resolved to an exception. + Error (R.Parsed R.Exception) + +-- | A temporary destination for calls on an unresolved promise. +data TmpDest + = -- | A destination that is local to this vat. + LocalDest LocalDest + | -- | A destination in another vat. + RemoteDest RemoteDest + +newtype LocalDest + = -- | Queue the calls in a buffer. + LocalBuffer {callBuffer :: TQueue Server.CallInfo} + +data RemoteDest + = -- | Send call messages to a remote vat, targeting the results + -- of an outstanding question. + AnswerDest + { -- | The connection to the remote vat. + conn :: Conn, + -- | The answer to target. + answer :: PromisedAnswer + } + | -- | Send call messages to a remote vat, targeting an entry in our + -- imports table. + ImportDest (Fin.Cell ImportRef) + +-- | A reference to a capability in our import table/a remote vat's export +-- table. +data ImportRef = ImportRef + { -- | The connection to the remote vat. + conn :: Conn, + -- | The import id for this capability. + importId :: !IEId, + -- | Export ids to use when this client is passed to a vat other than + -- the one identified by 'conn'. See Note [proxies] + proxies :: ExportMap + } + +-- Ideally we could just derive these, but stm-containers doesn't have Eq +-- instances, so neither does ExportMap. not all of the fields are actually +-- necessary to check equality though. See also +-- https://github.com/nikita-volkov/stm-hamt/pull/1 +instance Eq ImportRef where + ImportRef {conn = cx, importId = ix} == ImportRef {conn = cy, importId = iy} = + cx == cy && ix == iy + +instance Eq Client' where + LocalClient {qCall = x} == LocalClient {qCall = y} = + x == y + PromiseClient {pState = x} == PromiseClient {pState = y} = + x == y + ImportClient x == ImportClient y = + x == y + _ == _ = + False + +-- | an 'ExportMap' tracks a mapping from connections to export IDs; it is +-- used to ensure that we re-use export IDs for capabilities when passing +-- them to remote vats. This used for locally hosted capabilities, but also +-- by proxied imports (see Note [proxies]). +newtype ExportMap = ExportMap (M.Map Conn IEId) + +-- The below correspond to the similarly named types in +-- rpc.capnp, except: +-- + +-- * They use our newtype wrappers for ids + +-- * They don't have unknown variants + +-- * AnyPointers are left un-parsed + +-- * PromisedAnswer's transform field is just a list of pointer offsets, + +-- rather than a union with no other actually-useful variants. + +-- * PromisedAnswer's transform field is a SnocList, for efficient appending. + +data MsgTarget + = ImportTgt !IEId + | AnswerTgt PromisedAnswer + +data PromisedAnswer = PromisedAnswer + { answerId :: !QAId, + transform :: SnocList Word16 + } + +data Call = Call + { questionId :: !QAId, + target :: !MsgTarget, + interfaceId :: !Word64, + methodId :: !Word16, + params :: !Payload + } + +data Return = Return + { answerId :: !QAId, + releaseParamCaps :: !Bool, + union' :: Return' + } + +data Return' + = Return'results Payload + | Return'exception (R.Parsed R.Exception) + | Return'canceled + | Return'resultsSentElsewhere + | Return'takeFromOtherQuestion QAId + | Return'acceptFromThirdParty RawMPtr + +data Payload = Payload + { content :: RawMPtr, + capTable :: V.Vector (R.Parsed R.CapDescriptor) + } + +-- Note [proxies] +-- ============== +-- +-- It is possible to have multiple connections open at once, and pass around +-- clients freely between them. Without level 3 support, this means that when +-- we pass a capability pointing into Vat A to another Vat B, we must proxy it. +-- +-- To achieve this, capabilities pointing into a remote vat hold an 'ExportMap', +-- which tracks which export IDs we should be using to proxy the client on each +-- connection. + +-- | Queue a call on a client. +call :: MonadSTM m => Server.CallInfo -> Client -> m (Promise Pipeline) +call Server.CallInfo {response} (unwrapClient -> Nothing) = liftSTM $ do + breakPromise response eMethodUnimplemented + state <- newTVar $ ReadyPipeline (Left eMethodUnimplemented) + newReadyPromise $ wrapPipeline Pipeline' {state, steps = mempty} +call info@Server.CallInfo {response} (unwrapClient -> Just client') = liftSTM $ do + (localPipeline, response') <- makeLocalPipeline response + let info' = info {Server.response = response'} + case client' of + LocalClient {qCall} -> do + Rc.get qCall >>= \case + Just q -> do + q info' + Nothing -> + breakPromise response' eDisconnected + newReadyPromise localPipeline + PromiseClient {pState} -> + readTVar pState >>= \case + Ready {target} -> + call info target + Embargo {callBuffer} -> do + writeTQueue callBuffer info' + newReadyPromise localPipeline + Pending {tmpDest} -> case tmpDest of + LocalDest LocalBuffer {callBuffer} -> do + writeTQueue callBuffer info' + newReadyPromise localPipeline + RemoteDest AnswerDest {conn, answer} -> + callRemote conn info $ AnswerTgt answer + RemoteDest (ImportDest cell) -> do + ImportRef {conn, importId} <- Fin.readCell cell + callRemote conn info $ ImportTgt importId + Error exn -> do + breakPromise response' exn + newReadyPromise localPipeline + ImportClient cell -> do + ImportRef {conn, importId} <- Fin.readCell cell + callRemote conn info (ImportTgt importId) + +makeLocalPipeline :: Fulfiller RawMPtr -> STM (Pipeline, Fulfiller RawMPtr) +makeLocalPipeline f = do + state <- newTVar $ PendingLocalPipeline mempty + f' <- newCallback $ \r -> do + s <- readTVar state + case s of + PendingLocalPipeline fs -> do + writeTVar state (ReadyPipeline r) + breakOrFulfill f r + traverse_ (`breakOrFulfill` r) fs + _ -> + -- TODO(cleanup): refactor so we don't need this case. + error "impossible" + pure (wrapPipeline Pipeline' {state, steps = mempty}, f') + +-- | Send a call to a remote capability. +callRemote :: Conn -> Server.CallInfo -> MsgTarget -> STM (Promise Pipeline) +callRemote + conn + Server.CallInfo {interfaceId, methodId, arguments, response} + target = do + conn'@Conn' {questions} <- getLive conn + qid <- newQuestion conn' + payload@Payload {capTable} <- makeOutgoingPayload conn arguments + -- save these in case the callee sends back releaseParamCaps = True in the return + -- message: + let paramCaps = catMaybes $ flip map (V.toList capTable) $ \R.CapDescriptor {union'} -> case union' of + R.CapDescriptor'senderHosted eid -> Just (IEId eid) + R.CapDescriptor'senderPromise eid -> Just (IEId eid) + _ -> Nothing + + clientMap <- M.new + rp <- + newTVar + PendingRemotePipeline + { answerId = qid, + clientMap, + conn + } + + response' <- newCallback $ \r -> do + breakOrFulfill response r + case r of + Left e -> writeTVar rp $ ReadyPipeline (Left e) + Right v -> + writeTVar rp $ ReadyPipeline (Right v) + + M.insert + NewQA + { onReturn = SnocList.singleton $ cbCallReturn paramCaps conn response', + onFinish = SnocList.empty + } + qid + questions + (p, f) <- newPromise + f <- newCallback $ \r -> + breakOrFulfill f (wrapPipeline Pipeline' {state = rp, steps = mempty} <$ r) + sendCall + conn' + Call + { questionId = qid, + target = target, + params = payload, + interfaceId, + methodId + } + f + pure p + +-- | Callback to run when a return comes in that corresponds to a call +-- we sent. Registered in callRemote. The first argument is a list of +-- export IDs to release if the return message has releaseParamCaps = true. +cbCallReturn :: [IEId] -> Conn -> Fulfiller RawMPtr -> Return -> STM () +cbCallReturn + paramCaps + conn + response + Return {answerId, union', releaseParamCaps} = do + conn'@Conn' {answers} <- getLive conn + when releaseParamCaps $ + traverse_ (releaseExport conn 1) paramCaps + case union' of + Return'exception exn -> + breakPromise response exn + Return'results Payload {content} -> + fulfill response content + Return'canceled -> + breakPromise response $ eFailed "Canceled" + Return'resultsSentElsewhere -> + -- This should never happen, since we always set + -- sendResultsTo = caller + abortConn conn' $ + eFailed $ + mconcat + [ "Received Return.resultsSentElswhere for a call ", + "with sendResultsTo = caller." + ] + Return'takeFromOtherQuestion qid -> + -- TODO(cleanup): we should be a little stricter; the protocol + -- requires that (1) each answer is only used this way once, and + -- (2) The question was sent with sendResultsTo set to 'yourself', + -- but we don't enforce either of these requirements. + subscribeReturn "answer" conn' answers qid $ + cbCallReturn [] conn response + Return'acceptFromThirdParty _ -> + -- Note [Level 3] + abortConn conn' $ + eUnimplemented + "This vat does not support level 3." + -- Defer this until after any other callbacks run, in case disembargos + -- need to be sent due to promise resolutions that we triggered: + queueSTM conn' $ + finishQuestion + conn' + def + { R.questionId = qaWord answerId, + R.releaseResultCaps = False + } + +marshalMsgTarget :: MsgTarget -> R.Parsed R.MessageTarget +marshalMsgTarget = \case + ImportTgt importId -> + R.MessageTarget $ R.MessageTarget'importedCap (ieWord importId) + AnswerTgt tgt -> + R.MessageTarget $ R.MessageTarget'promisedAnswer $ marshalPromisedAnswer tgt + +marshalPromisedAnswer :: PromisedAnswer -> R.Parsed R.PromisedAnswer +marshalPromisedAnswer PromisedAnswer {answerId, transform} = + R.PromisedAnswer + { R.questionId = qaWord answerId, + R.transform = + V.fromList $ + map + (R.PromisedAnswer'Op . R.PromisedAnswer'Op'getPointerField) + (toList transform) + } + +unmarshalPromisedAnswer :: MonadThrow m => R.Parsed R.PromisedAnswer -> m PromisedAnswer +unmarshalPromisedAnswer R.PromisedAnswer {questionId, transform} = do + idxes <- unmarshalOps (toList transform) + pure + PromisedAnswer + { answerId = QAId questionId, + transform = SnocList.fromList idxes + } + +unmarshalOps :: MonadThrow m => [R.Parsed R.PromisedAnswer'Op] -> m [Word16] +unmarshalOps [] = pure [] +unmarshalOps (R.PromisedAnswer'Op {union' = R.PromisedAnswer'Op'noop} : ops) = + unmarshalOps ops +unmarshalOps (R.PromisedAnswer'Op {union' = R.PromisedAnswer'Op'getPointerField i} : ops) = + (i :) <$> unmarshalOps ops +unmarshalOps (R.PromisedAnswer'Op {union' = R.PromisedAnswer'Op'unknown' tag} : _) = + throwM $ eFailed $ "Unknown PromisedAnswer.Op: " <> fromString (show tag) + +-- | Create a new client based on a promise. The fulfiller can be used to +-- supply the final client. +newPromiseClient :: (MonadSTM m, IsClient c) => m (c, Fulfiller c) +newPromiseClient = liftSTM $ do + callBuffer <- newTQueue + let tmpDest = LocalDest LocalBuffer {callBuffer} + pState <- newTVar Pending {tmpDest} + exportMap <- ExportMap <$> M.new + f <- newCallback $ \case + Left e -> resolveClientExn tmpDest (writeTVar pState) e + Right v -> resolveClientClient tmpDest (writeTVar pState) (toClient v) + let p = + wrapClient $ + Just $ + PromiseClient + { pState, + exportMap, + origTarget = tmpDest + } + pure (fromClient p, f) + +-- | Attempt to unwrap a client, to get at an underlying value from the +-- server. Returns 'Nothing' on failure. +-- +-- This shells out to the underlying server's implementation of +-- 'Server.unwrap'. It will fail with 'Nothing' if any of these are true: +-- +-- * The client is a promise. +-- * The client points to an object in a remote vat. +-- * The underlying Server's 'unwrap' method returns 'Nothing' for type 'a'. +unwrapServer :: (IsClient c, Typeable a) => c -> Maybe a +unwrapServer c = case unwrapClient (toClient c) of + Just LocalClient {unwrapper} -> unwrapper + _ -> Nothing + +-- | Wait for the client to be fully resolved, and then return a client +-- pointing directly to the destination. +-- +-- If the argument is null, a local client, or a (permanent) remote client, +-- this returns the argument immediately. If the argument is a promise client, +-- then this waits for the promise to resolve and returns the result of +-- the resolution. If the promise resolves to *another* promise, then this waits +-- for that promise to also resolve. +-- +-- If the promise is rejected, then this throws the corresponding exception. +waitClient :: (IsClient c, MonadSTM m) => c -> m c +waitClient client = liftSTM $ case unwrapClient (toClient client) of + Nothing -> pure client + Just LocalClient {} -> pure client + Just ImportClient {} -> pure client + Just PromiseClient {pState} -> do + state <- readTVar pState + case state of + Ready {target} -> fromClient <$> waitClient target + Error e -> throwSTM e + Pending {} -> retry + Embargo {} -> retry + +-- | Spawn a local server with its lifetime bound to the supervisor, +-- and return a client for it. When the client is garbage collected, +-- the server will be stopped (if it is still running). +export :: MonadSTM m => Supervisor -> Server.ServerOps -> m Client +export sup ops = liftSTM $ do + q <- TCloseQ.new + qCall <- Rc.new (TCloseQ.write q) (TCloseQ.close q) + exportMap <- ExportMap <$> M.new + finalizerKey <- Fin.newCell () + let client' = + LocalClient + { qCall, + exportMap, + finalizerKey, + unwrapper = Server.handleCast ops + } + superviseSTM + sup + ( ( do + Fin.addFinalizer finalizerKey $ atomically $ Rc.release qCall + Server.runServer q ops + ) + `finally` Server.handleStop ops + ) + pure $ wrapClient (Just client') + +clientMethodHandler :: Word64 -> Word16 -> Client -> Server.MethodHandler p r +clientMethodHandler interfaceId methodId client = + Server.fromUntypedHandler $ + Server.untypedHandler $ + \arguments response -> atomically $ void $ call Server.CallInfo {..} client + +-- | See Note [callbacks] +callbacksLoop :: Conn' -> IO () +callbacksLoop Conn' {pendingCallbacks} = + loop `finally` cleanup + where + loop = + forever $ + doCallbacks $ + atomically $ + flushTQueue pendingCallbacks >>= \case + -- We need to make sure to block if there weren't any jobs, since + -- otherwise we'll busy loop, pegging the CPU. + [] -> retry + cbs -> pure cbs + cleanup = + -- Make sure any pending callbacks get run. This is important, since + -- some of these do things like raise disconnected exceptions. + doCallbacks $ atomically $ flushTQueue pendingCallbacks + doCallbacks getCbs = + -- We need to be careful not to lose any callbacks in the event + -- of an exception (even an async one): + bracket + getCbs + (foldr finally (pure ())) + (\_ -> pure ()) + +-- | 'sendLoop' shunts messages from the send queue into the transport. +sendLoop :: Transport -> Conn' -> IO () +sendLoop transport Conn' {sendQ} = + forever $ do + (msg, f) <- atomically $ readTChan sendQ + sendMsg transport msg + atomically $ fulfill f () + +-- | 'recvLoop' processes incoming messages. +recvLoop :: Transport -> Conn -> IO () +-- The logic here mostly routes messages to other parts of the code that know +-- more about the objects in question; See Note [Organization] for more info. +recvLoop transport conn@Conn {debugMode} = forever $ do + capnpMsg <- recvMsg transport + atomically $ do + flip catchSTM (throwSTM . makeAbortExn debugMode) $ do + evalLimitT defaultLimit $ do + rpcMsg <- msgToRaw capnpMsg + which <- structWhich rpcMsg + case which of + R.RW_Message'abort exn -> + parse exn >>= lift . handleAbortMsg conn + R.RW_Message'unimplemented oldMsg -> + parse oldMsg >>= lift . handleUnimplementedMsg conn + R.RW_Message'bootstrap bs -> + parse bs >>= lift . handleBootstrapMsg conn + R.RW_Message'call call -> do + handleCallMsg conn call + R.RW_Message'return ret -> do + ret' <- acceptReturn conn ret + lift $ handleReturnMsg conn ret' + R.RW_Message'finish finish -> + parse finish >>= lift . handleFinishMsg conn + R.RW_Message'resolve res -> + parse res >>= lift . handleResolveMsg conn + R.RW_Message'release release -> + parse release >>= lift . handleReleaseMsg conn + R.RW_Message'disembargo disembargo -> + parse disembargo >>= lift . handleDisembargoMsg conn + _ -> do + msg <- parse rpcMsg + lift $ do + (_, onSent) <- newPromise + conn' <- getLive conn + sendPureMsg conn' (R.Message'unimplemented msg) onSent + +-- Each function handle*Msg handles a message of a particular type; +-- 'recvLoop' dispatches to these. + +handleAbortMsg :: Conn -> R.Parsed R.Exception -> STM () +handleAbortMsg _ exn = + throwSTM (ReceivedAbort exn) + +handleUnimplementedMsg :: Conn -> R.Parsed R.Message -> STM () +handleUnimplementedMsg conn (R.Message msg) = + getLive conn >>= \conn' -> case msg of + R.Message'unimplemented _ -> + -- If the client itself doesn't handle unimplemented messages, that's + -- weird, but ultimately their problem. + pure () + R.Message'abort _ -> + abortConn conn' $ + eFailed $ + "Your vat sent an 'unimplemented' message for an abort message " + <> "that its remote peer never sent. This is likely a bug in your " + <> "capnproto library." + _ -> + abortConn conn' $ + eFailed "Received unimplemented response for required message." + +handleBootstrapMsg :: Conn -> R.Parsed R.Bootstrap -> STM () +handleBootstrapMsg conn R.Bootstrap {questionId} = + getLive conn >>= \conn' -> do + ret <- case bootstrap conn' of + Nothing -> + pure + Return + { answerId = QAId questionId, + releaseParamCaps = True, -- Not really meaningful for bootstrap, but... + union' = + Return'exception $ + eFailed "No bootstrap interface for this connection." + } + Just client -> do + capDesc <- emitCap conn client + content <- fmap Just $ createPure defaultLimit $ do + msg <- Message.newMessage Nothing + UntypedRaw.PtrCap <$> UntypedRaw.appendCap msg client + pure + Return + { answerId = QAId questionId, + releaseParamCaps = True, -- Not really meaningful for bootstrap, but... + union' = + Return'results + Payload + { content, + capTable = + V.singleton + (def {R.union' = capDesc} :: R.Parsed R.CapDescriptor) + } + } + M.focus + (Focus.alterM $ insertBootstrap conn' ret) + (QAId questionId) + (answers conn') + sendReturn conn' ret + where + insertBootstrap _ ret Nothing = + pure $ + Just + HaveReturn + { returnMsg = ret, + onFinish = + SnocList.fromList + [ \R.Finish {releaseResultCaps} -> + case ret of + Return + { union' = + Return'results + Payload + { capTable = (V.toList -> [R.CapDescriptor {union' = R.CapDescriptor'receiverHosted (IEId -> eid)}]) + } + } -> + when releaseResultCaps $ + releaseExport conn 1 eid + _ -> + pure () + ] + } + insertBootstrap conn' _ (Just _) = + abortConn conn' $ eFailed "Duplicate question ID" + +handleCallMsg :: Conn -> Raw R.Call 'Const -> LimitT STM () +handleCallMsg conn callMsg = do + conn'@Conn' {exports, answers, availableCallWords} <- lift $ getLive conn + let capnpMsg = UntypedRaw.message @(Raw R.Call) callMsg + + -- Apply backpressure, by limiting the memory usage of outstanding call + -- messages. + msgWords <- Message.totalNumWords capnpMsg + lift $ do + available <- readTVar availableCallWords + when + (msgWords > available) + retry + writeTVar availableCallWords $! available - msgWords + + questionId <- parseField #questionId callMsg + R.MessageTarget target <- parseField #target callMsg + interfaceId <- parseField #interfaceId callMsg + methodId <- parseField #methodId callMsg + payload <- readField #params callMsg + + Payload {content = callParams, capTable} <- acceptPayload conn payload + + lift $ do + -- First, add an entry in our answers table: + insertNewAbort + "answer" + conn' + (QAId questionId) + NewQA + { onReturn = + SnocList.fromList + [ \_ -> + modifyTVar' availableCallWords (msgWords +) + ], + onFinish = + SnocList.fromList + [ \R.Finish {releaseResultCaps} -> + when releaseResultCaps $ + for_ capTable $ \R.CapDescriptor {union'} -> case union' of + R.CapDescriptor'receiverHosted (IEId -> importId) -> + releaseExport conn 1 importId + _ -> + pure () + ] + } + answers + + -- Set up a callback for when the call is finished, to + -- send the return message: + fulfiller <- newCallback $ \case + Left e -> + returnAnswer + conn' + Return + { answerId = QAId questionId, + releaseParamCaps = False, + union' = Return'exception e + } + Right content -> do + capTable <- genSendableCapTableRaw conn content + returnAnswer + conn' + Return + { answerId = QAId questionId, + releaseParamCaps = False, + union' = + Return'results + Payload + { content = content, + capTable = capTable + } + } + -- Package up the info for the call: + let callInfo = + Server.CallInfo + { interfaceId, + methodId, + arguments = callParams, + response = fulfiller + } + -- Finally, figure out where to send it: + case target of + R.MessageTarget'importedCap exportId -> + lookupAbort "export" conn' exports (IEId exportId) $ + \EntryE {client} -> void $ call callInfo $ wrapClient $ Just client + R.MessageTarget'promisedAnswer R.PromisedAnswer {questionId = targetQid, transform} -> + let onReturn ret@Return {union'} = + case union' of + Return'exception _ -> + returnAnswer conn' ret {answerId = QAId questionId} + Return'canceled -> + returnAnswer conn' ret {answerId = QAId questionId} + Return'results Payload {content} -> + void $ transformClient transform content conn' >>= call callInfo + Return'resultsSentElsewhere -> + -- our implementation should never actually do this, but + -- this way we don't have to change this if/when we + -- support the feature: + abortConn conn' $ + eFailed $ + "Tried to call a method on a promised answer that " + <> "returned resultsSentElsewhere" + Return'takeFromOtherQuestion otherQid -> + subscribeReturn "answer" conn' answers otherQid onReturn + Return'acceptFromThirdParty _ -> + -- Note [Level 3] + error "BUG: our implementation unexpectedly used a level 3 feature" + in subscribeReturn "answer" conn' answers (QAId targetQid) onReturn + R.MessageTarget'unknown' ordinal -> + abortConn conn' $ + eUnimplemented $ + "Unknown MessageTarget ordinal #" <> fromString (show ordinal) + +ptrPathClient :: MonadThrow m => [Word16] -> RawMPtr -> m Client +ptrPathClient is ptr = + evalLimitT defaultLimit $ followPtrs is ptr >>= ptrClient + +transformClient :: V.Vector (R.Parsed R.PromisedAnswer'Op) -> RawMPtr -> Conn' -> STM Client +transformClient transform ptr conn = + (unmarshalOps (V.toList transform) >>= flip ptrPathClient ptr) + `catchSTM` abortConn conn + +ptrClient :: UntypedRaw.ReadCtx m 'Const => RawMPtr -> m Client +ptrClient Nothing = pure nullClient +ptrClient (Just (UntypedRaw.PtrCap cap)) = UntypedRaw.getClient cap +ptrClient (Just _) = throwM $ eFailed "Tried to call method on non-capability." + +-- | Follow a series of pointer indicies, returning the final value, or 'Left' +-- with an error if any of the pointers in the chain (except the last one) is +-- a non-null non struct. +followPtrs :: UntypedRaw.ReadCtx m 'Const => [Word16] -> RawMPtr -> m RawMPtr +followPtrs [] ptr = + pure ptr +followPtrs (_ : _) Nothing = + pure Nothing +followPtrs (i : is) (Just (UntypedRaw.PtrStruct struct)) = + UntypedRaw.getPtr (fromIntegral i) struct >>= followPtrs is +followPtrs (_ : _) (Just _) = + throwM $ eFailed "Tried to access pointer field of non-struct." + +sendRawMsg :: Conn' -> Message 'Const -> Fulfiller () -> STM () +sendRawMsg conn' msg onSent = writeTChan (sendQ conn') (msg, onSent) + +sendCall :: Conn' -> Call -> Fulfiller () -> STM () +sendCall + conn' + Call {questionId, target, interfaceId, methodId, params = Payload {content, capTable}} + onSent = do + msg <- createPure defaultLimit $ do + mcontent <- traverse thaw content + msg <- case mcontent of + Just v -> pure $ UntypedRaw.message @UntypedRaw.Ptr v + Nothing -> Message.newMessage Nothing + payload <- new @R.Payload () msg + payload & setField #content (Raw mcontent) + payload & encodeField #capTable capTable + call <- new @R.Call () msg + setField #params payload call + call & encodeField #questionId (qaWord questionId) + call & encodeField #interfaceId interfaceId + call & encodeField #methodId methodId + call & encodeField #target (marshalMsgTarget target) + rpcMsg <- newRoot @R.Message () msg + setVariant #call rpcMsg call + pure msg + sendRawMsg conn' msg onSent + +sendReturn :: Conn' -> Return -> STM () +sendReturn conn' Return {answerId, releaseParamCaps, union'} = do + (_, onSent) <- newPromise + case union' of + Return'results Payload {content, capTable} -> do + msg <- createPure defaultLimit $ do + mcontent <- traverse thaw content + msg <- case mcontent of + Just v -> pure $ UntypedRaw.message @UntypedRaw.Ptr v + Nothing -> Message.newMessage Nothing + payload <- new @R.Payload () msg + payload & setField #content (Raw mcontent) + payload & encodeField #capTable capTable + ret <- new @R.Return () msg + setVariant #results ret payload + ret & encodeField #answerId (qaWord answerId) + ret & encodeField #releaseParamCaps releaseParamCaps + rpcMsg <- newRoot @R.Message () msg + setVariant #return rpcMsg ret + pure msg + sendRawMsg conn' msg onSent + Return'exception exn -> + sendPureMsg + conn' + ( R.Message'return + R.Return + { answerId = qaWord answerId, + releaseParamCaps, + union' = R.Return'exception exn + } + ) + onSent + Return'canceled -> + sendPureMsg + conn' + ( R.Message'return + R.Return + { answerId = qaWord answerId, + releaseParamCaps, + union' = R.Return'canceled + } + ) + onSent + Return'resultsSentElsewhere -> + sendPureMsg + conn' + ( R.Message'return + R.Return + { answerId = qaWord answerId, + releaseParamCaps, + union' = R.Return'resultsSentElsewhere + } + ) + onSent + Return'takeFromOtherQuestion (QAId qid) -> + sendPureMsg + conn' + ( R.Message'return + R.Return + { answerId = qaWord answerId, + releaseParamCaps, + union' = R.Return'takeFromOtherQuestion qid + } + ) + onSent + Return'acceptFromThirdParty ptr -> do + msg <- createPure defaultLimit $ do + mptr <- traverse thaw ptr + msg <- case mptr of + Just v -> pure $ UntypedRaw.message @UntypedRaw.Ptr v + Nothing -> Message.newMessage Nothing + ret <- new @R.Return () msg + ret & encodeField #answerId (qaWord answerId) + ret & encodeField #releaseParamCaps releaseParamCaps + setVariant #acceptFromThirdParty ret (Raw @(Maybe B.AnyPointer) mptr) + rpcMsg <- newRoot @R.Message () msg + setVariant #return rpcMsg ret + pure msg + sendRawMsg conn' msg onSent + +acceptReturn :: Conn -> Raw R.Return 'Const -> LimitT STM Return +acceptReturn conn ret = do + let answerId = QAId (getField #answerId ret) + releaseParamCaps = getField #releaseParamCaps ret + which <- structWhich ret + union' <- case which of + R.RW_Return'results payload -> + Return'results <$> acceptPayload conn payload + R.RW_Return'exception exn -> + Return'exception <$> parse exn + R.RW_Return'canceled _ -> + pure Return'canceled + R.RW_Return'resultsSentElsewhere _ -> + pure Return'resultsSentElsewhere + R.RW_Return'takeFromOtherQuestion id -> + Return'takeFromOtherQuestion . QAId <$> parse id + R.RW_Return'acceptFromThirdParty (Raw ptr) -> + pure $ Return'acceptFromThirdParty ptr + R.RW_Return'unknown' ordinal -> + lift $ throwSTM $ eFailed $ "Unknown return variant #" <> fromString (show ordinal) + pure Return {answerId, releaseParamCaps, union'} + +handleReturnMsg :: Conn -> Return -> STM () +handleReturnMsg conn ret = + getLive conn >>= \conn'@Conn' {questions} -> + updateQAReturn conn' questions "question" ret + +handleFinishMsg :: Conn -> R.Parsed R.Finish -> STM () +handleFinishMsg conn finish = + getLive conn >>= \conn'@Conn' {answers} -> + updateQAFinish conn' answers "answer" finish + +handleResolveMsg :: Conn -> R.Parsed R.Resolve -> STM () +handleResolveMsg conn R.Resolve {promiseId, union'} = + getLive conn >>= \conn'@Conn' {imports} -> do + entry <- M.lookup (IEId promiseId) imports + case entry of + Nothing -> + -- This can happen if we dropped the promise, but the release + -- message is still in flight when the resolve message is sent. + case union' of + R.Resolve'cap R.CapDescriptor {union' = R.CapDescriptor'receiverHosted importId} -> do + (_, onSent) <- newPromise + -- Send a release message for the resolved cap, since + -- we're not going to use it: + sendPureMsg + conn' + ( R.Message'release + def + { R.id = importId, + R.referenceCount = 1 + } + ) + onSent + -- Note [Level 3]: do we need to do something with + -- thirdPartyHosted here? + _ -> pure () + Just EntryI {promiseState = Nothing} -> + -- This wasn't a promise! The remote vat has done something wrong; + -- abort the connection. + abortConn conn' $ + eFailed $ + mconcat + [ "Received a resolve message for export id #", + fromString (show promiseId), + ", but that capability is not a promise!" + ] + Just EntryI {promiseState = Just (tvar, tmpDest)} -> + case union' of + R.Resolve'cap R.CapDescriptor {union' = cap} -> do + client <- acceptCap conn cap + resolveClientClient tmpDest (writeTVar tvar) client + R.Resolve'exception exn -> + resolveClientExn tmpDest (writeTVar tvar) exn + R.Resolve'unknown' tag -> + abortConn conn' $ + eUnimplemented $ + mconcat + [ "Resolve variant #", + fromString (show tag), + " not understood" + ] + +handleReleaseMsg :: Conn -> R.Parsed R.Release -> STM () +handleReleaseMsg + conn + R.Release + { id = (IEId -> eid), + referenceCount = refCountDiff + } = + releaseExport conn refCountDiff eid + +releaseExport :: Conn -> Word32 -> IEId -> STM () +releaseExport conn refCountDiff eid = + getLive conn >>= \conn'@Conn' {exports} -> + lookupAbort "export" conn' exports eid $ + \EntryE {client, refCount = oldRefCount} -> + case compare oldRefCount refCountDiff of + LT -> + abortConn conn' $ + eFailed $ + "Received release for export with referenceCount " + <> "greater than our recorded total ref count." + EQ -> + dropConnExport conn client + GT -> + M.insert + EntryE + { client, + refCount = oldRefCount - refCountDiff + } + eid + exports + +handleDisembargoMsg :: Conn -> R.Parsed R.Disembargo -> STM () +handleDisembargoMsg conn d = getLive conn >>= go d + where + go + R.Disembargo + { context = + R.Disembargo'context' + (R.Disembargo'context'receiverLoopback (EmbargoId -> eid)) + } + conn'@Conn' {embargos} = + do + result <- M.lookup eid embargos + case result of + Nothing -> + abortConn conn' $ + eFailed $ + "No such embargo: " <> fromString (show $ embargoWord eid) + Just fulfiller -> do + queueSTM conn' (fulfill fulfiller ()) + M.delete eid embargos + freeEmbargo conn' eid + go + R.Disembargo + { target = R.MessageTarget target, + context = R.Disembargo'context' (R.Disembargo'context'senderLoopback embargoId) + } + conn'@Conn' {exports, answers} = + case target of + R.MessageTarget'importedCap exportId -> + lookupAbort "export" conn' exports (IEId exportId) $ \EntryE {client} -> + disembargoPromise client + R.MessageTarget'promisedAnswer R.PromisedAnswer {questionId, transform} -> + lookupAbort "answer" conn' answers (QAId questionId) $ \case + HaveReturn {returnMsg = Return {union' = Return'results Payload {content}}} -> + transformClient transform content conn' >>= \case + (unwrapClient -> Just client') -> disembargoClient client' + (unwrapClient -> Nothing) -> abortDisembargo "targets a null capability" + _ -> + abortDisembargo $ + "does not target an answer which has resolved to a value hosted by" + <> " the sender." + R.MessageTarget'unknown' ordinal -> + abortConn conn' $ + eUnimplemented $ + "Unknown MessageTarget ordinal #" <> fromString (show ordinal) + where + disembargoPromise PromiseClient {pState} = + readTVar pState >>= \case + Ready (unwrapClient -> Just client) -> + disembargoClient client + Ready (unwrapClient -> Nothing) -> + abortDisembargo "targets a promise which resolved to null." + _ -> + abortDisembargo "targets a promise which has not resolved." + disembargoPromise _ = + abortDisembargo "targets something that is not a promise." + + disembargoClient (ImportClient cell) = do + client <- Fin.readCell cell + case client of + ImportRef {conn = targetConn, importId} + | conn == targetConn -> do + (_, onSent) <- newPromise + sendPureMsg + conn' + ( R.Message'disembargo + R.Disembargo + { context = + R.Disembargo'context' $ + R.Disembargo'context'receiverLoopback embargoId, + target = + R.MessageTarget $ + R.MessageTarget'importedCap (ieWord importId) + } + ) + onSent + _ -> + abortDisembargoClient + disembargoClient _ = abortDisembargoClient + + abortDisembargoClient = + abortDisembargo $ + "targets a promise which has not resolved to a capability" + <> " hosted by the sender." + + abortDisembargo info = + abortConn conn' $ + eFailed $ + mconcat + [ "Disembargo #", + fromString (show embargoId), + " with context = senderLoopback ", + info + ] + -- Note [Level 3] + go d conn' = do + (_, onSent) <- newPromise + sendPureMsg + conn' + (R.Message'unimplemented $ R.Message $ R.Message'disembargo d) + onSent + +lookupAbort :: + (Eq k, Hashable k, Show k) => + Text -> + Conn' -> + M.Map k v -> + k -> + (v -> STM a) -> + STM a +lookupAbort keyTypeName conn m key f = do + result <- M.lookup key m + case result of + Just val -> + f val + Nothing -> + abortConn conn $ + eFailed $ + mconcat + [ "No such ", + keyTypeName, + ": ", + fromString (show key) + ] + +-- | @'insertNewAbort' keyTypeName conn key value stmMap@ inserts a key into a +-- map, aborting the connection if it is already present. @keyTypeName@ will be +-- used in the error message sent to the remote vat. +insertNewAbort :: (Eq k, Hashable k) => Text -> Conn' -> k -> v -> M.Map k v -> STM () +insertNewAbort keyTypeName conn key value = + M.focus + ( Focus.alterM $ \case + Just _ -> + abortConn conn $ + eFailed $ + "duplicate entry in " <> keyTypeName <> " table." + Nothing -> + pure (Just value) + ) + key + +-- | Generate a cap table describing the capabilities reachable from the given +-- pointer. The capability table will be correct for any message where all of +-- the capabilities are within the subtree under the pointer. +genSendableCapTableRaw :: + Conn -> + Maybe (UntypedRaw.Ptr 'Const) -> + STM (V.Vector (R.Parsed R.CapDescriptor)) +genSendableCapTableRaw _ Nothing = pure V.empty +genSendableCapTableRaw conn (Just ptr) = + traverse + ( \c -> do + union' <- emitCap conn c + pure (def :: R.Parsed R.CapDescriptor) {R.union' = union'} + ) + (Message.getCapTable (UntypedRaw.message @UntypedRaw.Ptr ptr)) + +-- | Convert the pointer into a Payload, including a capability table for +-- the clients in the pointer's cap table. +makeOutgoingPayload :: Conn -> RawMPtr -> STM Payload +makeOutgoingPayload conn content = do + capTable <- genSendableCapTableRaw conn content + pure Payload {content, capTable} + +sendPureMsg :: Conn' -> R.Parsed (Which R.Message) -> Fulfiller () -> STM () +sendPureMsg Conn' {sendQ} msg onSent = do + msg <- createPure maxBound (parsedToMsg (R.Message msg)) + writeTChan sendQ (msg, onSent) + +-- | Send a finish message, updating connection state and triggering +-- callbacks as necessary. +finishQuestion :: Conn' -> R.Parsed R.Finish -> STM () +finishQuestion conn@Conn' {questions} finish@R.Finish {questionId} = do + -- arrange for the question ID to be returned to the pool once + -- the return has also been received: + subscribeReturn "question" conn questions (QAId questionId) $ \_ -> + freeQuestion conn (QAId questionId) + (_, onSent) <- newPromise + sendPureMsg conn (R.Message'finish finish) onSent + updateQAFinish conn questions "question" finish + +-- | Send a return message, update the corresponding entry in our +-- answers table, and queue any registered callbacks. Calls 'error' +-- if the answerId is not in the table, or if we've already sent a +-- return for this answer. +returnAnswer :: Conn' -> Return -> STM () +returnAnswer conn@Conn' {answers} ret = do + sendReturn conn ret + updateQAReturn conn answers "answer" ret + +-- TODO(cleanup): updateQAReturn/Finish have a lot in common; can we refactor? + +updateQAReturn :: Conn' -> M.Map QAId EntryQA -> Text -> Return -> STM () +updateQAReturn conn table tableName ret@Return {answerId} = + lookupAbort tableName conn table answerId $ \case + NewQA {onFinish, onReturn} -> do + M.insert + HaveReturn + { returnMsg = ret, + onFinish + } + answerId + table + traverse_ ($ ret) onReturn + HaveFinish {onReturn} -> do + M.delete answerId table + traverse_ ($ ret) onReturn + HaveReturn {} -> + abortConn conn $ + eFailed $ + "Duplicate return message for " + <> tableName + <> " #" + <> fromString (show answerId) + +updateQAFinish :: Conn' -> M.Map QAId EntryQA -> Text -> R.Parsed R.Finish -> STM () +updateQAFinish conn table tableName finish@R.Finish {questionId} = + lookupAbort tableName conn table (QAId questionId) $ \case + NewQA {onFinish, onReturn} -> do + traverse_ ($ finish) onFinish + M.insert + HaveFinish + { finishMsg = finish, + onReturn + } + (QAId questionId) + table + HaveReturn {onFinish} -> do + traverse_ ($ finish) onFinish + M.delete (QAId questionId) table + HaveFinish {} -> + abortConn conn $ + eFailed $ + "Duplicate finish message for " + <> tableName + <> " #" + <> fromString (show questionId) + +-- | Update an entry in the questions or answers table to queue the given +-- callback when the return message for that answer comes in. If the return +-- has already arrived, the callback is queued immediately. +-- +-- If the entry already has other callbacks registered, this callback is +-- run *after* the others (see Note [callbacks]). Note that this is an +-- important property, as it is necessary to preserve E-order if the +-- callbacks are successive method calls on the returned object. +subscribeReturn :: Text -> Conn' -> M.Map QAId EntryQA -> QAId -> (Return -> STM ()) -> STM () +subscribeReturn tableName conn table qaId onRet = + lookupAbort tableName conn table qaId $ \qa -> do + new <- go qa + M.insert new qaId table + where + go = \case + NewQA {onFinish, onReturn} -> + pure + NewQA + { onFinish, + onReturn = SnocList.snoc onReturn onRet + } + HaveFinish {finishMsg, onReturn} -> + pure + HaveFinish + { finishMsg, + onReturn = SnocList.snoc onReturn onRet + } + val@HaveReturn {returnMsg} -> do + onRet returnMsg + pure val + +-- | Abort the connection, sending an abort message. This is only safe to call +-- from within either the thread running the receieve loop or the callback loop. +abortConn :: Conn' -> R.Parsed R.Exception -> STM a +abortConn _ e = throwSTM (SentAbort e) + +-- | Gets the live connection state, or throws disconnected if it is not live. +getLive :: Conn -> STM Conn' +getLive Conn {liveState} = + readTVar liveState >>= \case + Live conn' -> pure conn' + Dead -> throwSTM eDisconnected + +-- | Performs an action with the live connection state. Does nothing if the +-- connection is dead. +whenLive :: Conn -> (Conn' -> STM ()) -> STM () +whenLive Conn {liveState} f = + readTVar liveState >>= \case + Live conn' -> f conn' + Dead -> pure () + +-- | Request the remote vat's bootstrap interface. +requestBootstrap :: Conn -> STM Client +requestBootstrap conn@Conn {liveState} = + readTVar liveState >>= \case + Dead -> + pure nullClient + Live conn'@Conn' {questions} -> do + qid <- newQuestion conn' + let tmpDest = + RemoteDest + AnswerDest + { conn, + answer = + PromisedAnswer + { answerId = qid, + transform = SnocList.empty + } + } + pState <- newTVar Pending {tmpDest} + + -- Arguably, we should wait for this promise, since it's analagous + -- to a call in terms of operation, but we only send one of these + -- per connection, so whatever. + (_, onSent) <- newPromise + sendPureMsg + conn' + (R.Message'bootstrap (def {R.questionId = qaWord qid} :: R.Parsed R.Bootstrap)) + onSent + + M.insert + NewQA + { onReturn = + SnocList.fromList + [ resolveClientReturn tmpDest (writeTVar pState) conn' [], + \_ -> + finishQuestion + conn' + R.Finish + { questionId = qaWord qid, + releaseResultCaps = False + } + ], + onFinish = SnocList.empty + } + qid + questions + exportMap <- ExportMap <$> M.new + pure $ + wrapClient $ + Just + PromiseClient + { pState, + exportMap, + origTarget = tmpDest + } + +-- Note [resolveClient] +-- ==================== +-- +-- There are several functions resolveClient*, each of which resolves a +-- 'PromiseClient', which will previously have been in the 'Pending' state. +-- Each function accepts three parameters: the 'TmpDest' that the +-- pending promise had been targeting, a function for setting the new state, +-- and a thing to resolve the promise to. The type of the latter is specific +-- to each function. + +-- | Resolve a promised client to an exception. See Note [resolveClient] +resolveClientExn :: TmpDest -> (PromiseState -> STM ()) -> R.Parsed R.Exception -> STM () +resolveClientExn tmpDest resolve exn = do + case tmpDest of + LocalDest LocalBuffer {callBuffer} -> do + calls <- flushTQueue callBuffer + traverse_ + ( \Server.CallInfo {response} -> + breakPromise response exn + ) + calls + RemoteDest AnswerDest {} -> + pure () + RemoteDest (ImportDest _) -> + pure () + resolve $ Error exn + +-- Resolve a promised client to a pointer. If it is a non-null non-capability +-- pointer, it resolves to an exception. See Note [resolveClient] +resolveClientPtr :: TmpDest -> (PromiseState -> STM ()) -> RawMPtr -> STM () +resolveClientPtr tmpDest resolve ptr = case ptr of + Nothing -> + resolveClientClient tmpDest resolve nullClient + Just (UntypedRaw.PtrCap c) -> do + c' <- evalLimitT defaultLimit $ UntypedRaw.getClient c + resolveClientClient tmpDest resolve c' + Just _ -> + resolveClientExn tmpDest resolve $ + eFailed "Promise resolved to non-capability pointer" + +-- | Resolve a promised client to another client. See Note [resolveClient] +resolveClientClient :: TmpDest -> (PromiseState -> STM ()) -> Client -> STM () +resolveClientClient tmpDest resolve (unwrapClient -> client) = + case (client, tmpDest) of + -- Remote resolved to local; we need to embargo: + (Just LocalClient {}, RemoteDest dest) -> + disembargoAndResolve dest + (Just PromiseClient {origTarget = LocalDest _}, RemoteDest dest) -> + disembargoAndResolve dest + (Nothing, RemoteDest _) -> + -- If it resolves to a null client, then we can't send a disembargo. + -- Note that this may result in futrther calls throwing exceptions + -- /before/ the outstanding calls, which is a bit weird. But all + -- calls will throw at some point, so it's probably fine. + resolveNow + -- Local promises never need embargos; we can just forward: + (_, LocalDest LocalBuffer {callBuffer}) -> + flushAndResolve callBuffer + -- These cases are slightly subtle; despite resolving to a + -- client that points at a "remote" target, if it points into a + -- _different_ connection, we must be proxying it, so we treat + -- it as local and do a disembargo like above. We may need to + -- change this when we implement level 3, since third-party + -- handoff is a possibility; see Note [Level 3]. + -- + -- If it's pointing into the same connection, we don't need to + -- do a disembargo. + (Just PromiseClient {origTarget = RemoteDest newDest}, RemoteDest oldDest) -> do + newConn <- destConn newDest + oldConn <- destConn oldDest + if newConn == oldConn + then resolveNow + else disembargoAndResolve oldDest + (Just (ImportClient cell), RemoteDest oldDest) -> do + ImportRef {conn = newConn} <- Fin.readCell cell + oldConn <- destConn oldDest + if newConn == oldConn + then resolveNow + else disembargoAndResolve oldDest + where + destConn AnswerDest {conn} = pure conn + destConn (ImportDest cell) = do + ImportRef {conn} <- Fin.readCell cell + pure conn + destTarget AnswerDest {answer} = pure $ AnswerTgt answer + destTarget (ImportDest cell) = do + ImportRef {importId} <- Fin.readCell cell + pure $ ImportTgt importId + + resolveNow = do + resolve $ Ready (wrapClient client) + + -- Flush the call buffer into the client's queue, and then pass the client + -- to resolve. + flushAndResolve callBuffer = do + flushTQueue callBuffer >>= traverse_ (`call` wrapClient client) + resolve $ Ready (wrapClient client) + flushAndRaise callBuffer e = + flushTQueue callBuffer + >>= traverse_ (\Server.CallInfo {response} -> breakPromise response e) + disembargoAndResolve dest = do + Conn {liveState} <- destConn dest + readTVar liveState >>= \case + Live conn' -> do + callBuffer <- newTQueue + target <- destTarget dest + disembargo conn' target $ \case + Right () -> + flushAndResolve callBuffer + Left e -> + flushAndRaise callBuffer e + resolve $ Embargo {callBuffer} + Dead -> + resolveClientExn tmpDest resolve eDisconnected + +-- | Send a (senderLoopback) disembargo to the given message target, and +-- register the transaction to run when the corresponding receiverLoopback +-- message is received. +-- +-- The callback may be handed a 'Left' with a disconnected exception if +-- the connection is dropped before the disembargo is echoed. +disembargo :: Conn' -> MsgTarget -> (Either (R.Parsed R.Exception) () -> STM ()) -> STM () +disembargo conn@Conn' {embargos} tgt onEcho = do + callback <- newCallback onEcho + eid <- newEmbargo conn + M.insert callback eid embargos + (_, onSent) <- newPromise + sendPureMsg + conn + ( R.Message'disembargo + R.Disembargo + { target = marshalMsgTarget tgt, + context = + R.Disembargo'context' $ + R.Disembargo'context'senderLoopback (embargoWord eid) + } + ) + onSent + +-- | Resolve a promised client to the result of a return. See Note [resolveClient] +-- +-- The [Word16] is a list of pointer indexes to follow from the result. +resolveClientReturn :: TmpDest -> (PromiseState -> STM ()) -> Conn' -> [Word16] -> Return -> STM () +resolveClientReturn tmpDest resolve conn@Conn' {answers} transform Return {union'} = case union' of + -- TODO(cleanup) there is a lot of redundency betwen this and cbCallReturn; can + -- we refactor? + Return'exception exn -> + resolveClientExn tmpDest resolve exn + Return'results Payload {content} -> do + res <- try $ evalLimitT defaultLimit $ followPtrs transform content + case res of + Right v -> + resolveClientPtr tmpDest resolve v + Left e -> + resolveClientExn tmpDest resolve e + Return'canceled -> + resolveClientExn tmpDest resolve $ eFailed "Canceled" + Return'resultsSentElsewhere -> + -- Should never happen; we don't set sendResultsTo to anything other than + -- caller. + abortConn conn $ + eFailed $ + mconcat + [ "Received Return.resultsSentElsewhere for a call ", + "with sendResultsTo = caller." + ] + Return'takeFromOtherQuestion qid -> + subscribeReturn "answer" conn answers qid $ + resolveClientReturn tmpDest resolve conn transform + Return'acceptFromThirdParty _ -> + -- Note [Level 3] + abortConn conn $ + eUnimplemented + "This vat does not support level 3." + +-- | Get the client's export ID for this connection, or allocate a new one if needed. +-- If this is the first time this client has been exported on this connection, +-- bump the refcount. +getConnExport :: Conn -> Client' -> STM IEId +getConnExport conn client = + getLive conn >>= \conn'@Conn' {exports} -> do + ExportMap m <- clientExportMap client + val <- M.lookup conn m + case val of + Just eid -> do + addBumpExport eid client exports + pure eid + Nothing -> do + eid <- newExport conn' + addBumpExport eid client exports + M.insert eid conn m + pure eid + +-- | Remove export of the client on the connection. This entails removing it +-- from the export id, removing the connection from the client's ExportMap, +-- freeing the export id, and dropping the client's refcount. +dropConnExport :: Conn -> Client' -> STM () +dropConnExport conn client' = do + ExportMap eMap <- clientExportMap client' + val <- M.lookup conn eMap + case val of + Just eid -> do + M.delete conn eMap + whenLive conn $ \conn'@Conn' {exports} -> do + M.delete eid exports + freeExport conn' eid + Nothing -> + error "BUG: tried to drop an export that doesn't exist." + +clientExportMap :: Client' -> STM ExportMap +clientExportMap LocalClient {exportMap} = pure exportMap +clientExportMap PromiseClient {exportMap} = pure exportMap +clientExportMap (ImportClient cell) = do + ImportRef {proxies} <- Fin.readCell cell + pure proxies + +-- | insert the client into the exports table, bumping the refcount if it is +-- already there. If a different client is already in the table at the same +-- id, call 'error'. +addBumpExport :: IEId -> Client' -> M.Map IEId EntryE -> STM () +addBumpExport exportId client = + M.focus (Focus.alter go) exportId + where + go Nothing = Just EntryE {client, refCount = 1} + go (Just EntryE {client = oldClient, refCount}) + | client /= oldClient = + error $ + "BUG: addExportRef called with a client that is different " + ++ "from what is already in our exports table." + | otherwise = + Just EntryE {client, refCount = refCount + 1} + +-- | Generate a CapDescriptor', which we can send to the connection's remote +-- vat to identify client. In the process, this may allocate export ids, update +-- reference counts, and so forth. +emitCap :: Conn -> Client -> STM (R.Parsed (Which R.CapDescriptor)) +emitCap _targetConn (unwrapClient -> Nothing) = + pure R.CapDescriptor'none +emitCap targetConn (unwrapClient -> Just client') = case client' of + LocalClient {} -> + R.CapDescriptor'senderHosted . ieWord <$> getConnExport targetConn client' + PromiseClient {pState} -> + readTVar pState >>= \case + Pending {tmpDest = RemoteDest AnswerDest {conn, answer}} + | conn == targetConn -> + pure $ R.CapDescriptor'receiverAnswer (marshalPromisedAnswer answer) + Pending {tmpDest = RemoteDest (ImportDest cell)} -> do + ImportRef {conn, importId = IEId iid} <- Fin.readCell cell + if conn == targetConn + then pure (R.CapDescriptor'receiverHosted iid) + else newSenderPromise + _ -> + newSenderPromise + ImportClient cell -> do + ImportRef {conn = hostConn, importId} <- Fin.readCell cell + if hostConn == targetConn + then pure (R.CapDescriptor'receiverHosted (ieWord importId)) + else R.CapDescriptor'senderHosted . ieWord <$> getConnExport targetConn client' + where + newSenderPromise = R.CapDescriptor'senderPromise . ieWord <$> getConnExport targetConn client' + +acceptPayload :: Conn -> Raw R.Payload 'Const -> LimitT STM Payload +acceptPayload conn payload = do + capTable <- parseField #capTable payload + clients <- lift $ traverse (\R.CapDescriptor {union'} -> acceptCap conn union') capTable + Raw rawContent <- readField #content payload + content <- traverse (UntypedRaw.tMsg (pure . Message.withCapTable clients)) rawContent + pure Payload {content, capTable} + +-- | 'acceptCap' is a dual of 'emitCap'; it derives a Client from a CapDescriptor' +-- received via the connection. May update connection state as necessary. +acceptCap :: Conn -> R.Parsed (Which R.CapDescriptor) -> STM Client +acceptCap conn cap = getLive conn >>= \conn' -> go conn' cap + where + go _ R.CapDescriptor'none = pure (wrapClient Nothing) + go conn'@Conn' {imports} (R.CapDescriptor'senderHosted (IEId -> importId)) = do + entry <- M.lookup importId imports + case entry of + Just EntryI {promiseState = Just _} -> + let imp = fromString (show importId) + in abortConn conn' $ + eFailed $ + "received senderHosted capability #" + <> imp + <> ", but the imports table says #" + <> imp + <> " is senderPromise." + Just ent@EntryI {localRc, remoteRc, proxies} -> do + Rc.incr localRc + M.insert ent {localRc, remoteRc = remoteRc + 1} importId imports + cell <- + Fin.newCell + ImportRef + { conn, + importId, + proxies + } + queueIO conn' $ Fin.addFinalizer cell $ atomically $ Rc.decr localRc + pure $ wrapClient $ Just $ ImportClient cell + Nothing -> + wrapClient . Just . ImportClient <$> newImport importId conn Nothing + go conn'@Conn' {imports} (R.CapDescriptor'senderPromise (IEId -> importId)) = do + entry <- M.lookup importId imports + case entry of + Just EntryI {promiseState = Nothing} -> + let imp = fromString (show importId) + in abortConn conn' $ + eFailed $ + "received senderPromise capability #" + <> imp + <> ", but the imports table says #" + <> imp + <> " is senderHosted." + Just ent@EntryI {remoteRc, proxies, promiseState = Just (pState, origTarget)} -> do + M.insert ent {remoteRc = remoteRc + 1} importId imports + pure $ + wrapClient $ + Just + PromiseClient + { pState, + exportMap = proxies, + origTarget + } + Nothing -> do + rec imp <- newImport importId conn (Just (pState, tmpDest)) + ImportRef {proxies} <- Fin.readCell imp + let tmpDest = RemoteDest (ImportDest imp) + pState <- newTVar Pending {tmpDest} + pure $ + wrapClient $ + Just + PromiseClient + { pState, + exportMap = proxies, + origTarget = tmpDest + } + go conn'@Conn' {exports} (R.CapDescriptor'receiverHosted exportId) = + lookupAbort "export" conn' exports (IEId exportId) $ + \EntryE {client} -> + pure $ wrapClient $ Just client + go conn' (R.CapDescriptor'receiverAnswer pa) = do + pa <- unmarshalPromisedAnswer pa `catchSTM` abortConn conn' + newLocalAnswerClient conn' pa + go conn' (R.CapDescriptor'thirdPartyHosted _) = + -- Note [Level 3] + abortConn conn' $ + eUnimplemented + "thirdPartyHosted unimplemented; level 3 is not supported." + go conn' (R.CapDescriptor'unknown' tag) = + abortConn conn' $ + eUnimplemented $ + "Unimplemented CapDescriptor variant #" <> fromString (show tag) + +-- | Create a new entry in the imports table, with the given import id and +-- 'promiseState', and return a corresponding ImportRef. When the ImportRef is +-- garbage collected, the refcount in the table will be decremented. +newImport :: IEId -> Conn -> Maybe (TVar PromiseState, TmpDest) -> STM (Fin.Cell ImportRef) +newImport importId conn promiseState = + getLive conn >>= \conn'@Conn' {imports} -> do + localRc <- Rc.new () $ releaseImport importId conn' + proxies <- ExportMap <$> M.new + let importRef = + ImportRef + { conn, + importId, + proxies + } + M.insert + EntryI + { localRc, + remoteRc = 1, + proxies, + promiseState + } + importId + imports + cell <- Fin.newCell importRef + queueIO conn' $ Fin.addFinalizer cell $ atomically $ Rc.decr localRc + pure cell + +-- | Release the identified import. Removes it from the table and sends a release +-- message with the correct count. +releaseImport :: IEId -> Conn' -> STM () +releaseImport importId conn'@Conn' {imports} = do + (_, onSent) <- newPromise + lookupAbort "imports" conn' imports importId $ \EntryI {remoteRc} -> + sendPureMsg + conn' + ( R.Message'release + R.Release + { id = ieWord importId, + referenceCount = remoteRc + } + ) + onSent + M.delete importId imports + +-- | Create a new client targeting an object in our answers table. +-- Important: in this case the 'PromisedAnswer' refers to a question we +-- have recevied, not sent. +newLocalAnswerClient :: Conn' -> PromisedAnswer -> STM Client +newLocalAnswerClient conn@Conn' {answers} PromisedAnswer {answerId, transform} = do + callBuffer <- newTQueue + let tmpDest = LocalDest $ LocalBuffer {callBuffer} + pState <- newTVar Pending {tmpDest} + subscribeReturn "answer" conn answers answerId $ + resolveClientReturn + tmpDest + (writeTVar pState) + conn + (toList transform) + exportMap <- ExportMap <$> M.new + pure $ + wrapClient $ + Just + PromiseClient + { pState, + exportMap, + origTarget = tmpDest + } + +-- Note [Limiting resource usage] +-- ============================== +-- +-- N.B. much of this Note is future tense; the library is not yet robust against +-- resource useage attacks. +-- +-- We employ various strategies to prevent remote vats from causing excessive +-- resource usage. In particular: +-- + +-- * We set a maximum size for incoming messages; this is in keeping with how + +-- we mitigate these concerns when dealing with plain capnp data (i.e. not +-- rpc). + +-- * We set a limit on the total *size* of all messages from the remote vat that + +-- are currently being serviced. For example, if a Call message comes in, +-- we note its size, and deduct it from the quota. Once we have sent a return +-- and received a finish for this call, and thus can safely forget about it, +-- we remove it from our answers table, and add its size back to the available +-- quota. +-- +-- Still TBD: +-- + +-- * We should come up with some way of guarding against too many intra-vat calls; + +-- depending on the object graph, it may be possible for an attacker to get us +-- to "eat our own tail" so to speak. +-- +-- Ideas: +-- * Per-object bounded queues for messages +-- * Global limit on intra-vat calls. +-- +-- Right now I(zenhack) am more fond of the former. +-- + +-- * What should we actually do when limits are exceeded? + -- -- Possible strategies: -- * Block diff --git a/lib/Capnp/Rpc/Untyped.hs-boot b/lib/Capnp/Rpc/Untyped.hs-boot deleted file mode 100644 --- a/lib/Capnp/Rpc/Untyped.hs-boot +++ /dev/null @@ -1,9 +0,0 @@ -module Capnp.Rpc.Untyped where - -data Client -data Pipeline - -nullClient :: Client - -instance Eq Client -instance Show Client diff --git a/lib/Capnp/TraversalLimit.hs b/lib/Capnp/TraversalLimit.hs --- a/lib/Capnp/TraversalLimit.hs +++ b/lib/Capnp/TraversalLimit.hs @@ -1,70 +1,74 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{- | -Module: Capnp.TraversalLimit -Description: Support for managing message traversal limits. - -This module is used to mitigate several pitfalls with the capnproto format, -which could potentially lead to denial of service vulnerabilities. - -In particular, while they are illegal according to the spec, it is possible to -encode objects which have many pointers pointing the same place, or even -cycles. A naive traversal therefore could involve quite a lot of computation -for a message that is very small on the wire. - -Accordingly, most implementations of the format keep track of how many bytes -of a message have been accessed, and start signaling errors after a certain -value (the "traversal limit") has been reached. The Haskell implementation is -no exception; this module implements that logic. We provide a monad -transformer and mtl-style type class to track the limit; reading from the -message happens inside of this monad. +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} --} +-- | +-- Module: Capnp.TraversalLimit +-- Description: Support for managing message traversal limits. +-- +-- This module is used to mitigate several pitfalls with the capnproto format, +-- which could potentially lead to denial of service vulnerabilities. +-- +-- In particular, while they are illegal according to the spec, it is possible to +-- encode objects which have many pointers pointing the same place, or even +-- cycles. A naive traversal therefore could involve quite a lot of computation +-- for a message that is very small on the wire. +-- +-- Accordingly, most implementations of the format keep track of how many bytes +-- of a message have been accessed, and start signaling errors after a certain +-- value (the "traversal limit") has been reached. The Haskell implementation is +-- no exception; this module implements that logic. We provide a monad +-- transformer and mtl-style type class to track the limit; reading from the +-- message happens inside of this monad. module Capnp.TraversalLimit - ( MonadLimit(..) - , LimitT - , runLimitT - , evalLimitT - , execLimitT - , defaultLimit - ) where - -import Prelude hiding (fail) - -import Control.Monad (when) -import Control.Monad.Catch (MonadCatch(catch), MonadThrow(throwM)) -import Control.Monad.Fail (MonadFail (..)) -import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Primitive (PrimMonad(primitive), PrimState) -import Control.Monad.State.Strict - (MonadState, StateT, evalStateT, execStateT, get, put, runStateT) -import Control.Monad.Trans.Class (MonadTrans(lift)) + ( MonadLimit (..), + LimitT, + runLimitT, + evalLimitT, + execLimitT, + defaultLimit, + ) +where -- Just to define 'MonadLimit' instances: -import Control.Monad.RWS (RWST) -import Control.Monad.Reader (ReaderT) -import Control.Monad.Writer (WriterT) +import Capnp.Bits (WordCount) +import Capnp.Errors (Error (TraversalLimitError)) +import Control.Monad (when) +import Control.Monad.Catch (MonadCatch (catch), MonadThrow (throwM)) +import Control.Monad.Fail (MonadFail (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Primitive (PrimMonad (primitive), PrimState) +import Control.Monad.RWS (RWST) +import Control.Monad.Reader (ReaderT) import qualified Control.Monad.State.Lazy as LazyState - -import Capnp.Bits (WordCount) -import Capnp.Errors (Error(TraversalLimitError)) +import Control.Monad.State.Strict + ( MonadState, + StateT, + evalStateT, + execStateT, + get, + put, + runStateT, + ) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Control.Monad.Writer (WriterT) +import Prelude hiding (fail) -- | mtl-style type class to track the traversal limit. This is used -- by other parts of the library which actually do the reading. class Monad m => MonadLimit m where - -- | @'invoice' n@ deducts @n@ from the traversal limit, signaling - -- an error if the limit is exhausted. - invoice :: WordCount -> m () + -- | @'invoice' n@ deducts @n@ from the traversal limit, signaling + -- an error if the limit is exhausted. + invoice :: WordCount -> m () -- | Monad transformer implementing 'MonadLimit'. The underlying monad -- must implement 'MonadThrow'. 'invoice' calls @'throwM' 'TraversalLimitError'@ -- when the limit is exhausted. newtype LimitT m a = LimitT (StateT WordCount m a) - deriving(Functor, Applicative, Monad) + deriving (Functor, Applicative, Monad) -- | Run a 'LimitT', returning the value from the computation and the remaining -- traversal limit. @@ -86,50 +90,50 @@ ------ Instances of mtl type classes for 'LimitT'. instance MonadThrow m => MonadThrow (LimitT m) where - throwM = lift . throwM + throwM = lift . throwM instance MonadCatch m => MonadCatch (LimitT m) where - catch (LimitT m) f = LimitT $ do - catch m $ \e -> - let LimitT m' = f e in - m' + catch (LimitT m) f = LimitT $ do + catch m $ \e -> + let LimitT m' = f e + in m' instance MonadThrow m => MonadLimit (LimitT m) where - invoice deduct = LimitT $ do - limit <- get - when (limit < deduct) $ throwM TraversalLimitError - put (limit - deduct) + invoice deduct = LimitT $ do + limit <- get + when (limit < deduct) $ throwM TraversalLimitError + put (limit - deduct) instance MonadTrans LimitT where - lift = LimitT . lift + lift = LimitT . lift instance MonadState s m => MonadState s (LimitT m) where - get = lift get - put = lift . put + get = lift get + put = lift . put instance (PrimMonad m, s ~ PrimState m) => PrimMonad (LimitT m) where - type PrimState (LimitT m) = PrimState m - primitive = lift . primitive + type PrimState (LimitT m) = PrimState m + primitive = lift . primitive instance MonadFail m => MonadFail (LimitT m) where - fail = lift . fail + fail = lift . fail instance MonadIO m => MonadIO (LimitT m) where - liftIO = lift . liftIO + liftIO = lift . liftIO ------ Instances of 'MonadLimit' for standard monad transformers instance MonadLimit m => MonadLimit (StateT s m) where - invoice = lift . invoice + invoice = lift . invoice instance MonadLimit m => MonadLimit (LazyState.StateT s m) where - invoice = lift . invoice + invoice = lift . invoice instance (Monoid w, MonadLimit m) => MonadLimit (WriterT w m) where - invoice = lift . invoice + invoice = lift . invoice instance (MonadLimit m) => MonadLimit (ReaderT r m) where - invoice = lift . invoice + invoice = lift . invoice instance (Monoid w, MonadLimit m) => MonadLimit (RWST r w s m) where - invoice = lift . invoice + invoice = lift . invoice diff --git a/lib/Capnp/Tutorial.hs b/lib/Capnp/Tutorial.hs --- a/lib/Capnp/Tutorial.hs +++ b/lib/Capnp/Tutorial.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + -- | -- Module: Capnp.Tutorial -- Description: Tutorial for the Haskell Cap'N Proto library. @@ -8,17 +10,13 @@ -- -- Each of the example programs described here can also be found in the @examples/@ -- subdirectory in the source repository. -{-# OPTIONS_GHC -Wno-unused-imports #-} -module Capnp.Tutorial ( - -- * Overview +module Capnp.Tutorial + ( -- * Overview -- $overview -- * Setup -- $setup - -- * API Transition - -- $api-transition - -- * Serialization -- $serialization @@ -42,13 +40,14 @@ -- * RPC -- $rpc - ) where + ) +where -- So haddock references work: -import System.IO (stdout) import qualified Data.ByteString as BS -import qualified Data.Text as T +import qualified Data.Text as T +import System.IO (stdout) -- $overview -- @@ -67,25 +66,6 @@ -- which will compile the package and create the @capnpc-haskell@ executable -- at @$DIR/capnpc-haskell@. --- $api-transition --- --- This package is in them midst of transitioning many existing APIs over --- to a new design. As such, in this tuotrial we refer to the new api and the --- old API. --- --- The old API will eventually be removed, but not before there is at least --- one release where both APIs are present and the new API has reached feature --- pairty. Right now, the primary missing functionality is in implementing --- RPC servers (clients work fine, better even). --- --- This tutorial only covers the new API, but the tutorial for the old APIs --- is still available (and still correct) in the documentation for version --- 0.10 of this package: https://hackage.haskell.org/package/capnp-0.10.0.1 --- --- For more information about the reasons behind the new API, see: --- . TODO: link to blog post. - - -- $serialization -- -- The serialization API is roughly divided into two parts: a low level API @@ -163,15 +143,9 @@ -- This will create the following files relative to the current directory: -- -- * Capnp\/Gen\/Addressbook.hs --- * Capnp\/Gen\/Addressbook\/Pure.hs --- * Capnp\/Gen\/Addressbook\/New.hs --- * Capnp\/Gen\/ById\/Xcd6db6afb4a0cf5c/Pure.hs --- * Capnp\/Gen\/ById\/Xcd6db6afb4a0cf5c/New.hs -- * Capnp\/Gen\/ById\/Xcd6db6afb4a0cf5c.hs -- --- The modules under @ById@ are an implementation detail. --- @Capnp\/Gen\/Addressbook\.New.hs@ is generated code for use with the new API. --- Other files are for use with the old API, and not covered here. +-- The module under @ById@ is an implementation detail. -- -- The generated moule will export declarations like the following (cleaned up -- and abbreviated for readability): diff --git a/lib/Capnp/Untyped.hs b/lib/Capnp/Untyped.hs --- a/lib/Capnp/Untyped.hs +++ b/lib/Capnp/Untyped.hs @@ -1,1583 +1,1730 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-error=deprecations #-} -{-| -Module: Capnp.Untyped -Description: Utilities for reading capnproto messages with no schema. - -The types and functions in this module know about things like structs and -lists, but are not schema aware. - -Each of the data types exported by this module is parametrized over the -mutability of the message it contains (see "Capnp.Message"). --} -module Capnp.Untyped - ( - -- * Type-level descriptions of wire representations. - Repr(..) - , PtrRepr(..) - , ListRepr(..) - , NormalListRepr(..) - , DataSz(..) - - -- * Mapping representations to value types. - , Untyped - , UntypedData - , UntypedPtr - , UntypedSomePtr - , UntypedList - , UntypedSomeList - , IgnoreMut(..) - , MaybePtr(..) - , Unwrapped - - -- * Relating the representations of lists & their elements. - , Element(..) - , ListItem(..) - , ElemRepr - , ListReprFor - - -- * Working with pointers - , IsPtrRepr(..) - , IsListPtrRepr(..) - - -- * Allocating values - , Allocate(..) - , AllocateNormalList(..) - - , Ptr(..), List(..), Struct, ListOf, Cap - , structByteCount - , structWordCount - , structPtrCount - , structListByteCount - , structListWordCount - , structListPtrCount - , getData, getPtr - , setData, setPtr - , copyStruct - , copyPtr - , copyList - , copyCap - , getClient - , get, index - , setIndex - , take - , rootPtr - , setRoot - , rawBytes - , ReadCtx - , RWCtx - , HasMessage(..), MessageDefault(..) - , allocStruct - , allocCompositeList - , allocList0 - , allocList1 - , allocList8 - , allocList16 - , allocList32 - , allocList64 - , allocListPtr - , appendCap - - , TraverseMsg(..) - ) - where - -import Prelude hiding (length, take) - -import Data.Bits -import Data.Word - -import Control.Exception.Safe (impureThrow) -import Control.Monad (forM_, unless) -import Control.Monad.Catch (MonadCatch, MonadThrow(throwM)) -import Control.Monad.Catch.Pure (CatchT(runCatchT)) -import Control.Monad.Primitive (PrimMonad(..)) -import Control.Monad.ST (RealWorld) -import Control.Monad.Trans.Class (MonadTrans(lift)) -import Data.Coerce (coerce) -import Data.Function ((&)) -import Data.Kind (Type) - -import qualified Data.ByteString as BS -import qualified Language.Haskell.TH as TH - -import Capnp.Address - (OffsetError(..), WordAddr(..), pointerFrom, resolveOffset) -import Capnp.Bits - ( BitCount(..) - , ByteCount(..) - , Word1(..) - , WordCount(..) - , bitsToBytesCeil - , bytesToWordsCeil - , replaceBits - , wordsToBytes - ) -import Capnp.Mutability (MaybeMutable(..), Mutability(..)) -import Capnp.TraversalLimit (LimitT, MonadLimit(invoice)) -import Internal.BuildPure (PureBuilder) - -import qualified Capnp.Errors as E -import qualified Capnp.Message as M -import qualified Capnp.Pointer as P -import qualified Data.Vector.Storable.Mutable as SMV - -------------------------------------------------------------------------------- --- Untyped refernces to values in a message. -------------------------------------------------------------------------------- - --- | A an absolute pointer to a value (of arbitrary type) in a message. --- Note that there is no variant for far pointers, which don't make sense --- with absolute addressing. -data Ptr mut - = PtrCap (Cap mut) - | PtrList (List mut) - | PtrStruct (Struct mut) - --- | A list of values (of arbitrary type) in a message. -data List mut - = List0 (ListOf ('Data 'Sz0) mut) - | List1 (ListOf ('Data 'Sz1) mut) - | List8 (ListOf ('Data 'Sz8) mut) - | List16 (ListOf ('Data 'Sz16) mut) - | List32 (ListOf ('Data 'Sz32) mut) - | List64 (ListOf ('Data 'Sz64) mut) - | ListPtr (ListOf ('Ptr 'Nothing) mut) - | ListStruct (ListOf ('Ptr ('Just 'Struct)) mut) - --- | A "normal" (non-composite) list. -data NormalList mut = NormalList - { nPtr :: {-# UNPACK #-} !(M.WordPtr mut) - , nLen :: !Int - } - -data StructList mut = StructList - { slFirst :: Struct mut - -- ^ First element. data/ptr sizes are the same for - -- all elements. - , slLen :: !Int - -- ^ Number of elements - } - --- | A list of values with representation 'r' in a message. -newtype ListOf r mut = ListOf (ListRepOf r mut) - -type family ListRepOf (r :: Repr) :: Mutability -> Type where - ListRepOf ('Ptr ('Just 'Struct)) = StructList - ListRepOf r = NormalList - --- | @'ListItem' r@ indicates that @r@ is a representation for elements of some list --- type. Not every representation is covered; instances exist only for @r@ where --- @'ElemRepr' ('ListReprFor' r) ~ r@. -class Element r => ListItem (r :: Repr) where - -- | Returns the length of a list - length :: ListOf r mut -> Int - - -- underlying implementations of index, setIndex and take, but - -- without bounds checking. Don't call these directly. - unsafeIndex :: ReadCtx m mut => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut)) - unsafeSetIndex - :: (RWCtx m s, a ~ Unwrapped (Untyped r ('Mut s))) - => a -> Int -> ListOf r ('Mut s) -> m () - unsafeTake :: Int -> ListOf r mut -> ListOf r mut - - checkListOf :: ReadCtx m mut => ListOf r mut -> m () - - -- | Make a copy of the list, in the target message. - copyListOf :: RWCtx m s => ListOf r ('Mut s) -> ListOf r ('Mut s) -> m () - {-# INLINE copyListOf #-} - copyListOf dest src = - forM_ [0..length src - 1] $ \i -> do - value <- index i src - setIndex value i dest - - default length :: (ListRepOf r ~ NormalList) => ListOf r mut -> Int - length (ListOf nlist) = nLen nlist - {-# INLINE length #-} - - default unsafeIndex :: - forall m mut. - ( ReadCtx m mut - , Integral (Unwrapped (Untyped r mut)) - , ListRepOf r ~ NormalList - , FiniteBits (Unwrapped (Untyped r mut)) - ) => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut)) - unsafeIndex i (ListOf nlist) = - unsafeIndexBits @(Unwrapped (Untyped r mut)) i nlist - {-# INLINE unsafeIndex #-} - - default unsafeSetIndex :: - forall m s a. - ( RWCtx m s - , a ~ Unwrapped (Untyped r ('Mut s)) - , ListRepOf r ~ NormalList - , Integral a - , Bounded a - , FiniteBits a - ) => a -> Int -> ListOf r ('Mut s) -> m () - unsafeSetIndex value i (ListOf nlist) = - unsafeSetIndexBits @(Unwrapped (Untyped r ('Mut s))) value i nlist - {-# INLINE unsafeSetIndex #-} - - default unsafeTake :: ListRepOf r ~ NormalList => Int -> ListOf r mut -> ListOf r mut - unsafeTake count (ListOf NormalList{..}) = ListOf NormalList{ nLen = count, .. } - {-# INLINE unsafeTake #-} - - default checkListOf :: - forall m mut. - ( ReadCtx m mut - , ListRepOf r ~ NormalList - , FiniteBits (Untyped r mut) - ) => ListOf r mut -> m () - checkListOf (ListOf l) = checkNormalList - l - (fromIntegral $ finiteBitSize (undefined :: Untyped r mut)) - {-# INLINE checkListOf #-} - - -unsafeIndexBits - :: forall a m mut. - ( ReadCtx m mut - , FiniteBits a - , Integral a - ) => Int -> NormalList mut -> m a -{-# INLINE unsafeIndexBits #-} -unsafeIndexBits i nlist = - indexNList @a i nlist (64 `div` finiteBitSize (undefined :: a)) - -unsafeSetIndexBits - :: forall a m s. - ( RWCtx m s - , Bounded a - , FiniteBits a - , Integral a - ) => a -> Int -> NormalList ('Mut s) -> m () -{-# INLINE unsafeSetIndexBits #-} -unsafeSetIndexBits value i nlist = - setNIndex @a i nlist (64 `div` finiteBitSize value) value - -indexNList - :: forall a m mut. (ReadCtx m mut, Integral a) - => Int -> NormalList mut -> Int -> m a -{-# INLINE indexNList #-} -indexNList i (NormalList M.WordPtr{pSegment, pAddr=WordAt{..}} _) eltsPerWord = do - let wordIndex' = wordIndex + WordCount (i `div` eltsPerWord) - word <- M.read pSegment wordIndex' - let shift = (i `mod` eltsPerWord) * (64 `div` eltsPerWord) - pure $ fromIntegral $ word `shiftR` shift - -setNIndex - :: forall a m s. (RWCtx m s, Bounded a, Integral a) - => Int -> NormalList ('Mut s) -> Int -> a -> m () -{-# INLINE setNIndex #-} -setNIndex i NormalList{nPtr=M.WordPtr{pSegment, pAddr=WordAt{wordIndex}}} eltsPerWord value = do - let eltWordIndex = wordIndex + WordCount (i `div` eltsPerWord) - word <- M.read pSegment eltWordIndex - let shift = (i `mod` eltsPerWord) * (64 `div` eltsPerWord) - M.write pSegment eltWordIndex $ replaceBits value word shift - -setPtrIndex :: RWCtx m s => Int -> NormalList ('Mut s) -> Ptr ('Mut s) -> P.Ptr -> m () -{-# INLINE setPtrIndex #-} -setPtrIndex i NormalList{nPtr=nPtr@M.WordPtr{pAddr=addr@WordAt{wordIndex}}} absPtr relPtr = - let srcPtr = nPtr { M.pAddr = addr { wordIndex = wordIndex + WordCount i } } - in setPointerTo srcPtr (ptrAddr absPtr) relPtr - -instance ListItem ('Ptr ('Just 'Struct)) where - length (ListOf (StructList _ len)) = len - {-# INLINE length #-} - unsafeIndex i (ListOf (StructList (StructAt ptr@M.WordPtr{pAddr=addr@WordAt{..}} dataSz ptrSz) _)) = do - let offset = WordCount $ i * (fromIntegral dataSz + fromIntegral ptrSz) - let addr' = addr { wordIndex = wordIndex + offset } - return $ StructAt ptr { M.pAddr = addr' } dataSz ptrSz - {-# INLINE unsafeIndex #-} - unsafeSetIndex value i list = do - dest <- unsafeIndex i list - copyStruct dest value - unsafeTake count (ListOf (StructList s _)) = ListOf (StructList s count) - {-# INLINE unsafeTake #-} - - checkListOf (ListOf (StructList s@(StructAt ptr _ _) len)) = - checkPtrOffset ptr (fromIntegral len * structSize s) - {-# INLINE checkListOf #-} - -instance ListItem ('Data 'Sz0) where - unsafeIndex _ _ = pure () - {-# INLINE unsafeIndex #-} - unsafeSetIndex _ _ _ = pure () - {-# INLINE unsafeSetIndex #-} - checkListOf _ = pure () - {-# INLINE checkListOf #-} - copyListOf _ _ = pure () - {-# INLINE copyListOf #-} - -instance ListItem ('Data 'Sz1) where - unsafeIndex i (ListOf nlist) = do - Word1 val <- unsafeIndexBits @Word1 i nlist - pure val - {-# INLINE unsafeIndex #-} - unsafeSetIndex value i (ListOf nlist) = - unsafeSetIndexBits @Word1 (Word1 value) i nlist - {-# INLINE unsafeSetIndex #-} - checkListOf (ListOf l) = checkNormalList l 1 - {-# INLINE copyListOf #-} - copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 1 - -instance ListItem ('Data 'Sz8) where - {-# INLINE copyListOf #-} - copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 8 -instance ListItem ('Data 'Sz16) where - {-# INLINE copyListOf #-} - copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 16 -instance ListItem ('Data 'Sz32) where - {-# INLINE copyListOf #-} - copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 32 -instance ListItem ('Data 'Sz64) where - {-# INLINE copyListOf #-} - copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 64 - -instance ListItem ('Ptr 'Nothing) where - unsafeIndex i (ListOf (NormalList ptr@M.WordPtr{pAddr=addr@WordAt{..}} _)) = - get ptr { M.pAddr = addr { wordIndex = wordIndex + WordCount i } } - {-# INLINE unsafeIndex #-} - unsafeSetIndex value i list@(ListOf nlist) = case value of - Just p | message @Ptr p /= message @(ListOf ('Ptr 'Nothing)) list -> do - newPtr <- copyPtr (message @(ListOf ('Ptr 'Nothing)) list) value - unsafeSetIndex newPtr i list - Nothing -> - setNIndex i nlist 1 (P.serializePtr Nothing) - Just (PtrCap (CapAt _ cap)) -> - setNIndex i nlist 1 (P.serializePtr (Just (P.CapPtr cap))) - Just p@(PtrList ptrList) -> - setPtrIndex i nlist p $ P.ListPtr 0 (listEltSpec ptrList) - Just p@(PtrStruct (StructAt _ dataSz ptrSz)) -> - setPtrIndex i nlist p $ P.StructPtr 0 dataSz ptrSz - {-# INLINABLE unsafeSetIndex #-} - - checkListOf (ListOf l) = checkNormalList l 64 - {-# INLINE checkListOf #-} - --- | A Capability in a message. -data Cap mut = CapAt (M.Message mut) !Word32 - --- | A struct value in a message. -data Struct mut - = StructAt - {-# UNPACK #-} !(M.WordPtr mut) -- Start of struct - !Word16 -- Data section size. - !Word16 -- Pointer section size. - --- | Type (constraint) synonym for the constraints needed for most read --- operations. -type ReadCtx m mut = (M.MonadReadMessage mut m, MonadThrow m, MonadLimit m) - --- | Synonym for ReadCtx + WriteCtx -type RWCtx m s = (ReadCtx m ('Mut s), M.WriteCtx m s) - --- | A 'Repr' describes a wire representation for a value. This is --- mostly used at the type level (using DataKinds); types are --- parametrized over representations. -data Repr - = Ptr (Maybe PtrRepr) - -- ^ Pointer type. 'Nothing' indicates an AnyPointer, 'Just' describes - -- a more specific pointer type. - | Data DataSz - -- ^ Non-pointer type. - deriving(Show) - --- | Information about the representation of a pointer type -data PtrRepr - = Cap - -- ^ Capability pointer. - | List (Maybe ListRepr) - -- ^ List pointer. 'Nothing' describes an AnyList, 'Just' describes - -- more specific list types. - | Struct - -- ^ A struct (or group). - deriving(Show) - --- | Information about the representation of a list type. -data ListRepr where - -- | A "normal" list - ListNormal :: NormalListRepr -> ListRepr - ListComposite :: ListRepr - deriving(Show) - --- | Information about the representation of a normal (non-composite) list. -data NormalListRepr where - NormalListData :: DataSz -> NormalListRepr - NormalListPtr :: NormalListRepr - deriving(Show) - --- | The size of a non-pointer type. @SzN@ represents an @N@-bit value. -data DataSz = Sz0 | Sz1 | Sz8 | Sz16 | Sz32 | Sz64 - deriving(Show) - --- | Wrapper for use with 'Untyped'; see docs for 'Untyped' -newtype IgnoreMut a (mut :: Mutability) = IgnoreMut a - deriving(Show, Read, Eq, Ord, Enum, Bounded, Num, Real, Integral, Bits, FiniteBits) - --- | Wrapper for use with 'Untyped'; see docs for 'Untyped'. -newtype MaybePtr (mut :: Mutability) = MaybePtr (Maybe (Ptr mut)) - --- | Normalizes types returned by 'Untyped'; see docs for 'Untyped'. -type family Unwrapped a where - Unwrapped (IgnoreMut a mut) = a - Unwrapped (MaybePtr mut) = Maybe (Ptr mut) - Unwrapped a = a - --- | @Untyped r mut@ is an untyped value with representation @r@ stored in --- a message with mutability @mut@. --- --- Note that the return tyep of this type family has kind --- @'Mutability' -> 'Type'@. This is important, as it allows us --- to define instances on @'Untyped' r@, and use @'Untyped' r@ --- in constraints. --- --- This introduces some awkwardnesses though -- we really want --- this to be @(Maybe (Ptr mut))@ for @'Ptr 'Nothing@, and --- Int types/Bool/() for @'Data sz@. But we can't because these --- are the wrong kind. --- --- So, we hack around this by introducing two newtypes, 'IgnoreMut' --- and 'MaybePtr', and a type family 'Unwrapped', which lets us --- use @'Unwrapped' ('Untyped' r mut)@ as the type we really want --- in some places, though we can't curry it then. --- --- All this is super super awkward, but this is a low level --- mostly-internal API; most users will intract with this through --- the Raw type in "Capnp.Repr", which hides all of this... -type family Untyped (r :: Repr) :: Mutability -> Type where - Untyped ('Data sz) = IgnoreMut (UntypedData sz) - Untyped ('Ptr ptr) = UntypedPtr ptr - --- | @UntypedData sz@ is an untyped value with size @sz@. -type family UntypedData (sz :: DataSz) :: Type where - UntypedData 'Sz0 = () - UntypedData 'Sz1 = Bool - UntypedData 'Sz8 = Word8 - UntypedData 'Sz16 = Word16 - UntypedData 'Sz32 = Word32 - UntypedData 'Sz64 = Word64 - --- | Like 'Untyped', but for pointers only. -type family UntypedPtr (r :: Maybe PtrRepr) :: Mutability -> Type where - UntypedPtr 'Nothing = MaybePtr - UntypedPtr ('Just r) = UntypedSomePtr r - --- | Like 'UntypedPtr', but doesn't allow AnyPointers. -type family UntypedSomePtr (r :: PtrRepr) :: Mutability -> Type where - UntypedSomePtr 'Struct = Struct - UntypedSomePtr 'Cap = Cap - UntypedSomePtr ('List r) = UntypedList r - --- | Like 'Untyped', but for lists only. -type family UntypedList (r :: Maybe ListRepr) :: Mutability -> Type where - UntypedList 'Nothing = List - UntypedList ('Just r) = UntypedSomeList r - --- | Like 'UntypedList', but doesn't allow AnyLists. -type family UntypedSomeList (r :: ListRepr) :: Mutability -> Type where - UntypedSomeList r = ListOf (ElemRepr r) - --- | @ElemRepr r@ is the representation of elements of lists with --- representation @r@. -type family ElemRepr (rl :: ListRepr) :: Repr where - ElemRepr 'ListComposite = 'Ptr ('Just 'Struct) - ElemRepr ('ListNormal 'NormalListPtr) = 'Ptr 'Nothing - ElemRepr ('ListNormal ('NormalListData sz)) = 'Data sz - --- | @ListReprFor e@ is the representation of lists with elements --- whose representation is @e@. -type family ListReprFor (e :: Repr) :: ListRepr where - ListReprFor ('Data sz) = 'ListNormal ('NormalListData sz) - ListReprFor ('Ptr ('Just 'Struct)) = 'ListComposite - ListReprFor ('Ptr a) = 'ListNormal 'NormalListPtr - --- | 'Element' supports converting between values of representation --- @'ElemRepr' ('ListReprFor' r)@ and values of representation @r@. --- --- At a glance, you might expect this to just be a no-op, but it is actually --- *not* always the case that @'ElemRepr' ('ListReprFor' r) ~ r@; in the --- case of pointer types, @'ListReprFor' r@ can contain arbitrary pointers, --- so information is lost, and it is possible for the list to contain pointers --- of the incorrect type. In this case, 'fromElement' will throw an error. --- --- 'toElement' is more trivial. -class Element (r :: Repr) where - fromElement - :: forall m mut. ReadCtx m mut - => M.Message mut - -> Unwrapped (Untyped (ElemRepr (ListReprFor r)) mut) - -> m (Unwrapped (Untyped r mut)) - toElement :: Unwrapped (Untyped r mut) -> Unwrapped (Untyped (ElemRepr (ListReprFor r)) mut) - --- | Operations on types with pointer representations. -class IsPtrRepr (r :: Maybe PtrRepr) where - toPtr :: Unwrapped (Untyped ('Ptr r) mut) -> Maybe (Ptr mut) - -- ^ Convert an untyped value of this representation to an AnyPointer. - fromPtr :: ReadCtx m mut => M.Message mut -> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr r) mut)) - -- ^ Extract a value with this representation from an AnyPointer, failing - -- if the pointer is the wrong type for this representation. - --- | Operations on types with list representations. -class IsListPtrRepr (r :: ListRepr) where - rToList :: UntypedSomeList r mut -> List mut - -- ^ Convert an untyped value of this representation to an AnyList. - rFromList :: ReadCtx m mut => List mut -> m (UntypedSomeList r mut) - -- ^ Extract a value with this representation from an AnyList, failing - -- if the list is the wrong type for this representation. - rFromListMsg :: ReadCtx m mut => M.Message mut -> m (UntypedSomeList r mut) - -- ^ Create a zero-length value with this representation, living in the - -- provided message. - --- helper function for throwing SchemaViolationError "expected ..." -expected :: MonadThrow m => String -> m a -expected msg = throwM $ E.SchemaViolationError $ "expected " ++ msg - - -------------------------------------------------------------------------------- --- 'Element' instances -------------------------------------------------------------------------------- - -instance Element ('Data sz) where - fromElement _ = pure - toElement = id - {-# INLINE fromElement #-} - {-# INLINE toElement #-} -instance Element ('Ptr ('Just 'Struct)) where - fromElement _ = pure - toElement = id - {-# INLINE fromElement #-} - {-# INLINE toElement #-} -instance Element ('Ptr 'Nothing) where - fromElement _ = pure - toElement = id - {-# INLINE fromElement #-} - {-# INLINE toElement #-} -instance Element ('Ptr ('Just 'Cap)) where - fromElement = fromPtr @('Just 'Cap) - toElement = Just . PtrCap - {-# INLINE fromElement #-} - {-# INLINE toElement #-} -instance IsPtrRepr ('Just ('List a)) => Element ('Ptr ('Just ('List a))) where - fromElement = fromPtr @('Just ('List a)) - toElement = toPtr @('Just ('List a)) - {-# INLINE fromElement #-} - {-# INLINE toElement #-} - -------------------------------------------------------------------------------- --- 'IsPtrRepr' instances -------------------------------------------------------------------------------- - -instance IsPtrRepr 'Nothing where - toPtr p = p - fromPtr _ = pure - {-# INLINE toPtr #-} - {-# INLINE fromPtr #-} -instance IsPtrRepr ('Just 'Struct) where - toPtr s = Just (PtrStruct s) - fromPtr msg Nothing = messageDefault @Struct msg - fromPtr _ (Just (PtrStruct s)) = pure s - fromPtr _ _ = expected "pointer to struct" - {-# INLINE toPtr #-} - {-# INLINE fromPtr #-} -instance IsPtrRepr ('Just 'Cap) where - toPtr c = Just (PtrCap c) - fromPtr _ Nothing = expected "pointer to capability" - fromPtr _ (Just (PtrCap c)) = pure c - fromPtr _ _ = expected "pointer to capability" - {-# INLINE toPtr #-} - {-# INLINE fromPtr #-} -instance IsPtrRepr ('Just ('List 'Nothing)) where - toPtr l = Just (PtrList l) - fromPtr _ Nothing = expected "pointer to list" - fromPtr _ (Just (PtrList l)) = pure l - fromPtr _ (Just _) = expected "pointer to list" - {-# INLINE toPtr #-} - {-# INLINE fromPtr #-} -instance IsListPtrRepr r => IsPtrRepr ('Just ('List ('Just r))) where - toPtr l = Just (PtrList (rToList @r l)) - fromPtr msg Nothing = rFromListMsg @r msg - fromPtr _ (Just (PtrList l)) = rFromList @r l - fromPtr _ (Just _) = expected "pointer to list" - {-# INLINE toPtr #-} - {-# INLINE fromPtr #-} - --- | N.B. this should mostly be considered an implementation detail, but --- it is exposed because it is used by generated code. --- --- 'TraverseMsg' is similar to 'Traversable' from the prelude, but --- the intent is that rather than conceptually being a "container", --- the instance is a value backed by a message, and the point of the --- type class is to be able to apply transformations to the underlying --- message. --- --- We don't just use 'Traversable' for this for two reasons: --- --- 1. While algebraically it makes sense, it would be very unintuitive to --- e.g. have the 'Traversable' instance for 'List' not traverse over the --- *elements* of the list. --- 2. For the instance for WordPtr, we actually need a stronger constraint than --- Applicative in order for the implementation to type check. A previous --- version of the library *did* have @tMsg :: Applicative m => ...@, but --- performance considerations eventually forced us to open up the hood a --- bit. -class TraverseMsg f where - tMsg :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> f mutA -> m (f mutB) - -type TraverseMsgCtx m mutA mutB = - ( MonadThrow m - , M.MonadReadMessage mutA m - , M.MonadReadMessage mutB m - ) - -instance TraverseMsg M.WordPtr where - tMsg f M.WordPtr{pMessage, pAddr=pAddr@WordAt{segIndex}} = do - msg' <- f pMessage - seg' <- M.getSegment msg' segIndex - pure M.WordPtr - { pMessage = msg' - , pSegment = seg' - , pAddr - } - -instance TraverseMsg Ptr where - tMsg f = \case - PtrCap cap -> - PtrCap <$> tMsg f cap - PtrList l -> - PtrList <$> tMsg f l - PtrStruct s -> - PtrStruct <$> tMsg f s - -instance TraverseMsg Cap where - tMsg f (CapAt msg n) = CapAt <$> f msg <*> pure n - -instance TraverseMsg Struct where - tMsg f (StructAt ptr dataSz ptrSz) = StructAt - <$> tMsg f ptr - <*> pure dataSz - <*> pure ptrSz - -instance TraverseMsg List where - tMsg f = \case - List0 l -> List0 <$> tMsg f l - List1 l -> List1 <$> tMsg f l - List8 l -> List8 <$> tMsg f l - List16 l -> List16 <$> tMsg f l - List32 l -> List32 <$> tMsg f l - List64 l -> List64 <$> tMsg f l - ListPtr l -> ListPtr <$> tMsg f l - ListStruct l -> ListStruct <$> tMsg f l - -instance TraverseMsg (ListRepOf r) => TraverseMsg (ListOf r) where - tMsg f (ListOf l) = ListOf <$> tMsg f l - -instance TraverseMsg NormalList where - tMsg f NormalList{..} = do - ptr <- tMsg f nPtr - pure NormalList { nPtr = ptr, .. } - -instance TraverseMsg StructList where - tMsg f StructList{..} = do - s <- tMsg f slFirst - pure StructList { slFirst = s, .. } - -------------------------------------------------------------------------------- - --- | Types whose storage is owned by a message.. -class HasMessage (f :: Mutability -> Type) where - -- | Get the message in which the value is stored. - message :: Unwrapped (f mut) -> M.Message mut - --- | Types which have a "default" value, but require a message --- to construct it. --- --- The default is usually conceptually zero-size. This is mostly useful --- for generated code, so that it can use standard decoding techniques --- on default values. -class HasMessage f => MessageDefault f where - messageDefault :: ReadCtx m mut => M.Message mut -> m (Unwrapped (f mut)) - -instance HasMessage M.WordPtr where - message M.WordPtr{pMessage} = pMessage - -instance HasMessage Ptr where - message (PtrCap cap) = message @Cap cap - message (PtrList list) = message @List list - message (PtrStruct struct) = message @Struct struct - -instance HasMessage Cap where - message (CapAt msg _) = msg - -instance HasMessage Struct where - message (StructAt ptr _ _) = message @M.WordPtr ptr - -instance MessageDefault Struct where - messageDefault msg = do - pSegment <- M.getSegment msg 0 - pure $ StructAt M.WordPtr{pMessage = msg, pSegment, pAddr = WordAt 0 0} 0 0 - -instance HasMessage List where - message (List0 list) = message @(ListOf ('Data 'Sz0)) list - message (List1 list) = message @(ListOf ('Data 'Sz1)) list - message (List8 list) = message @(ListOf ('Data 'Sz8)) list - message (List16 list) = message @(ListOf ('Data 'Sz16)) list - message (List32 list) = message @(ListOf ('Data 'Sz32)) list - message (List64 list) = message @(ListOf ('Data 'Sz64)) list - message (ListPtr list) = message @(ListOf ('Ptr 'Nothing)) list - message (ListStruct list) = message @(ListOf ('Ptr ('Just 'Struct))) list - -instance HasMessage (ListOf ('Ptr ('Just 'Struct))) where - message (ListOf list) = message @StructList list - -instance MessageDefault (ListOf ('Ptr ('Just 'Struct))) where - messageDefault msg = ListOf <$> messageDefault @StructList msg - -instance {-# OVERLAPS #-} ListRepOf r ~ NormalList => HasMessage (ListOf r) where - message (ListOf list) = message @NormalList list - -instance {-# OVERLAPS #-} ListRepOf r ~ NormalList => MessageDefault (ListOf r) where - messageDefault msg = ListOf <$> messageDefault @NormalList msg - -instance HasMessage NormalList where - message = M.pMessage . nPtr - -instance MessageDefault NormalList where - messageDefault msg = do - pSegment <- M.getSegment msg 0 - pure NormalList - { nPtr = M.WordPtr { pMessage = msg, pSegment, pAddr = WordAt 0 0 } - , nLen = 0 - } - -instance HasMessage StructList where - message (StructList s _) = message @Struct s - -instance MessageDefault StructList where - messageDefault msg = StructList - <$> messageDefault @Struct msg - <*> pure 0 - --- | Extract a client (indepedent of the messsage) from the capability. -getClient :: ReadCtx m mut => Cap mut -> m M.Client -{-# INLINABLE getClient #-} -getClient (CapAt msg idx) = M.getCap msg (fromIntegral idx) - --- | @get ptr@ returns the Ptr stored at @ptr@. --- Deducts 1 from the quota for each word read (which may be multiple in the --- case of far pointers). -get :: ReadCtx m mut => M.WordPtr mut -> m (Maybe (Ptr mut)) -{-# INLINABLE get #-} -{-# SPECIALIZE get :: M.WordPtr ('Mut RealWorld) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-} -{-# SPECIALIZE get :: M.WordPtr ('Mut s) -> PureBuilder s (Maybe (Ptr ('Mut s))) #-} -get ptr = do - word <- M.getWord ptr - case P.parsePtr word of - Just (P.FarPtr twoWords offset segment) -> getFar ptr twoWords offset segment - v -> getNear ptr v - -getFar :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> Bool -> Word32 -> Word32 -> m (Maybe (Ptr mut)) -getFar M.WordPtr{pMessage} twoWords offset segment = do - landingSegment <- M.getSegment pMessage (fromIntegral segment) - let addr' = WordAt { wordIndex = fromIntegral offset - , segIndex = fromIntegral segment - } - let landingPtr = M.WordPtr - { pMessage - , pSegment = landingSegment - , pAddr = addr' - } - landingPad <- M.getWord landingPtr - if not twoWords - then getNear landingPtr (P.parsePtr landingPad) - else do - case P.parsePtr landingPad of - Just (P.FarPtr False off seg) -> do - let segIndex = fromIntegral seg - finalSegment <- M.getSegment pMessage segIndex - tagWord <- M.getWord M.WordPtr - { pMessage - , pSegment = landingSegment - , M.pAddr = addr' { wordIndex = wordIndex addr' + 1 } - } - let finalPtr = M.WordPtr - { pMessage - , pSegment = finalSegment - , pAddr = WordAt - { wordIndex = fromIntegral off - , segIndex - } - } - case P.parsePtr tagWord of - Just (P.StructPtr 0 dataSz ptrSz) -> - return $ Just $ PtrStruct $ - StructAt finalPtr dataSz ptrSz - Just (P.ListPtr 0 eltSpec) -> - Just . PtrList <$> getList finalPtr eltSpec - -- TODO: I'm not sure whether far pointers to caps are - -- legal; it's clear how they would work, but I don't - -- see a use, and the spec is unclear. Should check - -- how the reference implementation does this, copy - -- that, and submit a patch to the spec. - Just (P.CapPtr cap) -> - return $ Just $ PtrCap (CapAt pMessage cap) - ptr -> throwM $ E.InvalidDataError $ - "The tag word of a far pointer's " ++ - "2-word landing pad should be an intra " ++ - "segment pointer with offset 0, but " ++ - "we read " ++ show ptr - ptr -> throwM $ E.InvalidDataError $ - "The first word of a far pointer's 2-word " ++ - "landing pad should be another far pointer " ++ - "(with a one-word landing pad), but we read " ++ - show ptr - -getNear :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> Maybe P.Ptr -> m (Maybe (Ptr mut)) -getNear ptr@M.WordPtr{pMessage, pAddr} = \case - Nothing -> return Nothing - Just p -> case p of - P.CapPtr cap -> return $ Just $ PtrCap (CapAt pMessage cap) - P.StructPtr off dataSz ptrSz -> return $ Just $ PtrStruct $ - StructAt ptr { M.pAddr = resolveOffset pAddr off } dataSz ptrSz - P.ListPtr off eltSpec -> Just . PtrList <$> - getList ptr { M.pAddr = resolveOffset pAddr off } eltSpec - P.FarPtr{} -> throwM $ E.InvalidDataError - "Unexpected far pointer where only near pointers were expected." - -getList :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> P.EltSpec -> m (List mut) -getList ptr@M.WordPtr{pAddr=addr@WordAt{wordIndex}} eltSpec = - case eltSpec of - P.EltNormal sz len -> pure $ case sz of - P.Sz0 -> List0 (ListOf nlist) - P.Sz1 -> List1 (ListOf nlist) - P.Sz8 -> List8 (ListOf nlist) - P.Sz16 -> List16 (ListOf nlist) - P.Sz32 -> List32 (ListOf nlist) - P.Sz64 -> List64 (ListOf nlist) - P.SzPtr -> ListPtr (ListOf nlist) - where - nlist = NormalList ptr (fromIntegral len) - P.EltComposite _ -> do - tagWord <- M.getWord ptr - case P.parsePtr' tagWord of - P.StructPtr numElts dataSz ptrSz -> - pure $ ListStruct $ ListOf $ StructList - (StructAt - ptr { M.pAddr = addr { wordIndex = wordIndex + 1 } } - dataSz - ptrSz) - (fromIntegral numElts) - tag -> throwM $ E.InvalidDataError $ - "Composite list tag was not a struct-" ++ - "formatted word: " ++ show tag - --- | Return the EltSpec needed for a pointer to the given list. -listEltSpec :: List msg -> P.EltSpec -listEltSpec (ListStruct list@(ListOf (StructList (StructAt _ dataSz ptrSz) _))) = - P.EltComposite $ fromIntegral (length list) * (fromIntegral dataSz + fromIntegral ptrSz) -listEltSpec (List0 list) = P.EltNormal P.Sz0 $ fromIntegral (length list) -listEltSpec (List1 list) = P.EltNormal P.Sz1 $ fromIntegral (length list) -listEltSpec (List8 list) = P.EltNormal P.Sz8 $ fromIntegral (length list) -listEltSpec (List16 list) = P.EltNormal P.Sz16 $ fromIntegral (length list) -listEltSpec (List32 list) = P.EltNormal P.Sz32 $ fromIntegral (length list) -listEltSpec (List64 list) = P.EltNormal P.Sz64 $ fromIntegral (length list) -listEltSpec (ListPtr list) = P.EltNormal P.SzPtr $ fromIntegral (length list) - --- | Return the starting address of the list. -listAddr :: List msg -> WordAddr -listAddr (ListStruct (ListOf (StructList (StructAt M.WordPtr{pAddr} _ _) _))) = - -- pAddr is the address of the first element of the list, but - -- composite lists start with a tag word: - pAddr { wordIndex = wordIndex pAddr - 1 } -listAddr (List0 (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr -listAddr (List1 (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr -listAddr (List8 (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr -listAddr (List16 (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr -listAddr (List32 (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr -listAddr (List64 (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr -listAddr (ListPtr (ListOf NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr - --- | Return the address of the pointer's target. It is illegal to call this on --- a pointer which targets a capability. -ptrAddr :: Ptr msg -> WordAddr -ptrAddr (PtrCap _) = error "ptrAddr called on a capability pointer." -ptrAddr (PtrStruct (StructAt M.WordPtr{pAddr}_ _)) = pAddr -ptrAddr (PtrList list) = listAddr list - --- | @'setIndex value i list@ Set the @i@th element of @list@ to @value@. -setIndex - :: (RWCtx m s, ListItem r) - => Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> m () -{-# INLINE setIndex #-} -{-# SPECIALIZE setIndex - :: ListItem r - => Unwrapped (Untyped r ('Mut RealWorld)) -> Int -> ListOf r ('Mut RealWorld) -> LimitT IO () #-} -{-# SPECIALIZE setIndex - :: ListItem r - => Unwrapped (Untyped r ('Mut s)) -> Int -> ListOf r ('Mut s) -> PureBuilder s () #-} -setIndex _ i list | i < 0 || length list <= i = - throwM E.BoundsError { E.index = i, E.maxIndex = length list } -setIndex value i list = unsafeSetIndex value i list - --- | @'setPointerTo' msg srcLoc dstAddr relPtr@ sets the word at @srcLoc@ in @msg@ to a --- pointer like @relPtr@, but pointing to @dstAddr@. @relPtr@ should not be a far pointer. --- If the two addresses are in different segments, a landing pad will be allocated and --- @srcLoc@ will contain a far pointer. -setPointerTo :: M.WriteCtx m s => M.WordPtr ('Mut s) -> WordAddr -> P.Ptr -> m () -{-# INLINABLE setPointerTo #-} -{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut RealWorld) -> WordAddr -> P.Ptr -> LimitT IO () #-} -{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut s) -> WordAddr -> P.Ptr -> PureBuilder s () #-} -setPointerTo - M.WordPtr - { pMessage = msg - , pSegment=srcSegment - , pAddr=srcAddr@WordAt{wordIndex=srcWordIndex} - } - dstAddr - relPtr - | P.StructPtr _ 0 0 <- relPtr = - -- We special case zero-sized structs, since (1) we don't have to - -- really point at the correct offset, since they can "fit" anywhere, - -- and (2) they cause problems with double-far pointers, where part - -- of the landing pad needs to have a zero offset, but that makes it - -- look like a null pointer... so we just avoid that case by cutting - -- it off here. - M.write srcSegment srcWordIndex $ - P.serializePtr $ Just $ P.StructPtr (-1) 0 0 - | otherwise = case pointerFrom srcAddr dstAddr relPtr of - Right absPtr -> - M.write srcSegment srcWordIndex $ P.serializePtr $ Just absPtr - Left OutOfRange -> - error "BUG: segment is too large to set the pointer." - Left DifferentSegments -> do - -- We need a far pointer; allocate a landing pad in the target segment, - -- set it to point to the final destination, an then set the source pointer - -- pointer to point to the landing pad. - let WordAt{segIndex} = dstAddr - M.allocInSeg msg segIndex 1 >>= \case - Just M.WordPtr{pSegment=landingPadSegment, pAddr=landingPadAddr} -> - case pointerFrom landingPadAddr dstAddr relPtr of - Right landingPad -> do - let WordAt{segIndex,wordIndex} = landingPadAddr - M.write landingPadSegment wordIndex (P.serializePtr $ Just landingPad) - M.write srcSegment srcWordIndex $ - P.serializePtr $ Just $ P.FarPtr False (fromIntegral wordIndex) (fromIntegral segIndex) - Left DifferentSegments -> - error "BUG: allocated a landing pad in the wrong segment!" - Left OutOfRange -> - error "BUG: segment is too large to set the pointer." - Nothing -> do - -- The target segment is full. We need to do a double-far pointer. - -- First allocate the 2-word landing pad, wherever it will fit: - M.WordPtr - { pSegment = landingPadSegment - , pAddr = WordAt - { wordIndex = landingPadOffset - , segIndex = landingPadSegIndex - } - } <- M.alloc msg 2 - -- Next, point the source pointer at the landing pad: - M.write srcSegment srcWordIndex $ - P.serializePtr $ Just $ P.FarPtr True - (fromIntegral landingPadOffset) - (fromIntegral landingPadSegIndex) - -- Finally, fill in the landing pad itself. - -- - -- The first word is a far pointer whose offset is the - -- starting address of our target object: - M.write landingPadSegment landingPadOffset $ - let WordAt{wordIndex, segIndex} = dstAddr in - P.serializePtr $ Just $ P.FarPtr False - (fromIntegral wordIndex) - (fromIntegral segIndex) - -- The second word is a pointer of the right "shape" - -- for the target, but with a zero offset: - M.write landingPadSegment (landingPadOffset + 1) $ - P.serializePtr $ Just $ case relPtr of - P.StructPtr _ nWords nPtrs -> P.StructPtr 0 nWords nPtrs - P.ListPtr _ eltSpec -> P.ListPtr 0 eltSpec - _ -> relPtr - --- | Make a copy of a capability inside the target message. -copyCap :: RWCtx m s => M.Message ('Mut s) -> Cap ('Mut s) -> m (Cap ('Mut s)) -{-# INLINABLE copyCap #-} -copyCap dest cap = getClient cap >>= appendCap dest - --- | Make a copy of the value at the pointer, in the target message. -copyPtr :: RWCtx m s => M.Message ('Mut s) -> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s))) -{-# INLINABLE copyPtr #-} -{-# SPECIALIZE copyPtr :: M.Message ('Mut RealWorld) -> Maybe (Ptr ('Mut RealWorld)) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-} -{-# SPECIALIZE copyPtr :: M.Message ('Mut s) -> Maybe (Ptr ('Mut s)) -> PureBuilder s (Maybe (Ptr ('Mut s))) #-} -copyPtr _ Nothing = pure Nothing -copyPtr dest (Just (PtrCap cap)) = Just . PtrCap <$> copyCap dest cap -copyPtr dest (Just (PtrList src)) = Just . PtrList <$> copyList dest src -copyPtr dest (Just (PtrStruct src)) = Just . PtrStruct <$> do - destStruct <- allocStruct - dest - (fromIntegral $ structWordCount src) - (fromIntegral $ structPtrCount src) - copyStruct destStruct src - pure destStruct - --- | Make a copy of the list, in the target message. -copyList :: RWCtx m s => M.Message ('Mut s) -> List ('Mut s) -> m (List ('Mut s)) -{-# INLINABLE copyList #-} -{-# SPECIALIZE copyList :: M.Message ('Mut RealWorld) -> List ('Mut RealWorld) -> LimitT IO (List ('Mut RealWorld)) #-} -{-# SPECIALIZE copyList :: M.Message ('Mut s) -> List ('Mut s) -> PureBuilder s (List ('Mut s)) #-} -copyList dest src = case src of - List0 src -> List0 <$> allocList0 dest (length src) - List1 src -> List1 <$> copyNewListOf dest src allocList1 - List8 src -> List8 <$> copyNewListOf dest src allocList8 - List16 src -> List16 <$> copyNewListOf dest src allocList16 - List32 src -> List32 <$> copyNewListOf dest src allocList32 - List64 src -> List64 <$> copyNewListOf dest src allocList64 - ListPtr src -> ListPtr <$> copyNewListOf dest src allocListPtr - ListStruct src -> ListStruct <$> do - destList <- allocCompositeList - dest - (fromIntegral $ structListWordCount src) - (structListPtrCount src) - (length src) - copyListOf destList src - pure destList - -copyNewListOf - :: (ListItem r, RWCtx m s) - => M.Message ('Mut s) - -> ListOf r ('Mut s) - -> (M.Message ('Mut s) -> Int -> m (ListOf r ('Mut s))) - -> m (ListOf r ('Mut s)) -{-# INLINE copyNewListOf #-} -copyNewListOf destMsg src new = do - dest <- new destMsg (length src) - copyListOf dest src - pure dest - --- | @copyDataList dest src bits@ copies n elements of @src@ to @dest@, where n --- is the length of the smaller list. @bits@ is the number of bits per element --- in the two lists. --- --- This should only used for non-pointer types, as it does not do a deep copy and --- just copies the raw bytes. --- --- Warning: if you get the @bits@ argument wrong, you may trample over data outside --- the intended bounds. -copyDataList :: RWCtx m s => NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m () -copyDataList dest src bits = do - let unpack NormalList{nLen, nPtr = M.WordPtr{pSegment, pAddr=WordAt{wordIndex}}} = - (nLen, wordIndex, pSegment) - - (srcLen, srcOff, srcSeg) = unpack src - (destLen, destOff, destSeg) = unpack dest - - len = min destLen srcLen - lenWords = - fromIntegral len * bits - & bitsToBytesCeil - & bytesToWordsCeil - - sliceVec off = - SMV.slice (fromIntegral off) (fromIntegral lenWords) - srcVec <- M.segToVecMut srcSeg - destVec <- M.segToVecMut destSeg - SMV.copy - (sliceVec destOff destVec) - (sliceVec srcOff srcVec) - --- | @'copyStruct' dest src@ copies the source struct to the destination struct. -copyStruct :: RWCtx m s => Struct ('Mut s) -> Struct ('Mut s) -> m () -{-# INLINABLE copyStruct #-} -{-# SPECIALIZE copyStruct :: Struct ('Mut RealWorld) -> Struct ('Mut RealWorld) -> LimitT IO () #-} -{-# SPECIALIZE copyStruct :: Struct ('Mut s) -> Struct ('Mut s) -> PureBuilder s () #-} -copyStruct dest src = do - -- We copy both the data and pointer sections from src to dest, - -- padding the tail of the destination section with zeros/null - -- pointers as necessary. If the destination section is - -- smaller than the source section, this will raise a BoundsError. - -- - -- TODO: possible enhancement: allow the destination section to be - -- smaller than the source section if and only if the tail of the - -- source section is all zeros (default values). - copySection (dataSection dest) (dataSection src) 0 - copySection (ptrSection dest) (ptrSection src) Nothing - where - copySection dest src pad = do - -- Copy the source section to the destination section: - copyListOf dest src - -- Pad the remainder with zeros/default values: - forM_ [length src..length dest - 1] $ \i -> - setIndex pad i dest - - --- | @index i list@ returns the ith element in @list@. Deducts 1 from the quota -index :: (ReadCtx m mut, ListItem r) => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut)) -{-# INLINE index #-} -{-# SPECIALIZE index :: ListItem r => Int -> ListOf r 'Const -> LimitT IO (Unwrapped (Untyped r 'Const)) #-} -{-# SPECIALIZE index :: ListItem r => Int -> ListOf r ('Mut RealWorld) -> LimitT IO (Unwrapped (Untyped r ('Mut RealWorld))) #-} -{-# SPECIALIZE index :: ListItem r => Int -> ListOf r 'Const -> PureBuilder s (Unwrapped (Untyped r 'Const)) #-} -{-# SPECIALIZE index :: ListItem r => Int -> ListOf r ('Mut s) -> PureBuilder s (Unwrapped (Untyped r ('Mut s))) #-} -index i list - | i < 0 || i >= length list = - throwM E.BoundsError { E.index = i, E.maxIndex = length list - 1 } - | otherwise = unsafeIndex i list - --- | Return a prefix of the list, of the given length. -{-# INLINABLE take #-} -take :: (ListItem r, MonadThrow m) => Int -> ListOf r mut -> m (ListOf r mut) -take count list - | length list < count = - throwM E.BoundsError { E.index = count, E.maxIndex = length list - 1 } - | otherwise = pure $ unsafeTake count list - --- | The data section of a struct, as a list of Word64 -dataSection :: Struct mut -> ListOf ('Data 'Sz64) mut -{-# INLINE dataSection #-} -dataSection (StructAt ptr dataSz _) = - ListOf $ NormalList ptr (fromIntegral dataSz) - --- | The pointer section of a struct, as a list of Ptr -ptrSection :: Struct mut -> ListOf ('Ptr 'Nothing) mut -{-# INLINE ptrSection #-} -ptrSection (StructAt ptr@M.WordPtr{pAddr=addr@WordAt{wordIndex}} dataSz ptrSz) = - ListOf $ NormalList - { nPtr = ptr { M.pAddr = addr { wordIndex = wordIndex + fromIntegral dataSz } } - , nLen = fromIntegral ptrSz - } - --- | Get the size (in words) of a struct's data section. -structWordCount :: Struct mut -> WordCount -structWordCount (StructAt _ptr dataSz _ptrSz) = fromIntegral dataSz - --- | Get the size (in bytes) of a struct's data section. -structByteCount :: Struct mut -> ByteCount -structByteCount = wordsToBytes . structWordCount - --- | Get the size of a struct's pointer section. -structPtrCount :: Struct mut -> Word16 -structPtrCount (StructAt _ptr _dataSz ptrSz) = ptrSz - --- | Get the size (in words) of the data sections in a struct list. -structListWordCount :: ListOf ('Ptr ('Just 'Struct)) mut -> WordCount -structListWordCount (ListOf (StructList s _)) = structWordCount s - --- | Get the size (in words) of the data sections in a struct list. -structListByteCount :: ListOf ('Ptr ('Just 'Struct)) mut -> ByteCount -structListByteCount (ListOf (StructList s _)) = structByteCount s - --- | Get the size of the pointer sections in a struct list. -structListPtrCount :: ListOf ('Ptr ('Just 'Struct)) mut -> Word16 -structListPtrCount (ListOf (StructList s _)) = structPtrCount s - --- | @'getData' i struct@ gets the @i@th word from the struct's data section, --- returning 0 if it is absent. -getData :: ReadCtx m msg => Int -> Struct msg -> m Word64 -{-# INLINE getData #-} -getData i struct - | fromIntegral (structWordCount struct) <= i = pure 0 - | otherwise = index i (dataSection struct) - --- | @'getPtr' i struct@ gets the @i@th word from the struct's pointer section, --- returning Nothing if it is absent. -getPtr :: ReadCtx m msg => Int -> Struct msg -> m (Maybe (Ptr msg)) -{-# INLINE getPtr #-} -getPtr i struct - | fromIntegral (structPtrCount struct) <= i = do - invoice 1 - pure Nothing - | otherwise = do - ptr <- index i (ptrSection struct) - checkPtr ptr - invoicePtr ptr - pure ptr - -checkPtr :: ReadCtx m mut => Maybe (Ptr mut) -> m () -{-# INLINABLE checkPtr #-} -checkPtr Nothing = pure () -checkPtr (Just (PtrCap c)) = checkCap c -checkPtr (Just (PtrList l)) = checkList l -checkPtr (Just (PtrStruct s)) = checkStruct s - -checkCap :: ReadCtx m mut => Cap mut -> m () -{-# INLINABLE checkCap #-} -checkCap (CapAt _ _ ) = pure () - -- No need to do anything here; an out of bounds index is just treated - -- as null. - -checkList :: ReadCtx m mut => List mut -> m () -{-# INLINABLE checkList #-} -checkList (List0 l) = checkListOf @('Data 'Sz0) l -checkList (List1 l) = checkListOf @('Data 'Sz1) l -checkList (List8 l) = checkListOf @('Data 'Sz8) l -checkList (List16 l) = checkListOf @('Data 'Sz16) l -checkList (List32 l) = checkListOf @('Data 'Sz32) l -checkList (List64 l) = checkListOf @('Data 'Sz64) l -checkList (ListPtr l) = checkListOf @('Ptr 'Nothing) l -checkList (ListStruct l) = checkListOf @('Ptr ('Just 'Struct)) l - -checkNormalList :: ReadCtx m mut => NormalList mut -> BitCount -> m () -{-# INLINABLE checkNormalList #-} -checkNormalList NormalList{nPtr, nLen} eltSize = - let nBits = fromIntegral nLen * eltSize - nWords = bytesToWordsCeil $ bitsToBytesCeil nBits - in - checkPtrOffset nPtr nWords - -checkStruct :: ReadCtx m mut => Struct mut -> m () -{-# INLINABLE checkStruct #-} -checkStruct s@(StructAt ptr _ _) = - checkPtrOffset ptr (structSize s) - -checkPtrOffset :: ReadCtx m mut => M.WordPtr mut -> WordCount -> m () -{-# INLINABLE checkPtrOffset #-} -checkPtrOffset M.WordPtr{pSegment, pAddr=WordAt{wordIndex}} size = do - segWords <- M.numWords pSegment - let maxIndex = fromIntegral segWords - 1 - unless (wordIndex >= 0) $ - throwM E.BoundsError { index = fromIntegral wordIndex, maxIndex } - unless (wordIndex + size <= segWords) $ - throwM E.BoundsError - { index = fromIntegral (wordIndex + size) - 1 - , maxIndex - } - -structSize :: Struct mut -> WordCount -structSize s = structWordCount s + fromIntegral (structPtrCount s) - --- | Invoice the traversal limit for all data reachable via the pointer --- directly, i.e. without following further pointers. --- --- The minimum possible cost is 1, and for lists will always be proportional --- to the length of the list, even if the size of the elements is zero. -invoicePtr :: MonadLimit m => Maybe (Ptr mut) -> m () -{-# INLINABLE invoicePtr #-} -{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut RealWorld)) -> LimitT IO () #-} -{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut s)) -> PureBuilder s () #-} -invoicePtr p = invoice $! ptrInvoiceSize p - -ptrInvoiceSize :: Maybe (Ptr mut) -> WordCount -{-# INLINABLE ptrInvoiceSize #-} -ptrInvoiceSize = \case - Nothing -> 1 - Just (PtrCap _) -> 1 - Just (PtrStruct s) -> structInvoiceSize s - Just (PtrList l) -> listInvoiceSize l -listInvoiceSize :: List mut -> WordCount -{-# INLINABLE listInvoiceSize #-} -listInvoiceSize l = max 1 $! case l of - List0 l -> fromIntegral $! length l - List1 l -> fromIntegral $! length l `div` 64 - List8 l -> fromIntegral $! length l `div` 8 - List16 l -> fromIntegral $! length l `div` 4 - List32 l -> fromIntegral $! length l `div` 2 - List64 l -> fromIntegral $! length l - ListPtr l -> fromIntegral $! length l - ListStruct (ListOf (StructList s len)) -> - structInvoiceSize s * fromIntegral len -structInvoiceSize :: Struct mut -> WordCount -{-# INLINABLE structInvoiceSize #-} -structInvoiceSize (StructAt _ dataSz ptrSz) = - max 1 (fromIntegral dataSz + fromIntegral ptrSz) - --- | @'setData' value i struct@ sets the @i@th word in the struct's data section --- to @value@. -{-# INLINE setData #-} -setData :: (ReadCtx m ('Mut s), M.WriteCtx m s) - => Word64 -> Int -> Struct ('Mut s) -> m () -setData value i = setIndex value i . dataSection - --- | @'setData' value i struct@ sets the @i@th pointer in the struct's pointer --- section to @value@. -setPtr :: (ReadCtx m ('Mut s), M.WriteCtx m s) => Maybe (Ptr ('Mut s)) -> Int -> Struct ('Mut s) -> m () -{-# INLINE setPtr #-} -setPtr value i = setIndex value i . ptrSection - --- | 'rawBytes' returns the raw bytes corresponding to the list. -rawBytes :: ReadCtx m 'Const => ListOf ('Data 'Sz8) 'Const -> m BS.ByteString -{-# INLINABLE rawBytes #-} --- TODO: we can get away with a more lax context than ReadCtx, maybe even make --- this non-monadic. -rawBytes (ListOf (NormalList M.WordPtr{pSegment, pAddr=WordAt{wordIndex}} len)) = do - let bytes = M.toByteString pSegment - let ByteCount byteOffset = wordsToBytes wordIndex - pure $ BS.take len $ BS.drop byteOffset bytes - - --- | Returns the root pointer of a message. -rootPtr :: ReadCtx m mut => M.Message mut -> m (Struct mut) -{-# INLINABLE rootPtr #-} -rootPtr msg = do - seg <- M.getSegment msg 0 - root <- get M.WordPtr - { pMessage = msg - , pSegment = seg - , pAddr = WordAt 0 0 - } - checkPtr root - invoicePtr root - case root of - Just (PtrStruct struct) -> pure struct - Nothing -> messageDefault @Struct msg - _ -> throwM $ E.SchemaViolationError - "Unexpected root type; expected struct." - - --- | Make the given struct the root object of its message. -setRoot :: M.WriteCtx m s => Struct ('Mut s) -> m () -{-# INLINABLE setRoot #-} -setRoot (StructAt M.WordPtr{pMessage, pAddr=addr} dataSz ptrSz) = do - pSegment <- M.getSegment pMessage 0 - let rootPtr = M.WordPtr{pMessage, pSegment, pAddr = WordAt 0 0} - setPointerTo rootPtr addr (P.StructPtr 0 dataSz ptrSz) - - --- | An instace of @'Allocate'@ specifies how to allocate a value with a given representation. --- This only makes sense for pointers of course, so it is defined on PtrRepr. Of the well-kinded --- types, only @'List 'Nothing@ is missing an instance. -class Allocate (r :: PtrRepr) where - -- | Extra information needed to allocate a value: - -- - -- * For structs, the sizes of the sections. - -- * For capabilities, the client to attach to the messages. - -- * For lists, the length, and for composite lists, the struct sizes as well. - type AllocHint r - - -- | Allocate a value of the given type. - alloc :: RWCtx m s => M.Message ('Mut s) -> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s))) - -instance Allocate 'Struct where - type AllocHint 'Struct = (Word16, Word16) - alloc msg = uncurry (allocStruct msg) -instance Allocate 'Cap where - type AllocHint 'Cap = M.Client - alloc = appendCap -instance Allocate ('List ('Just 'ListComposite)) where - type AllocHint ('List ('Just 'ListComposite)) = (Int, AllocHint 'Struct) - alloc msg (len, (nWords, nPtrs)) = allocCompositeList msg nWords nPtrs len -instance AllocateNormalList r => Allocate ('List ('Just ('ListNormal r))) where - type AllocHint ('List ('Just ('ListNormal r))) = Int - alloc = allocNormalList @r - --- | Like 'Allocate', but specialized to normal (non-composite) lists. --- --- Instead of an 'AllocHint' type family, the hint is always an 'Int', --- which is the number of elements. -class AllocateNormalList (r :: NormalListRepr) where - allocNormalList - :: RWCtx m s - => M.Message ('Mut s) -> Int -> m (UntypedSomeList ('ListNormal r) ('Mut s)) - -instance AllocateNormalList ('NormalListData 'Sz0) where allocNormalList = allocList0 -instance AllocateNormalList ('NormalListData 'Sz1) where allocNormalList = allocList1 -instance AllocateNormalList ('NormalListData 'Sz8) where allocNormalList = allocList8 -instance AllocateNormalList ('NormalListData 'Sz16) where allocNormalList = allocList16 -instance AllocateNormalList ('NormalListData 'Sz32) where allocNormalList = allocList32 -instance AllocateNormalList ('NormalListData 'Sz64) where allocNormalList = allocList64 -instance AllocateNormalList 'NormalListPtr where allocNormalList = allocListPtr - --- | Allocate a struct in the message. -allocStruct :: M.WriteCtx m s => M.Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s)) -{-# INLINABLE allocStruct #-} -allocStruct msg dataSz ptrSz = do - let totalSz = fromIntegral dataSz + fromIntegral ptrSz - ptr <- M.alloc msg totalSz - pure $ StructAt ptr dataSz ptrSz - --- | Allocate a composite list. -allocCompositeList - :: M.WriteCtx m s - => M.Message ('Mut s) -- ^ The message to allocate in. - -> Word16 -- ^ The size of the data section - -> Word16 -- ^ The size of the pointer section - -> Int -- ^ The length of the list in elements. - -> m (ListOf ('Ptr ('Just 'Struct)) ('Mut s)) -{-# INLINABLE allocCompositeList #-} -allocCompositeList msg dataSz ptrSz len = do - let eltSize = fromIntegral dataSz + fromIntegral ptrSz - ptr@M.WordPtr{pSegment, pAddr=addr@WordAt{wordIndex}} - <- M.alloc msg (WordCount $ len * eltSize + 1) -- + 1 for the tag word. - M.write pSegment wordIndex $ P.serializePtr' $ P.StructPtr (fromIntegral len) dataSz ptrSz - let firstStruct = StructAt - ptr { M.pAddr = addr { wordIndex = wordIndex + 1 } } - dataSz - ptrSz - pure $ ListOf $ StructList firstStruct len - --- | Allocate a list of capnproto @Void@ values. -allocList0 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz0) ('Mut s)) -{-# INLINABLE allocList0 #-} - --- | Allocate a list of booleans -allocList1 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz1) ('Mut s)) -{-# INLINABLE allocList1 #-} - --- | Allocate a list of 8-bit values. -allocList8 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz8) ('Mut s)) -{-# INLINABLE allocList8 #-} - --- | Allocate a list of 16-bit values. -allocList16 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz16) ('Mut s)) -{-# INLINABLE allocList16 #-} - --- | Allocate a list of 32-bit values. -allocList32 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz32) ('Mut s)) -{-# INLINABLE allocList32 #-} - --- | Allocate a list of 64-bit words. -allocList64 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz64) ('Mut s)) -{-# INLINABLE allocList64 #-} - --- | Allocate a list of pointers. -allocListPtr :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Ptr 'Nothing) ('Mut s)) -{-# INLINABLE allocListPtr #-} - -allocList0 msg len = ListOf <$> allocNormalList' 0 msg len -allocList1 msg len = ListOf <$> allocNormalList' 1 msg len -allocList8 msg len = ListOf <$> allocNormalList' 8 msg len -allocList16 msg len = ListOf <$> allocNormalList' 16 msg len -allocList32 msg len = ListOf <$> allocNormalList' 32 msg len -allocList64 msg len = ListOf <$> allocNormalList' 64 msg len -allocListPtr msg len = ListOf <$> allocNormalList' 64 msg len - --- | Allocate a NormalList -allocNormalList' - :: M.WriteCtx m s - => Int -- ^ The number bits per element - -> M.Message ('Mut s) -- ^ The message to allocate in - -> Int -- ^ The number of elements in the list. - -> m (NormalList ('Mut s)) -{-# INLINABLE allocNormalList' #-} -allocNormalList' bitsPerElt msg len = do - -- round 'len' up to the nearest word boundary. - let totalBits = BitCount (len * bitsPerElt) - totalWords = bytesToWordsCeil $ bitsToBytesCeil totalBits - ptr <- M.alloc msg totalWords - pure NormalList { nPtr = ptr, nLen = len } - -appendCap :: M.WriteCtx m s => M.Message ('Mut s) -> M.Client -> m (Cap ('Mut s)) -{-# INLINABLE appendCap #-} -appendCap msg client = do - i <- M.appendCap msg client - pure $ CapAt msg (fromIntegral i) - -instance MaybeMutable (ListRepOf r) => MaybeMutable (ListOf r) where - thaw (ListOf l) = ListOf <$> thaw l - freeze (ListOf l) = ListOf <$> freeze l - unsafeThaw (ListOf l) = ListOf <$> unsafeThaw l - unsafeFreeze (ListOf l) = ListOf <$> unsafeFreeze l - - -------------------------------------------------------------------------------- --- Helpers generated MaybeMutable instances -------------------------------------------------------------------------------- - --- trivial wrapaper around CatchT, so we can add a PrimMonad instance. -newtype CatchTWrap m a = CatchTWrap { runCatchTWrap :: CatchT m a } - deriving(Functor, Applicative, Monad, MonadTrans, MonadThrow, MonadCatch) - -instance PrimMonad m => PrimMonad (CatchTWrap m) where - type PrimState (CatchTWrap m) = PrimState m - primitive = lift . primitive - --- | @runCatchImpure m@ runs @m@, and if it throws, raises the --- exception with 'impureThrow'. -runCatchImpure :: Monad m => CatchTWrap m a -> m a -{-# INLINABLE runCatchImpure #-} -runCatchImpure m = do - res <- runCatchT $ runCatchTWrap m - pure $ case res of - Left e -> impureThrow e - Right v -> v - -------------------------------------------------------------------------------- --- Generated MaybeMutable instances -------------------------------------------------------------------------------- - -do - let mkWrappedInstance name = - let f = pure $ TH.ConT name in - [d|instance MaybeMutable $f where - thaw = runCatchImpure . tMsg thaw - freeze = runCatchImpure . tMsg freeze - unsafeThaw = runCatchImpure . tMsg unsafeThaw - unsafeFreeze = runCatchImpure . tMsg unsafeFreeze - |] - concat <$> traverse mkWrappedInstance - [ ''Ptr - , ''List - , ''Cap - , ''Struct - , ''NormalList - , ''StructList - ] - -do - let mkIsListPtrRepr (r, listC, str) = - [d| instance IsListPtrRepr $r where - rToList = $(pure $ TH.ConE listC) - rFromList $(pure $ TH.ConP listC [] [TH.VarP (TH.mkName "l")]) = pure l - rFromList _ = expected $(pure $ TH.LitE $ TH.StringL $ "pointer to " ++ str) - rFromListMsg = messageDefault @(Untyped ('Ptr ('Just ('List ('Just $r))))) - |] - concat <$> traverse mkIsListPtrRepr - [ ( [t| 'ListNormal ('NormalListData 'Sz0) |] - , 'List0 - , "List(Void)" - ) - , ( [t| 'ListNormal ('NormalListData 'Sz1) |] - , 'List1 - , "List(Bool)" - ) - , ( [t| 'ListNormal ('NormalListData 'Sz8) |] - , 'List8 - , "List(UInt8)" - ) - , ( [t| 'ListNormal ('NormalListData 'Sz16) |] - , 'List16 - , "List(UInt16)" - ) - , ( [t| 'ListNormal ('NormalListData 'Sz32) |] - , 'List32 - , "List(UInt32)" - ) - , ( [t| 'ListNormal ('NormalListData 'Sz64) |] - , 'List64 - , "List(UInt64)" - ) - , ( [t| 'ListNormal 'NormalListPtr |] - , 'ListPtr - , "List(AnyPointer)" - ) - , ( [t| 'ListComposite |] - , 'ListStruct - , "composite list" - ) - ] - -instance MaybeMutable (IgnoreMut a) where - thaw = pure . coerce - freeze = pure . coerce - -instance MaybeMutable MaybePtr where - thaw (MaybePtr p) = MaybePtr <$> traverse thaw p - freeze (MaybePtr p) = MaybePtr <$> traverse freeze p - unsafeThaw (MaybePtr p) = MaybePtr <$> traverse unsafeThaw p - unsafeFreeze (MaybePtr p) = MaybePtr <$> traverse unsafeFreeze p +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-error=deprecations #-} + +-- | +-- Module: Capnp.Untyped +-- Description: Utilities for reading capnproto messages with no schema. +-- +-- The types and functions in this module know about things like structs and +-- lists, but are not schema aware. +-- +-- Each of the data types exported by this module is parametrized over the +-- mutability of the message it contains (see "Capnp.Message"). +module Capnp.Untyped + ( -- * Type-level descriptions of wire representations. + Repr (..), + PtrRepr (..), + ListRepr (..), + NormalListRepr (..), + DataSz (..), + + -- * Mapping representations to value types. + Untyped, + UntypedData, + UntypedPtr, + UntypedSomePtr, + UntypedList, + UntypedSomeList, + IgnoreMut (..), + MaybePtr (..), + Unwrapped, + + -- * Relating the representations of lists & their elements. + Element (..), + ListItem (..), + ElemRepr, + ListReprFor, + + -- * Working with pointers + IsPtrRepr (..), + IsListPtrRepr (..), + + -- * Allocating values + Allocate (..), + AllocateNormalList (..), + Ptr (..), + List (..), + Struct, + ListOf, + Cap, + structByteCount, + structWordCount, + structPtrCount, + structListByteCount, + structListWordCount, + structListPtrCount, + getData, + getPtr, + setData, + setPtr, + copyStruct, + copyPtr, + copyList, + copyCap, + getClient, + get, + index, + setIndex, + take, + rootPtr, + setRoot, + rawBytes, + ReadCtx, + RWCtx, + HasMessage (..), + MessageDefault (..), + allocStruct, + allocCompositeList, + allocList0, + allocList1, + allocList8, + allocList16, + allocList32, + allocList64, + allocListPtr, + appendCap, + TraverseMsg (..), + ) +where + +import Capnp.Address + ( OffsetError (..), + WordAddr (..), + pointerFrom, + resolveOffset, + ) +import Capnp.Bits + ( BitCount (..), + ByteCount (..), + Word1 (..), + WordCount (..), + bitsToBytesCeil, + bytesToWordsCeil, + replaceBits, + wordsToBytes, + ) +import qualified Capnp.Errors as E +import qualified Capnp.Message as M +import Capnp.Mutability (MaybeMutable (..), Mutability (..)) +import qualified Capnp.Pointer as P +import Capnp.TraversalLimit (LimitT, MonadLimit (invoice)) +import Control.Exception.Safe (impureThrow) +import Control.Monad (forM_, unless) +import Control.Monad.Catch (MonadCatch, MonadThrow (throwM)) +import Control.Monad.Catch.Pure (CatchT (runCatchT)) +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.ST (RealWorld) +import Control.Monad.Trans.Class (MonadTrans (lift)) +import Data.Bits +import qualified Data.ByteString as BS +import Data.Coerce (coerce) +import Data.Function ((&)) +import Data.Kind (Type) +import qualified Data.Vector.Storable.Mutable as SMV +import Data.Word +import Internal.BuildPure (PureBuilder) +import qualified Language.Haskell.TH as TH +import Prelude hiding (length, take) + +------------------------------------------------------------------------------- +-- Untyped refernces to values in a message. +------------------------------------------------------------------------------- + +-- | A an absolute pointer to a value (of arbitrary type) in a message. +-- Note that there is no variant for far pointers, which don't make sense +-- with absolute addressing. +data Ptr mut + = PtrCap (Cap mut) + | PtrList (List mut) + | PtrStruct (Struct mut) + +-- | A list of values (of arbitrary type) in a message. +data List mut + = List0 (ListOf ('Data 'Sz0) mut) + | List1 (ListOf ('Data 'Sz1) mut) + | List8 (ListOf ('Data 'Sz8) mut) + | List16 (ListOf ('Data 'Sz16) mut) + | List32 (ListOf ('Data 'Sz32) mut) + | List64 (ListOf ('Data 'Sz64) mut) + | ListPtr (ListOf ('Ptr 'Nothing) mut) + | ListStruct (ListOf ('Ptr ('Just 'Struct)) mut) + +-- | A "normal" (non-composite) list. +data NormalList mut = NormalList + { nPtr :: {-# UNPACK #-} !(M.WordPtr mut), + nLen :: !Int + } + +data StructList mut = StructList + { -- | First element. data/ptr sizes are the same for + -- all elements. + slFirst :: Struct mut, + -- | Number of elements + slLen :: !Int + } + +-- | A list of values with representation 'r' in a message. +newtype ListOf r mut = ListOf (ListRepOf r mut) + +type family ListRepOf (r :: Repr) :: Mutability -> Type where + ListRepOf ('Ptr ('Just 'Struct)) = StructList + ListRepOf r = NormalList + +-- | @'ListItem' r@ indicates that @r@ is a representation for elements of some list +-- type. Not every representation is covered; instances exist only for @r@ where +-- @'ElemRepr' ('ListReprFor' r) ~ r@. +class Element r => ListItem (r :: Repr) where + -- | Returns the length of a list + length :: ListOf r mut -> Int + + -- underlying implementations of index, setIndex and take, but + -- without bounds checking. Don't call these directly. + unsafeIndex :: ReadCtx m mut => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut)) + unsafeSetIndex :: + (RWCtx m s, a ~ Unwrapped (Untyped r ('Mut s))) => + a -> + Int -> + ListOf r ('Mut s) -> + m () + unsafeTake :: Int -> ListOf r mut -> ListOf r mut + + checkListOf :: ReadCtx m mut => ListOf r mut -> m () + + -- | Make a copy of the list, in the target message. + copyListOf :: RWCtx m s => ListOf r ('Mut s) -> ListOf r ('Mut s) -> m () + {-# INLINE copyListOf #-} + copyListOf dest src = + forM_ [0 .. length src - 1] $ \i -> do + value <- index i src + setIndex value i dest + + default length :: (ListRepOf r ~ NormalList) => ListOf r mut -> Int + length (ListOf nlist) = nLen nlist + {-# INLINE length #-} + + default unsafeIndex :: + forall m mut. + ( ReadCtx m mut, + Integral (Unwrapped (Untyped r mut)), + ListRepOf r ~ NormalList, + FiniteBits (Unwrapped (Untyped r mut)) + ) => + Int -> + ListOf r mut -> + m (Unwrapped (Untyped r mut)) + unsafeIndex i (ListOf nlist) = + unsafeIndexBits @(Unwrapped (Untyped r mut)) i nlist + {-# INLINE unsafeIndex #-} + + default unsafeSetIndex :: + forall m s a. + ( RWCtx m s, + a ~ Unwrapped (Untyped r ('Mut s)), + ListRepOf r ~ NormalList, + Integral a, + Bounded a, + FiniteBits a + ) => + a -> + Int -> + ListOf r ('Mut s) -> + m () + unsafeSetIndex value i (ListOf nlist) = + unsafeSetIndexBits @(Unwrapped (Untyped r ('Mut s))) value i nlist + {-# INLINE unsafeSetIndex #-} + + default unsafeTake :: ListRepOf r ~ NormalList => Int -> ListOf r mut -> ListOf r mut + unsafeTake count (ListOf NormalList {..}) = ListOf NormalList {nLen = count, ..} + {-# INLINE unsafeTake #-} + + default checkListOf :: + forall m mut. + ( ReadCtx m mut, + ListRepOf r ~ NormalList, + FiniteBits (Untyped r mut) + ) => + ListOf r mut -> + m () + checkListOf (ListOf l) = + checkNormalList + l + (fromIntegral $ finiteBitSize (undefined :: Untyped r mut)) + {-# INLINE checkListOf #-} + +unsafeIndexBits :: + forall a m mut. + ( ReadCtx m mut, + FiniteBits a, + Integral a + ) => + Int -> + NormalList mut -> + m a +{-# INLINE unsafeIndexBits #-} +unsafeIndexBits i nlist = + indexNList @a i nlist (64 `div` finiteBitSize (undefined :: a)) + +unsafeSetIndexBits :: + forall a m s. + ( RWCtx m s, + Bounded a, + FiniteBits a, + Integral a + ) => + a -> + Int -> + NormalList ('Mut s) -> + m () +{-# INLINE unsafeSetIndexBits #-} +unsafeSetIndexBits value i nlist = + setNIndex @a i nlist (64 `div` finiteBitSize value) value + +indexNList :: + forall a m mut. + (ReadCtx m mut, Integral a) => + Int -> + NormalList mut -> + Int -> + m a +{-# INLINE indexNList #-} +indexNList i (NormalList M.WordPtr {pSegment, pAddr = WordAt {..}} _) eltsPerWord = do + let wordIndex' = wordIndex + WordCount (i `div` eltsPerWord) + word <- M.read pSegment wordIndex' + let shift = (i `mod` eltsPerWord) * (64 `div` eltsPerWord) + pure $ fromIntegral $ word `shiftR` shift + +setNIndex :: + forall a m s. + (RWCtx m s, Bounded a, Integral a) => + Int -> + NormalList ('Mut s) -> + Int -> + a -> + m () +{-# INLINE setNIndex #-} +setNIndex i NormalList {nPtr = M.WordPtr {pSegment, pAddr = WordAt {wordIndex}}} eltsPerWord value = do + let eltWordIndex = wordIndex + WordCount (i `div` eltsPerWord) + word <- M.read pSegment eltWordIndex + let shift = (i `mod` eltsPerWord) * (64 `div` eltsPerWord) + M.write pSegment eltWordIndex $ replaceBits value word shift + +setPtrIndex :: RWCtx m s => Int -> NormalList ('Mut s) -> Ptr ('Mut s) -> P.Ptr -> m () +{-# INLINE setPtrIndex #-} +setPtrIndex i NormalList {nPtr = nPtr@M.WordPtr {pAddr = addr@WordAt {wordIndex}}} absPtr relPtr = + let srcPtr = nPtr {M.pAddr = addr {wordIndex = wordIndex + WordCount i}} + in setPointerTo srcPtr (ptrAddr absPtr) relPtr + +instance ListItem ('Ptr ('Just 'Struct)) where + length (ListOf (StructList _ len)) = len + {-# INLINE length #-} + unsafeIndex i (ListOf (StructList (StructAt ptr@M.WordPtr {pAddr = addr@WordAt {..}} dataSz ptrSz) _)) = do + let offset = WordCount $ i * (fromIntegral dataSz + fromIntegral ptrSz) + let addr' = addr {wordIndex = wordIndex + offset} + return $ StructAt ptr {M.pAddr = addr'} dataSz ptrSz + {-# INLINE unsafeIndex #-} + unsafeSetIndex value i list = do + dest <- unsafeIndex i list + copyStruct dest value + unsafeTake count (ListOf (StructList s _)) = ListOf (StructList s count) + {-# INLINE unsafeTake #-} + + checkListOf (ListOf (StructList s@(StructAt ptr _ _) len)) = + checkPtrOffset ptr (fromIntegral len * structSize s) + {-# INLINE checkListOf #-} + +instance ListItem ('Data 'Sz0) where + unsafeIndex _ _ = pure () + {-# INLINE unsafeIndex #-} + unsafeSetIndex _ _ _ = pure () + {-# INLINE unsafeSetIndex #-} + checkListOf _ = pure () + {-# INLINE checkListOf #-} + copyListOf _ _ = pure () + {-# INLINE copyListOf #-} + +instance ListItem ('Data 'Sz1) where + unsafeIndex i (ListOf nlist) = do + Word1 val <- unsafeIndexBits @Word1 i nlist + pure val + {-# INLINE unsafeIndex #-} + unsafeSetIndex value i (ListOf nlist) = + unsafeSetIndexBits @Word1 (Word1 value) i nlist + {-# INLINE unsafeSetIndex #-} + checkListOf (ListOf l) = checkNormalList l 1 + {-# INLINE copyListOf #-} + copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 1 + +instance ListItem ('Data 'Sz8) where + {-# INLINE copyListOf #-} + copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 8 + +instance ListItem ('Data 'Sz16) where + {-# INLINE copyListOf #-} + copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 16 + +instance ListItem ('Data 'Sz32) where + {-# INLINE copyListOf #-} + copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 32 + +instance ListItem ('Data 'Sz64) where + {-# INLINE copyListOf #-} + copyListOf (ListOf dest) (ListOf src) = copyDataList dest src 64 + +instance ListItem ('Ptr 'Nothing) where + unsafeIndex i (ListOf (NormalList ptr@M.WordPtr {pAddr = addr@WordAt {..}} _)) = + get ptr {M.pAddr = addr {wordIndex = wordIndex + WordCount i}} + {-# INLINE unsafeIndex #-} + unsafeSetIndex value i list@(ListOf nlist) = case value of + Just p | message @Ptr p /= message @(ListOf ('Ptr 'Nothing)) list -> do + newPtr <- copyPtr (message @(ListOf ('Ptr 'Nothing)) list) value + unsafeSetIndex newPtr i list + Nothing -> + setNIndex i nlist 1 (P.serializePtr Nothing) + Just (PtrCap (CapAt _ cap)) -> + setNIndex i nlist 1 (P.serializePtr (Just (P.CapPtr cap))) + Just p@(PtrList ptrList) -> + setPtrIndex i nlist p $ P.ListPtr 0 (listEltSpec ptrList) + Just p@(PtrStruct (StructAt _ dataSz ptrSz)) -> + setPtrIndex i nlist p $ P.StructPtr 0 dataSz ptrSz + {-# INLINEABLE unsafeSetIndex #-} + + checkListOf (ListOf l) = checkNormalList l 64 + {-# INLINE checkListOf #-} + +-- | A Capability in a message. +data Cap mut = CapAt (M.Message mut) !Word32 + +-- | A struct value in a message. +data Struct mut + = StructAt + {-# UNPACK #-} !(M.WordPtr mut) -- Start of struct + !Word16 -- Data section size. + !Word16 -- Pointer section size. + +-- | Type (constraint) synonym for the constraints needed for most read +-- operations. +type ReadCtx m mut = (M.MonadReadMessage mut m, MonadThrow m, MonadLimit m) + +-- | Synonym for ReadCtx + WriteCtx +type RWCtx m s = (ReadCtx m ('Mut s), M.WriteCtx m s) + +-- | A 'Repr' describes a wire representation for a value. This is +-- mostly used at the type level (using DataKinds); types are +-- parametrized over representations. +data Repr + = -- | Pointer type. 'Nothing' indicates an AnyPointer, 'Just' describes + -- a more specific pointer type. + Ptr (Maybe PtrRepr) + | -- | Non-pointer type. + Data DataSz + deriving (Show) + +-- | Information about the representation of a pointer type +data PtrRepr + = -- | Capability pointer. + Cap + | -- | List pointer. 'Nothing' describes an AnyList, 'Just' describes + -- more specific list types. + List (Maybe ListRepr) + | -- | A struct (or group). + Struct + deriving (Show) + +-- | Information about the representation of a list type. +data ListRepr where + -- | A "normal" list + ListNormal :: NormalListRepr -> ListRepr + -- | A composite (struct) list + ListComposite :: ListRepr + deriving (Show) + +-- | Information about the representation of a normal (non-composite) list. +data NormalListRepr where + NormalListData :: DataSz -> NormalListRepr + NormalListPtr :: NormalListRepr + deriving (Show) + +-- | The size of a non-pointer type. @SzN@ represents an @N@-bit value. +data DataSz = Sz0 | Sz1 | Sz8 | Sz16 | Sz32 | Sz64 + deriving (Show) + +-- | Wrapper for use with 'Untyped'; see docs for 'Untyped' +newtype IgnoreMut a (mut :: Mutability) = IgnoreMut a + deriving (Show, Read, Eq, Ord, Enum, Bounded, Num, Real, Integral, Bits, FiniteBits) + +-- | Wrapper for use with 'Untyped'; see docs for 'Untyped'. +newtype MaybePtr (mut :: Mutability) = MaybePtr (Maybe (Ptr mut)) + +-- | Normalizes types returned by 'Untyped'; see docs for 'Untyped'. +type family Unwrapped a where + Unwrapped (IgnoreMut a mut) = a + Unwrapped (MaybePtr mut) = Maybe (Ptr mut) + Unwrapped a = a + +-- | @Untyped r mut@ is an untyped value with representation @r@ stored in +-- a message with mutability @mut@. +-- +-- Note that the return type of this type family has kind +-- @'Mutability' -> 'Type'@. This is important, as it allows us +-- to define instances on @'Untyped' r@, and use @'Untyped' r@ +-- in constraints. +-- +-- This introduces some awkwardnesses though -- we really want +-- this to be @(Maybe (Ptr mut))@ for @'Ptr 'Nothing@, and +-- Int types/Bool/() for @'Data sz@. But we can't because these +-- are the wrong kind. +-- +-- So, we hack around this by introducing two newtypes, 'IgnoreMut' +-- and 'MaybePtr', and a type family 'Unwrapped', which lets us +-- use @'Unwrapped' ('Untyped' r mut)@ as the type we really want +-- in some places, though we can't curry it then. +-- +-- All this is super super awkward, but this is a low level +-- mostly-internal API; most users will intract with this through +-- the Raw type in "Capnp.Repr", which hides all of this... +type family Untyped (r :: Repr) :: Mutability -> Type where + Untyped ('Data sz) = IgnoreMut (UntypedData sz) + Untyped ('Ptr ptr) = UntypedPtr ptr + +-- | @UntypedData sz@ is an untyped value with size @sz@. +type family UntypedData (sz :: DataSz) :: Type where + UntypedData 'Sz0 = () + UntypedData 'Sz1 = Bool + UntypedData 'Sz8 = Word8 + UntypedData 'Sz16 = Word16 + UntypedData 'Sz32 = Word32 + UntypedData 'Sz64 = Word64 + +-- | Like 'Untyped', but for pointers only. +type family UntypedPtr (r :: Maybe PtrRepr) :: Mutability -> Type where + UntypedPtr 'Nothing = MaybePtr + UntypedPtr ('Just r) = UntypedSomePtr r + +-- | Like 'UntypedPtr', but doesn't allow AnyPointers. +type family UntypedSomePtr (r :: PtrRepr) :: Mutability -> Type where + UntypedSomePtr 'Struct = Struct + UntypedSomePtr 'Cap = Cap + UntypedSomePtr ('List r) = UntypedList r + +-- | Like 'Untyped', but for lists only. +type family UntypedList (r :: Maybe ListRepr) :: Mutability -> Type where + UntypedList 'Nothing = List + UntypedList ('Just r) = UntypedSomeList r + +-- | Like 'UntypedList', but doesn't allow AnyLists. +type family UntypedSomeList (r :: ListRepr) :: Mutability -> Type where + UntypedSomeList r = ListOf (ElemRepr r) + +-- | @ElemRepr r@ is the representation of elements of lists with +-- representation @r@. +type family ElemRepr (rl :: ListRepr) :: Repr where + ElemRepr 'ListComposite = 'Ptr ('Just 'Struct) + ElemRepr ('ListNormal 'NormalListPtr) = 'Ptr 'Nothing + ElemRepr ('ListNormal ('NormalListData sz)) = 'Data sz + +-- | @ListReprFor e@ is the representation of lists with elements +-- whose representation is @e@. +type family ListReprFor (e :: Repr) :: ListRepr where + ListReprFor ('Data sz) = 'ListNormal ('NormalListData sz) + ListReprFor ('Ptr ('Just 'Struct)) = 'ListComposite + ListReprFor ('Ptr a) = 'ListNormal 'NormalListPtr + +-- | 'Element' supports converting between values of representation +-- @'ElemRepr' ('ListReprFor' r)@ and values of representation @r@. +-- +-- At a glance, you might expect this to just be a no-op, but it is actually +-- *not* always the case that @'ElemRepr' ('ListReprFor' r) ~ r@; in the +-- case of pointer types, @'ListReprFor' r@ can contain arbitrary pointers, +-- so information is lost, and it is possible for the list to contain pointers +-- of the incorrect type. In this case, 'fromElement' will throw an error. +-- +-- 'toElement' is more trivial. +class Element (r :: Repr) where + fromElement :: + forall m mut. + ReadCtx m mut => + M.Message mut -> + Unwrapped (Untyped (ElemRepr (ListReprFor r)) mut) -> + m (Unwrapped (Untyped r mut)) + toElement :: Unwrapped (Untyped r mut) -> Unwrapped (Untyped (ElemRepr (ListReprFor r)) mut) + +-- | Operations on types with pointer representations. +class IsPtrRepr (r :: Maybe PtrRepr) where + toPtr :: Unwrapped (Untyped ('Ptr r) mut) -> Maybe (Ptr mut) + -- ^ Convert an untyped value of this representation to an AnyPointer. + + fromPtr :: ReadCtx m mut => M.Message mut -> Maybe (Ptr mut) -> m (Unwrapped (Untyped ('Ptr r) mut)) + -- ^ Extract a value with this representation from an AnyPointer, failing + -- if the pointer is the wrong type for this representation. + +-- | Operations on types with list representations. +class IsListPtrRepr (r :: ListRepr) where + rToList :: UntypedSomeList r mut -> List mut + -- ^ Convert an untyped value of this representation to an AnyList. + + rFromList :: ReadCtx m mut => List mut -> m (UntypedSomeList r mut) + -- ^ Extract a value with this representation from an AnyList, failing + -- if the list is the wrong type for this representation. + + rFromListMsg :: ReadCtx m mut => M.Message mut -> m (UntypedSomeList r mut) + -- ^ Create a zero-length value with this representation, living in the + -- provided message. + +-- helper function for throwing SchemaViolationError "expected ..." +expected :: MonadThrow m => String -> m a +expected msg = throwM $ E.SchemaViolationError $ "expected " ++ msg + +------------------------------------------------------------------------------- +-- 'Element' instances +------------------------------------------------------------------------------- + +instance Element ('Data sz) where + fromElement _ = pure + toElement = id + {-# INLINE fromElement #-} + {-# INLINE toElement #-} + +instance Element ('Ptr ('Just 'Struct)) where + fromElement _ = pure + toElement = id + {-# INLINE fromElement #-} + {-# INLINE toElement #-} + +instance Element ('Ptr 'Nothing) where + fromElement _ = pure + toElement = id + {-# INLINE fromElement #-} + {-# INLINE toElement #-} + +instance Element ('Ptr ('Just 'Cap)) where + fromElement = fromPtr @('Just 'Cap) + toElement = Just . PtrCap + {-# INLINE fromElement #-} + {-# INLINE toElement #-} + +instance IsPtrRepr ('Just ('List a)) => Element ('Ptr ('Just ('List a))) where + fromElement = fromPtr @('Just ('List a)) + toElement = toPtr @('Just ('List a)) + {-# INLINE fromElement #-} + {-# INLINE toElement #-} + +------------------------------------------------------------------------------- +-- 'IsPtrRepr' instances +------------------------------------------------------------------------------- + +instance IsPtrRepr 'Nothing where + toPtr p = p + fromPtr _ = pure + {-# INLINE toPtr #-} + {-# INLINE fromPtr #-} + +instance IsPtrRepr ('Just 'Struct) where + toPtr s = Just (PtrStruct s) + fromPtr msg Nothing = messageDefault @Struct msg + fromPtr _ (Just (PtrStruct s)) = pure s + fromPtr _ _ = expected "pointer to struct" + {-# INLINE toPtr #-} + {-# INLINE fromPtr #-} + +instance IsPtrRepr ('Just 'Cap) where + toPtr c = Just (PtrCap c) + fromPtr _ Nothing = expected "pointer to capability" + fromPtr _ (Just (PtrCap c)) = pure c + fromPtr _ _ = expected "pointer to capability" + {-# INLINE toPtr #-} + {-# INLINE fromPtr #-} + +instance IsPtrRepr ('Just ('List 'Nothing)) where + toPtr l = Just (PtrList l) + fromPtr _ Nothing = expected "pointer to list" + fromPtr _ (Just (PtrList l)) = pure l + fromPtr _ (Just _) = expected "pointer to list" + {-# INLINE toPtr #-} + {-# INLINE fromPtr #-} + +instance IsListPtrRepr r => IsPtrRepr ('Just ('List ('Just r))) where + toPtr l = Just (PtrList (rToList @r l)) + fromPtr msg Nothing = rFromListMsg @r msg + fromPtr _ (Just (PtrList l)) = rFromList @r l + fromPtr _ (Just _) = expected "pointer to list" + {-# INLINE toPtr #-} + {-# INLINE fromPtr #-} + +-- | N.B. this should mostly be considered an implementation detail, but +-- it is exposed because it is used by generated code. +-- +-- 'TraverseMsg' is similar to 'Traversable' from the prelude, but +-- the intent is that rather than conceptually being a "container", +-- the instance is a value backed by a message, and the point of the +-- type class is to be able to apply transformations to the underlying +-- message. +-- +-- We don't just use 'Traversable' for this for two reasons: +-- +-- 1. While algebraically it makes sense, it would be very unintuitive to +-- e.g. have the 'Traversable' instance for 'List' not traverse over the +-- *elements* of the list. +-- 2. For the instance for WordPtr, we actually need a stronger constraint than +-- Applicative in order for the implementation to type check. A previous +-- version of the library *did* have @tMsg :: Applicative m => ...@, but +-- performance considerations eventually forced us to open up the hood a +-- bit. +class TraverseMsg f where + tMsg :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> f mutA -> m (f mutB) + +type TraverseMsgCtx m mutA mutB = + ( MonadThrow m, + M.MonadReadMessage mutA m, + M.MonadReadMessage mutB m + ) + +instance TraverseMsg M.WordPtr where + tMsg f M.WordPtr {pMessage, pAddr = pAddr@WordAt {segIndex}} = do + msg' <- f pMessage + seg' <- M.getSegment msg' segIndex + pure + M.WordPtr + { pMessage = msg', + pSegment = seg', + pAddr + } + +instance TraverseMsg Ptr where + tMsg f = \case + PtrCap cap -> + PtrCap <$> tMsg f cap + PtrList l -> + PtrList <$> tMsg f l + PtrStruct s -> + PtrStruct <$> tMsg f s + +instance TraverseMsg Cap where + tMsg f (CapAt msg n) = CapAt <$> f msg <*> pure n + +instance TraverseMsg Struct where + tMsg f (StructAt ptr dataSz ptrSz) = + StructAt + <$> tMsg f ptr + <*> pure dataSz + <*> pure ptrSz + +instance TraverseMsg List where + tMsg f = \case + List0 l -> List0 <$> tMsg f l + List1 l -> List1 <$> tMsg f l + List8 l -> List8 <$> tMsg f l + List16 l -> List16 <$> tMsg f l + List32 l -> List32 <$> tMsg f l + List64 l -> List64 <$> tMsg f l + ListPtr l -> ListPtr <$> tMsg f l + ListStruct l -> ListStruct <$> tMsg f l + +instance TraverseMsg (ListRepOf r) => TraverseMsg (ListOf r) where + tMsg f (ListOf l) = ListOf <$> tMsg f l + +instance TraverseMsg NormalList where + tMsg f NormalList {..} = do + ptr <- tMsg f nPtr + pure NormalList {nPtr = ptr, ..} + +instance TraverseMsg StructList where + tMsg f StructList {..} = do + s <- tMsg f slFirst + pure StructList {slFirst = s, ..} + +------------------------------------------------------------------------------- + +-- | Types whose storage is owned by a message.. +class HasMessage (f :: Mutability -> Type) where + -- | Get the message in which the value is stored. + message :: Unwrapped (f mut) -> M.Message mut + +-- | Types which have a "default" value, but require a message +-- to construct it. +-- +-- The default is usually conceptually zero-size. This is mostly useful +-- for generated code, so that it can use standard decoding techniques +-- on default values. +class HasMessage f => MessageDefault f where + messageDefault :: ReadCtx m mut => M.Message mut -> m (Unwrapped (f mut)) + +instance HasMessage M.WordPtr where + message M.WordPtr {pMessage} = pMessage + +instance HasMessage Ptr where + message (PtrCap cap) = message @Cap cap + message (PtrList list) = message @List list + message (PtrStruct struct) = message @Struct struct + +instance HasMessage Cap where + message (CapAt msg _) = msg + +instance HasMessage Struct where + message (StructAt ptr _ _) = message @M.WordPtr ptr + +instance MessageDefault Struct where + messageDefault msg = do + pSegment <- M.getSegment msg 0 + pure $ StructAt M.WordPtr {pMessage = msg, pSegment, pAddr = WordAt 0 0} 0 0 + +instance HasMessage List where + message (List0 list) = message @(ListOf ('Data 'Sz0)) list + message (List1 list) = message @(ListOf ('Data 'Sz1)) list + message (List8 list) = message @(ListOf ('Data 'Sz8)) list + message (List16 list) = message @(ListOf ('Data 'Sz16)) list + message (List32 list) = message @(ListOf ('Data 'Sz32)) list + message (List64 list) = message @(ListOf ('Data 'Sz64)) list + message (ListPtr list) = message @(ListOf ('Ptr 'Nothing)) list + message (ListStruct list) = message @(ListOf ('Ptr ('Just 'Struct))) list + +instance HasMessage (ListOf ('Ptr ('Just 'Struct))) where + message (ListOf list) = message @StructList list + +instance MessageDefault (ListOf ('Ptr ('Just 'Struct))) where + messageDefault msg = ListOf <$> messageDefault @StructList msg + +instance {-# OVERLAPS #-} ListRepOf r ~ NormalList => HasMessage (ListOf r) where + message (ListOf list) = message @NormalList list + +instance {-# OVERLAPS #-} ListRepOf r ~ NormalList => MessageDefault (ListOf r) where + messageDefault msg = ListOf <$> messageDefault @NormalList msg + +instance HasMessage NormalList where + message = M.pMessage . nPtr + +instance MessageDefault NormalList where + messageDefault msg = do + pSegment <- M.getSegment msg 0 + pure + NormalList + { nPtr = M.WordPtr {pMessage = msg, pSegment, pAddr = WordAt 0 0}, + nLen = 0 + } + +instance HasMessage StructList where + message (StructList s _) = message @Struct s + +instance MessageDefault StructList where + messageDefault msg = + StructList + <$> messageDefault @Struct msg + <*> pure 0 + +-- | Extract a client (indepedent of the messsage) from the capability. +getClient :: ReadCtx m mut => Cap mut -> m M.Client +{-# INLINEABLE getClient #-} +getClient (CapAt msg idx) = M.getCap msg (fromIntegral idx) + +-- | @get ptr@ returns the Ptr stored at @ptr@. +-- Deducts 1 from the quota for each word read (which may be multiple in the +-- case of far pointers). +get :: ReadCtx m mut => M.WordPtr mut -> m (Maybe (Ptr mut)) +{-# INLINEABLE get #-} +{-# SPECIALIZE get :: M.WordPtr ('Mut RealWorld) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-} +{-# SPECIALIZE get :: M.WordPtr ('Mut s) -> PureBuilder s (Maybe (Ptr ('Mut s))) #-} +get ptr = do + word <- M.getWord ptr + case P.parsePtr word of + Just (P.FarPtr twoWords offset segment) -> getFar ptr twoWords offset segment + v -> getNear ptr v + +getFar :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> Bool -> Word32 -> Word32 -> m (Maybe (Ptr mut)) +getFar M.WordPtr {pMessage} twoWords offset segment = do + landingSegment <- M.getSegment pMessage (fromIntegral segment) + let addr' = + WordAt + { wordIndex = fromIntegral offset, + segIndex = fromIntegral segment + } + let landingPtr = + M.WordPtr + { pMessage, + pSegment = landingSegment, + pAddr = addr' + } + landingPad <- M.getWord landingPtr + if not twoWords + then getNear landingPtr (P.parsePtr landingPad) + else do + case P.parsePtr landingPad of + Just (P.FarPtr False off seg) -> do + let segIndex = fromIntegral seg + finalSegment <- M.getSegment pMessage segIndex + tagWord <- + M.getWord + M.WordPtr + { pMessage, + pSegment = landingSegment, + M.pAddr = addr' {wordIndex = wordIndex addr' + 1} + } + let finalPtr = + M.WordPtr + { pMessage, + pSegment = finalSegment, + pAddr = + WordAt + { wordIndex = fromIntegral off, + segIndex + } + } + case P.parsePtr tagWord of + Just (P.StructPtr 0 dataSz ptrSz) -> + return $ + Just $ + PtrStruct $ + StructAt finalPtr dataSz ptrSz + Just (P.ListPtr 0 eltSpec) -> + Just . PtrList <$> getList finalPtr eltSpec + -- TODO: I'm not sure whether far pointers to caps are + -- legal; it's clear how they would work, but I don't + -- see a use, and the spec is unclear. Should check + -- how the reference implementation does this, copy + -- that, and submit a patch to the spec. + Just (P.CapPtr cap) -> + return $ Just $ PtrCap (CapAt pMessage cap) + ptr -> + throwM $ + E.InvalidDataError $ + "The tag word of a far pointer's " + ++ "2-word landing pad should be an intra " + ++ "segment pointer with offset 0, but " + ++ "we read " + ++ show ptr + ptr -> + throwM $ + E.InvalidDataError $ + "The first word of a far pointer's 2-word " + ++ "landing pad should be another far pointer " + ++ "(with a one-word landing pad), but we read " + ++ show ptr + +getNear :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> Maybe P.Ptr -> m (Maybe (Ptr mut)) +getNear ptr@M.WordPtr {pMessage, pAddr} = \case + Nothing -> return Nothing + Just p -> case p of + P.CapPtr cap -> return $ Just $ PtrCap (CapAt pMessage cap) + P.StructPtr off dataSz ptrSz -> + return $ + Just $ + PtrStruct $ + StructAt ptr {M.pAddr = resolveOffset pAddr off} dataSz ptrSz + P.ListPtr off eltSpec -> + Just . PtrList + <$> getList ptr {M.pAddr = resolveOffset pAddr off} eltSpec + P.FarPtr {} -> + throwM $ + E.InvalidDataError + "Unexpected far pointer where only near pointers were expected." + +getList :: (M.MonadReadMessage mut m, MonadThrow m) => M.WordPtr mut -> P.EltSpec -> m (List mut) +getList ptr@M.WordPtr {pAddr = addr@WordAt {wordIndex}} eltSpec = + case eltSpec of + P.EltNormal sz len -> pure $ case sz of + P.Sz0 -> List0 (ListOf nlist) + P.Sz1 -> List1 (ListOf nlist) + P.Sz8 -> List8 (ListOf nlist) + P.Sz16 -> List16 (ListOf nlist) + P.Sz32 -> List32 (ListOf nlist) + P.Sz64 -> List64 (ListOf nlist) + P.SzPtr -> ListPtr (ListOf nlist) + where + nlist = NormalList ptr (fromIntegral len) + P.EltComposite _ -> do + tagWord <- M.getWord ptr + case P.parsePtr' tagWord of + P.StructPtr numElts dataSz ptrSz -> + pure $ + ListStruct $ + ListOf $ + StructList + ( StructAt + ptr {M.pAddr = addr {wordIndex = wordIndex + 1}} + dataSz + ptrSz + ) + (fromIntegral numElts) + tag -> + throwM $ + E.InvalidDataError $ + "Composite list tag was not a struct-" + ++ "formatted word: " + ++ show tag + +-- | Return the EltSpec needed for a pointer to the given list. +listEltSpec :: List msg -> P.EltSpec +listEltSpec (ListStruct list@(ListOf (StructList (StructAt _ dataSz ptrSz) _))) = + P.EltComposite $ fromIntegral (length list) * (fromIntegral dataSz + fromIntegral ptrSz) +listEltSpec (List0 list) = P.EltNormal P.Sz0 $ fromIntegral (length list) +listEltSpec (List1 list) = P.EltNormal P.Sz1 $ fromIntegral (length list) +listEltSpec (List8 list) = P.EltNormal P.Sz8 $ fromIntegral (length list) +listEltSpec (List16 list) = P.EltNormal P.Sz16 $ fromIntegral (length list) +listEltSpec (List32 list) = P.EltNormal P.Sz32 $ fromIntegral (length list) +listEltSpec (List64 list) = P.EltNormal P.Sz64 $ fromIntegral (length list) +listEltSpec (ListPtr list) = P.EltNormal P.SzPtr $ fromIntegral (length list) + +-- | Return the starting address of the list. +listAddr :: List msg -> WordAddr +listAddr (ListStruct (ListOf (StructList (StructAt M.WordPtr {pAddr} _ _) _))) = + -- pAddr is the address of the first element of the list, but + -- composite lists start with a tag word: + pAddr {wordIndex = wordIndex pAddr - 1} +listAddr (List0 (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr +listAddr (List1 (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr +listAddr (List8 (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr +listAddr (List16 (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr +listAddr (List32 (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr +listAddr (List64 (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr +listAddr (ListPtr (ListOf NormalList {nPtr = M.WordPtr {pAddr}})) = pAddr + +-- | Return the address of the pointer's target. It is illegal to call this on +-- a pointer which targets a capability. +ptrAddr :: Ptr msg -> WordAddr +ptrAddr (PtrCap _) = error "ptrAddr called on a capability pointer." +ptrAddr (PtrStruct (StructAt M.WordPtr {pAddr} _ _)) = pAddr +ptrAddr (PtrList list) = listAddr list + +-- | @'setIndex value i list@ Set the @i@th element of @list@ to @value@. +setIndex :: + (RWCtx m s, ListItem r) => + Unwrapped (Untyped r ('Mut s)) -> + Int -> + ListOf r ('Mut s) -> + m () +{-# INLINE setIndex #-} +{-# SPECIALIZE setIndex :: + ListItem r => + Unwrapped (Untyped r ('Mut RealWorld)) -> + Int -> + ListOf r ('Mut RealWorld) -> + LimitT IO () + #-} +{-# SPECIALIZE setIndex :: + ListItem r => + Unwrapped (Untyped r ('Mut s)) -> + Int -> + ListOf r ('Mut s) -> + PureBuilder s () + #-} +setIndex _ i list + | i < 0 || length list <= i = + throwM E.BoundsError {E.index = i, E.maxIndex = length list} +setIndex value i list = unsafeSetIndex value i list + +-- | @'setPointerTo' msg srcLoc dstAddr relPtr@ sets the word at @srcLoc@ in @msg@ to a +-- pointer like @relPtr@, but pointing to @dstAddr@. @relPtr@ should not be a far pointer. +-- If the two addresses are in different segments, a landing pad will be allocated and +-- @srcLoc@ will contain a far pointer. +setPointerTo :: M.WriteCtx m s => M.WordPtr ('Mut s) -> WordAddr -> P.Ptr -> m () +{-# INLINEABLE setPointerTo #-} +{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut RealWorld) -> WordAddr -> P.Ptr -> LimitT IO () #-} +{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut s) -> WordAddr -> P.Ptr -> PureBuilder s () #-} +setPointerTo + M.WordPtr + { pMessage = msg, + pSegment = srcSegment, + pAddr = srcAddr@WordAt {wordIndex = srcWordIndex} + } + dstAddr + relPtr + | P.StructPtr _ 0 0 <- relPtr = + -- We special case zero-sized structs, since (1) we don't have to + -- really point at the correct offset, since they can "fit" anywhere, + -- and (2) they cause problems with double-far pointers, where part + -- of the landing pad needs to have a zero offset, but that makes it + -- look like a null pointer... so we just avoid that case by cutting + -- it off here. + M.write srcSegment srcWordIndex $ + P.serializePtr $ + Just $ + P.StructPtr (-1) 0 0 + | otherwise = case pointerFrom srcAddr dstAddr relPtr of + Right absPtr -> + M.write srcSegment srcWordIndex $ P.serializePtr $ Just absPtr + Left OutOfRange -> + error "BUG: segment is too large to set the pointer." + Left DifferentSegments -> do + -- We need a far pointer; allocate a landing pad in the target segment, + -- set it to point to the final destination, an then set the source pointer + -- pointer to point to the landing pad. + let WordAt {segIndex} = dstAddr + M.allocInSeg msg segIndex 1 >>= \case + Just M.WordPtr {pSegment = landingPadSegment, pAddr = landingPadAddr} -> + case pointerFrom landingPadAddr dstAddr relPtr of + Right landingPad -> do + let WordAt {segIndex, wordIndex} = landingPadAddr + M.write landingPadSegment wordIndex (P.serializePtr $ Just landingPad) + M.write srcSegment srcWordIndex $ + P.serializePtr $ + Just $ + P.FarPtr False (fromIntegral wordIndex) (fromIntegral segIndex) + Left DifferentSegments -> + error "BUG: allocated a landing pad in the wrong segment!" + Left OutOfRange -> + error "BUG: segment is too large to set the pointer." + Nothing -> do + -- The target segment is full. We need to do a double-far pointer. + -- First allocate the 2-word landing pad, wherever it will fit: + M.WordPtr + { pSegment = landingPadSegment, + pAddr = + WordAt + { wordIndex = landingPadOffset, + segIndex = landingPadSegIndex + } + } <- + M.alloc msg 2 + -- Next, point the source pointer at the landing pad: + M.write srcSegment srcWordIndex $ + P.serializePtr $ + Just $ + P.FarPtr + True + (fromIntegral landingPadOffset) + (fromIntegral landingPadSegIndex) + -- Finally, fill in the landing pad itself. + -- + -- The first word is a far pointer whose offset is the + -- starting address of our target object: + M.write landingPadSegment landingPadOffset $ + let WordAt {wordIndex, segIndex} = dstAddr + in P.serializePtr $ + Just $ + P.FarPtr + False + (fromIntegral wordIndex) + (fromIntegral segIndex) + -- The second word is a pointer of the right "shape" + -- for the target, but with a zero offset: + M.write landingPadSegment (landingPadOffset + 1) $ + P.serializePtr $ + Just $ case relPtr of + P.StructPtr _ nWords nPtrs -> P.StructPtr 0 nWords nPtrs + P.ListPtr _ eltSpec -> P.ListPtr 0 eltSpec + _ -> relPtr + +-- | Make a copy of a capability inside the target message. +copyCap :: RWCtx m s => M.Message ('Mut s) -> Cap ('Mut s) -> m (Cap ('Mut s)) +{-# INLINEABLE copyCap #-} +copyCap dest cap = getClient cap >>= appendCap dest + +-- | Make a copy of the value at the pointer, in the target message. +copyPtr :: RWCtx m s => M.Message ('Mut s) -> Maybe (Ptr ('Mut s)) -> m (Maybe (Ptr ('Mut s))) +{-# INLINEABLE copyPtr #-} +{-# SPECIALIZE copyPtr :: M.Message ('Mut RealWorld) -> Maybe (Ptr ('Mut RealWorld)) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-} +{-# SPECIALIZE copyPtr :: M.Message ('Mut s) -> Maybe (Ptr ('Mut s)) -> PureBuilder s (Maybe (Ptr ('Mut s))) #-} +copyPtr _ Nothing = pure Nothing +copyPtr dest (Just (PtrCap cap)) = Just . PtrCap <$> copyCap dest cap +copyPtr dest (Just (PtrList src)) = Just . PtrList <$> copyList dest src +copyPtr dest (Just (PtrStruct src)) = + Just . PtrStruct <$> do + destStruct <- + allocStruct + dest + (fromIntegral $ structWordCount src) + (fromIntegral $ structPtrCount src) + copyStruct destStruct src + pure destStruct + +-- | Make a copy of the list, in the target message. +copyList :: RWCtx m s => M.Message ('Mut s) -> List ('Mut s) -> m (List ('Mut s)) +{-# INLINEABLE copyList #-} +{-# SPECIALIZE copyList :: M.Message ('Mut RealWorld) -> List ('Mut RealWorld) -> LimitT IO (List ('Mut RealWorld)) #-} +{-# SPECIALIZE copyList :: M.Message ('Mut s) -> List ('Mut s) -> PureBuilder s (List ('Mut s)) #-} +copyList dest src = case src of + List0 src -> List0 <$> allocList0 dest (length src) + List1 src -> List1 <$> copyNewListOf dest src allocList1 + List8 src -> List8 <$> copyNewListOf dest src allocList8 + List16 src -> List16 <$> copyNewListOf dest src allocList16 + List32 src -> List32 <$> copyNewListOf dest src allocList32 + List64 src -> List64 <$> copyNewListOf dest src allocList64 + ListPtr src -> ListPtr <$> copyNewListOf dest src allocListPtr + ListStruct src -> + ListStruct <$> do + destList <- + allocCompositeList + dest + (fromIntegral $ structListWordCount src) + (structListPtrCount src) + (length src) + copyListOf destList src + pure destList + +copyNewListOf :: + (ListItem r, RWCtx m s) => + M.Message ('Mut s) -> + ListOf r ('Mut s) -> + (M.Message ('Mut s) -> Int -> m (ListOf r ('Mut s))) -> + m (ListOf r ('Mut s)) +{-# INLINE copyNewListOf #-} +copyNewListOf destMsg src new = do + dest <- new destMsg (length src) + copyListOf dest src + pure dest + +-- | @copyDataList dest src bits@ copies n elements of @src@ to @dest@, where n +-- is the length of the smaller list. @bits@ is the number of bits per element +-- in the two lists. +-- +-- This should only used for non-pointer types, as it does not do a deep copy and +-- just copies the raw bytes. +-- +-- Warning: if you get the @bits@ argument wrong, you may trample over data outside +-- the intended bounds. +copyDataList :: RWCtx m s => NormalList ('Mut s) -> NormalList ('Mut s) -> BitCount -> m () +copyDataList dest src bits = do + let unpack NormalList {nLen, nPtr = M.WordPtr {pSegment, pAddr = WordAt {wordIndex}}} = + (nLen, wordIndex, pSegment) + + (srcLen, srcOff, srcSeg) = unpack src + (destLen, destOff, destSeg) = unpack dest + + len = min destLen srcLen + lenWords = + fromIntegral len * bits + & bitsToBytesCeil + & bytesToWordsCeil + + sliceVec off = + SMV.slice (fromIntegral off) (fromIntegral lenWords) + srcVec <- M.segToVecMut srcSeg + destVec <- M.segToVecMut destSeg + SMV.copy + (sliceVec destOff destVec) + (sliceVec srcOff srcVec) + +-- | @'copyStruct' dest src@ copies the source struct to the destination struct. +copyStruct :: RWCtx m s => Struct ('Mut s) -> Struct ('Mut s) -> m () +{-# INLINEABLE copyStruct #-} +{-# SPECIALIZE copyStruct :: Struct ('Mut RealWorld) -> Struct ('Mut RealWorld) -> LimitT IO () #-} +{-# SPECIALIZE copyStruct :: Struct ('Mut s) -> Struct ('Mut s) -> PureBuilder s () #-} +copyStruct dest src = do + -- We copy both the data and pointer sections from src to dest, + -- padding the tail of the destination section with zeros/null + -- pointers as necessary. If the destination section is + -- smaller than the source section, this will raise a BoundsError. + -- + -- TODO: possible enhancement: allow the destination section to be + -- smaller than the source section if and only if the tail of the + -- source section is all zeros (default values). + copySection (dataSection dest) (dataSection src) 0 + copySection (ptrSection dest) (ptrSection src) Nothing + where + copySection dest src pad = do + -- Copy the source section to the destination section: + copyListOf dest src + -- Pad the remainder with zeros/default values: + forM_ [length src .. length dest - 1] $ \i -> + setIndex pad i dest + +-- | @index i list@ returns the ith element in @list@. Deducts 1 from the quota +index :: (ReadCtx m mut, ListItem r) => Int -> ListOf r mut -> m (Unwrapped (Untyped r mut)) +{-# INLINE index #-} +{-# SPECIALIZE index :: ListItem r => Int -> ListOf r 'Const -> LimitT IO (Unwrapped (Untyped r 'Const)) #-} +{-# SPECIALIZE index :: ListItem r => Int -> ListOf r ('Mut RealWorld) -> LimitT IO (Unwrapped (Untyped r ('Mut RealWorld))) #-} +{-# SPECIALIZE index :: ListItem r => Int -> ListOf r 'Const -> PureBuilder s (Unwrapped (Untyped r 'Const)) #-} +{-# SPECIALIZE index :: ListItem r => Int -> ListOf r ('Mut s) -> PureBuilder s (Unwrapped (Untyped r ('Mut s))) #-} +index i list + | i < 0 || i >= length list = + throwM E.BoundsError {E.index = i, E.maxIndex = length list - 1} + | otherwise = unsafeIndex i list + +-- | Return a prefix of the list, of the given length. +{-# INLINEABLE take #-} +take :: (ListItem r, MonadThrow m) => Int -> ListOf r mut -> m (ListOf r mut) +take count list + | length list < count = + throwM E.BoundsError {E.index = count, E.maxIndex = length list - 1} + | otherwise = pure $ unsafeTake count list + +-- | The data section of a struct, as a list of Word64 +dataSection :: Struct mut -> ListOf ('Data 'Sz64) mut +{-# INLINE dataSection #-} +dataSection (StructAt ptr dataSz _) = + ListOf $ NormalList ptr (fromIntegral dataSz) + +-- | The pointer section of a struct, as a list of Ptr +ptrSection :: Struct mut -> ListOf ('Ptr 'Nothing) mut +{-# INLINE ptrSection #-} +ptrSection (StructAt ptr@M.WordPtr {pAddr = addr@WordAt {wordIndex}} dataSz ptrSz) = + ListOf $ + NormalList + { nPtr = ptr {M.pAddr = addr {wordIndex = wordIndex + fromIntegral dataSz}}, + nLen = fromIntegral ptrSz + } + +-- | Get the size (in words) of a struct's data section. +structWordCount :: Struct mut -> WordCount +structWordCount (StructAt _ptr dataSz _ptrSz) = fromIntegral dataSz + +-- | Get the size (in bytes) of a struct's data section. +structByteCount :: Struct mut -> ByteCount +structByteCount = wordsToBytes . structWordCount + +-- | Get the size of a struct's pointer section. +structPtrCount :: Struct mut -> Word16 +structPtrCount (StructAt _ptr _dataSz ptrSz) = ptrSz + +-- | Get the size (in words) of the data sections in a struct list. +structListWordCount :: ListOf ('Ptr ('Just 'Struct)) mut -> WordCount +structListWordCount (ListOf (StructList s _)) = structWordCount s + +-- | Get the size (in words) of the data sections in a struct list. +structListByteCount :: ListOf ('Ptr ('Just 'Struct)) mut -> ByteCount +structListByteCount (ListOf (StructList s _)) = structByteCount s + +-- | Get the size of the pointer sections in a struct list. +structListPtrCount :: ListOf ('Ptr ('Just 'Struct)) mut -> Word16 +structListPtrCount (ListOf (StructList s _)) = structPtrCount s + +-- | @'getData' i struct@ gets the @i@th word from the struct's data section, +-- returning 0 if it is absent. +getData :: ReadCtx m msg => Int -> Struct msg -> m Word64 +{-# INLINE getData #-} +getData i struct + | fromIntegral (structWordCount struct) <= i = pure 0 + | otherwise = index i (dataSection struct) + +-- | @'getPtr' i struct@ gets the @i@th word from the struct's pointer section, +-- returning Nothing if it is absent. +getPtr :: ReadCtx m msg => Int -> Struct msg -> m (Maybe (Ptr msg)) +{-# INLINE getPtr #-} +getPtr i struct + | fromIntegral (structPtrCount struct) <= i = do + invoice 1 + pure Nothing + | otherwise = do + ptr <- index i (ptrSection struct) + checkPtr ptr + invoicePtr ptr + pure ptr + +checkPtr :: ReadCtx m mut => Maybe (Ptr mut) -> m () +{-# INLINEABLE checkPtr #-} +checkPtr Nothing = pure () +checkPtr (Just (PtrCap c)) = checkCap c +checkPtr (Just (PtrList l)) = checkList l +checkPtr (Just (PtrStruct s)) = checkStruct s + +checkCap :: ReadCtx m mut => Cap mut -> m () +{-# INLINEABLE checkCap #-} +checkCap (CapAt _ _) = pure () + +-- No need to do anything here; an out of bounds index is just treated +-- as null. + +checkList :: ReadCtx m mut => List mut -> m () +{-# INLINEABLE checkList #-} +checkList (List0 l) = checkListOf @('Data 'Sz0) l +checkList (List1 l) = checkListOf @('Data 'Sz1) l +checkList (List8 l) = checkListOf @('Data 'Sz8) l +checkList (List16 l) = checkListOf @('Data 'Sz16) l +checkList (List32 l) = checkListOf @('Data 'Sz32) l +checkList (List64 l) = checkListOf @('Data 'Sz64) l +checkList (ListPtr l) = checkListOf @('Ptr 'Nothing) l +checkList (ListStruct l) = checkListOf @('Ptr ('Just 'Struct)) l + +checkNormalList :: ReadCtx m mut => NormalList mut -> BitCount -> m () +{-# INLINEABLE checkNormalList #-} +checkNormalList NormalList {nPtr, nLen} eltSize = + let nBits = fromIntegral nLen * eltSize + nWords = bytesToWordsCeil $ bitsToBytesCeil nBits + in checkPtrOffset nPtr nWords + +checkStruct :: ReadCtx m mut => Struct mut -> m () +{-# INLINEABLE checkStruct #-} +checkStruct s@(StructAt ptr _ _) = + checkPtrOffset ptr (structSize s) + +checkPtrOffset :: ReadCtx m mut => M.WordPtr mut -> WordCount -> m () +{-# INLINEABLE checkPtrOffset #-} +checkPtrOffset M.WordPtr {pSegment, pAddr = WordAt {wordIndex}} size = do + segWords <- M.numWords pSegment + let maxIndex = fromIntegral segWords - 1 + unless (wordIndex >= 0) $ + throwM E.BoundsError {index = fromIntegral wordIndex, maxIndex} + unless (wordIndex + size <= segWords) $ + throwM + E.BoundsError + { index = fromIntegral (wordIndex + size) - 1, + maxIndex + } + +structSize :: Struct mut -> WordCount +structSize s = structWordCount s + fromIntegral (structPtrCount s) + +-- | Invoice the traversal limit for all data reachable via the pointer +-- directly, i.e. without following further pointers. +-- +-- The minimum possible cost is 1, and for lists will always be proportional +-- to the length of the list, even if the size of the elements is zero. +invoicePtr :: MonadLimit m => Maybe (Ptr mut) -> m () +{-# INLINEABLE invoicePtr #-} +{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut RealWorld)) -> LimitT IO () #-} +{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut s)) -> PureBuilder s () #-} +invoicePtr p = invoice $! ptrInvoiceSize p + +ptrInvoiceSize :: Maybe (Ptr mut) -> WordCount +{-# INLINEABLE ptrInvoiceSize #-} +ptrInvoiceSize = \case + Nothing -> 1 + Just (PtrCap _) -> 1 + Just (PtrStruct s) -> structInvoiceSize s + Just (PtrList l) -> listInvoiceSize l + +listInvoiceSize :: List mut -> WordCount +{-# INLINEABLE listInvoiceSize #-} +listInvoiceSize l = + max 1 $! case l of + List0 l -> fromIntegral $! length l + List1 l -> fromIntegral $! length l `div` 64 + List8 l -> fromIntegral $! length l `div` 8 + List16 l -> fromIntegral $! length l `div` 4 + List32 l -> fromIntegral $! length l `div` 2 + List64 l -> fromIntegral $! length l + ListPtr l -> fromIntegral $! length l + ListStruct (ListOf (StructList s len)) -> + structInvoiceSize s * fromIntegral len + +structInvoiceSize :: Struct mut -> WordCount +{-# INLINEABLE structInvoiceSize #-} +structInvoiceSize (StructAt _ dataSz ptrSz) = + max 1 (fromIntegral dataSz + fromIntegral ptrSz) + +-- | @'setData' value i struct@ sets the @i@th word in the struct's data section +-- to @value@. +{-# INLINE setData #-} +setData :: + (ReadCtx m ('Mut s), M.WriteCtx m s) => + Word64 -> + Int -> + Struct ('Mut s) -> + m () +setData value i = setIndex value i . dataSection + +-- | @'setData' value i struct@ sets the @i@th pointer in the struct's pointer +-- section to @value@. +setPtr :: (ReadCtx m ('Mut s), M.WriteCtx m s) => Maybe (Ptr ('Mut s)) -> Int -> Struct ('Mut s) -> m () +{-# INLINE setPtr #-} +setPtr value i = setIndex value i . ptrSection + +-- | 'rawBytes' returns the raw bytes corresponding to the list. +rawBytes :: ReadCtx m 'Const => ListOf ('Data 'Sz8) 'Const -> m BS.ByteString +{-# INLINEABLE rawBytes #-} +-- TODO: we can get away with a more lax context than ReadCtx, maybe even make +-- this non-monadic. +rawBytes (ListOf (NormalList M.WordPtr {pSegment, pAddr = WordAt {wordIndex}} len)) = do + let bytes = M.toByteString pSegment + let ByteCount byteOffset = wordsToBytes wordIndex + pure $ BS.take len $ BS.drop byteOffset bytes + +-- | Returns the root pointer of a message. +rootPtr :: ReadCtx m mut => M.Message mut -> m (Struct mut) +{-# INLINEABLE rootPtr #-} +rootPtr msg = do + seg <- M.getSegment msg 0 + root <- + get + M.WordPtr + { pMessage = msg, + pSegment = seg, + pAddr = WordAt 0 0 + } + checkPtr root + invoicePtr root + case root of + Just (PtrStruct struct) -> pure struct + Nothing -> messageDefault @Struct msg + _ -> + throwM $ + E.SchemaViolationError + "Unexpected root type; expected struct." + +-- | Make the given struct the root object of its message. +setRoot :: M.WriteCtx m s => Struct ('Mut s) -> m () +{-# INLINEABLE setRoot #-} +setRoot (StructAt M.WordPtr {pMessage, pAddr = addr} dataSz ptrSz) = do + pSegment <- M.getSegment pMessage 0 + let rootPtr = M.WordPtr {pMessage, pSegment, pAddr = WordAt 0 0} + setPointerTo rootPtr addr (P.StructPtr 0 dataSz ptrSz) + +-- | An instace of @'Allocate'@ specifies how to allocate a value with a given representation. +-- This only makes sense for pointers of course, so it is defined on PtrRepr. Of the well-kinded +-- types, only @'List 'Nothing@ is missing an instance. +class Allocate (r :: PtrRepr) where + -- | Extra information needed to allocate a value: + -- + -- * For structs, the sizes of the sections. + -- * For capabilities, the client to attach to the messages. + -- * For lists, the length, and for composite lists, the struct sizes as well. + type AllocHint r + + -- | Allocate a value of the given type. + alloc :: RWCtx m s => M.Message ('Mut s) -> AllocHint r -> m (Unwrapped (UntypedSomePtr r ('Mut s))) + +instance Allocate 'Struct where + type AllocHint 'Struct = (Word16, Word16) + alloc msg = uncurry (allocStruct msg) + +instance Allocate 'Cap where + type AllocHint 'Cap = M.Client + alloc = appendCap + +instance Allocate ('List ('Just 'ListComposite)) where + type AllocHint ('List ('Just 'ListComposite)) = (Int, AllocHint 'Struct) + alloc msg (len, (nWords, nPtrs)) = allocCompositeList msg nWords nPtrs len + +instance AllocateNormalList r => Allocate ('List ('Just ('ListNormal r))) where + type AllocHint ('List ('Just ('ListNormal r))) = Int + alloc = allocNormalList @r + +-- | Like 'Allocate', but specialized to normal (non-composite) lists. +-- +-- Instead of an 'AllocHint' type family, the hint is always an 'Int', +-- which is the number of elements. +class AllocateNormalList (r :: NormalListRepr) where + allocNormalList :: + RWCtx m s => + M.Message ('Mut s) -> + Int -> + m (UntypedSomeList ('ListNormal r) ('Mut s)) + +instance AllocateNormalList ('NormalListData 'Sz0) where allocNormalList = allocList0 + +instance AllocateNormalList ('NormalListData 'Sz1) where allocNormalList = allocList1 + +instance AllocateNormalList ('NormalListData 'Sz8) where allocNormalList = allocList8 + +instance AllocateNormalList ('NormalListData 'Sz16) where allocNormalList = allocList16 + +instance AllocateNormalList ('NormalListData 'Sz32) where allocNormalList = allocList32 + +instance AllocateNormalList ('NormalListData 'Sz64) where allocNormalList = allocList64 + +instance AllocateNormalList 'NormalListPtr where allocNormalList = allocListPtr + +-- | Allocate a struct in the message. +allocStruct :: M.WriteCtx m s => M.Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s)) +{-# INLINEABLE allocStruct #-} +allocStruct msg dataSz ptrSz = do + let totalSz = fromIntegral dataSz + fromIntegral ptrSz + ptr <- M.alloc msg totalSz + pure $ StructAt ptr dataSz ptrSz + +-- | Allocate a composite list. +allocCompositeList :: + M.WriteCtx m s => + -- | The message to allocate in. + M.Message ('Mut s) -> + -- | The size of the data section + Word16 -> + -- | The size of the pointer section + Word16 -> + -- | The length of the list in elements. + Int -> + m (ListOf ('Ptr ('Just 'Struct)) ('Mut s)) +{-# INLINEABLE allocCompositeList #-} +allocCompositeList msg dataSz ptrSz len = do + let eltSize = fromIntegral dataSz + fromIntegral ptrSz + ptr@M.WordPtr {pSegment, pAddr = addr@WordAt {wordIndex}} <- + M.alloc msg (WordCount $ len * eltSize + 1) -- + 1 for the tag word. + M.write pSegment wordIndex $ P.serializePtr' $ P.StructPtr (fromIntegral len) dataSz ptrSz + let firstStruct = + StructAt + ptr {M.pAddr = addr {wordIndex = wordIndex + 1}} + dataSz + ptrSz + pure $ ListOf $ StructList firstStruct len + +-- | Allocate a list of capnproto @Void@ values. +allocList0 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz0) ('Mut s)) +{-# INLINEABLE allocList0 #-} + +-- | Allocate a list of booleans +allocList1 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz1) ('Mut s)) +{-# INLINEABLE allocList1 #-} + +-- | Allocate a list of 8-bit values. +allocList8 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz8) ('Mut s)) +{-# INLINEABLE allocList8 #-} + +-- | Allocate a list of 16-bit values. +allocList16 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz16) ('Mut s)) +{-# INLINEABLE allocList16 #-} + +-- | Allocate a list of 32-bit values. +allocList32 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz32) ('Mut s)) +{-# INLINEABLE allocList32 #-} + +-- | Allocate a list of 64-bit words. +allocList64 :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Data 'Sz64) ('Mut s)) +{-# INLINEABLE allocList64 #-} + +-- | Allocate a list of pointers. +allocListPtr :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Ptr 'Nothing) ('Mut s)) +{-# INLINEABLE allocListPtr #-} + +allocList0 msg len = ListOf <$> allocNormalList' 0 msg len + +allocList1 msg len = ListOf <$> allocNormalList' 1 msg len + +allocList8 msg len = ListOf <$> allocNormalList' 8 msg len + +allocList16 msg len = ListOf <$> allocNormalList' 16 msg len + +allocList32 msg len = ListOf <$> allocNormalList' 32 msg len + +allocList64 msg len = ListOf <$> allocNormalList' 64 msg len + +allocListPtr msg len = ListOf <$> allocNormalList' 64 msg len + +-- | Allocate a NormalList +allocNormalList' :: + M.WriteCtx m s => + -- | The number bits per element + Int -> + -- | The message to allocate in + M.Message ('Mut s) -> + -- | The number of elements in the list. + Int -> + m (NormalList ('Mut s)) +{-# INLINEABLE allocNormalList' #-} +allocNormalList' bitsPerElt msg len = do + -- round 'len' up to the nearest word boundary. + let totalBits = BitCount (len * bitsPerElt) + totalWords = bytesToWordsCeil $ bitsToBytesCeil totalBits + ptr <- M.alloc msg totalWords + pure NormalList {nPtr = ptr, nLen = len} + +appendCap :: M.WriteCtx m s => M.Message ('Mut s) -> M.Client -> m (Cap ('Mut s)) +{-# INLINEABLE appendCap #-} +appendCap msg client = do + i <- M.appendCap msg client + pure $ CapAt msg (fromIntegral i) + +instance MaybeMutable (ListRepOf r) => MaybeMutable (ListOf r) where + thaw (ListOf l) = ListOf <$> thaw l + freeze (ListOf l) = ListOf <$> freeze l + unsafeThaw (ListOf l) = ListOf <$> unsafeThaw l + unsafeFreeze (ListOf l) = ListOf <$> unsafeFreeze l + +------------------------------------------------------------------------------- +-- Helpers generated MaybeMutable instances +------------------------------------------------------------------------------- + +-- trivial wrapaper around CatchT, so we can add a PrimMonad instance. +newtype CatchTWrap m a = CatchTWrap {runCatchTWrap :: CatchT m a} + deriving (Functor, Applicative, Monad, MonadTrans, MonadThrow, MonadCatch) + +instance PrimMonad m => PrimMonad (CatchTWrap m) where + type PrimState (CatchTWrap m) = PrimState m + primitive = lift . primitive + +-- | @runCatchImpure m@ runs @m@, and if it throws, raises the +-- exception with 'impureThrow'. +runCatchImpure :: Monad m => CatchTWrap m a -> m a +{-# INLINEABLE runCatchImpure #-} +runCatchImpure m = do + res <- runCatchT $ runCatchTWrap m + pure $ case res of + Left e -> impureThrow e + Right v -> v + +------------------------------------------------------------------------------- +-- Generated MaybeMutable instances +------------------------------------------------------------------------------- + +do + let mkWrappedInstance name = + let f = pure $ TH.ConT name + in [d| + instance MaybeMutable $f where + thaw = runCatchImpure . tMsg thaw + freeze = runCatchImpure . tMsg freeze + unsafeThaw = runCatchImpure . tMsg unsafeThaw + unsafeFreeze = runCatchImpure . tMsg unsafeFreeze + |] + concat + <$> traverse + mkWrappedInstance + [ ''Ptr, + ''List, + ''Cap, + ''Struct, + ''NormalList, + ''StructList + ] + +do + let mkIsListPtrRepr (r, listC, str) = + [d| + instance IsListPtrRepr $r where + rToList = $(pure $ TH.ConE listC) + rFromList $(pure $ TH.ConP listC [] [TH.VarP (TH.mkName "l")]) = pure l + rFromList _ = expected $(pure $ TH.LitE $ TH.StringL $ "pointer to " ++ str) + rFromListMsg = messageDefault @(Untyped ('Ptr ('Just ('List ('Just $r))))) + |] + concat + <$> traverse + mkIsListPtrRepr + [ ( [t|'ListNormal ('NormalListData 'Sz0)|], + 'List0, + "List(Void)" + ), + ( [t|'ListNormal ('NormalListData 'Sz1)|], + 'List1, + "List(Bool)" + ), + ( [t|'ListNormal ('NormalListData 'Sz8)|], + 'List8, + "List(UInt8)" + ), + ( [t|'ListNormal ('NormalListData 'Sz16)|], + 'List16, + "List(UInt16)" + ), + ( [t|'ListNormal ('NormalListData 'Sz32)|], + 'List32, + "List(UInt32)" + ), + ( [t|'ListNormal ('NormalListData 'Sz64)|], + 'List64, + "List(UInt64)" + ), + ( [t|'ListNormal 'NormalListPtr|], + 'ListPtr, + "List(AnyPointer)" + ), + ( [t|'ListComposite|], + 'ListStruct, + "composite list" + ) + ] + +instance MaybeMutable (IgnoreMut a) where + thaw = pure . coerce + freeze = pure . coerce + +instance MaybeMutable MaybePtr where + thaw (MaybePtr p) = MaybePtr <$> traverse thaw p + freeze (MaybePtr p) = MaybePtr <$> traverse freeze p + unsafeThaw (MaybePtr p) = MaybePtr <$> traverse unsafeThaw p + unsafeFreeze (MaybePtr p) = MaybePtr <$> traverse unsafeFreeze p diff --git a/lib/Data/Mutable.hs b/lib/Data/Mutable.hs --- a/lib/Data/Mutable.hs +++ b/lib/Data/Mutable.hs @@ -1,55 +1,55 @@ -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} -{- | -Module: Data.Mutable -Description: Generic support for converting between mutable and immutable values. -There is a common pattern in Haskell libraries that work with mutable data: - -* Two types, a mutable and an immutable variant of the same structure. -* @thaw@ and @freeze@ functions to convert between these. -* Sometimes unsafe variants of @thaw@ and @freeze@, which avoid a copy but - can break referential transparency if misused. - -This module abstracts out the above pattern into a generic type family 'Thaw', -and provides some of the common higher-level tools built on top of these -primitives. - -Note that there's nothing terribly Cap'N Proto specific about this module; we -may even factor it out into a separate package at some point. --} +-- | +-- Module: Data.Mutable +-- Description: Generic support for converting between mutable and immutable values. +-- +-- There is a common pattern in Haskell libraries that work with mutable data: +-- +-- * Two types, a mutable and an immutable variant of the same structure. +-- * @thaw@ and @freeze@ functions to convert between these. +-- * Sometimes unsafe variants of @thaw@ and @freeze@, which avoid a copy but +-- can break referential transparency if misused. +-- +-- This module abstracts out the above pattern into a generic type family 'Thaw', +-- and provides some of the common higher-level tools built on top of these +-- primitives. +-- +-- Note that there's nothing terribly Cap'N Proto specific about this module; we +-- may even factor it out into a separate package at some point. module Data.Mutable {-# DEPRECATED "use Capnp.Mutability instead" #-} where import Control.Monad.Primitive (PrimMonad, PrimState) -import Control.Monad.ST (ST, runST) +import Control.Monad.ST (ST, runST) -- | The 'Thaw' type class relates mutable and immutable versions of a type. -- The instance is defined on the immutable variant; @'Mutable' s a@ is the -- mutable version of an immutable type @a@, bound to the state token @s@. class Thaw a where - -- | The mutable version of @a@, bound to the state token @s@. - type Mutable s a + -- | The mutable version of @a@, bound to the state token @s@. + type Mutable s a - -- | Convert an immutable value to a mutable one. - thaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) + -- | Convert an immutable value to a mutable one. + thaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) - -- | Convert a mutable value to an immutable one. - freeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a + -- | Convert a mutable value to an immutable one. + freeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a - -- | Like 'thaw', except that the caller is responsible for ensuring that - -- the original value is not subsequently used; doing so may violate - -- referential transparency. - -- - -- The default implementation of this is just the same as 'thaw', but - -- typically an instance will override this with a trivial (unsafe) cast, - -- hence the obligation described above. - unsafeThaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) - unsafeThaw = thaw + -- | Like 'thaw', except that the caller is responsible for ensuring that + -- the original value is not subsequently used; doing so may violate + -- referential transparency. + -- + -- The default implementation of this is just the same as 'thaw', but + -- typically an instance will override this with a trivial (unsafe) cast, + -- hence the obligation described above. + unsafeThaw :: (PrimMonad m, PrimState m ~ s) => a -> m (Mutable s a) + unsafeThaw = thaw - -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must - -- ensure that the original value is not used after this call. - unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a - unsafeFreeze = freeze + -- | Unsafe version of 'freeze' analagous to 'unsafeThaw'. The caller must + -- ensure that the original value is not used after this call. + unsafeFreeze :: (PrimMonad m, PrimState m ~ s) => Mutable s a -> m a + unsafeFreeze = freeze -- | Create and freeze a mutable value, safely, without doing a full copy. -- internally, 'create' calls unsafeFreeze, but it cannot be directly used to diff --git a/lib/Internal/AppendVec.hs b/lib/Internal/AppendVec.hs --- a/lib/Internal/AppendVec.hs +++ b/lib/Internal/AppendVec.hs @@ -1,82 +1,87 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TypeFamilies #-} -{- | -Module: Internal.AppendVec -Description: Helpers for efficient appending to vectors. --} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module: Internal.AppendVec +-- Description: Helpers for efficient appending to vectors. module Internal.AppendVec - ( AppendVec - , fromVector - , makeEmpty - , getVector - , getCapacity - , grow - , canGrowWithoutCopy - ) where + ( AppendVec, + fromVector, + makeEmpty, + getVector, + getCapacity, + grow, + canGrowWithoutCopy, + ) +where -import Control.Monad (when) -import Control.Monad.Catch (MonadThrow(throwM)) +import Capnp.Errors (Error (SizeError)) +import Control.Monad (when) +import Control.Monad.Catch (MonadThrow (throwM)) import Control.Monad.Primitive (PrimMonad, PrimState) - import qualified Data.Vector.Generic.Mutable as GMV -import Capnp.Errors (Error(SizeError)) - -- | 'AppendVec' wraps a mutable vector, and affords amortized O(1) appending. data AppendVec v s a = AppendVec - { mutVec :: v s a - , mutVecLen :: !Int - } + { mutVec :: v s a, + mutVecLen :: !Int + } -- | 'fromVector' wraps a mutable vector in an appendVector, with no initial -- spare capacity. fromVector :: GMV.MVector v a => v s a -> AppendVec v s a -fromVector vec = AppendVec - { mutVec = vec - , mutVecLen = GMV.length vec +fromVector vec = + AppendVec + { mutVec = vec, + mutVecLen = GMV.length vec } -- | 'makeEmpty' makes an initially empty 'AppendVec', using the argument -- as allocation space for 'grow'. makeEmpty :: GMV.MVector v a => v s a -> AppendVec v s a -makeEmpty vec = AppendVec - { mutVec = vec - , mutVecLen = 0 +makeEmpty vec = + AppendVec + { mutVec = vec, + mutVecLen = 0 } -- | 'getVector' returns the valid portion of the underlying mutable vector. getVector :: GMV.MVector v a => AppendVec v s a -> v s a -getVector AppendVec{mutVec, mutVecLen} = GMV.slice 0 mutVecLen mutVec +getVector AppendVec {mutVec, mutVecLen} = GMV.slice 0 mutVecLen mutVec getCapacity :: GMV.MVector v a => AppendVec v s a -> Int -getCapacity AppendVec{mutVec} = GMV.length mutVec +getCapacity AppendVec {mutVec} = GMV.length mutVec -- | @'grow' vec amount maxSize@ grows the vector @vec@ by @amount@ elements, -- provided the result does not exceed @maxSize@. Amortized O(@amount@). Returns -- the new vector; the original should not be used. -- . -- If the result does exceed @maxSize@, throws 'SizeError'. -grow :: (MonadThrow m, PrimMonad m, s ~ PrimState m, GMV.MVector v a) - => AppendVec v s a -> Int -> Int -> m (AppendVec v s a) -grow vec@AppendVec{mutVec,mutVecLen} amount maxSize = do - when (maxSize - amount < mutVecLen) $ - throwM SizeError - mutVec <- - if canGrowWithoutCopy vec amount then - -- we have enough un-allocated space already; leave the vector - -- itself alone. - pure mutVec - else - -- Allocate some more space. we at least double the underlying - -- vector's size, to make appending amortized O(1), but if the - -- vector is small enough and the allocation is big enough, we - -- may need to do more to satisfy the request: - GMV.grow mutVec (max amount (mutVecLen * 2)) - pure AppendVec - { mutVec = mutVec - , mutVecLen = mutVecLen + amount - } +grow :: + (MonadThrow m, PrimMonad m, s ~ PrimState m, GMV.MVector v a) => + AppendVec v s a -> + Int -> + Int -> + m (AppendVec v s a) +grow vec@AppendVec {mutVec, mutVecLen} amount maxSize = do + when (maxSize - amount < mutVecLen) $ + throwM SizeError + mutVec <- + if canGrowWithoutCopy vec amount + then -- we have enough un-allocated space already; leave the vector + -- itself alone. + pure mutVec + else -- Allocate some more space. we at least double the underlying + -- vector's size, to make appending amortized O(1), but if the + -- vector is small enough and the allocation is big enough, we + -- may need to do more to satisfy the request: + GMV.grow mutVec (max amount (mutVecLen * 2)) + pure + AppendVec + { mutVec = mutVec, + mutVecLen = mutVecLen + amount + } canGrowWithoutCopy :: (GMV.MVector v a) => AppendVec v s a -> Int -> Bool -canGrowWithoutCopy AppendVec{mutVec,mutVecLen} amount = - mutVecLen + amount <= GMV.length mutVec +canGrowWithoutCopy AppendVec {mutVec, mutVecLen} amount = + mutVecLen + amount <= GMV.length mutVec diff --git a/lib/Internal/BuildPure.hs b/lib/Internal/BuildPure.hs --- a/lib/Internal/BuildPure.hs +++ b/lib/Internal/BuildPure.hs @@ -1,38 +1,37 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE TypeFamilies #-} -{- | -Module: Internal.BuildPure -Description: Helpers for building capnproto messages in pure code. +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeFamilies #-} -This module provides some helpers for building capnproto messages and values -in pure code, using the low-level API. --} +-- | +-- Module: Internal.BuildPure +-- Description: Helpers for building capnproto messages in pure code. +-- +-- This module provides some helpers for building capnproto messages and values +-- in pure code, using the low-level API. module Internal.BuildPure - ( PureBuilder - , createPure - ) where - -import Control.Monad.Catch (Exception, MonadThrow(..), SomeException) -import Control.Monad.Primitive (PrimMonad(..)) -import Control.Monad.ST (ST) - -import Capnp.Bits (WordCount) -import Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT) + ( PureBuilder, + createPure, + ) +where +import Capnp.Bits (WordCount) import Capnp.Mutability +import Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT) +import Control.Monad.Catch (Exception, MonadThrow (..), SomeException) +import Control.Monad.Primitive (PrimMonad (..)) +import Control.Monad.ST (ST) import Internal.STE -- | 'PureBuilder' is a monad transformer stack with the instnaces needed -- manipulate mutable messages. @'PureBuilder' s a@ is morally equivalent -- to @'LimitT' ('CatchT' ('ST' s)) a@ newtype PureBuilder s a = PureBuilder (LimitT (STE SomeException s) a) - deriving(Functor, Applicative, Monad, MonadThrow, MonadLimit) + deriving (Functor, Applicative, Monad, MonadThrow, MonadLimit) instance PrimMonad (PureBuilder s) where - type PrimState (PureBuilder s) = s - primitive = PureBuilder . primitive + type PrimState (PureBuilder s) = s + primitive = PureBuilder . primitive runPureBuilder :: WordCount -> PureBuilder s a -> ST s (Either SomeException a) runPureBuilder limit (PureBuilder m) = steToST $ evalLimitT limit m @@ -46,5 +45,5 @@ -- I(zenhack) am surprised not to have found this in one of the various -- exception packages: throwLeft :: (Exception e, MonadThrow m) => Either e a -> m a - throwLeft (Left e) = throwM e + throwLeft (Left e) = throwM e throwLeft (Right a) = pure a diff --git a/lib/Internal/Rc.hs b/lib/Internal/Rc.hs --- a/lib/Internal/Rc.hs +++ b/lib/Internal/Rc.hs @@ -1,71 +1,79 @@ -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} -{-| -Module: Internal.Rc -Description: Reference counted boxes. -This module provides a reference-counted cell type 'Rc', which contains a -value and a finalizer. When the reference count reaches zero, the value is -dropped and the finalizer is run. --} +-- | +-- Module: Internal.Rc +-- Description: Reference counted boxes. +-- +-- This module provides a reference-counted cell type 'Rc', which contains a +-- value and a finalizer. When the reference count reaches zero, the value is +-- dropped and the finalizer is run. module Internal.Rc - ( Rc - , new - , get - , incr - , decr - , release - ) where + ( Rc, + new, + get, + incr, + decr, + release, + ) +where import Control.Concurrent.STM -- | A reference-counted container for a value of type @a@. newtype Rc a - = Rc (TVar (Maybe (RcState a))) - deriving(Eq) + = Rc (TVar (Maybe (RcState a))) + deriving (Eq) data RcState a = RcState - { refCount :: !Int - , value :: a - , finalizer :: STM () - } + { refCount :: !Int, + value :: a, + finalizer :: STM () + } -- | @'new' val finalizer@ creates a new 'Rc' containing the value @val@, with -- an initial reference count of 1. When the reference count drops to zero, the -- finalizer will be run. new :: a -> STM () -> STM (Rc a) -new value finalizer = fmap Rc $ newTVar $ Just RcState - { refCount = 1 - , value - , finalizer - } +new value finalizer = + fmap Rc $ + newTVar $ + Just + RcState + { refCount = 1, + value, + finalizer + } -- | Increment the reference count. incr :: Rc a -> STM () incr (Rc tv) = modifyTVar' tv $ - fmap $ \s@RcState{refCount} -> s { refCount = refCount + 1 } + fmap $ + \s@RcState {refCount} -> s {refCount = refCount + 1} -- | Decrement the reference count. If this brings the count to zero, run the -- finalizer and release the value. decr :: Rc a -> STM () -decr (Rc tv) = readTVar tv >>= \case +decr (Rc tv) = + readTVar tv >>= \case Nothing -> - pure () - Just RcState{refCount=1, finalizer} -> do - writeTVar tv Nothing - finalizer - Just s@RcState{refCount} -> - writeTVar tv $ Just s { refCount = refCount - 1 } + pure () + Just RcState {refCount = 1, finalizer} -> do + writeTVar tv Nothing + finalizer + Just s@RcState {refCount} -> + writeTVar tv $ Just s {refCount = refCount - 1} -- | Release the value immediately, and run the finalizer, regardless of the -- current reference count. release :: Rc a -> STM () -release (Rc tv) = readTVar tv >>= \case +release (Rc tv) = + readTVar tv >>= \case Nothing -> - pure () - Just RcState{finalizer} -> do - finalizer - writeTVar tv Nothing + pure () + Just RcState {finalizer} -> do + finalizer + writeTVar tv Nothing -- | Fetch the value, or 'Nothing' if it has been released. get :: Rc a -> STM (Maybe a) diff --git a/lib/Internal/Rpc/Breaker.hs b/lib/Internal/Rpc/Breaker.hs new file mode 100644 --- /dev/null +++ b/lib/Internal/Rpc/Breaker.hs @@ -0,0 +1,55 @@ +-- | Module: Internal.Rpc.Breaker +-- +-- This module serves to break a dependency cycle between the rpc +-- system and the serialization code; see Note [Breaker] in +-- "Capnp.Rpc.Untyped" for details. +module Internal.Rpc.Breaker + ( Client (..), + Pipeline (..), + nullClient, + -- | ** Internals + Opaque, + makeOpaque, + reflectOpaque, + ) +where + +import Data.Dynamic (Dynamic, Typeable, fromDynamic, toDyn) + +-- | A reference to a capability, which may be live either in the current vat +-- or elsewhere. Holding a client affords making method calls on a capability +-- or modifying the local vat's reference count to it. +newtype Client = Client Opaque + deriving (Eq) + +instance Show Client where + show client = + if client == nullClient + then "nullClient" + else "({- capability; not statically representable -})" + +-- | A 'Pipeline' is a reference to a value within a message that has not yet arrived. +newtype Pipeline = Pipeline Opaque + +-- | A null client. This is the only client value that can be represented +-- statically. Throws exceptions in response to all method calls. +nullClient :: Client +nullClient = Client $ makeOpaque () + +data Opaque = Opaque + { opDyn :: Dynamic, + opEq :: Opaque -> Bool + } + +makeOpaque :: (Typeable a, Eq a) => a -> Opaque +makeOpaque v = + Opaque + { opDyn = toDyn v, + opEq = \o -> fromDynamic (opDyn o) == Just v + } + +reflectOpaque :: Opaque -> Dynamic +reflectOpaque = opDyn + +instance Eq Opaque where + x == y = opEq x y diff --git a/lib/Internal/STE.hs b/lib/Internal/STE.hs --- a/lib/Internal/STE.hs +++ b/lib/Internal/STE.hs @@ -1,42 +1,44 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + -- | Simplified implementation of the monad-ste package, -- with a few extras. module Internal.STE - ( STE - , throwSTE - , runSTE - , liftST - , steToST - , steToIO - ) where + ( STE, + throwSTE, + runSTE, + liftST, + steToST, + steToIO, + ) +where import Control.Exception -import Control.Monad.Catch (MonadThrow(..)) -import Control.Monad.Primitive (PrimMonad(..)) +import Control.Monad.Catch (MonadThrow (..)) +import Control.Monad.Primitive (PrimMonad (..)) import Control.Monad.ST import Control.Monad.ST.Unsafe -import Data.Typeable (Typeable) +import Data.Typeable (Typeable) newtype InternalErr e = InternalErr e - deriving stock (Typeable) + deriving stock (Typeable) instance Show (InternalErr e) where - show _ = "(InternalErr _)" + show _ = "(InternalErr _)" instance Typeable e => Exception (InternalErr e) newtype STE e s a = STE (IO a) - deriving newtype (Functor, Applicative, Monad) + deriving newtype (Functor, Applicative, Monad) instance PrimMonad (STE e s) where - type PrimState (STE e s) = s - primitive = liftST . primitive + type PrimState (STE e s) = s + primitive = liftST . primitive liftST :: ST s a -> STE e s a liftST st = STE (unsafeSTToIO st) @@ -49,17 +51,17 @@ steToST :: Typeable e => STE e s a -> ST s (Either e a) steToST (STE io) = unsafeIOToST $ do - res <- try io - case res of - Left (InternalErr e) -> pure $ Left e - Right v -> pure $ Right v + res <- try io + case res of + Left (InternalErr e) -> pure $ Left e + Right v -> pure $ Right v steToIO :: forall e a. Exception e => STE e RealWorld a -> IO a steToIO (STE io) = do - res <- try io - case res of - Left (InternalErr (e :: e)) -> throwIO e - Right v -> pure v + res <- try io + case res of + Left (InternalErr (e :: e)) -> throwIO e + Right v -> pure v instance MonadThrow (STE SomeException s) where - throwM = throwSTE . toException + throwM = throwSTE . toException diff --git a/lib/Internal/SnocList.hs b/lib/Internal/SnocList.hs --- a/lib/Internal/SnocList.hs +++ b/lib/Internal/SnocList.hs @@ -1,11 +1,13 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} + module Internal.SnocList - ( SnocList - , fromList - , empty - , snoc - , singleton - ) where + ( SnocList, + fromList, + empty, + snoc, + singleton, + ) +where import Data.Foldable import Data.Hashable (Hashable) @@ -18,7 +20,7 @@ -- the list, and then reverse the list before processing. A SnocList -- just packages up this trick so you can't forget to do the reverse. newtype SnocList a = SnocList [a] - deriving(Eq, Hashable) + deriving (Eq, Hashable) -- | Convert a list to a 'SnocList'. O(n) fromList :: [a] -> SnocList a @@ -35,14 +37,14 @@ -- | Append a value to the 'SnocList'. A note on the name: 'snoc' is @cons@ -- backwards. snoc :: SnocList a -> a -> SnocList a -snoc (SnocList xs) x = SnocList (x:xs) +snoc (SnocList xs) x = SnocList (x : xs) instance Foldable SnocList where - foldMap f = foldMap f . toList - toList (SnocList xs) = reverse xs + foldMap f = foldMap f . toList + toList (SnocList xs) = reverse xs instance Semigroup (SnocList a) where - (SnocList l) <> (SnocList r) = SnocList (r <> l) + (SnocList l) <> (SnocList r) = SnocList (r <> l) instance Monoid (SnocList a) where - mempty = empty + mempty = empty diff --git a/lib/Internal/TCloseQ.hs b/lib/Internal/TCloseQ.hs --- a/lib/Internal/TCloseQ.hs +++ b/lib/Internal/TCloseQ.hs @@ -1,69 +1,69 @@ -{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} -{-| -Module: Internal.TCloseQ -Description: Transactional queues with a close operation. -This module provides a thin layer over 'TQueue', which affords "closing" -queues. Reading from a closed queue returns 'Nothing'. --} +-- | +-- Module: Internal.TCloseQ +-- Description: Transactional queues with a close operation. +-- +-- This module provides a thin layer over 'TQueue', which affords "closing" +-- queues. Reading from a closed queue returns 'Nothing'. module Internal.TCloseQ - ( Q - , ErrClosed(..) - , new - , read - , write - , close - ) where - -import Prelude hiding (read) + ( Q, + ErrClosed (..), + new, + read, + write, + close, + ) +where import Control.Concurrent.STM - import Control.Exception (Exception) -import Control.Monad (unless, when) -import Data.Maybe (isNothing) +import Control.Monad (unless, when) +import Data.Maybe (isNothing) +import Prelude hiding (read) -- | A Queue with a close operation, with element type @a@. data Q a = Q - { q :: TQueue (Maybe a) - , isClosed :: TVar Bool - } + { q :: TQueue (Maybe a), + isClosed :: TVar Bool + } -- | An exception which is thrown if a caller tries to write to a closed queue. data ErrClosed = ErrClosed - deriving(Show) + deriving (Show) + instance Exception ErrClosed -- | Create a new empty queue. new :: STM (Q a) new = do - q <- newTQueue - isClosed <- newTVar False - pure Q{..} + q <- newTQueue + isClosed <- newTVar False + pure Q {..} -- | Read a value from the queue. Returns Nothing if the queue is closed. read :: Q a -> STM (Maybe a) -read Q{q} = do - ret <- readTQueue q - when (isNothing ret) $ - -- put it back in, so future reads also return nothing: - writeTQueue q ret - pure ret +read Q {q} = do + ret <- readTQueue q + when (isNothing ret) $ + -- put it back in, so future reads also return nothing: + writeTQueue q ret + pure ret -- | Write a value to the queue, which must not be closed. If it is closed, -- this will throw 'ErrClosed'. write :: Q a -> a -> STM () -write Q{q, isClosed} v = do - c <- readTVar isClosed - when c $ throwSTM ErrClosed - writeTQueue q (Just v) +write Q {q, isClosed} v = do + c <- readTVar isClosed + when c $ throwSTM ErrClosed + writeTQueue q (Just v) -- | Close a queue. It is safe to close a queue more than once; subsequent -- closes will have no effect. close :: Q a -> STM () -close Q{q, isClosed} = do - c <- readTVar isClosed - unless c $ do - writeTVar isClosed True - writeTQueue q Nothing +close Q {q, isClosed} = do + c <- readTVar isClosed + unless c $ do + writeTVar isClosed True + writeTQueue q Nothing diff --git a/tests/CalculatorExample.hs b/tests/CalculatorExample.hs --- a/tests/CalculatorExample.hs +++ b/tests/CalculatorExample.hs @@ -1,83 +1,80 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -module CalculatorExample (tests) where -import Data.Word -import Test.Hspec - -import Control.Concurrent (threadDelay) -import Control.Concurrent.Async (race_) -import Control.Exception.Safe (throwIO, try) -import Data.Default (def) -import Data.Foldable (for_) -import Data.String (fromString) -import Network.Simple.TCP (connect, serve) -import System.Environment (getEnv) -import System.Exit (ExitCode(ExitSuccess)) -import System.IO.Error (isDoesNotExistError) -import System.Process (callProcess, readProcessWithExitCode) +module CalculatorExample (tests) where -import Capnp.Rpc.Transport (socketTransport) -import Capnp.Rpc.Untyped (ConnConfig (..), handleConn) +import Capnp.Rpc.Transport (socketTransport) +import Capnp.Rpc.Untyped (ConnConfig (..), handleConn) import Capnp.TraversalLimit (defaultLimit) - +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async (race_) +import Control.Exception.Safe (throwIO, try) +import Data.Default (def) +import Data.Foldable (for_) +import Data.String (fromString) +import Data.Word import qualified Examples.Rpc.CalculatorClient import qualified Examples.Rpc.CalculatorServer +import Network.Simple.TCP (connect, serve) +import System.Environment (getEnv) +import System.Exit (ExitCode (ExitSuccess)) +import System.IO.Error (isDoesNotExistError) +import System.Process (callProcess, readProcessWithExitCode) +import Test.Hspec getExe :: String -> IO (Maybe FilePath) getExe varName = - try (getEnv varName) >>= \case - Left e - | isDoesNotExistError e -> do - putStrLn $ varName ++ " not set; skipping." - pure Nothing - | otherwise -> - throwIO e - Right path -> - pure (Just path) + try (getEnv varName) >>= \case + Left e + | isDoesNotExistError e -> do + putStrLn $ varName ++ " not set; skipping." + pure Nothing + | otherwise -> + throwIO e + Right path -> + pure (Just path) tests :: Spec tests = describe "Check our example against the C++ implementation" $ do - clientPath <- runIO $ getExe "CXX_CALCULATOR_CLIENT" - serverPath <- runIO $ getExe "CXX_CALCULATOR_SERVER" - for_ clientPath $ \clientPath -> - it "Should pass when run against our server" $ - Examples.Rpc.CalculatorServer.main - `race_` (waitForServer >> cxxClient clientPath 4000) - for_ serverPath $ \serverPath -> - it "Should pass when run against our client" $ - cxxServer serverPath 4000 - `race_` (waitForServer >> Examples.Rpc.CalculatorClient.main) - for_ ((,) <$> clientPath <*> serverPath) $ \(clientPath, serverPath) -> - it "Should pass when run aginst the C++ server, proxied through us." $ - cxxServer serverPath 4000 - `race_` (waitForServer >> runProxy 4000 6000) - -- we wait twice, so that the proxy also has time to start: - `race_` (waitForServer >> waitForServer >> cxxClient clientPath 6000) + clientPath <- runIO $ getExe "CXX_CALCULATOR_CLIENT" + serverPath <- runIO $ getExe "CXX_CALCULATOR_SERVER" + for_ clientPath $ \clientPath -> + it "Should pass when run against our server" $ + Examples.Rpc.CalculatorServer.main + `race_` (waitForServer >> cxxClient clientPath 4000) + for_ serverPath $ \serverPath -> + it "Should pass when run against our client" $ + cxxServer serverPath 4000 + `race_` (waitForServer >> Examples.Rpc.CalculatorClient.main) + for_ ((,) <$> clientPath <*> serverPath) $ \(clientPath, serverPath) -> + it "Should pass when run aginst the C++ server, proxied through us." $ + cxxServer serverPath 4000 + `race_` (waitForServer >> runProxy 4000 6000) + -- we wait twice, so that the proxy also has time to start: + `race_` (waitForServer >> waitForServer >> cxxClient clientPath 6000) where - -- | Give the server a bit of time to start up. + -- \| Give the server a bit of time to start up. waitForServer :: IO () waitForServer = threadDelay 100000 cxxServer :: FilePath -> Word16 -> IO () cxxServer path port = - callProcess path ["localhost:" ++ show port] + callProcess path ["localhost:" ++ show port] cxxClient :: FilePath -> Word16 -> IO () cxxClient path port = do - (eStatus, out, err) <- readProcessWithExitCode path ["localhost:" ++ show port] "" - (eStatus, out, err) - `shouldBe` - ( ExitSuccess - , unlines - [ "Evaluating a literal... PASS" - , "Using add and subtract... PASS" - , "Pipelining eval() calls... PASS" - , "Defining functions... PASS" - , "Using a callback... PASS" - ] - , "" - ) + (eStatus, out, err) <- readProcessWithExitCode path ["localhost:" ++ show port] "" + (eStatus, out, err) + `shouldBe` ( ExitSuccess, + unlines + [ "Evaluating a literal... PASS", + "Using add and subtract... PASS", + "Pipelining eval() calls... PASS", + "Defining functions... PASS", + "Using a callback... PASS" + ], + "" + ) -- | @'runProxy' serverPort clientPort@ connects to the server listening at -- localhost:serverPort, requests its bootstrap interface, and then listens @@ -85,13 +82,17 @@ -- own. runProxy :: Word16 -> Word16 -> IO () runProxy serverPort clientPort = - connect "localhost" (fromString $ show serverPort) $ \(serverSock, _addr) -> - handleConn (socketTransport serverSock defaultLimit) def - { debugMode = True - , withBootstrap = Just $ \_sup client -> - serve "localhost" (fromString $ show clientPort) $ \(clientSock, _addr) -> - handleConn (socketTransport clientSock defaultLimit) def - { getBootstrap = \_sup -> pure $ Just client - , debugMode = True - } - } + connect "localhost" (fromString $ show serverPort) $ \(serverSock, _addr) -> + handleConn + (socketTransport serverSock defaultLimit) + def + { debugMode = True, + withBootstrap = Just $ \_sup client -> + serve "localhost" (fromString $ show clientPort) $ \(clientSock, _addr) -> + handleConn + (socketTransport clientSock defaultLimit) + def + { getBootstrap = \_sup -> pure $ Just client, + debugMode = True + } + } diff --git a/tests/Instances.hs b/tests/Instances.hs --- a/tests/Instances.hs +++ b/tests/Instances.hs @@ -1,416 +1,432 @@ -{-| -Module: Instances -Description: Instances of Arbitrary for various types. - -In particular, stuff from: - -* "Capnp.New.Basics" -* "Capnp.Gen.Capnp.Schema.New" --} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module: Instances +-- Description: Instances of Arbitrary for various types. +-- +-- In particular, stuff from: +-- +-- * "Capnp.Basics" +-- * "Capnp.Gen.Capnp.Schema" module Instances () where +import Capnp (Which) +import qualified Capnp.Basics as B +import Capnp.Gen.Capnp.Schema +import qualified Data.Vector as V import Data.Word import Test.QuickCheck - import Test.QuickCheck.Instances () -import qualified Data.Vector as V - -import Capnp.New (Which) - -import Capnp.Gen.Capnp.Schema.New - -import qualified Capnp.New.Basics as B - -- Generate an arbitrary "unknown" tag, i.e. one with a value unassigned -- by the schema. The parameter is the number of tags assigned by the schema. arbitraryTag :: Word16 -> Gen Word16 arbitraryTag numTags = max numTags <$> arbitrary instance Arbitrary (Parsed Node) where - shrink = genericShrink - arbitrary = do - id <- arbitrary - displayName <- arbitrary - displayNamePrefixLength <- arbitrary - scopeId <- arbitrary - parameters <- arbitrarySmallerVec - isGeneric <- arbitrary - nestedNodes <- arbitrarySmallerVec - annotations <- arbitrarySmallerVec - union' <- arbitrary - pure Node{..} + shrink = genericShrink + arbitrary = do + id <- arbitrary + displayName <- arbitrary + displayNamePrefixLength <- arbitrary + scopeId <- arbitrary + parameters <- arbitrarySmallerVec + isGeneric <- arbitrary + nestedNodes <- arbitrarySmallerVec + annotations <- arbitrarySmallerVec + union' <- arbitrary + pure Node {..} instance Arbitrary (Parsed Node'SourceInfo) where - shrink = genericShrink - arbitrary = do - id <- arbitrary - docComment <- arbitrary - members <- arbitrarySmallerVec - pure Node'SourceInfo{..} + shrink = genericShrink + arbitrary = do + id <- arbitrary + docComment <- arbitrary + members <- arbitrarySmallerVec + pure Node'SourceInfo {..} instance Arbitrary (Parsed Node'SourceInfo'Member) where - shrink = genericShrink - arbitrary = Node'SourceInfo'Member <$> arbitrary + shrink = genericShrink + arbitrary = Node'SourceInfo'Member <$> arbitrary instance Arbitrary (Parsed (Which Node)) where - shrink = genericShrink - arbitrary = oneof - [ pure Node'file - , Node'struct <$> arbitrary - , Node'enum <$> arbitrary - , Node'interface <$> arbitrary - , Node'const <$> arbitrary - , Node'annotation <$> arbitrary - , Node'unknown' <$> arbitraryTag 6 - ] + shrink = genericShrink + arbitrary = + oneof + [ pure Node'file, + Node'struct <$> arbitrary, + Node'enum <$> arbitrary, + Node'interface <$> arbitrary, + Node'const <$> arbitrary, + Node'annotation <$> arbitrary, + Node'unknown' <$> arbitraryTag 6 + ] instance Arbitrary (Parsed Node'enum) where - shrink = genericShrink - arbitrary = Node'enum' <$> arbitrarySmallerVec + shrink = genericShrink + arbitrary = Node'enum' <$> arbitrarySmallerVec instance Arbitrary (Parsed Node'struct) where - shrink = genericShrink - arbitrary = do - dataWordCount <- arbitrary - pointerCount <- arbitrary - preferredListEncoding <- arbitrary - isGroup <- arbitrary - discriminantCount <- arbitrary - discriminantOffset <- arbitrary - fields <- arbitrarySmallerVec - pure Node'struct'{..} + shrink = genericShrink + arbitrary = do + dataWordCount <- arbitrary + pointerCount <- arbitrary + preferredListEncoding <- arbitrary + isGroup <- arbitrary + discriminantCount <- arbitrary + discriminantOffset <- arbitrary + fields <- arbitrarySmallerVec + pure Node'struct' {..} instance Arbitrary (Parsed Node'interface) where - shrink = genericShrink - arbitrary = Node'interface' <$> arbitrarySmallerVec <*> arbitrarySmallerVec + shrink = genericShrink + arbitrary = Node'interface' <$> arbitrarySmallerVec <*> arbitrarySmallerVec instance Arbitrary (Parsed Node'const) where - shrink = genericShrink - arbitrary = Node'const' <$> arbitrary <*> arbitrary + shrink = genericShrink + arbitrary = Node'const' <$> arbitrary <*> arbitrary instance Arbitrary (Parsed Node'annotation) where - shrink = genericShrink - arbitrary = do - type_ <- arbitrary - targetsFile <- arbitrary - targetsConst <- arbitrary - targetsEnum <- arbitrary - targetsEnumerant <- arbitrary - targetsStruct <- arbitrary - targetsField <- arbitrary - targetsUnion <- arbitrary - targetsGroup <- arbitrary - targetsInterface <- arbitrary - targetsMethod <- arbitrary - targetsParam <- arbitrary - targetsAnnotation <- arbitrary - pure Node'annotation'{..} + shrink = genericShrink + arbitrary = do + type_ <- arbitrary + targetsFile <- arbitrary + targetsConst <- arbitrary + targetsEnum <- arbitrary + targetsEnumerant <- arbitrary + targetsStruct <- arbitrary + targetsField <- arbitrary + targetsUnion <- arbitrary + targetsGroup <- arbitrary + targetsInterface <- arbitrary + targetsMethod <- arbitrary + targetsParam <- arbitrary + targetsAnnotation <- arbitrary + pure Node'annotation' {..} instance Arbitrary (Parsed Node'NestedNode) where - shrink = genericShrink - arbitrary = Node'NestedNode - <$> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + Node'NestedNode + <$> arbitrary + <*> arbitrary instance Arbitrary (Parsed Field) where - shrink = genericShrink - arbitrary = do - name <- arbitrary - codeOrder <- arbitrary - annotations <- arbitrary - discriminantValue <- arbitrary - union' <- arbitrary - ordinal <- arbitrary - pure Field{..} + shrink = genericShrink + arbitrary = do + name <- arbitrary + codeOrder <- arbitrary + annotations <- arbitrary + discriminantValue <- arbitrary + union' <- arbitrary + ordinal <- arbitrary + pure Field {..} instance Arbitrary (Parsed (Which Field)) where - shrink = genericShrink - arbitrary = oneof - [ Field'slot <$> arbitrary - , Field'group <$> arbitrary - ] + shrink = genericShrink + arbitrary = + oneof + [ Field'slot <$> arbitrary, + Field'group <$> arbitrary + ] instance Arbitrary (Parsed Field'slot) where - shrink = genericShrink - arbitrary = do - offset <- arbitrary - type_ <- arbitrary - defaultValue <- arbitrary - hadExplicitDefault <- arbitrary - pure Field'slot'{..} + shrink = genericShrink + arbitrary = do + offset <- arbitrary + type_ <- arbitrary + defaultValue <- arbitrary + hadExplicitDefault <- arbitrary + pure Field'slot' {..} instance Arbitrary (Parsed Field'group) where - shrink = genericShrink - arbitrary = Field'group' <$> arbitrary + shrink = genericShrink + arbitrary = Field'group' <$> arbitrary instance Arbitrary (Parsed Field'ordinal) where - shrink = genericShrink - arbitrary = Field'ordinal' <$> arbitrary + shrink = genericShrink + arbitrary = Field'ordinal' <$> arbitrary instance Arbitrary (Parsed (Which Field'ordinal)) where - shrink = genericShrink - arbitrary = oneof - [ pure Field'ordinal'implicit - , Field'ordinal'explicit <$> arbitrary - ] + shrink = genericShrink + arbitrary = + oneof + [ pure Field'ordinal'implicit, + Field'ordinal'explicit <$> arbitrary + ] instance Arbitrary (Parsed Enumerant) where - shrink = genericShrink - arbitrary = Enumerant - <$> arbitrary - <*> arbitrary - <*> arbitrarySmallerVec + shrink = genericShrink + arbitrary = + Enumerant + <$> arbitrary + <*> arbitrary + <*> arbitrarySmallerVec instance Arbitrary (Parsed Superclass) where - shrink = genericShrink - arbitrary = Superclass - <$> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + Superclass + <$> arbitrary + <*> arbitrary instance Arbitrary (Parsed Method) where - shrink = genericShrink - arbitrary = do - name <- arbitrary - codeOrder <- arbitrary - implicitParameters <- arbitrary - paramStructType <- arbitrary - paramBrand <- arbitrary - resultStructType <- arbitrary - resultBrand <- arbitrary - annotations <- arbitrary - pure Method{..} + shrink = genericShrink + arbitrary = do + name <- arbitrary + codeOrder <- arbitrary + implicitParameters <- arbitrary + paramStructType <- arbitrary + paramBrand <- arbitrary + resultStructType <- arbitrary + resultBrand <- arbitrary + annotations <- arbitrary + pure Method {..} instance Arbitrary (Parsed CapnpVersion) where - shrink = genericShrink - arbitrary = CapnpVersion - <$> arbitrary - <*> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + CapnpVersion + <$> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary (Parsed Node'Parameter) where - shrink = genericShrink - arbitrary = Node'Parameter <$> arbitrary + shrink = genericShrink + arbitrary = Node'Parameter <$> arbitrary instance Arbitrary (Parsed Brand) where - shrink = genericShrink - arbitrary = Brand <$> arbitrarySmallerVec + shrink = genericShrink + arbitrary = Brand <$> arbitrarySmallerVec instance Arbitrary (Parsed Brand'Scope) where - shrink = genericShrink - arbitrary = Brand'Scope - <$> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + Brand'Scope + <$> arbitrary + <*> arbitrary instance Arbitrary (Parsed (Which Brand'Scope)) where - shrink = genericShrink - arbitrary = oneof - [ Brand'Scope'bind <$> arbitrarySmallerVec - , pure Brand'Scope'inherit - , Brand'Scope'unknown' <$> arbitraryTag 2 - ] + shrink = genericShrink + arbitrary = + oneof + [ Brand'Scope'bind <$> arbitrarySmallerVec, + pure Brand'Scope'inherit, + Brand'Scope'unknown' <$> arbitraryTag 2 + ] instance Arbitrary (Parsed Brand'Binding) where - shrink = genericShrink - arbitrary = Brand'Binding <$> arbitrary + shrink = genericShrink + arbitrary = Brand'Binding <$> arbitrary instance Arbitrary (Parsed (Which Brand'Binding)) where - shrink = genericShrink - arbitrary = oneof - [ pure Brand'Binding'unbound - , Brand'Binding'type_ <$> arbitrary - , Brand'Binding'unknown' <$> arbitraryTag 2 - ] + shrink = genericShrink + arbitrary = + oneof + [ pure Brand'Binding'unbound, + Brand'Binding'type_ <$> arbitrary, + Brand'Binding'unknown' <$> arbitraryTag 2 + ] instance Arbitrary (Parsed Value) where - shrink = genericShrink - arbitrary = Value <$> arbitrary + shrink = genericShrink + arbitrary = Value <$> arbitrary instance Arbitrary (Parsed (Which Value)) where - shrink = genericShrink - arbitrary = oneof - [ pure Value'void - , Value'bool <$> arbitrary - , Value'int8 <$> arbitrary - , Value'int16 <$> arbitrary - , Value'int32 <$> arbitrary - , Value'int64 <$> arbitrary - , Value'uint8 <$> arbitrary - , Value'uint16 <$> arbitrary - , Value'uint32 <$> arbitrary - , Value'uint64 <$> arbitrary - , Value'float32 <$> arbitrary - , Value'float64 <$> arbitrary - , Value'text <$> arbitrary - , Value'data_ <$> arbitrary - , Value'list <$> arbitrary - , Value'enum <$> arbitrary - , Value'struct <$> arbitrary - , pure Value'interface - , Value'anyPointer <$> arbitrary - , Value'unknown' <$> arbitraryTag 19 - ] + shrink = genericShrink + arbitrary = + oneof + [ pure Value'void, + Value'bool <$> arbitrary, + Value'int8 <$> arbitrary, + Value'int16 <$> arbitrary, + Value'int32 <$> arbitrary, + Value'int64 <$> arbitrary, + Value'uint8 <$> arbitrary, + Value'uint16 <$> arbitrary, + Value'uint32 <$> arbitrary, + Value'uint64 <$> arbitrary, + Value'float32 <$> arbitrary, + Value'float64 <$> arbitrary, + Value'text <$> arbitrary, + Value'data_ <$> arbitrary, + Value'list <$> arbitrary, + Value'enum <$> arbitrary, + Value'struct <$> arbitrary, + pure Value'interface, + Value'anyPointer <$> arbitrary, + Value'unknown' <$> arbitraryTag 19 + ] instance Arbitrary (Parsed Annotation) where - shrink = genericShrink - arbitrary = Annotation - <$> arbitrary - <*> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + Annotation + <$> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary ElementSize where - shrink = genericShrink - arbitrary = oneof - [ pure ElementSize'empty - , pure ElementSize'bit - , pure ElementSize'byte - , pure ElementSize'twoBytes - , pure ElementSize'fourBytes - , pure ElementSize'eightBytes - , pure ElementSize'pointer - , pure ElementSize'inlineComposite - , ElementSize'unknown' <$> arbitraryTag 8 - ] + shrink = genericShrink + arbitrary = + oneof + [ pure ElementSize'empty, + pure ElementSize'bit, + pure ElementSize'byte, + pure ElementSize'twoBytes, + pure ElementSize'fourBytes, + pure ElementSize'eightBytes, + pure ElementSize'pointer, + pure ElementSize'inlineComposite, + ElementSize'unknown' <$> arbitraryTag 8 + ] instance Arbitrary (Parsed Type'anyPointer) where - shrink = genericShrink - arbitrary = Type'anyPointer' <$> arbitrary + shrink = genericShrink + arbitrary = Type'anyPointer' <$> arbitrary instance Arbitrary (Parsed (Which Type'anyPointer)) where - shrink = genericShrink - arbitrary = oneof - [ Type'anyPointer'unconstrained <$> arbitrary - , Type'anyPointer'parameter <$> arbitrary - , Type'anyPointer'implicitMethodParameter <$> arbitrary - ] + shrink = genericShrink + arbitrary = + oneof + [ Type'anyPointer'unconstrained <$> arbitrary, + Type'anyPointer'parameter <$> arbitrary, + Type'anyPointer'implicitMethodParameter <$> arbitrary + ] instance Arbitrary (Parsed Type'anyPointer'unconstrained) where - shrink = genericShrink - arbitrary = Type'anyPointer'unconstrained' <$> arbitrary + shrink = genericShrink + arbitrary = Type'anyPointer'unconstrained' <$> arbitrary instance Arbitrary (Parsed (Which Type'anyPointer'unconstrained)) where - shrink = genericShrink - arbitrary = oneof - [ pure Type'anyPointer'unconstrained'anyKind - , pure Type'anyPointer'unconstrained'struct - , pure Type'anyPointer'unconstrained'list - , pure Type'anyPointer'unconstrained'capability - ] + shrink = genericShrink + arbitrary = + oneof + [ pure Type'anyPointer'unconstrained'anyKind, + pure Type'anyPointer'unconstrained'struct, + pure Type'anyPointer'unconstrained'list, + pure Type'anyPointer'unconstrained'capability + ] instance Arbitrary (Parsed Type'anyPointer'parameter) where - shrink = genericShrink - arbitrary = - Type'anyPointer'parameter' <$> arbitrary <*> arbitrary + shrink = genericShrink + arbitrary = + Type'anyPointer'parameter' <$> arbitrary <*> arbitrary instance Arbitrary (Parsed Type'anyPointer'implicitMethodParameter) where - shrink = genericShrink - arbitrary = - Type'anyPointer'implicitMethodParameter' <$> arbitrary + shrink = genericShrink + arbitrary = + Type'anyPointer'implicitMethodParameter' <$> arbitrary instance Arbitrary (Parsed Type) where - shrink = genericShrink - arbitrary = Type <$> arbitrary + shrink = genericShrink + arbitrary = Type <$> arbitrary instance Arbitrary (Parsed (Which Type)) where - shrink = genericShrink - arbitrary = oneof - [ pure Type'void - , pure Type'bool - , pure Type'int8 - , pure Type'int16 - , pure Type'int32 - , pure Type'int64 - , pure Type'uint8 - , pure Type'uint16 - , pure Type'uint32 - , pure Type'uint64 - , pure Type'float32 - , pure Type'float64 - , pure Type'text - , pure Type'data_ - , Type'list <$> arbitrary - , Type'enum <$> arbitrary - , Type'struct <$> arbitrary - , Type'interface <$> arbitrary - , Type'anyPointer <$> arbitrary - , Type'unknown' <$> arbitraryTag 21 - ] + shrink = genericShrink + arbitrary = + oneof + [ pure Type'void, + pure Type'bool, + pure Type'int8, + pure Type'int16, + pure Type'int32, + pure Type'int64, + pure Type'uint8, + pure Type'uint16, + pure Type'uint32, + pure Type'uint64, + pure Type'float32, + pure Type'float64, + pure Type'text, + pure Type'data_, + Type'list <$> arbitrary, + Type'enum <$> arbitrary, + Type'struct <$> arbitrary, + Type'interface <$> arbitrary, + Type'anyPointer <$> arbitrary, + Type'unknown' <$> arbitraryTag 21 + ] instance Arbitrary (Parsed Type'list) where - shrink = genericShrink - arbitrary = Type'list' <$> arbitrary + shrink = genericShrink + arbitrary = Type'list' <$> arbitrary instance Arbitrary (Parsed Type'enum) where - shrink = genericShrink - arbitrary = Type'enum' <$> arbitrary <*> arbitrary + shrink = genericShrink + arbitrary = Type'enum' <$> arbitrary <*> arbitrary instance Arbitrary (Parsed Type'struct) where - shrink = genericShrink - arbitrary = Type'struct' <$> arbitrary <*> arbitrary + shrink = genericShrink + arbitrary = Type'struct' <$> arbitrary <*> arbitrary instance Arbitrary (Parsed Type'interface) where - shrink = genericShrink - arbitrary = Type'interface' <$> arbitrary <*> arbitrary + shrink = genericShrink + arbitrary = Type'interface' <$> arbitrary <*> arbitrary instance Arbitrary (Parsed CodeGeneratorRequest) where - shrink = genericShrink - arbitrary = do - capnpVersion <- arbitrary - nodes <- arbitrarySmallerVec - requestedFiles <- arbitrarySmallerVec - sourceInfo <- arbitrarySmallerVec - pure CodeGeneratorRequest{..} + shrink = genericShrink + arbitrary = do + capnpVersion <- arbitrary + nodes <- arbitrarySmallerVec + requestedFiles <- arbitrarySmallerVec + sourceInfo <- arbitrarySmallerVec + pure CodeGeneratorRequest {..} instance Arbitrary (Parsed CodeGeneratorRequest'RequestedFile) where - shrink = genericShrink - arbitrary = CodeGeneratorRequest'RequestedFile - <$> arbitrary - <*> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + CodeGeneratorRequest'RequestedFile + <$> arbitrary + <*> arbitrary + <*> arbitrary instance Arbitrary (Parsed CodeGeneratorRequest'RequestedFile'Import) where - shrink = genericShrink - arbitrary = CodeGeneratorRequest'RequestedFile'Import - <$> arbitrary - <*> arbitrary + shrink = genericShrink + arbitrary = + CodeGeneratorRequest'RequestedFile'Import + <$> arbitrary + <*> arbitrary arbitrarySmallerVec :: Arbitrary a => Gen (V.Vector a) arbitrarySmallerVec = sized $ \size -> do - -- Make sure the elements are scaled down relative to - -- the size of the vector: - vec <- arbitrary :: Gen (V.Vector ()) - let gen = resize (size `div` V.length vec) arbitrary - traverse (const gen) vec + -- Make sure the elements are scaled down relative to + -- the size of the vector: + vec <- arbitrary :: Gen (V.Vector ()) + let gen = resize (size `div` V.length vec) arbitrary + traverse (const gen) vec instance Arbitrary (Parsed B.AnyStruct) where - shrink = genericShrink - arbitrary = sized $ \_ -> B.Struct - <$> arbitrarySmallerVec - <*> arbitrarySmallerVec + shrink = genericShrink + arbitrary = sized $ \_ -> + B.Struct + <$> arbitrarySmallerVec + <*> arbitrarySmallerVec instance Arbitrary (Parsed B.AnyList) where - shrink = genericShrink - arbitrary = oneof - [ B.List0 <$> arbitrarySmallerVec - , B.List1 <$> arbitrarySmallerVec - , B.List8 <$> arbitrarySmallerVec - , B.List16 <$> arbitrarySmallerVec - , B.List32 <$> arbitrarySmallerVec - , B.List64 <$> arbitrarySmallerVec - , B.ListPtr <$> arbitrarySmallerVec - , B.ListStruct <$> arbitrarySmallerVec - ] + shrink = genericShrink + arbitrary = + oneof + [ B.List0 <$> arbitrarySmallerVec, + B.List1 <$> arbitrarySmallerVec, + B.List8 <$> arbitrarySmallerVec, + B.List16 <$> arbitrarySmallerVec, + B.List32 <$> arbitrarySmallerVec, + B.List64 <$> arbitrarySmallerVec, + B.ListPtr <$> arbitrarySmallerVec, + B.ListStruct <$> arbitrarySmallerVec + ] instance Arbitrary (Parsed B.AnyPointer) where - shrink (B.PtrStruct s) = B.PtrStruct <$> shrink s - shrink (B.PtrList l) = B.PtrList <$> shrink l - shrink (B.PtrCap _) = [] - arbitrary = oneof - [ B.PtrStruct <$> arbitrary - , B.PtrList <$> arbitrary + shrink (B.PtrStruct s) = B.PtrStruct <$> shrink s + shrink (B.PtrList l) = B.PtrList <$> shrink l + shrink (B.PtrCap _) = [] + arbitrary = + oneof + [ B.PtrStruct <$> arbitrary, + B.PtrList <$> arbitrary -- We never generate capabilites, as we can't marshal Clients back in, -- so many of the invariants we check don't hold for caps. - ] + ] diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -1,41 +1,39 @@ module Main (main) where -import Test.Hspec - -import Module.Capnp.Basics (basicsTests) -import Module.Capnp.Bits (bitsTests) -import Module.Capnp.Canonicalize (canonicalizeTests) -import Module.Capnp.Gen.Capnp.Schema (schemaTests) -import Module.Capnp.Gen.Capnp.Schema.Pure (pureSchemaTests) -import Module.Capnp.Pointer (ptrTests) -import Module.Capnp.Rpc (rpcTests) -import Module.Capnp.Untyped (untypedTests) -import Module.Capnp.Untyped.Pure (pureUntypedTests) -import Regression (regressionTests) -import Rpc.Unwrap (unwrapTests) -import SchemaQuickCheck (schemaCGRQuickCheck) -import WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) - import qualified CalculatorExample +import Module.Capnp.Basics (basicsTests) +import Module.Capnp.Bits (bitsTests) +import Module.Capnp.Canonicalize (canonicalizeTests) +import Module.Capnp.Gen.Capnp.Schema (schemaTests) +import Module.Capnp.Gen.Capnp.Schema.Pure (pureSchemaTests) +import Module.Capnp.Pointer (ptrTests) +import Module.Capnp.Rpc (rpcTests) +import Module.Capnp.Untyped (untypedTests) +import Module.Capnp.Untyped.Pure (pureUntypedTests) import qualified PointerOOB +import Regression (regressionTests) +import Rpc.Unwrap (unwrapTests) +import SchemaQuickCheck (schemaCGRQuickCheck) +import Test.Hspec +import WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) main :: IO () main = hspec $ parallel $ do - describe "Tests for specific modules" $ do - describe "Capnp.Basics" basicsTests - describe "Capnp.Bits" bitsTests - describe "Capnp.Pointer" ptrTests - describe "Capnp.Rpc" rpcTests - describe "Capnp.Untyped" untypedTests - describe "Capnp.Untyped.Pure" pureUntypedTests - describe "Capnp.Canonicalize" canonicalizeTests - describe "Tests for generated output" $ do - describe "low-level output" schemaTests - describe "high-level output" pureSchemaTests - describe "Tests relate to schema" $ do - describe "tests using tests/data/schema-codegenreq" walkSchemaCodeGenRequestTest - describe "property tests for schema" schemaCGRQuickCheck - describe "Regression tests" regressionTests - CalculatorExample.tests - PointerOOB.tests - describe "Tests for client unwrapping" unwrapTests + describe "Tests for specific modules" $ do + describe "Capnp.Basics" basicsTests + describe "Capnp.Bits" bitsTests + describe "Capnp.Pointer" ptrTests + describe "Capnp.Rpc" rpcTests + describe "Capnp.Untyped" untypedTests + describe "Capnp.Untyped.Pure" pureUntypedTests + describe "Capnp.Canonicalize" canonicalizeTests + describe "Tests for generated output" $ do + describe "low-level output" schemaTests + describe "high-level output" pureSchemaTests + describe "Tests relate to schema" $ do + describe "tests using tests/data/schema-codegenreq" walkSchemaCodeGenRequestTest + describe "property tests for schema" schemaCGRQuickCheck + describe "Regression tests" regressionTests + CalculatorExample.tests + PointerOOB.tests + describe "Tests for client unwrapping" unwrapTests diff --git a/tests/Module/Capnp/Basics.hs b/tests/Module/Capnp/Basics.hs --- a/tests/Module/Capnp/Basics.hs +++ b/tests/Module/Capnp/Basics.hs @@ -1,37 +1,41 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-error=deprecations #-} -module Module.Capnp.Basics (basicsTests) where -import Prelude hiding (length) +module Module.Capnp.Basics (basicsTests) where +import Capnp + ( List, + Mutability (..), + Raw (..), + encode, + evalLimitT, + length, + newMessage, + ) +import Capnp.Basics +import Capnp.Mutability (freeze) +import Control.Monad.IO.Class (liftIO) +import qualified Data.ByteString as BS +import qualified Data.Text as T import Data.Word +import GHC.Prim (coerce) import Test.Hspec import Test.QuickCheck - -import Control.Monad.IO.Class (liftIO) -import GHC.Prim (coerce) -import Test.QuickCheck.IO (propertyIO) +import Test.QuickCheck.IO (propertyIO) import Test.QuickCheck.Instances () - -import qualified Data.ByteString as BS -import qualified Data.Text as T - -import Capnp.New.Basics +import Prelude hiding (length) -import Capnp.Mutability (freeze) -import Capnp.New - (List, Mutability(..), Raw(..), encode, evalLimitT, length, newMessage) -- import Data.Mutable (freeze) basicsTests :: Spec basicsTests = - describe "textBuffer and textBytes agree" $ - it "Should return the same number of bytes" $ - property $ \(text :: T.Text) -> propertyIO $ evalLimitT maxBound $ do - msg <- newMessage Nothing - Raw untyped <- encode msg text - raw :: Raw Text 'Const <- Raw <$> freeze untyped - buf <- textBuffer raw - bytes <- textBytes raw - liftIO $ BS.length bytes `shouldBe` length (coerce buf :: Raw (List Word8) 'Const) + describe "textBuffer and textBytes agree" $ + it "Should return the same number of bytes" $ + property $ \(text :: T.Text) -> propertyIO $ evalLimitT maxBound $ do + msg <- newMessage Nothing + Raw untyped <- encode msg text + raw :: Raw Text 'Const <- Raw <$> freeze untyped + buf <- textBuffer raw + bytes <- textBytes raw + liftIO $ BS.length bytes `shouldBe` length (coerce buf :: Raw (List Word8) 'Const) diff --git a/tests/Module/Capnp/Bits.hs b/tests/Module/Capnp/Bits.hs --- a/tests/Module/Capnp/Bits.hs +++ b/tests/Module/Capnp/Bits.hs @@ -1,46 +1,49 @@ module Module.Capnp.Bits (bitsTests) where +import Capnp.Bits import Data.Bits +import Data.Foldable (traverse_) import Data.Word import Test.Hspec -import Data.Foldable (traverse_) - -import Capnp.Bits - bitsTests :: Spec bitsTests = do - describe "bitRange" bitRangeExamples - describe "replaceBits" replaceBitsExamples + describe "bitRange" bitRangeExamples + describe "replaceBits" replaceBitsExamples bitRangeExamples :: Spec bitRangeExamples = do - it "Should get single bits correctly" $ - traverse_ bitRangeTest ones - it "Should work on this extra example" $ - bitRangeTest - (0x0000000200000000, 32, 48, 2) + it "Should get single bits correctly" $ + traverse_ bitRangeTest ones + it "Should work on this extra example" $ + bitRangeTest + (0x0000000200000000, 32, 48, 2) where bitRangeTest :: (Word64, Int, Int, Word64) -> IO () bitRangeTest (word, lo, hi, expected) = - bitRange word lo hi `shouldBe` expected - ones = map (\bit -> (1 `shiftL` bit, bit, bit + 1, 1)) [0..63] + bitRange word lo hi `shouldBe` expected + ones = map (\bit -> (1 `shiftL` bit, bit, bit + 1, 1)) [0 .. 63] replaceBitsExamples :: Spec replaceBitsExamples = - it "Should work with several examples" $ - sequence_ - [ replaceTest (0xf :: Word8) 0 0 0xf - , replaceTest (0x1 :: Word8) 0xf 0 0x1 - , replaceTest (0x2 :: Word8) 0x1 0 0x2 - , replaceTest (0x1 :: Word8) 0xf 0 0x1 - , replaceTest (0x2 :: Word8) 0x10 4 0x20 - , replaceTest (0x1 :: Word8) 0x10 8 0x0110 - , replaceTest (0xa :: Word8) 0xffff 8 0x0aff - , replaceTest (0x0 :: Word1) 0xff 4 0xef - ] - where - replaceTest :: (Bounded a, Integral a, Show a) - => a -> Word64 -> Int -> Word64 -> Expectation + it "Should work with several examples" $ + sequence_ + [ replaceTest (0xf :: Word8) 0 0 0xf, + replaceTest (0x1 :: Word8) 0xf 0 0x1, + replaceTest (0x2 :: Word8) 0x1 0 0x2, + replaceTest (0x1 :: Word8) 0xf 0 0x1, + replaceTest (0x2 :: Word8) 0x10 4 0x20, + replaceTest (0x1 :: Word8) 0x10 8 0x0110, + replaceTest (0xa :: Word8) 0xffff 8 0x0aff, + replaceTest (0x0 :: Word1) 0xff 4 0xef + ] + where + replaceTest :: + (Bounded a, Integral a, Show a) => + a -> + Word64 -> + Int -> + Word64 -> + Expectation replaceTest new orig shift expected = - replaceBits new orig shift `shouldBe` expected + replaceBits new orig shift `shouldBe` expected diff --git a/tests/Module/Capnp/Canonicalize.hs b/tests/Module/Capnp/Canonicalize.hs --- a/tests/Module/Capnp/Canonicalize.hs +++ b/tests/Module/Capnp/Canonicalize.hs @@ -1,73 +1,70 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ViewPatterns #-} -module Module.Capnp.Canonicalize - ( canonicalizeTests - ) where -import Test.Hspec -import Test.QuickCheck (property) -import Test.QuickCheck.IO (propertyIO) - -import qualified Data.ByteString.Lazy as LBS -import qualified Data.Vector as V - -import Control.Monad (unless) +module Module.Capnp.Canonicalize + ( canonicalizeTests, + ) +where +import Capnp (Parsed, Raw (..), createPure, encode, msgToLBS) +import qualified Capnp.Basics as B import Capnp.Canonicalize - -import Capnp.New (Parsed, Raw(..), createPure, encode, msgToLBS) - -import qualified Capnp.Message as M -import qualified Capnp.New.Basics as B -import qualified Capnp.Untyped as U - +import qualified Capnp.Message as M +import qualified Capnp.Untyped as U +import Control.Monad (unless) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Vector as V import Instances () -import Util (capnpCanonicalize) +import Test.Hspec +import Test.QuickCheck (property) +import Test.QuickCheck.IO (propertyIO) +import Util (capnpCanonicalize) canonicalizeTests :: Spec canonicalizeTests = - describe "canonicalization tests" $ do - it "agrees with reference implementation" $ - property $ \case - B.Struct (V.toList -> []) (V.toList -> []) -> - -- skip this; it fails due to a bug in the reference implementation: - -- - -- https://github.com/capnproto/capnproto/issues/1084 - -- - -- TODO: when that issue is fixed, stop skipping this case. - propertyIO $ pure () - struct -> - propertyIO $ implsAgreeOn struct + describe "canonicalization tests" $ do + it "agrees with reference implementation" $ + property $ \case + B.Struct (V.toList -> []) (V.toList -> []) -> + -- skip this; it fails due to a bug in the reference implementation: + -- + -- https://github.com/capnproto/capnproto/issues/1084 + -- + -- TODO: when that issue is fixed, stop skipping this case. + propertyIO $ pure () + struct -> + propertyIO $ implsAgreeOn struct implsAgreeOn :: Parsed B.AnyStruct -> IO () implsAgreeOn struct = do - let Just ourMsg = ourImplCanonicalize struct - refMsg <- refImplCanonicalize struct - unless (ourMsg == refMsg) $ - error $ concat - [ "Our implementation disagrees with the reference implementation on " ++ show struct - , ".\n\nWe produce:\n\n" - , show $ LBS.unpack $ msgToLBS ourMsg - , "\n\n" - , "But the reference implementation generates:\n\n" - , show $ LBS.unpack $ msgToLBS refMsg - ] + let Just ourMsg = ourImplCanonicalize struct + refMsg <- refImplCanonicalize struct + unless (ourMsg == refMsg) $ + error $ + concat + [ "Our implementation disagrees with the reference implementation on " ++ show struct, + ".\n\nWe produce:\n\n", + show $ LBS.unpack $ msgToLBS ourMsg, + "\n\n", + "But the reference implementation generates:\n\n", + show $ LBS.unpack $ msgToLBS refMsg + ] ourImplCanonicalize :: Parsed B.AnyStruct -> Maybe (M.Message 'M.Const) ourImplCanonicalize struct = createPure maxBound $ do - msg <- M.newMessage Nothing - Raw rawStruct <- encode msg struct - (msg, _) <- canonicalizeMut rawStruct - pure msg + msg <- M.newMessage Nothing + Raw rawStruct <- encode msg struct + (msg, _) <- canonicalizeMut rawStruct + pure msg refImplCanonicalize :: Parsed B.AnyStruct -> IO (M.Message 'M.Const) refImplCanonicalize struct = do - msg <- createPure maxBound $ do - msg <- M.newMessage Nothing - Raw rawStruct <- encode msg struct - U.setRoot rawStruct - pure msg - lbs <- capnpCanonicalize (msgToLBS msg) - let segment = M.fromByteString $ LBS.toStrict lbs - pure $ M.singleSegment segment + msg <- createPure maxBound $ do + msg <- M.newMessage Nothing + Raw rawStruct <- encode msg struct + U.setRoot rawStruct + pure msg + lbs <- capnpCanonicalize (msgToLBS msg) + let segment = M.fromByteString $ LBS.toStrict lbs + pure $ M.singleSegment segment diff --git a/tests/Module/Capnp/Gen/Capnp/Schema.hs b/tests/Module/Capnp/Gen/Capnp/Schema.hs --- a/tests/Module/Capnp/Gen/Capnp/Schema.hs +++ b/tests/Module/Capnp/Gen/Capnp/Schema.hs @@ -1,57 +1,58 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} -module Module.Capnp.Gen.Capnp.Schema (schemaTests) where -import Test.Hspec - -import Control.Monad.Primitive (RealWorld) -import Data.Foldable (traverse_) -import Data.Function ((&)) - -import qualified Capnp.Gen.Capnp.Schema.New as N +module Module.Capnp.Gen.Capnp.Schema (schemaTests) where -import Capnp.Mutability (freeze) -import Capnp.New (encodeField, encodeVariant, initVariant, readField) +import Capnp (encodeField, encodeVariant, initVariant, readField) +import qualified Capnp.Classes as C +import qualified Capnp.Gen.Capnp.Schema as S +import qualified Capnp.Message as M +import Capnp.Mutability (freeze) import Capnp.TraversalLimit (LimitT, evalLimitT) -import Util (decodeValue, schemaSchemaSrc) - -import qualified Capnp.Message as M -import qualified Capnp.New.Classes as NC +import Control.Monad.Primitive (RealWorld) +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Test.Hspec +import Util (decodeValue, schemaSchemaSrc) data BuildTest = BuildTest - { typeName :: String - , expected :: String - , builder :: M.Message ('M.Mut RealWorld) -> LimitT IO () - } + { typeName :: String, + expected :: String, + builder :: M.Message ('M.Mut RealWorld) -> LimitT IO () + } schemaTests :: Spec -schemaTests = describe "tests for typed setters" $ traverse_ testCase - [ BuildTest - { typeName = "Field" - , expected = concat - [ "( codeOrder = 4,\n" - , " discriminantValue = 6,\n" - , " group = (typeId = 322),\n" - , " ordinal = (explicit = 22) )\n" - ] - , builder = \msg -> do - field <- NC.newRoot @N.Field () msg - field & encodeField #codeOrder 4 - field & encodeField #discriminantValue 6 - field +schemaTests = + describe "tests for typed setters" $ + traverse_ + testCase + [ BuildTest + { typeName = "Field", + expected = + concat + [ "( codeOrder = 4,\n", + " discriminantValue = 6,\n", + " group = (typeId = 322),\n", + " ordinal = (explicit = 22) )\n" + ], + builder = \msg -> do + field <- C.newRoot @S.Field () msg + field & encodeField #codeOrder 4 + field & encodeField #discriminantValue 6 + field & initVariant #group >>= encodeField #typeId 322 - field + field & readField #ordinal >>= encodeVariant #explicit 22 - } - ] + } + ] where - testCase BuildTest{..} = it ("Should build " ++ expected) $ do - msg <- M.newMessage Nothing - evalLimitT maxBound $ builder msg - constMsg <- freeze msg - actual <- decodeValue schemaSchemaSrc typeName constMsg - actual `shouldBe` expected + testCase BuildTest {..} = it ("Should build " ++ expected) $ do + msg <- M.newMessage Nothing + evalLimitT maxBound $ builder msg + constMsg <- freeze msg + actual <- decodeValue schemaSchemaSrc typeName constMsg + actual `shouldBe` expected diff --git a/tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs b/tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs --- a/tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs +++ b/tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs @@ -1,97 +1,105 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NegativeLiterals #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +-- TODO(cleanup): the raw/pure split no longer exists, so this module path no longer +-- makes sense; reorganize. module Module.Capnp.Gen.Capnp.Schema.Pure (pureSchemaTests) where +import Capnp + ( IsStruct, + Mutability (..), + Parse (..), + Raw (..), + defaultLimit, + evalLimitT, + hGetParsed, + hPutParsed, + msgToParsed, + ) +import Capnp.Gen.Capnp.Schema +import qualified Capnp.Message as M +import Capnp.Mutability (freeze) +import qualified Capnp.Untyped as U +import Control.Exception.Safe (bracket) +import Control.Monad (when) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LBS +import Data.Default (Default (..)) +import Data.Foldable (traverse_) import Data.Proxy -import Test.Hspec - -import Control.Exception.Safe (bracket) -import Control.Monad (when) -import Data.Default (Default(..)) -import Data.Foldable (traverse_) -import System.Directory (removeFile) +import Instances () +import System.Directory (removeFile) import System.IO - (IOMode(ReadMode, WriteMode), hClose, openBinaryTempFile, withBinaryFile) -import Test.QuickCheck (Arbitrary, Property, property) -import Test.QuickCheck.IO (propertyIO) + ( IOMode (ReadMode, WriteMode), + hClose, + openBinaryTempFile, + withBinaryFile, + ) +import Test.Hspec +import Test.QuickCheck (Arbitrary, Property, property) +import Test.QuickCheck.IO (propertyIO) import Test.QuickCheck.Instances () -import Text.Heredoc (here) -import Text.Show.Pretty (ppShow) - -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as LBS - -import Capnp.Gen.Capnp.Schema.New +import Text.Heredoc (here) +import Text.Show.Pretty (ppShow) import Util -import Instances () - -import Capnp.Mutability (freeze) -import Capnp.New - ( IsStruct - , Mutability(..) - , Parse(..) - , Raw(..) - , defaultLimit - , evalLimitT - , hGetParsed - , hPutParsed - , msgToParsed - ) - -import qualified Capnp.Message as M -import qualified Capnp.Untyped as U - pureSchemaTests :: Spec pureSchemaTests = describe "Tests for generated high-level modules." $ do - decodeTests - decodeDefaultTests - encodeTests - propTests + decodeTests + decodeDefaultTests + encodeTests + propTests encodeTests :: Spec -encodeTests = describe "schema encode tests" $ +encodeTests = + describe "schema encode tests" $ testCase - ( "Node.Parameter" - , Node'Parameter { name = "Bob" } - , "(name = \"Bob\")\n" - ) + ( "Node.Parameter", + Node'Parameter {name = "Bob"}, + "(name = \"Bob\")\n" + ) where testCase :: - ( IsStruct a - , Parse a pa - , Show pa - , Eq pa - ) => (String, pa, String) -> Spec + ( IsStruct a, + Parse a pa, + Show pa, + Eq pa + ) => + (String, pa, String) -> + Spec testCase (name, expectedValue, expectedText) = describe "cerialize" $ - it ("Should agree with capnp decode (with name = " ++ name ++ ")") $ do - msg <- evalLimitT maxBound $ do - -- TODO: add some helpers for all this. - msg <- M.newMessage Nothing - Raw cerialOut <- encode msg expectedValue - U.setRoot cerialOut - freeze msg - let builder = M.encode msg - actualText <- capnpDecode - (LBS.toStrict $ BB.toLazyByteString builder) - (MsgMetaData schemaSchemaSrc name) - actualText `shouldBe` expectedText - actualValue <- evalLimitT maxBound $ msgToParsed msg - actualValue `shouldBe` expectedValue + it ("Should agree with capnp decode (with name = " ++ name ++ ")") $ do + msg <- evalLimitT maxBound $ do + -- TODO: add some helpers for all this. + msg <- M.newMessage Nothing + Raw cerialOut <- encode msg expectedValue + U.setRoot cerialOut + freeze msg + let builder = M.encode msg + actualText <- + capnpDecode + (LBS.toStrict $ BB.toLazyByteString builder) + (MsgMetaData schemaSchemaSrc name) + actualText `shouldBe` expectedText + actualValue <- evalLimitT maxBound $ msgToParsed msg + actualValue `shouldBe` expectedValue decodeTests :: Spec -decodeTests = describe "schema decode tests" $ sequence_ $ - [ decodeTests "CodeGeneratorRequest" - [ ( [here| +decodeTests = + describe "schema decode tests" $ + sequence_ $ + [ decodeTests + "CodeGeneratorRequest" + [ ( [here| ( capnpVersion = (major = 0, minor = 6, micro = 1) , nodes = [] , requestedFiles = @@ -103,22 +111,23 @@ ) ] ) - |] - , CodeGeneratorRequest - { capnpVersion = CapnpVersion { major = 0, minor = 6, micro = 1 } - , nodes = [] - , requestedFiles = + |], + CodeGeneratorRequest + { capnpVersion = CapnpVersion {major = 0, minor = 6, micro = 1}, + nodes = [], + requestedFiles = [ CodeGeneratorRequest'RequestedFile 4 "hello.capnp" [CodeGeneratorRequest'RequestedFile'Import 2 "std"] - ] - , sourceInfo = [] + ], + sourceInfo = [] } - ) - ] - , decodeTests "Node" - [ ( [here| + ) + ], + decodeTests + "Node" + [ ( [here| ( id = 7 , displayName = "foo:MyType" , displayNamePrefixLength = 4 @@ -127,23 +136,25 @@ , isGeneric = true , nestedNodes = [(name = "theName", id = 321)] , annotations = [ (id = 2, brand = (scopes = []), value = (bool = true)) ] - , |] ++ unionText ++ [here| + , |] + ++ unionText + ++ [here| ) - |] - , Node + |], + Node 7 "foo:MyType" 4 2 [Node'NestedNode "theName" 321] [Annotation 2 (Value $ Value'bool True) (Brand [])] - [Node'Parameter "theName" ] + [Node'Parameter "theName"] True unionVal - ) - | (unionText, unionVal) <- - [ ("file = void", Node'file) - , ( [here| struct = + ) + | (unionText, unionVal) <- + [ ("file = void", Node'file), + ( [here| struct = ( dataWordCount = 3 , pointerCount = 2 , preferredListEncoding = inlineComposite @@ -160,39 +171,40 @@ ) ] ) - |] - , Node'struct Node'struct' - { dataWordCount = 3 - , pointerCount = 2 - , preferredListEncoding = ElementSize'inlineComposite - , isGroup = False - , discriminantCount = 4 - , discriminantOffset = 2 - , fields = - [ Field - "fieldName" - 3 - [ Annotation - 2 - (Value $ Value'bool True) - (Brand []) + |], + Node'struct + Node'struct' + { dataWordCount = 3, + pointerCount = 2, + preferredListEncoding = ElementSize'inlineComposite, + isGroup = False, + discriminantCount = 4, + discriminantOffset = 2, + fields = + [ Field + "fieldName" + 3 + [ Annotation + 2 + (Value $ Value'bool True) + (Brand []) + ] + 7 + (Field'ordinal' Field'ordinal'implicit) + (Field'group $ Field'group' 4) ] - 7 - (Field'ordinal' Field'ordinal'implicit) - (Field'group $ Field'group' 4) - ] - } - ) - , ( "enum = (enumerants = [(name = \"blue\", codeOrder = 2, annotations = [])])" - , Node'enum $ Node'enum' [ Enumerant "blue" 2 [] ] - ) - , ( "interface = (methods = [], superclasses = [(id = 0, brand = (scopes = []))])" - , Node'interface $ Node'interface' [] [Superclass 0 (Brand [])] - ) - , ( "const = (type = (bool = void), value = (bool = false))" - , Node'const $ Node'const' (Type Type'bool) (Value $ Value'bool False) - ) - , ( [here| annotation = + } + ), + ( "enum = (enumerants = [(name = \"blue\", codeOrder = 2, annotations = [])])", + Node'enum $ Node'enum' [Enumerant "blue" 2 []] + ), + ( "interface = (methods = [], superclasses = [(id = 0, brand = (scopes = []))])", + Node'interface $ Node'interface' [] [Superclass 0 (Brand [])] + ), + ( "const = (type = (bool = void), value = (bool = false))", + Node'const $ Node'const' (Type Type'bool) (Value $ Value'bool False) + ), + ( [here| annotation = ( type = (bool = void) , targetsFile = true , targetsConst = false @@ -207,66 +219,73 @@ , targetsParam = true , targetsAnnotation = false ) - |] - , Node'annotation $ Node'annotation' - (Type Type'bool) - True - False - False - True - True - True - False - False - True - False - True - False - ) - ] - ] - , decodeTests "Node.Parameter" - [ ("(name = \"theName\")", Node'Parameter "theName" ) - ] - , decodeTests "Node.NestedNode" - [ ("(name = \"theName\", id = 321)", Node'NestedNode "theName" 321) - ] - , decodeTests "Value" - [ ("(bool = true)", Value'bool True) - , ("(bool = false)", Value'bool False) - , ("(int8 = -4)", Value'int8 (-4)) - , ("(int8 = -128)", Value'int8 (-128)) - , ("(int8 = 127)", Value'int8 127) - , ("(uint8 = 23)", Value'uint8 23) - , ("(uint8 = 255)", Value'uint8 255) - , ("(int16 = 1012)", Value'int16 1012) - , ("(uint16 = 40000)", Value'uint16 40000) - , ("(uint32 = 1000100)", Value'uint32 1000100) - , ("(int32 = 1000100)", Value'int32 1000100) - , ("(uint64 = 1234567890123456)", Value'uint64 1234567890123456) - , ("(int64 = 12345678901234567)", Value'int64 12345678901234567) - , ("(float32 = 17.32)", Value'float32 17.32) - , ("(float64 = 13.99)", Value'float64 13.99) - , ("(data = \"beep boop.\")", Value'data_ "beep boop.") - , ("(text = \"Hello, World!\")", Value'text "Hello, World!") - , ("(enum = 2313)", Value'enum 2313) - , ("(interface = void)", Value'interface) - -- TODO: It would be nice to test list, struct, and anyPointer - -- variants, but I(zenhack) haven't figured out how to specify - -- an AnyPointer in the input to capnp encode. Maybe capnp eval - -- can do something like this? will have to investigate. - ] - , decodeTests "Annotation" - [ ( "(id = 323, brand = (scopes = []), value = (bool = true))" - , Annotation 323 (Value $ Value'bool True) (Brand []) - ) - ] - , decodeTests "CapnpVersion" - [ ("(major = 0, minor = 5, micro = 3)", CapnpVersion 0 5 3) - , ("(major = 1, minor = 0, micro = 2)", CapnpVersion 1 0 2) - ] - , decodeTests "Field" - [ ( [here| + |], + Node'annotation $ + Node'annotation' + (Type Type'bool) + True + False + False + True + True + True + False + False + True + False + True + False + ) + ] + ], + decodeTests + "Node.Parameter" + [ ("(name = \"theName\")", Node'Parameter "theName") + ], + decodeTests + "Node.NestedNode" + [ ("(name = \"theName\", id = 321)", Node'NestedNode "theName" 321) + ], + decodeTests + "Value" + [ ("(bool = true)", Value'bool True), + ("(bool = false)", Value'bool False), + ("(int8 = -4)", Value'int8 (-4)), + ("(int8 = -128)", Value'int8 (-128)), + ("(int8 = 127)", Value'int8 127), + ("(uint8 = 23)", Value'uint8 23), + ("(uint8 = 255)", Value'uint8 255), + ("(int16 = 1012)", Value'int16 1012), + ("(uint16 = 40000)", Value'uint16 40000), + ("(uint32 = 1000100)", Value'uint32 1000100), + ("(int32 = 1000100)", Value'int32 1000100), + ("(uint64 = 1234567890123456)", Value'uint64 1234567890123456), + ("(int64 = 12345678901234567)", Value'int64 12345678901234567), + ("(float32 = 17.32)", Value'float32 17.32), + ("(float64 = 13.99)", Value'float64 13.99), + ("(data = \"beep boop.\")", Value'data_ "beep boop."), + ("(text = \"Hello, World!\")", Value'text "Hello, World!"), + ("(enum = 2313)", Value'enum 2313), + ("(interface = void)", Value'interface) + -- TODO: It would be nice to test list, struct, and anyPointer + -- variants, but I(zenhack) haven't figured out how to specify + -- an AnyPointer in the input to capnp encode. Maybe capnp eval + -- can do something like this? will have to investigate. + ], + decodeTests + "Annotation" + [ ( "(id = 323, brand = (scopes = []), value = (bool = true))", + Annotation 323 (Value $ Value'bool True) (Brand []) + ) + ], + decodeTests + "CapnpVersion" + [ ("(major = 0, minor = 5, micro = 3)", CapnpVersion 0 5 3), + ("(major = 1, minor = 0, micro = 2)", CapnpVersion 1 0 2) + ], + decodeTests + "Field" + [ ( [here| ( name = "fieldName" , codeOrder = 3 , annotations = [ (id = 2, brand = (scopes = []), value = (bool = true)) ] @@ -274,16 +293,16 @@ , group = (typeId = 4) , ordinal = (implicit = void) ) - |] - , Field + |], + Field "fieldName" 3 [Annotation 2 (Value $ Value'bool True) (Brand [])] 3 (Field'ordinal' Field'ordinal'implicit) (Field'group $ Field'group' 4) - ) - , ( [here| + ), + ( [here| ( name = "fieldName" , codeOrder = 3 , annotations = [ (id = 2, brand = (scopes = []), value = (bool = true)) ] @@ -296,89 +315,113 @@ ) , ordinal = (explicit = 7) ) - |] - , Field + |], + Field "fieldName" 3 [Annotation 2 (Value $ Value'bool True) (Brand [])] 3 (Field'ordinal' $ Field'ordinal'explicit 7) - (Field'slot $ Field'slot' - 3 - (Type Type'bool) - (Value $ Value'bool False) - True) - ) - ] - , decodeTests "Enumerant" - [ ( [here| + ( Field'slot $ + Field'slot' + 3 + (Type Type'bool) + (Value $ Value'bool False) + True + ) + ) + ], + decodeTests + "Enumerant" + [ ( [here| ( name = "red" , codeOrder = 4 , annotations = [ (id = 23, brand = (scopes = []), value = (uint8 = 3)) ] ) - |] - , Enumerant "red" 4 [Annotation 23 (Value $ Value'uint8 3) (Brand [])] - ) - ] - , decodeTests "Superclass" - [ ("(id = 34, brand = (scopes = []))", Superclass 34 (Brand [])) - ] - , decodeTests "Type" - [ ("(bool = void)", Type Type'bool) - , ("(int8 = void)", Type Type'int8) - , ("(int16 = void)", Type Type'int16) - , ("(int32 = void)", Type Type'int32) - , ("(int64 = void)", Type Type'int64) - , ("(uint8 = void)", Type Type'uint8) - , ("(uint16 = void)", Type Type'uint16) - , ("(uint32 = void)", Type Type'uint32) - , ("(uint64 = void)", Type Type'uint64) - , ("(float32 = void)", Type Type'float32) - , ("(float64 = void)", Type Type'float64) - , ("(text = void)", Type Type'text) - , ("(data = void)", Type Type'data_) - , ( "(list = (elementType = (list = (elementType = (text = void)))))" - , Type $ Type'list $ Type'list' $ Type $ Type'list $ Type'list' $ Type Type'text - ) - , ( "(enum = (typeId = 4, brand = (scopes = [])))" - , Type $ Type'enum $ Type'enum' 4 (Brand []) - ) - , ( "(struct = (typeId = 7, brand = (scopes = [])))" - , Type $ Type'struct $ Type'struct' 7 (Brand []) - ) - , ( "(interface = (typeId = 1, brand = (scopes = [])))" - , Type $ Type'interface $ Type'interface' 1 (Brand []) - ) - , ( "(anyPointer = (unconstrained = (anyKind = void)))" - , Type $ Type'anyPointer $ Type'anyPointer' $ Type'anyPointer'unconstrained $ - Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'anyKind - ) - , ( "(anyPointer = (unconstrained = (struct = void)))" - , Type $ Type'anyPointer $ Type'anyPointer' $ Type'anyPointer'unconstrained $ - Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'struct - ) - , ( "(anyPointer = (unconstrained = (list = void)))" - , Type $ Type'anyPointer $ Type'anyPointer' $ Type'anyPointer'unconstrained $ - Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'list - ) - , ( "(anyPointer = (unconstrained = (capability = void)))" - , Type $ Type'anyPointer $ Type'anyPointer' $ Type'anyPointer'unconstrained $ - Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'capability - ) - , ( "(anyPointer = (parameter = (scopeId = 4, parameterIndex = 2)))" - , Type $ Type'anyPointer $ Type'anyPointer' $ - Type'anyPointer'parameter $ Type'anyPointer'parameter' 4 2 - ) - , ( "(anyPointer = (implicitMethodParameter = (parameterIndex = 7)))" - , Type $ Type'anyPointer $ Type'anyPointer' $ Type'anyPointer'implicitMethodParameter $ - Type'anyPointer'implicitMethodParameter' 7 - ) - ] - , decodeTests "Brand" - [ ("(scopes = [])", Brand []) - , ( [here| + |], + Enumerant "red" 4 [Annotation 23 (Value $ Value'uint8 3) (Brand [])] + ) + ], + decodeTests + "Superclass" + [ ("(id = 34, brand = (scopes = []))", Superclass 34 (Brand [])) + ], + decodeTests + "Type" + [ ("(bool = void)", Type Type'bool), + ("(int8 = void)", Type Type'int8), + ("(int16 = void)", Type Type'int16), + ("(int32 = void)", Type Type'int32), + ("(int64 = void)", Type Type'int64), + ("(uint8 = void)", Type Type'uint8), + ("(uint16 = void)", Type Type'uint16), + ("(uint32 = void)", Type Type'uint32), + ("(uint64 = void)", Type Type'uint64), + ("(float32 = void)", Type Type'float32), + ("(float64 = void)", Type Type'float64), + ("(text = void)", Type Type'text), + ("(data = void)", Type Type'data_), + ( "(list = (elementType = (list = (elementType = (text = void)))))", + Type $ Type'list $ Type'list' $ Type $ Type'list $ Type'list' $ Type Type'text + ), + ( "(enum = (typeId = 4, brand = (scopes = [])))", + Type $ Type'enum $ Type'enum' 4 (Brand []) + ), + ( "(struct = (typeId = 7, brand = (scopes = [])))", + Type $ Type'struct $ Type'struct' 7 (Brand []) + ), + ( "(interface = (typeId = 1, brand = (scopes = [])))", + Type $ Type'interface $ Type'interface' 1 (Brand []) + ), + ( "(anyPointer = (unconstrained = (anyKind = void)))", + Type $ + Type'anyPointer $ + Type'anyPointer' $ + Type'anyPointer'unconstrained $ + Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'anyKind + ), + ( "(anyPointer = (unconstrained = (struct = void)))", + Type $ + Type'anyPointer $ + Type'anyPointer' $ + Type'anyPointer'unconstrained $ + Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'struct + ), + ( "(anyPointer = (unconstrained = (list = void)))", + Type $ + Type'anyPointer $ + Type'anyPointer' $ + Type'anyPointer'unconstrained $ + Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'list + ), + ( "(anyPointer = (unconstrained = (capability = void)))", + Type $ + Type'anyPointer $ + Type'anyPointer' $ + Type'anyPointer'unconstrained $ + Type'anyPointer'unconstrained' Type'anyPointer'unconstrained'capability + ), + ( "(anyPointer = (parameter = (scopeId = 4, parameterIndex = 2)))", + Type $ + Type'anyPointer $ + Type'anyPointer' $ + Type'anyPointer'parameter $ + Type'anyPointer'parameter' 4 2 + ), + ( "(anyPointer = (implicitMethodParameter = (parameterIndex = 7)))", + Type $ + Type'anyPointer $ + Type'anyPointer' $ + Type'anyPointer'implicitMethodParameter $ + Type'anyPointer'implicitMethodParameter' 7 + ) + ], + decodeTests + "Brand" + [ ("(scopes = [])", Brand []), + ( [here| ( scopes = [ (scopeId = 32, inherit = void) , (scopeId = 23, bind = @@ -388,131 +431,155 @@ ) ] ) - |] - , Brand - [ Brand'Scope 32 Brand'Scope'inherit - , Brand'Scope 23 $ Brand'Scope'bind - [ Brand'Binding Brand'Binding'unbound - , Brand'Binding $ Brand'Binding'type_ $ Type Type'bool - ] + |], + Brand + [ Brand'Scope 32 Brand'Scope'inherit, + Brand'Scope 23 $ + Brand'Scope'bind + [ Brand'Binding Brand'Binding'unbound, + Brand'Binding $ Brand'Binding'type_ $ Type Type'bool + ] ] - ) - ] - ] `asProxyTypeOf` (Proxy :: Proxy [Spec]) + ) + ] + ] + `asProxyTypeOf` (Proxy :: Proxy [Spec]) where -- TODO: rename this: it's confusing to have both the top level and helper -- have the same name; not sure how that happened in the first place. decodeTests :: - ( IsStruct a - , Parse a pa - , Eq pa - , Show pa - ) => String -> [(String, pa)] -> Spec + ( IsStruct a, + Parse a pa, + Eq pa, + Show pa + ) => + String -> + [(String, pa)] -> + Spec decodeTests typename cases = - describe ("Decode " ++ typename) $ traverse_ (testCase typename) cases + describe ("Decode " ++ typename) $ traverse_ (testCase typename) cases testCase typename (capnpText, expected) = - specify ("should agree with `capnp encode` on " ++ capnpText) $ do - msg <- encodeValue schemaSchemaSrc typename capnpText - actual <- evalLimitT 128 $ msgToParsed msg - ppAssertEqual actual expected + specify ("should agree with `capnp encode` on " ++ capnpText) $ do + msg <- encodeValue schemaSchemaSrc typename capnpText + actual <- evalLimitT 128 $ msgToParsed msg + ppAssertEqual actual expected decodeDefaultTests :: Spec decodeDefaultTests = describe "Decoding default values" $ do - decodeDefault @Type "Type" - decodeDefault @Value "Value" - decodeDefault @Node "Node" + decodeDefault @Type "Type" + decodeDefault @Value "Value" + decodeDefault @Node "Node" decodeDefault :: - forall a pa. - ( IsStruct a - , Parse a pa - , Show pa - , Eq pa - , Default pa - ) => String -> Spec + forall a pa. + ( IsStruct a, + Parse a pa, + Show pa, + Eq pa, + Default pa + ) => + String -> + Spec decodeDefault typename = - specify ("The empty struct decodes to the default value for " ++ typename) $ do - actual <- evalLimitT defaultLimit (msgToParsed @a M.empty) - ppAssertEqual actual def + specify ("The empty struct decodes to the default value for " ++ typename) $ do + actual <- evalLimitT defaultLimit (msgToParsed @a M.empty) + ppAssertEqual actual def ppAssertEqual :: (Show a, Eq a) => a -> a -> IO () ppAssertEqual actual expected = - when (actual /= expected) $ error $ - "Expected:\n\n" ++ ppShow expected ++ "\n\nbut got:\n\n" ++ ppShow actual + when (actual /= expected) $ + error $ + "Expected:\n\n" ++ ppShow expected ++ "\n\nbut got:\n\n" ++ ppShow actual propTests :: Spec propTests = describe "Various quickcheck properties" $ do - propCase "Node" (Proxy :: Proxy Node) - propCase "Node.Parameter" (Proxy :: Proxy Node'Parameter) - propCase "Node.NestedNode" (Proxy :: Proxy Node'NestedNode) - propCase "Field" (Proxy :: Proxy Field) - propCase "Enumerant" (Proxy :: Proxy Enumerant) - propCase "Superclass" (Proxy :: Proxy Superclass) - propCase "Method" (Proxy :: Proxy Method) - propCase "Type" (Proxy :: Proxy Type) - propCase "Brand" (Proxy :: Proxy Brand) - propCase "Brand.Scope" (Proxy :: Proxy Brand'Scope) - propCase "Brand.Binding" (Proxy :: Proxy Brand'Binding) - propCase "Value" (Proxy :: Proxy Value) - propCase "Annotation" (Proxy :: Proxy Annotation) - propCase "CapnpVersion" (Proxy :: Proxy CapnpVersion) - propCase "CodeGeneratorRequest" (Proxy :: Proxy CodeGeneratorRequest) - propCase "CodeGeneratorRequest.RequestedFile" - (Proxy :: Proxy CodeGeneratorRequest'RequestedFile) - propCase "CodeGeneratorRequest.RequestedFile.Import" - (Proxy :: Proxy CodeGeneratorRequest'RequestedFile'Import) + propCase "Node" (Proxy :: Proxy Node) + propCase "Node.Parameter" (Proxy :: Proxy Node'Parameter) + propCase "Node.NestedNode" (Proxy :: Proxy Node'NestedNode) + propCase "Field" (Proxy :: Proxy Field) + propCase "Enumerant" (Proxy :: Proxy Enumerant) + propCase "Superclass" (Proxy :: Proxy Superclass) + propCase "Method" (Proxy :: Proxy Method) + propCase "Type" (Proxy :: Proxy Type) + propCase "Brand" (Proxy :: Proxy Brand) + propCase "Brand.Scope" (Proxy :: Proxy Brand'Scope) + propCase "Brand.Binding" (Proxy :: Proxy Brand'Binding) + propCase "Value" (Proxy :: Proxy Value) + propCase "Annotation" (Proxy :: Proxy Annotation) + propCase "CapnpVersion" (Proxy :: Proxy CapnpVersion) + propCase "CodeGeneratorRequest" (Proxy :: Proxy CodeGeneratorRequest) + propCase + "CodeGeneratorRequest.RequestedFile" + (Proxy :: Proxy CodeGeneratorRequest'RequestedFile) + propCase + "CodeGeneratorRequest.RequestedFile.Import" + (Proxy :: Proxy CodeGeneratorRequest'RequestedFile'Import) propCase :: - ( IsStruct a - , Parse a pa - , Arbitrary pa - , Show pa - , Eq pa - ) => String -> Proxy a -> Spec + ( IsStruct a, + Parse a pa, + Arbitrary pa, + Show pa, + Eq pa + ) => + String -> + Proxy a -> + Spec propCase name proxy = describe ("...for " ++ name) $ do - specify "cerialize and decerialize are inverses." $ - property (prop_encodeParseInverses proxy) - specify "hPutValue and hGetValue are inverses." $ - property (prop_hGetPutInverses proxy) + specify "cerialize and decerialize are inverses." $ + property (prop_encodeParseInverses proxy) + specify "hPutValue and hGetValue are inverses." $ + property (prop_hGetPutInverses proxy) prop_hGetPutInverses :: - ( IsStruct a - , Parse a pa - , Show pa - , Eq pa - ) => Proxy a -> pa -> Property + ( IsStruct a, + Parse a pa, + Show pa, + Eq pa + ) => + Proxy a -> + pa -> + Property prop_hGetPutInverses _proxy expected = propertyIO $ do - -- This is a little more complicated than I'd like due to resource - -- management issues. We create a temporary file, then immediately - -- close the handle to it, and open it again in a separate call to - -- bracket. This allows us to decouple the lifetimes of the file and - -- the handle. - actual <- bracket - (do - (filename, handle) <- openBinaryTempFile "/tmp" "hPutParsed-output" - hClose handle - pure filename) - removeFile - (\filename -> do - withBinaryFile filename WriteMode - (`hPutParsed` expected) - withBinaryFile filename ReadMode $ \h -> - hGetParsed h defaultLimit) - ppAssertEqual actual expected + -- This is a little more complicated than I'd like due to resource + -- management issues. We create a temporary file, then immediately + -- close the handle to it, and open it again in a separate call to + -- bracket. This allows us to decouple the lifetimes of the file and + -- the handle. + actual <- + bracket + ( do + (filename, handle) <- openBinaryTempFile "/tmp" "hPutParsed-output" + hClose handle + pure filename + ) + removeFile + ( \filename -> do + withBinaryFile + filename + WriteMode + (`hPutParsed` expected) + withBinaryFile filename ReadMode $ \h -> + hGetParsed h defaultLimit + ) + ppAssertEqual actual expected prop_encodeParseInverses :: - ( IsStruct a - , Parse a pa - , Eq pa - , Show pa - ) => Proxy a -> pa -> Property + ( IsStruct a, + Parse a pa, + Eq pa, + Show pa + ) => + Proxy a -> + pa -> + Property prop_encodeParseInverses _proxy expected = propertyIO $ do - actual <- evalLimitT maxBound $ do - -- TODO: add some helpers for all this. - msg <- M.newMessage Nothing - Raw cerialOut <- encode msg expected - U.setRoot cerialOut - constMsg :: M.Message 'Const <- freeze msg - msgToParsed constMsg - ppAssertEqual actual expected + actual <- evalLimitT maxBound $ do + -- TODO: add some helpers for all this. + msg <- M.newMessage Nothing + Raw cerialOut <- encode msg expected + U.setRoot cerialOut + constMsg :: M.Message 'Const <- freeze msg + msgToParsed constMsg + ppAssertEqual actual expected diff --git a/tests/Module/Capnp/Pointer.hs b/tests/Module/Capnp/Pointer.hs --- a/tests/Module/Capnp/Pointer.hs +++ b/tests/Module/Capnp/Pointer.hs @@ -1,74 +1,84 @@ module Module.Capnp.Pointer (ptrTests) where +import Capnp.Pointer import Data.Bits import Data.Int import Data.Word import Test.Hspec import Test.QuickCheck -import Capnp.Pointer - instance Arbitrary EltSpec where - arbitrary = oneof [ EltNormal <$> arbitrary <*> arbitraryU29 - , EltComposite <$> arbitraryI29 - ] + arbitrary = + oneof + [ EltNormal <$> arbitrary <*> arbitraryU29, + EltComposite <$> arbitraryI29 + ] instance Arbitrary ElementSize where - arbitrary = oneof $ map return [ Sz0 - , Sz1 - , Sz8 - , Sz16 - , Sz32 - , Sz64 - , SzPtr - ] - + arbitrary = + oneof $ + map + return + [ Sz0, + Sz1, + Sz8, + Sz16, + Sz32, + Sz64, + SzPtr + ] -- | arbitraryIN is an arbitrary N bit signed integer as an Int32. arbitraryI32, arbitraryI30, arbitraryI29 :: Gen Int32 arbitraryI32 = arbitrary arbitraryI30 = (`shiftR` 2) <$> arbitraryI32 arbitraryI29 = (`shiftR` 3) <$> arbitraryI32 + -- | arbitraryUN is an arbitrary N bit unsigned integer as a Word32. arbitraryU32, arbitraryU29 :: Gen Word32 arbitraryU32 = arbitrary arbitraryU29 = (`shiftR` 3) <$> arbitraryU32 - instance Arbitrary Ptr where - arbitrary = oneof [ StructPtr <$> arbitraryI30 - <*> arbitrary - <*> arbitrary - , ListPtr <$> arbitraryI30 - <*> arbitrary - , FarPtr <$> arbitrary - <*> arbitraryU29 - <*> arbitrary - , CapPtr <$> arbitrary - ] + arbitrary = + oneof + [ StructPtr + <$> arbitraryI30 + <*> arbitrary + <*> arbitrary, + ListPtr + <$> arbitraryI30 + <*> arbitrary, + FarPtr + <$> arbitrary + <*> arbitraryU29 + <*> arbitrary, + CapPtr <$> arbitrary + ] ptrTests :: Spec ptrTests = do - ptrProps - parsePtrExamples + ptrProps + parsePtrExamples ptrProps :: Spec ptrProps = describe "Pointer Properties" $ do - it "Should satisfy: parseEltSpec . serializeEltSpec == id" $ - property $ \spec -> parseEltSpec (serializeEltSpec spec) == spec - it "Should satisfy: parsePtr . serializePtr == id" $ - property $ \ptr -> - case ptr of - (Just (StructPtr 0 0 0)) -> True -- we skip this one, since it's - -- the same bits as a null, so this - -- shouldn't hold. TODO: the name - -- of this test is a bit misleading - -- because of this case; should fix - -- that. - _ -> parsePtr (serializePtr ptr) == ptr - + it "Should satisfy: parseEltSpec . serializeEltSpec == id" $ + property $ + \spec -> parseEltSpec (serializeEltSpec spec) == spec + it "Should satisfy: parsePtr . serializePtr == id" $ + property $ \ptr -> + case ptr of + (Just (StructPtr 0 0 0)) -> True -- we skip this one, since it's + -- the same bits as a null, so this + -- shouldn't hold. TODO: the name + -- of this test is a bit misleading + -- because of this case; should fix + -- that. + _ -> parsePtr (serializePtr ptr) == ptr parsePtrExamples :: Spec -parsePtrExamples = describe "parsePtr (examples)" $ +parsePtrExamples = + describe "parsePtr (examples)" $ it "Should parse this example correctly" $ - parsePtr 0x0000000200000000 `shouldBe` Just (StructPtr 0 2 0) + parsePtr 0x0000000200000000 `shouldBe` Just (StructPtr 0 2 0) diff --git a/tests/Module/Capnp/Rpc.hs b/tests/Module/Capnp/Rpc.hs --- a/tests/Module/Capnp/Rpc.hs +++ b/tests/Module/Capnp/Rpc.hs @@ -1,103 +1,107 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-error=missing-methods #-} -module Module.Capnp.Rpc (rpcTests) where -import Control.Concurrent.STM -import Data.Word -import Test.Hspec +module Module.Capnp.Rpc (rpcTests) where -import Capnp.Mutability (freeze) +import Capnp + ( Client, + IsCap, + Parse (..), + Pipeline, + SomeServer, + TypeParam, + Which, + callP, + callR, + createPure, + def, + defaultLimit, + evalLimitT, + export, + handleParsed, + lbsToMsg, + msgToParsed, + parsedToMsg, + pipe, + waitPipeline, + ) +import Capnp.Bits (WordCount) +import Capnp.Gen.Aircraft hiding (Left, Right) +import Capnp.Gen.Capnp.Rpc +import qualified Capnp.Gen.Echo as E +import Capnp.Mutability (freeze) +import qualified Capnp.Pointer as P +import qualified Capnp.Repr as R +import Capnp.Rpc hiding (Client) +import Capnp.Rpc.Errors (eFailed) +import Capnp.Rpc.Revoke (makeRevocable) +import Capnp.Rpc.Untyped hiding (Client, Pipeline, export, waitPipeline) import Control.Concurrent.Async (concurrently_, race_) -import Control.Exception.Safe (bracket, try) -import Control.Monad (replicateM, void, (>=>)) -import Control.Monad.Catch (throwM) -import Control.Monad.IO.Class (liftIO) -import Data.Foldable (for_) -import Data.Function ((&)) -import Data.Traversable (for) -import System.Timeout (timeout) - +import Control.Concurrent.STM +import Control.Exception.Safe (SomeException, bracket, try) +import Control.Monad (replicateM, void, (>=>)) +import Control.Monad.Catch (throwM) +import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Builder as BB -import qualified Data.Text as T -import qualified Network.Socket as Socket +import Data.Foldable (for_) +import Data.Function ((&)) +import Data.Functor ((<&>)) +import qualified Data.Text as T +import Data.Traversable (for) +import Data.Word +import qualified Network.Socket as Socket import qualified Supervisors - -import Capnp.Bits (WordCount) -import Capnp.New - ( Client - , IsCap - , Parse(..) - , Pipeline - , SomeServer - , TypeParam - , Which - , callP - , callR - , createPure - , def - , defaultLimit - , evalLimitT - , export - , handleParsed - , lbsToMsg - , msgToParsed - , parsedToMsg - , waitPipeline - ) -import qualified Capnp.Repr as R -import Capnp.Rpc.Errors (eFailed) - -import Capnp.Gen.Aircraft.New hiding (Left, Right) -import Capnp.Gen.Capnp.Rpc.New -import Capnp.Rpc hiding (Client) -import Capnp.Rpc.Untyped hiding (Client, Pipeline, export, waitPipeline) - -import qualified Capnp.Gen.Echo.New as E -import qualified Capnp.Pointer as P +import System.Timeout (timeout) +import Test.Hspec rpcTests :: Spec rpcTests = do - echoTests - aircraftTests - unusualTests + echoTests + aircraftTests + unusualTests ------------------------------------------------------------------------------- -- Tests using echo.capnp. ------------------------------------------------------------------------------- echoTests :: Spec -echoTests = describe "Echo server & client" $ - it "Should echo back the same message." $ runVatPair +echoTests = + describe "Echo server & client" $ + it "Should echo back the same message." $ + runVatPair (\sup -> export @E.Echo sup TestEchoServer) - (\_sup echoSrv -> do - let msgs = - [ def { E.query = "Hello #1" } - , def { E.query = "Hello #2" } - ] - rets <- for msgs $ \arg -> echoSrv - & callP #echo arg - >>= waitPipeline - >>= evalLimitT defaultLimit . parse - liftIO $ rets `shouldBe` - [ def { E.reply = "Hello #1" } - , def { E.reply = "Hello #2" } - ] + ( \_sup echoSrv -> do + let msgs = + [ def {E.query = "Hello #1"}, + def {E.query = "Hello #2"} + ] + rets <- for msgs $ \arg -> + echoSrv + & callP #echo arg + >>= waitPipeline + >>= evalLimitT defaultLimit . parse + liftIO $ + rets + `shouldBe` [ def {E.reply = "Hello #1"}, + def {E.reply = "Hello #2"} + ] ) data TestEchoServer = TestEchoServer instance SomeServer TestEchoServer + instance E.Echo'server_ TestEchoServer where - echo'echo _ = handleParsed $ \params -> pure def { E.reply = E.query params } + echo'echo _ = handleParsed $ \params -> pure def {E.reply = E.query params} ------------------------------------------------------------------------------- -- Tests using aircraft.capnp. @@ -107,7 +111,8 @@ -- | Bump a counter n times, returning a list of the results. bumpN :: Client CallSequence -> Int -> IO [Parsed CallSequence'getNumber'results] -bumpN ctr n = bumpNPipeline ctr n +bumpN ctr n = + bumpNPipeline ctr n >>= traverse waitPipeline >>= traverse (evalLimitT defaultLimit . parse) @@ -117,157 +122,225 @@ aircraftTests :: Spec aircraftTests = describe "aircraft.capnp rpc tests" $ do - describe "newPromiseClient" $ - it "Should preserve E-order" $ - Supervisors.withSupervisor $ \sup -> do - (pc, f) <- newPromiseClient - firsts <- bumpNPipeline pc 2 - atomically (newTestCtr 0) - >>= export @CallSequence sup - >>= fulfill f - nexts <- bumpN pc 2 - firstsResolved <- for firsts $ - waitPipeline >=> evalLimitT defaultLimit . parse - firstsResolved `shouldBe` - [ def { n = 1 } - , def { n = 2 } - ] - nexts `shouldBe` - [ def { n = 3 } - , def { n = 4 } - ] - it "Should propogate server-side exceptions to client method calls" $ runVatPair - (\sup -> export @CallSequence sup ExnCtrServer) - (\_sup -> expectException + describe "newPromiseClient" $ + it "Should preserve E-order" $ + Supervisors.withSupervisor $ \sup -> do + (pc, f) <- newPromiseClient + firsts <- bumpNPipeline pc 2 + atomically (newTestCtr 0) + >>= export @CallSequence sup + >>= fulfill f + nexts <- bumpN pc 2 + firstsResolved <- + for firsts $ + waitPipeline >=> evalLimitT defaultLimit . parse + firstsResolved + `shouldBe` [ def {n = 1}, + def {n = 2} + ] + nexts + `shouldBe` [ def {n = 3}, + def {n = 4} + ] + it "Should propogate server-side exceptions to client method calls" $ + runVatPair + (\sup -> export @CallSequence sup ExnCtrServer) + ( \_sup -> + expectException (callR #getNumber def) def - { type_ = Exception'Type'failed - , reason = "Something went sideways." - } - ) - it "Should receive unimplemented when calling a method on a null cap." $ runVatPair - (\_sup -> pure (fromClient nullClient :: Client CallSequence)) - (\_sup -> expectException + { type_ = Exception'Type'failed, + reason = "Something went sideways." + } + ) + it "Should receive unimplemented when calling a method on a null cap." $ + runVatPair + (\_sup -> pure (fromClient nullClient :: Client CallSequence)) + ( \_sup -> + expectException (callR #getNumber def) def - { type_ = Exception'Type'unimplemented - , reason = "Method unimplemented" - } - ) - it "Should throw an unimplemented exception if the server doesn't implement a method" $ runVatPair - (\sup -> export @CallSequence sup NoImplServer) - (\_sup -> expectException + { type_ = Exception'Type'unimplemented, + reason = "Method unimplemented" + } + ) + it "Should throw an unimplemented exception if the server doesn't implement a method" $ + runVatPair + (\sup -> export @CallSequence sup NoImplServer) + ( \_sup -> + expectException (callR #getNumber def) def - { type_ = Exception'Type'unimplemented - , reason = "Method unimplemented" - } - ) - it "Should throw an opaque exception when the server throws a non-rpc exception" $ runVatPair - (\sup -> export @CallSequence sup NonRpcExnServer) - (\_sup -> expectException + { type_ = Exception'Type'unimplemented, + reason = "Method unimplemented" + } + ) + it "Should throw an opaque exception when the server throws a non-rpc exception" $ + runVatPair + (\sup -> export @CallSequence sup NonRpcExnServer) + ( \_sup -> + expectException (callR #getNumber def) def - { type_ = Exception'Type'failed - , reason = "Unhandled exception" - } - ) - it "A counter should maintain state" $ runVatPair - (\sup -> newTestCtr 0 >>= export @CallSequence sup) - (\_sup ctr -> do - results <- bumpN ctr 4 - liftIO $ results `shouldBe` - [ def { n = 1 } - , def { n = 2 } - , def { n = 3 } - , def { n = 4 } - ] - ) - it "Methods returning interfaces work" $ runVatPair - (\sup -> export @CounterFactory sup (TestCtrFactory sup)) - (\_sup factory -> do - let newCounter start = do - CounterFactory'newCounter'results{counter} <- - factory & callP #newCounter def { start } - >>= waitPipeline - >>= evalLimitT defaultLimit . parse - pure counter + { type_ = Exception'Type'failed, + reason = "Unhandled exception" + } + ) + it "A counter should maintain state" $ + runVatPair + (\sup -> newTestCtr 0 >>= export @CallSequence sup) + ( \_sup ctr -> do + results <- bumpN ctr 4 + liftIO $ + results + `shouldBe` [ def {n = 1}, + def {n = 2}, + def {n = 3}, + def {n = 4} + ] + ) + it "Methods returning interfaces work" $ + runVatPair + (\sup -> export @CounterFactory sup (TestCtrFactory sup)) + ( \_sup factory -> do + let newCounter start = do + CounterFactory'newCounter'results {counter} <- + factory + & callP #newCounter def {start} + >>= waitPipeline + >>= evalLimitT defaultLimit . parse + pure counter - ctrA <- newCounter 2 - ctrB <- newCounter 0 + ctrA <- newCounter 2 + ctrB <- newCounter 0 - r1 <- bumpN ctrA 4 - liftIO $ r1 `shouldBe` - [ def { n = 3 } - , def { n = 4 } - , def { n = 5 } - , def { n = 6 } - ] + r1 <- bumpN ctrA 4 + liftIO $ + r1 + `shouldBe` [ def {n = 3}, + def {n = 4}, + def {n = 5}, + def {n = 6} + ] - r2 <- bumpN ctrB 2 - liftIO $ r2 `shouldBe` - [ def { n = 1 } - , def { n = 2 } - ] + r2 <- bumpN ctrB 2 + liftIO $ + r2 + `shouldBe` [ def {n = 1}, + def {n = 2} + ] - ctrC <- newCounter 30 + ctrC <- newCounter 30 - r3 <- bumpN ctrA 3 - liftIO $ r3 `shouldBe` - [ def { n = 7 } - , def { n = 8 } - , def { n = 9 } - ] + r3 <- bumpN ctrA 3 + liftIO $ + r3 + `shouldBe` [ def {n = 7}, + def {n = 8}, + def {n = 9} + ] - r4 <- bumpN ctrC 1 - liftIO $ r4 `shouldBe` [ def { n = 31 } ] - ) - it "Methods with interface parameters work" $ do - ctrA <- atomically $ newTestCtr 2 - ctrB <- atomically $ newTestCtr 0 - ctrC <- atomically $ newTestCtr 30 - runVatPair - (\sup -> export @CounterAcceptor sup TestCtrAcceptor) - (\sup acceptor -> do - for_ [ctrA, ctrB, ctrC] $ \ctrSrv -> do - ctr <- atomically $ export @CallSequence sup ctrSrv - acceptor - & callP #accept CounterAcceptor'accept'params { counter = ctr } - >>= waitPipeline @CounterAcceptor'accept'results - r <- traverse - (\(TestCtrServer var) -> liftIO $ readTVarIO var) - [ctrA, ctrB, ctrC] - liftIO $ r `shouldBe` [7, 5, 35] - ) + r4 <- bumpN ctrC 1 + liftIO $ r4 `shouldBe` [def {n = 31}] + ) + it "Methods with interface parameters work" $ do + ctrA <- atomically $ newTestCtr 2 + ctrB <- atomically $ newTestCtr 0 + ctrC <- atomically $ newTestCtr 30 + runVatPair + (\sup -> export @CounterAcceptor sup TestCtrAcceptor) + ( \sup acceptor -> do + for_ [ctrA, ctrB, ctrC] $ \ctrSrv -> do + ctr <- atomically $ export @CallSequence sup ctrSrv + acceptor + & callP #accept CounterAcceptor'accept'params {counter = ctr} + >>= waitPipeline @CounterAcceptor'accept'results + r <- + traverse + (\(TestCtrServer var) -> liftIO $ readTVarIO var) + [ctrA, ctrB, ctrC] + liftIO $ r `shouldBe` [7, 5, 35] + ) + describe "revokers" $ revokerTests +-- | Tests for revokers. +revokerTests :: Spec +revokerTests = do + it "should allow methods through before revocation" $ do + withSupervisor $ \sup -> do + factory <- export @CounterFactory sup (TestCtrFactory sup) + (mfactory, _revoke) <- makeRevocable sup factory + CallSequence'getNumber'results {n} <- + mfactory + & callP #newCounter def {start = 0} + <&> pipe #counter + >>= callP #getNumber def + >>= waitPipeline + >>= evalLimitT defaultLimit . parse + n `shouldBe` 1 + it "should block methods after revocation" $ do + withSupervisor $ \sup -> do + factory <- export @CounterFactory sup (TestCtrFactory sup) + (mfactory, revoke) <- makeRevocable sup factory + atomically revoke + result <- + try $ + mfactory + & callP #newCounter def {start = 0} + >>= waitPipeline + case result of + Left (_ :: SomeException) -> pure () + Right _ -> error "Expected an error after revocation." + it "should block methods on returned objects after revocation" $ do + withSupervisor $ \sup -> do + factory <- export @CounterFactory sup (TestCtrFactory sup) + (mfactory, revoke) <- makeRevocable sup factory + CounterFactory'newCounter'results {counter = mctr} <- + mfactory + & callP #newCounter def {start = 0} + >>= waitPipeline + >>= evalLimitT defaultLimit . parse + atomically revoke + result <- + try $ + mctr + & callP #getNumber def + >>= waitPipeline + case result of + Left (_ :: SomeException) -> pure () + Right _ -> error "Expected an error after revocation." + data TestCtrAcceptor = TestCtrAcceptor instance SomeServer TestCtrAcceptor + instance CounterAcceptor'server_ TestCtrAcceptor where - counterAcceptor'accept _ = - handleParsed $ \CounterAcceptor'accept'params{counter} -> do - [start] <- map n <$> bumpN counter 1 - r <- bumpN counter 4 - liftIO $ r `shouldBe` - [ def { n = start + 1 } - , def { n = start + 2 } - , def { n = start + 3 } - , def { n = start + 4 } - ] - pure def + counterAcceptor'accept _ = + handleParsed $ \CounterAcceptor'accept'params {counter} -> do + [start] <- map n <$> bumpN counter 1 + r <- bumpN counter 4 + liftIO $ + r + `shouldBe` [ def {n = start + 1}, + def {n = start + 2}, + def {n = start + 3}, + def {n = start + 4} + ] + pure def ------------------------------------------------------------------------------- -- Implementations of various interfaces for testing purposes. ------------------------------------------------------------------------------- -newtype TestCtrFactory = TestCtrFactory { sup :: Supervisor } +newtype TestCtrFactory = TestCtrFactory {sup :: Supervisor} instance SomeServer TestCtrFactory + instance CounterFactory'server_ TestCtrFactory where - counterFactory'newCounter TestCtrFactory{sup} = - handleParsed $ \CounterFactory'newCounter'params{start} -> do - ctr <- atomically $ newTestCtr start >>= export @CallSequence sup - pure CounterFactory'newCounter'results { counter = ctr } + counterFactory'newCounter TestCtrFactory {sup} = + handleParsed $ \CounterFactory'newCounter'params {start} -> do + ctr <- atomically $ newTestCtr start >>= export @CallSequence sup + pure CounterFactory'newCounter'results {counter = ctr} newTestCtr :: Word32 -> STM TestCtrServer newTestCtr n = TestCtrServer <$> newTVar n @@ -275,37 +348,42 @@ newtype TestCtrServer = TestCtrServer (TVar Word32) instance SomeServer TestCtrServer -instance CallSequence'server_ TestCtrServer where - callSequence'getNumber (TestCtrServer tvar) = - handleParsed $ \_ -> do - ret <- liftIO $ atomically $ do - modifyTVar' tvar (+1) - readTVar tvar - pure def { n = ret } +instance CallSequence'server_ TestCtrServer where + callSequence'getNumber (TestCtrServer tvar) = + handleParsed $ \_ -> do + ret <- liftIO $ atomically $ do + modifyTVar' tvar (+ 1) + readTVar tvar + pure def {n = ret} + -- a 'CallSequence' which always throws an exception. data ExnCtrServer = ExnCtrServer instance SomeServer ExnCtrServer + instance CallSequence'server_ ExnCtrServer where - callSequence'getNumber _ = handleParsed $ \_ -> - throwM def - { type_ = Exception'Type'failed - , reason = "Something went sideways." - } + callSequence'getNumber _ = handleParsed $ \_ -> + throwM + def + { type_ = Exception'Type'failed, + reason = "Something went sideways." + } -- a 'CallSequence' which doesn't implement its methods. data NoImplServer = NoImplServer instance SomeServer NoImplServer + instance CallSequence'server_ NoImplServer -- TODO: can we silence the warning somehow? -- Server that throws some non-rpc exception. data NonRpcExnServer = NonRpcExnServer instance SomeServer NonRpcExnServer + instance CallSequence'server_ NonRpcExnServer where - callSequence'getNumber _ = handleParsed $ \_ -> error "OOPS" + callSequence'getNumber _ = handleParsed $ \_ -> error "OOPS" ------------------------------------------------------------------------------- -- Tests for unusual patterns of messages . @@ -318,141 +396,160 @@ unusualTests :: Spec unusualTests = describe "Tests for unusual message patterns" $ do - it "Should raise ReceivedAbort in response to an abort message." $ do - -- Send an abort message to the remote vat, and verify that - -- the vat actually aborts. - let exn = def - { type_ = Exception'Type'failed - , reason = "Testing abort" - } - withTransportPair $ \(vatTrans, probeTrans) -> do - ret <- try $ concurrently_ - (handleConn (vatTrans defaultLimit) def { debugMode = True}) - $ do - msg <- createPure maxBound $ parsedToMsg $ Message $ Message'abort exn - sendMsg (probeTrans defaultLimit) msg - ret `shouldBe` Left (ReceivedAbort exn) - triggerAbort (Message'unimplemented $ Message $ Message'abort def) $ - "Your vat sent an 'unimplemented' message for an abort message " <> - "that its remote peer never sent. This is likely a bug in your " <> - "capnproto library." - triggerAbort - (Message'call (def + it "Should raise ReceivedAbort in response to an abort message." $ do + -- Send an abort message to the remote vat, and verify that + -- the vat actually aborts. + let exn = + def + { type_ = Exception'Type'failed, + reason = "Testing abort" + } + withTransportPair $ \(vatTrans, probeTrans) -> do + ret <- try + $ concurrently_ + (handleConn (vatTrans defaultLimit) def {debugMode = True}) + $ do + msg <- createPure maxBound $ parsedToMsg $ Message $ Message'abort exn + sendMsg (probeTrans defaultLimit) msg + ret `shouldBe` Left (ReceivedAbort exn) + triggerAbort (Message'unimplemented $ Message $ Message'abort def) $ + "Your vat sent an 'unimplemented' message for an abort message " + <> "that its remote peer never sent. This is likely a bug in your " + <> "capnproto library." + triggerAbort + ( Message'call + ( def { target = MessageTarget $ MessageTarget'importedCap 443 - } :: Parsed Call) + } :: + Parsed Call ) - "No such export: 443" - triggerAbort - (Message'call (def - { target = MessageTarget $ - MessageTarget'promisedAnswer (def { questionId=300 } :: Parsed PromisedAnswer) - } :: Parsed Call) + ) + "No such export: 443" + triggerAbort + ( Message'call + ( def + { target = + MessageTarget $ + MessageTarget'promisedAnswer (def {questionId = 300} :: Parsed PromisedAnswer) + } :: + Parsed Call ) - "No such answer: 300" - triggerAbort - (Message'return def { answerId = 234 }) - "No such question: 234" - it "Should respond with an abort if sent junk data" $ do - let wantAbortExn = def - { reason = "Unhandled exception: TraversalLimitError" - , type_ = Exception'Type'failed - } - withTransportPair $ \(vatTrans, probeTrans) -> - concurrently_ - (do - Left (e :: RpcError) <- try $ - handleConn (vatTrans defaultLimit) def { debugMode = True } - e `shouldBe` SentAbort wantAbortExn - ) - (do - let bb = mconcat - [ BB.word32LE 0 -- 1 segment - 1 = 0 - , BB.word32LE 2 -- 2 words in first segment - -- a pair of structs that point to each other: - , BB.word64LE (P.serializePtr (Just (P.StructPtr 0 0 1))) - , BB.word64LE (P.serializePtr (Just (P.StructPtr (-1) 0 1))) - ] - lbs = BB.toLazyByteString bb - msg <- lbsToMsg lbs - sendMsg (probeTrans defaultLimit) msg - msg' <- recvMsg (probeTrans defaultLimit) - resp <- evalLimitT maxBound $ msgToParsed msg' - resp `shouldBe` Message (Message'abort wantAbortExn) - ) - it "Should respond with an abort if erroneously sent return = resultsSentElsewhere" $ - - withTransportPair $ \(vatTrans, probeTrans) -> - let wantExn = eFailed $ - "Received Return.resultsSentElswhere for a call " - <> "with sendResultsTo = caller." - in concurrently_ - (do - Left (e :: RpcError) <- try $ - handleConn (vatTrans defaultLimit) def - { debugMode = True - , withBootstrap = Just $ \_sup client -> - let ctr :: Client CallSequence = fromClient client - in void $ (ctr & callR #getNumber def) >>= waitPipeline - } - e `shouldBe` SentAbort wantExn - ) - (do - let send msg = - evalLimitT maxBound (parsedToMsg msg >>= freeze) - >>= sendMsg (probeTrans defaultLimit) - recv = recvMsg (probeTrans defaultLimit) - >>= evalLimitT maxBound . msgToParsed - Message'bootstrap Bootstrap{} <- recv - Message'call Call{questionId} <- recv - send $ Message'return def - { answerId = questionId - , union' = Return'resultsSentElsewhere + ) + "No such answer: 300" + triggerAbort + (Message'return def {answerId = 234}) + "No such question: 234" + it "Should respond with an abort if sent junk data" $ do + let wantAbortExn = + def + { reason = "Unhandled exception: TraversalLimitError", + type_ = Exception'Type'failed + } + withTransportPair $ \(vatTrans, probeTrans) -> + concurrently_ + ( do + Left (e :: RpcError) <- + try $ + handleConn (vatTrans defaultLimit) def {debugMode = True} + e `shouldBe` SentAbort wantAbortExn + ) + ( do + let bb = + mconcat + [ BB.word32LE 0, -- 1 segment - 1 = 0 + BB.word32LE 2, -- 2 words in first segment + -- a pair of structs that point to each other: + BB.word64LE (P.serializePtr (Just (P.StructPtr 0 0 1))), + BB.word64LE (P.serializePtr (Just (P.StructPtr (-1) 0 1))) + ] + lbs = BB.toLazyByteString bb + msg <- lbsToMsg lbs + sendMsg (probeTrans defaultLimit) msg + msg' <- recvMsg (probeTrans defaultLimit) + resp <- evalLimitT maxBound $ msgToParsed msg' + resp `shouldBe` Message (Message'abort wantAbortExn) + ) + it "Should respond with an abort if erroneously sent return = resultsSentElsewhere" $ + withTransportPair $ \(vatTrans, probeTrans) -> + let wantExn = + eFailed $ + "Received Return.resultsSentElswhere for a call " + <> "with sendResultsTo = caller." + in concurrently_ + ( do + Left (e :: RpcError) <- + try $ + handleConn + (vatTrans defaultLimit) + def + { debugMode = True, + withBootstrap = Just $ \_sup client -> + let ctr :: Client CallSequence = fromClient client + in void $ (ctr & callR #getNumber def) >>= waitPipeline } - msg <- recv - msg `shouldBe` Message'abort wantExn - ) - it "Should reply with unimplemented when sent a join (level 4 only)." $ - withTransportPair $ \(vatTrans, probeTrans) -> - race_ - (handleConn (vatTrans defaultLimit) def { debugMode = True }) - $ do - msg <- createPure maxBound $ parsedToMsg $ Message'join def - sendMsg (probeTrans defaultLimit) msg - msg' <- recvMsg (probeTrans defaultLimit) + e `shouldBe` SentAbort wantExn + ) + ( do + let send msg = + evalLimitT maxBound (parsedToMsg msg >>= freeze) + >>= sendMsg (probeTrans defaultLimit) + recv = + recvMsg (probeTrans defaultLimit) >>= evalLimitT maxBound . msgToParsed - msg' `shouldBe` Message (Message'unimplemented (Message (Message'join def))) - + Message'bootstrap Bootstrap {} <- recv + Message'call Call {questionId} <- recv + send $ + Message'return + def + { answerId = questionId, + union' = Return'resultsSentElsewhere + } + msg <- recv + msg `shouldBe` Message'abort wantExn + ) + it "Should reply with unimplemented when sent a join (level 4 only)." $ + withTransportPair $ \(vatTrans, probeTrans) -> + race_ + (handleConn (vatTrans defaultLimit) def {debugMode = True}) + $ do + msg <- createPure maxBound $ parsedToMsg $ Message'join def + sendMsg (probeTrans defaultLimit) msg + msg' <- + recvMsg (probeTrans defaultLimit) + >>= evalLimitT maxBound . msgToParsed + msg' `shouldBe` Message (Message'unimplemented (Message (Message'join def))) -- | Verify that the given message triggers an abort with the specified 'reason' -- field. triggerAbort :: Parsed (Which Message) -> T.Text -> Spec triggerAbort msg reason = - it ("Should abort when sent the message " ++ show msg ++ " on startup") $ do - let wantAbortExn = def - { reason = reason - , type_ = Exception'Type'failed - } - withTransportPair $ \(vatTrans, probeTrans) -> - concurrently_ - (do - ret <- try $ handleConn (vatTrans defaultLimit) def { debugMode = True } - ret `shouldBe` Left (SentAbort wantAbortExn) - ) - (do - rawMsg <- createPure maxBound $ parsedToMsg msg - sendMsg (probeTrans defaultLimit) rawMsg - -- 4 second timeout. The remote vat's timeout before killing the - -- connection is one second, so if this happens we're never going - -- to receive the message. In theory this is possible, but if it - -- happens something is very wrong. - r <- timeout 4000000 $ recvMsg (probeTrans defaultLimit) - case r of - Nothing -> - error "Test timed out waiting on abort message." - Just rawResp -> do - resp <- evalLimitT maxBound $ msgToParsed rawResp - resp `shouldBe` Message (Message'abort wantAbortExn) - ) + it ("Should abort when sent the message " ++ show msg ++ " on startup") $ do + let wantAbortExn = + def + { reason = reason, + type_ = Exception'Type'failed + } + withTransportPair $ \(vatTrans, probeTrans) -> + concurrently_ + ( do + ret <- try $ handleConn (vatTrans defaultLimit) def {debugMode = True} + ret `shouldBe` Left (SentAbort wantAbortExn) + ) + ( do + rawMsg <- createPure maxBound $ parsedToMsg msg + sendMsg (probeTrans defaultLimit) rawMsg + -- 4 second timeout. The remote vat's timeout before killing the + -- connection is one second, so if this happens we're never going + -- to receive the message. In theory this is possible, but if it + -- happens something is very wrong. + r <- timeout 4000000 $ recvMsg (probeTrans defaultLimit) + case r of + Nothing -> + error "Test timed out waiting on abort message." + Just rawResp -> do + resp <- evalLimitT maxBound $ msgToParsed rawResp + resp `shouldBe` Message (Message'abort wantAbortExn) + ) ------------------------------------------------------------------------------- -- Utilties used by the tests. @@ -460,43 +557,57 @@ withSocketPair :: ((Socket.Socket, Socket.Socket) -> IO a) -> IO a withSocketPair = - bracket - (Socket.socketPair Socket.AF_UNIX Socket.Stream 0) - (\(x, y) -> Socket.close x >> Socket.close y) + bracket + (Socket.socketPair Socket.AF_UNIX Socket.Stream 0) + (\(x, y) -> Socket.close x >> Socket.close y) withTransportPair :: - ( ( WordCount -> Transport - , WordCount -> Transport - ) -> IO a - ) -> IO a + ( ( WordCount -> Transport, + WordCount -> Transport + ) -> + IO a + ) -> + IO a withTransportPair f = - withSocketPair $ \(x, y) -> f (socketTransport x, socketTransport y) + withSocketPair $ \(x, y) -> f (socketTransport x, socketTransport y) -- | @'runVatPair' server client@ runs a pair of vats connected to one another, -- using 'server' as the 'offerBootstrap' field in the one vat's config, and -- 'client' as the 'withBootstrap' field in the other's. runVatPair :: IsClient c => (Supervisor -> STM c) -> (Supervisor -> c -> IO ()) -> IO () runVatPair getBootstrap withBootstrap = withTransportPair $ \(clientTrans, serverTrans) -> do - let runClient = handleConn (clientTrans defaultLimit) def - { debugMode = True - , withBootstrap = Just $ \sup -> withBootstrap sup . fromClient + let runClient = + handleConn + (clientTrans defaultLimit) + def + { debugMode = True, + withBootstrap = Just $ \sup -> withBootstrap sup . fromClient } - runServer = handleConn (serverTrans defaultLimit) def - { debugMode = True - , getBootstrap = fmap (Just . toClient) . getBootstrap + runServer = + handleConn + (serverTrans defaultLimit) + def + { debugMode = True, + getBootstrap = fmap (Just . toClient) . getBootstrap } - race_ runServer runClient + race_ runServer runClient -expectException - :: ( IsCap c, TypeParam a, Parse a pa, Show pa - , R.ReprFor a ~ 'R.Ptr pr - ) - => (Client c -> IO (Pipeline a)) -> Parsed Exception -> Client c -> IO () +expectException :: + ( IsCap c, + TypeParam a, + Parse a pa, + Show pa, + R.ReprFor a ~ 'R.Ptr pr + ) => + (Client c -> IO (Pipeline a)) -> + Parsed Exception -> + Client c -> + IO () expectException callFn wantExn cap = do - ret <- try $ callFn cap >>= waitPipeline - case ret of - Left (e :: Parsed Exception) -> - liftIO $ e `shouldBe` wantExn - Right val -> do - parsed <- evalLimitT defaultLimit (parse val) - error $ "Should have received exn, but got " ++ show parsed + ret <- try $ callFn cap >>= waitPipeline + case ret of + Left (e :: Parsed Exception) -> + liftIO $ e `shouldBe` wantExn + Right val -> do + parsed <- evalLimitT defaultLimit (parse val) + error $ "Should have received exn, but got " ++ show parsed diff --git a/tests/Module/Capnp/Untyped.hs b/tests/Module/Capnp/Untyped.hs --- a/tests/Module/Capnp/Untyped.hs +++ b/tests/Module/Capnp/Untyped.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} -- The tests have a number of cases where we do stuff like: -- -- let 4 = ... @@ -15,56 +15,55 @@ -- Letting pattern-match failure fail the test. GHC warns about this, -- let's shut off that warning: {-# OPTIONS_GHC -Wno-unused-pattern-binds #-} -module Module.Capnp.Untyped (untypedTests) where -import Prelude hiding (length) - -import Test.Hspec - -import Data.Word +module Module.Capnp.Untyped (untypedTests) where -import Control.Monad (forM_, when) +import Capnp + ( createPure, + def, + encode, + msgToParsed, + newRoot, + setField, + ) +import Capnp.Gen.Capnp.Schema +import qualified Capnp.Message as M +import Capnp.Mutability (freeze, thaw) +import qualified Capnp.Repr as R +import Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT) +import Capnp.Untyped +import Control.Monad (forM_, when) import Control.Monad.Primitive (RealWorld) -import Data.Foldable (traverse_) -import Data.Function ((&)) -import Data.Text (Text) -import GHC.Float (castDoubleToWord64, castWord64ToDouble) -import Test.QuickCheck (property) -import Test.QuickCheck.IO (propertyIO) -import Text.Heredoc (here) - import qualified Data.ByteString as BS -import qualified Data.Vector as V - -import Capnp.Untyped -import Util - -import Capnp.Mutability (freeze, thaw) -import Capnp.New - (createPure, def, encode, msgToParsed, newRoot, setField) -import Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT) - +import Data.Foldable (traverse_) +import Data.Function ((&)) +import Data.Text (Text) +import qualified Data.Vector as V +import Data.Word +import GHC.Float (castDoubleToWord64, castWord64ToDouble) import Instances () - -import Capnp.Gen.Capnp.Schema.New - -import qualified Capnp.Message as M -import qualified Capnp.Repr as R +import Test.Hspec +import Test.QuickCheck (property) +import Test.QuickCheck.IO (propertyIO) +import Text.Heredoc (here) +import Util +import Prelude hiding (length) untypedTests :: Spec untypedTests = describe "low-level untyped API tests" $ do - readTests - modifyTests - farPtrTest - otherMessageTest + readTests + modifyTests + farPtrTest + otherMessageTest readTests :: Spec readTests = describe "read tests" $ - it "Should agree with `capnp decode`" $ do - msg <- encodeValue - aircraftSchemaSrc - "Aircraft" - [here|(f16 = (base = ( + it "Should agree with `capnp decode`" $ do + msg <- + encodeValue + aircraftSchemaSrc + "Aircraft" + [here|(f16 = (base = ( name = "bob", homes = [], rating = 7, @@ -72,286 +71,292 @@ capacity = 5173, maxSpeed = 12.0 )))|] - endQuota <- execLimitT 128 $ do - root <- rootPtr msg - -- Aircraft just has the union tag, nothing else in it's data - -- section. - let 1 = structWordCount root - 3 <- getData 0 root -- tag for F16 - let 1 = structPtrCount root - Just (PtrStruct f16) <- getPtr 0 root - let 0 = structWordCount f16 - let 0 = structByteCount f16 - let 1 = structPtrCount f16 - Just (PtrStruct base) <- getPtr 0 f16 - let 4 = structWordCount base -- Except canFly, each field is 1 word, and - -- canFly is aligned such that it ends up - -- consuming a whole word. - let 32 = structByteCount base -- 32 = 4 * 8 - let 2 = structPtrCount base -- name, homes + endQuota <- execLimitT 128 $ do + root <- rootPtr msg + -- Aircraft just has the union tag, nothing else in it's data + -- section. + let 1 = structWordCount root + 3 <- getData 0 root -- tag for F16 + let 1 = structPtrCount root + Just (PtrStruct f16) <- getPtr 0 root + let 0 = structWordCount f16 + let 0 = structByteCount f16 + let 1 = structPtrCount f16 + Just (PtrStruct base) <- getPtr 0 f16 + let 4 = structWordCount base -- Except canFly, each field is 1 word, and + -- canFly is aligned such that it ends up + -- consuming a whole word. + let 32 = structByteCount base -- 32 = 4 * 8 + let 2 = structPtrCount base -- name, homes - -- Walk the data section: - 7 <- getData 0 base -- rating - 1 <- getData 1 base -- canFly - 5173 <- getData 2 base -- capacity - 12.0 <- castWord64ToDouble <$> getData 3 base + -- Walk the data section: + 7 <- getData 0 base -- rating + 1 <- getData 1 base -- canFly + 5173 <- getData 2 base -- capacity + 12.0 <- castWord64ToDouble <$> getData 3 base - -- ...and the pointer section: - Just (PtrList (List8 name)) <- getPtr 0 base - -- Text values have a NUL terminator, which is included in the - -- length on the wire. The spec says that this shouldn't be - -- included in the length reported to the caller, but that needs - -- to be dealt with by schema-aware code, so this is the length of - -- "bob\0" - let 4 = length name + -- ...and the pointer section: + Just (PtrList (List8 name)) <- getPtr 0 base + -- Text values have a NUL terminator, which is included in the + -- length on the wire. The spec says that this shouldn't be + -- included in the length reported to the caller, but that needs + -- to be dealt with by schema-aware code, so this is the length of + -- "bob\0" + let 4 = length name - forM_ (zip [0..3] (BS.unpack "bob\0")) $ \(i, c) -> do - c' <- index i name - when (c /= c') $ - error ("index " ++ show i ++ ": " ++ show c ++ " /= " ++ show c') - Just (PtrList (List16 homes)) <- getPtr 1 base - let 0 = length homes - return () - endQuota `shouldBe` 117 + forM_ (zip [0 .. 3] (BS.unpack "bob\0")) $ \(i, c) -> do + c' <- index i name + when (c /= c') $ + error ("index " ++ show i ++ ": " ++ show c ++ " /= " ++ show c') + Just (PtrList (List16 homes)) <- getPtr 1 base + let 0 = length homes + return () + endQuota `shouldBe` 117 data ModTest = ModTest - { testIn :: String - , testMod :: Struct ('M.Mut RealWorld) -> LimitT IO () - , testOut :: String - , testType :: String - } + { testIn :: String, + testMod :: Struct ('M.Mut RealWorld) -> LimitT IO (), + testOut :: String, + testType :: String + } modifyTests :: Spec -modifyTests = describe "modification tests" $ traverse_ testCase - -- tests for setIndex - [ ModTest - { testIn = "(year = 2018, month = 6, day = 20)\n" - , testType = "Zdate" - , testOut = "(year = 0, month = 0, day = 0)\n" - , testMod = setData 0 0 - } - , ModTest - { testIn = "(text = \"Hello, World!\")\n" - , testType = "Z" - , testOut = "(text = \"hEllo, world!\")\n" - , testMod = \struct -> do - Just (PtrList (List8 list)) <- getPtr 0 struct - setIndex (fromIntegral (fromEnum 'h')) 0 list - setIndex (fromIntegral (fromEnum 'E')) 1 list - setIndex (fromIntegral (fromEnum 'w')) 7 list - } - , ModTest - { testIn = "(boolvec = [true, true, false, true])\n" - , testType = "Z" - , testOut = "( boolvec = [false, true, true, false] )\n" - , testMod = \struct -> do - Just (PtrList (List1 list)) <- getPtr 0 struct - setIndex False 0 list - setIndex True 2 list - setIndex False 3 list - } - , ModTest - { testIn = "(f64 = 2.0)\n" - , testType = "Z" - , testOut = "(f64 = 7.2)\n" - , testMod = setData (castDoubleToWord64 7.2) 1 - } - , ModTest - { testIn = unlines - [ "( size = 4," - , " words = \"Hello, World!\"," - , " wordlist = [\"apples\", \"oranges\"] )" - ] - , testType = "Counter" - , testOut = unlines - [ "( size = 4," - , " words = \"oranges\"," - , " wordlist = [\"apples\", \"Hello, World!\"] )" - ] - , testMod = \struct -> do - Just (PtrList (ListPtr list)) <- getPtr 1 struct - helloWorld <- getPtr 0 struct - oranges <- index 1 list - setPtr oranges 0 struct - setIndex helloWorld 1 list - } - , ModTest - { testIn = unlines - [ "( aircraftvec = [" - , " ( f16 = (" - , " base = (" - , " name = \"alice\"," - , " homes = []," - , " rating = 7," - , " canFly = true," - , " capacity = 4," - , " maxSpeed = 100 ) ) )," - , " ( b737 = (" - , " base = (" - , " name = \"bob\"," - , " homes = []," - , " rating = 2," - , " canFly = false," - , " capacity = 9," - , " maxSpeed = 50 ) ) ) ] )" - ] - , testType = "Z" - , testOut = unlines - [ "( aircraftvec = [" - , " ( f16 = (" - , " base = (" - , " name = \"alice\"," - , " homes = []," - , " rating = 7," - , " canFly = true," - , " capacity = 4," - , " maxSpeed = 100 ) ) )," - , " ( f16 = (" - , " base = (" - , " name = \"alice\"," - , " homes = []," - , " rating = 7," - , " canFly = true," - , " capacity = 4," - , " maxSpeed = 100 ) ) ) ] )" - ] - , testMod = \struct -> do - Just (PtrList (ListStruct list)) <- getPtr 0 struct - src <- index 0 list - setIndex src 1 list - } - -- tests for allocation functions - , ModTest - { testIn = "()" - , testType = "StackingRoot" - , testOut = "( aWithDefault = (num = 6400),\n a = (num = 65, b = (num = 90000)) )\n" - - , testMod = \struct -> do - when (structPtrCount struct /= 2) $ +modifyTests = + describe "modification tests" $ + traverse_ + testCase + -- tests for setIndex + [ ModTest + { testIn = "(year = 2018, month = 6, day = 20)\n", + testType = "Zdate", + testOut = "(year = 0, month = 0, day = 0)\n", + testMod = setData 0 0 + }, + ModTest + { testIn = "(text = \"Hello, World!\")\n", + testType = "Z", + testOut = "(text = \"hEllo, world!\")\n", + testMod = \struct -> do + Just (PtrList (List8 list)) <- getPtr 0 struct + setIndex (fromIntegral (fromEnum 'h')) 0 list + setIndex (fromIntegral (fromEnum 'E')) 1 list + setIndex (fromIntegral (fromEnum 'w')) 7 list + }, + ModTest + { testIn = "(boolvec = [true, true, false, true])\n", + testType = "Z", + testOut = "( boolvec = [false, true, true, false] )\n", + testMod = \struct -> do + Just (PtrList (List1 list)) <- getPtr 0 struct + setIndex False 0 list + setIndex True 2 list + setIndex False 3 list + }, + ModTest + { testIn = "(f64 = 2.0)\n", + testType = "Z", + testOut = "(f64 = 7.2)\n", + testMod = setData (castDoubleToWord64 7.2) 1 + }, + ModTest + { testIn = + unlines + [ "( size = 4,", + " words = \"Hello, World!\",", + " wordlist = [\"apples\", \"oranges\"] )" + ], + testType = "Counter", + testOut = + unlines + [ "( size = 4,", + " words = \"oranges\",", + " wordlist = [\"apples\", \"Hello, World!\"] )" + ], + testMod = \struct -> do + Just (PtrList (ListPtr list)) <- getPtr 1 struct + helloWorld <- getPtr 0 struct + oranges <- index 1 list + setPtr oranges 0 struct + setIndex helloWorld 1 list + }, + ModTest + { testIn = + unlines + [ "( aircraftvec = [", + " ( f16 = (", + " base = (", + " name = \"alice\",", + " homes = [],", + " rating = 7,", + " canFly = true,", + " capacity = 4,", + " maxSpeed = 100 ) ) ),", + " ( b737 = (", + " base = (", + " name = \"bob\",", + " homes = [],", + " rating = 2,", + " canFly = false,", + " capacity = 9,", + " maxSpeed = 50 ) ) ) ] )" + ], + testType = "Z", + testOut = + unlines + [ "( aircraftvec = [", + " ( f16 = (", + " base = (", + " name = \"alice\",", + " homes = [],", + " rating = 7,", + " canFly = true,", + " capacity = 4,", + " maxSpeed = 100 ) ) ),", + " ( f16 = (", + " base = (", + " name = \"alice\",", + " homes = [],", + " rating = 7,", + " canFly = true,", + " capacity = 4,", + " maxSpeed = 100 ) ) ) ] )" + ], + testMod = \struct -> do + Just (PtrList (ListStruct list)) <- getPtr 0 struct + src <- index 0 list + setIndex src 1 list + }, + -- tests for allocation functions + ModTest + { testIn = "()", + testType = "StackingRoot", + testOut = "( aWithDefault = (num = 6400),\n a = (num = 65, b = (num = 90000)) )\n", + testMod = \struct -> do + when (structPtrCount struct /= 2) $ error "struct's pointer section is unexpedly small" - let msg = message @Struct struct - a <- allocStruct msg 1 1 - aWithDefault <- allocStruct msg 1 1 - b <- allocStruct msg 1 0 - setPtr (Just (PtrStruct b)) 0 a - setPtr (Just (PtrStruct aWithDefault)) 0 struct - setPtr (Just (PtrStruct a)) 1 struct - setData 65 0 a - setData 6400 0 aWithDefault - setData 90000 0 b - } - , ModTest - { testIn = "()" - , testType = "HoldsVerTwoTwoList" - , testOut = "( mylist = [(val = 0, duo = 70), (val = 0, duo = 71), (val = 0, duo = 72), (val = 0, duo = 73)] )\n" - , testMod = \struct -> do - mylist <- allocCompositeList (message @Struct struct) 2 2 4 - forM_ [0..3] $ \i -> + let msg = message @Struct struct + a <- allocStruct msg 1 1 + aWithDefault <- allocStruct msg 1 1 + b <- allocStruct msg 1 0 + setPtr (Just (PtrStruct b)) 0 a + setPtr (Just (PtrStruct aWithDefault)) 0 struct + setPtr (Just (PtrStruct a)) 1 struct + setData 65 0 a + setData 6400 0 aWithDefault + setData 90000 0 b + }, + ModTest + { testIn = "()", + testType = "HoldsVerTwoTwoList", + testOut = "( mylist = [(val = 0, duo = 70), (val = 0, duo = 71), (val = 0, duo = 72), (val = 0, duo = 73)] )\n", + testMod = \struct -> do + mylist <- allocCompositeList (message @Struct struct) 2 2 4 + forM_ [0 .. 3] $ \i -> index i mylist >>= setData (70 + fromIntegral i) 1 - setPtr (Just $ PtrList $ ListStruct mylist) 0 struct - } - , allocNormalListTest "u64vec" 21 allocList64 List64 - , allocNormalListTest "u32vec" 22 allocList32 List32 - , allocNormalListTest "u16vec" 23 allocList16 List16 - , allocNormalListTest "u8vec" 24 allocList8 List8 - , ModTest - { testIn = "()" - , testType = "Z" - , testOut = "( boolvec = [true, false, true] )\n" - , testMod = \struct -> do - setData 39 0 struct -- Set the union tag. - boolvec <- allocList1 (message @Struct struct) 3 - forM_ [0..2] $ \i -> + setPtr (Just $ PtrList $ ListStruct mylist) 0 struct + }, + allocNormalListTest "u64vec" 21 allocList64 List64, + allocNormalListTest "u32vec" 22 allocList32 List32, + allocNormalListTest "u16vec" 23 allocList16 List16, + allocNormalListTest "u8vec" 24 allocList8 List8, + ModTest + { testIn = "()", + testType = "Z", + testOut = "( boolvec = [true, false, true] )\n", + testMod = \struct -> do + setData 39 0 struct -- Set the union tag. + boolvec <- allocList1 (message @Struct struct) 3 + forM_ [0 .. 2] $ \i -> setIndex (even i) i boolvec - setPtr (Just $ PtrList $ List1 boolvec) 0 struct - } - ] + setPtr (Just $ PtrList $ List1 boolvec) 0 struct + } + ] where -- generate a ModTest for a (normal) list allocation function. -- -- parameters: -- - -- * tagname - the name of the union variant - -- * tagvalue - the numeric value of the tag for this variant - -- * allocList - the allocation function - -- * dataCon - the data constructor for 'List' to use. + -- \* tagname - the name of the union variant + -- \* tagvalue - the numeric value of the tag for this variant + -- \* allocList - the allocation function + -- \* dataCon - the data constructor for 'List' to use. -- - allocNormalListTest - :: (ListItem ('Data sz), Num (UntypedData sz)) - => String - -> Word64 - -> (M.Message ('M.Mut RealWorld) -> Int -> LimitT IO (ListOf ('Data sz) ('M.Mut RealWorld))) - -> (ListOf ('Data sz) ('M.Mut RealWorld) -> List ('M.Mut RealWorld)) - -> ModTest + allocNormalListTest :: + (ListItem ('Data sz), Num (UntypedData sz)) => + String -> + Word64 -> + (M.Message ('M.Mut RealWorld) -> Int -> LimitT IO (ListOf ('Data sz) ('M.Mut RealWorld))) -> + (ListOf ('Data sz) ('M.Mut RealWorld) -> List ('M.Mut RealWorld)) -> + ModTest allocNormalListTest tagname tagvalue allocList dataCon = - ModTest - { testIn = "()" - , testType = "Z" - , testOut = "(" ++ tagname ++ " = [0, 1, 2, 3, 4])\n" - , testMod = \struct -> do - setData tagvalue 0 struct - vec <- allocList (message @Struct struct) 5 - forM_ [0..4] $ \i -> setIndex (fromIntegral i) i vec - setPtr (Just $ PtrList $ dataCon vec) 0 struct - } - testCase ModTest{..} = - it ("Should satisfy: " ++ show testIn ++ " : " ++ testType ++ " == " ++ show testOut) $ do - msg <- thaw =<< encodeValue aircraftSchemaSrc testType testIn - evalLimitT 128 $ rootPtr msg >>= testMod - actualOut <- decodeValue aircraftSchemaSrc testType =<< freeze msg - actualOut `shouldBe` testOut - + ModTest + { testIn = "()", + testType = "Z", + testOut = "(" ++ tagname ++ " = [0, 1, 2, 3, 4])\n", + testMod = \struct -> do + setData tagvalue 0 struct + vec <- allocList (message @Struct struct) 5 + forM_ [0 .. 4] $ \i -> setIndex (fromIntegral i) i vec + setPtr (Just $ PtrList $ dataCon vec) 0 struct + } + testCase ModTest {..} = + it ("Should satisfy: " ++ show testIn ++ " : " ++ testType ++ " == " ++ show testOut) $ do + msg <- thaw =<< encodeValue aircraftSchemaSrc testType testIn + evalLimitT 128 $ rootPtr msg >>= testMod + actualOut <- decodeValue aircraftSchemaSrc testType =<< freeze msg + actualOut `shouldBe` testOut farPtrTest :: Spec farPtrTest = describe "Setting cross-segment pointers shouldn't crash" $ do - -- I(zenhack) am disappointed in hindsight that we only check for crashes - -- here; we should make these more thorough, actually checking validity - -- somehow. - it "Should work when setting the root pointer" $ do - pure () :: IO () -- Not sure why ghc needs this hint, but it does. - msg <- M.newMessage Nothing - -- The allocator always allocates new objects in the last segment, so - -- if we create a new segment, the call to allocStruct below should - -- allocate there: - (1, _) <- M.newSegment msg 16 - struct <- allocStruct msg 3 4 - setRoot struct :: IO () - it "Should work when setting a field in a struct" $ do - pure () :: IO () -- Not sure why ghc needs this hint, but it does. - evalLimitT maxBound $ do - msg <- M.newMessage Nothing - srcStruct <- allocStruct msg 4 4 - (1, _) <- M.newSegment msg 10 - dstStruct <- allocStruct msg 2 2 - let ptr = R.toPtr @('Just 'R.Struct) dstStruct - setPtr ptr 0 srcStruct + -- I(zenhack) am disappointed in hindsight that we only check for crashes + -- here; we should make these more thorough, actually checking validity + -- somehow. + it "Should work when setting the root pointer" $ do + pure () :: IO () -- Not sure why ghc needs this hint, but it does. + msg <- M.newMessage Nothing + -- The allocator always allocates new objects in the last segment, so + -- if we create a new segment, the call to allocStruct below should + -- allocate there: + (1, _) <- M.newSegment msg 16 + struct <- allocStruct msg 3 4 + setRoot struct :: IO () + it "Should work when setting a field in a struct" $ do + pure () :: IO () -- Not sure why ghc needs this hint, but it does. + evalLimitT maxBound $ do + msg <- M.newMessage Nothing + srcStruct <- allocStruct msg 4 4 + (1, _) <- M.newSegment msg 10 + dstStruct <- allocStruct msg 2 2 + let ptr = R.toPtr @('Just 'R.Struct) dstStruct + setPtr ptr 0 srcStruct otherMessageTest :: Spec otherMessageTest = describe "Setting pointers in other messages" $ - it "Should copy them if needed." $ - property $ \(name :: Text) (params :: V.Vector (Parsed Node'Parameter)) (brand :: Parsed Brand) -> - propertyIO $ do - let expected = def - { name = name - , implicitParameters = params - , paramBrand = brand - } - msg :: M.Message 'M.Const <- createPure maxBound $ do - methodMsg <- M.newMessage Nothing - nameMsg <- M.newMessage Nothing - paramsMsg <- M.newMessage Nothing - brandMsg <- M.newMessage Nothing + it "Should copy them if needed." $ + property $ \(name :: Text) (params :: V.Vector (Parsed Node'Parameter)) (brand :: Parsed Brand) -> + propertyIO $ do + let expected = + def + { name = name, + implicitParameters = params, + paramBrand = brand + } + msg :: M.Message 'M.Const <- createPure maxBound $ do + methodMsg <- M.newMessage Nothing + nameMsg <- M.newMessage Nothing + paramsMsg <- M.newMessage Nothing + brandMsg <- M.newMessage Nothing - methodCerial <- newRoot @Method () methodMsg - nameCerial <- encode nameMsg name - brandCerial <- encode brandMsg brand - paramsCerial <- encode paramsMsg params + methodCerial <- newRoot @Method () methodMsg + nameCerial <- encode nameMsg name + brandCerial <- encode brandMsg brand + paramsCerial <- encode paramsMsg params - methodCerial & setField #name nameCerial - methodCerial & setField #implicitParameters paramsCerial - methodCerial & setField #paramBrand brandCerial + methodCerial & setField #name nameCerial + methodCerial & setField #implicitParameters paramsCerial + methodCerial & setField #paramBrand brandCerial - pure methodMsg - actual <- evalLimitT maxBound $ msgToParsed msg - actual `shouldBe` expected + pure methodMsg + actual <- evalLimitT maxBound $ msgToParsed msg + actual `shouldBe` expected diff --git a/tests/Module/Capnp/Untyped/Pure.hs b/tests/Module/Capnp/Untyped/Pure.hs --- a/tests/Module/Capnp/Untyped/Pure.hs +++ b/tests/Module/Capnp/Untyped/Pure.hs @@ -1,32 +1,32 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE QuasiQuotes #-} + +-- TODO(cleanup): the raw/pure split no longer exists, so this module path doesn't +-- make a lot of sense anymore; reorganize. module Module.Capnp.Untyped.Pure (pureUntypedTests) where +import Capnp (msgToRaw, parse) +import Capnp.Basics +import Capnp.TraversalLimit (runLimitT) +import qualified Data.Vector as V +import GHC.Float (castDoubleToWord64) import Test.Hspec - -import GHC.Float (castDoubleToWord64) import Text.Heredoc (here) - -import qualified Data.Vector as V - -import Capnp.New.Basics import Util -import Capnp.New (msgToRaw, parse) -import Capnp.TraversalLimit (runLimitT) - -- This is analogous to Tests.Module.Capnp.Untyped.untypedTests, but -- using the Pure module: pureUntypedTests :: Spec pureUntypedTests = - describe "high-level untyped decoding" $ - it "Should agree with `capnp decode`" $ do - msg <- encodeValue - aircraftSchemaSrc - "Aircraft" - [here|(f16 = (base = ( + describe "high-level untyped decoding" $ + it "Should agree with `capnp decode`" $ do + msg <- + encodeValue + aircraftSchemaSrc + "Aircraft" + [here|(f16 = (base = ( name = "bob", homes = [], rating = 7, @@ -34,19 +34,24 @@ capacity = 5173, maxSpeed = 12.0 )))|] - (actual, 117) <- runLimitT 128 $ msgToRaw msg >>= parse - actual `shouldBe` Struct - [3] - [ Just $ PtrStruct $ Struct - [] - [ Just $ PtrStruct $ Struct - [ 7 - , 1 - , 5173 - , castDoubleToWord64 12.0 - ] - [ Just $ PtrList $ List8 $ V.fromList $ map (fromIntegral . fromEnum) "bob\0" - , Just $ PtrList $ List16 [] - ] - ] - ] + (actual, 117) <- runLimitT 128 $ msgToRaw msg >>= parse + actual + `shouldBe` Struct + [3] + [ Just $ + PtrStruct $ + Struct + [] + [ Just $ + PtrStruct $ + Struct + [ 7, + 1, + 5173, + castDoubleToWord64 12.0 + ] + [ Just $ PtrList $ List8 $ V.fromList $ map (fromIntegral . fromEnum) "bob\0", + Just $ PtrList $ List16 [] + ] + ] + ] diff --git a/tests/PointerOOB.hs b/tests/PointerOOB.hs --- a/tests/PointerOOB.hs +++ b/tests/PointerOOB.hs @@ -1,68 +1,66 @@ {-# LANGUAGE DataKinds #-} -module PointerOOB (tests) where -import Test.Hspec - -import Control.Category ((>>>)) -import Control.Exception.Safe (try) -import Control.Monad.IO.Class (MonadIO(liftIO)) -import Data.Foldable (for_) -import Data.Function ((&)) +module PointerOOB (tests) where -import qualified Capnp.Errors as E +import qualified Capnp as Capnp +import qualified Capnp.Errors as E import qualified Capnp.Message as M -import qualified Capnp.New as Capnp import qualified Capnp.Pointer as P import qualified Capnp.Untyped as U - -import qualified Data.ByteString as BS +import Control.Category ((>>>)) +import Control.Exception.Safe (try) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy as LBS +import Data.Foldable (for_) +import Data.Function ((&)) +import Test.Hspec errPtrs :: [(P.Ptr, E.Error)] errPtrs = - [ ( P.ListPtr 0 (P.EltNormal P.Sz1 1) - , E.BoundsError { E.index = 2, E.maxIndex = 1 } - ) - , ( P.ListPtr 0 (P.EltNormal P.Sz32 4) - , E.BoundsError { E.index = 3, E.maxIndex = 1 } - ) - , ( P.ListPtr (-3) (P.EltNormal P.Sz1 1) - , E.BoundsError { E.index = -1, E.maxIndex = 1 } - ) - , ( P.ListPtr (-4) (P.EltNormal P.Sz1 1) - , E.BoundsError { E.index = -2, E.maxIndex = 1 } - ) - , ( P.StructPtr 0 1 0 - , E.BoundsError { E.index = 2, E.maxIndex = 1 } - ) - , ( P.StructPtr 0 0 1 - , E.BoundsError { E.index = 2, E.maxIndex = 1 } - ) - , ( P.StructPtr 0 1 1 - , E.BoundsError { E.index = 3, E.maxIndex = 1 } - ) - ] + [ ( P.ListPtr 0 (P.EltNormal P.Sz1 1), + E.BoundsError {E.index = 2, E.maxIndex = 1} + ), + ( P.ListPtr 0 (P.EltNormal P.Sz32 4), + E.BoundsError {E.index = 3, E.maxIndex = 1} + ), + ( P.ListPtr (-3) (P.EltNormal P.Sz1 1), + E.BoundsError {E.index = -1, E.maxIndex = 1} + ), + ( P.ListPtr (-4) (P.EltNormal P.Sz1 1), + E.BoundsError {E.index = -2, E.maxIndex = 1} + ), + ( P.StructPtr 0 1 0, + E.BoundsError {E.index = 2, E.maxIndex = 1} + ), + ( P.StructPtr 0 0 1, + E.BoundsError {E.index = 2, E.maxIndex = 1} + ), + ( P.StructPtr 0 1 1, + E.BoundsError {E.index = 3, E.maxIndex = 1} + ) + ] wrapPtr :: P.Ptr -> BS.ByteString wrapPtr p = - [ Just (P.StructPtr 0 0 1), Just p ] - & map (P.serializePtr >>> BB.word64LE) - & mconcat - & BB.toLazyByteString - & LBS.toStrict + [Just (P.StructPtr 0 0 1), Just p] + & map (P.serializePtr >>> BB.word64LE) + & mconcat + & BB.toLazyByteString + & LBS.toStrict tests :: Spec tests = describe "Test correct handling of out of bound pointers" $ do - describe "pointers that go off the end of the message" $ do - for_ errPtrs $ \(p, err) -> do - it ("Should catch the issue for " <> show p) $ do - let testPtrBounds :: P.Ptr -> Capnp.LimitT IO () - testPtrBounds p = do - let msg = M.singleSegment $ Capnp.fromByteString (wrapPtr p) - root <- U.rootPtr msg - v <- try $ U.getPtr 0 root - case v of - Right _ -> fail "should have signaled an error" - Left e -> liftIO $ e `shouldBe` err - Capnp.evalLimitT maxBound (testPtrBounds p) + describe "pointers that go off the end of the message" $ do + for_ errPtrs $ \(p, err) -> do + it ("Should catch the issue for " <> show p) $ do + let testPtrBounds :: P.Ptr -> Capnp.LimitT IO () + testPtrBounds p = do + let msg = M.singleSegment $ Capnp.fromByteString (wrapPtr p) + root <- U.rootPtr msg + v <- try $ U.getPtr 0 root + case v of + Right _ -> fail "should have signaled an error" + Left e -> liftIO $ e `shouldBe` err + Capnp.evalLimitT maxBound (testPtrBounds p) diff --git a/tests/Regression.hs b/tests/Regression.hs --- a/tests/Regression.hs +++ b/tests/Regression.hs @@ -1,38 +1,41 @@ {-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + module Regression (regressionTests) where +import Capnp (bsToParsed, def, evalLimitT) +import Capnp.Gen.Aircraft +import Capnp.Gen.Capnp.Rpc import Test.Hspec -import Capnp.New (bsToParsed, def, evalLimitT) - -import Capnp.Gen.Aircraft.New -import Capnp.Gen.Capnp.Rpc.New - regressionTests :: Spec regressionTests = describe "Regression tests" $ do - it "Should decode abort message successfully (issue #56)" $ do - let bytes = - "\NUL\NUL\NUL\NUL\ETB\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL" <> - "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL" <> - "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL" <> - "\NUL\NULz\EOT\NUL\NULYour vat sent an 'unimplemented' " <> - "message for an abort message that its remote peer never " <> - "sent. This is likely a bug in your capnproto library.\NUL\NUL" - msg <- evalLimitT maxBound $ bsToParsed bytes - msg `shouldBe` Message (Message'abort def - { reason = - "Your vat sent an 'unimplemented' message for an abort " <> - "message that its remote peer never sent. This is likely " <> - "a bug in your capnproto library." - , type_ = Exception'Type'failed - }) - it "Should decode negative default values correctly (issue #55)" $ do - -- Note that this was never actually broken, but we were getting - -- a warning about a literal overflowing the bounds of its type. - -- It worked anyway, since it became the right value after casting, - -- but the warning has been fixed and this test makes sure it still - -- actually works. - let Defaults{int} = def - int `shouldBe` (-123) + it "Should decode abort message successfully (issue #56)" $ do + let bytes = + "\NUL\NUL\NUL\NUL\ETB\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL" + <> "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL" + <> "\SOH\NUL\SOH\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\NUL\SOH\NUL" + <> "\NUL\NULz\EOT\NUL\NULYour vat sent an 'unimplemented' " + <> "message for an abort message that its remote peer never " + <> "sent. This is likely a bug in your capnproto library.\NUL\NUL" + msg <- evalLimitT maxBound $ bsToParsed bytes + msg + `shouldBe` Message + ( Message'abort + def + { reason = + "Your vat sent an 'unimplemented' message for an abort " + <> "message that its remote peer never sent. This is likely " + <> "a bug in your capnproto library.", + type_ = Exception'Type'failed + } + ) + it "Should decode negative default values correctly (issue #55)" $ do + -- Note that this was never actually broken, but we were getting + -- a warning about a literal overflowing the bounds of its type. + -- It worked anyway, since it became the right value after casting, + -- but the warning has been fixed and this test makes sure it still + -- actually works. + let Defaults {int} = def + int `shouldBe` (-123) diff --git a/tests/Rpc/Unwrap.hs b/tests/Rpc/Unwrap.hs --- a/tests/Rpc/Unwrap.hs +++ b/tests/Rpc/Unwrap.hs @@ -1,52 +1,52 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module Rpc.Unwrap (unwrapTests) where - -import Test.Hspec +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -import qualified Data.Typeable as Typeable +module Rpc.Unwrap (unwrapTests) where +import Capnp + ( SomeServer (..), + export, + methodUnimplemented, + ) +import qualified Capnp.Gen.Aircraft as Aircraft +import qualified Capnp.Rpc as Rpc import Data.Typeable (Typeable) - -import qualified Capnp.Gen.Aircraft.New as Aircraft -import Capnp.New - (SomeServer(..), export, methodUnimplemented) -import qualified Capnp.Rpc as Rpc +import qualified Data.Typeable as Typeable import qualified Supervisors +import Test.Hspec data OpaqueEcho = OpaqueEcho - deriving(Show, Read, Eq, Ord, Enum, Bounded) + deriving (Show, Read, Eq, Ord, Enum, Bounded) instance SomeServer OpaqueEcho instance Aircraft.Echo'server_ OpaqueEcho where - echo'echo _ = methodUnimplemented + echo'echo _ = methodUnimplemented newtype TransparentEcho = TransparentEcho Int - deriving(Show, Read, Eq, Ord, Bounded, Typeable) + deriving (Show, Read, Eq, Ord, Bounded, Typeable) instance SomeServer TransparentEcho where - unwrap = Typeable.cast + unwrap = Typeable.cast instance Aircraft.Echo'server_ TransparentEcho where - echo'echo _ = methodUnimplemented - + echo'echo _ = methodUnimplemented unwrapTests :: Spec unwrapTests = describe "Tests for client unwrapping" $ do - it "Should return nothing for OpaqueEcho." $ do - r :: Maybe OpaqueEcho <- exportAndUnwrap OpaqueEcho - r `shouldBe` Nothing - it "Should return nothing for the wrong type." $ do - r :: Maybe () <- exportAndUnwrap (TransparentEcho 4) - r `shouldBe` Nothing - it "Should return the value for TransparentEcho." $ do - r <- exportAndUnwrap (TransparentEcho 4) - r `shouldBe` Just (TransparentEcho 4) + it "Should return nothing for OpaqueEcho." $ do + r :: Maybe OpaqueEcho <- exportAndUnwrap OpaqueEcho + r `shouldBe` Nothing + it "Should return nothing for the wrong type." $ do + r :: Maybe () <- exportAndUnwrap (TransparentEcho 4) + r `shouldBe` Nothing + it "Should return the value for TransparentEcho." $ do + r <- exportAndUnwrap (TransparentEcho 4) + r `shouldBe` Just (TransparentEcho 4) exportAndUnwrap :: (SomeServer a, Aircraft.Echo'server_ a, Typeable b) => a -> IO (Maybe b) exportAndUnwrap srv = Supervisors.withSupervisor $ \sup -> do - client <- export @Aircraft.Echo sup srv - pure $ Rpc.unwrapServer client + client <- export @Aircraft.Echo sup srv + pure $ Rpc.unwrapServer client diff --git a/tests/SchemaGeneration.hs b/tests/SchemaGeneration.hs --- a/tests/SchemaGeneration.hs +++ b/tests/SchemaGeneration.hs @@ -1,15 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} module SchemaGeneration - ( Schema (..), genSchema - ) where + ( Schema (..), + genSchema, + ) +where import Control.Monad.State.Strict - -import Data.List.NonEmpty (NonEmpty((:|))) - +import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as NE -import qualified Test.QuickCheck as QC +import qualified Test.QuickCheck as QC -- Definitions @@ -26,72 +26,83 @@ show (StructName fn) = fn data Field - = FieldDef FieldName Int FieldType - | StructDef StructName [Field] + = FieldDef FieldName Int FieldType + | StructDef StructName [Field] data BuiltIn - = Void - | Bool - | Int8 - | Int16 - | Int32 - | Int64 - | UInt8 - | UInt16 - | UInt32 - | UInt64 - | Float32 - | Float64 - | Text - | Data - deriving (Show, Enum) + = Void + | Bool + | Int8 + | Int16 + | Int32 + | Int64 + | UInt8 + | UInt16 + | UInt32 + | UInt64 + | Float32 + | Float64 + | Text + | Data + deriving (Show, Enum) data FieldType - = BasicType BuiltIn - | ListType FieldType - | StructType StructName + = BasicType BuiltIn + | ListType FieldType + | StructType StructName instance Show FieldType where - show (BasicType bi) = show bi - show (ListType ft) = "List(" ++ show ft ++ ")" - show (StructType sn) = show sn + show (BasicType bi) = show bi + show (ListType ft) = "List(" ++ show ft ++ ")" + show (StructType sn) = show sn instance Show Field where - show (FieldDef name order entryType) = concat - [ show name, " @", show order, " :" - , show entryType, ";\n" - ] - show (StructDef name content) = concat - [ "struct ", show name, " {\n" - , concatMap (('\t':) . show) content - , "}\n\n" - ] + show (FieldDef name order entryType) = + concat + [ show name, + " @", + show order, + " :", + show entryType, + ";\n" + ] + show (StructDef name content) = + concat + [ "struct ", + show name, + " {\n", + concatMap (('\t' :) . show) content, + "}\n\n" + ] data Schema = Schema - { schemaId :: String - , schemaContent :: [Field] - } + { schemaId :: String, + schemaContent :: [Field] + } instance Show Schema where - show s = concat - [ "@0x", schemaId s, ";\n\n" - , concatMap show (schemaContent s) - ] + show s = + concat + [ "@0x", + schemaId s, + ";\n\n", + concatMap show (schemaContent s) + ] -- Helper generators genSafeLCChar :: QC.Gen Char -genSafeLCChar = QC.elements ['a'..'z'] +genSafeLCChar = QC.elements ['a' .. 'z'] genSafeUCChar :: QC.Gen Char -genSafeUCChar = QC.elements ['A'..'Z'] +genSafeUCChar = QC.elements ['A' .. 'Z'] genSafeHexChar :: QC.Gen Char -genSafeHexChar = QC.elements (['0'..'9'] ++ ['a'..'f']) +genSafeHexChar = QC.elements (['0' .. '9'] ++ ['a' .. 'f']) newtype FieldGen a - = FieldGen (StateT (NonEmpty (Int, Int)) QC.Gen a) - deriving (Functor, Applicative, Monad) + = FieldGen (StateT (NonEmpty (Int, Int)) QC.Gen a) + deriving (Functor, Applicative, Monad) liftGen :: QC.Gen a -> FieldGen a liftGen m = FieldGen (lift m) @@ -104,26 +115,26 @@ popFieldGen :: FieldGen () popFieldGen = FieldGen $ do - original <- get - case original of - (_ :| (y : rest)) -> put (y :| rest) - (x :| []) -> put (x :| []) + original <- get + case original of + (_ :| (y : rest)) -> put (y :| rest) + (x :| []) -> put (x :| []) getStructOrder :: FieldGen Int getStructOrder = FieldGen $ do - current <- get - let (result, _) = NE.head current - case current of - ((x, y) :| rest) -> put ((x + 1, y) :| rest) - return result + current <- get + let (result, _) = NE.head current + case current of + ((x, y) :| rest) -> put ((x + 1, y) :| rest) + return result getOrder :: FieldGen Int getOrder = FieldGen $ do - current <- get - let (_, result) = NE.head current - case current of - ((x, y) :| rest) -> put ((x + 1, y + 1) :| rest) - return result + current <- get + let (_, result) = NE.head current + case current of + ((x, y) :| rest) -> put ((x + 1, y + 1) :| rest) + return result -- Field types @@ -131,51 +142,51 @@ -- generation where the number of fields is known (numberDefs) genFieldDef :: [FieldType] -> FieldGen Field genFieldDef structTypes = do - order <- getOrder - fieldName <- do - str <- liftGen $ QC.listOf1 genSafeLCChar - return $ FieldName (str ++ show order) - fieldType <- liftGen $ QC.elements (map BasicType [Bool ..] ++ structTypes) - return $ FieldDef fieldName order fieldType + order <- getOrder + fieldName <- do + str <- liftGen $ QC.listOf1 genSafeLCChar + return $ FieldName (str ++ show order) + fieldType <- liftGen $ QC.elements (map BasicType [Bool ..] ++ structTypes) + return $ FieldDef fieldName order fieldType -- Struct type -- like fields, we enumerate each struct during generation for uniqueness genStructDef :: Int -> FieldGen Field genStructDef depth = do - order <- getStructOrder - - pushFieldGen + order <- getStructOrder - -- generate the struct's name - structName <- do - fc <- liftGen genSafeUCChar - rest <- liftGen (QC.listOf genSafeLCChar) - return $ StructName ((fc:rest) ++ show order) + pushFieldGen - -- generate the nested structs - structNum <- if depth <= 0 - then pure 0 - else liftGen (QC.choose (0, 3)) - structDefs <- replicateM structNum (genStructDef (depth - 1)) + -- generate the struct's name + structName <- do + fc <- liftGen genSafeUCChar + rest <- liftGen (QC.listOf genSafeLCChar) + return $ StructName ((fc : rest) ++ show order) - -- extract the available struct types - let structTypes = map (\(StructDef sn _) -> StructType sn) structDefs + -- generate the nested structs + structNum <- + if depth <= 0 + then pure 0 + else liftGen (QC.choose (0, 3)) + structDefs <- replicateM structNum (genStructDef (depth - 1)) - -- generate the fields using available struct types - fieldNum <- liftGen (QC.sized (\n -> QC.choose (1, 1 `max` n))) - fieldDefs <- replicateM fieldNum (genFieldDef structTypes) + -- extract the available struct types + let structTypes = map (\(StructDef sn _) -> StructType sn) structDefs - popFieldGen + -- generate the fields using available struct types + fieldNum <- liftGen (QC.sized (\n -> QC.choose (1, 1 `max` n))) + fieldDefs <- replicateM fieldNum (genFieldDef structTypes) - return $ StructDef structName (fieldDefs ++ structDefs) + popFieldGen + return $ StructDef structName (fieldDefs ++ structDefs) -- Schema type genSchema :: QC.Gen Schema genSchema = do - id1st <- QC.elements ['a'..'f'] - idrest <- QC.vectorOf 15 genSafeHexChar - -- multiple structs make tests take too long - content <- runFieldGen (genStructDef 3) - return $ Schema (id1st:idrest) [content] + id1st <- QC.elements ['a' .. 'f'] + idrest <- QC.vectorOf 15 genSafeHexChar + -- multiple structs make tests take too long + content <- runFieldGen (genStructDef 3) + return $ Schema (id1st : idrest) [content] diff --git a/tests/SchemaQuickCheck.hs b/tests/SchemaQuickCheck.hs --- a/tests/SchemaQuickCheck.hs +++ b/tests/SchemaQuickCheck.hs @@ -1,28 +1,24 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -module SchemaQuickCheck - (schemaCGRQuickCheck) - where +{-# LANGUAGE TypeApplications #-} -import qualified Data.ByteString as BS +module SchemaQuickCheck (schemaCGRQuickCheck) where -import Capnp.Convert (bsToParsed) -import Capnp.Errors (Error) +import Capnp.Convert (bsToParsed) +import Capnp.Errors (Error) +import qualified Capnp.Gen.Capnp.Schema as Schema import Capnp.TraversalLimit (defaultLimit, evalLimitT) - -import qualified Capnp.Gen.Capnp.Schema.New as Schema - -- Testing framework imports -import Test.Hspec -import Test.QuickCheck -- Schema generation imports -import SchemaGeneration -import Util -- Schema validation imports import Control.Monad.Catch as C +import qualified Data.ByteString as BS +import SchemaGeneration +import Test.Hspec +import Test.QuickCheck +import Util -- Functions to generate valid CGRs @@ -33,21 +29,22 @@ decodeCGR :: BS.ByteString -> IO () decodeCGR bytes = do - _ <- evalLimitT defaultLimit (bsToParsed @Schema.CodeGeneratorRequest bytes) - pure () + _ <- evalLimitT defaultLimit (bsToParsed @Schema.CodeGeneratorRequest bytes) + pure () -- QuickCheck properties prop_schemaValid :: Schema -> Property prop_schemaValid schema = ioProperty $ do - compiled <- generateCGR schema - decoded <- try $ decodeCGR compiled - return $ case (decoded :: Either Error ()) of - Left _ -> False - Right _ -> True + compiled <- generateCGR schema + decoded <- try $ decodeCGR compiled + return $ case (decoded :: Either Error ()) of + Left _ -> False + Right _ -> True schemaCGRQuickCheck :: Spec schemaCGRQuickCheck = - describe "generateCGR an decodeCGR agree" $ - it "successfully decodes generated schema" $ - property $ prop_schemaValid <$> genSchema + describe "generateCGR an decodeCGR agree" $ + it "successfully decodes generated schema" $ + property $ + prop_schemaValid <$> genSchema diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -1,35 +1,34 @@ -{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} -module Util - ( MsgMetaData(..) - , capnpEncode, capnpDecode, capnpCompile - , capnpCanonicalize - , decodeValue - , encodeValue - , aircraftSchemaSrc - , schemaSchemaSrc - ) - where +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} -import System.Process hiding (readCreateProcessWithExitCode) +module Util + ( MsgMetaData (..), + capnpEncode, + capnpDecode, + capnpCompile, + capnpCanonicalize, + decodeValue, + encodeValue, + aircraftSchemaSrc, + schemaSchemaSrc, + ) +where +import qualified Capnp.Message as M +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Resource (ResourceT, allocate, runResourceT) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Lazy.Char8 as LBSC8 +import System.Directory (removeFile) +import System.Exit (ExitCode (..)) import System.IO - -import Control.Monad.Trans (lift) -import Control.Monad.Trans.Resource (ResourceT, allocate, runResourceT) -import System.Directory (removeFile) -import System.Exit (ExitCode (..)) +import System.Process hiding (readCreateProcessWithExitCode) import System.Process.ByteString.Lazy (readCreateProcessWithExitCode) -import Text.Heredoc (there) - -import qualified Data.ByteString as BS -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Lazy as LBS -import qualified Data.ByteString.Lazy.Char8 as LBSC8 - -import qualified Capnp.Message as M +import Text.Heredoc (there) aircraftSchemaSrc, schemaSchemaSrc :: String aircraftSchemaSrc = [there|tests/data/aircraft.capnp|] @@ -38,54 +37,62 @@ -- | Information about the contents of a capnp message. This is enough -- to encode/decode both textual and binary forms. data MsgMetaData = MsgMetaData - { msgSchema :: String -- ^ The source of the schema - , msgType :: String -- ^ The name of the root struct's type - } deriving(Show) + { -- | The source of the schema + msgSchema :: String, + -- | The name of the root struct's type + msgType :: String + } + deriving (Show) capnpCanonicalize :: LBS.ByteString -> IO LBS.ByteString capnpCanonicalize stdInBytes = do - (exitStatus, stdOut, stdErr) <- - readCreateProcessWithExitCode - (proc "capnp" ["convert", "binary:canonical"]) - stdInBytes - case exitStatus of - ExitSuccess -> pure stdOut - ExitFailure code -> fail $ concat - [ "capnp convert binary:canonical failed with exit code " - , show code - , ":\n" - , show stdErr - ] + (exitStatus, stdOut, stdErr) <- + readCreateProcessWithExitCode + (proc "capnp" ["convert", "binary:canonical"]) + stdInBytes + case exitStatus of + ExitSuccess -> pure stdOut + ExitFailure code -> + fail $ + concat + [ "capnp convert binary:canonical failed with exit code ", + show code, + ":\n", + show stdErr + ] -- | @capnpEncode msg meta@ runs @capnp encode@ on the message, providing -- the needed metadata and returning the output capnpEncode :: String -> MsgMetaData -> IO BS.ByteString capnpEncode msgValue meta = do - (exitStatus, stdOut, stdErr) <- runResourceT $ - interactCapnpWithSchema "encode" (msgSchema meta) (LBSC8.pack msgValue) [msgType meta] - case exitStatus of - ExitSuccess -> return (LBS.toStrict stdOut) - ExitFailure code -> fail ("`capnp encode` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) + (exitStatus, stdOut, stdErr) <- + runResourceT $ + interactCapnpWithSchema "encode" (msgSchema meta) (LBSC8.pack msgValue) [msgType meta] + case exitStatus of + ExitSuccess -> return (LBS.toStrict stdOut) + ExitFailure code -> fail ("`capnp encode` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) -- | @capnpDecode msg meta@ runs @capnp decode@ on the message, providing -- the needed metadata and returning the output capnpDecode :: BS.ByteString -> MsgMetaData -> IO String capnpDecode encodedMsg meta = do - (exitStatus, stdOut, stdErr) <- runResourceT $ - interactCapnpWithSchema "decode" (msgSchema meta) (LBS.fromStrict encodedMsg) [msgType meta] - case exitStatus of - ExitSuccess -> return (LBSC8.unpack stdOut) - ExitFailure code -> fail ("`capnp decode` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) + (exitStatus, stdOut, stdErr) <- + runResourceT $ + interactCapnpWithSchema "decode" (msgSchema meta) (LBS.fromStrict encodedMsg) [msgType meta] + case exitStatus of + ExitSuccess -> return (LBSC8.unpack stdOut) + ExitFailure code -> fail ("`capnp decode` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) -- | @capnpCompile msg meta@ runs @capnp compile@ on the schema, providing -- the needed metadata and returning the output capnpCompile :: String -> String -> IO BS.ByteString capnpCompile msgSchema outputArg = do - (exitStatus, stdOut, stdErr) <- runResourceT $ - interactCapnpWithSchema "compile" msgSchema LBSC8.empty ["-o", outputArg] - case exitStatus of - ExitSuccess -> return (LBS.toStrict stdOut) - ExitFailure code -> fail ("`capnp compile` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) + (exitStatus, stdOut, stdErr) <- + runResourceT $ + interactCapnpWithSchema "compile" msgSchema LBSC8.empty ["-o", outputArg] + case exitStatus of + ExitSuccess -> return (LBS.toStrict stdOut) + ExitFailure code -> fail ("`capnp compile` failed with exit code " ++ show code ++ ":\n" ++ show stdErr) -- | A helper for @capnpEncode@ and @capnpDecode@. Launches the capnp command -- with the given subcommand (either "encode" or "decode") and metadata, @@ -94,22 +101,23 @@ -- when the ResourceT exits. interactCapnpWithSchema :: String -> String -> LBS.ByteString -> [String] -> ResourceT IO (ExitCode, LBS.ByteString, LBS.ByteString) interactCapnpWithSchema subCommand msgSchema stdInBytes args = do - let writeTempFile = runResourceT $ do - (_, (path, hndl)) <- allocate - (openTempFile "/tmp" "schema.capnp") - (\(_, hndl) -> hClose hndl) - lift $ hPutStr hndl msgSchema - return path - schemaFile <- snd <$> allocate writeTempFile removeFile - lift $ readCreateProcessWithExitCode (proc "capnp" ([subCommand, schemaFile] ++ args)) stdInBytes + let writeTempFile = runResourceT $ do + (_, (path, hndl)) <- + allocate + (openTempFile "/tmp" "schema.capnp") + (\(_, hndl) -> hClose hndl) + lift $ hPutStr hndl msgSchema + return path + schemaFile <- snd <$> allocate writeTempFile removeFile + lift $ readCreateProcessWithExitCode (proc "capnp" ([subCommand, schemaFile] ++ args)) stdInBytes -- | @'decodeValue' schema typename message@ decodes the value at the root of -- the message and converts it to text. This is a thin wrapper around -- 'capnpDecode'. decodeValue :: String -> String -> M.Message 'M.Const -> IO String decodeValue schema typename msg = - let bytes = M.encode msg in - capnpDecode + let bytes = M.encode msg + in capnpDecode (LBS.toStrict $ BB.toLazyByteString bytes) (MsgMetaData schema typename) @@ -117,5 +125,5 @@ -- as a capnp message. This is a thin wrapper around 'capnpEncode'. encodeValue :: String -> String -> String -> IO (M.Message 'M.Const) encodeValue schema typename value = - let meta = MsgMetaData schema typename - in capnpEncode value meta >>= M.decode + let meta = MsgMetaData schema typename + in capnpEncode value meta >>= M.decode diff --git a/tests/WalkSchemaCodeGenRequest.hs b/tests/WalkSchemaCodeGenRequest.hs --- a/tests/WalkSchemaCodeGenRequest.hs +++ b/tests/WalkSchemaCodeGenRequest.hs @@ -1,94 +1,103 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} + -- | This module defines a test that tries to walk over the -- CodeGeneratorRequest in `tests/data/schema-codegenreq`, -- failing if any of the data is not as expected. -module WalkSchemaCodeGenRequest - (walkSchemaCodeGenRequestTest) - where - -import Prelude hiding (length) - -import Test.Hspec +module WalkSchemaCodeGenRequest (walkSchemaCodeGenRequestTest) where -import Control.Monad (when) +import Capnp + ( Raw, + bsToRaw, + hasField, + index, + length, + parseField, + readField, + textBytes, + ) +import qualified Capnp.Gen.Capnp.Schema as Schema +import qualified Capnp.Message as M +import Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT) +import Control.Monad (when) import Control.Monad.Trans.Class (lift) -import Data.Function ((&)) - import qualified Data.ByteString as BS -import qualified Data.Vector as V - -import Capnp.New - (Raw, bsToRaw, hasField, index, length, parseField, readField, textBytes) -import Capnp.TraversalLimit (LimitT, evalLimitT, execLimitT) - -import qualified Capnp.Gen.Capnp.Schema.New as Schema -import qualified Capnp.Message as M +import Data.Function ((&)) +import qualified Data.Vector as V +import Test.Hspec +import Prelude hiding (length) nodeNames :: V.Vector BS.ByteString -nodeNames = V.fromList - [ "Import" - , "annotation" - , "Value" - , "Type" +nodeNames = + V.fromList + [ "Import", + "annotation", + "Value", + "Type" ] -- TODO: This contains a bit of copypasta from some of the untyped tests; should -- factor that out. walkSchemaCodeGenRequestTest :: Spec walkSchemaCodeGenRequestTest = - describe "Various sanity checks on a known schema CodeGeneratorRequest" $ - it "Should match misc. expectations" $ do - -- TODO: the above description betrays that this test isn't - -- especially well defined at a granularity that I(zenhack) - -- know how to tell hspec about, because there are data - -- dependencies between conceptual tests (we walk over the - -- data checking various things as we go). - -- - -- It would be nice if we could mark off individual checks for - -- hspec's reporting somehow. - bytes <- BS.readFile "tests/data/schema-codegenreq" - root <- evalLimitT maxBound (bsToRaw bytes) - endQuota <- execLimitT 4096 (reader root) - endQuota `shouldBe` 3409 + describe "Various sanity checks on a known schema CodeGeneratorRequest" $ + it "Should match misc. expectations" $ do + -- TODO: the above description betrays that this test isn't + -- especially well defined at a granularity that I(zenhack) + -- know how to tell hspec about, because there are data + -- dependencies between conceptual tests (we walk over the + -- data checking various things as we go). + -- + -- It would be nice if we could mark off individual checks for + -- hspec's reporting somehow. + bytes <- BS.readFile "tests/data/schema-codegenreq" + root <- evalLimitT maxBound (bsToRaw bytes) + endQuota <- execLimitT 4096 (reader root) + endQuota `shouldBe` 3409 where reader :: Raw Schema.CodeGeneratorRequest 'M.Const -> LimitT IO () reader req = do - nodes <- req & readField #nodes - requestedFiles <- req & readField #requestedFiles - lift $ length nodes `shouldBe` 37 - lift $ length requestedFiles `shouldBe` 1 - mapM_ (walkNode nodes) [0,1..36] + nodes <- req & readField #nodes + requestedFiles <- req & readField #requestedFiles + lift $ length nodes `shouldBe` 37 + lift $ length requestedFiles `shouldBe` 1 + mapM_ (walkNode nodes) [0, 1 .. 36] walkNode nodes i = do - node <- index i nodes - -- None of the nodes in the schema have parameters: - False <- node & hasField #parameters - -- And none of them are generic: - False <- node & parseField #isGeneric + node <- index i nodes + -- None of the nodes in the schema have parameters: + False <- node & hasField #parameters + -- And none of them are generic: + False <- node & parseField #isGeneric - nameList <- node & readField #displayName - name <- textBytes nameList - prefixLen <- parseField #displayNamePrefixLength node - let baseName = BS.drop (fromIntegral prefixLen) name + nameList <- node & readField #displayName + name <- textBytes nameList + prefixLen <- parseField #displayNamePrefixLength node + let baseName = BS.drop (fromIntegral prefixLen) name - when (i < V.length nodeNames && baseName /= (nodeNames V.! i)) $ - error "Incorrect name." + when (i < V.length nodeNames && baseName /= (nodeNames V.! i)) $ + error "Incorrect name." - has <- node & hasField #annotations + has <- node & hasField #annotations - -- there are two annotations in all of the nodes, at these indicies: - case (has, i `elem` [4, 9]) of - (False, False) -> return () - (True, True) -> do - 1 <- length <$> readField #annotations node - return () - (False, True) -> - error $ "Node at index " ++ show i ++ " should have had" ++ - "an annotation." - (True, False) -> - error $ "Node at index " ++ show i ++ " should not " ++ - "have had an annotation." + -- there are two annotations in all of the nodes, at these indicies: + case (has, i `elem` [4, 9]) of + (False, False) -> return () + (True, True) -> do + 1 <- length <$> readField #annotations node + return () + (False, True) -> + error $ + "Node at index " + ++ show i + ++ " should have had" + ++ "an annotation." + (True, False) -> + error $ + "Node at index " + ++ show i + ++ " should not " + ++ "have had an annotation."