capnp 0.13.0.0 → 0.14.0.0

raw patch · 36 files changed

+2129/−1860 lines, 36 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +19/−0
• bench/Main.hs +1/−1
• capnp.cabal +2/−1
• cmd/capnpc-haskell/Trans/NewToHaskell.hs +7/−7
• examples/gen/lib/Capnp/Gen/Calculator/New.hs +5/−5
• gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs +8/−8
• gen/lib/Capnp/Gen/Capnp/Rpc/New.hs +47/−47
• gen/lib/Capnp/Gen/Capnp/Schema/New.hs +68/−68
• gen/tests/Capnp/Gen/Aircraft/New.hs +56/−56
• gen/tests/Capnp/Gen/Generics/New.hs +6/−6
• lib/Capnp/Bits.hs +1/−1
• lib/Capnp/Canonicalize.hs +70/−38
• lib/Capnp/Convert.hs +12/−11
• lib/Capnp/Fields.hs +2/−2
• lib/Capnp/GenHelpers/New.hs +6/−6
• lib/Capnp/GenHelpers/New/Rpc.hs +2/−2
• lib/Capnp/IO.hs +3/−3
• lib/Capnp/Message.hs +17/−48
• lib/Capnp/Mutability.hs +54/−0
• lib/Capnp/New/Accessors.hs +20/−20
• lib/Capnp/New/Basics.hs +4/−4
• lib/Capnp/New/Classes.hs +85/−48
• lib/Capnp/New/Rpc/Server.hs +3/−3
• lib/Capnp/Repr.hs +60/−279
• lib/Capnp/Repr/Methods.hs +4/−4
• lib/Capnp/Rpc/Untyped.hs +15/−15
• lib/Capnp/Untyped.hs +1518/−1134
• lib/Data/Mutable.hs +1/−1
• lib/Internal/AppendVec.hs +0/−24
• lib/Internal/BuildPure.hs +7/−5
• tests/Module/Capnp/Basics.hs +5/−3
• tests/Module/Capnp/Gen/Capnp/Schema.hs +1/−1
• tests/Module/Capnp/Gen/Capnp/Schema/Pure.hs +1/−1
• tests/Module/Capnp/Rpc.hs +1/−1
• tests/Module/Capnp/Untyped.hs +17/−6
• tests/WalkSchemaCodeGenRequest.hs +1/−1

@@ -1,3 +1,22 @@+# 0.14.0.0++- Significant performance improvements.+- The `Data.Mutable` module and its `Thaw` class have been replaced+  by `Capnp.Mutability` and a class `MaybeMutable`, which serves the+  same function but is easier to work with. Notably, `thaw` and `freeze+  can now be used on `Raw` values directly.+- `Mutability` is now defined in `Capnp.Mutability` instead of+  `Capnp.Message`, though the latter still re-exports it for+  compatibility (for now).+- The parameters to the `Raw` type constructor have been flipped; the+  new ordering makes it possible to implement thaw/freeze on `Raw a`+  - The `Untyped` type family has seen similar treatment.+- HasMessage and MessageDefault are now defined on a type of kind+  `* -> Mutability`, which keeps the mutability out of constraints.+  - This has the unfortunate side-effect of making type inference+    for these classes not work very well :(. Hopefully a better+    solution will be found in the future.+ # 0.13.0.0  This release drops support for the old API. To upgrade to the new API,

@@ -3,13 +3,13 @@ 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           Data.Mutable              (thaw) import           System.Exit               (ExitCode(..)) import qualified System.Process.ByteString as PB 

@@ -1,6 +1,6 @@ cabal-version:            2.2 name:                     capnp-version:                  0.13.0.0+version:                  0.14.0.0 category:                 Data, Serialization, Network, Rpc copyright:                2016-2021 haskell-capnp contributors (see CONTRIBUTORS file). author:                   Ian Denhardt@@ -109,6 +109,7 @@       , Capnp.GenHelpers.New.Rpc       , Capnp.IO       , Capnp.Message+      , Capnp.Mutability       , Capnp.Pointer       , Capnp.Untyped       , Capnp.Repr

@@ -405,7 +405,7 @@             ]         C.PtrValue t v ->             [ Hs.DcValue-                { typ = Hs.TApp (tgName ["R"] "Raw") [tgName ["GH"] "Const", typeToType thisMod (C.PtrType t)]+                { typ = Hs.TApp (tgName ["R"] "Raw") [ typeToType thisMod (C.PtrType t), tgName ["GH"] "Const"]                 , def = Hs.DfValue                     { name                     , params = []@@ -420,8 +420,8 @@     Hs.IdData Hs.Data         { dataName = "RawWhich"         , typeArgs =-            [ Hs.TVar "mut_"-            , Hs.TApp (Hs.TVar $ Name.renderUnQ $ Name.localToUnQ name) tVars+            [ Hs.TApp (Hs.TVar $ Name.renderUnQ $ Name.localToUnQ name) tVars+            , Hs.TVar "mut_"             ]          , dataNewtype = False@@ -433,8 +433,8 @@                 , dvArgs = Hs.APos                     [ Hs.TApp                         (tReprName "Raw")-                        [ Hs.TVar "mut_"-                        , fieldLocTypeToType thisMod fieldLocType+                        [ fieldLocTypeToType thisMod fieldLocType+                        , Hs.TVar "mut_"                         ]                     ]                 }@@ -647,8 +647,8 @@     toType R.ListComposite   = tReprName "ListComposite"  instance ToType R.NormalListRepr where-    toType (R.ListData r) = rApp "ListData" [toType r]-    toType R.ListPtr      = tReprName "ListPtr"+    toType (R.NormalListData r) = rApp "ListData" [toType r]+    toType R.NormalListPtr      = tReprName "ListPtr"  instance ToType R.DataSz where     toType = tReprName . fromString . show

@@ -272,11 +272,11 @@         ) instance (GH.HasUnion Expression) where     unionField  = (GH.dataField 0 1 16 0)-    data RawWhich mut_ Expression-        = RW_Expression'literal (R.Raw mut_ Std_.Double)-        | RW_Expression'previousResult (R.Raw mut_ Value)-        | RW_Expression'parameter (R.Raw mut_ Std_.Word32)-        | RW_Expression'call (R.Raw mut_ Expression'call)+    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 ->

@@ -60,14 +60,14 @@         ) instance (GH.HasUnion Value) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Value-        = RW_Value'null (R.Raw mut_ ())-        | RW_Value'boolean (R.Raw mut_ Std_.Bool)-        | RW_Value'number (R.Raw mut_ Std_.Double)-        | RW_Value'string (R.Raw mut_ Basics.Text)-        | RW_Value'array (R.Raw mut_ (R.List Value))-        | RW_Value'object (R.Raw mut_ (R.List Value'Field))-        | RW_Value'call (R.Raw mut_ Value'Call)+    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 ->

@@ -60,21 +60,21 @@         ) instance (GH.HasUnion Message) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Message-        = RW_Message'unimplemented (R.Raw mut_ Message)-        | RW_Message'abort (R.Raw mut_ Exception)-        | RW_Message'call (R.Raw mut_ Call)-        | RW_Message'return (R.Raw mut_ Return)-        | RW_Message'finish (R.Raw mut_ Finish)-        | RW_Message'resolve (R.Raw mut_ Resolve)-        | RW_Message'release (R.Raw mut_ Release)-        | RW_Message'obsoleteSave (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))-        | RW_Message'bootstrap (R.Raw mut_ Bootstrap)-        | RW_Message'obsoleteDelete (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))-        | RW_Message'provide (R.Raw mut_ Provide)-        | RW_Message'accept (R.Raw mut_ Accept)-        | RW_Message'join (R.Raw mut_ Join)-        | RW_Message'disembargo (R.Raw mut_ Disembargo)+    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 ->@@ -349,10 +349,10 @@         ) instance (GH.HasUnion Call'sendResultsTo) where     unionField  = (GH.dataField 48 0 16 0)-    data RawWhich mut_ Call'sendResultsTo-        = RW_Call'sendResultsTo'caller (R.Raw mut_ ())-        | RW_Call'sendResultsTo'yourself (R.Raw mut_ ())-        | RW_Call'sendResultsTo'thirdParty (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))+    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 ->@@ -436,13 +436,13 @@         ) instance (GH.HasUnion Return) where     unionField  = (GH.dataField 48 0 16 0)-    data RawWhich mut_ Return-        = RW_Return'results (R.Raw mut_ Payload)-        | RW_Return'exception (R.Raw mut_ Exception)-        | RW_Return'canceled (R.Raw mut_ ())-        | RW_Return'resultsSentElsewhere (R.Raw mut_ ())-        | RW_Return'takeFromOtherQuestion (R.Raw mut_ Std_.Word32)-        | RW_Return'acceptFromThirdParty (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))+    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 ->@@ -589,9 +589,9 @@         ) instance (GH.HasUnion Resolve) where     unionField  = (GH.dataField 32 0 16 0)-    data RawWhich mut_ Resolve-        = RW_Resolve'cap (R.Raw mut_ CapDescriptor)-        | RW_Resolve'exception (R.Raw mut_ Exception)+    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 ->@@ -735,11 +735,11 @@         ) instance (GH.HasUnion Disembargo'context) where     unionField  = (GH.dataField 32 0 16 0)-    data RawWhich mut_ Disembargo'context-        = RW_Disembargo'context'senderLoopback (R.Raw mut_ Std_.Word32)-        | RW_Disembargo'context'receiverLoopback (R.Raw mut_ Std_.Word32)-        | RW_Disembargo'context'accept (R.Raw mut_ ())-        | RW_Disembargo'context'provide (R.Raw mut_ Std_.Word32)+    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 ->@@ -946,9 +946,9 @@         ) instance (GH.HasUnion MessageTarget) where     unionField  = (GH.dataField 32 0 16 0)-    data RawWhich mut_ MessageTarget-        = RW_MessageTarget'importedCap (R.Raw mut_ Std_.Word32)-        | RW_MessageTarget'promisedAnswer (R.Raw mut_ PromisedAnswer)+    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 ->@@ -1055,13 +1055,13 @@         ) instance (GH.HasUnion CapDescriptor) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ CapDescriptor-        = RW_CapDescriptor'none (R.Raw mut_ ())-        | RW_CapDescriptor'senderHosted (R.Raw mut_ Std_.Word32)-        | RW_CapDescriptor'senderPromise (R.Raw mut_ Std_.Word32)-        | RW_CapDescriptor'receiverHosted (R.Raw mut_ Std_.Word32)-        | RW_CapDescriptor'receiverAnswer (R.Raw mut_ PromisedAnswer)-        | RW_CapDescriptor'thirdPartyHosted (R.Raw mut_ ThirdPartyCapDescriptor)+    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 ->@@ -1203,9 +1203,9 @@         ) instance (GH.HasUnion PromisedAnswer'Op) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ PromisedAnswer'Op-        = RW_PromisedAnswer'Op'noop (R.Raw mut_ ())-        | RW_PromisedAnswer'Op'getPointerField (R.Raw mut_ Std_.Word16)+    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 ->

@@ -84,13 +84,13 @@         ) instance (GH.HasUnion Node) where     unionField  = (GH.dataField 32 1 16 0)-    data RawWhich mut_ Node-        = RW_Node'file (R.Raw mut_ ())-        | RW_Node'struct (R.Raw mut_ Node'struct)-        | RW_Node'enum (R.Raw mut_ Node'enum)-        | RW_Node'interface (R.Raw mut_ Node'interface)-        | RW_Node'const (R.Raw mut_ Node'const)-        | RW_Node'annotation (R.Raw mut_ Node'annotation)+    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 ->@@ -629,9 +629,9 @@         ) instance (GH.HasUnion Field) where     unionField  = (GH.dataField 0 1 16 0)-    data RawWhich mut_ Field-        = RW_Field'slot (R.Raw mut_ Field'slot)-        | RW_Field'group (R.Raw mut_ Field'group)+    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 ->@@ -791,9 +791,9 @@         ) instance (GH.HasUnion Field'ordinal) where     unionField  = (GH.dataField 16 1 16 0)-    data RawWhich mut_ Field'ordinal-        = RW_Field'ordinal'implicit (R.Raw mut_ ())-        | RW_Field'ordinal'explicit (R.Raw mut_ Std_.Word16)+    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 ->@@ -1004,26 +1004,26 @@         ) instance (GH.HasUnion Type) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Type-        = 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 mut_ Type'list)-        | RW_Type'enum (R.Raw mut_ Type'enum)-        | RW_Type'struct (R.Raw mut_ Type'struct)-        | RW_Type'interface (R.Raw mut_ Type'interface)-        | RW_Type'anyPointer (R.Raw mut_ Type'anyPointer)+    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 ->@@ -1395,10 +1395,10 @@         ) instance (GH.HasUnion Type'anyPointer) where     unionField  = (GH.dataField 0 1 16 0)-    data RawWhich mut_ Type'anyPointer-        = RW_Type'anyPointer'unconstrained (R.Raw mut_ Type'anyPointer'unconstrained)-        | RW_Type'anyPointer'parameter (R.Raw mut_ Type'anyPointer'parameter)-        | RW_Type'anyPointer'implicitMethodParameter (R.Raw mut_ Type'anyPointer'implicitMethodParameter)+    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 ->@@ -1485,11 +1485,11 @@         ) instance (GH.HasUnion Type'anyPointer'unconstrained) where     unionField  = (GH.dataField 16 1 16 0)-    data RawWhich mut_ Type'anyPointer'unconstrained-        = 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_ ())+    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 ->@@ -1674,9 +1674,9 @@         ) instance (GH.HasUnion Brand'Scope) where     unionField  = (GH.dataField 0 1 16 0)-    data RawWhich mut_ Brand'Scope-        = RW_Brand'Scope'bind (R.Raw mut_ (R.List Brand'Binding))-        | RW_Brand'Scope'inherit (R.Raw mut_ ())+    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 ->@@ -1747,9 +1747,9 @@         ) instance (GH.HasUnion Brand'Binding) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Brand'Binding-        = RW_Brand'Binding'unbound (R.Raw mut_ ())-        | RW_Brand'Binding'type_ (R.Raw mut_ Type)+    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 ->@@ -1818,26 +1818,26 @@         ) instance (GH.HasUnion Value) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Value-        = RW_Value'void (R.Raw mut_ ())-        | RW_Value'bool (R.Raw mut_ Std_.Bool)-        | RW_Value'int8 (R.Raw mut_ Std_.Int8)-        | RW_Value'int16 (R.Raw mut_ Std_.Int16)-        | RW_Value'int32 (R.Raw mut_ Std_.Int32)-        | RW_Value'int64 (R.Raw mut_ Std_.Int64)-        | RW_Value'uint8 (R.Raw mut_ Std_.Word8)-        | RW_Value'uint16 (R.Raw mut_ Std_.Word16)-        | RW_Value'uint32 (R.Raw mut_ Std_.Word32)-        | RW_Value'uint64 (R.Raw mut_ Std_.Word64)-        | RW_Value'float32 (R.Raw mut_ Std_.Float)-        | RW_Value'float64 (R.Raw mut_ Std_.Double)-        | RW_Value'text (R.Raw mut_ Basics.Text)-        | RW_Value'data_ (R.Raw mut_ Basics.Data)-        | RW_Value'list (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))-        | RW_Value'enum (R.Raw mut_ Std_.Word16)-        | RW_Value'struct (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))-        | RW_Value'interface (R.Raw mut_ ())-        | RW_Value'anyPointer (R.Raw mut_ (Std_.Maybe Basics.AnyPointer))+    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 ->

@@ -32,9 +32,9 @@ import qualified Data.Word as Std_ import qualified Data.Int as Std_ import Prelude ((<$>), (<*>), (>>=))-constDate :: (R.Raw GH.Const Zdate)+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 GH.Const (R.List Zdate))+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)@@ -396,11 +396,11 @@         ) instance (GH.HasUnion Aircraft) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Aircraft-        = RW_Aircraft'void (R.Raw mut_ ())-        | RW_Aircraft'b737 (R.Raw mut_ B737)-        | RW_Aircraft'a320 (R.Raw mut_ A320)-        | RW_Aircraft'f16 (R.Raw mut_ F16)+    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 ->@@ -487,52 +487,52 @@         ) instance (GH.HasUnion Z) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ Z-        = RW_Z'void (R.Raw mut_ ())-        | RW_Z'zz (R.Raw mut_ Z)-        | RW_Z'f64 (R.Raw mut_ Std_.Double)-        | RW_Z'f32 (R.Raw mut_ Std_.Float)-        | RW_Z'i64 (R.Raw mut_ Std_.Int64)-        | RW_Z'i32 (R.Raw mut_ Std_.Int32)-        | RW_Z'i16 (R.Raw mut_ Std_.Int16)-        | RW_Z'i8 (R.Raw mut_ Std_.Int8)-        | RW_Z'u64 (R.Raw mut_ Std_.Word64)-        | RW_Z'u32 (R.Raw mut_ Std_.Word32)-        | RW_Z'u16 (R.Raw mut_ Std_.Word16)-        | RW_Z'u8 (R.Raw mut_ Std_.Word8)-        | RW_Z'bool (R.Raw mut_ Std_.Bool)-        | RW_Z'text (R.Raw mut_ Basics.Text)-        | RW_Z'blob (R.Raw mut_ Basics.Data)-        | RW_Z'f64vec (R.Raw mut_ (R.List Std_.Double))-        | RW_Z'f32vec (R.Raw mut_ (R.List Std_.Float))-        | RW_Z'i64vec (R.Raw mut_ (R.List Std_.Int64))-        | RW_Z'i32vec (R.Raw mut_ (R.List Std_.Int32))-        | RW_Z'i16vec (R.Raw mut_ (R.List Std_.Int16))-        | RW_Z'i8vec (R.Raw mut_ (R.List Std_.Int8))-        | RW_Z'u64vec (R.Raw mut_ (R.List Std_.Word64))-        | RW_Z'u32vec (R.Raw mut_ (R.List Std_.Word32))-        | RW_Z'u16vec (R.Raw mut_ (R.List Std_.Word16))-        | RW_Z'u8vec (R.Raw mut_ (R.List Std_.Word8))-        | RW_Z'zvec (R.Raw mut_ (R.List Z))-        | RW_Z'zvecvec (R.Raw mut_ (R.List (R.List Z)))-        | RW_Z'zdate (R.Raw mut_ Zdate)-        | RW_Z'zdata (R.Raw mut_ Zdata)-        | RW_Z'aircraftvec (R.Raw mut_ (R.List Aircraft))-        | RW_Z'aircraft (R.Raw mut_ Aircraft)-        | RW_Z'regression (R.Raw mut_ Regression)-        | RW_Z'planebase (R.Raw mut_ PlaneBase)-        | RW_Z'airport (R.Raw mut_ Airport)-        | RW_Z'b737 (R.Raw mut_ B737)-        | RW_Z'a320 (R.Raw mut_ A320)-        | RW_Z'f16 (R.Raw mut_ F16)-        | RW_Z'zdatevec (R.Raw mut_ (R.List Zdate))-        | RW_Z'zdatavec (R.Raw mut_ (R.List Zdata))-        | RW_Z'boolvec (R.Raw mut_ (R.List Std_.Bool))-        | RW_Z'datavec (R.Raw mut_ (R.List Basics.Data))-        | RW_Z'textvec (R.Raw mut_ (R.List Basics.Text))-        | RW_Z'grp (R.Raw mut_ Z'grp)-        | RW_Z'echo (R.Raw mut_ Echo)-        | RW_Z'echoBases (R.Raw mut_ EchoBases)+    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 ->@@ -1756,9 +1756,9 @@         ) instance (GH.HasUnion VoidUnion) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ VoidUnion-        = RW_VoidUnion'a (R.Raw mut_ ())-        | RW_VoidUnion'b (R.Raw mut_ ())+    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 ->

@@ -61,9 +61,9 @@         ) instance ((GH.TypeParam t)) => (GH.HasUnion (Maybe t)) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ (Maybe t)-        = RW_Maybe'nothing (R.Raw mut_ ())-        | RW_Maybe'just (R.Raw mut_ t)+    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 ->@@ -142,9 +142,9 @@ instance ((GH.TypeParam a)          ,(GH.TypeParam b)) => (GH.HasUnion (Either a b)) where     unionField  = (GH.dataField 0 0 16 0)-    data RawWhich mut_ (Either a b)-        = RW_Either'left (R.Raw mut_ a)-        | RW_Either'right (R.Raw mut_ b)+    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 ->

@@ -105,7 +105,7 @@  -- | 1 bit datatype, in the tradition of Word8, Word16 et al. newtype Word1 = Word1 { word1ToBool :: Bool }-    deriving(Ord, Eq, Enum, Bounded, Bits)+    deriving(Ord, Eq, Enum, Bounded, Bits, FiniteBits)  instance Num Word1 where     (+) = w1ThruEnum (+)

@@ -4,6 +4,7 @@ {-# LANGUAGE BangPatterns     #-} {-# LANGUAGE DataKinds        #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies     #-} module Capnp.Canonicalize     ( canonicalize@@ -53,7 +54,7 @@ {-# SPECIALIZE canonicalize :: U.Struct 'Const -> LimitT IO (M.Message ('Mut RealWorld), M.Segment ('Mut RealWorld)) #-} {-# SPECIALIZE canonicalize :: U.Struct ('Mut RealWorld) -> LimitT IO (M.Message ('Mut RealWorld), M.Segment ('Mut RealWorld)) #-} canonicalize rootStructIn = do-    let msgIn = U.message rootStructIn+    let msgIn = U.message @U.Struct rootStructIn     -- Note [Allocation strategy]     words <- totalWords msgIn     msgOut <- M.newMessage $ Just words@@ -95,7 +96,7 @@         U.setData word i structOut     for_ [0..nPtrs - 1] $ \i -> do         ptrIn <- U.getPtr i structIn-        ptrOut <- cloneCanonicalPtr ptrIn (U.message structOut)+        ptrOut <- cloneCanonicalPtr ptrIn (U.message @U.Struct structOut)         U.setPtr ptrOut i structOut  findCanonicalSectionCounts :: U.ReadCtx m mut => U.Struct mut -> m (Word16, Word16)@@ -147,19 +148,50 @@         U.ListPtr l -> U.ListPtr <$> (U.allocListPtr msgOut (U.length l) >>= copyCanonicalPtrList l)         U.ListStruct l -> U.ListStruct <$> cloneCanonicalStructList l msgOut -copyCanonicalDataList-    :: (U.RWCtx m s, M.MonadReadMessage mutIn m)-    => U.ListOf mutIn a -> U.ListOf ('Mut s) a -> m (U.ListOf ('Mut s) a)-{-# SPECIALIZE copyCanonicalDataList-    :: U.ListOf 'Const a-    -> U.ListOf ('Mut RealWorld) a-    -> LimitT IO (U.ListOf ('Mut RealWorld) a)+copyCanonicalDataList ::+    ( U.RWCtx m s+    , M.MonadReadMessage mutIn m+    , U.ListItem r+    , U.Unwrapped (U.Untyped r mutIn) ~ U.Unwrapped (U.Untyped r ('Mut s))+    )+    => U.ListOf r mutIn -> U.ListOf r ('Mut s) -> m (U.ListOf r ('Mut s))+{-+{-# SPECIALIZE copyCanonicalDataList ::+    ( U.ListItem r+    , U.Unwrapped (U.Untyped r 'Const) ~ U.Unwrapped (U.Untyped r ('Mut RealWorld))+    )+    => U.ListOf r 'Const+    -> U.ListOf r ('Mut RealWorld)+    -> LimitT IO (U.ListOf r ('Mut RealWorld))     #-}-{-# SPECIALIZE copyCanonicalDataList-    :: U.ListOf ('Mut RealWorld) a-    -> U.ListOf ('Mut RealWorld) a-    -> LimitT IO (U.ListOf ('Mut RealWorld) a)+-}+{-# SPECIALIZE copyCanonicalDataList ::+    U.ListOf ('U.Data 'U.Sz8) 'Const+    -> U.ListOf ('U.Data 'U.Sz8) ('Mut RealWorld)+    -> LimitT IO (U.ListOf ('U.Data 'U.Sz8) ('Mut RealWorld))     #-}+{-# SPECIALIZE copyCanonicalDataList ::+    U.ListOf ('U.Data 'U.Sz16) 'Const+    -> U.ListOf ('U.Data 'U.Sz16) ('Mut RealWorld)+    -> LimitT IO (U.ListOf ('U.Data 'U.Sz16) ('Mut RealWorld))+    #-}+{-# SPECIALIZE copyCanonicalDataList ::+    U.ListOf ('U.Data 'U.Sz32) 'Const+    -> U.ListOf ('U.Data 'U.Sz32) ('Mut RealWorld)+    -> LimitT IO (U.ListOf ('U.Data 'U.Sz32) ('Mut RealWorld))+    #-}+{-# SPECIALIZE copyCanonicalDataList ::+    U.ListOf ('U.Data 'U.Sz64) 'Const+    -> U.ListOf ('U.Data 'U.Sz64) ('Mut RealWorld)+    -> LimitT IO (U.ListOf ('U.Data 'U.Sz64) ('Mut RealWorld))+    #-}+{-# SPECIALIZE copyCanonicalDataList ::+    ( U.ListItem r+    )+    => U.ListOf r ('Mut RealWorld)+    -> U.ListOf r ('Mut RealWorld)+    -> LimitT IO (U.ListOf r ('Mut RealWorld))+    #-} copyCanonicalDataList listIn listOut = do     for_ [0..U.length listIn - 1] $ \i -> do         value <- U.index i listIn@@ -168,40 +200,40 @@  copyCanonicalPtrList     :: (U.RWCtx m s, M.MonadReadMessage mutIn m)-    => U.ListOf mutIn (Maybe (U.Ptr mutIn))-    -> U.ListOf ('Mut s) (Maybe (U.Ptr ('Mut s)))-    -> m (U.ListOf ('Mut s) (Maybe (U.Ptr ('Mut s))))+    => U.ListOf ('U.Ptr 'Nothing) mutIn+    -> U.ListOf ('U.Ptr 'Nothing) ('Mut s)+    -> m (U.ListOf ('U.Ptr 'Nothing) ('Mut s)) {-# SPECIALIZE copyCanonicalPtrList-    :: U.ListOf 'Const (Maybe (U.Ptr 'Const))-    -> U.ListOf ('Mut RealWorld) (Maybe (U.Ptr ('Mut RealWorld)))-    -> LimitT IO (U.ListOf ('Mut RealWorld) (Maybe (U.Ptr ('Mut RealWorld))))+    :: U.ListOf ('U.Ptr 'Nothing) 'Const+    -> U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld)+    -> LimitT IO (U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld))     #-} {-# SPECIALIZE copyCanonicalPtrList-    :: U.ListOf ('Mut RealWorld) (Maybe (U.Ptr ('Mut RealWorld)))-    -> U.ListOf ('Mut RealWorld) (Maybe (U.Ptr ('Mut RealWorld)))-    -> LimitT IO (U.ListOf ('Mut RealWorld) (Maybe (U.Ptr ('Mut RealWorld))))+    :: U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld)+    -> U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld)+    -> LimitT IO (U.ListOf ('U.Ptr 'Nothing) ('Mut RealWorld))     #-} copyCanonicalPtrList listIn listOut = do     for_ [0..U.length listIn - 1] $ \i -> do         ptrIn <- U.index i listIn-        ptrOut <- cloneCanonicalPtr ptrIn (U.message listOut)+        ptrOut <- cloneCanonicalPtr ptrIn (U.message @(U.ListOf ('U.Ptr 'Nothing)) listOut)         U.setIndex ptrOut i listOut     pure listOut  cloneCanonicalStructList     :: (U.RWCtx m s, M.MonadReadMessage mutIn m)-    => U.ListOf mutIn (U.Struct mutIn)+    => U.ListOf ('U.Ptr ('Just 'U.Struct)) mutIn     -> M.Message ('Mut s)-    -> m (U.ListOf ('Mut s) (U.Struct ('Mut s)))+    -> m (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s)) {-# SPECIALIZE cloneCanonicalStructList-    :: U.ListOf 'Const (U.Struct 'Const)+    :: U.ListOf ('U.Ptr ('Just ('U.Struct))) 'Const     -> M.Message ('Mut RealWorld)-    -> LimitT IO (U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld)))+    -> LimitT IO (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld))     #-} {-# SPECIALIZE cloneCanonicalStructList-    :: U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld))+    :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld)     -> M.Message ('Mut RealWorld)-    -> LimitT IO (U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld)))+    -> LimitT IO (U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld))     #-} cloneCanonicalStructList listIn msgOut = do     (nWords, nPtrs) <- findCanonicalListSectionCounts listIn@@ -211,17 +243,17 @@  copyCanonicalStructList     :: (U.RWCtx m s, M.MonadReadMessage mutIn m)-    => U.ListOf mutIn (U.Struct mutIn)-    -> U.ListOf ('Mut s) (U.Struct ('Mut s))+    => U.ListOf ('U.Ptr ('Just 'U.Struct)) mutIn+    -> U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut s)     -> m () {-# SPECIALIZE copyCanonicalStructList-    :: U.ListOf 'Const (U.Struct 'Const)-    -> U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld))+    :: U.ListOf ('U.Ptr ('Just 'U.Struct)) 'Const+    -> U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld)     -> LimitT IO ()     #-} {-# SPECIALIZE copyCanonicalStructList-    :: U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld))-    -> U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld))+    :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld)+    -> U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld)     -> LimitT IO ()     #-} copyCanonicalStructList listIn listOut =@@ -232,12 +264,12 @@  findCanonicalListSectionCounts     :: U.ReadCtx m mut-    => U.ListOf mut (U.Struct mut) -> m (Word16, Word16)+    => U.ListOf ('U.Ptr ('Just 'U.Struct)) mut -> m (Word16, Word16) {-# SPECIALIZE findCanonicalListSectionCounts-    :: U.ListOf 'Const (U.Struct 'Const) -> LimitT IO (Word16, Word16)+    :: U.ListOf ('U.Ptr ('Just 'U.Struct)) 'Const -> LimitT IO (Word16, Word16)     #-} {-# SPECIALIZE findCanonicalListSectionCounts-    :: U.ListOf ('Mut RealWorld) (U.Struct ('Mut RealWorld)) -> LimitT IO (Word16, Word16)+    :: U.ListOf ('U.Ptr ('Just 'U.Struct)) ('Mut RealWorld) -> LimitT IO (Word16, Word16)     #-} findCanonicalListSectionCounts list = go 0 0 0 where     go i !nWords !nPtrs

@@ -1,7 +1,9 @@-{-# LANGUAGE DataKinds        #-}-{-# LANGUAGE ExplicitForAll   #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies     #-}+{-# 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).@@ -43,9 +45,8 @@ import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy    as LBS -import Capnp.Message     (Mutability(..))+import Capnp.Mutability  (Mutability(..), freeze) import Capnp.New.Classes (Parse(encode, parse))-import Data.Mutable      (freeze)  import qualified Capnp.Message as M import qualified Capnp.Repr    as R@@ -97,7 +98,7 @@ lbsToMsg = bsToMsg . LBS.toStrict  -- | Get the root pointer of a message, wrapped as a 'R.Raw'.-msgToRaw :: forall a m mut. (U.ReadCtx m mut, R.IsStruct a) => M.Message mut -> m (R.Raw mut a)+msgToRaw :: forall a m mut. (U.ReadCtx m mut, R.IsStruct a) => M.Message mut -> m (R.Raw a mut) msgToRaw = fmap R.Raw . U.rootPtr  -- | Get the root pointer of a message, as a parsed ADT.@@ -105,7 +106,7 @@ msgToParsed msg = msgToRaw msg >>= parse  -- | Like 'msgToRaw', but takes a (strict) bytestring.-bsToRaw :: forall a m. (U.ReadCtx m 'Const, R.IsStruct a) => BS.ByteString -> m (R.Raw 'Const a)+bsToRaw :: forall a m. (U.ReadCtx m 'Const, R.IsStruct a) => BS.ByteString -> m (R.Raw a 'Const) bsToRaw bs = bsToMsg bs >>= msgToRaw  -- | Like 'msgToParsed', but takes a (strict) bytestring.@@ -113,7 +114,7 @@ bsToParsed bs = bsToRaw bs >>= parse  -- | Like 'msgToRaw', but takes a (lazy) bytestring.-lbsToRaw :: forall a m. (U.ReadCtx m 'Const, R.IsStruct a) => LBS.ByteString -> m (R.Raw 'Const a)+lbsToRaw :: forall a m. (U.ReadCtx m 'Const, R.IsStruct a) => LBS.ByteString -> m (R.Raw a 'Const) lbsToRaw = bsToRaw . LBS.toStrict  -- | Like 'msgToParsed', but takes a (lazzy) bytestring.@@ -122,7 +123,7 @@  -- | Serialize the parsed form of a struct into its 'R.Raw' form, and make it the root -- of its message.-parsedToRaw :: forall a m pa s. (U.RWCtx m s, R.IsStruct a, Parse a pa) => pa -> m (R.Raw ('Mut s) a)+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@@ -134,7 +135,7 @@ 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 root+    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

@@ -80,11 +80,11 @@      -- | Concrete view into a union embedded in a message. This will be a sum     -- type with other 'Raw' values as arguments.-    data RawWhich (mut :: M.Mutability) a+    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 mut a -> m (RawWhich mut a)+    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) 

@@ -76,19 +76,19 @@         ( R.IsStruct a         , U.ReadCtx m mut         )-    => F.Variant k a b -> R.Raw mut a -> m (R.Raw mut b)+    => 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 ('Mut s) a)+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 'Const a -> m a+    => 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 ('Mut s) a)+    => 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@@ -98,9 +98,9 @@ -- 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 'Const a+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 root)+        >>= R.fromPtr @(R.PtrReprFor (R.ReprFor a)) (U.message @U.Struct root)         <&> R.Raw

@@ -15,8 +15,8 @@ import           Capnp.Repr.Methods import qualified Capnp.Untyped        as U -parseCap :: (R.IsCap a, U.ReadCtx m 'Const) => R.Raw 'Const a -> m (Client a)+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 ('Mut s) a)+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

@@ -122,19 +122,19 @@  -- | 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 'Const a)+hGetRaw :: R.IsStruct a => Handle -> WordCount -> IO (R.Raw a 'Const) hGetRaw h limit = do     msg <- M.hGetMsg h limit     evalLimitT limit $ msgToRaw msg  -- | Read a struct from stdin using the supplied read limit, -- and return its root pointer.-getRaw :: R.IsStruct a => WordCount -> IO (R.Raw 'Const a)+getRaw :: R.IsStruct a => WordCount -> IO (R.Raw a 'Const) getRaw = hGetRaw stdin  -- | Read a struct from the socket using the supplied read limit, -- and return its root pointer.-sGetRaw :: R.IsStruct a => Socket -> WordCount -> IO (R.Raw 'Const a)+sGetRaw :: R.IsStruct a => Socket -> WordCount -> IO (R.Raw a 'Const) sGetRaw socket limit = do     msg <- sGetMsg socket limit     evalLimitT limit $ msgToRaw msg

@@ -44,7 +44,6 @@     -- * Reading data from messages     , MonadReadMessage(..)     , getSegment-    , getWord     , getCap     , getCapTable @@ -59,7 +58,6 @@      -- ** Modifying messages     , setSegment-    , setWord     , write     , setCap     , appendCap@@ -85,7 +83,6 @@ import Control.Monad.Writer      (execWriterT, tell) import Data.ByteString.Internal  (ByteString(..)) import Data.Bytes.Get            (getWord32le, runGetS)-import Data.Kind                 (Type) import Data.Maybe                (fromJust) import Data.Primitive            (MutVar, newMutVar, readMutVar, writeMutVar) import Data.Word                 (Word32, Word64, byteSwap64)@@ -102,8 +99,8 @@  import Capnp.Address        (WordAddr(..)) import Capnp.Bits           (WordCount(..), hi, lo)+import Capnp.Mutability     (MaybeMutable(..), Mutability(..)) import Capnp.TraversalLimit (LimitT, MonadLimit(invoice), evalLimitT)-import Data.Mutable         (Mutable(..)) import Internal.AppendVec   (AppendVec)  import qualified Capnp.Errors       as E@@ -129,13 +126,6 @@ maxCaps :: Int maxCaps = 16 * 1024 ---- | 'Mutability' is used as a type parameter (with the DataKinds extension)--- to indicate the mutability of some values in this library; 'Const' denotes--- an immutable value, while @'Mut' s@ denotes a value that can be mutated--- in the scope of the state token @s@.-data Mutability = Const | Mut Type- -- | A pointer to a location in a message. This encodes the same -- information as a 'WordAddr', but also includes direct references -- to the segment and message, which can improve performance in very@@ -147,26 +137,24 @@     -- - pSegment is in pMessage.     { pMessage :: !(Message mut)     , pSegment :: !(Segment mut)-    , pAddr    :: !WordAddr+    , pAddr    :: {-# UNPACK #-} !WordAddr     }  -- | A Cap'n Proto message, parametrized over its mutability.-data Message (mut :: Mutability) where-    MsgConst :: !ConstMsg -> Message 'Const-    MsgMut :: !(MutMsg s) -> Message ('Mut s)+data family Message (mut :: Mutability) -instance Eq (Message mut) where-    (MsgConst x) == (MsgConst y) = x == y-    (MsgMut x) == (MsgMut y)     = x == y+newtype instance Message 'Const = MsgConst ConstMsg+    deriving(Eq)+newtype instance Message ('Mut s) = MsgMut (MutMsg s)+    deriving(Eq)  -- | A segment in a Cap'n Proto message.-data Segment (mut :: Mutability) where-    SegConst :: !ConstSegment -> Segment 'Const-    SegMut :: !(MutSegment s) -> Segment ('Mut s)+data family Segment (mut :: Mutability) -instance Eq (Segment mut)  where-    (SegConst x) == (SegConst y) = x == y-    (SegMut x) == (SegMut y)     = x == y+newtype instance Segment 'Const = SegConst ConstSegment+    deriving(Eq)+newtype instance Segment ('Mut s) = SegMut (MutSegment s)+    deriving(Eq)  data MutSegment s = MutSegment     { vec  :: SMV.MVector s Word64@@ -241,14 +229,6 @@         then pure nullClient         else msg `internalGetCap` i --- | @'getWord' msg addr@ returns the word at @addr@ within @msg@. It throws a--- 'E.BoundsError' if the address is out of bounds.-getWord :: (MonadThrow m, MonadReadMessage mut m) => Message mut -> WordAddr -> m Word64-getWord msg WordAt{wordIndex=i, segIndex} = do-    seg <- getSegment msg segIndex-    checkIndex i =<< numWords seg-    seg `read` i- -- | @'setSegment' message index segment@ sets the segment at the given index -- in the message. It throws a 'E.BoundsError' if the address is out of bounds. setSegment :: WriteCtx m s => Message ('Mut s) -> Int -> Segment ('Mut s) -> m ()@@ -256,15 +236,6 @@     checkIndex i =<< numSegs msg     internalSetSeg msg i seg --- | @'setWord' message address value@ sets the word at @address@ in the--- message to @value@. If the address is not valid in the message, a--- 'E.BoundsError' will be thrown.-setWord :: WriteCtx m s => Message ('Mut s) -> WordAddr -> Word64 -> m ()-setWord msg WordAt{wordIndex=i, segIndex} val = do-    seg <- getSegment msg segIndex-    checkIndex i =<< numWords seg-    write seg i val- -- | @'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.@@ -464,6 +435,7 @@ -- 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) @@ -492,6 +464,7 @@ -- index of the segment in which to allocate the data. Returns 'Nothing' if there is -- insufficient space in that segment.. 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 ...) <- ...@@ -518,6 +491,7 @@ -- 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 #-} alloc msg size = do     when (size > maxSegmentSize) $         throwM E.SizeError@@ -567,10 +541,7 @@     , constCaps = V.empty     } --instance Thaw (Segment 'Const) where-    type Mutable s (Segment 'Const) = Segment ('Mut s)-+instance MaybeMutable Segment where     thaw         = thawSeg   SV.thaw     unsafeThaw   = thawSeg   SV.unsafeThaw     freeze       = freezeSeg SV.freeze@@ -596,9 +567,7 @@     WordCount len <- readMutVar used     SegConst .ConstSegment <$> freeze (SMV.take len vec) -instance Thaw (Message 'Const) where-    type Mutable s (Message 'Const) = Message ('Mut s)-+instance MaybeMutable Message where     thaw         = thawMsg   thaw         V.thaw     unsafeThaw   = thawMsg   unsafeThaw   V.unsafeThaw     freeze       = freezeMsg freeze       V.freeze

@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE TypeFamilies   #-}+module Capnp.Mutability+    ( Mutability(..)+    , MaybeMutable(..)+    , create+    , createT+    ) where++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+-- an immutable value, while @'Mut' s@ denotes a value that can be mutated+-- in the scope of the state token @s@.+data Mutability = Const | Mut Type++-- | 'MaybeMutable' relates mutable and immutable versions of a type.+class MaybeMutable (f :: Mutability -> *) where+    -- | 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)++    -- | 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++-- | Create and freeze a mutable value, safely, without doing a full copy.+-- internally, 'create' calls unsafeFreeze, but it cannot be directly used to+-- violate referential transparency, as the value is not available to the+-- caller after freezing.+create :: MaybeMutable f => (forall s. ST s (f ('Mut s))) -> f 'Const+create st = runST (st >>= unsafeFreeze)++-- | Like 'create', but the result is wrapped in an instance of 'Traversable'.+createT :: (Traversable t, MaybeMutable f) => (forall s. ST s (t (f ('Mut s)))) -> t (f 'Const)+createT st = runST (st >>= traverse unsafeFreeze)

@@ -46,8 +46,8 @@         , U.ReadCtx m mut         )     => F.Field k a b-    -> R.Raw mut a-    -> m (R.Raw mut 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@@ -65,9 +65,9 @@         :: forall pr.         ( R.ReprFor b ~ 'R.Ptr pr         , R.IsPtrRepr pr-        ) => Maybe (U.Ptr mut) -> m (R.Raw mut b)+        ) => Maybe (U.Ptr mut) -> m (R.Raw b mut)     readPtrField ptr =-        R.Raw <$> R.fromPtr @pr (U.message struct) ptr+        R.Raw <$> R.fromPtr @pr (U.message @U.Struct struct) ptr  -- | Return whether the specified field is present. Only applicable for pointer -- fields.@@ -75,7 +75,7 @@     ( U.ReadCtx m mut     , R.IsStruct a     , R.IsPtr b-    ) => F.Field 'F.Slot a b -> R.Raw mut a -> m Bool+    ) => 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 @@ -91,7 +91,7 @@         , C.Parse b bp         )     => F.Field 'F.Slot a b-    -> R.Raw 'Const a+    -> R.Raw a 'Const     -> bp getField field struct =     fromJust $ evalLimitT maxBound $@@ -103,7 +103,7 @@     forall a b m s.     ( R.IsStruct a     , U.RWCtx m s-    ) => F.Field 'F.Slot a b -> R.Raw ('Mut s) b -> R.Raw ('Mut s) a -> m ()+    ) => 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 ->@@ -119,7 +119,7 @@         :: forall pr.         ( R.ReprFor b ~ 'R.Ptr pr         , R.IsPtrRepr pr-        ) => Word16 -> R.UntypedPtr ('Mut s) pr -> U.Struct ('Mut s) -> m ()+        ) => 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 @@ -141,9 +141,9 @@     ( R.IsStruct a     , C.Allocate b     , U.RWCtx m s-    ) => F.Field 'F.Slot a b -> C.AllocHint b -> R.Raw ('Mut s) a -> m (R.Raw ('Mut s) b)+    ) => 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 parent)+    value <- C.new @b hint (U.message @(R.Raw a) parent)     setField field value parent     pure value @@ -153,9 +153,9 @@     ( R.IsStruct a     , C.Parse b bp     , U.RWCtx m s-    ) => F.Field 'F.Slot a b -> bp -> R.Raw ('Mut s) a -> m ()+    ) => F.Field 'F.Slot a b -> bp -> R.Raw a ('Mut s) -> m () encodeField field parsed struct = do-    encoded <- C.encode (U.message struct) parsed+    encoded <- C.encode (U.message @(R.Raw a) struct) parsed     setField field encoded struct  -- | parse a struct's field and return its parsed form.@@ -163,7 +163,7 @@     ( R.IsStruct a     , C.Parse b bp     , U.ReadCtx m 'Const-    ) => F.Field k a b -> R.Raw 'Const a -> m bp+    ) => F.Field k a b -> R.Raw a 'Const -> m bp parseField field raw =     readField field raw >>= C.parse @@ -174,7 +174,7 @@     :: forall a b m s.     ( F.HasUnion a     , U.RWCtx m s-    ) => F.Variant 'F.Slot a b -> R.Raw ('Mut s) a -> R.Raw ('Mut s) b -> m ()+    ) => 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@@ -187,7 +187,7 @@     ( F.HasUnion a     , C.Parse b bp     , U.RWCtx m s-    ) => F.Variant 'F.Slot a b -> bp -> R.Raw ('Mut s) a -> m ()+    ) => 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@@ -197,27 +197,27 @@ -- 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 ('Mut s) a -> m (R.Raw ('Mut s) b)+    => 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 mut a -> R.Raw mut (F.Which a)+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 mut (F.Which a) -> R.Raw mut a+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 mut a -> m (F.RawWhich mut a)+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 mut (F.Which a) -> m (F.RawWhich mut a)+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

@@ -76,7 +76,7 @@ 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 'M.Const AnyPointer)+        Just _  -> Just <$> C.parse (R.Raw ptr :: R.Raw AnyPointer 'M.Const)      encode msg value = R.Raw <$> case value of         Nothing -> pure Nothing@@ -158,7 +158,7 @@         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 raw) value+            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@@ -261,12 +261,12 @@  -- | Return the underlying buffer containing the text. This does not include the -- null terminator.-textBuffer :: MonadThrow m => R.Raw mut Text -> m (R.Raw mut Data)+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 'M.Const Text -> m BS.ByteString+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

@@ -69,18 +69,19 @@ -- * @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 'Const t -> m p+    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 ('Mut s) t)+    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 ('Mut s) t)+        => 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. --@@ -92,6 +93,7 @@      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.@@ -101,7 +103,8 @@     , 'R.Ptr ('Just r) ~ R.ReprFor a     , U.RWCtx m s     )-    => R.AllocHint r -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)+    => 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... @@ -112,7 +115,7 @@     -- ^ 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 ('Mut s) a)+    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 ::@@ -120,17 +123,18 @@         , R.Allocate pr         , AllocHint a ~ R.AllocHint pr         , U.RWCtx m s-        ) => AllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) a)+        ) => 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 ('Mut s) (R.List a))+    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@@ -138,12 +142,14 @@         , r ~ 'R.List ('Just lr)         , R.Allocate r         , R.AllocHint r ~ ListAllocHint a-        ) => ListAllocHint a -> M.Message ('Mut s) -> m (R.Raw ('Mut s) (R.List 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@@ -155,13 +161,15 @@  -- | 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 ('Mut s) a)+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 ('Mut s) (R.List a))+    => 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@@ -170,7 +178,7 @@ -- | 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 ('Mut s) t -> p -> m ()+    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.@@ -179,6 +187,7 @@  -- | 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.@@ -197,27 +206,31 @@ -- | 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 ('Mut s) 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 ('Mut s) a -> m ()+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 mut (R.ReprFor a) ~ a, U.ReadCtx m mut) => R.Raw mut a -> m a-parseId = pure . R.fromRaw+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 (R.Untyped mut (R.ReprFor a))+    , Integral (U.Unwrapped (R.Untyped (R.ReprFor a) mut))     , U.ReadCtx m mut-    ) => R.Raw mut a -> m a+    ) => R.Raw a mut -> m a+{-# INLINABLE parseInt #-} parseInt = pure . fromIntegral . R.fromRaw  instance Parse Float Float where@@ -244,6 +257,8 @@     ( 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     )@@ -253,12 +268,15 @@     MarshalElementReprConstraints 'R.ListComposite  a ap = Marshal a ap     MarshalElementReprConstraints ('R.ListNormal r) a ap = Parse a ap -class MarshalElementByRepr (lr :: R.ListRepr) where+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 ('Mut s) (R.List a) -> Int -> ap -> m ()+        ) => R.Raw (R.List a) ('Mut s) -> Int -> ap -> m ()  -- | An instance @'Super' p c@ indicates that the interface @c@ extends -- the interface @p@.@@ -268,17 +286,26 @@     marshalElementByRepr rawList i parsed = do         rawElt <- R.index i rawList         marshalInto rawElt parsed+    {-# INLINABLE marshalElementByRepr #-} -instance MarshalElementByRepr ('R.ListNormal l) where-    marshalElementByRepr rawList i parsed = do-        rawElt <- encode (U.message rawList) parsed+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 ('Mut s) (R.List a) -> Int -> ap -> m ()+  ) => 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@@ -286,9 +313,11 @@      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@@ -297,21 +326,26 @@ -- be something else. data family Parsed a -instance (Default (R.Raw 'Const a), Parse a (Parsed a)) => Default (Parsed a) where+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@@ -319,6 +353,7 @@                  instance EstimateListAlloc $ty $ty where                     estimateListAlloc = V.length+                    {-# INLINABLE estimateListAlloc #-}             |]          nameTy name = pure (TH.ConT name)@@ -352,42 +387,44 @@  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.-instance IsWord Int8 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Int16 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Int32 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Int64 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Word8 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Word16 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Word32 where-    fromWord = fromIntegral-    toWord = fromIntegral-instance IsWord Word64 where-    fromWord = fromIntegral-    toWord = fromIntegral+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 #-}

@@ -61,8 +61,8 @@  -- | Type alias for a handler for a particular rpc method. type MethodHandler p r-    = R.Raw 'Const p-    -> Fulfiller (R.Raw 'Const r)+    = R.Raw p 'Const+    -> Fulfiller (R.Raw r 'Const)     -> IO ()  -- | Type alias for a handler for an untyped RPC method.@@ -198,7 +198,7 @@ -- parameters and results. handleRaw     :: (R.IsStruct p, R.IsStruct r)-    => (R.Raw 'Const p -> IO (R.Raw 'Const r)) -> MethodHandler p r+    => (R.Raw p 'Const -> IO (R.Raw r 'Const)) -> MethodHandler p r handleRaw handler param = propagateExceptions $ \f ->     handler param >>= fulfill f 

@@ -43,10 +43,14 @@     , PtrReprFor      -- * Relating the representations of lists & their elements.+    , Element(..)     , ElemRepr     , ListReprFor-    , Element(..) +    -- * Working with pointers+    , IsPtrRepr(..)+    , IsListPtrRepr(..)+     -- * Working with wire-encoded values     , Raw(..) @@ -56,10 +60,6 @@     , index     , setIndex -    -- * Working with pointers-    , IsPtrRepr(..)-    , IsListPtrRepr(..)-     -- * Allocating values     , Allocate(..) @@ -71,109 +71,36 @@  import Prelude hiding (length) -import qualified Capnp.Errors         as E import           Capnp.Message        (Mutability(..)) import qualified Capnp.Message        as M import           Capnp.TraversalLimit (evalLimitT)+import           Capnp.Untyped+    ( Allocate(..)+    , DataSz(..)+    , ElemRepr+    , Element(..)+    , IsListPtrRepr(..)+    , IsPtrRepr(..)+    , ListRepr(..)+    , ListReprFor+    , NormalListRepr(..)+    , PtrRepr(..)+    , Repr(..)+    , Untyped+    , UntypedData+    , UntypedList+    , UntypedPtr+    , UntypedSomeList+    , UntypedSomePtr+    ) import qualified Capnp.Untyped        as U-import           Control.Monad.Catch  (MonadThrow(..)) import           Data.Default         (Default(..)) import           Data.Int import           Data.Kind            (Type) import           Data.Maybe           (fromJust) import           Data.Word import           GHC.Generics         (Generic)-import qualified Language.Haskell.TH  as TH --- | 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-    ListData :: DataSz -> NormalListRepr-    ListPtr :: 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)---- | @Untyped mut r@ is an untyped value with representation @r@ stored in--- a message with mutability @mut@.-type family Untyped (mut :: Mutability) (r :: Repr) :: Type where-    Untyped mut ('Data sz) = UntypedData sz-    Untyped mut ('Ptr ptr) = UntypedPtr mut 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 (mut :: Mutability) (r :: Maybe PtrRepr) :: Type where-    UntypedPtr mut 'Nothing = Maybe (U.Ptr mut)-    UntypedPtr mut ('Just r) = UntypedSomePtr mut r---- | Like 'UntypedPtr', but doesn't allow AnyPointers.-type family UntypedSomePtr (mut :: Mutability) (r :: PtrRepr) :: Type where-    UntypedSomePtr mut 'Struct = U.Struct mut-    UntypedSomePtr mut 'Cap = U.Cap mut-    UntypedSomePtr mut ('List r) = UntypedList mut r---- | Like 'Untyped', but for lists only.-type family UntypedList (mut :: Mutability) (r :: Maybe ListRepr) :: Type where-    UntypedList mut 'Nothing = U.List mut-    UntypedList mut ('Just r) = UntypedSomeList mut r---- | Like 'UntypedList', but doesn't allow AnyLists.-type family UntypedSomeList (mut :: Mutability) (r :: ListRepr) :: Type where-    UntypedSomeList mut r = U.ListOf mut (Untyped mut (ElemRepr r))----- | 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 :: U.RWCtx m s => M.Message ('Mut s) -> AllocHint r -> m (UntypedSomePtr ('Mut s) r)- -- | @'ReprFor' a@ denotes the Cap'n Proto wire represent of the type @a@. type family ReprFor (a :: Type) :: Repr @@ -190,11 +117,11 @@ type instance ReprFor Float = 'Data 'Sz32 type instance ReprFor Double = 'Data 'Sz64 -type instance ReprFor (U.ListOf mut a) = ReprFor (List a) 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))))) @@ -203,207 +130,61 @@ type family PtrReprFor (r :: Repr) :: Maybe PtrRepr where     PtrReprFor ('Ptr pr) = pr --- | @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 'ListPtr) = 'Ptr 'Nothing-    ElemRepr ('ListNormal ('ListData 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 ('ListData sz)-    ListReprFor ('Ptr ('Just 'Struct)) = 'ListComposite-    ListReprFor ('Ptr a) = 'ListNormal 'ListPtr---- | '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. U.ReadCtx m mut-        => M.Message mut-        -> Untyped mut (ElemRepr (ListReprFor r))-        -> m (Untyped mut r)-    toElement :: Untyped mut r -> Untyped mut (ElemRepr (ListReprFor r))--instance Element ('Data sz) where-    fromElement _ = pure-    toElement = id-instance Element ('Ptr ('Just 'Struct)) where-    fromElement _ = pure-    toElement = id-instance Element ('Ptr 'Nothing) where-    fromElement _ = pure-    toElement = id-instance Element ('Ptr ('Just 'Cap)) where-    fromElement = fromPtr @('Just 'Cap)-    toElement = Just . U.PtrCap-instance IsPtrRepr ('Just ('List a)) => Element ('Ptr ('Just ('List a))) where-    fromElement = fromPtr @('Just ('List a))-    toElement = toPtr @('Just ('List a))- -- | A @'Raw' mut a@ is an @a@ embedded in a capnproto message with mutability -- @mut@.-newtype Raw (mut :: Mutability) (a :: Type)-    = Raw { fromRaw :: Untyped mut (ReprFor a) }+newtype Raw (a :: Type ) (mut :: Mutability)+    = Raw { fromRaw :: U.Unwrapped (Untyped (ReprFor a) mut) } -deriving instance Show (Untyped mut (ReprFor a)) => Show (Raw mut a)-deriving instance Read (Untyped mut (ReprFor a)) => Read (Raw mut a)-deriving instance Eq (Untyped mut (ReprFor a)) => Eq (Raw mut a)-deriving instance Generic (Untyped mut (ReprFor a)) => Generic (Raw mut a)+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)))+    )+ -- | Get the length of a capnproto list.-length :: Raw mut (List a) -> Int+length :: ListElem a => Raw (List a) mut -> Int+{-# INLINE length #-} 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-    , Element (ReprFor a)-    ) => Int -> Raw mut (List a) -> m (Raw mut a)-index i (Raw l) =-    Raw <$> (U.index i l >>= fromElement @(ReprFor a) @m @mut (U.message l))+    , 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+    elt <- U.index i l+    fromElement+        @(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-    , Element (ReprFor a)-    ) => Raw ('Mut s) a -> Int -> Raw ('Mut s) (List a) -> m ()+    , 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 mut (ReprFor a)) mut => U.HasMessage (Raw mut a) mut where-    message (Raw r) = U.message r-instance U.MessageDefault (Untyped mut (ReprFor a)) mut => U.MessageDefault (Raw mut a) mut where-    messageDefault msg = Raw <$> U.messageDefault msg--instance U.MessageDefault (Raw 'Const a) 'Const => Default (Raw 'Const a) where-    def = fromJust $ evalLimitT maxBound $ U.messageDefault M.empty---- | Operations on types with pointer representations.-class IsPtrRepr (r :: Maybe PtrRepr) where-    toPtr :: Untyped mut ('Ptr r) -> Maybe (U.Ptr mut)-    -- ^ Convert an untyped value of this representation to an AnyPointer.-    fromPtr :: U.ReadCtx m mut => M.Message mut -> Maybe (U.Ptr mut) -> m (Untyped mut ('Ptr r))-    -- ^ Extract a value with this representation from an AnyPointer, failing-    -- if the pointer is the wrong type for this representation.--instance IsPtrRepr 'Nothing where-    toPtr p = p-    fromPtr _ p = pure p--instance IsPtrRepr ('Just 'Struct) where-    toPtr s = Just (U.PtrStruct s)-    fromPtr msg Nothing              = U.messageDefault msg-    fromPtr _ (Just (U.PtrStruct s)) = pure s-    fromPtr _ _                      = expected "pointer to struct"-instance IsPtrRepr ('Just 'Cap) where-    toPtr c = Just (U.PtrCap c)-    fromPtr _ Nothing             = expected "pointer to capability"-    fromPtr _ (Just (U.PtrCap c)) = pure c-    fromPtr _ _                   = expected "pointer to capability"-instance IsPtrRepr ('Just ('List 'Nothing)) where-    toPtr l = Just (U.PtrList l)-    fromPtr _ Nothing              = expected "pointer to list"-    fromPtr _ (Just (U.PtrList l)) = pure l-    fromPtr _ (Just _)             = expected "pointer to list"-instance IsListPtrRepr r => IsPtrRepr ('Just ('List ('Just r))) where-    toPtr l = Just (U.PtrList (rToList @r l))-    fromPtr msg Nothing            = rFromListMsg @r msg-    fromPtr _ (Just (U.PtrList l)) = rFromList @r l-    fromPtr _ (Just _)             = expected "pointer to list"---- | Operations on types with list representations.-class IsListPtrRepr (r :: ListRepr) where-    rToList :: UntypedSomeList mut r -> U.List mut-    -- ^ Convert an untyped value of this representation to an AnyList.-    rFromList :: U.ReadCtx m mut => U.List mut -> m (UntypedSomeList mut r)-    -- ^ Extract a value with this representation from an AnyList, failing-    -- if the list is the wrong type for this representation.-    rFromListMsg :: U.ReadCtx m mut => M.Message mut -> m (UntypedSomeList mut r)-    -- ^ 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--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 = U.messageDefault-            |]-    concat <$> traverse mkIsListPtrRepr-        [ ( [t| 'ListNormal ('ListData 'Sz0) |]-          , 'U.List0-          , "List(Void)"-          )-        , ( [t| 'ListNormal ('ListData 'Sz1) |]-          , 'U.List1-          , "List(Bool)"-          )-        , ( [t| 'ListNormal ('ListData 'Sz8) |]-          , 'U.List8-          , "List(UInt8)"-          )-        , ( [t| 'ListNormal ('ListData 'Sz16) |]-          , 'U.List16-          , "List(UInt16)"-          )-        , ( [t| 'ListNormal ('ListData 'Sz32) |]-          , 'U.List32-          , "List(UInt32)"-          )-        , ( [t| 'ListNormal ('ListData 'Sz64) |]-          , 'U.List64-          , "List(UInt64)"-          )-        , ( [t| 'ListNormal 'ListPtr |]-          , 'U.ListPtr-          , "List(AnyPointer)"-          )-        , ( [t| 'ListComposite |]-          , 'U.ListStruct-          , "composite list"-          )-        ]--instance Allocate 'Struct where-    type AllocHint 'Struct = (Word16, Word16)-    alloc msg = uncurry (U.allocStruct msg)-instance Allocate 'Cap where-    type AllocHint 'Cap = M.Client-    alloc = U.appendCap-instance Allocate ('List ('Just 'ListComposite)) where-    type AllocHint ('List ('Just 'ListComposite)) = (Int, AllocHint 'Struct)-    alloc msg (len, (nWords, nPtrs)) = U.allocCompositeList msg nWords nPtrs len-instance AllocateNormalList r => Allocate ('List ('Just ('ListNormal r))) where-    type AllocHint ('List ('Just ('ListNormal r))) = Int-    alloc = allocNormalList @r+instance U.HasMessage (Untyped (ReprFor a)) => U.HasMessage (Raw a) where+    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 -class AllocateNormalList (r :: NormalListRepr) where-    allocNormalList :: U.RWCtx m s => M.Message ('Mut s) -> Int -> m (UntypedSomeList ('Mut s) ('ListNormal r))-instance AllocateNormalList ('ListData 'Sz0) where allocNormalList = U.allocList0-instance AllocateNormalList ('ListData 'Sz1) where allocNormalList = U.allocList1-instance AllocateNormalList ('ListData 'Sz8) where allocNormalList = U.allocList8-instance AllocateNormalList ('ListData 'Sz16) where allocNormalList = U.allocList16-instance AllocateNormalList ('ListData 'Sz32) where allocNormalList = U.allocList32-instance AllocateNormalList ('ListData 'Sz64) where allocNormalList = U.allocList64-instance AllocateNormalList 'ListPtr where allocNormalList = U.allocListPtr+instance U.MessageDefault (Raw a) => Default (Raw a 'Const) where+    def = fromJust $ evalLimitT maxBound $ U.messageDefault @(Raw a) M.empty   -- | Constraint that @a@ is a struct type.

@@ -87,17 +87,17 @@ callB     :: (AsClient f, R.IsCap c, R.IsStruct p, MonadSTM m)     => Method c p r-    -> (forall s. PureBuilder s (R.Raw ('Mut s) p))+    -> (forall s. PureBuilder s (R.Raw p ('Mut s)))     -> f c     -> m (Pipeline r) callB method buildRaw c = liftSTM $ do-    (params :: R.Raw 'Const a) <- R.Raw <$> createPure maxBound (R.fromRaw <$> buildRaw)+    (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, MonadSTM m)-    => Method c p r -> R.Raw 'Const p -> f c -> m (Pipeline r)+    => Method c p r -> R.Raw p 'Const -> f c -> m (Pipeline r) callR Method{interfaceId, methodId} (R.Raw arg) c = liftSTM $ do     Client client <- asClient c     (_, f) <- newPromise@@ -147,7 +147,7 @@     ( 'R.Ptr pr ~ R.ReprFor a     , R.IsPtrRepr pr     , MonadSTM m-    ) => Pipeline a -> m (R.Raw 'Const a)+    ) => 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

@@ -97,7 +97,8 @@  import Capnp.Convert        (msgToRaw, parsedToMsg) import Capnp.Fields         (Which)-import Capnp.Message        (Message, Mutability(..))+import Capnp.Message        (Message)+import Capnp.Mutability     (Mutability(..), thaw) import Capnp.New.Classes    (new, newRoot, parse) import Capnp.Repr           (Raw(..)) import Capnp.Rpc.Errors@@ -111,7 +112,6 @@     (Fulfiller, breakOrFulfill, breakPromise, fulfill, newCallback) import Capnp.Rpc.Transport  (Transport(recvMsg, sendMsg)) import Capnp.TraversalLimit (LimitT, defaultLimit, evalLimitT)-import Data.Mutable         (thaw) import Internal.BuildPure   (createPure) import Internal.Rc          (Rc) import Internal.SnocList    (SnocList)@@ -1225,9 +1225,9 @@                 }         Just client -> do             capDesc <- emitCap conn client-            content <- createPure defaultLimit $ do+            content <- fmap Just $ createPure defaultLimit $ do                 msg <- Message.newMessage Nothing-                Just . UntypedRaw.PtrCap <$> UntypedRaw.appendCap msg client+                UntypedRaw.PtrCap <$> UntypedRaw.appendCap msg client             pure Return                 { answerId = QAId questionId                 , releaseParamCaps = True -- Not really meaningful for bootstrap, but...@@ -1265,7 +1265,7 @@     insertBootstrap conn' _ (Just _) =         abortConn conn' $ eFailed "Duplicate question ID" -handleCallMsg :: Conn -> Raw 'Const R.Call -> LimitT STM ()+handleCallMsg :: Conn -> Raw R.Call 'Const -> LimitT STM () handleCallMsg conn callMsg = do     conn'@Conn'{exports, answers} <- lift $ getLive conn     questionId <- parseField #questionId callMsg@@ -1387,9 +1387,9 @@ sendCall :: Conn' -> Call -> STM () sendCall conn' Call{questionId, target, interfaceId, methodId, params=Payload{content, capTable}} =     sendRawMsg conn' =<< createPure defaultLimit (do-        mcontent <- thaw content+        mcontent <- traverse thaw content         msg <- case mcontent of-            Just v  -> pure $ UntypedRaw.message v+            Just v  -> pure $ UntypedRaw.message @UntypedRaw.Ptr v             Nothing -> Message.newMessage Nothing         payload <- new @R.Payload () msg         payload & setField #content (Raw mcontent)@@ -1409,9 +1409,9 @@ sendReturn conn' Return{answerId, releaseParamCaps, union'} = case union' of     Return'results Payload{content, capTable} ->         sendRawMsg conn' =<< createPure defaultLimit (do-            mcontent <- thaw content+            mcontent <- traverse thaw content             msg <- case mcontent of-                Just v  -> pure $ UntypedRaw.message v+                Just v  -> pure $ UntypedRaw.message @UntypedRaw.Ptr  v                 Nothing -> Message.newMessage Nothing             payload <- new @R.Payload () msg             payload & setField #content (Raw mcontent)@@ -1450,20 +1450,20 @@             }     Return'acceptFromThirdParty ptr ->         sendRawMsg conn' =<< createPure defaultLimit (do-            mptr <- thaw ptr+            mptr <- traverse thaw ptr             msg <- case mptr of-                Just v  -> pure $ UntypedRaw.message v+                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)+            setVariant #acceptFromThirdParty ret (Raw @(Maybe B.AnyPointer) mptr)             rpcMsg <- newRoot @R.Message () msg             setVariant #return rpcMsg ret             pure msg         ) -acceptReturn :: Conn -> Raw 'Const R.Return -> LimitT STM Return+acceptReturn :: Conn -> Raw R.Return 'Const -> LimitT STM Return acceptReturn conn ret = do     let answerId = QAId (getField #answerId ret)         releaseParamCaps = getField #releaseParamCaps ret@@ -1692,7 +1692,7 @@             union' <- emitCap conn c             pure (def :: R.Parsed R.CapDescriptor) { R.union' = union' }         )-        (Message.getCapTable (UntypedRaw.message ptr))+        (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.@@ -2123,7 +2123,7 @@   where     newSenderPromise = R.CapDescriptor'senderPromise . ieWord <$> getConnExport targetConn client' -acceptPayload :: Conn -> Raw 'Const R.Payload -> LimitT STM Payload+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

@@ -1,1134 +1,1518 @@-{-# LANGUAGE ApplicativeDo              #-}-{-# LANGUAGE ConstraintKinds            #-}-{-# LANGUAGE DataKinds                  #-}-{-# LANGUAGE FlexibleContexts           #-}-{-# LANGUAGE FlexibleInstances          #-}-{-# LANGUAGE FunctionalDependencies     #-}-{-# LANGUAGE GADTs                      #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase                 #-}-{-# LANGUAGE NamedFieldPuns             #-}-{-# LANGUAGE RankNTypes                 #-}-{-# LANGUAGE RecordWildCards            #-}-{-# LANGUAGE TemplateHaskell            #-}-{-# LANGUAGE TypeFamilies               #-}-{-|-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-    ( Ptr(..), List(..), Struct, ListOf, Cap-    , structByteCount-    , structWordCount-    , structPtrCount-    , structListByteCount-    , structListWordCount-    , structListPtrCount-    , getData, getPtr-    , setData, setPtr-    , copyStruct-    , copyPtr-    , copyList-    , copyCap-    , copyListOf-    , getClient-    , get, index, length-    , 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 qualified Data.ByteString     as BS-import qualified Language.Haskell.TH as TH--import Capnp.Address        (OffsetError(..), WordAddr(..), pointerFrom)-import Capnp.Bits-    ( BitCount(..)-    , ByteCount(..)-    , Word1(..)-    , WordCount(..)-    , bitsToBytesCeil-    , bytesToWordsCeil-    , replaceBits-    , wordsToBytes-    )-import Capnp.Message        (Mutability(..))-import Capnp.Pointer        (ElementSize(..))-import Capnp.TraversalLimit (LimitT, MonadLimit(invoice))-import Data.Mutable         (Thaw(..))--import qualified Capnp.Errors  as E-import qualified Capnp.Message as M-import qualified Capnp.Pointer as P---- | 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 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 mut ())-    | List1 (ListOf mut Bool)-    | List8 (ListOf mut Word8)-    | List16 (ListOf mut Word16)-    | List32 (ListOf mut Word32)-    | List64 (ListOf mut Word64)-    | ListPtr (ListOf mut (Maybe (Ptr mut)))-    | ListStruct (ListOf mut (Struct mut))---- | A "normal" (non-composite) list.-data NormalList mut = NormalList-    { nPtr :: !(M.WordPtr mut)-    , nLen :: !Int-    }---- | A list of values of type 'a' in a message.-data ListOf mut a where-    ListOfStruct-        :: Struct mut -- First element. data/ptr sizes are the same for-                      -- all elements.-        -> !Int       -- Number of elements-        -> ListOf mut (Struct mut)-    ListOfVoid   :: !(NormalList mut) -> ListOf mut ()-    ListOfBool   :: !(NormalList mut) -> ListOf mut Bool-    ListOfWord8  :: !(NormalList mut) -> ListOf mut Word8-    ListOfWord16 :: !(NormalList mut) -> ListOf mut Word16-    ListOfWord32 :: !(NormalList mut) -> ListOf mut Word32-    ListOfWord64 :: !(NormalList mut) -> ListOf mut Word64-    ListOfPtr    :: !(NormalList mut) -> ListOf mut (Maybe (Ptr mut))---- | A Capability in a message.-data Cap mut = Cap (M.Message mut) !Word32---- | A struct value in a message.-data Struct mut-    = Struct-        !(M.WordPtr mut) -- Start of struct-        !Word16 -- Data section size.-        !Word16 -- Pointer section size.---- | 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 (Cap msg n) = Cap <$> f msg <*> pure n--instance TraverseMsg Struct where-    tMsg f (Struct ptr dataSz ptrSz) = Struct-        <$> tMsg f ptr-        <*> pure dataSz-        <*> pure ptrSz--instance TraverseMsg List where-    tMsg f = \case-        List0      l -> List0      . unflip  <$> tMsg f (FlipList  l)-        List1      l -> List1      . unflip  <$> tMsg f (FlipList  l)-        List8      l -> List8      . unflip  <$> tMsg f (FlipList  l)-        List16     l -> List16     . unflip  <$> tMsg f (FlipList  l)-        List32     l -> List32     . unflip  <$> tMsg f (FlipList  l)-        List64     l -> List64     . unflip  <$> tMsg f (FlipList  l)-        ListPtr    l -> ListPtr    . unflipP <$> tMsg f (FlipListP l)-        ListStruct l -> ListStruct . unflipS <$> tMsg f (FlipListS l)--instance TraverseMsg NormalList where-    tMsg f NormalList{..} = do-        ptr <- tMsg f nPtr-        pure NormalList { nPtr = ptr, .. }------------------------------------------------------------------------------------ newtype wrappers for the purpose of implementing 'TraverseMsg'; these adjust--- the shape of 'ListOf' so that we can define an instance. We need a couple--- different wrappers depending on the shape of the element type.------------------------------------------------------------------------------------ 'FlipList' wraps a @ListOf msg a@ where 'a' is of kind @*@.-newtype FlipList  a msg = FlipList  { unflip  :: ListOf msg a                 }---- 'FlipListS' wraps a @ListOf msg (Struct msg)@. We can't use 'FlipList' for--- our instances, because we need both instances of the 'msg' parameter to stay--- equal.-newtype FlipListS   msg = FlipListS { unflipS :: ListOf msg (Struct msg)      }---- 'FlipListP' wraps a @ListOf msg (Maybe (Ptr msg))@. Pointers can't use--- 'FlipList' for the same reason as structs.-newtype FlipListP   msg = FlipListP { unflipP :: ListOf msg (Maybe (Ptr msg)) }------------------------------------------------------------------------------------ 'TraverseMsg' instances for 'FlipList'----------------------------------------------------------------------------------instance TraverseMsg (FlipList ()) where-    tMsg f (FlipList (ListOfVoid   nlist)) = FlipList . ListOfVoid <$> tMsg f nlist--instance TraverseMsg (FlipList Bool) where-    tMsg f (FlipList (ListOfBool   nlist)) = FlipList . ListOfBool   <$> tMsg f nlist--instance TraverseMsg (FlipList Word8) where-    tMsg f (FlipList (ListOfWord8  nlist)) = FlipList . ListOfWord8  <$> tMsg f nlist--instance TraverseMsg (FlipList Word16) where-    tMsg f (FlipList (ListOfWord16 nlist)) = FlipList . ListOfWord16 <$> tMsg f nlist--instance TraverseMsg (FlipList Word32) where-    tMsg f (FlipList (ListOfWord32 nlist)) = FlipList . ListOfWord32 <$> tMsg f nlist--instance TraverseMsg (FlipList Word64) where-    tMsg f (FlipList (ListOfWord64 nlist)) = FlipList . ListOfWord64 <$> tMsg f nlist------------------------------------------------------------------------------------ 'TraverseMsg' instances for struct and pointer lists.----------------------------------------------------------------------------------instance TraverseMsg FlipListP where-    tMsg f (FlipListP (ListOfPtr nlist))   = FlipListP . ListOfPtr   <$> tMsg f nlist--instance TraverseMsg FlipListS where-    tMsg f (FlipListS (ListOfStruct tag size)) =-        FlipListS <$> (ListOfStruct <$> tMsg f tag <*> pure size)---- helpers for applying tMsg to a @ListOf@.-tFlip  :: (TraverseMsg (FlipList a), TraverseMsgCtx m mutA mutB)-    => (M.Message mutA -> m (M.Message mutB)) -> ListOf mutA a -> m (ListOf mutB a)-tFlipS :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> ListOf mutA (Struct mutA) -> m (ListOf mutB (Struct mutB ))-tFlipP :: TraverseMsgCtx m mutA mutB => (M.Message mutA -> m (M.Message mutB)) -> ListOf mutA (Maybe (Ptr mutA)) -> m (ListOf mutB (Maybe (Ptr mutB)))-tFlip  f list  = unflip  <$> tMsg f (FlipList  list)-tFlipS f list  = unflipS <$> tMsg f (FlipListS list)-tFlipP f list  = unflipP <$> tMsg f (FlipListP list)------------------------------------------------------------------------------------ Boilerplate 'Thaw' instances.------ These all just call the underlying methods on the message, using 'TraverseMsg'.----------------------------------------------------------------------------------instance Thaw a => Thaw (Maybe a) where-    type Mutable s (Maybe a) = Maybe (Mutable s a)--    thaw         = traverse thaw-    freeze       = traverse freeze-    unsafeThaw   = traverse unsafeThaw-    unsafeFreeze = traverse unsafeFreeze--do-    let mkWrappedInstance name =-            let f = pure $ TH.ConT name in-            [d|instance Thaw ($f 'Const) where-                type Mutable s ($f 'Const) = $f ('Mut s)--                thaw         = runCatchImpure . tMsg thaw-                freeze       = runCatchImpure . tMsg freeze-                unsafeThaw   = runCatchImpure . tMsg unsafeThaw-                unsafeFreeze = runCatchImpure . tMsg unsafeFreeze-            |]-        mkListOfInstance t =-            [d|instance Thaw (ListOf 'Const $t) where-                type Mutable s (ListOf 'Const $t) = ListOf ('Mut s) $t--                thaw         = runCatchImpure . tFlip thaw-                freeze       = runCatchImpure . tFlip freeze-                unsafeThaw   = runCatchImpure . tFlip unsafeThaw-                unsafeFreeze = runCatchImpure . tFlip unsafeFreeze-            |]-    xs <- traverse mkWrappedInstance-        [ ''Ptr-        , ''List-        , ''NormalList-        , ''Struct-        ]-    ys <- traverse mkListOfInstance-        [ [t|()|]-        , [t|Bool|]-        , [t|Word8|]-        , [t|Word16|]-        , [t|Word32|]-        , [t|Word64|]-        ]-    pure $ concat $ xs ++ ys--instance Thaw (ListOf 'Const (Struct 'Const)) where-    type Mutable s (ListOf 'Const (Struct 'Const)) =-        ListOf ('Mut s) (Struct ('Mut s))--    thaw         = runCatchImpure . tFlipS thaw-    freeze       = runCatchImpure . tFlipS freeze-    unsafeThaw   = runCatchImpure . tFlipS unsafeThaw-    unsafeFreeze = runCatchImpure . tFlipS unsafeFreeze--instance Thaw (ListOf 'Const (Maybe (Ptr 'Const))) where-    type Mutable s (ListOf 'Const (Maybe (Ptr 'Const))) =-        ListOf ('Mut s) (Maybe (Ptr ('Mut s)))--    thaw         = runCatchImpure . tFlipP thaw-    freeze       = runCatchImpure . tFlipP freeze-    unsafeThaw   = runCatchImpure . tFlipP unsafeThaw-    unsafeFreeze = runCatchImpure . tFlipP unsafeFreeze------------------------------------------------------------------------------------ Helpers for the above boilerplate Thaw 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-runCatchImpure m = do-    res <- runCatchT $ runCatchTWrap m-    pure $ case res of-        Left e  -> impureThrow e-        Right v -> v------------------------------------------------------------------------------------- | Types @a@ whose storage is owned by a message..-class HasMessage a mut | a -> mut where-    -- | Get the message in which the @a@ is stored.-    message :: a -> 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 a mut => MessageDefault a mut where-    messageDefault :: ReadCtx m mut => M.Message mut -> m a--instance HasMessage (M.WordPtr mut) mut where-    message M.WordPtr{pMessage} = pMessage--instance HasMessage (Ptr mut) mut where-    message (PtrCap cap)       = message cap-    message (PtrList list)     = message list-    message (PtrStruct struct) = message struct--instance HasMessage (Cap mut) mut where-    message (Cap msg _) = msg--instance HasMessage (Struct mut) mut where-    message (Struct ptr _ _) = message ptr--instance MessageDefault (Struct mut) mut where-    messageDefault msg = do-        pSegment <- M.getSegment msg 0-        pure $ Struct M.WordPtr{pMessage = msg, pSegment, pAddr = WordAt 0 0} 0 0--instance HasMessage (List mut) mut where-    message (List0 list)      = message list-    message (List1 list)      = message list-    message (List8 list)      = message list-    message (List16 list)     = message list-    message (List32 list)     = message list-    message (List64 list)     = message list-    message (ListPtr list)    = message list-    message (ListStruct list) = message list--instance HasMessage (ListOf mut a) mut where-    message (ListOfStruct tag _) = message tag-    message (ListOfVoid list)    = message list-    message (ListOfBool list)    = message list-    message (ListOfWord8 list)   = message list-    message (ListOfWord16 list)  = message list-    message (ListOfWord32 list)  = message list-    message (ListOfWord64 list)  = message list-    message (ListOfPtr list)     = message list--instance MessageDefault (ListOf mut ()) mut where-    messageDefault msg = ListOfVoid <$> messageDefault msg-instance MessageDefault (ListOf mut (Struct mut)) mut where-    messageDefault msg = flip ListOfStruct 0 <$> messageDefault msg-instance MessageDefault (ListOf mut Bool) mut where-    messageDefault msg = ListOfBool <$> messageDefault msg-instance MessageDefault (ListOf mut Word8) mut where-    messageDefault msg = ListOfWord8 <$> messageDefault msg-instance MessageDefault (ListOf mut Word16) mut where-    messageDefault msg = ListOfWord16 <$> messageDefault msg-instance MessageDefault (ListOf mut Word32) mut where-    messageDefault msg = ListOfWord32 <$> messageDefault msg-instance MessageDefault (ListOf mut Word64) mut where-    messageDefault msg = ListOfWord64 <$> messageDefault msg-instance MessageDefault (ListOf mut (Maybe (Ptr mut))) mut where-    messageDefault msg = ListOfPtr <$> messageDefault msg--instance HasMessage (NormalList mut) mut where-    message = M.pMessage . nPtr--instance MessageDefault (NormalList mut) mut where-    messageDefault msg = do-        pSegment <- M.getSegment msg 0-        pure NormalList-            { nPtr = M.WordPtr { pMessage = msg, pSegment, pAddr = WordAt 0 0 }-            , nLen = 0-            }---- | Extract a client (indepedent of the messsage) from the capability.-getClient :: ReadCtx m mut => Cap mut -> m M.Client-getClient (Cap 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))-{-# SPECIALIZE get :: M.WordPtr ('Mut RealWorld) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-}-get ptr@M.WordPtr{pMessage, pAddr} = do-    word <- getWord ptr-    case P.parsePtr word of-        Nothing -> return Nothing-        Just p -> case p of-            P.CapPtr cap -> return $ Just $ PtrCap (Cap pMessage cap)-            P.StructPtr off dataSz ptrSz -> return $ Just $ PtrStruct $-                Struct ptr { M.pAddr = resolveOffset pAddr off } dataSz ptrSz-            P.ListPtr off eltSpec -> Just <$>-                getList ptr { M.pAddr = resolveOffset pAddr off } eltSpec-            P.FarPtr 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'-                        }-                if not twoWords-                    then do-                        -- XXX: invoice so we don't open ourselves up to DoS-                        -- in the case of a chain of far pointers -- but a-                        -- better solution would be to just reject after the-                        -- first chain since this isn't actually legal. TODO-                        -- refactor (and then get rid of the MonadLimit-                        -- constraint).-                        invoice 1-                        get landingPtr-                    else do-                        landingPad <- getWord landingPtr-                        case P.parsePtr landingPad of-                            Just (P.FarPtr False off seg) -> do-                                let segIndex = fromIntegral seg-                                finalSegment <- M.getSegment pMessage segIndex-                                tagWord <- 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 $-                                            Struct finalPtr dataSz ptrSz-                                    Just (P.ListPtr 0 eltSpec) ->-                                        Just <$> 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 (Cap 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--  where-    getWord M.WordPtr{pSegment, pAddr=WordAt{wordIndex}} =-        M.read pSegment wordIndex-    resolveOffset addr@WordAt{..} off =-        addr { wordIndex = wordIndex + fromIntegral off + 1 }-    getList ptr@M.WordPtr{pAddr=addr@WordAt{wordIndex}} eltSpec = PtrList <$>-        case eltSpec of-            P.EltNormal sz len -> pure $ case sz of-                Sz0   -> List0  (ListOfVoid    nlist)-                Sz1   -> List1  (ListOfBool    nlist)-                Sz8   -> List8  (ListOfWord8   nlist)-                Sz16  -> List16 (ListOfWord16  nlist)-                Sz32  -> List32 (ListOfWord32  nlist)-                Sz64  -> List64 (ListOfWord64  nlist)-                SzPtr -> ListPtr (ListOfPtr nlist)-              where-                nlist = NormalList ptr (fromIntegral len)-            P.EltComposite _ -> do-                tagWord <- getWord ptr-                case P.parsePtr' tagWord of-                    P.StructPtr numElts dataSz ptrSz ->-                        pure $ ListStruct $ ListOfStruct-                            (Struct 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@(ListOfStruct (Struct _ dataSz ptrSz) _)) =-    P.EltComposite $ fromIntegral (length list) * (fromIntegral dataSz + fromIntegral ptrSz)-listEltSpec (List0 list)   = P.EltNormal Sz0 $ fromIntegral (length list)-listEltSpec (List1 list)   = P.EltNormal Sz1 $ fromIntegral (length list)-listEltSpec (List8 list)   = P.EltNormal Sz8 $ fromIntegral (length list)-listEltSpec (List16 list)  = P.EltNormal Sz16 $ fromIntegral (length list)-listEltSpec (List32 list)  = P.EltNormal Sz32 $ fromIntegral (length list)-listEltSpec (List64 list)  = P.EltNormal Sz64 $ fromIntegral (length list)-listEltSpec (ListPtr list) = P.EltNormal SzPtr $ fromIntegral (length list)---- | Return the starting address of the list.-listAddr :: List msg -> WordAddr-listAddr (ListStruct (ListOfStruct (Struct 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 (ListOfVoid NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr-listAddr (List1 (ListOfBool NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr-listAddr (List8 (ListOfWord8 NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr-listAddr (List16 (ListOfWord16 NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr-listAddr (List32 (ListOfWord32 NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr-listAddr (List64 (ListOfWord64 NormalList{nPtr=M.WordPtr{pAddr}})) = pAddr-listAddr (ListPtr (ListOfPtr 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 (Struct 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 => a -> Int -> ListOf ('Mut s) a -> m ()-{-# SPECIALIZE setIndex :: a -> Int -> ListOf ('Mut RealWorld) a -> LimitT IO () #-}-setIndex _ i list | i < 0 || length list <= i =-    throwM E.BoundsError { E.index = i, E.maxIndex = length list }-setIndex value i list = case list of-    ListOfVoid _       -> pure ()-    ListOfBool nlist   -> setNIndex nlist 64 (Word1 value)-    ListOfWord8 nlist  -> setNIndex nlist 8 value-    ListOfWord16 nlist -> setNIndex nlist 4 value-    ListOfWord32 nlist -> setNIndex nlist 2 value-    ListOfWord64 nlist -> setNIndex nlist 1 value-    ListOfPtr nlist -> case value of-        Just p | message p /= message list -> do-            newPtr <- copyPtr (message list) value-            setIndex newPtr i list-        Nothing                -> setNIndex nlist 1 (P.serializePtr Nothing)-        Just (PtrCap (Cap _ cap))    -> setNIndex nlist 1 (P.serializePtr (Just (P.CapPtr cap)))-        Just p@(PtrList ptrList)     ->-            setPtrIndex nlist p $ P.ListPtr 0 (listEltSpec ptrList)-        Just p@(PtrStruct (Struct _ dataSz ptrSz)) ->-            setPtrIndex nlist p $ P.StructPtr 0 dataSz ptrSz-    list@(ListOfStruct _ _) -> do-        dest <- index i list-        copyStruct dest value-  where-    setNIndex :: (RWCtx m s, Bounded a, Integral a) => NormalList ('Mut s) -> Int -> a -> m ()-    setNIndex 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 => NormalList ('Mut s) -> Ptr ('Mut s) -> P.Ptr -> m ()-    setPtrIndex 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---- | @'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 ()-{-# SPECIALIZE setPointerTo :: M.WordPtr ('Mut RealWorld) -> WordAddr -> P.Ptr -> LimitT IO () #-}-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))-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)))-{-# SPECIALIZE copyPtr :: M.Message ('Mut RealWorld) -> Maybe (Ptr ('Mut RealWorld)) -> LimitT IO (Maybe (Ptr ('Mut RealWorld))) #-}-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))-{-# SPECIALIZE copyList :: M.Message ('Mut RealWorld) -> List ('Mut RealWorld) -> LimitT IO (List ('Mut RealWorld)) #-}-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-    :: RWCtx m s-    => M.Message ('Mut s)-    -> ListOf ('Mut s) a-    -> (M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) a))-    -> m (ListOf ('Mut s) a)-{-# INLINE copyNewListOf #-}-copyNewListOf destMsg src new = do-    dest <- new destMsg (length src)-    copyListOf dest src-    pure dest----- | Make a copy of the list, in the target message.-copyListOf :: RWCtx m s => ListOf ('Mut s) a -> ListOf ('Mut s) a -> m ()-{-# SPECIALIZE copyListOf :: ListOf ('Mut RealWorld) a -> ListOf ('Mut RealWorld) a -> LimitT IO () #-}-copyListOf dest src =-    forM_ [0..length src - 1] $ \i -> do-        value <- index i src-        setIndex value i dest---- | @'copyStruct' dest src@ copies the source struct to the destination struct.-copyStruct :: RWCtx m s => Struct ('Mut s) -> Struct ('Mut s) -> m ()-{-# SPECIALIZE copyStruct :: Struct ('Mut RealWorld) -> Struct ('Mut RealWorld) -> LimitT IO () #-}-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 => Int -> ListOf mut a -> m a-{-# SPECIALIZE index :: Int -> ListOf 'Const a -> LimitT IO a #-}-{-# SPECIALIZE index :: Int -> ListOf ('Mut RealWorld) a -> LimitT IO a #-}-index i list-    | i < 0 || i >= length list =-        throwM E.BoundsError { E.index = i, E.maxIndex = length list - 1 }-    | otherwise = index' list-  where-    index' :: ReadCtx m mut => ListOf mut a -> m a-    index' (ListOfVoid _) = pure ()-    index' (ListOfStruct (Struct ptr@M.WordPtr{pAddr=addr@WordAt{..}} dataSz ptrSz) _) = do-        let offset = WordCount $ i * (fromIntegral dataSz + fromIntegral ptrSz)-        let addr' = addr { wordIndex = wordIndex + offset }-        return $ Struct ptr { M.pAddr = addr' } dataSz ptrSz-    index' (ListOfBool   nlist) = do-        Word1 val <- indexNList nlist 64-        pure val-    index' (ListOfWord8  nlist) = indexNList nlist 8-    index' (ListOfWord16 nlist) = indexNList nlist 4-    index' (ListOfWord32 nlist) = indexNList nlist 2-    index' (ListOfWord64 (NormalList M.WordPtr{pSegment, pAddr=WordAt{wordIndex}} _)) =-        M.read pSegment $ wordIndex + WordCount i-    index' (ListOfPtr (NormalList ptr@M.WordPtr{pAddr=addr@WordAt{..}} _)) =-        get ptr { M.pAddr = addr { wordIndex = wordIndex + WordCount i } }-    indexNList :: (ReadCtx m mut, Integral a) => NormalList mut -> Int -> m a-    indexNList (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---- | Returns the length of a list-length :: ListOf msg a -> Int-length (ListOfStruct _ len) = len-length (ListOfVoid   nlist) = nLen nlist-length (ListOfBool   nlist) = nLen nlist-length (ListOfWord8  nlist) = nLen nlist-length (ListOfWord16 nlist) = nLen nlist-length (ListOfWord32 nlist) = nLen nlist-length (ListOfWord64 nlist) = nLen nlist-length (ListOfPtr    nlist) = nLen nlist---- | Return a prefix of the list, of the given length.-take :: MonadThrow m => Int -> ListOf msg a -> m (ListOf msg a)-take count list-    | length list < count =-        throwM E.BoundsError { E.index = count, E.maxIndex = length list - 1 }-    | otherwise = pure $ go list-  where-    go (ListOfStruct tag _) = ListOfStruct tag count-    go (ListOfVoid nlist)   = ListOfVoid $ nTake nlist-    go (ListOfBool nlist)   = ListOfBool $ nTake nlist-    go (ListOfWord8 nlist)  = ListOfWord8 $ nTake nlist-    go (ListOfWord16 nlist) = ListOfWord16 $ nTake nlist-    go (ListOfWord32 nlist) = ListOfWord32 $ nTake nlist-    go (ListOfWord64 nlist) = ListOfWord64 $ nTake nlist-    go (ListOfPtr nlist)    = ListOfPtr $ nTake nlist--    nTake :: NormalList msg -> NormalList msg-    nTake NormalList{..} = NormalList { nLen = count, .. }---- | The data section of a struct, as a list of Word64-dataSection :: Struct msg -> ListOf msg Word64-{-# INLINE dataSection #-}-dataSection (Struct ptr dataSz _) =-    ListOfWord64 $ NormalList ptr (fromIntegral dataSz)---- | The pointer section of a struct, as a list of Ptr-ptrSection :: Struct msg -> ListOf msg (Maybe (Ptr msg))-{-# INLINE ptrSection #-}-ptrSection (Struct ptr@M.WordPtr{pAddr=addr@WordAt{wordIndex}} dataSz ptrSz) =-    ListOfPtr $ 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 msg -> WordCount-structWordCount (Struct _ptr dataSz _ptrSz) = fromIntegral dataSz---- | Get the size (in bytes) of a struct's data section.-structByteCount :: Struct msg -> ByteCount-structByteCount = wordsToBytes . structWordCount---- | Get the size of a struct's pointer section.-structPtrCount  :: Struct msg -> Word16-structPtrCount (Struct _ptr _dataSz ptrSz) = ptrSz---- | Get the size (in words) of the data sections in a struct list.-structListWordCount :: ListOf msg (Struct msg) -> WordCount-structListWordCount (ListOfStruct s _) = structWordCount s---- | Get the size (in words) of the data sections in a struct list.-structListByteCount :: ListOf msg (Struct msg) -> ByteCount-structListByteCount (ListOfStruct s _) = structByteCount s---- | Get the size of the pointer sections in a struct list.-structListPtrCount  :: ListOf msg (Struct msg) -> Word16-structListPtrCount  (ListOfStruct 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 ()-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 ()-checkCap (Cap _ _ ) = pure ()-    -- No need to do anything here; an out of bounds index is just treated-    -- as null.--checkList :: ReadCtx m mut => List mut -> m ()-checkList (List0 l)      = checkListOf l-checkList (List1 l)      = checkListOf l-checkList (List8 l)      = checkListOf l-checkList (List16 l)     = checkListOf l-checkList (List32 l)     = checkListOf l-checkList (List64 l)     = checkListOf l-checkList (ListPtr l)    = checkListOf l-checkList (ListStruct l) = checkListOf l--checkListOf :: ReadCtx m mut => ListOf mut a -> m ()-checkListOf (ListOfStruct s@(Struct ptr _ _) len) =-    checkPtrOffset ptr (fromIntegral len * structSize s)-checkListOf (ListOfVoid _) = pure ()-checkListOf (ListOfBool l) = checkNormalList l 1-checkListOf (ListOfWord8 l) = checkNormalList l 8-checkListOf (ListOfWord16 l) = checkNormalList l 16-checkListOf (ListOfWord32 l) = checkNormalList l 32-checkListOf (ListOfWord64 l) = checkNormalList l 64-checkListOf (ListOfPtr l) = checkNormalList l 64--checkNormalList :: ReadCtx m mut => NormalList mut -> BitCount -> m ()-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 ()-checkStruct s@(Struct ptr _ _) =-    checkPtrOffset ptr (structSize s)--checkPtrOffset :: ReadCtx m mut => M.WordPtr mut -> WordCount -> m ()-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 ()-{-# SPECIALIZE invoicePtr :: Maybe (Ptr ('Mut RealWorld)) -> LimitT IO () #-}-invoicePtr p = invoice $! ptrInvoiceSize p--ptrInvoiceSize :: Maybe (Ptr mut) -> WordCount-ptrInvoiceSize = \case-    Nothing            -> 1-    Just (PtrCap _)    -> 1-    Just (PtrStruct s) -> structInvoiceSize s-    Just (PtrList l)   -> listInvoiceSize l-listInvoiceSize :: List mut -> WordCount-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 (ListOfStruct s len) ->-        structInvoiceSize s * fromIntegral len-structInvoiceSize :: Struct mut -> WordCount-structInvoiceSize (Struct _ 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 'Const Word8 -> m BS.ByteString--- TODO: we can get away with a more lax context than ReadCtx, maybe even make--- this non-monadic.-rawBytes (ListOfWord8 (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)-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 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 ()-setRoot (Struct 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)---- | Allocate a struct in the message.-allocStruct :: M.WriteCtx m s => M.Message ('Mut s) -> Word16 -> Word16 -> m (Struct ('Mut s))-allocStruct msg dataSz ptrSz = do-    let totalSz = fromIntegral dataSz + fromIntegral ptrSz-    ptr <- M.alloc msg totalSz-    pure $ Struct 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 ('Mut s) (Struct ('Mut s)))-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 = Struct-            ptr { M.pAddr = addr { wordIndex = wordIndex + 1 } }-            dataSz-            ptrSz-    pure $ ListOfStruct firstStruct len---- | Allocate a list of capnproto @Void@ values.-allocList0   :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) ())---- | Allocate a list of booleans-allocList1   :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Bool)---- | Allocate a list of 8-bit values.-allocList8   :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word8)---- | Allocate a list of 16-bit values.-allocList16  :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word16)---- | Allocate a list of 32-bit values.-allocList32  :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word32)---- | Allocate a list of 64-bit words.-allocList64  :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) Word64)---- | Allocate a list of pointers.-allocListPtr :: M.WriteCtx m s => M.Message ('Mut s) -> Int -> m (ListOf ('Mut s) (Maybe (Ptr ('Mut s))))--allocList0   msg len = ListOfVoid   <$> allocNormalList 0  msg len-allocList1   msg len = ListOfBool   <$> allocNormalList 1  msg len-allocList8   msg len = ListOfWord8  <$> allocNormalList 8  msg len-allocList16  msg len = ListOfWord16 <$> allocNormalList 16 msg len-allocList32  msg len = ListOfWord32 <$> allocNormalList 32 msg len-allocList64  msg len = ListOfWord64 <$> allocNormalList 64 msg len-allocListPtr msg len = ListOfPtr    <$> 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))-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))-appendCap msg client = do-    i <- M.appendCap msg client-    pure $ Cap msg (fromIntegral i)+{-# 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+    , copyListOf+    , 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.Kind                 (Type)++import qualified Data.ByteString     as BS+import qualified Language.Haskell.TH as TH++import Capnp.Address        (OffsetError(..), WordAddr(..), pointerFrom)+import Capnp.Bits+    ( BitCount(..)+    , ByteCount(..)+    , Word1(..)+    , WordCount(..)+    , bitsToBytesCeil+    , bytesToWordsCeil+    , replaceBits+    , wordsToBytes+    )+import Capnp.Mutability     (MaybeMutable(..), Mutability(..))+import Capnp.TraversalLimit (LimitT, MonadLimit(invoice))++import qualified Capnp.Errors  as E+import qualified Capnp.Message as M+import qualified Capnp.Pointer as P++-------------------------------------------------------------------------------+-- 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 -> * 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 ()++    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 #-}++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 checkListOf #-}++instance ListItem ('Data 'Sz8)+instance ListItem ('Data 'Sz16)+instance ListItem ('Data 'Sz32)+instance ListItem ('Data 'Sz64)++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 -> *) 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))) #-}+get ptr@M.WordPtr{pMessage, pAddr} = do+    word <- getWord ptr+    case P.parsePtr word of+        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 <$>+                getList ptr { M.pAddr = resolveOffset pAddr off } eltSpec+            P.FarPtr 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'+                        }+                if not twoWords+                    then do+                        -- XXX: invoice so we don't open ourselves up to DoS+                        -- in the case of a chain of far pointers -- but a+                        -- better solution would be to just reject after the+                        -- first chain since this isn't actually legal. TODO+                        -- refactor (and then get rid of the MonadLimit+                        -- constraint).+                        invoice 1+                        get landingPtr+                    else do+                        landingPad <- getWord landingPtr+                        case P.parsePtr landingPad of+                            Just (P.FarPtr False off seg) -> do+                                let segIndex = fromIntegral seg+                                finalSegment <- M.getSegment pMessage segIndex+                                tagWord <- 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 <$> 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++  where+    getWord M.WordPtr{pSegment, pAddr=WordAt{wordIndex}} =+        M.read pSegment wordIndex+    resolveOffset addr@WordAt{..} off =+        addr { wordIndex = wordIndex + fromIntegral off + 1 }+    getList ptr@M.WordPtr{pAddr=addr@WordAt{wordIndex}} eltSpec = PtrList <$>+        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 <- 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 () #-}+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 () #-}+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))) #-}+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)) #-}+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+++-- | Make a copy of the list, in the target message.+copyListOf+    :: (ListItem r, 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++-- | @'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 () #-}+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))) #-}+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 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 () #-}+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+        , ''NormalList+        , ''Struct+        ]++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"+          )+        ]

@@ -18,7 +18,7 @@ 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 where+module Data.Mutable {-# DEPRECATED "use Capnp.Mutability instead" #-} where  import Control.Monad.Primitive (PrimMonad, PrimState) import Control.Monad.ST        (ST, runST)

@@ -10,7 +10,6 @@     , makeEmpty     , getVector     , getCapacity-    , FrozenAppendVec(..)     , grow     , canGrowWithoutCopy     ) where@@ -19,11 +18,9 @@ import Control.Monad.Catch     (MonadThrow(throwM)) import Control.Monad.Primitive (PrimMonad, PrimState) -import qualified Data.Vector.Generic         as GV import qualified Data.Vector.Generic.Mutable as GMV  import Capnp.Errors (Error(SizeError))-import Data.Mutable (Thaw (..))  -- | 'AppendVec' wraps a mutable vector, and affords amortized O(1) appending. data AppendVec v s a = AppendVec@@ -53,27 +50,6 @@  getCapacity :: GMV.MVector v a => AppendVec v s a -> Int getCapacity AppendVec{mutVec} = GMV.length mutVec---- | immutable version of 'AppendVec'; this is defined for the purpose of--- implementing 'Thaw'.-newtype FrozenAppendVec v a = FrozenAppendVec { getFrozenVector :: v a }--instance GV.Vector v a => Thaw (FrozenAppendVec v a) where-    type Mutable s (FrozenAppendVec v a) = AppendVec (GV.Mutable v) s a--    thaw         = thawAppend GV.thaw-    unsafeThaw   = thawAppend GV.unsafeThaw-    freeze       = freezeAppend GV.freeze-    unsafeFreeze = freezeAppend GV.unsafeFreeze---- Helpers for the thaw & freeze methods for the instance above.-thawAppend thaw frozen = do-    mvec <- thaw $ getFrozenVector frozen-    pure AppendVec-        { mutVec = mvec-        , mutVecLen = GMV.length mvec-        }-freezeAppend freeze = fmap FrozenAppendVec . freeze . getVector  -- | @'grow' vec amount maxSize@ grows the vector @vec@ by @amount@ elements, -- provided the result does not exceed @maxSize@. Amortized O(@amount@). Returns

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds                  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types                 #-} {-# LANGUAGE TypeFamilies               #-}@@ -13,16 +14,17 @@     , createPure     ) where -import Control.Monad.Catch      (Exception, MonadThrow (..), SomeException)+import Control.Monad.Catch      (Exception, MonadThrow(..), SomeException) import Control.Monad.Catch.Pure (CatchT, runCatchT)-import Control.Monad.Primitive  (PrimMonad (..))+import Control.Monad.Primitive  (PrimMonad(..)) import Control.Monad.ST         (ST)-import Control.Monad.Trans      (MonadTrans (..))+import Control.Monad.Trans      (MonadTrans(..))  import Capnp.Bits           (WordCount) import Capnp.TraversalLimit (LimitT, MonadLimit, evalLimitT)-import Data.Mutable         (Thaw (..), createT) +import Capnp.Mutability+ -- | '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@@@ -39,7 +41,7 @@ -- | @'createPure' limit m@ creates a capnproto value in pure code according -- to @m@, then freezes it without copying. If @m@ calls 'throwM' then -- 'createPure' rethrows the exception in the specified monad.-createPure :: (MonadThrow m, Thaw a) => WordCount -> (forall s. PureBuilder s (Mutable s a)) -> m a+createPure :: (MonadThrow m, MaybeMutable f) => WordCount -> (forall s. PureBuilder s (f ('Mut s))) -> m (f 'Const) createPure limit m = throwLeft $ createT (runPureBuilder limit m)   where     -- I(zenhack) am surprised not to have found this in one of the various

@@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds           #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -Wno-error=deprecations #-} module Module.Capnp.Basics (basicsTests) where  import Prelude hiding (length)@@ -18,9 +19,10 @@  import Capnp.New.Basics +import Capnp.Mutability (freeze) import Capnp.New     (List, Mutability(..), Raw(..), encode, evalLimitT, length, newMessage)-import Data.Mutable (Thaw(freeze))+-- import Data.Mutable (freeze)  basicsTests :: Spec basicsTests =@@ -29,7 +31,7 @@             property $ \(text :: T.Text) -> propertyIO $ evalLimitT maxBound $ do                 msg <- newMessage Nothing                 Raw untyped <- encode msg text-                raw :: Raw 'Const Text <- Raw <$> freeze untyped+                raw :: Raw Text 'Const <- Raw <$> freeze untyped                 buf <- textBuffer raw                 bytes <- textBytes raw-                liftIO $ BS.length bytes `shouldBe` length (coerce buf :: Raw 'Const (List Word8))+                liftIO $ BS.length bytes `shouldBe` length (coerce buf :: Raw (List Word8) 'Const)

@@ -12,9 +12,9 @@  import qualified Capnp.Gen.Capnp.Schema.New as N +import Capnp.Mutability     (freeze) import Capnp.New            (encodeField, encodeVariant, initVariant, readField) import Capnp.TraversalLimit (LimitT, evalLimitT)-import Data.Mutable         (Thaw(..)) import Util                 (decodeValue, schemaSchemaSrc)  import qualified Capnp.Message     as M

@@ -35,6 +35,7 @@  import Instances () +import Capnp.Mutability (freeze) import Capnp.New     ( IsStruct     , Mutability(..)@@ -46,7 +47,6 @@     , hPutParsed     , msgToParsed     )-import Data.Mutable (Thaw(..))  import qualified Capnp.Message as M import qualified Capnp.Untyped as U

@@ -14,6 +14,7 @@ import Data.Word import Test.Hspec +import Capnp.Mutability         (freeze) import Control.Concurrent.Async (concurrently_, race_) import Control.Exception.Safe   (bracket, try) import Control.Monad            (replicateM, void, (>=>))@@ -21,7 +22,6 @@ import Control.Monad.IO.Class   (liftIO) import Data.Foldable            (for_) import Data.Function            ((&))-import Data.Mutable             (freeze) import Data.Traversable         (for) import System.Timeout           (timeout) 

@@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-} -- The tests have a number of cases where we do stuff like: -- -- let 4 = ...@@ -20,6 +21,8 @@  import Test.Hspec +import Data.Word+ import Control.Monad           (forM_, when) import Control.Monad.Primitive (RealWorld) import Data.Foldable           (traverse_)@@ -36,10 +39,10 @@ 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.Mutable         (Thaw(..))  import Instances () @@ -111,7 +114,7 @@             return ()         endQuota `shouldBe` 117 -data ModTest s = ModTest+data ModTest = ModTest     { testIn   :: String     , testMod  :: Struct ('M.Mut RealWorld) -> LimitT IO ()     , testOut  :: String@@ -227,7 +230,7 @@             when (structPtrCount struct /= 2) $                 error "struct's pointer section is unexpedly small" -            let msg = message struct+            let msg = message @Struct struct             a <- allocStruct msg 1 1             aWithDefault <- allocStruct msg 1 1             b <- allocStruct msg 1 0@@ -243,7 +246,7 @@         , 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) 2 2 4+            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@@ -258,7 +261,7 @@         , testOut = "( boolvec = [true, false, true] )\n"         , testMod = \struct -> do             setData 39 0 struct -- Set the union tag.-            boolvec <- allocList1 (message struct) 3+            boolvec <- allocList1 (message @Struct struct) 3             forM_ [0..2] $ \i ->                 setIndex (even i) i boolvec             setPtr (Just $ PtrList $ List1 boolvec) 0 struct@@ -273,6 +276,14 @@     -- * 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 tagname tagvalue allocList dataCon =         ModTest             { testIn = "()"@@ -280,7 +291,7 @@             , testOut = "(" ++ tagname ++ " = [0, 1, 2, 3, 4])\n"             , testMod = \struct -> do                 setData tagvalue 0 struct-                vec <- allocList (message struct) 5+                vec <- allocList (message @Struct struct) 5                 forM_ [0..4] $ \i -> setIndex (fromIntegral i) i vec                 setPtr (Just $ PtrList $ dataCon vec) 0 struct             }

@@ -56,7 +56,7 @@             endQuota <- execLimitT 4096 (reader root)             endQuota `shouldBe` 3374   where-    reader :: Raw 'M.Const Schema.CodeGeneratorRequest -> LimitT IO ()+    reader :: Raw Schema.CodeGeneratorRequest 'M.Const -> LimitT IO ()     reader req = do         nodes <- req & readField #nodes         requestedFiles <- req & readField #requestedFiles