AbstractOpToHaskell.hs

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}

module Trans.AbstractOpToHaskell
  ( fileToModules,
  )
where

import qualified Capnp.Repr as R
import Control.Monad (guard)
import Data.String (IsString (fromString))
import Data.Word
import qualified IR.AbstractOp as AO
import qualified IR.Common as C
import qualified IR.Haskell as Hs
import qualified IR.Name as Name
import Trans.ToHaskellCommon

-- | Modules imported by all generated modules.
imports :: [Hs.Import]
imports =
  [ Hs.ImportAs {importAs = "R", parts = ["Capnp", "Repr"]},
    Hs.ImportAs {importAs = "RP", parts = ["Capnp", "Repr", "Parsed"]},
    Hs.ImportAs {importAs = "Basics", parts = ["Capnp", "Basics"]},
    Hs.ImportAs {importAs = "OL", parts = ["GHC", "OverloadedLabels"]},
    Hs.ImportAs {importAs = "GH", parts = ["Capnp", "GenHelpers"]},
    Hs.ImportAs {importAs = "C", parts = ["Capnp", "Classes"]},
    Hs.ImportAs {importAs = "Generics", parts = ["GHC", "Generics"]}
  ]

-- | Modules imported by generated modules that use rpc. We separate these out to
-- avoid a circular import when generating code for rpc.capnp -- which does not
-- contain interfaces, so does not need to import the rpc system -- but which
-- must be imported *by* the rpc system.
rpcImports :: [Hs.Import]
rpcImports =
  [ Hs.ImportAs {importAs = "GH", parts = ["Capnp", "GenHelpers", "Rpc"]}
  ]

fileToModules :: AO.File -> [Hs.Module]
fileToModules file =
  [ fileToMainModule file,
    fileToModuleAlias file
  ]

fileToMainModule :: AO.File -> Hs.Module
fileToMainModule file@AO.File {fileName, usesRpc} =
  fixImports $
    Hs.Module
      { modName = ["Capnp", "Gen"] ++ makeModName fileName,
        modLangPragmas =
          [ "TypeFamilies",
            "DataKinds",
            "DeriveGeneric",
            "DuplicateRecordFields",
            "EmptyDataDeriving",
            "FlexibleContexts",
            "FlexibleInstances",
            "MultiParamTypeClasses",
            "UndecidableInstances",
            "UndecidableSuperClasses",
            "OverloadedLabels",
            "OverloadedStrings",
            "StandaloneDeriving",
            "RecordWildCards",
            "TypeApplications",
            "ScopedTypeVariables"
          ],
        modExports = Nothing,
        modImports = imports ++ (guard usesRpc >> rpcImports),
        modDecls = fileToDecls file
      }

fileToModuleAlias :: AO.File -> Hs.Module
fileToModuleAlias AO.File {fileId, fileName} =
  let reExport = ["Capnp", "Gen"] ++ makeModName fileName
   in Hs.Module
        { modName = idToModule fileId,
          modLangPragmas = [],
          modExports = Just [Hs.ExportMod reExport],
          modImports = [Hs.ImportAll {parts = reExport}],
          modDecls = []
        }

fileToDecls :: AO.File -> [Hs.Decl]
fileToDecls AO.File {fileId, decls} =
  concatMap (declToDecls fileId) decls

declToDecls :: Word64 -> AO.Decl -> [Hs.Decl]
declToDecls thisMod decl =
  case decl of
    AO.TypeDecl {name, nodeId, params, repr, extraTypeInfo} ->
      let dataName = Name.localToUnQ name
          typeArgs = toTVars params
          typ = case typeArgs of
            [] -> tuName dataName
            _ -> Hs.TApp (tuName dataName) typeArgs
       in [ Hs.DcData
              Hs.Data
                { dataName,
                  typeArgs,
                  dataVariants =
                    case extraTypeInfo of
                      Just (AO.EnumTypeInfo variants) ->
                        [ Hs.DataVariant
                            { dvCtorName = Name.localToUnQ $ Name.mkSub name variantName,
                              dvArgs = Hs.APos []
                            }
                          | variantName <- variants
                        ]
                          ++ [declareUnknownVariant name]
                      _ -> [],
                  derives =
                    case extraTypeInfo of
                      Just AO.EnumTypeInfo {} -> ["Std_.Eq", "Std_.Show", "Generics.Generic"]
                      _ -> [],
                  dataNewtype = False,
                  dataInstance = False
                },
            Hs.DcTypeInstance
              (Hs.TApp (tgName ["R"] "ReprFor") [typ])
              (toType repr),
            Hs.DcInstance
              { ctx = [],
                typ = Hs.TApp (tgName ["C"] "HasTypeId") [typ],
                defs =
                  [ Hs.IdValue
                      Hs.DfValue
                        { name = "typeId",
                          params = [],
                          value = Hs.EInt (fromIntegral nodeId)
                        }
                  ]
              }
          ]
            ++ let ctx = paramsContext typeArgs
                in case extraTypeInfo of
                     Just AO.StructTypeInfo {nWords, nPtrs} ->
                       [ Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "TypedStruct") [typ],
                             defs =
                               [ Hs.IdValue
                                   Hs.DfValue
                                     { name = "numStructWords",
                                       params = [],
                                       value = Hs.EInt $ fromIntegral nWords
                                     },
                                 Hs.IdValue
                                   Hs.DfValue
                                     { name = "numStructPtrs",
                                       params = [],
                                       value = Hs.EInt $ fromIntegral nPtrs
                                     }
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "Allocate") [typ],
                             defs =
                               [ Hs.IdType $
                                   Hs.TypeAlias "AllocHint" [typ] Hs.TUnit,
                                 Hs.IdValue
                                   Hs.DfValue
                                     { name = "new",
                                       params = [Hs.PVar "_"],
                                       value = egName ["C"] "newTypedStruct"
                                     }
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ =
                               Hs.TApp
                                 (tgName ["C"] "EstimateAlloc")
                                 [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
                             defs = []
                           },
                         Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "AllocateList") [typ],
                             defs =
                               [ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int"),
                                 Hs.IdValue
                                   Hs.DfValue
                                     { name = "newList",
                                       params = [],
                                       value = egName ["C"] "newTypedStructList"
                                     }
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ =
                               Hs.TApp
                                 (tgName ["C"] "EstimateListAlloc")
                                 [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
                             defs = []
                           }
                       ]
                     Just (AO.EnumTypeInfo variants) ->
                       [ Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tStd_ "Enum") [typ],
                             defs =
                               [ Hs.IdValue
                                   Hs.DfValue
                                     { name = "toEnum",
                                       params = [Hs.PVar "n_"],
                                       value =
                                         Hs.ECase (euName "n_") $
                                           [ ( Hs.PInt i,
                                               Hs.ELName (Name.mkSub name variantName)
                                             )
                                             | (i, variantName) <- zip [0 ..] variants
                                           ]
                                             ++ [ ( Hs.PVar "tag_",
                                                    Hs.EApp
                                                      (Hs.ELName (unknownVariant name))
                                                      [Hs.EApp (eStd_ "fromIntegral") [euName "tag_"]]
                                                  )
                                                ]
                                     },
                                 Hs.IdValue
                                   Hs.DfValue
                                     { name = "fromEnum",
                                       params = [Hs.PVar "value_"],
                                       value =
                                         Hs.ECase (euName "value_") $
                                           [ ( Hs.PLCtor (Name.mkSub name variantName) [],
                                               Hs.EInt i
                                             )
                                             | (i, variantName) <- zip [0 ..] variants
                                           ]
                                             ++ [ ( Hs.PLCtor (unknownVariant name) [Hs.PVar "tag_"],
                                                    Hs.EApp (eStd_ "fromIntegral") [euName "tag_"]
                                                  )
                                                ]
                                     }
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "IsWord") [typ],
                             defs =
                               [ Hs.IdValue
                                   Hs.DfValue
                                     { name = "fromWord",
                                       params = [Hs.PVar "w_"],
                                       value = Hs.EApp (eStd_ "toEnum") [Hs.EApp (eStd_ "fromIntegral") [Hs.EVar "w_"]]
                                     },
                                 Hs.IdValue
                                   Hs.DfValue
                                     { name = "toWord",
                                       params = [Hs.PVar "v_"],
                                       value = Hs.EApp (eStd_ "fromIntegral") [Hs.EApp (eStd_ "fromEnum") [Hs.EVar "v_"]]
                                     }
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "Parse") [typ, typ],
                             defs =
                               [ Hs.IdValue
                                   Hs.DfValue
                                     { name = "parse",
                                       params = [],
                                       value = egName ["GH"] "parseEnum"
                                     },
                                 Hs.IdValue
                                   Hs.DfValue
                                     { name = "encode",
                                       params = [],
                                       value = egName ["GH"] "encodeEnum"
                                     }
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "AllocateList") [typ],
                             defs =
                               [ Hs.IdType $ Hs.TypeAlias "ListAllocHint" [typ] (tStd_ "Int")
                               ]
                           },
                         Hs.DcInstance
                           { ctx,
                             typ = Hs.TApp (tgName ["C"] "EstimateListAlloc") [typ, typ],
                             defs = []
                           }
                       ]
                     Just AO.InterfaceTypeInfo {methods, supers} ->
                       defineInterfaceParse name params
                         ++ defineInterfaceServer thisMod name params methods supers
                     Nothing -> []
    AO.FieldDecl {containerType, typeParams, fieldName, fieldLocType} ->
      let tVars = toTVars typeParams
          ctx = paramsContext tVars
          labelType = Hs.TString (Name.renderUnQ fieldName)
          parentType = Hs.TApp (Hs.TLName containerType) tVars
          childType = fieldLocTypeToType thisMod fieldLocType
          fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType
       in [ Hs.DcInstance
              { ctx,
                typ =
                  Hs.TApp
                    (tgName ["GH"] "HasField")
                    [labelType, fieldKind, parentType, childType],
                defs =
                  [ Hs.IdValue
                      Hs.DfValue
                        { name = "fieldByLabel",
                          value = fieldLocTypeToField fieldLocType,
                          params = []
                        }
                  ]
              }
          ]
    AO.UnionDecl {name, typeParams, tagLoc, variants} ->
      let tVars = toTVars typeParams
          typ = Hs.TApp (Hs.TLName name) tVars
       in Hs.DcInstance
            { ctx = paramsContext tVars,
              typ = Hs.TApp (tgName ["GH"] "HasUnion") [typ],
              defs =
                [ Hs.IdValue
                    Hs.DfValue
                      { name = "unionField",
                        params = [],
                        value =
                          fieldLocTypeToField $
                            C.DataField
                              tagLoc
                              (C.PrimWord (C.PrimInt (C.IntType C.Unsigned C.Sz16)))
                      },
                  defineRawData thisMod name tVars variants,
                  defineInternalWhich name variants,
                  Hs.IdData
                    Hs.Data
                      { dataName = "Which",
                        typeArgs = [typ],
                        dataVariants = [],
                        derives = [],
                        dataNewtype = False,
                        dataInstance = False
                      }
                ]
            }
            : concatMap (variantToDecls thisMod name typeParams) variants
    AO.SuperDecl {subName, typeParams, superType} ->
      let tVars = toTVars typeParams
       in [ Hs.DcInstance
              { ctx = paramsContext tVars,
                typ =
                  Hs.TApp
                    (tgName ["C"] "Super")
                    [ typeToType thisMod $ C.PtrType $ C.PtrInterface superType,
                      Hs.TApp (Hs.TLName subName) tVars
                    ],
                defs = []
              }
          ]
    AO.MethodDecl
      { interfaceName,
        interfaceId,
        methodId,
        methodInfo =
          AO.MethodInfo
            { typeParams,
              methodName,
              paramType,
              resultType
            }
      } ->
        let tVars = toTVars typeParams
         in [ Hs.DcInstance
                { ctx = paramsContext tVars,
                  typ =
                    Hs.TApp
                      (tgName ["GH"] "HasMethod")
                      [ Hs.TString (Name.renderUnQ methodName),
                        Hs.TApp (Hs.TLName interfaceName) tVars,
                        compositeTypeToType thisMod paramType,
                        compositeTypeToType thisMod resultType
                      ],
                  defs =
                    [ Hs.IdValue
                        Hs.DfValue
                          { name = "methodByLabel",
                            params = [],
                            value =
                              Hs.EApp
                                (egName ["GH"] "Method")
                                [ Hs.EInt $ fromIntegral interfaceId,
                                  Hs.EInt $ fromIntegral methodId
                                ]
                          }
                    ]
                }
            ]
    AO.ParsedInstanceDecl {typeName, typeParams, parsedInstances} ->
      defineParsedInstances thisMod typeName typeParams parsedInstances
    AO.ConstDecl {name, value} ->
      defineConstant thisMod name value

defineConstant thisMod localName value =
  let name = Name.localToUnQ localName
   in case value of
        C.VoidValue ->
          [ Hs.DcValue
              { typ = Hs.TUnit,
                def =
                  Hs.DfValue
                    { name,
                      params = [],
                      value = Hs.ETup []
                    }
              }
          ]
        C.WordValue t v ->
          [ Hs.DcValue
              { typ = typeToType thisMod (C.WordType t),
                def =
                  Hs.DfValue
                    { name,
                      params = [],
                      value = Hs.EApp (egName ["C"] "fromWord") [Hs.EInt (fromIntegral v)]
                    }
              }
          ]
        C.PtrValue t v ->
          [ Hs.DcValue
              { typ = Hs.TApp (tgName ["R"] "Raw") [typeToType thisMod (C.PtrType t), tgName ["GH"] "Const"],
                def =
                  Hs.DfValue
                    { name,
                      params = [],
                      value =
                        Hs.EApp
                          (egName ["GH"] "getPtrConst")
                          [Hs.ETypeAnno (Hs.EBytes (makePtrBytes v)) (tgName ["GH"] "ByteString")]
                    }
              }
          ]

defineRawData thisMod name tVars variants =
  Hs.IdData
    Hs.Data
      { dataName = "RawWhich",
        typeArgs =
          [ Hs.TApp (Hs.TVar $ Name.renderUnQ $ Name.localToUnQ name) tVars,
            Hs.TVar "mut_"
          ],
        dataNewtype = False,
        dataInstance = False,
        dataVariants =
          [ Hs.DataVariant
              { dvCtorName =
                  "RW_" <> Name.localToUnQ (Name.mkSub name variantName),
                dvArgs =
                  Hs.APos
                    [ Hs.TApp
                        (tReprName "Raw")
                        [ fieldLocTypeToType thisMod fieldLocType,
                          Hs.TVar "mut_"
                        ]
                    ]
              }
            | AO.UnionVariant {variantName, fieldLocType} <- variants
          ]
            ++ [ Hs.DataVariant
                   { dvCtorName = "RW_" <> Name.localToUnQ (unknownVariant name),
                     dvArgs = Hs.APos [tStd_ "Word16"]
                   }
               ],
        -- TODO: derive Show, Read, Eq, Generic, to be feature complete with the code generated by RawToHaskell.
        -- This will require a stand-alone deriving declaration
        derives = []
      }

unknownVariant :: Name.LocalQ -> Name.LocalQ
unknownVariant name = Name.mkSub name "unknown'"

rawCtorName :: Name.LocalQ -> Name.UnQ
rawCtorName local = "RW_" <> Name.localToUnQ local

defineInternalWhich structName variants =
  Hs.IdValue
    Hs.DfValue
      { name = "internalWhich",
        params = [Hs.PVar "tag_", Hs.PVar "struct_"],
        value =
          Hs.ECase (Hs.ELName "tag_") $
            [ ( Hs.PInt $ fromIntegral tagValue,
                Hs.EFApp
                  (euName $ rawCtorName (Name.mkSub structName variantName))
                  [ Hs.EApp
                      (egName ["GH"] "readVariant")
                      [ Hs.ELabel variantName,
                        euName "struct_"
                      ]
                  ]
              )
              | AO.UnionVariant {tagValue, variantName} <- variants
            ]
              ++ [ ( Hs.PVar "_",
                     Hs.EApp
                       (eStd_ "pure")
                       [ Hs.EApp
                           (euName $ rawCtorName (unknownVariant structName))
                           [euName "tag_"]
                       ]
                   )
                 ]
      }

variantToDecls thisMod containerType typeParams AO.UnionVariant {tagValue, variantName, fieldLocType} =
  let tVars = toTVars typeParams
      ctx = paramsContext tVars
      labelType = Hs.TString (Name.renderUnQ variantName)
      parentType = Hs.TApp (Hs.TLName containerType) tVars
      childType = fieldLocTypeToType thisMod fieldLocType
      fieldKind = Hs.TGName $ fieldLocTypeToFieldKind fieldLocType
   in [ Hs.DcInstance
          { ctx,
            typ =
              Hs.TApp
                (tgName ["GH"] "HasVariant")
                [labelType, fieldKind, parentType, childType],
            defs =
              [ Hs.IdValue
                  Hs.DfValue
                    { name = "variantByLabel",
                      params = [],
                      value =
                        Hs.EApp
                          (egName ["GH"] "Variant")
                          [ fieldLocTypeToField fieldLocType,
                            Hs.EInt (fromIntegral tagValue)
                          ]
                    }
              ]
          }
      ]

paramsContext :: [Hs.Type] -> [Hs.Type]
paramsContext = map paramConstraints

-- | Constraints required for a capnproto type parameter. The returned
-- expression has kind 'Constraint'.
paramConstraints :: Hs.Type -> Hs.Type
paramConstraints t =
  Hs.TApp (tgName ["GH"] "TypeParam") [t]

tCapnp :: Word64 -> Name.CapnpQ -> Hs.Type
tCapnp thisMod Name.CapnpQ {local, fileId}
  | thisMod == fileId = Hs.TLName local
  | otherwise = tgName (map Name.renderUnQ $ idToModule fileId) local

fieldLocTypeToType :: Word64 -> C.FieldLocType AO.Brand Name.CapnpQ -> Hs.Type
fieldLocTypeToType thisMod = \case
  C.VoidField -> Hs.TUnit
  C.DataField _ t -> wordTypeToType thisMod t
  C.PtrField _ t -> ptrTypeToType thisMod t
  C.HereField t -> compositeTypeToType thisMod t

fieldLocTypeToFieldKind :: C.FieldLocType b n -> Name.GlobalQ
fieldLocTypeToFieldKind = \case
  C.HereField _ -> gName ["GH"] "Group"
  _ -> gName ["GH"] "Slot"

wordTypeToType thisMod = \case
  C.EnumType t -> tCapnp thisMod t
  C.PrimWord t -> primWordToType t

primWordToType = \case
  C.PrimInt t -> intTypeToType t
  C.PrimFloat32 -> tStd_ "Float"
  C.PrimFloat64 -> tStd_ "Double"
  C.PrimBool -> tStd_ "Bool"

intTypeToType (C.IntType sign size) =
  let prefix = case sign of
        C.Signed -> "Int"
        C.Unsigned -> "Word"
   in tStd_ $ fromString $ prefix ++ show (C.sizeBits size)

wordTypeBits = \case
  C.EnumType _ -> 16
  C.PrimWord (C.PrimInt (C.IntType _ size)) -> C.sizeBits size
  C.PrimWord C.PrimFloat32 -> 32
  C.PrimWord C.PrimFloat64 -> 64
  C.PrimWord C.PrimBool -> 1

ptrTypeToType thisMod = \case
  C.ListOf t -> Hs.TApp (tgName ["R"] "List") [typeToType thisMod t]
  C.PrimPtr t -> primPtrToType t
  C.PtrComposite t -> compositeTypeToType thisMod t
  C.PtrInterface t -> interfaceTypeToType thisMod t
  C.PtrParam t -> typeParamToType t

typeToType thisMod = \case
  C.CompositeType t -> compositeTypeToType thisMod t
  C.VoidType -> Hs.TUnit
  C.WordType t -> wordTypeToType thisMod t
  C.PtrType t -> ptrTypeToType thisMod t

primPtrToType = \case
  C.PrimText -> tgName ["Basics"] "Text"
  C.PrimData -> tgName ["Basics"] "Data"
  C.PrimAnyPtr t -> anyPtrToType t

anyPtrToType :: C.AnyPtr -> Hs.Type
anyPtrToType t = case t of
  C.Struct -> basics "AnyStruct"
  C.List -> basics "AnyList"
  C.Cap -> basics "Capability"
  C.Ptr -> Hs.TApp (tStd_ "Maybe") [basics "AnyPointer"]
  where
    basics = tgName ["Basics"]

compositeTypeToType thisMod (C.StructType name brand) = namedType thisMod name brand

interfaceTypeToType thisMod (C.InterfaceType name brand) = namedType thisMod name brand

typeParamToType = Hs.TVar . Name.typeVarName . C.paramName

namedType :: Word64 -> Name.CapnpQ -> C.ListBrand Name.CapnpQ -> Hs.Type
namedType thisMod name (C.ListBrand []) = tCapnp thisMod name
namedType thisMod name (C.ListBrand args) =
  Hs.TApp
    (tCapnp thisMod name)
    [typeToType thisMod (C.PtrType t) | t <- args]

fieldLocTypeToField = \case
  C.DataField loc wt ->
    let shift = C.dataOff loc
        index = C.dataIdx loc
        nbits = wordTypeBits wt
        defaultValue = C.dataDef loc
     in Hs.EApp
          (egName ["GH"] "dataField")
          [ Hs.EInt $ fromIntegral shift,
            Hs.EInt $ fromIntegral index,
            Hs.EInt $ fromIntegral nbits,
            Hs.EInt $ fromIntegral defaultValue
          ]
  C.PtrField idx _ ->
    Hs.EApp (egName ["GH"] "ptrField") [Hs.EInt $ fromIntegral idx]
  C.VoidField ->
    egName ["GH"] "voidField"
  C.HereField _ ->
    egName ["GH"] "groupField"

class ToType a where
  toType :: a -> Hs.Type

instance ToType R.Repr where
  toType (R.Ptr p) = rApp "Ptr" [toType p]
  toType (R.Data d) = rApp "Data" [toType d]

instance ToType a => ToType (Maybe a) where
  toType Nothing = tStd_ "Nothing"
  toType (Just a) = Hs.TApp (tStd_ "Just") [toType a]

instance ToType R.PtrRepr where
  toType R.Cap = tReprName "Cap"
  toType (R.List r) = rApp "List" [toType r]
  toType R.Struct = tReprName "Struct"

instance ToType R.ListRepr where
  toType (R.ListNormal nl) = rApp "ListNormal" [toType nl]
  toType R.ListComposite = tReprName "ListComposite"

instance ToType R.NormalListRepr where
  toType (R.NormalListData r) = rApp "ListData" [toType r]
  toType R.NormalListPtr = tReprName "ListPtr"

instance ToType R.DataSz where
  toType = tReprName . fromString . show

rApp :: Name.LocalQ -> [Hs.Type] -> Hs.Type
rApp n = Hs.TApp (tReprName n)

tReprName :: Name.LocalQ -> Hs.Type
tReprName = tgName ["R"]

declareUnknownVariant :: Name.LocalQ -> Hs.DataVariant
declareUnknownVariant name =
  Hs.DataVariant
    { dvCtorName = Name.localToUnQ $ Name.mkSub name "unknown'",
      dvArgs = Hs.APos [tStd_ "Word16"]
    }

defineParsedInstances :: Word64 -> Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
defineParsedInstances thisMod typeName typeParams instanceInfo =
  concatMap
    (\f -> f typeName typeParams instanceInfo)
    [ defineParsed thisMod,
      defineParse,
      defineMarshal
    ]

defineParsed :: Word64 -> Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
defineParsed thisMod typeName typeParams instanceInfo =
  let tVars = map (Hs.TVar . Name.typeVarName) typeParams
      typ = Hs.TApp (Hs.TLName typeName) tVars
      parsedTy = case instanceInfo of
        AO.ParsedStruct {} -> typ
        AO.ParsedUnion {} -> Hs.TApp (tgName ["GH"] "Which") [typ]
   in Hs.DcData
        Hs.Data
          { dataName = "C.Parsed",
            typeArgs = [parsedTy],
            derives = ["Generics.Generic"],
            dataNewtype = False,
            dataInstance = True,
            dataVariants =
              case instanceInfo of
                AO.ParsedStruct {fields, hasUnion, dataCtorName} ->
                  [ Hs.DataVariant
                      { dvCtorName = Name.localToUnQ dataCtorName,
                        dvArgs =
                          Hs.ARec $
                            [ ( name,
                                Hs.TApp
                                  (tgName ["RP"] "Parsed")
                                  [fieldLocTypeToType thisMod typ]
                              )
                              | (name, typ) <- fields
                            ]
                              ++ [ ( "union'",
                                     Hs.TApp
                                       (tgName ["C"] "Parsed")
                                       [Hs.TApp (tgName ["GH"] "Which") [typ]]
                                   )
                                   | hasUnion
                                 ]
                      }
                  ]
                AO.ParsedUnion {variants} ->
                  [ Hs.DataVariant
                      { dvCtorName = Name.localToUnQ $ Name.mkSub typeName name,
                        dvArgs = case ftype of
                          C.VoidField -> Hs.APos []
                          _ ->
                            Hs.APos
                              [ Hs.TApp
                                  (tgName ["RP"] "Parsed")
                                  [fieldLocTypeToType thisMod ftype]
                              ]
                      }
                    | (name, ftype) <- variants
                  ]
                    ++ [declareUnknownVariant typeName]
          }
        : [ Hs.DcDeriveInstance
              [ Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["RP"] "Parsed") [v]]
                | v <- tVars
              ]
              (Hs.TApp (tStd_ cls) [Hs.TApp (tgName ["C"] "Parsed") [parsedTy]])
            | cls <- ["Show", "Eq"]
          ]

defineParse :: Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
defineParse typeName typeParams AO.ParsedStruct {fields, hasUnion, dataCtorName} =
  let tVars = toTVars typeParams
      typ = Hs.TApp (Hs.TLName typeName) tVars
   in [ Hs.DcInstance
          { ctx = paramsContext tVars,
            typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
            defs =
              [ Hs.IdValue
                  Hs.DfValue
                    { name = "parse",
                      params = [Hs.PVar "raw_"],
                      value =
                        Hs.EFApp (Hs.ELName dataCtorName) $
                          [ Hs.EApp
                              (egName ["GH"] "parseField")
                              [Hs.ELabel field, euName "raw_"]
                            | field <- map fst fields
                          ]
                            ++ if hasUnion
                              then
                                [ Hs.EApp
                                    (egName ["C"] "parse")
                                    [Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"]]
                                ]
                              else []
                    }
              ]
          }
      ]
defineParse typeName typeParams AO.ParsedUnion {variants} =
  let tVars = toTVars typeParams
      typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars]
   in [ Hs.DcInstance
          { ctx = paramsContext tVars,
            typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
            defs =
              [ Hs.IdValue
                  Hs.DfValue
                    { name = "parse",
                      params = [Hs.PVar "raw_"],
                      value =
                        Hs.EDo
                          [ Hs.DoBind "rawWhich_" $ Hs.EApp (egName ["GH"] "unionWhich") [euName "raw_"]
                          ]
                          ( Hs.ECase (euName "rawWhich_") $
                              [ let ctorName = Name.mkSub typeName variantName
                                 in case fieldLocType of
                                      C.VoidField ->
                                        ( puName (rawCtorName ctorName) [Hs.PVar "_"],
                                          Hs.EApp (eStd_ "pure") [Hs.ELName ctorName]
                                        )
                                      _ ->
                                        ( puName (rawCtorName ctorName) [Hs.PVar "rawArg_"],
                                          Hs.EFApp
                                            (Hs.ELName ctorName)
                                            [Hs.EApp (egName ["C"] "parse") [euName "rawArg_"]]
                                        )
                                | (variantName, fieldLocType) <- variants
                              ]
                                ++ [ let ctorName = unknownVariant typeName
                                      in ( puName (rawCtorName ctorName) [Hs.PVar "tag_"],
                                           Hs.EApp
                                             (eStd_ "pure")
                                             [Hs.EApp (Hs.ELName ctorName) [euName "tag_"]]
                                         )
                                   ]
                          )
                    }
              ]
          }
      ]

defineInterfaceParse typeName typeParams =
  let tVars = toTVars typeParams
      typ = Hs.TApp (Hs.TLName typeName) tVars
   in [ Hs.DcInstance
          { ctx = paramsContext tVars,
            typ = Hs.TApp (tgName ["C"] "Parse") [typ, Hs.TApp (tgName ["GH"] "Client") [typ]],
            defs =
              [ Hs.IdValue
                  Hs.DfValue
                    { name = "parse",
                      params = [],
                      value = egName ["GH"] "parseCap"
                    },
                Hs.IdValue
                  Hs.DfValue
                    { name = "encode",
                      params = [],
                      value = egName ["GH"] "encodeCap"
                    }
              ]
          }
      ]

defineMarshal :: Name.LocalQ -> [Name.UnQ] -> AO.ParsedInstances -> [Hs.Decl]
defineMarshal typeName typeParams AO.ParsedStruct {fields, hasUnion, dataCtorName} =
  let tVars = toTVars typeParams
      typ = Hs.TApp (Hs.TLName typeName) tVars
   in [ Hs.DcInstance
          { ctx = paramsContext tVars,
            typ =
              Hs.TApp
                (tgName ["C"] "Marshal")
                [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
            defs =
              [ if null fields && not hasUnion
                  then -- We need to special case this, since otherwise GHC will complain about
                  -- the record wildcard pattern on a ctor with no arguments.

                    Hs.IdValue
                      Hs.DfValue
                        { name = "marshalInto",
                          params = [Hs.PVar "_raw", Hs.PLCtor dataCtorName []],
                          value = Hs.EApp (eStd_ "pure") [Hs.ETup []]
                        }
                  else
                    Hs.IdValue
                      Hs.DfValue
                        { name = "marshalInto",
                          params =
                            [Hs.PVar "raw_", Hs.PLRecordWildCard dataCtorName],
                          value =
                            Hs.EDo
                              (map (Hs.DoE . uncurry emitMarshalField) fields)
                              ( if hasUnion
                                  then
                                    Hs.EApp
                                      (egName ["C"] "marshalInto")
                                      [ Hs.EApp (egName ["GH"] "structUnion") [euName "raw_"],
                                        euName "union'"
                                      ]
                                  else Hs.EApp (eStd_ "pure") [Hs.ETup []]
                              )
                        }
              ]
          }
      ]
defineMarshal typeName typeParams AO.ParsedUnion {variants} =
  let tVars = toTVars typeParams
      typ = Hs.TApp (tgName ["GH"] "Which") [Hs.TApp (Hs.TLName typeName) tVars]
   in [ Hs.DcInstance
          { ctx = paramsContext tVars,
            typ =
              Hs.TApp
                (tgName ["C"] "Marshal")
                [typ, Hs.TApp (tgName ["C"] "Parsed") [typ]],
            defs =
              [ Hs.IdValue
                  Hs.DfValue
                    { name = "marshalInto",
                      params = [Hs.PVar "raw_", Hs.PVar "parsed_"],
                      value =
                        Hs.ECase (Hs.EVar "parsed_") $
                          [ ( Hs.PLCtor (Name.mkSub typeName name) $
                                case fieldLocType of
                                  C.VoidField -> []
                                  _ -> [Hs.PVar "arg_"],
                              emitMarshalVariant name fieldLocType
                            )
                            | (name, fieldLocType) <- variants
                          ]
                            ++ [ ( Hs.PLCtor (unknownVariant typeName) [Hs.PVar "tag_"],
                                   Hs.EApp
                                     (egName ["GH"] "encodeField")
                                     [ egName ["GH"] "unionField",
                                       Hs.EVar "tag_",
                                       unionStruct (euName "raw_")
                                     ]
                                 )
                               ]
                    }
              ]
          }
      ]

defineInterfaceServer thisMod typeName typeParams methods supers =
  let tVars = toTVars typeParams
      typ = Hs.TApp (Hs.TLName typeName) tVars
      clsName = Name.mkSub typeName "server_"
   in [ Hs.DcInstance
          { ctx = paramsContext tVars,
            typ = Hs.TApp (tgName ["GH"] "Export") [typ],
            defs =
              [ Hs.IdType $ Hs.TypeAlias "Server" [typ] $ Hs.TApp (Hs.TLName clsName) tVars,
                Hs.IdValue
                  Hs.DfValue
                    { name = "methodHandlerTree",
                      params = [Hs.PVar "_", Hs.PVar "s_"],
                      value =
                        Hs.EApp
                          (egName ["GH"] "MethodHandlerTree")
                          [ Hs.ETypeApp (egName ["C"] "typeId") [typ],
                            Hs.EList
                              [ Hs.EApp
                                  (egName ["GH"] "toUntypedMethodHandler")
                                  [ Hs.EApp
                                      ( Hs.ETypeApp
                                          (Hs.EVar (Name.renderUnQ (Name.valueName (Name.mkSub typeName methodName))))
                                          tVars
                                      )
                                      [Hs.EVar "s_"]
                                  ]
                                | AO.MethodInfo {methodName} <- methods
                              ],
                            Hs.EList
                              [ Hs.EApp
                                  (egName ["GH"] "methodHandlerTree")
                                  [ Hs.ETypeApp
                                      (egName ["GH"] "Proxy")
                                      [typeToType thisMod $ C.PtrType $ C.PtrInterface super],
                                    Hs.EVar "s_"
                                  ]
                                | super <- supers
                              ]
                          ]
                    }
              ]
          },
        Hs.DcClass
          { ctx =
              [ Hs.TApp
                  (tgName ["GH"] "Server")
                  [ typeToType thisMod $ C.PtrType $ C.PtrInterface super,
                    Hs.TVar "s_"
                  ]
                | super <- supers
              ],
            name = clsName,
            params = map (Name.UnQ . Name.typeVarName) typeParams ++ ["s_"],
            funDeps = [],
            decls =
              Hs.CdMinimal
                [ mkMethodName typeName methodName
                  | AO.MethodInfo {methodName} <- methods
                ]
                : concatMap (defineIfaceClassMethod thisMod typeName) methods
          }
      ]

defineIfaceClassMethod thisMod typeName AO.MethodInfo {methodName, paramType, resultType} =
  let mkType t = typeToType thisMod (C.CompositeType t)
      name = mkMethodName typeName methodName
   in [ Hs.CdValueDecl
          name
          ( Hs.TFn
              [ Hs.TVar "s_",
                Hs.TApp
                  (tgName ["GH"] "MethodHandler")
                  [ mkType paramType,
                    mkType resultType
                  ]
              ]
          ),
        Hs.CdValueDef
          Hs.DfValue
            { name,
              params = [Hs.PVar "_"],
              value = egName ["GH"] "methodUnimplemented"
            }
      ]

mkMethodName typeName methodName =
  Name.valueName (Name.mkSub typeName methodName)

emitMarshalField :: Name.UnQ -> C.FieldLocType AO.Brand Name.CapnpQ -> Hs.Exp
emitMarshalField name (C.HereField _) =
  Hs.EDo
    [ Hs.DoBind "group_" $
        Hs.EApp
          (egName ["GH"] "readField")
          [Hs.ELabel name, Hs.EVar "raw_"]
    ]
    (Hs.EApp (egName ["C"] "marshalInto") [Hs.EVar "group_", euName name])
emitMarshalField name _ =
  Hs.EApp
    (egName ["GH"] "encodeField")
    [ Hs.ELabel name,
      euName name,
      euName "raw_"
    ]

emitMarshalVariant :: Name.UnQ -> C.FieldLocType AO.Brand Name.CapnpQ -> Hs.Exp
emitMarshalVariant name (C.HereField _) =
  Hs.EDo
    [ Hs.DoBind "rawGroup_" $
        Hs.EApp
          (egName ["GH"] "initVariant")
          [ Hs.ELabel name,
            unionStruct (euName "raw_")
          ]
    ]
    (Hs.EApp (egName ["C"] "marshalInto") [euName "rawGroup_", euName "arg_"])
emitMarshalVariant name C.VoidField =
  Hs.EApp
    (egName ["GH"] "encodeVariant")
    [ Hs.ELabel name,
      Hs.ETup [],
      unionStruct (euName "raw_")
    ]
emitMarshalVariant name _ =
  Hs.EApp
    (egName ["GH"] "encodeVariant")
    [ Hs.ELabel name,
      euName "arg_",
      unionStruct (euName "raw_")
    ]

unionStruct :: Hs.Exp -> Hs.Exp
unionStruct e = Hs.EApp (egName ["GH"] "unionStruct") [e]