Raw.hs

-- Generate low-level accessors from type types in IR.
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Backends.Raw
    ( fmtModule
    ) where

import Data.Word

import Data.List                    (sortOn)
import Data.Monoid                  ((<>))
import Data.Ord                     (Down(..))
import Data.String                  (IsString(..))
import Text.PrettyPrint.Leijen.Text (hcat, vcat)
import Text.Printf                  (printf)

import qualified Data.Map.Strict              as M
import qualified Data.Text                    as T
import qualified Text.PrettyPrint.Leijen.Text as PP

import IR
import Util

import Backends.Common (dataFieldSize, fmtPrimWord)

indent = PP.indent 4

-- | Sort varaints by their tag, in decending order (with no tag at all being last).
sortVariants = sortOn (Down . variantTag)

fmtModule :: Module -> [(FilePath, PP.Doc)]
fmtModule thisMod@Module{modName=Namespace modNameParts,..} =
    [ ( T.unpack $ mintercalate "/" humanParts <> ".hs"
      , mainContent
      )
    , ( printf "Capnp/ById/X%x.hs" modId
      , vcat
        [ "{-# OPTIONS_GHC -Wno-unused-imports #-}"
        , "{- |"
        , hcat [ "Module: ", machineMod ]
        , hcat [ "Description: machine-addressable alias for '", humanMod, "'." ]
        , "-}"
        , hcat [ "module ", machineMod, " (module ", humanMod, ") where" ]
        , hcat [ "import ", humanMod ]
        ]
      )
    ] where
  machineMod = fromString (printf "Capnp.ById.X%x" modId)
  humanMod = fmtModRef $ FullyQualified $ Namespace humanParts
  humanParts = "Capnp":modNameParts
  modFileText = PP.textStrict modFile
  mainContent = vcat
    [ "{-# OPTIONS_GHC -Wno-unused-imports #-}"
    , "{-# LANGUAGE FlexibleContexts #-}"
    , "{-# LANGUAGE FlexibleInstances #-}"
    , "{-# LANGUAGE MultiParamTypeClasses #-}"
    , "{-# LANGUAGE TypeFamilies #-}"
    , "{-# LANGUAGE DeriveGeneric #-}"
    , "{- |"
    , "Module: " <> humanMod
    , "Description: Low-level generated module for " <> modFileText
    , ""
    , "This module is the generated code for " <> modFileText <> ", for the"
    , "low-level api."
    , "-}"
    , "module " <> humanMod <> " where"
    , ""
    , "-- Code generated by capnpc-haskell. DO NOT EDIT."
    , "-- Generated from schema file: " <> modFileText
    , ""
    , "import Data.Int"
    , "import Data.Word"
    , ""
    , "import GHC.Generics (Generic)"
    , ""
    , "import Data.Capnp.Bits (Word1)"
    , ""
    , "import qualified Data.Bits"
    , "import qualified Data.Maybe"
    -- The trailing ' is to avoid possible name collisions:
    , "import qualified Data.Capnp.Classes as C'"
    , "import qualified Data.Capnp.Basics as B'"
    , "import qualified Data.Capnp.GenHelpers as H'"
    , "import qualified Data.Capnp.TraversalLimit as TL'"
    , "import qualified Data.Capnp.Untyped as U'"
    , "import qualified Data.Capnp.Message as M'"
    , ""
    , vcat $ map fmtImport modImports
    , ""
    , vcat $ map (fmtDecl thisMod) (M.toList modDecls)
    ]

fmtModRef :: ModuleRef -> PP.Doc
fmtModRef (ByCapnpId id) = fromString $ printf "Capnp.ById.X%x" id
fmtModRef (FullyQualified (Namespace ns)) = mintercalate "." (map PP.textStrict ns)

fmtImport :: Import -> PP.Doc
fmtImport (Import ref) = "import qualified " <> fmtModRef ref

-- | format the IsPtr instance for a list of the struct type with
-- the given name.
fmtStructListIsPtr :: PP.Doc -> PP.Doc
fmtStructListIsPtr nameText = vcat
    [ hcat [ "instance C'.IsPtr msg (B'.List msg (", nameText, " msg)) where" ]
    , indent $ vcat
        [ hcat [ "fromPtr msg ptr = List_", nameText, " <$> C'.fromPtr msg ptr" ]
        , hcat [ "toPtr (List_", nameText, " l) = C'.toPtr l" ]
        ]
    ]

-- | Generate declarations common to all types which are represented
-- by 'Untyped.Struct'.
--
-- parameters:
--
-- * thisMod - the module that we are generating.
-- * name    - the name of the type.
-- * dataSz  - the size of the data section, in words.
-- * ptrSz   - the size of the pointer section.
fmtNewtypeStruct :: Module -> Name -> Word16 -> Word16 -> PP.Doc
fmtNewtypeStruct thisMod name dataSz ptrSz =
    let typeCon = fmtName thisMod name
        dataCon = typeCon <> "_newtype_"
    in vcat
        [ hcat [ "newtype ", typeCon, " msg = ", dataCon, " (U'.Struct msg)" ]

        , hcat [ "instance C'.FromStruct msg (", typeCon, " msg) where" ]
        , indent $ vcat
            [ hcat [ "fromStruct = pure . ", dataCon ]
            ]

        , hcat [ "instance C'.ToStruct msg (", typeCon, " msg) where" ]
        , indent $ vcat
            [ hcat [ "toStruct (", dataCon, " struct) = struct" ]
            ]

        , hcat [ "instance C'.IsPtr msg (", typeCon, " msg) where" ]
        , indent $ vcat
            [ hcat [ "fromPtr msg ptr = ", dataCon, " <$> C'.fromPtr msg ptr" ]
            , hcat [ "toPtr (", dataCon, " struct) = C'.toPtr struct" ]
            ]
        , fmtStructListElem typeCon

        , hcat [ "instance B'.MutListElem s (", typeCon, " (M'.MutMsg s)) where" ]
        , indent $ vcat
            [ hcat [ "setIndex (", dataCon, " elt) i (List_", typeCon, " l) = U'.setIndex elt i l" ]
            , hcat
                [ "newList msg len = List_", typeCon, " <$> U'.allocCompositeList msg "
                , fromString (show dataSz), " "
                , fromString (show ptrSz), " len"
                ]
            ]

        , hcat [ "instance U'.HasMessage (", typeCon, " msg) msg where" ]
        , indent $ vcat
            [ hcat [ "message (", dataCon, " struct) = U'.message struct" ]
            ]

        , hcat [ "instance U'.MessageDefault (", typeCon, " msg) msg where" ]
        , indent $ vcat
            [ hcat [ "messageDefault = ", dataCon, " . U'.messageDefault" ]
            ]

        , hcat [ "instance C'.Allocate s (", typeCon, " (M'.MutMsg s)) where" ]
        , indent $ vcat
            [ hcat
                [ "new msg = ", dataCon , " <$> U'.allocStruct msg "
                , fromString (show dataSz), " "
                , fromString (show ptrSz)
                ]
            ]
        , fmtStructListIsPtr typeCon
        ]

-- | Generate an instance of ListElem for a struct type. The parameter is the name of
-- the type constructor.
fmtStructListElem :: PP.Doc -> PP.Doc
fmtStructListElem nameText = vcat
    [ hcat [ "instance B'.ListElem msg (", nameText, " msg) where" ]
    , indent $ vcat
        [ hcat [ "newtype List msg (", nameText, " msg) = List_", nameText, " (U'.ListOf msg (U'.Struct msg))" ]
        , hcat [ "length (List_", nameText, " l) = U'.length l" ]
        , hcat [ "index i (List_", nameText, " l) = U'.index i l >>= ", fmtRestrictedFromStruct nameText ]
        ]
    ]

-- | Output an expression equivalent to fromStruct, but restricted to the type
-- with the given type constructor (which must have kind * -> *).
fmtRestrictedFromStruct :: PP.Doc -> PP.Doc
fmtRestrictedFromStruct nameText = hcat
    [ "(let {"
    , "go :: U'.ReadCtx m msg => U'.Struct msg -> m (", nameText, " msg); "
    , "go = C'.fromStruct"
    , "} in go)"
    ]

-- | Generate a call to 'H'.getWordField' based on a 'DataLoc'.
-- The first argument is an expression for the struct.
fmtGetWordField :: PP.Doc -> DataLoc -> PP.Doc
fmtGetWordField struct DataLoc{..} = mintercalate " "
    [ " H'.getWordField"
    , struct
    , fromString (show dataIdx)
    , fromString (show dataOff)
    , fromString (show dataDef)
    ]

-- | @'fmtSetWordField' struct value loc@ is like 'fmtGetWordField', except that
-- it generates a call to 'H'.setWordField'. The extra value parameter corresponds
-- to the extra parameter in 'H'.setWordField'.
fmtSetWordField :: PP.Doc -> PP.Doc -> DataLoc -> PP.Doc
fmtSetWordField struct value DataLoc{..} = mintercalate " "
    [ "H'.setWordField"
    , struct
    , value
    , fromString (show dataIdx)
    , fromString (show dataOff)
    , fromString (show dataDef)
    ]

-- | Format the various accessors @(set_*, get_*, has_*, new_*)@ for a field.
-- .
-- Parameters (in order):
-- .
-- * @thisMod@: the module we're generating.
-- * @typeName@: the name of the type to which the field belongs.
-- * @variantName@: the name of the variant of @typeName@.
-- * @field@: the field to format.
fmtFieldAccessor :: Module -> Name -> Name -> Field -> PP.Doc
fmtFieldAccessor thisMod typeName variantName Field{..} = vcat
    [ fmtGetter
    , fmtHas
    , fmtSetter
    , fmtNew thisMod accessorName typeCon fieldLocType
    ]
  where
    accessorName prefix = fmtName thisMod $ prefixName prefix (subName variantName fieldName)

    getName = accessorName "get_"
    hasName = accessorName "has_"
    setName = accessorName "set_"
    newName = accessorName "new_"

    typeCon = fmtName thisMod typeName
    dataCon = typeCon <> "_newtype_"

    fmtGetter =
        let getType fieldType = typeCon <> " msg -> m " <> fmtType thisMod "msg" fieldType
            typeAnnotation fieldType =
                hcat [ getName, " :: U'.ReadCtx m msg => ", getType fieldType ]
            getDef def = hcat [ getName, " (", dataCon, " struct) =", def ]
        in case fieldLocType of
            DataField loc ty -> vcat
                [ typeAnnotation (WordType ty)
                , getDef $ fmtGetWordField "struct" loc
                ]
            PtrField idx ty -> vcat
                [ typeAnnotation (PtrType ty)
                , getDef $ PP.line <> indent (vcat
                    [ hcat [ "U'.getPtr ", fromString (show idx), " struct" ]
                    , hcat [ ">>= C'.fromPtr (U'.message struct)" ]
                    ])
                ]
            HereField ty -> vcat
                [ typeAnnotation (CompositeType ty)
                , getDef " C'.fromStruct struct"
                ]
            VoidField -> vcat
                [ typeAnnotation VoidType
                , getDef " Data.Capnp.TraversalLimit.invoice 1 >> pure ()"
                ]
    fmtHas =
        let hasType = typeCon <> " msg -> m Bool"
        in vcat
        [ hcat [ hasName, " :: U'.ReadCtx m msg => ", hasType ]
        , hcat
            [ hasName, "(", dataCon, " struct) = ", case fieldLocType of
                DataField DataLoc{dataIdx} _ ->
                    "pure $ " <> fromString (show dataIdx) <> " < U'.length (U'.dataSection struct)"
                PtrField idx _ ->
                    "Data.Maybe.isJust <$> U'.getPtr " <> fromString (show idx) <> " struct"
                HereField _ -> "pure True"
                VoidField -> "pure True"
            ]
        ]
    fmtSetter =
        let setType fieldType = typeCon <> " (M'.MutMsg s) -> " <> fmtType thisMod "(M'.MutMsg s)" fieldType <> " -> m ()"
            typeAnnotation fieldType = setName <> " :: U'.RWCtx m s => " <> setType fieldType
        in
        case fieldLocType of
            DataField loc@DataLoc{..} ty -> vcat
                [ typeAnnotation (WordType ty)
                , hcat
                    [ setName, " (", dataCon, " struct) value = "
                    , fmtSetWordField
                        "struct"
                        ("(fromIntegral (C'.toWord value) :: Word" <> fromString (show $ dataFieldSize ty) <> ")")
                        loc
                    ]
                ]
            VoidField -> vcat
                [ typeAnnotation VoidType
                , setName <> " _ = pure ()"
                ]
            PtrField idx ty -> vcat
                [ typeAnnotation (PtrType ty)
                , hcat
                    [ setName, " (", dataCon, " struct) value = "
                    , "U'.setPtr (C'.toPtr value) ", fromString (show idx), " struct"
                    ]
                ]
            HereField _ ->
                -- We don't generate setters for these fields; instead, the
                -- user should call the getter and then modify the child in-place.
                ""

-- | format a @new_*@ function for a field.
-- .
-- Parameters (in order):
-- .
-- * @thisMod@: The module we're generating.
-- * @accessorName@: function getting the accessor for a specific prefix;
--   takes an argument that is @"set_"@, @"get_"@, etc.
-- * @typeCon@: The name of the type constructor for the type owning the
--   field.
-- * @fieldLocType@: the field location and type.
fmtNew thisMod accessorName typeCon fieldLocType =
    case fieldLocType of
        PtrField _ fieldType ->
            let newType = hcat
                    [ typeCon
                    , " (M'.MutMsg s) -> m ("
                    , fmtType thisMod "(M'.MutMsg s)" (PtrType fieldType)
                    , ")"
                    ]
            in case fieldType of
                ListOf _ ->
                    fmtNewListLike newType "C'.newList"
                PrimPtr PrimText ->
                    fmtNewListLike newType "B'.newText"
                PrimPtr PrimData ->
                    fmtNewListLike newType "B'.newData"
                PrimPtr (PrimAnyPtr _) ->
                    ""
                PtrComposite _ -> vcat
                    [ hcat [ newName, " :: U'.RWCtx m s => ", newType ]
                    , hcat [ newName, " struct = do" ]
                    , indent $ vcat
                        [ hcat [ "result <- C'.new (U'.message struct)" ]
                        , hcat [ setName, " struct result" ]
                        , "pure result"
                        ]
                    ]
        _ ->
            ""
  where
    newName = accessorName "new_"
    setName = accessorName "set_"

    fmtNewListLike newType allocFn = vcat
        [ hcat [ newName, " :: U'.RWCtx m s => Int -> ", newType ]
        , hcat [ newName, " len struct = do" ]
        , indent $ vcat
            [ hcat [ "result <- ", allocFn, " (U'.message struct) len" ]
            , hcat [ setName, " struct result" ]
            , "pure result"
            ]
        ]


-- Generate setters for union variants, plus new_* functions where the argument
-- is a pointer type.
fmtUnionSetter :: Module -> Name -> DataLoc -> Variant -> PP.Doc
fmtUnionSetter thisMod parentType tagLoc Variant{..} = go variantTag
  where
    accessorName prefix = prefix <> fmtName thisMod variantName
    setName = "set_" <> fmtName thisMod variantName
    parentTypeCon = fmtName thisMod parentType
    parentDataCon = parentTypeCon <> "_newtype_"
    fmtSetTag = fmtSetWordField "struct"
        (hcat
            [ "("
            , case variantTag of
                Just tagValue ->
                    fromString (show tagValue)
                Nothing ->
                    "tagValue"
            , " :: Word16)"
            ])
        tagLoc
    go Nothing = vcat
        -- this is the unknown' variant; we just accept the tag as an argument.
        [ hcat [ setName, " :: U'.RWCtx m s => ", parentTypeCon, " (M'.MutMsg s) -> Word16 -> m ()" ]
        , hcat [ setName, "(", parentDataCon, " struct) tagValue = ", fmtSetTag ]
        ]
    go (Just _) = case variantParams of
        Record _ ->
            -- Variant is a group; we return a reference to the group so the user can
            -- modify it.
            let childTypeCon = fmtName thisMod (subName variantName "group'")
                childDataCon = childTypeCon <> "_newtype_"
            in vcat
            [ hcat
                [ setName, " :: U'.RWCtx m s => ", parentTypeCon, " (M'.MutMsg s) -> "
                , "m (", childTypeCon, " (M'.MutMsg s))"
                ]
            , hcat [ setName, " (", parentDataCon, " struct) = do" ]
            , indent $ vcat
                [ fmtSetTag
                , hcat [ "pure $ ", childDataCon, " struct" ]
                ]
            ]
        Unnamed _ (DataField loc typ) -> vcat
            [ hcat
                [ setName, " :: U'.RWCtx m s => ", parentTypeCon, " (M'.MutMsg s) -> "
                , fmtType thisMod "(M'.MutMsg s)" (WordType typ), " -> m ()"
                ]
            , hcat [ setName, " (", parentDataCon, " struct) value = do" ]
            , indent $ vcat
                [ fmtSetTag
                , let size = dataFieldSize typ
                  in fmtSetWordField "struct"
                        ("(fromIntegral (C'.toWord value) :: Word" <> fromString (show size) <> ")")
                        loc
                ]
            ]
        Unnamed _ fieldLocType@(PtrField index typ) -> vcat
            [ hcat
                [ setName, " :: U'.RWCtx m s => ", parentTypeCon, " (M'.MutMsg s) -> "
                , fmtType thisMod "(M'.MutMsg s)" (PtrType typ), " -> m ()"
                ]
            , hcat [ setName, "(", parentDataCon, " struct) value = do" ]
            , indent $ vcat
                [ fmtSetTag
                , hcat [ "U'.setPtr (C'.toPtr value) ", fromString (show index), " struct" ]
                ]

            -- Also generate a new_* function.
            , fmtNew thisMod accessorName parentTypeCon fieldLocType
            ]
        Unnamed _ VoidField -> vcat
            [ hcat [ setName, " :: U'.RWCtx m s => ", parentTypeCon, " (M'.MutMsg s) -> m ()" ]
            , hcat [ setName, " (", parentDataCon, " struct) = ", fmtSetTag ]
            ]
        Unnamed _ (HereField typ) -> vcat
            [ hcat
                [ setName, " :: U'.RWCtx m s => ", parentTypeCon, " (M'.MutMsg s) -> "
                , "m (", fmtType thisMod " (M'.MutMsg s)" (CompositeType typ), ")"
                ]
            , hcat [ setName, "(", parentDataCon, " struct) value = do" ]
            , indent $ vcat
                [ fmtSetTag
                , "fromStruct struct"
                ]
            ]

fmtDecl :: Module -> (Name, Decl) -> PP.Doc
fmtDecl thisMod (name, DeclDef d)   = fmtDataDef thisMod name d
fmtDecl thisMod (name, DeclConst c) = fmtConst thisMod name c

-- | Format a constant declaration.
fmtConst :: Module -> Name -> Const -> PP.Doc
fmtConst thisMod name value =
    let nameText = fmtName thisMod (valueName name)
    in case value of
        WordConst{wordType,wordValue} -> vcat
            [ hcat
                [ nameText, " :: "
                , case wordType of
                    PrimWord ty     -> fmtPrimWord ty
                    EnumType tyName -> fmtName thisMod tyName
                ]
            , hcat [ nameText, " = C'.fromWord ", fromString (show wordValue) ]
            ]
        VoidConst -> vcat
            [ hcat [ nameText, " :: ()" ]
            , hcat [ nameText, " = ()" ]
            ]

fmtDataDef :: Module -> Name -> DataDef -> PP.Doc
fmtDataDef thisMod dataName DataDef{dataVariants=[Variant{..}], dataCerialType=CTyStruct dataSz ptrSz, ..} =
    vcat
        [ fmtNewtypeStruct thisMod dataName dataSz ptrSz
        , case variantParams of
            Record fields ->
                vcat $ map (fmtFieldAccessor thisMod dataName variantName) fields
            _ -> ""
        ]
fmtDataDef thisMod dataName DataDef{dataCerialType=CTyStruct dataSz ptrSz,dataTagLoc=Just tagLoc,dataVariants} =
    let unionName = subName dataName ""
        unionNameText = fmtName thisMod unionName
    in vcat
        [ fmtNewtypeStruct thisMod dataName dataSz ptrSz
        , hcat [ "data ", unionNameText, " msg =" ]
        , indent $ vcat $ PP.punctuate " |" (map fmtDataVariant dataVariants)
        , fmtFieldAccessor thisMod dataName dataName Field
            { fieldName = ""
            , fieldLocType = HereField $ StructType unionName []
            }
        , vcat $ map (fmtUnionSetter thisMod dataName tagLoc) dataVariants
        -- Generate auxiliary newtype definitions for group fields:
        , vcat $ map fmtVariantAuxNewtype dataVariants
        , hcat [ "instance C'.FromStruct msg (", unionNameText, " msg) where" ]
        , indent $ vcat
            [ "fromStruct struct = do"
            , indent $ vcat
                [ hcat [ "tag <- ", fmtGetWordField "struct" tagLoc ]
                , "case tag of"
                , indent $ vcat $ map fmtVariantCase $ sortVariants dataVariants
                ]
            ]
        ]
  where
    fmtDataVariant Variant{..} = fmtName thisMod variantName <>
        case variantParams of
            Record _   -> " (" <> fmtName thisMod (subName variantName "group' msg)")
            Unnamed VoidType _ -> ""
            Unnamed ty _ -> " " <> fmtType thisMod "msg" ty
    fmtVariantCase Variant{..} =
        let nameText = fmtName thisMod variantName
        in case variantTag of
                Just tag ->
                    hcat
                        [ fromString (show tag), " -> "
                        , case variantParams of
                            Record _  -> nameText <> " <$> C'.fromStruct struct"
                            Unnamed _ (HereField _) -> nameText <> " <$> C'.fromStruct struct"
                            Unnamed _ VoidField ->
                                "pure " <> nameText
                            Unnamed _ (DataField loc _) ->
                                nameText <> " <$> " <> fmtGetWordField "struct" loc
                            Unnamed _ (PtrField idx _) -> hcat
                                [ nameText," <$> "
                                , " (U'.getPtr ", fromString (show idx), " struct"
                                , " >>= C'.fromPtr (U'.message struct))"
                                ]
                        ]
                Nothing ->
                    "_ -> pure $ " <> nameText <> " tag"
    fmtVariantAuxNewtype Variant{variantName, variantParams=Record fields} =
        let typeName = subName variantName "group'"
        in vcat
            [ fmtNewtypeStruct thisMod typeName dataSz ptrSz
            , vcat $ map (fmtFieldAccessor thisMod typeName variantName) fields
            ]
    fmtVariantAuxNewtype _ = ""
fmtDataDef thisMod dataName DataDef{dataCerialType=CTyEnum,..} =
    let typeName = fmtName thisMod dataName
    in vcat
        [ hcat [ "data ", typeName, " =" ]
        , indent $ vcat
            [ vcat $ PP.punctuate " |" $ map fmtEnumVariant dataVariants
            , "deriving(Show, Read, Eq, Generic)"
            ]
        -- Generate an Enum instance. This is a trivial wrapper around the
        -- IsWord instance, below.
        , hcat [ "instance Enum ", typeName, " where" ]
        , indent $ vcat
            [ "toEnum = C'.fromWord . fromIntegral"
            , "fromEnum = fromIntegral . C'.toWord"
            ]
        -- Generate an IsWord instance.
        , hcat [ "instance C'.IsWord ", typeName, " where" ]
        , indent $ vcat
            [ "fromWord n = go (fromIntegral n :: Word16) where"
            , indent $ vcat $
                map (("go "     <>) . fmtEnumFromWordCase) $ sortVariants dataVariants
            , vcat $
                map (("toWord " <>) .   fmtEnumToWordCase) $ sortVariants dataVariants
            ]
        , hcat [ "instance B'.ListElem msg ", typeName, " where" ]
        , indent $ vcat
            [ hcat [ "newtype List msg ", typeName, " = List_", typeName, " (U'.ListOf msg Word16)" ]
            , hcat [ "length (List_", typeName, " l) = U'.length l" ]
            , hcat [ "index i (List_", typeName, " l) = (C'.fromWord . fromIntegral) <$> U'.index i l" ]
            ]
        , hcat [ "instance B'.MutListElem s ", typeName, " where" ]
        , indent $ vcat
            [ hcat [ "setIndex elt i (List_", typeName, " l) = U'.setIndex (fromIntegral $ C'.toWord elt) i l" ]
            , hcat [ "newList msg size = List_", typeName, " <$> U'.allocList16 msg size" ]
            ]
        , hcat [ "instance C'.IsPtr msg (B'.List msg ", typeName, ") where" ]
        , indent $ vcat
            [ hcat [ "fromPtr msg ptr = List_", typeName, " <$> C'.fromPtr msg ptr" ]
            , hcat [ "toPtr (List_", typeName, " l) = C'.toPtr l" ]
            ]
        ]
  where
    -- | Format a data constructor in the definition of a data type for an enum.
    fmtEnumVariant Variant{variantName,variantParams=Unnamed VoidType _,variantTag=Just _} =
        fmtName thisMod variantName
    fmtEnumVariant Variant{variantName,variantParams=Unnamed ty _, variantTag=Nothing} =
        fmtName thisMod variantName <> " " <> fmtType thisMod "msg" ty
    fmtEnumVariant variant =
        error $ "Unexpected variant for enum: " ++ show variant
    -- | Format an equation in an enum's IsWord.fromWord implementation.
    fmtEnumFromWordCase Variant{variantTag=Just tag,variantName} =
        -- For the tags we know about:
        fromString (show tag) <> " = " <> fmtName thisMod variantName
    fmtEnumFromWordCase Variant{variantTag=Nothing,variantName} =
        -- For other tags:
        "tag = " <> fmtName thisMod variantName <> " (fromIntegral tag)"
    -- | Format an equation in an enum's IsWord.toWord implementation.
    fmtEnumToWordCase Variant{variantTag=Just tag,variantName} =
        fmtName thisMod variantName <> " = " <> fromString (show tag)
    fmtEnumToWordCase Variant{variantTag=Nothing,variantName} =
        "(" <> fmtName thisMod variantName <> " tag) = fromIntegral tag"
fmtDataDef _ dataName dataDef =
    error $ "Unexpected data definition: " ++ show (dataName, dataDef)

-- | @'fmtType ident msg ty@ formats the type @ty@ from module @ident@,
-- using @msg@ as the message parameter, if any.
fmtType :: Module -> PP.Doc -> Type -> PP.Doc
fmtType thisMod msg = \case
    WordType (EnumType name) ->
        fmtName thisMod name
    WordType (PrimWord ty) ->
        fmtPrimWord ty
    VoidType ->
        "()"
    PtrType (ListOf eltType) ->
        "(B'.List " <> msg <> " " <> fmtType thisMod msg eltType <> ")"
    PtrType (PrimPtr PrimText) ->
        "(B'.Text " <> msg <> ")"
    PtrType (PrimPtr PrimData) ->
        "(B'.Data " <> msg <> ")"
    PtrType (PrimPtr (PrimAnyPtr anyPtr)) ->
        "(Maybe " <> fmtAnyPtr msg anyPtr <> ")"
    PtrType (PtrComposite ty) ->
        fmtType thisMod msg (CompositeType ty)
    CompositeType (StructType name params) -> hcat
        [ "("
        , fmtName thisMod name
        , " "
        , mintercalate " " $ msg : map (fmtType thisMod msg) params
        , ")"
        ]

fmtAnyPtr :: PP.Doc -> AnyPtr -> PP.Doc
fmtAnyPtr msg Struct = "(U'.Struct " <> msg <> ")"
fmtAnyPtr msg List   = "(U'.List " <> msg <> ")"
fmtAnyPtr _ Cap      = "Word32"
fmtAnyPtr msg Ptr    = "(U'.Ptr " <> msg <> ")"

fmtName :: Module -> Name -> PP.Doc
fmtName Module{modId=thisMod} Name{nameModule, nameLocalNS=Namespace parts, nameUnqualified=localName} =
    modPrefix <> mintercalate "'" (map PP.textStrict $ parts <> [localName])
  where
    modPrefix = case nameModule of
        ByCapnpId id                  | id == thisMod -> ""
        FullyQualified (Namespace []) -> ""
        _                             -> fmtModRef nameModule <> "."