diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,15 @@ +# 0.12.0.0 + +* The 0.12.x series is the last major version that will support the old + API; the next release will not generate code for the old API, and some + low level interfaces will be removed. See + + for details. +* For the new API, there is a new `HasTypeId` class, with instances + defined for all generated types. +* The new API now supports implementing RPC servers. `Capnp.Tutorial` + discusses this, and the examples have been updated to use the new + API. # 0.11.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -22,9 +22,8 @@ type List(T) (where T is any non-struct type) to a list of a struct type. -Level 1 RPC support is implemented and usable, though there are a couple -gaps in the API. It should be considered alpha quality for now. Specific -things to be aware of: +Level 1 RPC support is implemented and usable, though it should be +considered alpha quality for now. Specific things to be aware of: * The implementation is *not* robust against resource exhaustion attacks; for now users are strongly discouraged from using it to do diff --git a/capnp.cabal b/capnp.cabal --- a/capnp.cabal +++ b/capnp.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: capnp -version: 0.11.0.0 +version: 0.12.0.0 category: Data, Serialization, Network, Rpc copyright: 2016-2021 haskell-capnp contributors (see CONTRIBUTORS file). author: Ian Denhardt @@ -42,11 +42,6 @@ , .gitattributes , .gitignore , .gitlab-ci.yml -tested-with: - -- Our Gitlab CI uses this version: - GHC == 8.4.3 - -- @zenhack currently uses this version: - , GHC == 8.6.3 -------------------------------------------------------------------------------- @@ -65,12 +60,12 @@ , containers >= 0.5.9 && <0.7 , data-default ^>= 0.7.1 , exceptions ^>= 0.10.0 - , ghc-prim ^>= 0.6.1 + , ghc-prim >= 0.6.1 && <0.8 , mtl ^>= 2.2.2 , primitive >= 0.6.3 && <0.8 , safe-exceptions ^>= 0.1.7 , text >= 1.2 && < 2.0 - , transformers ^>= 0.5.2 + , transformers >= 0.5.2 && <0.7 , vector ^>= 0.12.0 , monad-stm ^>= 0.1 ghc-options: @@ -110,6 +105,7 @@ , Capnp.New.Basics , Capnp.New.Classes , Capnp.New.Constraints + , Capnp.New.Rpc.Server , Capnp.Convert , Capnp.Errors , Capnp.Fields @@ -217,7 +213,7 @@ , supervisors ^>= 0.2.1 , lifetimes ^>= 0.1 , pretty-show >= 1.9.5 && <1.11 - , template-haskell ^>=2.16.0 + , template-haskell >=2.16.0 && <2.18 -------------------------------------------------------------------------------- diff --git a/cmd/capnpc-haskell/IR/Common.hs b/cmd/capnpc-haskell/IR/Common.hs --- a/cmd/capnpc-haskell/IR/Common.hs +++ b/cmd/capnpc-haskell/IR/Common.hs @@ -196,7 +196,7 @@ data Value b r = VoidValue | WordValue (WordType r) !Word64 - | PtrValue (PtrType b r) (Parsed B.AnyPointer) + | PtrValue (PtrType b r) (Maybe (Parsed B.AnyPointer)) deriving(Show, Eq, Functor) instance Bifunctor Value where diff --git a/cmd/capnpc-haskell/IR/Haskell.hs b/cmd/capnpc-haskell/IR/Haskell.hs --- a/cmd/capnpc-haskell/IR/Haskell.hs +++ b/cmd/capnpc-haskell/IR/Haskell.hs @@ -187,6 +187,8 @@ | ELambda [Pattern] Exp | ERecord Exp [(Name.UnQ, Exp)] | ELabel Name.UnQ + | EList [Exp] + | ETypeApp Exp [Type] -- TypeApplications; f @x @y @z deriving(Show, Read, Eq) data Do diff --git a/cmd/capnpc-haskell/IR/New.hs b/cmd/capnpc-haskell/IR/New.hs --- a/cmd/capnpc-haskell/IR/New.hs +++ b/cmd/capnpc-haskell/IR/New.hs @@ -37,13 +37,15 @@ } | MethodDecl { interfaceName :: Name.LocalQ - , typeParams :: [Name.UnQ] , interfaceId :: !Word64 - , methodName :: Name.UnQ , methodId :: !Word16 - , paramType :: C.CompositeType Brand Name.CapnpQ - , resultType :: C.CompositeType Brand Name.CapnpQ + , methodInfo :: MethodInfo } + | SuperDecl + { subName :: Name.LocalQ + , typeParams :: [Name.UnQ] + , superType :: C.InterfaceType Brand Name.CapnpQ + } | ParsedInstanceDecl { typeName :: Name.LocalQ , typeParams :: [Name.UnQ] @@ -66,6 +68,13 @@ { variants :: [(Name.UnQ, C.FieldLocType Brand Name.CapnpQ)] } +data MethodInfo = MethodInfo + { typeParams :: [Name.UnQ] + , methodName :: Name.UnQ + , paramType :: C.CompositeType Brand Name.CapnpQ + , resultType :: C.CompositeType Brand Name.CapnpQ + } + data ExtraTypeInfo = StructTypeInfo { nWords :: !Word16 @@ -73,6 +82,9 @@ } | EnumTypeInfo [Name.UnQ] | InterfaceTypeInfo + { methods :: [MethodInfo] + , supers :: [C.InterfaceType Brand Name.CapnpQ] + } data UnionVariant = UnionVariant { variantName :: Name.UnQ diff --git a/cmd/capnpc-haskell/Trans/CgrToStage1.hs b/cmd/capnpc-haskell/Trans/CgrToStage1.hs --- a/cmd/capnpc-haskell/Trans/CgrToStage1.hs +++ b/cmd/capnpc-haskell/Trans/CgrToStage1.hs @@ -111,13 +111,13 @@ C.WordValue (C.PrimWord C.PrimFloat64) (toWord v) Schema.Value'text v -> - C.PtrValue (C.PrimPtr C.PrimText) $ B.PtrList $ B.List8 $ + C.PtrValue (C.PrimPtr C.PrimText) $ Just $ B.PtrList $ B.List8 $ encodeUtf8 v & BS.unpack & (++ [0]) & V.fromList Schema.Value'data_ v -> - C.PtrValue (C.PrimPtr C.PrimText) $ B.PtrList $ B.List8 $ + C.PtrValue (C.PrimPtr C.PrimText) $ Just $ B.PtrList $ B.List8 $ BS.unpack v & V.fromList @@ -155,7 +155,7 @@ Schema.Type'interface Schema.Type'interface'{ typeId, brand } -> C.PtrValue (C.PtrInterface (C.InterfaceType (outMap M.! typeId) (brandToBrand outMap brand))) - B.PtrNull + Nothing _ -> mismatch diff --git a/cmd/capnpc-haskell/Trans/FlatToNew.hs b/cmd/capnpc-haskell/Trans/FlatToNew.hs --- a/cmd/capnpc-haskell/Trans/FlatToNew.hs +++ b/cmd/capnpc-haskell/Trans/FlatToNew.hs @@ -39,13 +39,10 @@ mkField field = fieldToDecl local typeParams field - mkMethod methodId Flat.Method{name, paramType, resultType} = - New.MethodDecl - { interfaceName = local - , interfaceId = nodeId - , typeParams = map C.paramName typeParams + mkMethodInfo Flat.Method{name, paramType, resultType} = + New.MethodInfo + { typeParams = map C.paramName typeParams , methodName = name - , methodId , paramType = mapTypes paramType , resultType = mapTypes resultType } @@ -105,9 +102,32 @@ [ New.ConstDecl { name = local, value = mapTypes value } ] Flat.Enum enumerants -> [ mkType (R.Data R.Sz16) $ Just $ New.EnumTypeInfo enumerants ] - Flat.Interface{methods} -> - mkType (R.Ptr (Just R.Cap)) (Just New.InterfaceTypeInfo) - : zipWith mkMethod [0..] methods + Flat.Interface{methods, supers} -> + let methodInfos = map mkMethodInfo methods + superTypes = map mapTypes supers + in + mkType + (R.Ptr (Just R.Cap)) + (Just New.InterfaceTypeInfo + { methods = methodInfos + , supers = superTypes + } + ) + : [ New.SuperDecl + { subName = local + , typeParams = map C.paramName typeParams + , superType = superType + } + | superType <- superTypes + ] ++ + [ New.MethodDecl + { interfaceName = local + , interfaceId = nodeId + , methodId + , methodInfo + } + | (methodId, methodInfo) <- zip [0..] methodInfos + ] Flat.Struct{isGroup, fields, union, dataWordCount = nWords, pointerCount = nPtrs} -> mkType (R.Ptr (Just R.Struct)) (Just New.StructTypeInfo { nWords, nPtrs }) : parsedStructNode fields (isJust union) isGroup diff --git a/cmd/capnpc-haskell/Trans/HaskellToText.hs b/cmd/capnpc-haskell/Trans/HaskellToText.hs --- a/cmd/capnpc-haskell/Trans/HaskellToText.hs +++ b/cmd/capnpc-haskell/Trans/HaskellToText.hs @@ -205,6 +205,7 @@ ] format (EBind x f) = PP.parens (format x <> " >>= " <> format f) format (ETup es) = PP.tupled (map format es) + format (EList es) = PP.list (map format es) format (ECase ex arms) = vcat [ hcat [ "case ", format ex, " of"] , indent $ vcat @@ -232,6 +233,8 @@ [ hcat [ format name, " = ", format value ] | (name, value) <- updates ] + format (ETypeApp e ts) = + hcat ("(": format e : [ " @(" <> format t <> ")" | t <- ts ] ++ [")"]) format (ELabel name) = "#" <> format name instance Format Do where diff --git a/cmd/capnpc-haskell/Trans/NewToHaskell.hs b/cmd/capnpc-haskell/Trans/NewToHaskell.hs --- a/cmd/capnpc-haskell/Trans/NewToHaskell.hs +++ b/cmd/capnpc-haskell/Trans/NewToHaskell.hs @@ -46,10 +46,13 @@ , "FlexibleInstances" , "MultiParamTypeClasses" , "UndecidableInstances" + , "UndecidableSuperClasses" , "OverloadedLabels" , "OverloadedStrings" , "StandaloneDeriving" , "RecordWildCards" + , "TypeApplications" + , "ScopedTypeVariables" ] , modExports = Nothing , modImports = imports @@ -75,7 +78,7 @@ declToDecls :: Word64 -> New.Decl -> [Hs.Decl] declToDecls thisMod decl = case decl of - New.TypeDecl {name, params, repr, extraTypeInfo} -> + New.TypeDecl {name, nodeId, params, repr, extraTypeInfo} -> let dataName = Name.localToUnQ name typeArgs = toTVars params typ = case typeArgs of @@ -107,6 +110,17 @@ , Hs.DcTypeInstance (Hs.TApp (tgName ["R"] "ReprFor") [typ]) (toType repr) + , Hs.DcInstance + { ctx = [] + , typ = Hs.TApp (tgName ["C"] "HasTypeId") [typ] + , defs = + [ Hs.IdValue Hs.DfValue + { name = "typeId" + , params = [] + , value = Hs.EInt (fromIntegral nodeId) + } + ] + } ] ++ let ctx = paramsContext typeArgs in case extraTypeInfo of @@ -252,8 +266,9 @@ , defs = [] } ] - Just New.InterfaceTypeInfo -> + Just New.InterfaceTypeInfo {methods, supers} -> defineInterfaceParse name params + ++ defineInterfaceServer thisMod name params methods supers Nothing -> [] New.FieldDecl{containerType, typeParams, fieldName, fieldLocType} -> let tVars = toTVars typeParams @@ -305,14 +320,27 @@ ] } : concatMap (variantToDecls thisMod name typeParams) variants + New.SuperDecl { subName, typeParams, superType } -> + let tVars = toTVars typeParams in + [ Hs.DcInstance + { ctx = paramsContext tVars + , typ = Hs.TApp (tgName ["C"] "Super") + [ typeToType thisMod $ C.PtrType $ C.PtrInterface superType + , Hs.TApp (Hs.TLName subName) tVars + ] + , defs = [] + } + ] New.MethodDecl { interfaceName - , typeParams , interfaceId - , methodName , methodId - , paramType - , resultType + , methodInfo = New.MethodInfo + { typeParams + , methodName + , paramType + , resultType + } } -> let tVars = toTVars typeParams in [ Hs.DcInstance @@ -546,11 +574,13 @@ C.PrimAnyPtr t -> anyPtrToType t anyPtrToType :: C.AnyPtr -> Hs.Type -anyPtrToType t = tgName ["Basics"] $ case t of - C.Struct -> "AnyStruct" - C.List -> "AnyList" - C.Cap -> "Capability" - C.Ptr -> "AnyPointer" +anyPtrToType t = case t of + C.Struct -> basics "AnyStruct" + C.List -> basics "AnyList" + C.Cap -> basics "Capability" + C.Ptr -> Hs.TApp (tStd_ "Maybe") [basics "AnyPointer"] + where + basics = tgName ["Basics"] compositeTypeToType thisMod (C.StructType name brand) = namedType thisMod name brand interfaceTypeToType thisMod (C.InterfaceType name brand) = namedType thisMod name brand @@ -864,6 +894,76 @@ ] } ] + +defineInterfaceServer thisMod typeName typeParams methods supers = + let tVars = toTVars typeParams + typ = Hs.TApp (Hs.TLName typeName) tVars + clsName = Name.mkSub typeName "server_" + in + [ Hs.DcInstance + { ctx = paramsContext tVars + , typ = Hs.TApp (tgName ["GH"] "Export") [typ] + , defs = + [ Hs.IdType $ Hs.TypeAlias "Server" [typ] $ Hs.TApp (Hs.TLName clsName) tVars + , Hs.IdValue Hs.DfValue + { name = "methodHandlerTree" + , params = [Hs.PVar "_", Hs.PVar "s_"] + , value = + Hs.EApp (egName ["GH"] "MethodHandlerTree") + [ Hs.ETypeApp (egName ["C"] "typeId") [typ] + , Hs.EList + [ Hs.EApp + (egName ["GH"] "toUntypedMethodHandler") + [ Hs.EApp + (Hs.ETypeApp + (Hs.EVar (Name.renderUnQ (Name.valueName (Name.mkSub typeName methodName)))) + tVars + ) + [Hs.EVar "s_"] + ] + | New.MethodInfo{methodName} <- methods + ] + , Hs.EList + [ Hs.EApp (egName ["GH"] "methodHandlerTree") + [ Hs.ETypeApp + (egName ["GH"] "Proxy") + [typeToType thisMod $ C.PtrType $ C.PtrInterface super] + , Hs.EVar "s_" + ] + | super <- supers + ] + ] + } + ] + } + , Hs.DcClass + { ctx = + [ Hs.TApp (tgName ["GH"] "Server") + [ typeToType thisMod $ C.PtrType $ C.PtrInterface super + , Hs.TVar "s_" + ] + | super <- supers + ] + , name = clsName + , params = map (Name.UnQ . Name.typeVarName) typeParams ++ ["s_"] + , funDeps = [] + , decls = + map (defineIfaceClassMethod thisMod typeName) methods + } + ] +defineIfaceClassMethod thisMod typeName New.MethodInfo{methodName, paramType, resultType} = + let mkType t = typeToType thisMod (C.CompositeType t) in + Hs.CdValueDecl + (Name.valueName (Name.mkSub typeName methodName)) + (Hs.TFn + [ Hs.TVar "s_" + , Hs.TApp + (tgName ["GH"] "MethodHandler") + [ mkType paramType + , mkType resultType + ] + ] + ) emitMarshalField :: Name.UnQ -> C.FieldLocType New.Brand Name.CapnpQ -> Hs.Exp emitMarshalField name (C.HereField _) = diff --git a/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs b/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs --- a/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs +++ b/cmd/capnpc-haskell/Trans/ToHaskellCommon.hs @@ -158,7 +158,7 @@ toTVars :: [Name.UnQ] -> [Type] toTVars = map (TVar . Name.typeVarName) -makePtrBytes :: Parsed B.AnyPointer -> LBS.ByteString +makePtrBytes :: Maybe (Parsed B.AnyPointer) -> LBS.ByteString makePtrBytes ptr = Capnp.msgToLBS $ fromJust $ Capnp.createPure Capnp.defaultLimit $ do msg <- Capnp.newMessage Nothing diff --git a/examples/gen/lib/Capnp/Gen/Calculator/New.hs b/examples/gen/lib/Capnp/Gen/Calculator/New.hs --- a/examples/gen/lib/Capnp/Gen/Calculator/New.hs +++ b/examples/gen/lib/Capnp/Gen/Calculator/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,9 +34,20 @@ import Prelude ((<$>), (<*>), (>>=)) data Calculator type instance (R.ReprFor Calculator) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Calculator) where + typeId = 10923537602090224694 instance (C.Parse Calculator (GH.Client Calculator)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Calculator) where + type Server Calculator = Calculator'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Calculator)) [(GH.toUntypedMethodHandler ((calculator'evaluate) s_)) + ,(GH.toUntypedMethodHandler ((calculator'defFunction) s_)) + ,(GH.toUntypedMethodHandler ((calculator'getOperator) s_))] []) +class (Calculator'server_ s_) where + calculator'evaluate :: s_ -> (GH.MethodHandler Calculator'evaluate'params Calculator'evaluate'results) + calculator'defFunction :: s_ -> (GH.MethodHandler Calculator'defFunction'params Calculator'defFunction'results) + calculator'getOperator :: s_ -> (GH.MethodHandler Calculator'getOperator'params Calculator'getOperator'results) instance (GH.HasMethod "evaluate" Calculator Calculator'evaluate'params Calculator'evaluate'results) where methodByLabel = (GH.Method 10923537602090224694 0) instance (GH.HasMethod "defFunction" Calculator Calculator'defFunction'params Calculator'defFunction'results) where @@ -42,6 +56,8 @@ methodByLabel = (GH.Method 10923537602090224694 2) data Calculator'evaluate'params type instance (R.ReprFor Calculator'evaluate'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Calculator'evaluate'params) where + typeId = 13478898619544909524 instance (C.TypedStruct Calculator'evaluate'params) where numStructWords = 0 numStructPtrs = 1 @@ -70,6 +86,8 @@ fieldByLabel = (GH.ptrField 0) data Calculator'evaluate'results type instance (R.ReprFor Calculator'evaluate'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Calculator'evaluate'results) where + typeId = 9345430975918089745 instance (C.TypedStruct Calculator'evaluate'results) where numStructWords = 0 numStructPtrs = 1 @@ -98,6 +116,8 @@ fieldByLabel = (GH.ptrField 0) data Calculator'defFunction'params type instance (R.ReprFor Calculator'defFunction'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Calculator'defFunction'params) where + typeId = 17476144387247758473 instance (C.TypedStruct Calculator'defFunction'params) where numStructWords = 1 numStructPtrs = 1 @@ -131,6 +151,8 @@ fieldByLabel = (GH.ptrField 0) data Calculator'defFunction'results type instance (R.ReprFor Calculator'defFunction'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Calculator'defFunction'results) where + typeId = 10170522573213587144 instance (C.TypedStruct Calculator'defFunction'results) where numStructWords = 0 numStructPtrs = 1 @@ -159,6 +181,8 @@ fieldByLabel = (GH.ptrField 0) data Calculator'getOperator'params type instance (R.ReprFor Calculator'getOperator'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Calculator'getOperator'params) where + typeId = 9983863225544066352 instance (C.TypedStruct Calculator'getOperator'params) where numStructWords = 1 numStructPtrs = 0 @@ -187,6 +211,8 @@ fieldByLabel = (GH.dataField 0 0 16 0) data Calculator'getOperator'results type instance (R.ReprFor Calculator'getOperator'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Calculator'getOperator'results) where + typeId = 15100494197045627936 instance (C.TypedStruct Calculator'getOperator'results) where numStructWords = 0 numStructPtrs = 1 @@ -215,6 +241,8 @@ fieldByLabel = (GH.ptrField 0) data Expression type instance (R.ReprFor Expression) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Expression) where + typeId = 15292209801435843861 instance (C.TypedStruct Expression) where numStructWords = 2 numStructPtrs = 2 @@ -307,6 +335,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Expression'call type instance (R.ReprFor Expression'call) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Expression'call) where + typeId = 15678475764784139622 instance (C.TypedStruct Expression'call) where numStructWords = 2 numStructPtrs = 2 @@ -340,13 +370,22 @@ fieldByLabel = (GH.ptrField 1) data Value type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Value) where + typeId = 14116142932258867410 instance (C.Parse Value (GH.Client Value)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Value) where + type Server Value = Value'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Value)) [(GH.toUntypedMethodHandler ((value'read) s_))] []) +class (Value'server_ s_) where + value'read :: s_ -> (GH.MethodHandler Value'read'params Value'read'results) instance (GH.HasMethod "read" Value Value'read'params Value'read'results) where methodByLabel = (GH.Method 14116142932258867410 0) data Value'read'params type instance (R.ReprFor Value'read'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value'read'params) where + typeId = 15227555948799047000 instance (C.TypedStruct Value'read'params) where numStructWords = 0 numStructPtrs = 0 @@ -370,6 +409,8 @@ marshalInto _raw (Value'read'params) = (Std_.pure ()) data Value'read'results type instance (R.ReprFor Value'read'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value'read'results) where + typeId = 16626840274624768034 instance (C.TypedStruct Value'read'results) where numStructWords = 1 numStructPtrs = 0 @@ -398,13 +439,22 @@ fieldByLabel = (GH.dataField 0 0 64 0) data Function type instance (R.ReprFor Function) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Function) where + typeId = 17143016017778443156 instance (C.Parse Function (GH.Client Function)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Function) where + type Server Function = Function'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Function)) [(GH.toUntypedMethodHandler ((function'call) s_))] []) +class (Function'server_ s_) where + function'call :: s_ -> (GH.MethodHandler Function'call'params Function'call'results) instance (GH.HasMethod "call" Function Function'call'params Function'call'results) where methodByLabel = (GH.Method 17143016017778443156 0) data Function'call'params type instance (R.ReprFor Function'call'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Function'call'params) where + typeId = 12795114529121400599 instance (C.TypedStruct Function'call'params) where numStructWords = 0 numStructPtrs = 1 @@ -433,6 +483,8 @@ fieldByLabel = (GH.ptrField 0) data Function'call'results type instance (R.ReprFor Function'call'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Function'call'results) where + typeId = 13898297529173597869 instance (C.TypedStruct Function'call'results) where numStructWords = 1 numStructPtrs = 0 @@ -467,6 +519,8 @@ | Operator'unknown' Std_.Word16 deriving(Std_.Eq,Std_.Show) type instance (R.ReprFor Operator) = (R.Data R.Sz16) +instance (C.HasTypeId Operator) where + typeId = 9769222902479511526 instance (Std_.Enum Operator) where toEnum n_ = case n_ of 0 -> diff --git a/examples/gen/lib/Capnp/Gen/Echo/New.hs b/examples/gen/lib/Capnp/Gen/Echo/New.hs --- a/examples/gen/lib/Capnp/Gen/Echo/New.hs +++ b/examples/gen/lib/Capnp/Gen/Echo/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,13 +34,22 @@ import Prelude ((<$>), (<*>), (>>=)) data Echo type instance (R.ReprFor Echo) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Echo) where + typeId = 16940812395455687611 instance (C.Parse Echo (GH.Client Echo)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Echo) where + type Server Echo = Echo'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) +class (Echo'server_ s_) where + echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where methodByLabel = (GH.Method 16940812395455687611 0) data Echo'echo'params type instance (R.ReprFor Echo'echo'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Echo'echo'params) where + typeId = 11805419372138457970 instance (C.TypedStruct Echo'echo'params) where numStructWords = 0 numStructPtrs = 1 @@ -66,6 +78,8 @@ fieldByLabel = (GH.ptrField 0) data Echo'echo'results type instance (R.ReprFor Echo'echo'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Echo'echo'results) where + typeId = 9634882973594762090 instance (C.TypedStruct Echo'echo'results) where numStructWords = 0 numStructPtrs = 1 diff --git a/examples/lib/Examples/Rpc/CalculatorServer.hs b/examples/lib/Examples/Rpc/CalculatorServer.hs --- a/examples/lib/Examples/Rpc/CalculatorServer.hs +++ b/examples/lib/Examples/Rpc/CalculatorServer.hs @@ -1,8 +1,10 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} module Examples.Rpc.CalculatorServer (main) where import Prelude hiding (subtract) @@ -11,40 +13,44 @@ import Control.Concurrent.STM (STM, atomically) import Control.Monad (when) +import Data.Function ((&)) +import Data.Functor ((<&>)) import Network.Simple.TCP (serve) import Supervisors (Supervisor) import qualified Data.Vector as V -import Capnp (def, defaultLimit) -import Capnp.Rpc - ( ConnConfig (..) - , Server - , handleConn - , pureHandler - , socketTransport - , throwFailed - , toClient - , wait - , (?) +import Capnp.New + ( Client + , Pipeline + , SomeServer + , callP + , def + , defaultLimit + , export + , getField + , handleParsed + , waitPipeline ) +import Capnp.Rpc + (ConnConfig(..), handleConn, socketTransport, throwFailed, toClient) -import Capnp.Gen.Calculator.Pure +import Capnp.Gen.Calculator.New newtype LitValue = LitValue Double -instance Server IO LitValue +instance SomeServer LitValue -instance Value'server_ IO LitValue where - value'read = pureHandler $ \(LitValue val) _ -> +instance Value'server_ LitValue where + value'read (LitValue val) = handleParsed $ \_ -> pure Value'read'results { value = val } newtype OpFunc = OpFunc (Double -> Double -> Double) -instance Server IO OpFunc +instance SomeServer OpFunc -instance Function'server_ IO OpFunc where - function'call = pureHandler $ \(OpFunc op) Function'call'params{params} -> do +instance Function'server_ OpFunc where + function'call (OpFunc op) = handleParsed $ \Function'call'params{params} -> do when (V.length params /= 2) $ throwFailed "Wrong number of parameters." pure Function'call'results @@ -52,36 +58,40 @@ data ExprFunc = ExprFunc { paramCount :: !Int32 - , body :: Expression + , body :: Parsed Expression } -instance Server IO ExprFunc +instance SomeServer ExprFunc -instance Function'server_ IO ExprFunc where - function'call = - pureHandler $ \ExprFunc{..} Function'call'params{params} -> do +instance Function'server_ ExprFunc where + function'call ExprFunc{..} = + handleParsed $ \Function'call'params{params} -> do when (fromIntegral (V.length params) /= paramCount) $ throwFailed "Wrong number of parameters." - Function'call'results <$> eval params body + eval params body + >>= waitResult + <&> Function'call'results data MyCalc = MyCalc - { add :: Function - , subtract :: Function - , multiply :: Function - , divide :: Function + { add :: Client Function + , subtract :: Client Function + , multiply :: Client Function + , divide :: Client Function , sup :: Supervisor } -instance Server IO MyCalc +instance SomeServer MyCalc -instance Calculator'server_ IO MyCalc where - calculator'evaluate = - pureHandler $ \MyCalc{sup} Calculator'evaluate'params{expression} -> - Calculator'evaluate'results <$> - (eval V.empty expression >>= atomically . export_Value sup . LitValue) +instance Calculator'server_ MyCalc where + calculator'evaluate MyCalc{sup} = + handleParsed $ \Calculator'evaluate'params{expression} -> do + eval V.empty expression + >>= waitResult + >>= export @Value sup . LitValue + <&> Calculator'evaluate'results - calculator'getOperator = - pureHandler $ \MyCalc{..} Calculator'getOperator'params{op} -> + calculator'getOperator MyCalc{..} = + handleParsed $ \Calculator'getOperator'params{op} -> Calculator'getOperator'results <$> case op of Operator'add -> pure add Operator'subtract -> pure subtract @@ -91,38 +101,51 @@ Operator'unknown' _ -> throwFailed "Unknown operator" - calculator'defFunction = - pureHandler $ \MyCalc{sup} Calculator'defFunction'params{..} -> + calculator'defFunction MyCalc{sup} = + handleParsed $ \Calculator'defFunction'params{..} -> Calculator'defFunction'results <$> - atomically (export_Function sup ExprFunc{..}) + atomically (export @Function sup ExprFunc{..}) -newCalculator :: Supervisor -> STM Calculator +newCalculator :: Supervisor -> STM (Client Calculator) newCalculator sup = do - add <- export_Function sup $ OpFunc (+) - subtract <- export_Function sup $ OpFunc (-) - multiply <- export_Function sup $ OpFunc (*) - divide <- export_Function sup $ OpFunc (/) - export_Calculator sup MyCalc{..} + add <- export @Function sup $ OpFunc (+) + subtract <- export @Function sup $ OpFunc (-) + multiply <- export @Function sup $ OpFunc (*) + divide <- export @Function sup $ OpFunc (/) + export @Calculator sup MyCalc{..} -eval :: V.Vector Double -> Expression -> IO Double -eval _ (Expression'literal lit) = - pure lit -eval _ (Expression'previousResult val) = do - Value'read'results{value} <- value'read val ? def >>= wait - pure value -eval args (Expression'parameter idx) - | fromIntegral idx >= V.length args = - throwFailed "Parameter index out of bounds" - | otherwise = - pure $ args V.! fromIntegral idx -eval outerParams (Expression'call Expression'call'{function, params=innerParams}) = do - args' <- traverse (eval outerParams) innerParams - Function'call'results{value} <- - function'call function ? Function'call'params { params = args' } - >>= wait - pure value -eval _ (Expression'unknown' _) = - throwFailed "Unknown expression type" + +data EvalResult + = Immediate Double + | CallResult (Pipeline Function'call'results) + | ReadResult (Pipeline Value'read'results) + +waitResult :: EvalResult -> IO Double +waitResult (Immediate v) = pure v +waitResult (CallResult p) = getField #value <$> waitPipeline p +waitResult (ReadResult p) = getField #value <$> waitPipeline p + +eval :: V.Vector Double -> Parsed Expression -> IO EvalResult +eval outerParams (Expression exp) = go outerParams exp where + go _ (Expression'literal lit) = + pure $ Immediate lit + go _ (Expression'previousResult val) = do + val + & callP #read def + <&> ReadResult + go args (Expression'parameter idx) + | fromIntegral idx >= V.length args = + throwFailed "Parameter index out of bounds" + | otherwise = + pure $ Immediate $ args V.! fromIntegral idx + go outerParams (Expression'call Expression'call'{function, params=innerParams}) = do + argPipelines <- traverse (eval outerParams) innerParams + argValues <- traverse waitResult argPipelines + function + & callP #call Function'call'params { params = argValues } + <&> CallResult + go _ (Expression'unknown' _) = + throwFailed "Unknown expression type" main :: IO () main = serve "localhost" "4000" $ \(sock, _addr) -> diff --git a/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs b/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs --- a/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/Compat/Json/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,6 +34,8 @@ import Prelude ((<$>), (<*>), (>>=)) data Value type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value) where + typeId = 11815888814287216003 instance (C.TypedStruct Value) where numStructWords = 2 numStructPtrs = 1 @@ -150,6 +155,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Value'Field type instance (R.ReprFor Value'Field) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value'Field) where + typeId = 16361620220719570399 instance (C.TypedStruct Value'Field) where numStructWords = 0 numStructPtrs = 2 @@ -183,6 +190,8 @@ fieldByLabel = (GH.ptrField 1) data Value'Call type instance (R.ReprFor Value'Call) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value'Call) where + typeId = 11590566612201717064 instance (C.TypedStruct Value'Call) where numStructWords = 0 numStructPtrs = 2 @@ -216,6 +225,8 @@ fieldByLabel = (GH.ptrField 1) data FlattenOptions type instance (R.ReprFor FlattenOptions) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId FlattenOptions) where + typeId = 14186078402951440993 instance (C.TypedStruct FlattenOptions) where numStructWords = 0 numStructPtrs = 1 @@ -244,6 +255,8 @@ fieldByLabel = (GH.ptrField 0) data DiscriminatorOptions type instance (R.ReprFor DiscriminatorOptions) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId DiscriminatorOptions) where + typeId = 14049192395069608729 instance (C.TypedStruct DiscriminatorOptions) where numStructWords = 0 numStructPtrs = 2 diff --git a/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs b/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs --- a/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/Cxx/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} diff --git a/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs b/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs --- a/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/Persistent/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,15 +34,25 @@ import Prelude ((<$>), (<*>), (>>=)) data Persistent sturdyRef owner type instance (R.ReprFor (Persistent sturdyRef owner)) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId (Persistent sturdyRef owner)) where + typeId = 14468694717054801553 instance ((GH.TypeParam sturdyRef) ,(GH.TypeParam owner)) => (C.Parse (Persistent sturdyRef owner) (GH.Client (Persistent sturdyRef owner))) where parse = GH.parseCap encode = GH.encodeCap instance ((GH.TypeParam sturdyRef) + ,(GH.TypeParam owner)) => (GH.Export (Persistent sturdyRef owner)) where + type Server (Persistent sturdyRef owner) = (Persistent'server_ sturdyRef owner) + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((Persistent sturdyRef owner))) [(GH.toUntypedMethodHandler ((persistent'save @(sturdyRef) @(owner)) s_))] []) +class (Persistent'server_ sturdyRef owner s_) where + persistent'save :: s_ -> (GH.MethodHandler (Persistent'SaveParams sturdyRef owner) (Persistent'SaveResults sturdyRef owner)) +instance ((GH.TypeParam sturdyRef) ,(GH.TypeParam owner)) => (GH.HasMethod "save" (Persistent sturdyRef owner) (Persistent'SaveParams sturdyRef owner) (Persistent'SaveResults sturdyRef owner)) where methodByLabel = (GH.Method 14468694717054801553 0) data Persistent'SaveParams sturdyRef owner type instance (R.ReprFor (Persistent'SaveParams sturdyRef owner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Persistent'SaveParams sturdyRef owner)) where + typeId = 17829674341603767205 instance ((GH.TypeParam sturdyRef) ,(GH.TypeParam owner)) => (C.TypedStruct (Persistent'SaveParams sturdyRef owner)) where numStructWords = 0 @@ -78,6 +91,8 @@ fieldByLabel = (GH.ptrField 0) data Persistent'SaveResults sturdyRef owner type instance (R.ReprFor (Persistent'SaveResults sturdyRef owner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Persistent'SaveResults sturdyRef owner)) where + typeId = 13215893102637674431 instance ((GH.TypeParam sturdyRef) ,(GH.TypeParam owner)) => (C.TypedStruct (Persistent'SaveResults sturdyRef owner)) where numStructWords = 0 @@ -116,6 +131,8 @@ fieldByLabel = (GH.ptrField 0) data RealmGateway internalRef externalRef internalOwner externalOwner type instance (R.ReprFor (RealmGateway internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId (RealmGateway internalRef externalRef internalOwner externalOwner)) where + typeId = 9583422979879616212 instance ((GH.TypeParam internalRef) ,(GH.TypeParam externalRef) ,(GH.TypeParam internalOwner) @@ -125,6 +142,16 @@ instance ((GH.TypeParam internalRef) ,(GH.TypeParam externalRef) ,(GH.TypeParam internalOwner) + ,(GH.TypeParam externalOwner)) => (GH.Export (RealmGateway internalRef externalRef internalOwner externalOwner)) where + type Server (RealmGateway internalRef externalRef internalOwner externalOwner) = (RealmGateway'server_ internalRef externalRef internalOwner externalOwner) + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((RealmGateway internalRef externalRef internalOwner externalOwner))) [(GH.toUntypedMethodHandler ((realmGateway'import_ @(internalRef) @(externalRef) @(internalOwner) @(externalOwner)) s_)) + ,(GH.toUntypedMethodHandler ((realmGateway'export @(internalRef) @(externalRef) @(internalOwner) @(externalOwner)) s_))] []) +class (RealmGateway'server_ internalRef externalRef internalOwner externalOwner s_) where + realmGateway'import_ :: s_ -> (GH.MethodHandler (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults internalRef internalOwner)) + realmGateway'export :: s_ -> (GH.MethodHandler (RealmGateway'export'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults externalRef externalOwner)) +instance ((GH.TypeParam internalRef) + ,(GH.TypeParam externalRef) + ,(GH.TypeParam internalOwner) ,(GH.TypeParam externalOwner)) => (GH.HasMethod "import_" (RealmGateway internalRef externalRef internalOwner externalOwner) (RealmGateway'import'params internalRef externalRef internalOwner externalOwner) (Persistent'SaveResults internalRef internalOwner)) where methodByLabel = (GH.Method 9583422979879616212 0) instance ((GH.TypeParam internalRef) @@ -134,6 +161,8 @@ methodByLabel = (GH.Method 9583422979879616212 1) data RealmGateway'import'params internalRef externalRef internalOwner externalOwner type instance (R.ReprFor (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (RealmGateway'import'params internalRef externalRef internalOwner externalOwner)) where + typeId = 17348653140467603277 instance ((GH.TypeParam internalRef) ,(GH.TypeParam externalRef) ,(GH.TypeParam internalOwner) @@ -200,6 +229,8 @@ fieldByLabel = (GH.ptrField 1) data RealmGateway'export'params internalRef externalRef internalOwner externalOwner type instance (R.ReprFor (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (RealmGateway'export'params internalRef externalRef internalOwner externalOwner)) where + typeId = 17055027933458834346 instance ((GH.TypeParam internalRef) ,(GH.TypeParam externalRef) ,(GH.TypeParam internalOwner) diff --git a/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs b/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs --- a/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/Rpc/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,6 +34,8 @@ import Prelude ((<$>), (<*>), (>>=)) data Message type instance (R.ReprFor Message) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Message) where + typeId = 10500036013887172658 instance (C.TypedStruct Message) where numStructWords = 1 numStructPtrs = 1 @@ -64,9 +69,9 @@ | 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_ Basics.AnyPointer) + | RW_Message'obsoleteSave (R.Raw mut_ (Std_.Maybe Basics.AnyPointer)) | RW_Message'bootstrap (R.Raw mut_ Bootstrap) - | RW_Message'obsoleteDelete (R.Raw mut_ Basics.AnyPointer) + | 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) @@ -118,11 +123,11 @@ variantByLabel = (GH.Variant (GH.ptrField 0) 5) instance (GH.HasVariant "release" GH.Slot Message Release) where variantByLabel = (GH.Variant (GH.ptrField 0) 6) -instance (GH.HasVariant "obsoleteSave" GH.Slot Message Basics.AnyPointer) where +instance (GH.HasVariant "obsoleteSave" GH.Slot Message (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 0) 7) instance (GH.HasVariant "bootstrap" GH.Slot Message Bootstrap) where variantByLabel = (GH.Variant (GH.ptrField 0) 8) -instance (GH.HasVariant "obsoleteDelete" GH.Slot Message Basics.AnyPointer) where +instance (GH.HasVariant "obsoleteDelete" GH.Slot Message (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 0) 9) instance (GH.HasVariant "provide" GH.Slot Message Provide) where variantByLabel = (GH.Variant (GH.ptrField 0) 10) @@ -140,9 +145,9 @@ | Message'finish (RP.Parsed Finish) | Message'resolve (RP.Parsed Resolve) | Message'release (RP.Parsed Release) - | Message'obsoleteSave (RP.Parsed Basics.AnyPointer) + | Message'obsoleteSave (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Message'bootstrap (RP.Parsed Bootstrap) - | Message'obsoleteDelete (RP.Parsed Basics.AnyPointer) + | Message'obsoleteDelete (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Message'provide (RP.Parsed Provide) | Message'accept (RP.Parsed Accept) | Message'join (RP.Parsed Join) @@ -220,6 +225,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Bootstrap type instance (R.ReprFor Bootstrap) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bootstrap) where + typeId = 16811039658553601732 instance (C.TypedStruct Bootstrap) where numStructWords = 1 numStructPtrs = 1 @@ -234,7 +241,7 @@ data instance C.Parsed Bootstrap = Bootstrap {questionId :: (RP.Parsed Std_.Word32) - ,deprecatedObjectId :: (RP.Parsed Basics.AnyPointer)} + ,deprecatedObjectId :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Bootstrap)) deriving instance (Std_.Eq (C.Parsed Bootstrap)) @@ -249,10 +256,12 @@ ) instance (GH.HasField "questionId" GH.Slot Bootstrap Std_.Word32) where fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "deprecatedObjectId" GH.Slot Bootstrap Basics.AnyPointer) where +instance (GH.HasField "deprecatedObjectId" GH.Slot Bootstrap (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 0) data Call type instance (R.ReprFor Call) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Call) where + typeId = 9469473312751832276 instance (C.TypedStruct Call) where numStructWords = 3 numStructPtrs = 3 @@ -314,6 +323,8 @@ fieldByLabel = (GH.dataField 0 2 1 0) data Call'sendResultsTo type instance (R.ReprFor Call'sendResultsTo) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Call'sendResultsTo) where + typeId = 15774052265921044377 instance (C.TypedStruct Call'sendResultsTo) where numStructWords = 3 numStructPtrs = 3 @@ -342,7 +353,7 @@ 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_ Basics.AnyPointer) + | RW_Call'sendResultsTo'thirdParty (R.Raw mut_ (Std_.Maybe Basics.AnyPointer)) | RW_Call'sendResultsTo'unknown' Std_.Word16 internalWhich tag_ struct_ = case tag_ of 0 -> @@ -358,12 +369,12 @@ variantByLabel = (GH.Variant GH.voidField 0) instance (GH.HasVariant "yourself" GH.Slot Call'sendResultsTo ()) where variantByLabel = (GH.Variant GH.voidField 1) -instance (GH.HasVariant "thirdParty" GH.Slot Call'sendResultsTo Basics.AnyPointer) where +instance (GH.HasVariant "thirdParty" GH.Slot Call'sendResultsTo (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 2) 2) data instance C.Parsed (GH.Which Call'sendResultsTo) = Call'sendResultsTo'caller | Call'sendResultsTo'yourself - | Call'sendResultsTo'thirdParty (RP.Parsed Basics.AnyPointer) + | Call'sendResultsTo'thirdParty (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Call'sendResultsTo'unknown' Std_.Word16 deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed (GH.Which Call'sendResultsTo))) @@ -393,6 +404,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Return type instance (R.ReprFor Return) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Return) where + typeId = 11392333052105676602 instance (C.TypedStruct Return) where numStructWords = 2 numStructPtrs = 1 @@ -430,7 +443,7 @@ | 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_ Basics.AnyPointer) + | RW_Return'acceptFromThirdParty (R.Raw mut_ (Std_.Maybe Basics.AnyPointer)) | RW_Return'unknown' Std_.Word16 internalWhich tag_ struct_ = case tag_ of 0 -> @@ -458,7 +471,7 @@ variantByLabel = (GH.Variant GH.voidField 3) instance (GH.HasVariant "takeFromOtherQuestion" GH.Slot Return Std_.Word32) where variantByLabel = (GH.Variant (GH.dataField 0 1 32 0) 4) -instance (GH.HasVariant "acceptFromThirdParty" GH.Slot Return Basics.AnyPointer) where +instance (GH.HasVariant "acceptFromThirdParty" GH.Slot Return (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 0) 5) data instance C.Parsed (GH.Which Return) = Return'results (RP.Parsed Payload) @@ -466,7 +479,7 @@ | Return'canceled | Return'resultsSentElsewhere | Return'takeFromOtherQuestion (RP.Parsed Std_.Word32) - | Return'acceptFromThirdParty (RP.Parsed Basics.AnyPointer) + | Return'acceptFromThirdParty (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Return'unknown' Std_.Word16 deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed (GH.Which Return))) @@ -512,6 +525,8 @@ fieldByLabel = (GH.dataField 32 0 1 1) data Finish type instance (R.ReprFor Finish) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Finish) where + typeId = 15239388059401719395 instance (C.TypedStruct Finish) where numStructWords = 1 numStructPtrs = 0 @@ -545,6 +560,8 @@ fieldByLabel = (GH.dataField 32 0 1 1) data Resolve type instance (R.ReprFor Resolve) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Resolve) where + typeId = 13529541526594062446 instance (C.TypedStruct Resolve) where numStructWords = 1 numStructPtrs = 1 @@ -619,6 +636,8 @@ fieldByLabel = (GH.dataField 0 0 32 0) data Release type instance (R.ReprFor Release) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Release) where + typeId = 12473400923157197975 instance (C.TypedStruct Release) where numStructWords = 1 numStructPtrs = 0 @@ -652,6 +671,8 @@ fieldByLabel = (GH.dataField 32 0 32 0) data Disembargo type instance (R.ReprFor Disembargo) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Disembargo) where + typeId = 17970548384007534353 instance (C.TypedStruct Disembargo) where numStructWords = 1 numStructPtrs = 1 @@ -688,6 +709,8 @@ fieldByLabel = GH.groupField data Disembargo'context type instance (R.ReprFor Disembargo'context) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Disembargo'context) where + typeId = 15376050949367520589 instance (C.TypedStruct Disembargo'context) where numStructWords = 1 numStructPtrs = 1 @@ -777,6 +800,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Provide type instance (R.ReprFor Provide) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Provide) where + typeId = 11270825879279873114 instance (C.TypedStruct Provide) where numStructWords = 1 numStructPtrs = 2 @@ -792,7 +817,7 @@ = Provide {questionId :: (RP.Parsed Std_.Word32) ,target :: (RP.Parsed MessageTarget) - ,recipient :: (RP.Parsed Basics.AnyPointer)} + ,recipient :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Provide)) deriving instance (Std_.Eq (C.Parsed Provide)) @@ -811,10 +836,12 @@ fieldByLabel = (GH.dataField 0 0 32 0) instance (GH.HasField "target" GH.Slot Provide MessageTarget) where fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "recipient" GH.Slot Provide Basics.AnyPointer) where +instance (GH.HasField "recipient" GH.Slot Provide (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 1) data Accept type instance (R.ReprFor Accept) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Accept) where + typeId = 15332985841292492822 instance (C.TypedStruct Accept) where numStructWords = 1 numStructPtrs = 1 @@ -829,7 +856,7 @@ data instance C.Parsed Accept = Accept {questionId :: (RP.Parsed Std_.Word32) - ,provision :: (RP.Parsed Basics.AnyPointer) + ,provision :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) ,embargo :: (RP.Parsed Std_.Bool)} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Accept)) @@ -847,12 +874,14 @@ ) instance (GH.HasField "questionId" GH.Slot Accept Std_.Word32) where fieldByLabel = (GH.dataField 0 0 32 0) -instance (GH.HasField "provision" GH.Slot Accept Basics.AnyPointer) where +instance (GH.HasField "provision" GH.Slot Accept (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 0) instance (GH.HasField "embargo" GH.Slot Accept Std_.Bool) where fieldByLabel = (GH.dataField 32 0 1 0) data Join type instance (R.ReprFor Join) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Join) where + typeId = 18149955118657700271 instance (C.TypedStruct Join) where numStructWords = 1 numStructPtrs = 2 @@ -868,7 +897,7 @@ = Join {questionId :: (RP.Parsed Std_.Word32) ,target :: (RP.Parsed MessageTarget) - ,keyPart :: (RP.Parsed Basics.AnyPointer)} + ,keyPart :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Join)) deriving instance (Std_.Eq (C.Parsed Join)) @@ -887,10 +916,12 @@ fieldByLabel = (GH.dataField 0 0 32 0) instance (GH.HasField "target" GH.Slot Join MessageTarget) where fieldByLabel = (GH.ptrField 0) -instance (GH.HasField "keyPart" GH.Slot Join Basics.AnyPointer) where +instance (GH.HasField "keyPart" GH.Slot Join (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 1) data MessageTarget type instance (R.ReprFor MessageTarget) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId MessageTarget) where + typeId = 10789521159760378817 instance (C.TypedStruct MessageTarget) where numStructWords = 1 numStructPtrs = 1 @@ -960,6 +991,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Payload type instance (R.ReprFor Payload) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Payload) where + typeId = 11100916931204903995 instance (C.TypedStruct Payload) where numStructWords = 0 numStructPtrs = 2 @@ -973,7 +1006,7 @@ instance (C.EstimateListAlloc Payload (C.Parsed Payload)) data instance C.Parsed Payload = Payload - {content :: (RP.Parsed Basics.AnyPointer) + {content :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) ,capTable :: (RP.Parsed (R.List CapDescriptor))} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed Payload)) @@ -987,12 +1020,14 @@ (GH.encodeField #capTable capTable raw_) (Std_.pure ()) ) -instance (GH.HasField "content" GH.Slot Payload Basics.AnyPointer) where +instance (GH.HasField "content" GH.Slot Payload (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 0) instance (GH.HasField "capTable" GH.Slot Payload (R.List CapDescriptor)) where fieldByLabel = (GH.ptrField 1) data CapDescriptor type instance (R.ReprFor CapDescriptor) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CapDescriptor) where + typeId = 9593755465305995440 instance (C.TypedStruct CapDescriptor) where numStructWords = 1 numStructPtrs = 1 @@ -1107,6 +1142,8 @@ fieldByLabel = (GH.dataField 16 0 8 255) data PromisedAnswer type instance (R.ReprFor PromisedAnswer) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId PromisedAnswer) where + typeId = 15564635848320162976 instance (C.TypedStruct PromisedAnswer) where numStructWords = 1 numStructPtrs = 1 @@ -1140,6 +1177,8 @@ fieldByLabel = (GH.ptrField 0) data PromisedAnswer'Op type instance (R.ReprFor PromisedAnswer'Op) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId PromisedAnswer'Op) where + typeId = 17516350820840804481 instance (C.TypedStruct PromisedAnswer'Op) where numStructWords = 1 numStructPtrs = 0 @@ -1209,6 +1248,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data ThirdPartyCapDescriptor type instance (R.ReprFor ThirdPartyCapDescriptor) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ThirdPartyCapDescriptor) where + typeId = 15235686326393111165 instance (C.TypedStruct ThirdPartyCapDescriptor) where numStructWords = 1 numStructPtrs = 1 @@ -1222,7 +1263,7 @@ instance (C.EstimateListAlloc ThirdPartyCapDescriptor (C.Parsed ThirdPartyCapDescriptor)) data instance C.Parsed ThirdPartyCapDescriptor = ThirdPartyCapDescriptor - {id :: (RP.Parsed Basics.AnyPointer) + {id :: (RP.Parsed (Std_.Maybe Basics.AnyPointer)) ,vineId :: (RP.Parsed Std_.Word32)} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed ThirdPartyCapDescriptor)) @@ -1236,12 +1277,14 @@ (GH.encodeField #vineId vineId raw_) (Std_.pure ()) ) -instance (GH.HasField "id" GH.Slot ThirdPartyCapDescriptor Basics.AnyPointer) where +instance (GH.HasField "id" GH.Slot ThirdPartyCapDescriptor (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 0) instance (GH.HasField "vineId" GH.Slot ThirdPartyCapDescriptor Std_.Word32) where fieldByLabel = (GH.dataField 0 0 32 0) data Exception type instance (R.ReprFor Exception) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Exception) where + typeId = 15430940935639230746 instance (C.TypedStruct Exception) where numStructWords = 1 numStructPtrs = 1 @@ -1291,6 +1334,8 @@ | Exception'Type'unknown' Std_.Word16 deriving(Std_.Eq,Std_.Show) type instance (R.ReprFor Exception'Type) = (R.Data R.Sz16) +instance (C.HasTypeId Exception'Type) where + typeId = 12865824133959433560 instance (Std_.Enum Exception'Type) where toEnum n_ = case n_ of 0 -> diff --git a/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs b/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs --- a/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/RpcTwoparty/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -35,6 +38,8 @@ | Side'unknown' Std_.Word16 deriving(Std_.Eq,Std_.Show) type instance (R.ReprFor Side) = (R.Data R.Sz16) +instance (C.HasTypeId Side) where + typeId = 11517567629614739868 instance (Std_.Enum Side) where toEnum n_ = case n_ of 0 -> @@ -61,6 +66,8 @@ instance (C.EstimateListAlloc Side Side) data VatId type instance (R.ReprFor VatId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VatId) where + typeId = 15135349989283412622 instance (C.TypedStruct VatId) where numStructWords = 1 numStructPtrs = 0 @@ -89,6 +96,8 @@ fieldByLabel = (GH.dataField 0 0 16 0) data ProvisionId type instance (R.ReprFor ProvisionId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ProvisionId) where + typeId = 13298295899470141463 instance (C.TypedStruct ProvisionId) where numStructWords = 1 numStructPtrs = 0 @@ -117,6 +126,8 @@ fieldByLabel = (GH.dataField 0 0 32 0) data RecipientId type instance (R.ReprFor RecipientId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId RecipientId) where + typeId = 9940440221562733249 instance (C.TypedStruct RecipientId) where numStructWords = 0 numStructPtrs = 0 @@ -140,6 +151,8 @@ marshalInto _raw (RecipientId) = (Std_.pure ()) data ThirdPartyCapId type instance (R.ReprFor ThirdPartyCapId) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ThirdPartyCapId) where + typeId = 13006195034640135581 instance (C.TypedStruct ThirdPartyCapId) where numStructWords = 0 numStructPtrs = 0 @@ -163,6 +176,8 @@ marshalInto _raw (ThirdPartyCapId) = (Std_.pure ()) data JoinKeyPart type instance (R.ReprFor JoinKeyPart) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId JoinKeyPart) where + typeId = 10786842769591618179 instance (C.TypedStruct JoinKeyPart) where numStructWords = 1 numStructPtrs = 0 @@ -201,6 +216,8 @@ fieldByLabel = (GH.dataField 48 0 16 0) data JoinResult type instance (R.ReprFor JoinResult) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId JoinResult) where + typeId = 11323802317489695726 instance (C.TypedStruct JoinResult) where numStructWords = 1 numStructPtrs = 1 @@ -216,7 +233,7 @@ = JoinResult {joinId :: (RP.Parsed Std_.Word32) ,succeeded :: (RP.Parsed Std_.Bool) - ,cap :: (RP.Parsed Basics.AnyPointer)} + ,cap :: (RP.Parsed (Std_.Maybe Basics.AnyPointer))} deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed JoinResult)) deriving instance (Std_.Eq (C.Parsed JoinResult)) @@ -235,5 +252,5 @@ fieldByLabel = (GH.dataField 0 0 32 0) instance (GH.HasField "succeeded" GH.Slot JoinResult Std_.Bool) where fieldByLabel = (GH.dataField 32 0 1 0) -instance (GH.HasField "cap" GH.Slot JoinResult Basics.AnyPointer) where +instance (GH.HasField "cap" GH.Slot JoinResult (Std_.Maybe Basics.AnyPointer)) where fieldByLabel = (GH.ptrField 0) diff --git a/gen/lib/Capnp/Gen/Capnp/Schema/New.hs b/gen/lib/Capnp/Gen/Capnp/Schema/New.hs --- a/gen/lib/Capnp/Gen/Capnp/Schema/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/Schema/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,6 +34,8 @@ import Prelude ((<$>), (<*>), (>>=)) data Node type instance (R.ReprFor Node) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node) where + typeId = 16610026722781537303 instance (C.TypedStruct Node) where numStructWords = 5 numStructPtrs = 6 @@ -195,6 +200,8 @@ fieldByLabel = (GH.dataField 32 4 1 0) data Node'struct type instance (R.ReprFor Node'struct) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'struct) where + typeId = 11430331134483579957 instance (C.TypedStruct Node'struct) where numStructWords = 5 numStructPtrs = 6 @@ -253,6 +260,8 @@ fieldByLabel = (GH.ptrField 3) data Node'enum type instance (R.ReprFor Node'enum) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'enum) where + typeId = 13063450714778629528 instance (C.TypedStruct Node'enum) where numStructWords = 5 numStructPtrs = 6 @@ -281,6 +290,8 @@ fieldByLabel = (GH.ptrField 3) data Node'interface type instance (R.ReprFor Node'interface) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'interface) where + typeId = 16728431493453586831 instance (C.TypedStruct Node'interface) where numStructWords = 5 numStructPtrs = 6 @@ -314,6 +325,8 @@ fieldByLabel = (GH.ptrField 4) data Node'const type instance (R.ReprFor Node'const) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'const) where + typeId = 12793219851699983392 instance (C.TypedStruct Node'const) where numStructWords = 5 numStructPtrs = 6 @@ -347,6 +360,8 @@ fieldByLabel = (GH.ptrField 4) data Node'annotation type instance (R.ReprFor Node'annotation) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'annotation) where + typeId = 17011813041836786320 instance (C.TypedStruct Node'annotation) where numStructWords = 5 numStructPtrs = 6 @@ -435,6 +450,8 @@ fieldByLabel = (GH.dataField 59 1 1 0) data Node'Parameter type instance (R.ReprFor Node'Parameter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'Parameter) where + typeId = 13353766412138554289 instance (C.TypedStruct Node'Parameter) where numStructWords = 0 numStructPtrs = 1 @@ -463,6 +480,8 @@ fieldByLabel = (GH.ptrField 0) data Node'NestedNode type instance (R.ReprFor Node'NestedNode) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'NestedNode) where + typeId = 16050641862814319170 instance (C.TypedStruct Node'NestedNode) where numStructWords = 1 numStructPtrs = 1 @@ -496,6 +515,8 @@ fieldByLabel = (GH.dataField 0 0 64 0) data Node'SourceInfo type instance (R.ReprFor Node'SourceInfo) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'SourceInfo) where + typeId = 17549997658772559790 instance (C.TypedStruct Node'SourceInfo) where numStructWords = 1 numStructPtrs = 2 @@ -534,6 +555,8 @@ fieldByLabel = (GH.ptrField 1) data Node'SourceInfo'Member type instance (R.ReprFor Node'SourceInfo'Member) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Node'SourceInfo'Member) where + typeId = 14031686161526562722 instance (C.TypedStruct Node'SourceInfo'Member) where numStructWords = 0 numStructPtrs = 1 @@ -562,6 +585,8 @@ fieldByLabel = (GH.ptrField 0) data Field type instance (R.ReprFor Field) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field) where + typeId = 11145653318641710175 instance (C.TypedStruct Field) where numStructWords = 3 numStructPtrs = 4 @@ -665,6 +690,8 @@ fieldByLabel = GH.groupField data Field'slot type instance (R.ReprFor Field'slot) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field'slot) where + typeId = 14133145859926553711 instance (C.TypedStruct Field'slot) where numStructWords = 3 numStructPtrs = 4 @@ -708,6 +735,8 @@ fieldByLabel = (GH.dataField 0 2 1 0) data Field'group type instance (R.ReprFor Field'group) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field'group) where + typeId = 14626792032033250577 instance (C.TypedStruct Field'group) where numStructWords = 3 numStructPtrs = 4 @@ -736,6 +765,8 @@ fieldByLabel = (GH.dataField 0 2 64 0) data Field'ordinal type instance (R.ReprFor Field'ordinal) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Field'ordinal) where + typeId = 13515537513213004774 instance (C.TypedStruct Field'ordinal) where numStructWords = 3 numStructPtrs = 4 @@ -807,6 +838,8 @@ field'noDiscriminant = (C.fromWord 65535) data Enumerant type instance (R.ReprFor Enumerant) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Enumerant) where + typeId = 10919677598968879693 instance (C.TypedStruct Enumerant) where numStructWords = 1 numStructPtrs = 2 @@ -845,6 +878,8 @@ fieldByLabel = (GH.ptrField 1) data Superclass type instance (R.ReprFor Superclass) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Superclass) where + typeId = 12220001500510083064 instance (C.TypedStruct Superclass) where numStructWords = 1 numStructPtrs = 1 @@ -878,6 +913,8 @@ fieldByLabel = (GH.ptrField 0) data Method type instance (R.ReprFor Method) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Method) where + typeId = 10736806783679155584 instance (C.TypedStruct Method) where numStructWords = 3 numStructPtrs = 5 @@ -941,6 +978,8 @@ fieldByLabel = (GH.ptrField 4) data Type type instance (R.ReprFor Type) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type) where + typeId = 15020482145304562784 instance (C.TypedStruct Type) where numStructWords = 3 numStructPtrs = 1 @@ -1195,6 +1234,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Type'list type instance (R.ReprFor Type'list) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'list) where + typeId = 9792858745991129751 instance (C.TypedStruct Type'list) where numStructWords = 3 numStructPtrs = 1 @@ -1223,6 +1264,8 @@ fieldByLabel = (GH.ptrField 0) data Type'enum type instance (R.ReprFor Type'enum) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'enum) where + typeId = 11389172934837766057 instance (C.TypedStruct Type'enum) where numStructWords = 3 numStructPtrs = 1 @@ -1256,6 +1299,8 @@ fieldByLabel = (GH.ptrField 0) data Type'struct type instance (R.ReprFor Type'struct) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'struct) where + typeId = 12410354185295152851 instance (C.TypedStruct Type'struct) where numStructWords = 3 numStructPtrs = 1 @@ -1289,6 +1334,8 @@ fieldByLabel = (GH.ptrField 0) data Type'interface type instance (R.ReprFor Type'interface) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'interface) where + typeId = 17116997365232503999 instance (C.TypedStruct Type'interface) where numStructWords = 3 numStructPtrs = 1 @@ -1322,6 +1369,8 @@ fieldByLabel = (GH.ptrField 0) data Type'anyPointer type instance (R.ReprFor Type'anyPointer) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer) where + typeId = 14003731834718800369 instance (C.TypedStruct Type'anyPointer) where numStructWords = 3 numStructPtrs = 1 @@ -1410,6 +1459,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Type'anyPointer'unconstrained type instance (R.ReprFor Type'anyPointer'unconstrained) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer'unconstrained) where + typeId = 10248890354574636630 instance (C.TypedStruct Type'anyPointer'unconstrained) where numStructWords = 3 numStructPtrs = 1 @@ -1499,6 +1550,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Type'anyPointer'parameter type instance (R.ReprFor Type'anyPointer'parameter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer'parameter) where + typeId = 11372142272178113157 instance (C.TypedStruct Type'anyPointer'parameter) where numStructWords = 3 numStructPtrs = 1 @@ -1532,6 +1585,8 @@ fieldByLabel = (GH.dataField 16 1 16 0) data Type'anyPointer'implicitMethodParameter type instance (R.ReprFor Type'anyPointer'implicitMethodParameter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Type'anyPointer'implicitMethodParameter) where + typeId = 13470206089842057844 instance (C.TypedStruct Type'anyPointer'implicitMethodParameter) where numStructWords = 3 numStructPtrs = 1 @@ -1560,6 +1615,8 @@ fieldByLabel = (GH.dataField 16 1 16 0) data Brand type instance (R.ReprFor Brand) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Brand) where + typeId = 10391024731148337707 instance (C.TypedStruct Brand) where numStructWords = 0 numStructPtrs = 1 @@ -1588,6 +1645,8 @@ fieldByLabel = (GH.ptrField 0) data Brand'Scope type instance (R.ReprFor Brand'Scope) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Brand'Scope) where + typeId = 12382423449155627977 instance (C.TypedStruct Brand'Scope) where numStructWords = 2 numStructPtrs = 1 @@ -1662,6 +1721,8 @@ fieldByLabel = (GH.dataField 0 0 64 0) data Brand'Binding type instance (R.ReprFor Brand'Binding) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Brand'Binding) where + typeId = 14439610327179913212 instance (C.TypedStruct Brand'Binding) where numStructWords = 1 numStructPtrs = 1 @@ -1731,6 +1792,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Value type instance (R.ReprFor Value) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Value) where + typeId = 14853958794117909659 instance (C.TypedStruct Value) where numStructWords = 2 numStructPtrs = 1 @@ -1771,11 +1834,11 @@ | 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_ Basics.AnyPointer) + | RW_Value'list (R.Raw mut_ (Std_.Maybe Basics.AnyPointer)) | RW_Value'enum (R.Raw mut_ Std_.Word16) - | RW_Value'struct (R.Raw mut_ Basics.AnyPointer) + | RW_Value'struct (R.Raw mut_ (Std_.Maybe Basics.AnyPointer)) | RW_Value'interface (R.Raw mut_ ()) - | RW_Value'anyPointer (R.Raw mut_ Basics.AnyPointer) + | RW_Value'anyPointer (R.Raw mut_ (Std_.Maybe Basics.AnyPointer)) | RW_Value'unknown' Std_.Word16 internalWhich tag_ struct_ = case tag_ of 0 -> @@ -1847,15 +1910,15 @@ variantByLabel = (GH.Variant (GH.ptrField 0) 12) instance (GH.HasVariant "data_" GH.Slot Value Basics.Data) where variantByLabel = (GH.Variant (GH.ptrField 0) 13) -instance (GH.HasVariant "list" GH.Slot Value Basics.AnyPointer) where +instance (GH.HasVariant "list" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 0) 14) instance (GH.HasVariant "enum" GH.Slot Value Std_.Word16) where variantByLabel = (GH.Variant (GH.dataField 16 0 16 0) 15) -instance (GH.HasVariant "struct" GH.Slot Value Basics.AnyPointer) where +instance (GH.HasVariant "struct" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 0) 16) instance (GH.HasVariant "interface" GH.Slot Value ()) where variantByLabel = (GH.Variant GH.voidField 17) -instance (GH.HasVariant "anyPointer" GH.Slot Value Basics.AnyPointer) where +instance (GH.HasVariant "anyPointer" GH.Slot Value (Std_.Maybe Basics.AnyPointer)) where variantByLabel = (GH.Variant (GH.ptrField 0) 18) data instance C.Parsed (GH.Which Value) = Value'void @@ -1872,11 +1935,11 @@ | Value'float64 (RP.Parsed Std_.Double) | Value'text (RP.Parsed Basics.Text) | Value'data_ (RP.Parsed Basics.Data) - | Value'list (RP.Parsed Basics.AnyPointer) + | Value'list (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Value'enum (RP.Parsed Std_.Word16) - | Value'struct (RP.Parsed Basics.AnyPointer) + | Value'struct (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Value'interface - | Value'anyPointer (RP.Parsed Basics.AnyPointer) + | Value'anyPointer (RP.Parsed (Std_.Maybe Basics.AnyPointer)) | Value'unknown' Std_.Word16 deriving(Generics.Generic) deriving instance (Std_.Show (C.Parsed (GH.Which Value))) @@ -1970,6 +2033,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Annotation type instance (R.ReprFor Annotation) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Annotation) where + typeId = 17422339044421236034 instance (C.TypedStruct Annotation) where numStructWords = 1 numStructPtrs = 2 @@ -2018,6 +2083,8 @@ | ElementSize'unknown' Std_.Word16 deriving(Std_.Eq,Std_.Show) type instance (R.ReprFor ElementSize) = (R.Data R.Sz16) +instance (C.HasTypeId ElementSize) where + typeId = 15102134695616452902 instance (Std_.Enum ElementSize) where toEnum n_ = case n_ of 0 -> @@ -2068,6 +2135,8 @@ instance (C.EstimateListAlloc ElementSize ElementSize) data CapnpVersion type instance (R.ReprFor CapnpVersion) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CapnpVersion) where + typeId = 15590670654532458851 instance (C.TypedStruct CapnpVersion) where numStructWords = 1 numStructPtrs = 0 @@ -2106,6 +2175,8 @@ fieldByLabel = (GH.dataField 24 0 8 0) data CodeGeneratorRequest type instance (R.ReprFor CodeGeneratorRequest) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CodeGeneratorRequest) where + typeId = 13818529054586492878 instance (C.TypedStruct CodeGeneratorRequest) where numStructWords = 0 numStructPtrs = 4 @@ -2149,6 +2220,8 @@ fieldByLabel = (GH.ptrField 3) data CodeGeneratorRequest'RequestedFile type instance (R.ReprFor CodeGeneratorRequest'RequestedFile) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CodeGeneratorRequest'RequestedFile) where + typeId = 14981803260258615394 instance (C.TypedStruct CodeGeneratorRequest'RequestedFile) where numStructWords = 1 numStructPtrs = 2 @@ -2187,6 +2260,8 @@ fieldByLabel = (GH.ptrField 1) data CodeGeneratorRequest'RequestedFile'Import type instance (R.ReprFor CodeGeneratorRequest'RequestedFile'Import) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CodeGeneratorRequest'RequestedFile'Import) where + typeId = 12560611460656617445 instance (C.TypedStruct CodeGeneratorRequest'RequestedFile'Import) where numStructWords = 1 numStructPtrs = 1 diff --git a/gen/lib/Capnp/Gen/Capnp/Stream/New.hs b/gen/lib/Capnp/Gen/Capnp/Stream/New.hs --- a/gen/lib/Capnp/Gen/Capnp/Stream/New.hs +++ b/gen/lib/Capnp/Gen/Capnp/Stream/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,6 +34,8 @@ import Prelude ((<$>), (<*>), (>>=)) data StreamResult type instance (R.ReprFor StreamResult) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StreamResult) where + typeId = 11051721556433613166 instance (C.TypedStruct StreamResult) where numStructWords = 0 numStructPtrs = 0 diff --git a/gen/tests/Capnp/Gen/Aircraft/New.hs b/gen/tests/Capnp/Gen/Aircraft/New.hs --- a/gen/tests/Capnp/Gen/Aircraft/New.hs +++ b/gen/tests/Capnp/Gen/Aircraft/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -37,6 +40,8 @@ constEnum = (C.fromWord 1) data Zdate type instance (R.ReprFor Zdate) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zdate) where + typeId = 16019495995647153309 instance (C.TypedStruct Zdate) where numStructWords = 1 numStructPtrs = 0 @@ -75,6 +80,8 @@ fieldByLabel = (GH.dataField 24 0 8 0) data Zdata type instance (R.ReprFor Zdata) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zdata) where + typeId = 14400934881325616034 instance (C.TypedStruct Zdata) where numStructWords = 0 numStructPtrs = 1 @@ -112,6 +119,8 @@ | Airport'unknown' Std_.Word16 deriving(Std_.Eq,Std_.Show) type instance (R.ReprFor Airport) = (R.Data R.Sz16) +instance (C.HasTypeId Airport) where + typeId = 16527513525367090977 instance (Std_.Enum Airport) where toEnum n_ = case n_ of 0 -> @@ -158,6 +167,8 @@ instance (C.EstimateListAlloc Airport Airport) data PlaneBase type instance (R.ReprFor PlaneBase) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId PlaneBase) where + typeId = 15617585680788961169 instance (C.TypedStruct PlaneBase) where numStructWords = 4 numStructPtrs = 2 @@ -211,6 +222,8 @@ fieldByLabel = (GH.dataField 0 3 64 0) data B737 type instance (R.ReprFor B737) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId B737) where + typeId = 14750329894210119392 instance (C.TypedStruct B737) where numStructWords = 0 numStructPtrs = 1 @@ -239,6 +252,8 @@ fieldByLabel = (GH.ptrField 0) data A320 type instance (R.ReprFor A320) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId A320) where + typeId = 15676010542212434829 instance (C.TypedStruct A320) where numStructWords = 0 numStructPtrs = 1 @@ -267,6 +282,8 @@ fieldByLabel = (GH.ptrField 0) data F16 type instance (R.ReprFor F16) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId F16) where + typeId = 16269793260987437921 instance (C.TypedStruct F16) where numStructWords = 0 numStructPtrs = 1 @@ -295,6 +312,8 @@ fieldByLabel = (GH.ptrField 0) data Regression type instance (R.ReprFor Regression) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Regression) where + typeId = 12821810113427682943 instance (C.TypedStruct Regression) where numStructWords = 3 numStructPtrs = 3 @@ -348,6 +367,8 @@ fieldByLabel = (GH.dataField 0 2 64 0) data Aircraft type instance (R.ReprFor Aircraft) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Aircraft) where + typeId = 16523162426109446065 instance (C.TypedStruct Aircraft) where numStructWords = 1 numStructPtrs = 1 @@ -437,6 +458,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Z type instance (R.ReprFor Z) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Z) where + typeId = 16872429889743397081 instance (C.TypedStruct Z) where numStructWords = 3 numStructPtrs = 1 @@ -939,6 +962,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Z'grp type instance (R.ReprFor Z'grp) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Z'grp) where + typeId = 13198763830743312036 instance (C.TypedStruct Z'grp) where numStructWords = 3 numStructPtrs = 1 @@ -972,6 +997,8 @@ fieldByLabel = (GH.dataField 0 2 64 0) data Counter type instance (R.ReprFor Counter) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Counter) where + typeId = 9748248141862325085 instance (C.TypedStruct Counter) where numStructWords = 1 numStructPtrs = 2 @@ -1010,6 +1037,8 @@ fieldByLabel = (GH.ptrField 1) data Bag type instance (R.ReprFor Bag) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bag) where + typeId = 15435801458704439998 instance (C.TypedStruct Bag) where numStructWords = 0 numStructPtrs = 1 @@ -1038,6 +1067,8 @@ fieldByLabel = (GH.ptrField 0) data Zserver type instance (R.ReprFor Zserver) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zserver) where + typeId = 14718909161889449112 instance (C.TypedStruct Zserver) where numStructWords = 0 numStructPtrs = 1 @@ -1066,6 +1097,8 @@ fieldByLabel = (GH.ptrField 0) data Zjob type instance (R.ReprFor Zjob) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Zjob) where + typeId = 15983628460635158035 instance (C.TypedStruct Zjob) where numStructWords = 0 numStructPtrs = 2 @@ -1099,6 +1132,8 @@ fieldByLabel = (GH.ptrField 1) data VerEmpty type instance (R.ReprFor VerEmpty) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerEmpty) where + typeId = 10649211371004916479 instance (C.TypedStruct VerEmpty) where numStructWords = 0 numStructPtrs = 0 @@ -1122,6 +1157,8 @@ marshalInto _raw (VerEmpty) = (Std_.pure ()) data VerOneData type instance (R.ReprFor VerOneData) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerOneData) where + typeId = 18204521836387912926 instance (C.TypedStruct VerOneData) where numStructWords = 1 numStructPtrs = 0 @@ -1150,6 +1187,8 @@ fieldByLabel = (GH.dataField 0 0 16 0) data VerTwoData type instance (R.ReprFor VerTwoData) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoData) where + typeId = 17799875294539507453 instance (C.TypedStruct VerTwoData) where numStructWords = 2 numStructPtrs = 0 @@ -1183,6 +1222,8 @@ fieldByLabel = (GH.dataField 0 1 64 0) data VerOnePtr type instance (R.ReprFor VerOnePtr) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerOnePtr) where + typeId = 10718424143143379341 instance (C.TypedStruct VerOnePtr) where numStructWords = 0 numStructPtrs = 1 @@ -1211,6 +1252,8 @@ fieldByLabel = (GH.ptrField 0) data VerTwoPtr type instance (R.ReprFor VerTwoPtr) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoPtr) where + typeId = 14509379619124759853 instance (C.TypedStruct VerTwoPtr) where numStructWords = 0 numStructPtrs = 2 @@ -1244,6 +1287,8 @@ fieldByLabel = (GH.ptrField 1) data VerTwoDataTwoPtr type instance (R.ReprFor VerTwoDataTwoPtr) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoDataTwoPtr) where + typeId = 13123175871726013043 instance (C.TypedStruct VerTwoDataTwoPtr) where numStructWords = 2 numStructPtrs = 2 @@ -1287,6 +1332,8 @@ fieldByLabel = (GH.ptrField 1) data HoldsVerEmptyList type instance (R.ReprFor HoldsVerEmptyList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerEmptyList) where + typeId = 16041492281108738195 instance (C.TypedStruct HoldsVerEmptyList) where numStructWords = 0 numStructPtrs = 1 @@ -1315,6 +1362,8 @@ fieldByLabel = (GH.ptrField 0) data HoldsVerOneDataList type instance (R.ReprFor HoldsVerOneDataList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerOneDataList) where + typeId = 12380489118307417585 instance (C.TypedStruct HoldsVerOneDataList) where numStructWords = 0 numStructPtrs = 1 @@ -1343,6 +1392,8 @@ fieldByLabel = (GH.ptrField 0) data HoldsVerTwoDataList type instance (R.ReprFor HoldsVerTwoDataList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoDataList) where + typeId = 14689746238557910970 instance (C.TypedStruct HoldsVerTwoDataList) where numStructWords = 0 numStructPtrs = 1 @@ -1371,6 +1422,8 @@ fieldByLabel = (GH.ptrField 0) data HoldsVerOnePtrList type instance (R.ReprFor HoldsVerOnePtrList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerOnePtrList) where + typeId = 16503619627606104568 instance (C.TypedStruct HoldsVerOnePtrList) where numStructWords = 0 numStructPtrs = 1 @@ -1399,6 +1452,8 @@ fieldByLabel = (GH.ptrField 0) data HoldsVerTwoPtrList type instance (R.ReprFor HoldsVerTwoPtrList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoPtrList) where + typeId = 14959808741027971272 instance (C.TypedStruct HoldsVerTwoPtrList) where numStructWords = 0 numStructPtrs = 1 @@ -1427,6 +1482,8 @@ fieldByLabel = (GH.ptrField 0) data HoldsVerTwoTwoList type instance (R.ReprFor HoldsVerTwoTwoList) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoTwoList) where + typeId = 10790341304104545899 instance (C.TypedStruct HoldsVerTwoTwoList) where numStructWords = 0 numStructPtrs = 1 @@ -1455,6 +1512,8 @@ fieldByLabel = (GH.ptrField 0) data HoldsVerTwoTwoPlus type instance (R.ReprFor HoldsVerTwoTwoPlus) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsVerTwoTwoPlus) where + typeId = 9782732235957253080 instance (C.TypedStruct HoldsVerTwoTwoPlus) where numStructWords = 0 numStructPtrs = 1 @@ -1483,6 +1542,8 @@ fieldByLabel = (GH.ptrField 0) data VerTwoTwoPlus type instance (R.ReprFor VerTwoTwoPlus) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VerTwoTwoPlus) where + typeId = 14863196959570808905 instance (C.TypedStruct VerTwoTwoPlus) where numStructWords = 3 numStructPtrs = 3 @@ -1536,6 +1597,8 @@ fieldByLabel = (GH.ptrField 2) data HoldsText type instance (R.ReprFor HoldsText) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId HoldsText) where + typeId = 16537639514277480156 instance (C.TypedStruct HoldsText) where numStructWords = 0 numStructPtrs = 3 @@ -1574,6 +1637,8 @@ fieldByLabel = (GH.ptrField 2) data WrapEmpty type instance (R.ReprFor WrapEmpty) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId WrapEmpty) where + typeId = 11147985329045285977 instance (C.TypedStruct WrapEmpty) where numStructWords = 0 numStructPtrs = 1 @@ -1602,6 +1667,8 @@ fieldByLabel = (GH.ptrField 0) data Wrap2x2 type instance (R.ReprFor Wrap2x2) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Wrap2x2) where + typeId = 16258788317804871341 instance (C.TypedStruct Wrap2x2) where numStructWords = 0 numStructPtrs = 1 @@ -1630,6 +1697,8 @@ fieldByLabel = (GH.ptrField 0) data Wrap2x2plus type instance (R.ReprFor Wrap2x2plus) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Wrap2x2plus) where + typeId = 16610659964001347673 instance (C.TypedStruct Wrap2x2plus) where numStructWords = 0 numStructPtrs = 1 @@ -1658,6 +1727,8 @@ fieldByLabel = (GH.ptrField 0) data VoidUnion type instance (R.ReprFor VoidUnion) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId VoidUnion) where + typeId = 9809347628687718458 instance (C.TypedStruct VoidUnion) where numStructWords = 1 numStructPtrs = 0 @@ -1727,6 +1798,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Nester1Capn type instance (R.ReprFor Nester1Capn) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Nester1Capn) where + typeId = 17388306941580478492 instance (C.TypedStruct Nester1Capn) where numStructWords = 0 numStructPtrs = 1 @@ -1755,6 +1828,8 @@ fieldByLabel = (GH.ptrField 0) data RWTestCapn type instance (R.ReprFor RWTestCapn) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId RWTestCapn) where + typeId = 17870076700317718634 instance (C.TypedStruct RWTestCapn) where numStructWords = 0 numStructPtrs = 1 @@ -1783,6 +1858,8 @@ fieldByLabel = (GH.ptrField 0) data ListStructCapn type instance (R.ReprFor ListStructCapn) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId ListStructCapn) where + typeId = 12802613814325702673 instance (C.TypedStruct ListStructCapn) where numStructWords = 0 numStructPtrs = 1 @@ -1811,13 +1888,22 @@ fieldByLabel = (GH.ptrField 0) data Echo type instance (R.ReprFor Echo) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Echo) where + typeId = 10255578992688506164 instance (C.Parse Echo (GH.Client Echo)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Echo) where + type Server Echo = Echo'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Echo)) [(GH.toUntypedMethodHandler ((echo'echo) s_))] []) +class (Echo'server_ s_) where + echo'echo :: s_ -> (GH.MethodHandler Echo'echo'params Echo'echo'results) instance (GH.HasMethod "echo" Echo Echo'echo'params Echo'echo'results) where methodByLabel = (GH.Method 10255578992688506164 0) data Echo'echo'params type instance (R.ReprFor Echo'echo'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Echo'echo'params) where + typeId = 9950245657029374882 instance (C.TypedStruct Echo'echo'params) where numStructWords = 0 numStructPtrs = 1 @@ -1846,6 +1932,8 @@ fieldByLabel = (GH.ptrField 0) data Echo'echo'results type instance (R.ReprFor Echo'echo'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Echo'echo'results) where + typeId = 11184644773809847197 instance (C.TypedStruct Echo'echo'results) where numStructWords = 0 numStructPtrs = 1 @@ -1874,6 +1962,8 @@ fieldByLabel = (GH.ptrField 0) data Hoth type instance (R.ReprFor Hoth) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Hoth) where + typeId = 12504202882178935737 instance (C.TypedStruct Hoth) where numStructWords = 0 numStructPtrs = 1 @@ -1902,6 +1992,8 @@ fieldByLabel = (GH.ptrField 0) data EchoBase type instance (R.ReprFor EchoBase) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId EchoBase) where + typeId = 12159459504633104486 instance (C.TypedStruct EchoBase) where numStructWords = 0 numStructPtrs = 1 @@ -1930,6 +2022,8 @@ fieldByLabel = (GH.ptrField 0) data EchoBases type instance (R.ReprFor EchoBases) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId EchoBases) where + typeId = 13848178635387355324 instance (C.TypedStruct EchoBases) where numStructWords = 0 numStructPtrs = 1 @@ -1958,6 +2052,8 @@ fieldByLabel = (GH.ptrField 0) data StackingRoot type instance (R.ReprFor StackingRoot) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StackingRoot) where + typeId = 10353348115798411408 instance (C.TypedStruct StackingRoot) where numStructWords = 0 numStructPtrs = 2 @@ -1991,6 +2087,8 @@ fieldByLabel = (GH.ptrField 1) data StackingA type instance (R.ReprFor StackingA) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StackingA) where + typeId = 11326609135883271029 instance (C.TypedStruct StackingA) where numStructWords = 1 numStructPtrs = 1 @@ -2024,6 +2122,8 @@ fieldByLabel = (GH.ptrField 0) data StackingB type instance (R.ReprFor StackingB) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId StackingB) where + typeId = 9594210030877276357 instance (C.TypedStruct StackingB) where numStructWords = 1 numStructPtrs = 0 @@ -2052,13 +2152,22 @@ fieldByLabel = (GH.dataField 0 0 32 0) data CallSequence type instance (R.ReprFor CallSequence) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId CallSequence) where + typeId = 12371070827563042848 instance (C.Parse CallSequence (GH.Client CallSequence)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export CallSequence) where + type Server CallSequence = CallSequence'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CallSequence)) [(GH.toUntypedMethodHandler ((callSequence'getNumber) s_))] []) +class (CallSequence'server_ s_) where + callSequence'getNumber :: s_ -> (GH.MethodHandler CallSequence'getNumber'params CallSequence'getNumber'results) instance (GH.HasMethod "getNumber" CallSequence CallSequence'getNumber'params CallSequence'getNumber'results) where methodByLabel = (GH.Method 12371070827563042848 0) data CallSequence'getNumber'params type instance (R.ReprFor CallSequence'getNumber'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CallSequence'getNumber'params) where + typeId = 17692253647948355992 instance (C.TypedStruct CallSequence'getNumber'params) where numStructWords = 0 numStructPtrs = 0 @@ -2082,6 +2191,8 @@ marshalInto _raw (CallSequence'getNumber'params) = (Std_.pure ()) data CallSequence'getNumber'results type instance (R.ReprFor CallSequence'getNumber'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CallSequence'getNumber'results) where + typeId = 11846148517662891671 instance (C.TypedStruct CallSequence'getNumber'results) where numStructWords = 1 numStructPtrs = 0 @@ -2110,13 +2221,22 @@ fieldByLabel = (GH.dataField 0 0 32 0) data CounterFactory type instance (R.ReprFor CounterFactory) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId CounterFactory) where + typeId = 15610220054254702620 instance (C.Parse CounterFactory (GH.Client CounterFactory)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export CounterFactory) where + type Server CounterFactory = CounterFactory'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CounterFactory)) [(GH.toUntypedMethodHandler ((counterFactory'newCounter) s_))] []) +class (CounterFactory'server_ s_) where + counterFactory'newCounter :: s_ -> (GH.MethodHandler CounterFactory'newCounter'params CounterFactory'newCounter'results) instance (GH.HasMethod "newCounter" CounterFactory CounterFactory'newCounter'params CounterFactory'newCounter'results) where methodByLabel = (GH.Method 15610220054254702620 0) data CounterFactory'newCounter'params type instance (R.ReprFor CounterFactory'newCounter'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterFactory'newCounter'params) where + typeId = 17606593106159030387 instance (C.TypedStruct CounterFactory'newCounter'params) where numStructWords = 1 numStructPtrs = 0 @@ -2145,6 +2265,8 @@ fieldByLabel = (GH.dataField 0 0 32 0) data CounterFactory'newCounter'results type instance (R.ReprFor CounterFactory'newCounter'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterFactory'newCounter'results) where + typeId = 14063453475556553460 instance (C.TypedStruct CounterFactory'newCounter'results) where numStructWords = 0 numStructPtrs = 1 @@ -2173,13 +2295,22 @@ fieldByLabel = (GH.ptrField 0) data CounterAcceptor type instance (R.ReprFor CounterAcceptor) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId CounterAcceptor) where + typeId = 14317498215560924065 instance (C.Parse CounterAcceptor (GH.Client CounterAcceptor)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export CounterAcceptor) where + type Server CounterAcceptor = CounterAcceptor'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(CounterAcceptor)) [(GH.toUntypedMethodHandler ((counterAcceptor'accept) s_))] []) +class (CounterAcceptor'server_ s_) where + counterAcceptor'accept :: s_ -> (GH.MethodHandler CounterAcceptor'accept'params CounterAcceptor'accept'results) instance (GH.HasMethod "accept" CounterAcceptor CounterAcceptor'accept'params CounterAcceptor'accept'results) where methodByLabel = (GH.Method 14317498215560924065 0) data CounterAcceptor'accept'params type instance (R.ReprFor CounterAcceptor'accept'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterAcceptor'accept'params) where + typeId = 9397955985493553485 instance (C.TypedStruct CounterAcceptor'accept'params) where numStructWords = 0 numStructPtrs = 1 @@ -2208,6 +2339,8 @@ fieldByLabel = (GH.ptrField 0) data CounterAcceptor'accept'results type instance (R.ReprFor CounterAcceptor'accept'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId CounterAcceptor'accept'results) where + typeId = 12945664473818918456 instance (C.TypedStruct CounterAcceptor'accept'results) where numStructWords = 0 numStructPtrs = 0 @@ -2231,13 +2364,22 @@ marshalInto _raw (CounterAcceptor'accept'results) = (Std_.pure ()) data Top type instance (R.ReprFor Top) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Top) where + typeId = 17861645508359101525 instance (C.Parse Top (GH.Client Top)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Top) where + type Server Top = Top'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Top)) [(GH.toUntypedMethodHandler ((top'top) s_))] []) +class (Top'server_ s_) where + top'top :: s_ -> (GH.MethodHandler Top'top'params Top'top'results) instance (GH.HasMethod "top" Top Top'top'params Top'top'results) where methodByLabel = (GH.Method 17861645508359101525 0) data Top'top'params type instance (R.ReprFor Top'top'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Top'top'params) where + typeId = 9393200598485985531 instance (C.TypedStruct Top'top'params) where numStructWords = 0 numStructPtrs = 0 @@ -2261,6 +2403,8 @@ marshalInto _raw (Top'top'params) = (Std_.pure ()) data Top'top'results type instance (R.ReprFor Top'top'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Top'top'results) where + typeId = 15495666596821516773 instance (C.TypedStruct Top'top'results) where numStructWords = 0 numStructPtrs = 0 @@ -2284,13 +2428,23 @@ marshalInto _raw (Top'top'results) = (Std_.pure ()) data Left type instance (R.ReprFor Left) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Left) where + typeId = 17679152961798450446 instance (C.Parse Left (GH.Client Left)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Left) where + type Server Left = Left'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Left)) [(GH.toUntypedMethodHandler ((left'left) s_))] [(GH.methodHandlerTree (GH.Proxy @(Top)) s_)]) +class ((GH.Server Top s_)) => (Left'server_ s_) where + left'left :: s_ -> (GH.MethodHandler Left'left'params Left'left'results) +instance (C.Super Top Left) instance (GH.HasMethod "left" Left Left'left'params Left'left'results) where methodByLabel = (GH.Method 17679152961798450446 0) data Left'left'params type instance (R.ReprFor Left'left'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Left'left'params) where + typeId = 15491006379377963583 instance (C.TypedStruct Left'left'params) where numStructWords = 0 numStructPtrs = 0 @@ -2314,6 +2468,8 @@ marshalInto _raw (Left'left'params) = (Std_.pure ()) data Left'left'results type instance (R.ReprFor Left'left'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Left'left'results) where + typeId = 14681384339713198083 instance (C.TypedStruct Left'left'results) where numStructWords = 0 numStructPtrs = 0 @@ -2337,13 +2493,23 @@ marshalInto _raw (Left'left'results) = (Std_.pure ()) data Right type instance (R.ReprFor Right) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Right) where + typeId = 14712639595305348988 instance (C.Parse Right (GH.Client Right)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Right) where + type Server Right = Right'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Right)) [(GH.toUntypedMethodHandler ((right'right) s_))] [(GH.methodHandlerTree (GH.Proxy @(Top)) s_)]) +class ((GH.Server Top s_)) => (Right'server_ s_) where + right'right :: s_ -> (GH.MethodHandler Right'right'params Right'right'results) +instance (C.Super Top Right) instance (GH.HasMethod "right" Right Right'right'params Right'right'results) where methodByLabel = (GH.Method 14712639595305348988 0) data Right'right'params type instance (R.ReprFor Right'right'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Right'right'params) where + typeId = 17692925949004434588 instance (C.TypedStruct Right'right'params) where numStructWords = 0 numStructPtrs = 0 @@ -2367,6 +2533,8 @@ marshalInto _raw (Right'right'params) = (Std_.pure ()) data Right'right'results type instance (R.ReprFor Right'right'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Right'right'results) where + typeId = 12438774687365689496 instance (C.TypedStruct Right'right'results) where numStructWords = 0 numStructPtrs = 0 @@ -2390,13 +2558,26 @@ marshalInto _raw (Right'right'results) = (Std_.pure ()) data Bottom type instance (R.ReprFor Bottom) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId Bottom) where + typeId = 18402872613340521775 instance (C.Parse Bottom (GH.Client Bottom)) where parse = GH.parseCap encode = GH.encodeCap +instance (GH.Export Bottom) where + type Server Bottom = Bottom'server_ + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @(Bottom)) [(GH.toUntypedMethodHandler ((bottom'bottom) s_))] [(GH.methodHandlerTree (GH.Proxy @(Left)) s_) + ,(GH.methodHandlerTree (GH.Proxy @(Right)) s_)]) +class ((GH.Server Left s_) + ,(GH.Server Right s_)) => (Bottom'server_ s_) where + bottom'bottom :: s_ -> (GH.MethodHandler Bottom'bottom'params Bottom'bottom'results) +instance (C.Super Left Bottom) +instance (C.Super Right Bottom) instance (GH.HasMethod "bottom" Bottom Bottom'bottom'params Bottom'bottom'results) where methodByLabel = (GH.Method 18402872613340521775 0) data Bottom'bottom'params type instance (R.ReprFor Bottom'bottom'params) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bottom'bottom'params) where + typeId = 12919405706404437540 instance (C.TypedStruct Bottom'bottom'params) where numStructWords = 0 numStructPtrs = 0 @@ -2420,6 +2601,8 @@ marshalInto _raw (Bottom'bottom'params) = (Std_.pure ()) data Bottom'bottom'results type instance (R.ReprFor Bottom'bottom'results) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Bottom'bottom'results) where + typeId = 10197200620860118778 instance (C.TypedStruct Bottom'bottom'results) where numStructWords = 0 numStructPtrs = 0 @@ -2443,6 +2626,8 @@ marshalInto _raw (Bottom'bottom'results) = (Std_.pure ()) data Defaults type instance (R.ReprFor Defaults) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId Defaults) where + typeId = 10944742465095042957 instance (C.TypedStruct Defaults) where numStructWords = 2 numStructPtrs = 2 @@ -2491,6 +2676,8 @@ fieldByLabel = (GH.dataField 0 1 32 42) data BenchmarkA type instance (R.ReprFor BenchmarkA) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId BenchmarkA) where + typeId = 16008637057130021148 instance (C.TypedStruct BenchmarkA) where numStructWords = 3 numStructPtrs = 2 diff --git a/gen/tests/Capnp/Gen/Generics/New.hs b/gen/tests/Capnp/Gen/Generics/New.hs --- a/gen/tests/Capnp/Gen/Generics/New.hs +++ b/gen/tests/Capnp/Gen/Generics/New.hs @@ -6,10 +6,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wno-dodgy-exports #-} {-# OPTIONS_GHC -Wno-unused-matches #-} @@ -31,6 +34,8 @@ import Prelude ((<$>), (<*>), (>>=)) data Maybe t type instance (R.ReprFor (Maybe t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Maybe t)) where + typeId = 12834113532530355529 instance ((GH.TypeParam t)) => (C.TypedStruct (Maybe t)) where numStructWords = 1 numStructPtrs = 1 @@ -100,6 +105,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Either a b type instance (R.ReprFor (Either a b)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Either a b)) where + typeId = 16016919828037144358 instance ((GH.TypeParam a) ,(GH.TypeParam b)) => (C.TypedStruct (Either a b)) where numStructWords = 1 @@ -185,6 +192,8 @@ (GH.encodeField GH.unionField tag_ (GH.unionStruct raw_)) data Pair a b type instance (R.ReprFor (Pair a b)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Pair a b)) where + typeId = 18425972019411955385 instance ((GH.TypeParam a) ,(GH.TypeParam b)) => (C.TypedStruct (Pair a b)) where numStructWords = 0 @@ -229,6 +238,8 @@ fieldByLabel = (GH.ptrField 1) data Nested t type instance (R.ReprFor (Nested t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested t)) where + typeId = 17472990467641505320 instance ((GH.TypeParam t)) => (C.TypedStruct (Nested t)) where numStructWords = 0 numStructPtrs = 0 @@ -252,6 +263,8 @@ marshalInto _raw (Nested) = (Std_.pure ()) data Nested'SomeStruct t type instance (R.ReprFor (Nested'SomeStruct t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested'SomeStruct t)) where + typeId = 10581732449597785397 instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeStruct t)) where numStructWords = 0 numStructPtrs = 1 @@ -280,13 +293,22 @@ fieldByLabel = (GH.ptrField 0) data Nested'SomeInterface t type instance (R.ReprFor (Nested'SomeInterface t)) = (R.Ptr (Std_.Just R.Cap)) +instance (C.HasTypeId (Nested'SomeInterface t)) where + typeId = 17400383877992806407 instance ((GH.TypeParam t)) => (C.Parse (Nested'SomeInterface t) (GH.Client (Nested'SomeInterface t))) where parse = GH.parseCap encode = GH.encodeCap +instance ((GH.TypeParam t)) => (GH.Export (Nested'SomeInterface t)) where + type Server (Nested'SomeInterface t) = (Nested'SomeInterface'server_ t) + methodHandlerTree _ s_ = (GH.MethodHandlerTree (C.typeId @((Nested'SomeInterface t))) [(GH.toUntypedMethodHandler ((nested'SomeInterface'method @(t)) s_))] []) +class (Nested'SomeInterface'server_ t s_) where + nested'SomeInterface'method :: s_ -> (GH.MethodHandler (Nested'SomeInterface'method'params t) (Nested'SomeInterface'method'results t)) instance ((GH.TypeParam t)) => (GH.HasMethod "method" (Nested'SomeInterface t) (Nested'SomeInterface'method'params t) (Nested'SomeInterface'method'results t)) where methodByLabel = (GH.Method 17400383877992806407 0) data Nested'SomeInterface'method'params t type instance (R.ReprFor (Nested'SomeInterface'method'params t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested'SomeInterface'method'params t)) where + typeId = 13278839458779198088 instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeInterface'method'params t)) where numStructWords = 0 numStructPtrs = 1 @@ -315,6 +337,8 @@ fieldByLabel = (GH.ptrField 0) data Nested'SomeInterface'method'results t type instance (R.ReprFor (Nested'SomeInterface'method'results t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Nested'SomeInterface'method'results t)) where + typeId = 9305012847082487733 instance ((GH.TypeParam t)) => (C.TypedStruct (Nested'SomeInterface'method'results t)) where numStructWords = 0 numStructPtrs = 1 @@ -343,6 +367,8 @@ fieldByLabel = (GH.ptrField 0) data Specialized t type instance (R.ReprFor (Specialized t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (Specialized t)) where + typeId = 11111346635683596512 instance ((GH.TypeParam t)) => (C.TypedStruct (Specialized t)) where numStructWords = 0 numStructPtrs = 2 @@ -376,6 +402,8 @@ fieldByLabel = (GH.ptrField 1) data HasGroup t type instance (R.ReprFor (HasGroup t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (HasGroup t)) where + typeId = 10809380793126616697 instance ((GH.TypeParam t)) => (C.TypedStruct (HasGroup t)) where numStructWords = 0 numStructPtrs = 1 @@ -407,6 +435,8 @@ fieldByLabel = GH.groupField data HasGroup'theGroup t type instance (R.ReprFor (HasGroup'theGroup t)) = (R.Ptr (Std_.Just R.Struct)) +instance (C.HasTypeId (HasGroup'theGroup t)) where + typeId = 13022770763187353254 instance ((GH.TypeParam t)) => (C.TypedStruct (HasGroup'theGroup t)) where numStructWords = 0 numStructPtrs = 1 diff --git a/lib/Capnp/Convert.hs b/lib/Capnp/Convert.hs --- a/lib/Capnp/Convert.hs +++ b/lib/Capnp/Convert.hs @@ -33,6 +33,10 @@ -- new API , msgToRaw , msgToParsed + , bsToRaw + , bsToParsed + , lbsToRaw + , lbsToParsed , parsedToRaw , parsedToMsg , parsedToBuilder @@ -143,6 +147,22 @@ -- | Get the root pointer of a message, as a parsed ADT. msgToParsed :: forall a m pa. (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => M.Message 'Const -> m pa msgToParsed msg = msgToRaw msg >>= parse + +-- | Like 'msgToRaw', but takes a (strict) bytestring. +bsToRaw :: (U.ReadCtx m 'Const, R.IsStruct a) => BS.ByteString -> m (R.Raw 'Const a) +bsToRaw bs = bsToMsg bs >>= msgToRaw + +-- | Like 'msgToParsed', but takes a (strict) bytestring. +bsToParsed :: (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => BS.ByteString -> m pa +bsToParsed bs = bsToRaw bs >>= parse + +-- | Like 'msgToRaw', but takes a (lazy) bytestring. +lbsToRaw :: (U.ReadCtx m 'Const, R.IsStruct a) => LBS.ByteString -> m (R.Raw 'Const a) +lbsToRaw = bsToRaw . LBS.toStrict + +-- | Like 'msgToParsed', but takes a (lazzy) bytestring. +lbsToParsed :: (U.ReadCtx m 'Const, R.IsStruct a, Parse a pa) => LBS.ByteString -> m pa +lbsToParsed = bsToParsed . LBS.toStrict -- | Serialize the parsed form of a struct into its 'R.Raw' form, and make it the root -- of its message. diff --git a/lib/Capnp/GenHelpers/New.hs b/lib/Capnp/GenHelpers/New.hs --- a/lib/Capnp/GenHelpers/New.hs +++ b/lib/Capnp/GenHelpers/New.hs @@ -30,14 +30,21 @@ , getPtrConst , module F , module Capnp.Repr.Methods + , module Capnp.New.Rpc.Server + , buildCallHandler + + -- * Re-exports from the standard library. + , Proxy(..) ) where + + import Capnp.Bits -import qualified Capnp.Classes as C -import Capnp.Fields as F -import Capnp.GenHelpers (getPtrConst) -import Capnp.Message (Mutability(..)) -import qualified Capnp.Message as M +import qualified Capnp.Classes as C +import Capnp.Fields as F +import Capnp.GenHelpers (getPtrConst) +import Capnp.Message (Mutability(..)) +import qualified Capnp.Message as M import Capnp.New ( TypeParam , encodeField @@ -49,12 +56,16 @@ , unionStruct , unionWhich ) -import qualified Capnp.New.Basics as NB -import qualified Capnp.New.Classes as NC -import qualified Capnp.Repr as R +import qualified Capnp.New.Basics as NB +import qualified Capnp.New.Classes as NC +import Capnp.New.Rpc.Server +import qualified Capnp.Repr as R import Capnp.Repr.Methods -import qualified Capnp.Untyped as U +import qualified Capnp.Untyped as U import Data.Bits +import qualified Data.Map.Strict as M +import Data.Proxy (Proxy(..)) +import qualified Data.Vector as V import Data.Word dataField @@ -106,3 +117,7 @@ encodeCap :: (R.IsCap a, U.RWCtx m s) => M.Message ('Mut s) -> Client a -> m (R.Raw ('Mut s) a) encodeCap msg (Client c) = R.Raw <$> U.appendCap msg c + + +buildCallHandler :: [(Word64, [UntypedMethodHandler])] -> CallHandler +buildCallHandler hs = M.fromList [ (k, V.fromList v) | (k, v) <- hs ] diff --git a/lib/Capnp/New.hs b/lib/Capnp/New.hs --- a/lib/Capnp/New.hs +++ b/lib/Capnp/New.hs @@ -5,7 +5,7 @@ , Parsed -- * Working with raw values - , R.Raw + , R.Raw(..) -- ** Working with raw lists , R.List @@ -33,6 +33,18 @@ , PureBuilder , createPure + -- * Canonicalizing messages + , canonicalize + + -- * Implementing RPC servers + , MethodHandler + , SomeServer(..) + , Export(Server) + , export + , handleParsed + , handleRaw + , methodUnimplemented + -- * Re-exported from "Data.Default", for convienence. , def ) where @@ -40,13 +52,16 @@ -- TODO: be more intentional about the ordering of the stuff we're -- currently exposing as X, so the haddocks are clearer. +import Capnp.Canonicalize (canonicalize) import Capnp.Convert as X import qualified Capnp.Fields as F import Capnp.IO as X import qualified Capnp.Message as Message import Capnp.New.Accessors as X +import Capnp.New.Basics as X hiding (Parsed) import Capnp.New.Classes as X hiding (Parsed) import Capnp.New.Constraints as X +import Capnp.New.Rpc.Server import qualified Capnp.Repr as R import Capnp.Repr.Methods as X import Capnp.Repr.Parsed (Parsed) diff --git a/lib/Capnp/New/Basics.hs b/lib/Capnp/New/Basics.hs --- a/lib/Capnp/New/Basics.hs +++ b/lib/Capnp/New/Basics.hs @@ -34,6 +34,7 @@ import qualified Data.Text.Encoding as TE import qualified Data.Vector as V import Data.Word +import GHC.Prim (coerce) -- | The Cap'n Proto @Text@ type. data Text @@ -56,28 +57,37 @@ type instance R.ReprFor Data = R.ReprFor (R.List Word8) type instance R.ReprFor Text = R.ReprFor (R.List Word8) type instance R.ReprFor AnyPointer = 'R.Ptr 'Nothing +type instance R.ReprFor (Maybe AnyPointer) = 'R.Ptr 'Nothing type instance R.ReprFor AnyList = 'R.Ptr ('Just ('R.List 'Nothing)) type instance R.ReprFor AnyStruct = 'R.Ptr ('Just 'R.Struct) type instance R.ReprFor Capability = 'R.Ptr ('Just 'R.Cap) data instance C.Parsed AnyPointer - = PtrNull - | PtrStruct (C.Parsed AnyStruct) + = PtrStruct (C.Parsed AnyStruct) | PtrList (C.Parsed AnyList) | PtrCap M.Client deriving(Show, Eq) +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) + + encode msg value = R.Raw <$> case value of + Nothing -> pure Nothing + Just v -> coerce <$> C.encode msg v + instance C.Parse AnyPointer (C.Parsed AnyPointer) where parse (R.Raw ptr) = case ptr of - Nothing -> pure PtrNull Just (U.PtrCap cap) -> PtrCap <$> C.parse (R.Raw cap) Just (U.PtrList list) -> PtrList <$> C.parse (R.Raw list) Just (U.PtrStruct struct) -> PtrStruct <$> C.parse (R.Raw struct) + Nothing -> + throwM $ E.SchemaViolationError "Non-nullable AnyPointer was null" encode msg value = R.Raw <$> case value of - PtrNull -> pure Nothing - PtrCap cap -> Just . U.PtrCap . R.fromRaw <$> C.encode msg cap - PtrList list -> Just . U.PtrList . R.fromRaw <$> C.encode msg list + PtrCap cap -> Just . U.PtrCap . R.fromRaw <$> C.encode msg cap + PtrList list -> Just . U.PtrList . R.fromRaw <$> C.encode msg list PtrStruct struct -> Just . U.PtrStruct . R.fromRaw <$> C.encode msg struct instance C.AllocateList AnyPointer where @@ -85,9 +95,14 @@ instance C.EstimateListAlloc AnyPointer (C.Parsed AnyPointer) +instance C.AllocateList (Maybe AnyPointer) where + type ListAllocHint (Maybe AnyPointer) = Int + +instance C.EstimateListAlloc (Maybe AnyPointer) (Maybe (C.Parsed AnyPointer)) + data instance C.Parsed AnyStruct = Struct { structData :: V.Vector Word64 - , structPtrs :: V.Vector (C.Parsed AnyPointer) + , structPtrs :: V.Vector (Maybe (C.Parsed AnyPointer)) } deriving(Show, Eq) @@ -130,7 +145,7 @@ type ParsedList a = V.Vector a data instance C.Parsed AnyList - = ListPtr (ParsedList (C.Parsed AnyPointer)) + = ListPtr (ParsedList (Maybe (C.Parsed AnyPointer))) | ListStruct (ParsedList (C.Parsed AnyStruct)) | List0 (ParsedList ()) | List1 (ParsedList Bool) diff --git a/lib/Capnp/New/Classes.hs b/lib/Capnp/New/Classes.hs --- a/lib/Capnp/New/Classes.hs +++ b/lib/Capnp/New/Classes.hs @@ -30,12 +30,18 @@ , EstimateListAlloc(..) , newFromRepr - -- * Typed Structs + -- * Working with Cap'n Proto types + , HasTypeId(..) + + -- ** Typed Structs , TypedStruct(..) , newTypedStruct , newTypedStructList , structSizes + -- ** Inheritance + , Super + -- * Values that go in a struct's data section , IsWord(..) ) where @@ -171,8 +177,14 @@ structSizes :: forall a. TypedStruct a => (Word16, Word16) structSizes = (numStructWords @a, numStructPtrs @a) +-- | Types which have a numeric type-id defined in a capnp schema. +class HasTypeId a where + -- | The node id for this type. You will generally want to use the + -- @TypeApplications@ extension to specify the type. + typeId :: Word64 + -- | Operations on typed structs. -class (R.IsStruct a, Allocate a, AllocHint a ~ ()) => TypedStruct a where +class (R.IsStruct a, Allocate a, HasTypeId a, AllocHint a ~ ()) => TypedStruct a where -- Get the size of the struct's word and pointer sections, respectively. numStructWords :: Word16 numStructPtrs :: Word16 @@ -239,6 +251,10 @@ , R.ListReprFor (R.ReprFor a) ~ lr , MarshalElement a ap ) => R.Raw ('Mut s) (R.List a) -> Int -> ap -> m () + +-- | An instance @'Super' p c@ indicates that the interface @c@ extends +-- the interface @p@. +class (R.IsCap p, R.IsCap c) => Super p c instance MarshalElementByRepr 'R.ListComposite where marshalElementByRepr rawList i parsed = do diff --git a/lib/Capnp/New/Rpc/Server.hs b/lib/Capnp/New/Rpc/Server.hs new file mode 100644 --- /dev/null +++ b/lib/Capnp/New/Rpc/Server.hs @@ -0,0 +1,236 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Capnp.New.Rpc.Server + ( CallHandler + , MethodHandler + , UntypedMethodHandler + , Export(..) + , export + , findMethod + + , SomeServer(..) + + -- * Helpers for writing method handlers + , handleParsed + , handleRaw + , methodUnimplemented + + , toUntypedMethodHandler + + -- * Internals; exposed only for use by generated code. + , MethodHandlerTree(..) + ) where + +import Capnp.Convert (parsedToRaw) +import Capnp.Message (Mutability(..)) +import qualified Capnp.New.Basics as B +import qualified Capnp.New.Classes as C +import qualified Capnp.Repr as R +import Capnp.Repr.Methods (Client(..)) +import Capnp.Rpc.Errors (eFailed, eMethodUnimplemented) +import Capnp.Rpc.Promise + (Fulfiller, breakPromise, fulfill, newCallback) +import qualified Capnp.Rpc.Server as Legacy +import qualified Capnp.Rpc.Untyped as URpc +import Capnp.TraversalLimit (defaultLimit, evalLimitT) +import qualified Capnp.Untyped as U +import Control.Exception.Safe (withException) +import Control.Monad.STM.Class (MonadSTM(..)) +import Data.Function ((&)) +import Data.Kind (Constraint) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy(..)) +import Data.Typeable (Typeable) +import qualified Data.Vector as V +import Data.Word +import GHC.Prim (coerce) +import Internal.BuildPure (createPure) +import Supervisors (Supervisor) + +-- | A handler for arbitrary RPC calls. Maps (interfaceId, methodId) pairs to +-- 'UntypedMethodHandler's. +type CallHandler = M.Map Word64 (V.Vector UntypedMethodHandler) + +-- | Type alias for a handler for a particular rpc method. +type MethodHandler p r + = R.Raw 'Const p + -> Fulfiller (R.Raw 'Const r) + -> IO () + +-- | Type alias for a handler for an untyped RPC method. +type UntypedMethodHandler = MethodHandler B.AnyStruct B.AnyStruct + +-- | Base class for things that can act as capnproto servers. +class SomeServer a where + -- | Called when the last live reference to a server is dropped. + shutdown :: a -> IO () + shutdown _ = pure () + + -- | Try to extract a value of a given type. The default implementation + -- always fails (returns 'Nothing'). If an instance chooses to implement + -- this, it will be possible to use "reflection" on clients that point + -- at local servers to dynamically unwrap the server value. A typical + -- implementation will just call Typeable's @cast@ method, but this + -- needn't be the case -- a server may wish to allow local peers to + -- unwrap some value that is not exactly the data the server has access + -- to. + unwrap :: Typeable b => a -> Maybe b + unwrap _ = Nothing + +-- | Generated interface types have instances of 'Export', which allows a server +-- for that interface to be exported as a 'Client'. +class (R.IsCap i, C.HasTypeId i) => Export i where + -- | The constraint needed for a server to implement an interface; + -- if @'Server' i s@ is satisfied, @s@ is a server for interface @i@. + -- The code generator generates a type class for each interface, and + -- this will aways be an alias for that type class. + type Server i :: * -> Constraint + + -- | Convert the server to a 'MethodHandlerTree' populated with appropriate + -- 'MethodHandler's for the interface. This is really only exported for use + -- by generated code; users of the library will generally prefer to use + -- 'export'. + methodHandlerTree :: Server i s => Proxy i -> s -> MethodHandlerTree + -- NB: the proxy helps disambiguate types; for some reason TypeApplications + -- doesn't seem to be enough in the face of a type alias of kind 'Constraint'. + -- the inconsistency is a bit ugly, but this method isn't intended to called + -- by users directly, only by generated code and our helper in this module, + -- so it's less of a big deal. + +-- | Lazily computed tree of the method handlers exposed by an interface. Only +-- of interest to generated code. +data MethodHandlerTree = MethodHandlerTree + { mhtId :: Word64 + -- ^ type id for the primary interface + , mhtHandlers :: [UntypedMethodHandler] + -- ^ method handlers for methods of the primary interface. + , mhtParents :: [MethodHandlerTree] + -- ^ Trees for parent interfaces. In the case of diamond dependencies, + -- there may be duplicates, which are eliminated by 'mhtToCallHandler'. + } + +mhtToCallHandler :: MethodHandlerTree -> CallHandler +mhtToCallHandler = go M.empty . pure where + go accum [] = accum + go accum (t : ts) + | mhtId t `M.member` accum = go accum ts -- dedup diamond dependencies + | otherwise = + go (M.insert (mhtId t) (V.fromList (mhtHandlers t)) accum) (mhtParents t ++ ts) + +-- | Export the server as a client for interface @i@. Spawns a server thread +-- with its lifetime bound to the supervisor. +export :: forall i s m. (MonadSTM m, Export i, Server i s, SomeServer s) => Supervisor -> s -> m (Client i) +export sup srv = + let h = mhtToCallHandler (methodHandlerTree (Proxy @i) srv) in + liftSTM $ Client <$> URpc.export sup (toLegacyServerOps srv h) + +-- | Look up a particlar 'MethodHandler' in the 'CallHandler'. +findMethod :: Word64 -> Word16 -> CallHandler -> Maybe UntypedMethodHandler +findMethod interfaceId methodId handler = do + iface <- M.lookup interfaceId handler + iface V.!? fromIntegral methodId + +toLegacyCallHandler + :: CallHandler + -> Word64 + -> Word16 + -> Legacy.MethodHandler IO (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) +toLegacyCallHandler callHandler interfaceId methodId = + findMethod interfaceId methodId callHandler + & fromMaybe methodUnimplemented + & toLegacyMethodHandler + + +-- | Convert a typed method handler to an untyped one. Mostly intended for +-- use by generated code. +toUntypedMethodHandler + :: forall p r. (R.IsStruct p, R.IsStruct r) + => MethodHandler p r + -> UntypedMethodHandler +toUntypedMethodHandler = coerce + +toLegacyMethodHandler :: UntypedMethodHandler -> Legacy.MethodHandler IO (Maybe (U.Ptr 'Const)) (Maybe (U.Ptr 'Const)) +toLegacyMethodHandler handler = + Legacy.untypedHandler $ \args respond -> do + respond' <- newCallback $ \case + Left e -> + breakPromise respond e + Right (R.Raw s) -> + fulfill respond (Just (U.PtrStruct s)) + case args of + Just (U.PtrStruct argStruct) -> + handler (R.Raw argStruct) respond' + _ -> + breakPromise respond $ eFailed "Argument was not a struct" + +toLegacyServerOps :: SomeServer a => a -> CallHandler -> Legacy.ServerOps IO +toLegacyServerOps srv callHandler = Legacy.ServerOps + { handleStop = shutdown srv + , handleCast = unwrap srv + , handleCall = toLegacyCallHandler callHandler + } + +-- Helpers for writing method handlers + +-- | Handle a method, working with the parsed form of parameters and +-- results. +handleParsed :: + ( C.Parse p pp, R.IsStruct p + , C.Parse r rr, R.IsStruct r + ) => (pp -> IO rr) -> MethodHandler p r +handleParsed handler = + handleRaw $ \param -> do + p <- evalLimitT defaultLimit $ C.parse param + r <- handler p + -- TODO: Figure out how to add an instance of Thaw for + -- Raw so we can skip the (un)wrapping here. + struct <- createPure maxBound $ R.fromRaw <$> parsedToRaw r + pure (R.Raw struct) + +-- | Handle a method, working with the raw (unparsed) form of +-- parameters and results. +handleRaw + :: (R.IsStruct p, R.IsStruct r) + => (R.Raw 'Const p -> IO (R.Raw 'Const r)) -> MethodHandler p r +handleRaw handler param f = do + res <- handler param `withException` breakPromise f + fulfill f res + + +-- | 'MethodHandler' that always throws unimplemented. +methodUnimplemented :: MethodHandler p r +methodUnimplemented _ f = breakPromise f eMethodUnimplemented + +{- +Sketch of future Async API, might take a bit of internals work to make +this possible: + +-- | Handle a method call asynchronously. +-- +-- When invoked, the handleer will be run synchronously, blocking further +-- method calls until the 'IO' returns. The method call does not return +-- until the 'Async' resolves, but further method calls can be serviced in +-- the meantime. +-- +-- If a Finish message is received before the Async resolves, it will be +-- 'cancel'ed. +handleRawAsync + :: (R.IsStruct p, R.IsStruct r) + => (R.Raw 'Const p -> IO (Async (R.Raw 'Const r))) + -> MethodHandler IO p r + +-- | Like 'handleRawAsync', but accepts and returns parsed values. +handleParsedAsync :: + ( C.Parse p pp, R.IsStruct p + , C.Parse r, rr, R.IsStruct r + ) + => (pp -> IO (Async rr)) + -> MethodHandler IO p r +-} diff --git a/lib/Capnp/Repr/Methods.hs b/lib/Capnp/Repr/Methods.hs --- a/lib/Capnp/Repr/Methods.hs +++ b/lib/Capnp/Repr/Methods.hs @@ -22,6 +22,7 @@ , waitPipeline , AsClient(..) + , upcast -- * Calling methods. , callB @@ -43,7 +44,9 @@ import Control.Monad.STM.Class (MonadSTM(..)) import Data.Word import GHC.OverloadedLabels (IsLabel(..)) +import GHC.Prim (coerce) import GHC.TypeLits (Symbol) +import GHC.Types (Coercible) import Internal.BuildPure (PureBuilder, createPure) -- | Represents a method on the interface type @c@ with parameter @@ -81,6 +84,10 @@ instance AsClient Client where asClient = liftSTM . pure + +-- | Upcast is a (safe) cast from an interface to one of its superclasses. +upcast :: (AsClient f, Coercible (f p) (f c), NC.Super p c) => f c -> f p +upcast = coerce -- | Call a method. Use the provided 'PureBuilder' to construct the parameters. callB diff --git a/lib/Capnp/Repr/Parsed.hs b/lib/Capnp/Repr/Parsed.hs --- a/lib/Capnp/Repr/Parsed.hs +++ b/lib/Capnp/Repr/Parsed.hs @@ -27,4 +27,5 @@ ParsedByRepr _ B.Data = BS.ByteString ParsedByRepr _ B.Text = T.Text ParsedByRepr _ (List a) = V.Vector (Parsed a) + ParsedByRepr _ (Maybe B.AnyPointer) = Maybe (C.Parsed B.AnyPointer) ParsedByRepr _ a = C.Parsed a diff --git a/lib/Capnp/Tutorial.hs b/lib/Capnp/Tutorial.hs --- a/lib/Capnp/Tutorial.hs +++ b/lib/Capnp/Tutorial.hs @@ -526,10 +526,6 @@ -- example which demos more of the protocol's capabilities, see the calculator example -- in the source repository's @examples/@ directory. -- --- Note: for now, we only show the client here, as the new API does not yet support --- implementing rpc servers -- for that you can use the old API, see old docs for --- more info. --- -- Note that capnproto does not have a notion of "clients" and "servers" in the -- traditional networking sense; the two sides of a connection are symmetric. In -- capnproto terminology, a "client" is a handle for calling methods, and a "server" @@ -544,13 +540,66 @@ -- > echo @0 (query :Text) -> (reply :Text); -- > } -- --- In the low level module, the code generator generates an unihabited type @Echo@, --- with its @'R.ReprFor'@ instance indicating that it is a capability. +-- The code generator generates a few things of interest: -- --- There is a 'Client' type exported by "Capnp.New", which is parametrized over --- a phantom type indicating the type of the remote capability. So a @'Client' --- Echo@ allows you to call methods on an @Echo@ interface. +-- * An unihabited type @Echo@, with its @'R.ReprFor'@ instance indicating that it +-- is a capability. +-- * A type class for servers implementing the interface. -- +-- To provide an implementation of the @Echo@ interface, you need an instance of the +-- @Echo'server_@ type class. Each type class method is a handler for one of the +-- Cap'n Proto interface's rpc methods. The handler has this type: +-- +-- > type MethodHandler p r +-- > = R.Raw 'Const p +-- > -> Fulfiller (R.Raw 'Const r) +-- > -> IO () +-- +-- ...where @p@ and @r@ are the phantom types for the parameter and return values. +-- To break this down, it's a function which accepts the raw (unparsed) form of the +-- parameters, and a 'Fulfiller' that can be used to respond to the request, either +-- with a result or an exception. +-- +-- Much of the time you will use higher level helpers such as 'handleParsed' or +-- 'handleRaw' to construct these, which can be more ergonomic and less error +-- prone. In particular, they prevent you from forgetting to use the 'Fulfiller'. +-- +-- Once you have an instance of the server class, the 'Capnp.New.export' function +-- is used to convert such an instance into a handle to the object that can be +-- passed around. +-- +-- Here is an an echo (networking) server using this interface: +-- +-- > {-# LANGUAGE MultiParamTypeClasses #-} +-- > {-# LANGUAGE OverloadedStrings #-} +-- > {-# LANGUAGE TypeApplications #-} +-- > +-- > import Network.Simple.TCP (serve) +-- > +-- > import Capnp.New (SomeServer, def, defaultLimit, export, handleParsed) +-- > import Capnp.Rpc (ConnConfig(..), handleConn, socketTransport, toClient) +-- > +-- > import Capnp.Gen.Echo.New +-- > +-- > data MyEchoServer = MyEchoServer +-- > +-- > instance SomeServer MyEchoServer +-- > +-- > instance Echo'server_ MyEchoServer where +-- > echo'echo MyEchoServer = handleParsed $ \params -> +-- > pure def { reply = query params } +-- > +-- > main :: IO () +-- > main = serve "localhost" "4000" $ \(sock, _addr) -> +-- > handleConn (socketTransport sock defaultLimit) def +-- > { debugMode = True +-- > , getBootstrap = \sup -> Just . toClient <$> export @Echo sup MyEchoServer +-- > } +-- +-- For RPC clients, there is a 'Client' type exported by "Capnp.New", which is +-- parametrized over a phantom type indicating the type of the remote capability. +-- So a @'Client' Echo@ allows you to call methods on an @Echo@ interface. +-- -- Actually invoking methods uses the functions in "Capnp.Repr.Methods", -- re-exported by "Capnp.New". 'callP', 'callB', and 'callR' provide different -- ways of supplying arguments to a call, but all are intended to be used with @@ -559,7 +608,7 @@ -- Pipelining onto a field can be done with the 'pipe' function. -- 'waitPipeline' blocks until the result is available. -- --- Here is an an echo (networking) client using this interface: +-- Here is an an echo client using this interface: -- -- > {-# LANGUAGE OverloadedLabels #-} -- > {-# LANGUAGE OverloadedStrings #-} diff --git a/tests/Module/Capnp/Rpc.hs b/tests/Module/Capnp/Rpc.hs --- a/tests/Module/Capnp/Rpc.hs +++ b/tests/Module/Capnp/Rpc.hs @@ -4,6 +4,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-error=missing-methods #-} module Module.Capnp.Rpc (rpcTests) where import Control.Concurrent.STM