Deftype.hs

{-# LANGUAGE NamedFieldPuns #-}

module Deftype
  ( moduleForDeftype,
    moduleForDeftypeInContext,
    bindingsForRegisteredType,
    fieldArg,
    memberArg,
  )
where

import Concretize
import Context
import Data.Maybe
import Env (addListOfBindings, new)
import Info
import Managed
import Obj
import StructUtils
import Template
import TemplateGenerator as TG
import ToTemplate
import qualified TypeCandidate as TC
import TypeError
import TypePredicates
import Types
import TypesToC
import Util
import Validate

{-# ANN module "HLint: ignore Reduce duplication" #-}

moduleForDeftypeInContext :: Context -> String -> [Ty] -> [XObj] -> Maybe Info -> Either TypeError (String, XObj, [XObj])
moduleForDeftypeInContext ctx name vars members info =
  let global = contextGlobalEnv ctx
      types = contextTypeEnv ctx
      path = contextPath ctx
      inner = either (const Nothing) Just (innermostModuleEnv ctx)
      previous =
        either
          (const Nothing)
          Just
          ( (lookupBinderInInternalEnv ctx (SymPath path name))
              <> (lookupBinderInGlobalEnv ctx (SymPath path name))
                >>= \b ->
                  replaceLeft
                    (NotFoundGlobal (SymPath path name))
                    ( case binderXObj b of
                        XObj (Mod ev et) _ _ -> Right (ev, et)
                        _ -> Left "Non module"
                    )
          )
   in moduleForDeftype inner types global path name vars members info previous

-- | This function creates a "Type Module" with the same name as the type being defined.
--   A type module provides a namespace for all the functions that area automatically
--   generated by a deftype.
moduleForDeftype :: Maybe Env -> TypeEnv -> Env -> [String] -> String -> [Ty] -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i existingEnv =
  let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
      moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
      initmembers = case rest of
        -- ANSI C does not allow empty structs. We add a dummy member here to account for this.
        -- Note that we *don't* add this member for external types--we leave those definitions up to the user.
        -- The corresponding field is emitted for the struct definition in Emit.hs
        [(XObj (Arr []) ii t)] -> [(XObj (Arr [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)]) ii t)]
        _ -> rest
   in do
        let mems = case initmembers of
              [(XObj (Arr ms) _ _)] -> ms
              _ -> []
        -- Check that this is a valid type definition.
        candidate <- TC.mkStructCandidate typeName typeVariables typeEnv env mems pathStrings
        validateType candidate
        -- Generate standard function bindings for the type.
        (funcs, deps) <- generateTypeBindings candidate
        -- Add the type and bindings to the environment.
        let moduleEnvWithBindings = addListOfBindings moduleValueEnv funcs
            typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
        pure (typeName, typeModuleXObj, deps)

-- | Will generate getters/setters/updaters when registering EXTERNAL types.
-- | i.e. (register-type VRUnicornData [hp Int, magic Float])
-- | TODO: Remove duplication shared by moduleForDeftype-function.
bindingsForRegisteredType :: TypeEnv -> Env -> [String] -> String -> [XObj] -> Maybe Info -> Maybe (Env, TypeEnv) -> Either TypeError (String, XObj, [XObj])
bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
  let moduleValueEnv = fromMaybe (new (Just env) (Just typeName)) (fmap fst existingEnv)
      moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
   in do
        let mems = case rest of
              [(XObj (Arr ms) _ _)] -> ms
              _ -> []
        -- Check that this is a valid type definition.
        candidate <- TC.mkStructCandidate typeName [] typeEnv env mems pathStrings
        validateType candidate
        -- Generate function bindings for the registered type.
        (binders, deps) <- templatesForMembers candidate
        okInit <- binderForInit candidate
        (okStr, strDeps) <- binderForStrOrPrn "str" candidate
        (okPrn, _) <- binderForStrOrPrn "prn" candidate
        -- Add the type and bindings to the environment.
        let moduleEnvWithBindings = addListOfBindings moduleValueEnv (okInit : okStr : okPrn : binders)
            typeModuleXObj = XObj (Mod moduleEnvWithBindings moduleTypeEnv) i (Just ModuleTy)
        pure (typeName, typeModuleXObj, deps ++ strDeps)

--------------------------------------------------------------------------------
-- Binding creators

-- | Generate the standard set of functions for a new type.
generateTypeBindings :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj])
generateTypeBindings candidate =
  do
    (okMembers, membersDeps) <- templatesForMembers candidate
    okInit <- binderForInit candidate
    (okStr, strDeps) <- binderForStrOrPrn "str" candidate
    (okPrn, _) <- binderForStrOrPrn "prn" candidate
    (okDelete, deleteDeps) <- binderForDelete candidate
    (okCopy, copyDeps) <- binderForCopy candidate
    pure
      ( (okInit : okStr : okPrn : okDelete : okCopy : okMembers),
        (deleteDeps ++ membersDeps ++ copyDeps ++ strDeps)
      )

-- | Generate all the templates for ALL the member variables in a deftype declaration.
templatesForMembers :: TC.TypeCandidate -> Either TypeError ([(String, Binder)], [XObj])
templatesForMembers candidate =
  let bindersAndDeps = concatMap (templatesForSingleMember candidate) (TC.getFields candidate)
   in Right (map fst bindersAndDeps, concatMap snd bindersAndDeps)

-- | Generate the templates for a single member in a deftype declaration.
templatesForSingleMember :: TC.TypeCandidate -> TC.TypeField -> [((String, Binder), [XObj])]
templatesForSingleMember _ (TC.StructField "__dummy" _) = []
templatesForSingleMember candidate field@(TC.StructField _ t) =
  case t of
    -- Unit member types are special since we do not represent them in emitted c.
    -- Instead, members of type Unit are executed for their side effects and silently omitted
    -- from the produced C structs.
    UnitTy ->
      binders
        (FuncTy [RefTy p (VarTy "q")] UnitTy StaticLifetimeTy)
        (FuncTy [p, t] p StaticLifetimeTy)
        (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
        (FuncTy [p, RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
    _ ->
      binders
        (FuncTy [RefTy p (VarTy "q")] (RefTy t (VarTy "q")) StaticLifetimeTy)
        (FuncTy [p, t] p StaticLifetimeTy)
        (FuncTy [RefTy p (VarTy "q"), t] UnitTy StaticLifetimeTy)
        (FuncTy [p, RefTy (FuncTy [t] t (VarTy "fq")) (VarTy "q")] p StaticLifetimeTy)
  where
    p = TC.toType candidate
    memberName = TC.fieldName field
    binders getterSig setterSig mutatorSig updaterSig =
      [ getter getterSig,
        setter setterSig,
        mutator mutatorSig,
        updater updaterSig
      ]

    getter :: Ty -> ((String, Binder), [XObj])
    getter sig =
      let doc = "gets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`."
          binderT = sig
          binderP = SymPath (TC.getFullPath candidate) (TC.fieldName field)
          temp = TG.generateConcreteFieldTemplate candidate field getterGenerator
       in instanceBinderWithDeps binderP binderT temp doc

    setter :: Ty -> ((String, Binder), [XObj])
    setter sig =
      let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "`."
          binderT = sig
          binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field))
          concrete = (TG.generateConcreteFieldTemplate candidate field setterGenerator)
          generic = (TG.generateGenericFieldTemplate candidate field setterGenerator)
       in if isTypeGeneric t
            then (defineTypeParameterizedTemplate generic binderP binderT doc, [])
            else instanceBinderWithDeps binderP binderT concrete doc

    mutator :: Ty -> ((String, Binder), [XObj])
    mutator sig =
      let doc = "sets the `" ++ (TC.fieldName field) ++ "` property of a `" ++ (TC.getName candidate) ++ "` in place."
          binderT = sig
          binderP = SymPath (TC.getFullPath candidate) ("set-" ++ (TC.fieldName field) ++ "!")
          concrete = (TG.generateConcreteFieldTemplate candidate field mutatorGenerator)
          generic = (TG.generateGenericFieldTemplate candidate field mutatorGenerator)
       in if isTypeGeneric t
            then (defineTypeParameterizedTemplate generic binderP binderT doc, [])
            else instanceBinderWithDeps binderP binderT concrete doc

    updater :: Ty -> ((String, Binder), [XObj])
    updater sig =
      let doc = "updates the `" ++ memberName ++ "` property of a `" ++ show p ++ "` using a function `f`."
          binderT = sig
          binderP = SymPath (TC.getFullPath candidate) ("update-" ++ (TC.fieldName field))
          temp = TG.generateConcreteFieldTemplate candidate field updateGenerator
       in instanceBinderWithDeps binderP binderT temp doc
templatesForSingleMember _ _ = error "templatesforsinglemember"

-- | Helper function to create the binder for the 'init' template.
binderForInit :: TC.TypeCandidate -> Either TypeError (String, Binder)
binderForInit candidate =
  -- Remove the __dummy field from the members array to ensure we can call the initializer with no arguments.
  -- See the implementation of moduleForDeftype for more details.
  let nodummy = remove ((== "__dummy") . TC.fieldName) (TC.getFields candidate)
      doc = "creates a `" ++ (TC.getName candidate) ++ "`."
      binderP = (SymPath (TC.getFullPath candidate) "init")
      binderT = (FuncTy (concatMap TC.fieldTypes nodummy) (TC.toType candidate) StaticLifetimeTy)
      gen = (initGenerator StackAlloc)
   in if isTypeGeneric (TC.toType candidate)
        then Right (defineTypeParameterizedTemplate (generateGenericTypeTemplate candidate gen) binderP binderT doc)
        else Right (instanceBinder binderP binderT (generateConcreteTypeTemplate candidate gen) doc)

-- | Helper function to create the binder for the 'str' template.
binderForStrOrPrn :: String -> TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj])
binderForStrOrPrn strOrPrn candidate =
  let binderP = SymPath (TC.getFullPath candidate) strOrPrn
      binderT = (FuncTy [RefTy (TC.toType candidate) (VarTy "q")] StringTy StaticLifetimeTy)
      doc = "converts a `" ++ TC.getName candidate ++ "` to a string."
   in if isTypeGeneric (TC.toType candidate)
        then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate strGenerator) binderP binderT doc, [])
        else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate strGenerator) doc

-- | Helper function to create the binder for the 'delete' template.
binderForDelete :: TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj])
binderForDelete candidate =
  let doc = "deletes a `" ++ TC.getName candidate ++ "`. Should usually not be called manually."
      binderP = SymPath (TC.getFullPath candidate) "delete"
      binderT = FuncTy [(TC.toType candidate)] UnitTy StaticLifetimeTy
   in if isTypeGeneric (TC.toType candidate)
        then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate deleteGenerator) binderP binderT doc, [])
        else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate deleteGenerator) doc

-- | Helper function to create the binder for the 'copy' template.
binderForCopy :: TC.TypeCandidate -> Either TypeError ((String, Binder), [XObj])
binderForCopy candidate =
  let doc = "copies a `" ++ TC.getName candidate ++ "`."
      binderP = SymPath (TC.getFullPath candidate) "copy"
      binderT = FuncTy [RefTy (TC.toType candidate) (VarTy "q")] (TC.toType candidate) StaticLifetimeTy
   in if isTypeGeneric (TC.toType candidate)
        then Right $ (defineTypeParameterizedTemplate (TG.generateGenericTypeTemplate candidate copyGenerator) binderP binderT doc, [])
        else Right $ instanceBinderWithDeps binderP binderT (TG.generateConcreteTypeTemplate candidate copyGenerator) doc

--------------------------------------------------------------------------------
-- Template generators
--
-- These functions declaratively specify how C code should be emitted for a
-- type. Binder helpers use these to generate an appropriate template for a
-- bound function name for the type.

-- | getterGenerator returns a template generator for struct property getters.
getterGenerator :: TG.TemplateGenerator TC.TypeField
getterGenerator = TG.mkTemplateGenerator tgen decl body deps
  where
    tgen :: TG.TypeGenerator TC.TypeField
    tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "t") StaticLifetimeTy)

    decl :: TG.TokenGenerator TC.TypeField
    decl TG.GeneratorArg {instanceT = UnitTy} = toTemplate "void $NAME($(Ref p) p)"
    decl _ = toTemplate "$t $NAME($(Ref p) p)"

    body :: TG.TokenGenerator TC.TypeField
    body TG.GeneratorArg {value = (TC.StructField _ UnitTy)} = toTemplate "$DECL { return; }\n"
    body TG.GeneratorArg {instanceT = (FuncTy _ (RefTy UnitTy _) _)} = toTemplate " $DECL { void* ptr = NULL; return ptr; }\n"
    body TG.GeneratorArg {value = (TC.StructField name ty)} =
      let fixForVoidStarMembers =
            if isFunctionType ty && not (isTypeGeneric ty)
              then "(" ++ tyToCLambdaFix (RefTy ty (VarTy "q")) ++ ")"
              else ""
       in toTemplate ("$DECL { return " ++ fixForVoidStarMembers ++ "(&(p->" ++ (mangle name) ++ ")); }\n")
    body TG.GeneratorArg {} = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeField
    deps = const []

-- | setterGenerator returns a template generator for struct property setters.
setterGenerator :: TG.TemplateGenerator TC.TypeField
setterGenerator = TG.mkTemplateGenerator tgen decl body deps
  where
    tgen :: TG.TypeGenerator TC.TypeField
    tgen _ = (FuncTy [VarTy "p", VarTy "t"] (VarTy "p") StaticLifetimeTy)

    decl :: TG.TokenGenerator TC.TypeField
    decl GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$p $NAME($p p)"
    decl _ = toTemplate "$p $NAME($p p, $t newValue)"

    body :: TG.TokenGenerator TC.TypeField
    body GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return p; }\n"
    body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} =
      multilineTemplate
        [ "$DECL {",
          memberDeletion tenv env (mangle name, ty),
          "    p." ++ (mangle name) ++ " = newValue;",
          "    return p;",
          "}\n"
        ]
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeField
    deps GeneratorArg {tenv, env, TG.instanceT = (FuncTy [_, ty] _ _)}
      | isManaged tenv env ty = depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty)
      | isFunctionType ty = [defineFunctionTypeAlias ty]
      | otherwise = []
    deps _ = []

-- | mutatorGenerator returns a template generator for struct property setters (in-place).
mutatorGenerator :: TG.TemplateGenerator TC.TypeField
mutatorGenerator = TG.mkTemplateGenerator tgen decl body deps
  where
    tgen :: TG.TypeGenerator TC.TypeField
    tgen _ = (FuncTy [RefTy (VarTy "p") (VarTy "q"), VarTy "t"] UnitTy StaticLifetimeTy)

    decl :: TG.TokenGenerator TC.TypeField
    decl GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "void $NAME($p* pRef)"
    decl _ = toTemplate "void $NAME($p* pRef, $t newValue)"

    body :: TG.TokenGenerator TC.TypeField
    -- Execution of the action passed as an argument is handled in Emit.hs.
    body GeneratorArg {instanceT = (FuncTy [_, UnitTy] _ _)} = toTemplate "$DECL { return; }\n"
    body GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _), value = (TC.StructField name _)} =
      multilineTemplate
        [ "$DECL {",
          memberRefDeletion tenv env (mangle name, ty),
          "    pRef->" ++ mangle name ++ " = newValue;",
          "}\n"
        ]
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeField
    deps GeneratorArg {tenv, env, instanceT = (FuncTy [_, ty] _ _)} =
      if isManaged tenv env ty
        then depsOfPolymorphicFunction tenv env [] "delete" (typesDeleterFunctionType ty)
        else []
    deps _ = []

-- | Returns a template generator for updating struct properties with a function.
updateGenerator :: TG.TemplateGenerator TC.TypeField
updateGenerator = TG.mkTemplateGenerator tgen decl body deps
  where
    tgen :: TG.TypeGenerator TC.TypeField
    tgen GeneratorArg {value = (TC.StructField _ UnitTy)} =
      (FuncTy [VarTy "p", RefTy (FuncTy [] UnitTy (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)
    tgen _ = (FuncTy [VarTy "p", RefTy (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) (VarTy "q")] (VarTy "p") StaticLifetimeTy)

    decl :: TG.TokenGenerator TC.TypeField
    decl _ = toTemplate "$p $NAME($p p, Lambda *updater)" -- Lambda used to be (Fn [t] t)
    body :: TG.TokenGenerator TC.TypeField
    body GeneratorArg {value = (TC.StructField _ UnitTy)} =
      toTemplate ("$DECL { " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [] UnitTy (VarTy "fq")) [] ++ "; return p;}\n")
    body GeneratorArg {value = (TC.StructField name _)} =
      multilineTemplate
        [ "$DECL {",
          "    p." ++ mangle name ++ " = " ++ templateCodeForCallingLambda "(*updater)" (FuncTy [VarTy "t"] (VarTy "t") (VarTy "fq")) ["p." ++ mangle name] ++ ";",
          "    return p;",
          "}\n"
        ]
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeField
    deps GeneratorArg {instanceT = (FuncTy [_, RefTy t@(FuncTy fArgTys fRetTy _) _] _ _)} =
      if isTypeGeneric fRetTy
        then []
        else [defineFunctionTypeAlias t, defineFunctionTypeAlias (FuncTy (lambdaEnvTy : fArgTys) fRetTy StaticLifetimeTy)]
    deps _ = []

-- | Returns a template generator for a types initializer function.
initGenerator :: AllocationMode -> TG.TemplateGenerator TC.TypeCandidate
initGenerator alloc = TG.mkTemplateGenerator genT decl body deps
  where
    genT :: TG.TypeGenerator TC.TypeCandidate
    genT GeneratorArg {value} =
      (FuncTy (concatMap TC.fieldTypes (TC.getFields value)) (VarTy "p") StaticLifetimeTy)

    decl :: TG.TokenGenerator TC.TypeCandidate
    decl GeneratorArg {originalT, instanceT = (FuncTy _ concreteT _), value} =
      let mappings = unifySignatures originalT concreteT
          concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
          cFields = remove isUnitT (remove isDummy concreteFields)
       in toTemplate ("$p $NAME(" ++ joinWithComma (map fieldArg cFields) ++ ")")
    decl _ = toTemplate "/* template error! */"

    body :: TG.TokenGenerator TC.TypeCandidate
    body GeneratorArg {originalT, instanceT = (FuncTy _ concreteT _), value} =
      let mappings = unifySignatures originalT concreteT
          concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
       in tokensForInit alloc (show originalT) (remove isUnitT concreteFields)
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeCandidate
    deps GeneratorArg {tenv, env, instanceT = (FuncTy _ concreteT _)} =
      case concretizeType tenv env concreteT of
        Left _ -> []
        Right ok -> ok
    deps _ = []

    tokensForInit :: AllocationMode -> String -> [TC.TypeField] -> [Token]
    -- if this is truly a memberless struct, init it to 0;
    -- This can happen in cases where *all* members of the struct are of type Unit.
    -- Since we do not generate members for Unit types.
    tokensForInit StackAlloc _ [] =
      multilineTemplate
        [ "$DECL {",
          "    $p instance = {};",
          "    return instance;",
          "}"
        ]
    tokensForInit StackAlloc _ fields =
      multilineTemplate
        [ "$DECL {",
          "    $p instance;",
          assignments fields,
          "    return instance;",
          "}"
        ]
    tokensForInit HeapAlloc typeName fields =
      multilineTemplate
        [ "$DECL {",
          "    $p instance = CARP_MALLOC(sizeof(" ++ typeName ++ "));",
          assignments fields,
          "    return instance;",
          "}"
        ]

    assignments :: [TC.TypeField] -> String
    assignments [] = ""
    assignments fields = joinLines $ fmap (memberAssignment alloc) fields

    isDummy field = TC.fieldName field == "__dummy"
    isUnitT (TC.StructField _ UnitTy) = True
    isUnitT _ = False

-- | Generate C code for assigning to a member variable.
-- Needs to know if the instance is a pointer or stack variable.
-- Also handles the special dummy member we add for empty structs to be ANSI C compatible.
memberAssignment :: AllocationMode -> TC.TypeField -> String
memberAssignment allocationMode field =
  case (TC.fieldName field) of
    "__dummy" -> "    instance" ++ sep ++ mangle name ++ " = " ++ "0" ++ ";"
    _ -> "    instance" ++ sep ++ mangle name ++ " = " ++ mangle name ++ ";"
  where
    name = (TC.fieldName field)
    sep = case allocationMode of
      StackAlloc -> "."
      HeapAlloc -> "->"

-- | Creates the C code for an arg to the init function.
-- | i.e. "(deftype A [x Int])" will generate "int x" which
-- | will be used in the init function like this: "A_init(int x)"
fieldArg :: TC.TypeField -> String
fieldArg (TC.StructField name ty) =
  tyToCLambdaFix (templatizeTy ty) ++ " " ++ mangle name
fieldArg _ = ""

---- | Creates the C code for an arg to the init function.
---- | i.e. "(deftype A [x Int])" will generate "int x" which
---- | will be used in the init function like this: "A_init(int x)"
memberArg :: (String, Ty) -> String
memberArg (memberName, memberTy) =
  tyToCLambdaFix (templatizeTy memberTy) ++ " " ++ memberName

-- | If the type is just a type variable; create a template type variable by appending $ in front of it's name
templatizeTy :: Ty -> Ty
templatizeTy (VarTy vt) = VarTy ("$" ++ vt)
templatizeTy (FuncTy argTys retTy ltTy) = FuncTy (map templatizeTy argTys) (templatizeTy retTy) (templatizeTy ltTy)
templatizeTy (StructTy name tys) = StructTy name (map templatizeTy tys)
templatizeTy (RefTy t lt) = RefTy (templatizeTy t) (templatizeTy lt)
templatizeTy (PointerTy t) = PointerTy (templatizeTy t)
templatizeTy t = t

-- | Returns a template generator for a type's str and prn functions.
strGenerator :: TG.TemplateGenerator TC.TypeCandidate
strGenerator = TG.mkTemplateGenerator genT decl body deps
  where
    genT :: TG.TypeGenerator TC.TypeCandidate
    genT GeneratorArg {originalT} =
      FuncTy [RefTy originalT (VarTy "q")] StringTy StaticLifetimeTy

    decl :: TG.TokenGenerator TC.TypeCandidate
    decl GeneratorArg {instanceT = (FuncTy [RefTy structT _] _ _)} =
      toTemplate $ "String $NAME(" ++ tyToCLambdaFix structT ++ " *p)"
    decl _ = toTemplate "/* template error! */"

    body :: TG.TokenGenerator TC.TypeCandidate
    body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} =
      let mappings = unifySignatures originalT structT
          concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
       in tokensForStr tenv env (getStructName structT) concreteFields structT
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeCandidate
    deps arg@GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} =
      let mappings = unifySignatures originalT structT
          concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
       in concatMap
            (depsOfPolymorphicFunction tenv env [] "prn" . typesStrFunctionType tenv env)
            (remove isFullyGenericType (concatMap TC.fieldTypes concreteFields))
            ++ [defineFunctionTypeAlias (instanceT arg) | not (isTypeGeneric structT)]
    deps _ = []

    tokensForStr :: TypeEnv -> Env -> String -> [TC.TypeField] -> Ty -> [Token]
    tokensForStr typeEnv env typeName fields concreteStructTy =
      let members = remove ((== "__dummy") . fst) (map fieldToTuple fields)
       in multilineTemplate
            [ "$DECL {",
              "  // convert members to String here:",
              "  String temp = NULL;",
              "  int tempsize = 0;",
              "  (void)tempsize; // that way we remove the occasional unused warning ",
              calculateStructStrSize typeEnv env members concreteStructTy,
              "  String buffer = CARP_MALLOC(size);",
              "  String bufferPtr = buffer;",
              "",
              "  sprintf(bufferPtr, \"(%s \", \"" ++ typeName ++ "\");",
              "  bufferPtr += strlen(\"" ++ typeName ++ "\") + 2;\n",
              joinLines (map (memberPrn typeEnv env) members),
              "  bufferPtr--;",
              "  sprintf(bufferPtr, \")\");",
              "  return buffer;",
              "}"
            ]
    calculateStructStrSize :: TypeEnv -> Env -> [(String, Ty)] -> Ty -> String
    calculateStructStrSize typeEnv env fields s =
      "  int size = snprintf(NULL, 0, \"(%s )\", \"" ++ show s ++ "\");\n"
        ++ unlines (map (memberPrnSize typeEnv env) fields)

-- | Returns a template generator for a type's delete function.
deleteGenerator :: TG.TemplateGenerator TC.TypeCandidate
deleteGenerator = TG.mkTemplateGenerator genT decl body deps
  where
    genT :: TG.TypeGenerator TC.TypeCandidate
    genT _ = FuncTy [VarTy "p"] UnitTy StaticLifetimeTy

    decl :: TG.TokenGenerator TC.TypeCandidate
    decl _ = toTemplate "void $NAME($p p)"

    body :: TG.TokenGenerator TC.TypeCandidate
    body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [structT] _ _), value} =
      let mappings = unifySignatures originalT structT
          concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
          members = map fieldToTuple concreteFields
       in multilineTemplate
            [ "$DECL {",
              joinLines (map (memberDeletion tenv env) members),
              "}"
            ]
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeCandidate
    deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [structT] _ _), value}
      | isTypeGeneric structT = []
      | otherwise =
        let mappings = unifySignatures originalT structT
            concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
         in concatMap
              (depsOfPolymorphicFunction tenv env [] "delete" . typesDeleterFunctionType)
              (filter (isManaged tenv env) (concatMap TC.fieldTypes concreteFields))
    deps _ = []

-- | Returns a template generator for a type's copy function.
copyGenerator :: TG.TemplateGenerator TC.TypeCandidate
copyGenerator = TG.mkTemplateGenerator genT decl body deps
  where
    genT :: TG.TypeGenerator TC.TypeCandidate
    genT _ = FuncTy [RefTy (VarTy "p") (VarTy "q")] (VarTy "p") StaticLifetimeTy

    decl :: TG.TokenGenerator TC.TypeCandidate
    decl _ = toTemplate "$p $NAME($p* pRef)"

    body :: TG.TokenGenerator TC.TypeCandidate
    body GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value} =
      let mappings = unifySignatures originalT structT
          concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
          members = map fieldToTuple concreteFields
       in tokensForCopy tenv env members
    body _ = toTemplate "/* template error! */"

    deps :: TG.DepenGenerator TC.TypeCandidate
    deps GeneratorArg {tenv, env, originalT, instanceT = (FuncTy [RefTy structT _] _ _), value}
      | isTypeGeneric structT = []
      | otherwise =
        let mappings = unifySignatures originalT structT
            concreteFields = replaceGenericTypeSymbolsOnFields mappings (TC.getFields value)
            members = map fieldToTuple concreteFields
         in concatMap
              (depsOfPolymorphicFunction tenv env [] "copy" . typesCopyFunctionType)
              (filter (isManaged tenv env) (map snd members))
    deps _ = []

--------------------------------------------------------------------------------
-- Utilities

-- | Converts a type field to a tuple of its name and primary type.
-- This is a convenience function for interop with the old tuple based
-- functions for handling type members and it should eventually be deprecated
-- once these functions work on type fields directly.
fieldToTuple :: TC.TypeField -> (String, Ty)
fieldToTuple (TC.StructField name t) = (mangle name, t)
fieldToTuple (TC.SumField name (t : _)) = (mangle name, t) -- note: not actually used.
fieldToTuple (TC.SumField name []) = (mangle name, TypeTy) -- note: not actually used.