mirror of
https://github.com/zap-proto/haskell.git
synced 2026-10-30 15:05:00 +00:00
1077 lines
41 KiB
Haskell
1077 lines
41 KiB
Haskell
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
module Trans.AbstractOpToHaskell
|
|
( fileToModules,
|
|
)
|
|
where
|
|
|
|
import qualified Zap.Repr as R
|
|
import Control.Monad (guard)
|
|
import Data.String (IsString (fromString))
|
|
import Data.Word
|
|
import qualified IR.AbstractOp as AO
|
|
import qualified IR.Common as C
|
|
import qualified IR.Haskell as Hs
|
|
import qualified IR.Name as Name
|
|
import Trans.ToHaskellCommon
|
|
|
|
-- | Modules imported by all generated modules.
|
|
imports :: [Hs.Import]
|
|
imports =
|
|
[ Hs.ImportAs {importAs = "R", parts = ["Zap", "Repr"]},
|
|
Hs.ImportAs {importAs = "RP", parts = ["Zap", "Repr", "Parsed"]},
|
|
Hs.ImportAs {importAs = "Basics", parts = ["Zap", "Basics"]},
|
|
Hs.ImportAs {importAs = "OL", parts = ["GHC", "OverloadedLabels"]},
|
|
Hs.ImportAs {importAs = "GH", parts = ["Zap", "GenHelpers"]},
|
|
Hs.ImportAs {importAs = "C", parts = ["Zap", "Classes"]},
|
|
Hs.ImportAs {importAs = "Generics", parts = ["GHC", "Generics"]}
|
|
]
|
|
|
|
-- | Modules imported by generated modules that use rpc. We separate these out to
|
|
-- avoid a circular import when generating code for rpc.zap -- which does not
|
|
-- contain interfaces, so does not need to import the rpc system -- but which
|
|
-- must be imported *by* the rpc system.
|
|
rpcImports :: [Hs.Import]
|
|
rpcImports =
|
|
[ Hs.ImportAs {importAs = "GH", parts = ["Zap", "GenHelpers", "Rpc"]}
|
|
]
|
|
|
|
fileToModules :: AO.File -> [Hs.Module]
|
|
fileToModules file =
|
|
[ fileToMainModule file,
|
|
fileToModuleAlias file
|
|
]
|
|
|
|
fileToMainModule :: AO.File -> Hs.Module
|
|
fileToMainModule file@AO.File {fileName, usesRpc} =
|
|
fixImports $
|
|
Hs.Module
|
|
{ modName = ["Zap", "Gen"] ++ makeModName fileName,
|
|
modLangPragmas =
|
|
[ "TypeFamilies",
|
|
"DataKinds",
|
|
"DeriveGeneric",
|
|
"DuplicateRecordFields",
|
|
"EmptyDataDeriving",
|
|
"FlexibleContexts",
|
|
"FlexibleInstances",
|
|
"MultiParamTypeClasses",
|
|
"UndecidableInstances",
|
|
"UndecidableSuperClasses",
|
|
"OverloadedLabels",
|
|
"OverloadedStrings",
|
|
"StandaloneDeriving",
|
|
"RecordWildCards",
|
|
"TypeApplications",
|
|
"ScopedTypeVariables"
|
|
],
|
|
modExports = Nothing,
|
|
modImports = imports ++ (guard usesRpc >> rpcImports),
|
|
modDecls = fileToDecls file
|
|
}
|
|
|
|
fileToModuleAlias :: AO.File -> Hs.Module
|
|
fileToModuleAlias AO.File {fileId, fileName} =
|
|
let reExport = ["Zap", "Gen"] ++ makeModName fileName
|
|
in Hs.Module
|
|
{ modName = idToModule fileId,
|
|
modLangPragmas = [],
|
|
modExports = Just [Hs.ExportMod reExport],
|
|
modImports = [Hs.ImportAll {parts = reExport}],
|
|
modDecls = []
|
|
}
|
|
|
|
fileToDecls :: AO.File -> [Hs.Decl]
|
|
fileToDecls AO.File {fileId, decls} =
|
|
concatMap (declToDecls fileId) decls
|
|
|
|
declToDecls :: Word64 -> AO.Decl -> [Hs.Decl]
|
|
declToDecls thisMod decl =
|
|
case decl of
|
|
AO.TypeDecl {name, nodeId, params, repr, extraTypeInfo} ->
|
|
let dataName = Name.localToUnQ name
|
|
typeArgs = toTVars params
|
|
typ = case typeArgs of
|
|
[] -> tuName dataName
|
|
_ -> Hs.TApp (tuName dataName) typeArgs
|
|
in [ Hs.DcData
|
|
Hs.Data
|
|
{ dataName,
|
|
typeArgs,
|
|
dataVariants =
|
|
case extraTypeInfo of
|
|
Just (AO.EnumTypeInfo variants) ->
|
|
[ Hs.DataVariant
|
|
{ dvCtorName = Name.localToUnQ $ Name.mkSub name variantName,
|
|
dvArgs = Hs.APos []
|
|
}
|
|
| variantName <- variants
|
|
]
|
|
++ [declareUnknownVariant name]
|
|
_ -> [],
|
|
derives =
|
|
case extraTypeInfo of
|
|
Just AO.EnumTypeInfo {} -> ["Std_.Eq", "Std_.Show", "Generics.Generic"]
|
|
_ -> [],
|
|
dataNewtype = False,
|
|
dataInstance = False
|
|
},
|
|
Hs.DcTypeInstance
|
|
(Hs.TApp (tgName ["R"] "ReprFor") [typ])
|
|
(toType repr),
|
|
Hs.DcInstance
|
|
{ ctx = [],
|
|
typ = Hs.TApp (tgName ["C"] "HasTypeId") [typ],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "typeId",
|
|
params = [],
|
|
value = Hs.EInt (fromIntegral nodeId)
|
|
}
|
|
]
|
|
}
|
|
]
|
|
++ let ctx = paramsContext typeArgs
|
|
in case extraTypeInfo of
|
|
Just AO.StructTypeInfo {nWords, nPtrs} ->
|
|
[ Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "TypedStruct") [typ],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "numStructWords",
|
|
params = [],
|
|
value = Hs.EInt $ fromIntegral nWords
|
|
},
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "numStructPtrs",
|
|
params = [],
|
|
value = Hs.EInt $ fromIntegral nPtrs
|
|
}
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "Allocate") [typ],
|
|
defs =
|
|
[ Hs.IdType $
|
|
Hs.TypeAlias "AllocHint" [typ] Hs.TUnit,
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "new",
|
|
params = [Hs.PVar "_"],
|
|
value = egName ["C"] "newTypedStruct"
|
|
}
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["C"] "EstimateAlloc")
|
|
[typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
|
|
defs = []
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "AllocateList") [typ],
|
|
defs =
|
|
[ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int"),
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "newList",
|
|
params = [],
|
|
value = egName ["C"] "newTypedStructList"
|
|
}
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["C"] "EstimateListAlloc")
|
|
[typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
|
|
defs = []
|
|
}
|
|
]
|
|
Just (AO.EnumTypeInfo variants) ->
|
|
[ Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tStd_ "Enum") [typ],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "toEnum",
|
|
params = [Hs.PVar "n_"],
|
|
value =
|
|
Hs.ECase (euName "n_") $
|
|
[ ( Hs.PInt i,
|
|
Hs.ELName (Name.mkSub name variantName)
|
|
)
|
|
| (i, variantName) <- zip [0 ..] variants
|
|
]
|
|
++ [ ( Hs.PVar "tag_",
|
|
Hs.EApp
|
|
(Hs.ELName (unknownVariant name))
|
|
[Hs.EApp (eStd_ "fromIntegral") [euName "tag_"]]
|
|
)
|
|
]
|
|
},
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "fromEnum",
|
|
params = [Hs.PVar "value_"],
|
|
value =
|
|
Hs.ECase (euName "value_") $
|
|
[ ( Hs.PLCtor (Name.mkSub name variantName) [],
|
|
Hs.EInt i
|
|
)
|
|
| (i, variantName) <- zip [0 ..] variants
|
|
]
|
|
++ [ ( Hs.PLCtor (unknownVariant name) [Hs.PVar "tag_"],
|
|
Hs.EApp (eStd_ "fromIntegral") [euName "tag_"]
|
|
)
|
|
]
|
|
}
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "IsWord") [typ],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "fromWord",
|
|
params = [Hs.PVar "w_"],
|
|
value = Hs.EApp (eStd_ "toEnum") [Hs.EApp (eStd_ "fromIntegral") [Hs.EVar "w_"]]
|
|
},
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "toWord",
|
|
params = [Hs.PVar "v_"],
|
|
value = Hs.EApp (eStd_ "fromIntegral") [Hs.EApp (eStd_ "fromEnum") [Hs.EVar "v_"]]
|
|
}
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "Parse") [typ, typ],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "parse",
|
|
params = [],
|
|
value = egName ["GH"] "parseEnum"
|
|
},
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "encode",
|
|
params = [],
|
|
value = egName ["GH"] "encodeEnum"
|
|
}
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "AllocateList") [typ],
|
|
defs =
|
|
[ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int")
|
|
]
|
|
},
|
|
Hs.DcInstance
|
|
{ ctx,
|
|
typ = Hs.TApp (tgName ["C"] "EstimateListAlloc") [typ, typ],
|
|
defs = []
|
|
}
|
|
]
|
|
Just AO.InterfaceTypeInfo {methods, supers} ->
|
|
defineInterfaceParse name params
|
|
++ defineInterfaceServer thisMod name params methods supers
|
|
Nothing -> []
|
|
AO.FieldDecl {containerType, typeParams, fieldName, fieldLocType} ->
|
|
let tVars = toTVars typeParams
|
|
ctx = paramsContext tVars
|
|
labelType = Hs.TString (Name.renderUnQ fieldName)
|
|
parentType = Hs.TApp (Hs.TLName containerType) tVars
|
|
childType = fieldLocTypeToType thisMod fieldLocType
|
|
fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType
|
|
in [ Hs.DcInstance
|
|
{ ctx,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["GH"] "HasField")
|
|
[labelType, fieldKind, parentType, childType],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "fieldByLabel",
|
|
value = fieldLocTypeToField fieldLocType,
|
|
params = []
|
|
}
|
|
]
|
|
}
|
|
]
|
|
AO.UnionDecl {name, typeParams, tagLoc, variants} ->
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (Hs.TLName name) tVars
|
|
in Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ = Hs.TApp (tgName ["GH"] "HasUnion") [typ],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "unionField",
|
|
params = [],
|
|
value =
|
|
fieldLocTypeToField $
|
|
C.DataField
|
|
tagLoc
|
|
(C.PrimWord (C.PrimInt (C.IntType C.Unsigned C.Sz16)))
|
|
},
|
|
defineRawData thisMod name tVars variants,
|
|
defineInternalWhich name variants,
|
|
Hs.IdData
|
|
Hs.Data
|
|
{ dataName = "Which",
|
|
typeArgs = [typ],
|
|
dataVariants = [],
|
|
derives = [],
|
|
dataNewtype = False,
|
|
dataInstance = False
|
|
}
|
|
]
|
|
}
|
|
: concatMap (variantToDecls thisMod name typeParams) variants
|
|
AO.SuperDecl {subName, typeParams, superType} ->
|
|
let tVars = toTVars typeParams
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["C"] "Super")
|
|
[ typeToType thisMod $ C.PtrType $ C.PtrInterface superType,
|
|
Hs.TApp (Hs.TLName subName) tVars
|
|
],
|
|
defs = []
|
|
}
|
|
]
|
|
AO.MethodDecl
|
|
{ interfaceName,
|
|
interfaceId,
|
|
methodId,
|
|
methodInfo =
|
|
AO.MethodInfo
|
|
{ typeParams,
|
|
methodName,
|
|
paramType,
|
|
resultType
|
|
}
|
|
} ->
|
|
let tVars = toTVars typeParams
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["GH"] "HasMethod")
|
|
[ Hs.TString (Name.renderUnQ methodName),
|
|
Hs.TApp (Hs.TLName interfaceName) tVars,
|
|
compositeTypeToType thisMod paramType,
|
|
compositeTypeToType thisMod resultType
|
|
],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "methodByLabel",
|
|
params = [],
|
|
value =
|
|
Hs.EApp
|
|
(egName ["GH"] "Method")
|
|
[ Hs.EInt $ fromIntegral interfaceId,
|
|
Hs.EInt $ fromIntegral methodId
|
|
]
|
|
}
|
|
]
|
|
}
|
|
]
|
|
AO.ParsedInstanceDecl {typeName, typeParams, parsedInstances} ->
|
|
defineParsedInstances thisMod typeName typeParams parsedInstances
|
|
AO.ConstDecl {name, value} ->
|
|
defineConstant thisMod name value
|
|
|
|
defineConstant thisMod localName value =
|
|
let name = Name.localToUnQ localName
|
|
in case value of
|
|
C.VoidValue ->
|
|
[ Hs.DcValue
|
|
{ typ = Hs.TUnit,
|
|
def =
|
|
Hs.DfValue
|
|
{ name,
|
|
params = [],
|
|
value = Hs.ETup []
|
|
}
|
|
}
|
|
]
|
|
C.WordValue t v ->
|
|
[ Hs.DcValue
|
|
{ typ = typeToType thisMod (C.WordType t),
|
|
def =
|
|
Hs.DfValue
|
|
{ name,
|
|
params = [],
|
|
value = Hs.EApp (egName ["C"] "fromWord") [Hs.EInt (fromIntegral v)]
|
|
}
|
|
}
|
|
]
|
|
C.PtrValue t v ->
|
|
[ Hs.DcValue
|
|
{ typ = Hs.TApp (tgName ["R"] "Raw") [typeToType thisMod (C.PtrType t), tgName ["GH"] "Const"],
|
|
def =
|
|
Hs.DfValue
|
|
{ name,
|
|
params = [],
|
|
value =
|
|
Hs.EApp
|
|
(egName ["GH"] "getPtrConst")
|
|
[Hs.ETypeAnno (Hs.EBytes (makePtrBytes v)) (tgName ["GH"] "ByteString")]
|
|
}
|
|
}
|
|
]
|
|
|
|
defineRawData thisMod name tVars variants =
|
|
Hs.IdData
|
|
Hs.Data
|
|
{ dataName = "RawWhich",
|
|
typeArgs =
|
|
[ Hs.TApp (Hs.TVar $ Name.renderUnQ $ Name.localToUnQ name) tVars,
|
|
Hs.TVar "mut_"
|
|
],
|
|
dataNewtype = False,
|
|
dataInstance = False,
|
|
dataVariants =
|
|
[ Hs.DataVariant
|
|
{ dvCtorName =
|
|
"RW_" <> Name.localToUnQ (Name.mkSub name variantName),
|
|
dvArgs =
|
|
Hs.APos
|
|
[ Hs.TApp
|
|
(tReprName "Raw")
|
|
[ fieldLocTypeToType thisMod fieldLocType,
|
|
Hs.TVar "mut_"
|
|
]
|
|
]
|
|
}
|
|
| AO.UnionVariant {variantName, fieldLocType} <- variants
|
|
]
|
|
++ [ Hs.DataVariant
|
|
{ dvCtorName = "RW_" <> Name.localToUnQ (unknownVariant name),
|
|
dvArgs = Hs.APos [tStd_ "Word16"]
|
|
}
|
|
],
|
|
-- TODO: derive Show, Read, Eq, Generic, to be feature complete with the code generated by RawToHaskell.
|
|
-- This will require a stand-alone deriving declaration
|
|
derives = []
|
|
}
|
|
|
|
unknownVariant :: Name.LocalQ -> Name.LocalQ
|
|
unknownVariant name = Name.mkSub name "unknown'"
|
|
|
|
rawCtorName :: Name.LocalQ -> Name.UnQ
|
|
rawCtorName local = "RW_" <> Name.localToUnQ local
|
|
|
|
defineInternalWhich structName variants =
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "internalWhich",
|
|
params = [Hs.PVar "tag_", Hs.PVar "struct_"],
|
|
value =
|
|
Hs.ECase (Hs.ELName "tag_") $
|
|
[ ( Hs.PInt $ fromIntegral tagValue,
|
|
Hs.EFApp
|
|
(euName $ rawCtorName (Name.mkSub structName variantName))
|
|
[ Hs.EApp
|
|
(egName ["GH"] "readVariant")
|
|
[ Hs.ELabel variantName,
|
|
euName "struct_"
|
|
]
|
|
]
|
|
)
|
|
| AO.UnionVariant {tagValue, variantName} <- variants
|
|
]
|
|
++ [ ( Hs.PVar "_",
|
|
Hs.EApp
|
|
(eStd_ "pure")
|
|
[ Hs.EApp
|
|
(euName $ rawCtorName (unknownVariant structName))
|
|
[euName "tag_"]
|
|
]
|
|
)
|
|
]
|
|
}
|
|
|
|
variantToDecls thisMod containerType typeParams AO.UnionVariant {tagValue, variantName, fieldLocType} =
|
|
let tVars = toTVars typeParams
|
|
ctx = paramsContext tVars
|
|
labelType = Hs.TString (Name.renderUnQ variantName)
|
|
parentType = Hs.TApp (Hs.TLName containerType) tVars
|
|
childType = fieldLocTypeToType thisMod fieldLocType
|
|
fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType
|
|
in [ Hs.DcInstance
|
|
{ ctx,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["GH"] "HasVariant")
|
|
[labelType, fieldKind, parentType, childType],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "variantByLabel",
|
|
params = [],
|
|
value =
|
|
Hs.EApp
|
|
(egName ["GH"] "Variant")
|
|
[ fieldLocTypeToField fieldLocType,
|
|
Hs.EInt (fromIntegral tagValue)
|
|
]
|
|
}
|
|
]
|
|
}
|
|
]
|
|
|
|
paramsContext :: [Hs.Type] -> [Hs.Type]
|
|
paramsContext = map paramConstraints
|
|
|
|
-- | Constraints required for a zap type parameter. The returned
|
|
-- expression has kind 'Constraint'.
|
|
paramConstraints :: Hs.Type -> Hs.Type
|
|
paramConstraints t =
|
|
Hs.TApp (tgName ["GH"] "TypeParam") [t]
|
|
|
|
tZap :: Word64 -> Name.ZapQ -> Hs.Type
|
|
tZap thisMod Name.ZapQ {local, fileId}
|
|
| thisMod == fileId = Hs.TLName local
|
|
| otherwise = tgName (map Name.renderUnQ $ idToModule fileId) local
|
|
|
|
fieldLocTypeToType :: Word64 -> C.FieldLocType AO.Brand Name.ZapQ -> Hs.Type
|
|
fieldLocTypeToType thisMod = \case
|
|
C.VoidField -> Hs.TUnit
|
|
C.DataField _ t -> wordTypeToType thisMod t
|
|
C.PtrField _ t -> ptrTypeToType thisMod t
|
|
C.HereField t -> compositeTypeToType thisMod t
|
|
|
|
fieldLocTypeToFieldKind :: C.FieldLocType b n -> Name.GlobalQ
|
|
fieldLocTypeToFieldKind = \case
|
|
C.HereField _ -> gName ["GH"] "Group"
|
|
_ -> gName ["GH"] "Slot"
|
|
|
|
wordTypeToType thisMod = \case
|
|
C.EnumType t -> tZap thisMod t
|
|
C.PrimWord t -> primWordToType t
|
|
|
|
primWordToType = \case
|
|
C.PrimInt t -> intTypeToType t
|
|
C.PrimFloat32 -> tStd_ "Float"
|
|
C.PrimFloat64 -> tStd_ "Double"
|
|
C.PrimBool -> tStd_ "Bool"
|
|
|
|
intTypeToType (C.IntType sign size) =
|
|
let prefix = case sign of
|
|
C.Signed -> "Int"
|
|
C.Unsigned -> "Word"
|
|
in tStd_ $ fromString $ prefix ++ show (C.sizeBits size)
|
|
|
|
wordTypeBits = \case
|
|
C.EnumType _ -> 16
|
|
C.PrimWord (C.PrimInt (C.IntType _ size)) -> C.sizeBits size
|
|
C.PrimWord C.PrimFloat32 -> 32
|
|
C.PrimWord C.PrimFloat64 -> 64
|
|
C.PrimWord C.PrimBool -> 1
|
|
|
|
ptrTypeToType thisMod = \case
|
|
C.ListOf t -> Hs.TApp (tgName ["R"] "List") [typeToType thisMod t]
|
|
C.PrimPtr t -> primPtrToType t
|
|
C.PtrComposite t -> compositeTypeToType thisMod t
|
|
C.PtrInterface t -> interfaceTypeToType thisMod t
|
|
C.PtrParam t -> typeParamToType t
|
|
|
|
typeToType thisMod = \case
|
|
C.CompositeType t -> compositeTypeToType thisMod t
|
|
C.VoidType -> Hs.TUnit
|
|
C.WordType t -> wordTypeToType thisMod t
|
|
C.PtrType t -> ptrTypeToType thisMod t
|
|
|
|
primPtrToType = \case
|
|
C.PrimText -> tgName ["Basics"] "Text"
|
|
C.PrimData -> tgName ["Basics"] "Data"
|
|
C.PrimAnyPtr t -> anyPtrToType t
|
|
|
|
anyPtrToType :: C.AnyPtr -> Hs.Type
|
|
anyPtrToType t = case t of
|
|
C.Struct -> basics "AnyStruct"
|
|
C.List -> basics "AnyList"
|
|
C.Cap -> basics "Capability"
|
|
C.Ptr -> Hs.TApp (tStd_ "Maybe") [basics "AnyPointer"]
|
|
where
|
|
basics = tgName ["Basics"]
|
|
|
|
compositeTypeToType thisMod (C.StructType name brand) = namedType thisMod name brand
|
|
|
|
interfaceTypeToType thisMod (C.InterfaceType name brand) = namedType thisMod name brand
|
|
|
|
typeParamToType = Hs.TVar . Name.typeVarName . C.paramName
|
|
|
|
namedType :: Word64 -> Name.ZapQ -> C.ListBrand Name.ZapQ -> Hs.Type
|
|
namedType thisMod name (C.ListBrand []) = tZap thisMod name
|
|
namedType thisMod name (C.ListBrand args) =
|
|
Hs.TApp
|
|
(tZap thisMod name)
|
|
[typeToType thisMod (C.PtrType t) | t <- args]
|
|
|
|
fieldLocTypeToField = \case
|
|
C.DataField loc wt ->
|
|
let shift = C.dataOff loc
|
|
index = C.dataIdx loc
|
|
nbits = wordTypeBits wt
|
|
defaultValue = C.dataDef loc
|
|
in Hs.EApp
|
|
(egName ["GH"] "dataField")
|
|
[ Hs.EInt $ fromIntegral shift,
|
|
Hs.EInt $ fromIntegral index,
|
|
Hs.EInt $ fromIntegral nbits,
|
|
Hs.EInt $ fromIntegral defaultValue
|
|
]
|
|
C.PtrField idx _ ->
|
|
Hs.EApp (egName ["GH"] "ptrField") [Hs.EInt $ fromIntegral idx]
|
|
C.VoidField ->
|
|
egName ["GH"] "voidField"
|
|
C.HereField _ ->
|
|
egName ["GH"] "groupField"
|
|
|
|
class ToType a where
|
|
toType :: a -> Hs.Type
|
|
|
|
instance ToType R.Repr where
|
|
toType (R.Ptr p) = rApp "Ptr" [toType p]
|
|
toType (R.Data d) = rApp "Data" [toType d]
|
|
|
|
instance ToType a => ToType (Maybe a) where
|
|
toType Nothing = tStd_ "Nothing"
|
|
toType (Just a) = Hs.TApp (tStd_ "Just") [toType a]
|
|
|
|
instance ToType R.PtrRepr where
|
|
toType R.Cap = tReprName "Cap"
|
|
toType (R.List r) = rApp "List" [toType r]
|
|
toType R.Struct = tReprName "Struct"
|
|
|
|
instance ToType R.ListRepr where
|
|
toType (R.ListNormal nl) = rApp "ListNormal" [toType nl]
|
|
toType R.ListComposite = tReprName "ListComposite"
|
|
|
|
instance ToType R.NormalListRepr where
|
|
toType (R.NormalListData r) = rApp "ListData" [toType r]
|
|
toType R.NormalListPtr = tReprName "ListPtr"
|
|
|
|
instance ToType R.DataSz where
|
|
toType = tReprName . fromString . show
|
|
|
|
rApp :: Name.LocalQ -> [Hs.Type] -> Hs.Type
|
|
rApp n = Hs.TApp (tReprName n)
|
|
|
|
tReprName :: Name.LocalQ -> Hs.Type
|
|
tReprName = tgName ["R"]
|
|
|
|
declareUnknownVariant :: Name.LocalQ -> Hs.DataVariant
|
|
declareUnknownVariant name =
|
|
Hs.DataVariant
|
|
{ dvCtorName = Name.localToUnQ $ Name.mkSub name "unknown'",
|
|
dvArgs = Hs.APos [tStd_ "Word16"]
|
|
}
|
|
|
|
defineParsedInstances :: Word64 -> Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
|
|
defineParsedInstances thisMod typeName typeParams instanceInfo =
|
|
concatMap
|
|
(\f -> f typeName typeParams instanceInfo)
|
|
[ defineParsed thisMod,
|
|
defineParse,
|
|
defineMarshal
|
|
]
|
|
|
|
defineParsed :: Word64 -> Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
|
|
defineParsed thisMod typeName typeParams instanceInfo =
|
|
let tVars = map (Hs.TVar . Name.typeVarName) typeParams
|
|
typ = Hs.TApp (Hs.TLName typeName) tVars
|
|
parsedTy = case instanceInfo of
|
|
AO.ParsedStruct {} -> typ
|
|
AO.ParsedUnion {} -> Hs.TApp (tgName ["GH"] "Which") [typ]
|
|
in Hs.DcData
|
|
Hs.Data
|
|
{ dataName = "C.Parsed",
|
|
typeArgs = [parsedTy],
|
|
derives = ["Generics.Generic"],
|
|
dataNewtype = False,
|
|
dataInstance = True,
|
|
dataVariants =
|
|
case instanceInfo of
|
|
AO.ParsedStruct {fields, hasUnion, dataCtorName} ->
|
|
[ Hs.DataVariant
|
|
{ dvCtorName = Name.localToUnQ dataCtorName,
|
|
dvArgs =
|
|
Hs.ARec $
|
|
[ ( name,
|
|
Hs.TApp
|
|
(tgName ["RP"] "Parsed")
|
|
[fieldLocTypeToType thisMod typ]
|
|
)
|
|
| (name, typ) <- fields
|
|
]
|
|
++ [ ( "union'",
|
|
Hs.TApp
|
|
(tgName ["C"] "Parsed")
|
|
[Hs.TApp (tgName ["GH"] "Which") [typ]]
|
|
)
|
|
| hasUnion
|
|
]
|
|
}
|
|
]
|
|
AO.ParsedUnion {variants} ->
|
|
[ Hs.DataVariant
|
|
{ dvCtorName = Name.localToUnQ $ Name.mkSub typeName name,
|
|
dvArgs = case ftype of
|
|
C.VoidField -> Hs.APos []
|
|
_ ->
|
|
Hs.APos
|
|
[ Hs.TApp
|
|
(tgName ["RP"] "Parsed")
|
|
[fieldLocTypeToType thisMod ftype]
|
|
]
|
|
}
|
|
| (name, ftype) <- variants
|
|
]
|
|
++ [declareUnknownVariant typeName]
|
|
}
|
|
: [ Hs.DcDeriveInstance
|
|
[ Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["RP"] "Parsed") [v]]
|
|
| v <- tVars
|
|
]
|
|
(Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["C"] "Parsed") [parsedTy]])
|
|
| cls <- ["Show", "Eq"]
|
|
]
|
|
|
|
defineParse :: Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
|
|
defineParse typeName typeParams AO.ParsedStruct {fields, hasUnion, dataCtorName} =
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (Hs.TLName typeName) tVars
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "parse",
|
|
params = [Hs.PVar "raw_"],
|
|
value =
|
|
Hs.EFApp (Hs.ELName dataCtorName) $
|
|
[ Hs.EApp
|
|
(egName ["GH"] "parseField")
|
|
[Hs.ELabel field, euName "raw_"]
|
|
| field <- map fst fields
|
|
]
|
|
++ if hasUnion
|
|
then
|
|
[ Hs.EApp
|
|
(egName ["C"] "parse")
|
|
[Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"]]
|
|
]
|
|
else []
|
|
}
|
|
]
|
|
}
|
|
]
|
|
defineParse typeName typeParams AO.ParsedUnion {variants} =
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars]
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "parse",
|
|
params = [Hs.PVar "raw_"],
|
|
value =
|
|
Hs.EDo
|
|
[ Hs.DoBind "rawWhich_" $ Hs.EApp (egName ["GH"] "unionWhich") [euName "raw_"]
|
|
]
|
|
( Hs.ECase (euName "rawWhich_") $
|
|
[ let ctorName = Name.mkSub typeName variantName
|
|
in case fieldLocType of
|
|
C.VoidField ->
|
|
( puName (rawCtorName ctorName) [Hs.PVar "_"],
|
|
Hs.EApp (eStd_ "pure") [Hs.ELName ctorName]
|
|
)
|
|
_ ->
|
|
( puName (rawCtorName ctorName) [Hs.PVar "rawArg_"],
|
|
Hs.EFApp
|
|
(Hs.ELName ctorName)
|
|
[Hs.EApp (egName ["C"] "parse") [euName "rawArg_"]]
|
|
)
|
|
| (variantName, fieldLocType) <- variants
|
|
]
|
|
++ [ let ctorName = unknownVariant typeName
|
|
in ( puName (rawCtorName ctorName) [Hs.PVar "tag_"],
|
|
Hs.EApp
|
|
(eStd_ "pure")
|
|
[Hs.EApp (Hs.ELName ctorName) [euName "tag_"]]
|
|
)
|
|
]
|
|
)
|
|
}
|
|
]
|
|
}
|
|
]
|
|
|
|
defineInterfaceParse typeName typeParams =
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (Hs.TLName typeName) tVars
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["GH"] "Client") [typ]],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "parse",
|
|
params = [],
|
|
value = egName ["GH"] "parseCap"
|
|
},
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "encode",
|
|
params = [],
|
|
value = egName ["GH"] "encodeCap"
|
|
}
|
|
]
|
|
}
|
|
]
|
|
|
|
defineMarshal :: Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
|
|
defineMarshal typeName typeParams AO.ParsedStruct {fields, hasUnion, dataCtorName} =
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (Hs.TLName typeName) tVars
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["C"] "Marshal")
|
|
[typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
|
|
defs =
|
|
[ if null fields && not hasUnion
|
|
then -- We need to special case this, since otherwise GHC will complain about
|
|
-- the record wildcard pattern on a ctor with no arguments.
|
|
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "marshalInto",
|
|
params = [Hs.PVar "_raw", Hs.PLCtor dataCtorName []],
|
|
value = Hs.EApp (eStd_ "pure") [Hs.ETup []]
|
|
}
|
|
else
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "marshalInto",
|
|
params =
|
|
[Hs.PVar "raw_", Hs.PLRecordWildCard dataCtorName],
|
|
value =
|
|
Hs.EDo
|
|
(map (Hs.DoE . uncurry emitMarshalField) fields)
|
|
( if hasUnion
|
|
then
|
|
Hs.EApp
|
|
(egName ["C"] "marshalInto")
|
|
[ Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"],
|
|
euName "union'"
|
|
]
|
|
else Hs.EApp (eStd_ "pure") [Hs.ETup []]
|
|
)
|
|
}
|
|
]
|
|
}
|
|
]
|
|
defineMarshal typeName typeParams AO.ParsedUnion {variants} =
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars]
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ =
|
|
Hs.TApp
|
|
(tgName ["C"] "Marshal")
|
|
[typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
|
|
defs =
|
|
[ Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "marshalInto",
|
|
params = [Hs.PVar "raw_", Hs.PVar "parsed_"],
|
|
value =
|
|
Hs.ECase (Hs.EVar "parsed_") $
|
|
[ ( Hs.PLCtor (Name.mkSub typeName name) $
|
|
case fieldLocType of
|
|
C.VoidField -> []
|
|
_ -> [Hs.PVar "arg_"],
|
|
emitMarshalVariant name fieldLocType
|
|
)
|
|
| (name, fieldLocType) <- variants
|
|
]
|
|
++ [ ( Hs.PLCtor (unknownVariant typeName) [Hs.PVar "tag_"],
|
|
Hs.EApp
|
|
(egName ["GH"] "encodeField")
|
|
[ egName ["GH"] "unionField",
|
|
Hs.EVar "tag_",
|
|
unionStruct (euName "raw_")
|
|
]
|
|
)
|
|
]
|
|
}
|
|
]
|
|
}
|
|
]
|
|
|
|
defineInterfaceServer thisMod typeName typeParams methods supers =
|
|
let tVars = toTVars typeParams
|
|
typ = Hs.TApp (Hs.TLName typeName) tVars
|
|
clsName = Name.mkSub typeName "server_"
|
|
in [ Hs.DcInstance
|
|
{ ctx = paramsContext tVars,
|
|
typ = Hs.TApp (tgName ["GH"] "Export") [typ],
|
|
defs =
|
|
[ Hs.IdType $ Hs.TypeAlias "Server" [typ] $ Hs.TApp (Hs.TLName clsName) tVars,
|
|
Hs.IdValue
|
|
Hs.DfValue
|
|
{ name = "methodHandlerTree",
|
|
params = [Hs.PVar "_", Hs.PVar "s_"],
|
|
value =
|
|
Hs.EApp
|
|
(egName ["GH"] "MethodHandlerTree")
|
|
[ Hs.ETypeApp (egName ["C"] "typeId") [typ],
|
|
Hs.EList
|
|
[ Hs.EApp
|
|
(egName ["GH"] "toUntypedMethodHandler")
|
|
[ Hs.EApp
|
|
( Hs.ETypeApp
|
|
(Hs.EVar (Name.renderUnQ (Name.valueName (Name.mkSub typeName methodName))))
|
|
tVars
|
|
)
|
|
[Hs.EVar "s_"]
|
|
]
|
|
| AO.MethodInfo {methodName} <- methods
|
|
],
|
|
Hs.EList
|
|
[ Hs.EApp
|
|
(egName ["GH"] "methodHandlerTree")
|
|
[ Hs.ETypeApp
|
|
(egName ["GH"] "Proxy")
|
|
[typeToType thisMod $ C.PtrType $ C.PtrInterface super],
|
|
Hs.EVar "s_"
|
|
]
|
|
| super <- supers
|
|
]
|
|
]
|
|
}
|
|
]
|
|
},
|
|
Hs.DcClass
|
|
{ ctx =
|
|
[ Hs.TApp
|
|
(tgName ["GH"] "Server")
|
|
[ typeToType thisMod $ C.PtrType $ C.PtrInterface super,
|
|
Hs.TVar "s_"
|
|
]
|
|
| super <- supers
|
|
],
|
|
name = clsName,
|
|
params = map (Name.UnQ . Name.typeVarName) typeParams ++ ["s_"],
|
|
funDeps = [],
|
|
decls =
|
|
Hs.CdMinimal
|
|
[ mkMethodName typeName methodName
|
|
| AO.MethodInfo {methodName} <- methods
|
|
]
|
|
: concatMap (defineIfaceClassMethod thisMod typeName) methods
|
|
}
|
|
]
|
|
|
|
defineIfaceClassMethod thisMod typeName AO.MethodInfo {methodName, paramType, resultType} =
|
|
let mkType t = typeToType thisMod (C.CompositeType t)
|
|
name = mkMethodName typeName methodName
|
|
in [ Hs.CdValueDecl
|
|
name
|
|
( Hs.TFn
|
|
[ Hs.TVar "s_",
|
|
Hs.TApp
|
|
(tgName ["GH"] "MethodHandler")
|
|
[ mkType paramType,
|
|
mkType resultType
|
|
]
|
|
]
|
|
),
|
|
Hs.CdValueDef
|
|
Hs.DfValue
|
|
{ name,
|
|
params = [Hs.PVar "_"],
|
|
value = egName ["GH"] "methodUnimplemented"
|
|
}
|
|
]
|
|
|
|
mkMethodName typeName methodName =
|
|
Name.valueName (Name.mkSub typeName methodName)
|
|
|
|
emitMarshalField :: Name.UnQ -> C.FieldLocType AO.Brand Name.ZapQ -> Hs.Exp
|
|
emitMarshalField name (C.HereField _) =
|
|
Hs.EDo
|
|
[ Hs.DoBind "group_" $
|
|
Hs.EApp
|
|
(egName ["GH"] "readField")
|
|
[Hs.ELabel name, Hs.EVar "raw_"]
|
|
]
|
|
(Hs.EApp (egName ["C"] "marshalInto") [Hs.EVar "group_", euName name])
|
|
emitMarshalField name _ =
|
|
Hs.EApp
|
|
(egName ["GH"] "encodeField")
|
|
[ Hs.ELabel name,
|
|
euName name,
|
|
euName "raw_"
|
|
]
|
|
|
|
emitMarshalVariant :: Name.UnQ -> C.FieldLocType AO.Brand Name.ZapQ -> Hs.Exp
|
|
emitMarshalVariant name (C.HereField _) =
|
|
Hs.EDo
|
|
[ Hs.DoBind "rawGroup_" $
|
|
Hs.EApp
|
|
(egName ["GH"] "initVariant")
|
|
[ Hs.ELabel name,
|
|
unionStruct (euName "raw_")
|
|
]
|
|
]
|
|
(Hs.EApp (egName ["C"] "marshalInto") [euName "rawGroup_", euName "arg_"])
|
|
emitMarshalVariant name C.VoidField =
|
|
Hs.EApp
|
|
(egName ["GH"] "encodeVariant")
|
|
[ Hs.ELabel name,
|
|
Hs.ETup [],
|
|
unionStruct (euName "raw_")
|
|
]
|
|
emitMarshalVariant name _ =
|
|
Hs.EApp
|
|
(egName ["GH"] "encodeVariant")
|
|
[ Hs.ELabel name,
|
|
euName "arg_",
|
|
unionStruct (euName "raw_")
|
|
]
|
|
|
|
unionStruct :: Hs.Exp -> Hs.Exp
|
|
unionStruct e = Hs.EApp (egName ["GH"] "unionStruct") [e]
|