capnp 0.16.0.0 → 0.17.0.0
raw patch · 139 files changed
+22269/−20798 lines, 139 filesdep ~criteriondep ~ghc-primdep ~hashable
Dependency ranges changed: criterion, ghc-prim, hashable, mtl, template-haskell, text, vector
Files
- .gitlab-ci.yml +0/−33
- CHANGELOG.md +10/−0
- README.md +0/−4
- bench/Main.hs +54/−50
- capnp.cabal +46/−44
- cmd/capnpc-haskell/Check.hs +44/−40
- cmd/capnpc-haskell/IR/AbstractOp.hs +94/−0
- cmd/capnpc-haskell/IR/Common.hs +122/−122
- cmd/capnpc-haskell/IR/Flat.hs +64/−65
- cmd/capnpc-haskell/IR/Haskell.hs +155/−156
- cmd/capnpc-haskell/IR/Name.hs +83/−51
- cmd/capnpc-haskell/IR/New.hs +0/−94
- cmd/capnpc-haskell/IR/Stage1.hs +67/−66
- cmd/capnpc-haskell/Main.hs +28/−32
- cmd/capnpc-haskell/Trans/AbstractOpToHaskell.hs +1076/−0
- cmd/capnpc-haskell/Trans/CgrToStage1.hs +300/−291
- cmd/capnpc-haskell/Trans/FlatToAbstractOp.hs +154/−0
- cmd/capnpc-haskell/Trans/FlatToNew.hs +0/−152
- cmd/capnpc-haskell/Trans/HaskellToText.hs +273/−240
- cmd/capnpc-haskell/Trans/NewToHaskell.hs +0/−1032
- cmd/capnpc-haskell/Trans/Stage1ToFlat.hs +228/−220
- cmd/capnpc-haskell/Trans/ToHaskellCommon.hs +144/−139
- examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs +14/−0
- examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b/New.hs +0/−12
- examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs +14/−0
- examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5/New.hs +0/−12
- examples/gen/lib/Capnp/Gen/Calculator.hs +793/−0
- examples/gen/lib/Capnp/Gen/Calculator/New.hs +0/−566
- examples/gen/lib/Capnp/Gen/Echo.hs +148/−0
- examples/gen/lib/Capnp/Gen/Echo/New.hs +0/−111
- examples/lib/Examples/Rpc/CalculatorClient.hs +73/−55
- examples/lib/Examples/Rpc/CalculatorServer.hs +109/−105
- gen/lib/Capnp/Gen/ById/X86c366a91393f3f8.hs +12/−0
- gen/lib/Capnp/Gen/ById/X86c366a91393f3f8/New.hs +0/−12
- gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34.hs +12/−0
- gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34/New.hs +0/−12
- gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1.hs +12/−0
- gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1/New.hs +0/−12
- gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9.hs +12/−0
- gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9/New.hs +0/−12
- gen/lib/Capnp/Gen/ById/Xb312981b2552a250.hs +12/−0
- gen/lib/Capnp/Gen/ById/Xb312981b2552a250/New.hs +0/−12
- gen/lib/Capnp/Gen/ById/Xb8630836983feed7.hs +12/−0
- gen/lib/Capnp/Gen/ById/Xb8630836983feed7/New.hs +0/−12
- gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81.hs +12/−0
- gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81/New.hs +0/−12
- gen/lib/Capnp/Gen/Capnp/Compat/Json.hs +290/−0
- gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs +0/−290
- gen/lib/Capnp/Gen/Capnp/Cxx.hs +34/−0
- gen/lib/Capnp/Gen/Capnp/Cxx/New.hs +0/−34
- gen/lib/Capnp/Gen/Capnp/Persistent.hs +303/−0
- gen/lib/Capnp/Gen/Capnp/Persistent/New.hs +0/−303
- gen/lib/Capnp/Gen/Capnp/Rpc.hs +1372/−0
- gen/lib/Capnp/Gen/Capnp/Rpc/New.hs +0/−1372
- gen/lib/Capnp/Gen/Capnp/RpcTwoparty.hs +258/−0
- gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs +0/−258
- gen/lib/Capnp/Gen/Capnp/Schema.hs +2297/−0
- gen/lib/Capnp/Gen/Capnp/Schema/New.hs +0/−2297
- gen/lib/Capnp/Gen/Capnp/Stream.hs +59/−0
- gen/lib/Capnp/Gen/Capnp/Stream/New.hs +0/−59
- gen/tests/Capnp/Gen/Aircraft.hs +2750/−0
- gen/tests/Capnp/Gen/Aircraft/New.hs +0/−2750
- gen/tests/Capnp/Gen/ById/X832bcc6686a26d56.hs +12/−0
- gen/tests/Capnp/Gen/ById/X832bcc6686a26d56/New.hs +0/−12
- gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144.hs +12/−0
- gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144/New.hs +0/−12
- gen/tests/Capnp/Gen/Generics.hs +468/−0
- gen/tests/Capnp/Gen/Generics/New.hs +0/−468
- lib/Capnp.hs +76/−0
- lib/Capnp/Accessors.hs +266/−0
- lib/Capnp/Address.hs +48/−47
- lib/Capnp/Basics.hs +290/−0
- lib/Capnp/Bits.hs +70/−49
- lib/Capnp/Canonicalize.hs +152/−150
- lib/Capnp/Classes.hs +465/−0
- lib/Capnp/Constraints.hs +17/−0
- lib/Capnp/Convert.hs +49/−52
- lib/Capnp/Errors.hs +27/−27
- lib/Capnp/Fields.hs +70/−69
- lib/Capnp/Gen.hs +7/−8
- lib/Capnp/Gen/Capnp.hs +6/−7
- lib/Capnp/GenHelpers.hs +120/−0
- lib/Capnp/GenHelpers/New.hs +0/−106
- lib/Capnp/GenHelpers/New/Rpc.hs +0/−22
- lib/Capnp/GenHelpers/Rpc.hs +24/−0
- lib/Capnp/IO.hs +79/−78
- lib/Capnp/Message.hs +377/−359
- lib/Capnp/Mutability.hs +30/−28
- lib/Capnp/New.hs +0/−75
- lib/Capnp/New/Accessors.hs +0/−223
- lib/Capnp/New/Basics.hs +0/−272
- lib/Capnp/New/Classes.hs +0/−430
- lib/Capnp/New/Constraints.hs +0/−17
- lib/Capnp/New/Rpc/Common.hs +0/−13
- lib/Capnp/New/Rpc/Server.hs +153/−138
- lib/Capnp/Pointer.hs +106/−104
- lib/Capnp/Repr.hs +186/−154
- lib/Capnp/Repr/Methods.hs +129/−114
- lib/Capnp/Repr/Parsed.hs +17/−18
- lib/Capnp/Rpc.hs +31/−30
- lib/Capnp/Rpc/Common.hs +14/−0
- lib/Capnp/Rpc/Errors.hs +44/−41
- lib/Capnp/Rpc/Membrane.hs +166/−0
- lib/Capnp/Rpc/Promise.hs +56/−55
- lib/Capnp/Rpc/Revoke.hs +42/−0
- lib/Capnp/Rpc/Server.hs +98/−93
- lib/Capnp/Rpc/Transport.hs +62/−59
- lib/Capnp/Rpc/Untyped.hs +2557/−2357
- lib/Capnp/Rpc/Untyped.hs-boot +0/−9
- lib/Capnp/TraversalLimit.hs +76/−72
- lib/Capnp/Tutorial.hs +9/−35
- lib/Capnp/Untyped.hs +1730/−1583
- lib/Data/Mutable.hs +38/−38
- lib/Internal/AppendVec.hs +56/−51
- lib/Internal/BuildPure.hs +22/−23
- lib/Internal/Rc.hs +47/−39
- lib/Internal/Rpc/Breaker.hs +55/−0
- lib/Internal/STE.hs +32/−30
- lib/Internal/SnocList.hs +14/−12
- lib/Internal/TCloseQ.hs +41/−41
- tests/CalculatorExample.hs +71/−70
- tests/Instances.hs +320/−304
- tests/Main.hs +32/−34
- tests/Module/Capnp/Basics.hs +28/−24
- tests/Module/Capnp/Bits.hs +31/−28
- tests/Module/Capnp/Canonicalize.hs +53/−56
- tests/Module/Capnp/Gen/Capnp/Schema.hs +44/−43
- tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs +429/−362
- tests/Module/Capnp/Pointer.hs +52/−42
- tests/Module/Capnp/Rpc.hs +477/−366
- tests/Module/Capnp/Untyped.hs +309/−304
- tests/Module/Capnp/Untyped/Pure.hs +39/−34
- tests/PointerOOB.hs +50/−52
- tests/Regression.hs +34/−31
- tests/Rpc/Unwrap.hs +29/−29
- tests/SchemaGeneration.hs +106/−95
- tests/SchemaQuickCheck.hs +22/−25
- tests/Util.hs +77/−69
- tests/WalkSchemaCodeGenRequest.hs +80/−71
− .gitlab-ci.yml
@@ -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
CHANGELOG.md view
@@ -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:
README.md view
@@ -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
bench/Main.hs view
@@ -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))+ )+ ]
capnp.cabal view
@@ -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
cmd/capnpc-haskell/Check.hs view
@@ -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
+ cmd/capnpc-haskell/IR/AbstractOp.hs view
@@ -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+ }
cmd/capnpc-haskell/IR/Common.hs view
@@ -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
cmd/capnpc-haskell/IR/Flat.hs view
@@ -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)
cmd/capnpc-haskell/IR/Haskell.hs view
@@ -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"
cmd/capnpc-haskell/IR/Name.hs view
@@ -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
− cmd/capnpc-haskell/IR/New.hs
@@ -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- }
cmd/capnpc-haskell/IR/Stage1.hs view
@@ -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)
cmd/capnpc-haskell/Main.hs view
@@ -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
+ cmd/capnpc-haskell/Trans/AbstractOpToHaskell.hs view
@@ -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]
cmd/capnpc-haskell/Trans/CgrToStage1.hs view
@@ -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
+ cmd/capnpc-haskell/Trans/FlatToAbstractOp.hs view
@@ -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+ }
− cmd/capnpc-haskell/Trans/FlatToNew.hs
@@ -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- }
cmd/capnpc-haskell/Trans/HaskellToText.hs view
@@ -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
− cmd/capnpc-haskell/Trans/NewToHaskell.hs
@@ -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]
cmd/capnpc-haskell/Trans/Stage1ToFlat.hs view
@@ -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"
cmd/capnpc-haskell/Trans/ToHaskellCommon.hs view
@@ -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
+ examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b.hs view
@@ -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_
− examples/gen/lib/Capnp/Gen/ById/X85150b117366d14b/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5.hs view
@@ -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_
− examples/gen/lib/Capnp/Gen/ById/Xd0a87f36fa0182f5/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ examples/gen/lib/Capnp/Gen/Calculator.hs view
@@ -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)
− examples/gen/lib/Capnp/Gen/Calculator/New.hs
@@ -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)
+ examples/gen/lib/Capnp/Gen/Echo.hs view
@@ -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)
− examples/gen/lib/Capnp/Gen/Echo/New.hs
@@ -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)
examples/lib/Examples/Rpc/CalculatorClient.hs view
@@ -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
examples/lib/Examples/Rpc/CalculatorServer.hs view
@@ -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+ }
+ gen/lib/Capnp/Gen/ById/X86c366a91393f3f8.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/X86c366a91393f3f8/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/X8ef99297a43a5e34/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/Xa184c7885cdaf2a1/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/Xa93fc509624c72d9/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/ById/Xb312981b2552a250.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/Xb312981b2552a250/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/ById/Xb8630836983feed7.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/Xb8630836983feed7/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/ById/Xbdf87d7bb8304e81/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/Capnp/Compat/Json.hs view
@@ -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)
− gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs
@@ -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)
+ gen/lib/Capnp/Gen/Capnp/Cxx.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/lib/Capnp/Gen/Capnp/Cxx/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/lib/Capnp/Gen/Capnp/Persistent.hs view
@@ -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)
− gen/lib/Capnp/Gen/Capnp/Persistent/New.hs
@@ -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)
+ gen/lib/Capnp/Gen/Capnp/Rpc.hs view
@@ -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)
− gen/lib/Capnp/Gen/Capnp/Rpc/New.hs
@@ -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)
+ gen/lib/Capnp/Gen/Capnp/RpcTwoparty.hs view
@@ -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)
− gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs
@@ -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)
+ gen/lib/Capnp/Gen/Capnp/Schema.hs view
@@ -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)
− gen/lib/Capnp/Gen/Capnp/Schema/New.hs
@@ -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)
+ gen/lib/Capnp/Gen/Capnp/Stream.hs view
@@ -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 ())
− gen/lib/Capnp/Gen/Capnp/Stream/New.hs
@@ -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 ())
+ gen/tests/Capnp/Gen/Aircraft.hs view
@@ -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)
− gen/tests/Capnp/Gen/Aircraft/New.hs
@@ -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)
+ gen/tests/Capnp/Gen/ById/X832bcc6686a26d56.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/tests/Capnp/Gen/ById/X832bcc6686a26d56/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144.hs view
@@ -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 ((<$>), (<*>), (>>=))
− gen/tests/Capnp/Gen/ById/Xb6421fb8e478d144/New.hs
@@ -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 ((<$>), (<*>), (>>=))
+ gen/tests/Capnp/Gen/Generics.hs view
@@ -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)
− gen/tests/Capnp/Gen/Generics/New.hs
@@ -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)
+ lib/Capnp.hs view
@@ -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)
+ lib/Capnp/Accessors.hs view
@@ -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
lib/Capnp/Address.hs view
@@ -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}
+ lib/Capnp/Basics.hs view
@@ -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
lib/Capnp/Bits.hs view
@@ -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
lib/Capnp/Canonicalize.hs view
@@ -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
+ lib/Capnp/Classes.hs view
@@ -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 #-}
+ lib/Capnp/Constraints.hs view
@@ -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)+ )
lib/Capnp/Convert.hs view
@@ -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
lib/Capnp/Errors.hs view
@@ -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
lib/Capnp/Fields.hs view
@@ -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
lib/Capnp/Gen.hs view
@@ -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
lib/Capnp/Gen/Capnp.hs view
@@ -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
+ lib/Capnp/GenHelpers.hs view
@@ -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
− lib/Capnp/GenHelpers/New.hs
@@ -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
− lib/Capnp/GenHelpers/New/Rpc.hs
@@ -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
+ lib/Capnp/GenHelpers/Rpc.hs view
@@ -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
lib/Capnp/IO.hs view
@@ -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
lib/Capnp/Message.hs view
@@ -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+ }
lib/Capnp/Mutability.hs view
@@ -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
− lib/Capnp/New.hs
@@ -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)
− lib/Capnp/New/Accessors.hs
@@ -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
− lib/Capnp/New/Basics.hs
@@ -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
− lib/Capnp/New/Classes.hs
@@ -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 #-}
− lib/Capnp/New/Constraints.hs
@@ -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)- )-
− lib/Capnp/New/Rpc/Common.hs
@@ -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)
lib/Capnp/New/Rpc/Server.hs view
@@ -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
lib/Capnp/Pointer.hs view
@@ -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)
lib/Capnp/Repr.hs view
@@ -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))+ )
lib/Capnp/Repr/Methods.hs view
@@ -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
lib/Capnp/Repr/Parsed.hs view
@@ -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
lib/Capnp/Rpc.hs view
@@ -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
+ lib/Capnp/Rpc/Common.hs view
@@ -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)
lib/Capnp/Rpc/Errors.hs view
@@ -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
+ lib/Capnp/Rpc/Membrane.hs view
@@ -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
lib/Capnp/Rpc/Promise.hs view
@@ -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)
+ lib/Capnp/Rpc/Revoke.hs view
@@ -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")
lib/Capnp/Rpc/Server.hs view
@@ -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
lib/Capnp/Rpc/Transport.hs view
@@ -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+ )
lib/Capnp/Rpc/Untyped.hs view
@@ -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
− lib/Capnp/Rpc/Untyped.hs-boot
@@ -1,9 +0,0 @@-module Capnp.Rpc.Untyped where--data Client-data Pipeline--nullClient :: Client--instance Eq Client-instance Show Client
lib/Capnp/TraversalLimit.hs view
@@ -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
lib/Capnp/Tutorial.hs view
@@ -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:--- <http://zenhack.net/TODO>. 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):
lib/Capnp/Untyped.hs view
@@ -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
lib/Data/Mutable.hs view
@@ -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
lib/Internal/AppendVec.hs view
@@ -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
lib/Internal/BuildPure.hs view
@@ -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
lib/Internal/Rc.hs view
@@ -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)
+ lib/Internal/Rpc/Breaker.hs view
@@ -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
lib/Internal/STE.hs view
@@ -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
lib/Internal/SnocList.hs view
@@ -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
lib/Internal/TCloseQ.hs view
@@ -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
tests/CalculatorExample.hs view
@@ -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+ }+ }
tests/Instances.hs view
@@ -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.- ]+ ]
tests/Main.hs view
@@ -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
tests/Module/Capnp/Basics.hs view
@@ -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)
tests/Module/Capnp/Bits.hs view
@@ -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
tests/Module/Capnp/Canonicalize.hs view
@@ -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
tests/Module/Capnp/Gen/Capnp/Schema.hs view
@@ -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
tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs view
@@ -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
tests/Module/Capnp/Pointer.hs view
@@ -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)
tests/Module/Capnp/Rpc.hs view
@@ -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
tests/Module/Capnp/Untyped.hs view
@@ -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
tests/Module/Capnp/Untyped/Pure.hs view
@@ -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 []+ ]+ ]+ ]
tests/PointerOOB.hs view
@@ -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)
tests/Regression.hs view
@@ -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)
tests/Rpc/Unwrap.hs view
@@ -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
tests/SchemaGeneration.hs view
@@ -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]
tests/SchemaQuickCheck.hs view
@@ -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
tests/Util.hs view
@@ -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
tests/WalkSchemaCodeGenRequest.hs view
@@ -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."