feat: register-type improvements (#1332)

* fix: don't instantiate dummy fields for external types

For ANSI C compatibility reasons, we add a dummy field for memberless
types defined in Carp (see commit 59ef5bb). When registering a type
with no fields, `(register-type A [])`, we'd also attempt to set our
dummy field in the Carp generated initializer for the type. However, the
registered type is totally opaque from the perspective of Carp, and we
can't assume it has a field corresponding to our dummy field.

This commit changes our handling of __dummy in initializers to avoid
setting it for registered types.

* feat: automatically implement str and prn for registered types

This commit makes the auto-generated str and prn functions for
registered types implement the str and prn interfaces, removing the need
for users to call implements on these functions explicitly.

It alters the signature of `autoDerive` in Primitives.hs slightly to
make it more flexible (since registered types have no delete or copy
functions that we can add to the implementation lists of these
interfaces).

* docs: add docs on register-type to CInterop.md

The new documentation clarifies the usage of `register-type` and accounts
for the changes in the prior two commits.

* fix: fix function signatures for generic memberless initers

Filter out dummy field arguments.

* docs: Add details about type name overrides to CInterop.md

* docs: clarify that users can implement delete for registered types

Author: scolsen

docs/CInterop.md

@@ -14,6 +14,7 @@ This is an extension of what is covered in the [Language Guide](./LanguageGuide.
     - [`Generics`](#generics)
   - [`emit-c`](#unsafe-emit-c)
   - [`preproc`](#unsafe-preproc)
+  - [Registering Types](#register-types)
 - [Callbacks](#callbacks)
 
 
@@ -409,6 +410,113 @@ in compiler output. If your helper functions, macros, or preprocessor
 directives are lengthy or complex, you may want to define them in a separate
 `h` file and `relative-include` it in your Carp source instead.
 
+### Registering Types
+
+Carp supports a few different ways of registering types defined in C. You can
+register types using the `register-type` function. Calling `register-type` with
+only a symbol argument registers the C type with a name corresponding to the
+symbol.  For example, the following code registers the C type `A` as the type
+`A` in Carp.
+
+```c
+typedef int A;
+```
+
+```clojure
+(register-type A)
+```
+
+After this call to `register-type`, you can use the type `A` anywhere type
+names are valid in Carp code. For example, you can use it in function
+signatures:
+
+```clojure
+(sig a-prn (Fn [A] String))
+```
+
+The prior type registration *only* registers the type name in Carp. In other
+words, the type is entirely "opaque" from the perspective of your Carp program.
+Carp knows the type exists, but it knows nothing about its implementation or
+how to construct values of the type--all of that is left up to your C code.
+
+If you want to construct values of this type from Carp code, you have two
+options:
+
+1. You can define your own initializers for the type in C and register them in Carp.
+2. You can use `register-type` to generate initializers for the type in Carp.
+
+If you define an initializer for the type in C, you can access it from Carp by
+using `register`:
+
+```c
+typedef int A;
+
+A initializer() {
+  return 0;
+}
+```
+
+```clojure
+(register-type A)
+(register initializer (Fn [] A))
+;; returns a value of type A
+(initializer)
+```
+
+Alternatively, you can add a non-empty array of type members in your
+`register-type` call to have Carp generate initializers, getters and setters,
+and printing functions for the external type. The initializer Carp generates
+will only initialize the fields you specify. If you omit or misname a field,
+the generated initializer might cause errors.
+
+```clojure
+(register-type B [])
+:i B
+=> B : Type
+     init : (Fn [] B)
+     prn  : (Fn [(Ref B q)] String)
+     str  : (Fn [(Ref B q)] String)
+}
+(register-type C [x Int])
+:i C
+=> C : Type
+   C : Module {
+     init     : (Fn [Int] C)
+     prn      : (Fn [(Ref C q) String])
+     str      : (Fn [(Ref C q) String])
+     set-x    : (Fn [C, Int] C)
+     set-x!   : (Fn [(Ref C q), Int] ())
+     update-x : (Fn [C, (Ref (Fn [Int] Int) q)] C)
+     x        : (Fn [(Ref C q)] (Ref Int q))
+}
+```
+
+The `prn` and `str` functions for the type will also automatically implement
+their corresponding interfaces.
+
+Be mindful that Carp *does not manage the memory associated with external types
+by default!* Unlike types defined in Carp, Carp will not generate `copy` and
+`delete` functions for registered types. If you use generated initializers for
+a registered type for convenience, remember that you still need to manage the
+memory associated with values of the type manually. If you want Carp to manage
+the memory for a registered type, you can provide implementations of the `copy`
+and `delete` interfaces.
+
+If needed, you can override the name Carp emits for a registered type by
+providing an additional string argument. This comes in handy when the type's
+name in C does not follow lisp or Carp naming conventions. For example, the
+type in C might begin with a lowercase letter, while Carp requires all types to
+begin with uppercase letters:
+
+```clojure
+;; Emitted in C code as "A"
+(register-type A)
+;; Emitted in C code a "a_type"
+(register-type A "a_type")
+;; Emitted in C code as "b_type"
+(register-type B "b_type" [x Int])
+```
+
 ## Callbacks
 
 Some C APIs rely on callbacks, let's define a C function that accepts a

src/Deftype.hs

@@ -59,11 +59,17 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
       -- The variable 'insidePath' is the path used for all member functions inside the 'typeModule'.
       -- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
       insidePath = pathStrings ++ [typeName]
+      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
         validateMemberCases typeEnv env typeVariables rest
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
         (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
-        okInit <- binderForInit insidePath structTy rest
+        okInit <- binderForInit insidePath structTy initmembers
         (okStr, strDeps) <- binderForStrOrPrn typeEnv env insidePath structTy rest "str"
         (okPrn, _) <- binderForStrOrPrn typeEnv env insidePath structTy rest "prn"
         (okDelete, deleteDeps) <- binderForDelete typeEnv env insidePath structTy rest
@@ -336,15 +342,21 @@ templateUpdater member _ =
 -- | Helper function to create the binder for the 'init' template.
 binderForInit :: [String] -> Ty -> [XObj] -> Either TypeError (String, Binder)
 binderForInit insidePath structTy@(StructTy (ConcreteNameTy _) _) [XObj (Arr membersXObjs) _ _] =
-  if isTypeGeneric structTy
-    then Right (genericInit StackAlloc insidePath structTy membersXObjs)
-    else
-      Right $
-        instanceBinder
-          (SymPath insidePath "init")
-          (FuncTy (initArgListTypes membersXObjs) structTy StaticLifetimeTy)
-          (concreteInit StackAlloc structTy membersXObjs)
-          ("creates a `" ++ show structTy ++ "`.")
+  -- 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 = case membersXObjs of
+                  [(XObj (Sym (SymPath [] "__dummy") Symbol) Nothing Nothing), (XObj (Sym (SymPath [] "Char") Symbol) Nothing Nothing)] -> []
+                  _ -> membersXObjs
+   in if isTypeGeneric structTy
+        then Right (genericInit StackAlloc insidePath structTy membersXObjs)
+        else
+          Right $
+            instanceBinder
+              (SymPath insidePath "init")
+              -- don't include the dummy field in arg lists
+              (FuncTy (initArgListTypes nodummy) structTy StaticLifetimeTy)
+              (concreteInit StackAlloc structTy membersXObjs)
+              ("creates a `" ++ show structTy ++ "`.")
 binderForInit _ _ _ = error "binderforinit"
 
 -- | Generate a list of types from a deftype declaration.
@@ -361,7 +373,7 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) mem
         let mappings = unifySignatures originalStructTy concreteStructTy
             correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
             memberPairs = memberXObjsToPairs correctedMembers
-         in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (unitless memberPairs)) ++ ")")
+         in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (unitless memberPairs))) ++ ")")
     )
     ( \(FuncTy _ concreteStructTy _) ->
         let mappings = unifySignatures originalStructTy concreteStructTy
@@ -371,6 +383,9 @@ concreteInit allocationMode originalStructTy@(StructTy (ConcreteNameTy _) _) mem
     (\FuncTy {} -> [])
   where
     unitless = remove (isUnit . snd)
+    nodummy  = remove (isDummy . fst)
+    isDummy "__dummy" = True
+    isDummy _ = False
 concreteInit _ _ _ = error "concreteinit"
 
 -- | The template for the 'init' and 'new' functions for a generic deftype.
@@ -379,7 +394,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
   defineTypeParameterizedTemplate templateCreator path t docs
   where
     path = SymPath pathStrings "init"
-    t = FuncTy (map snd (memberXObjsToPairs membersXObjs)) originalStructTy StaticLifetimeTy
+    t = FuncTy (map snd (nodummy (memberXObjsToPairs membersXObjs))) originalStructTy StaticLifetimeTy
     docs = "creates a `" ++ show originalStructTy ++ "`."
     templateCreator = TemplateCreator $
       \typeEnv env ->
@@ -389,7 +404,7 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
               let mappings = unifySignatures originalStructTy concreteStructTy
                   correctedMembers = replaceGenericTypeSymbolsOnMembers mappings membersXObjs
                   memberPairs = memberXObjsToPairs correctedMembers
-               in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (remove (isUnit . snd) memberPairs)) ++ ")")
+               in (toTemplate $ "$p $NAME(" ++ joinWithComma (map memberArg (nodummy (remove (isUnit . snd) memberPairs))) ++ ")")
           )
           ( \(FuncTy _ concreteStructTy _) ->
               let mappings = unifySignatures originalStructTy concreteStructTy
@@ -401,6 +416,9 @@ genericInit allocationMode pathStrings originalStructTy@(StructTy (ConcreteNameT
                 Left _ -> []
                 Right ok -> ok
           )
+    nodummy  = remove (isDummy . fst)
+    isDummy "__dummy" = True
+    isDummy _ = False
 genericInit _ _ _ _ = error "genericinit"
 
 tokensForInit :: AllocationMode -> String -> [XObj] -> [Token]
@@ -421,7 +439,7 @@ tokensForInit allocationMode typeName membersXObjs =
         "}"
       ]
   where
-    assignments [] = "    instance.__dummy = 0;"
+    assignments [] = ""
     assignments _ = go unitless
       where
         go [] = ""
@@ -537,9 +555,13 @@ calculateStructStrSize typeEnv env members s@(StructTy (ConcreteNameTy _) _) =
 calculateStructStrSize _ _ _ _ = error "calculatestructstrsize"
 
 -- | Generate C code for assigning to a member variable.
--- | Needs to know if the instance is a pointer or stack 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 -> String -> String
-memberAssignment allocationMode memberName = "    instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
+memberAssignment allocationMode memberName =
+  case memberName of
+    "__dummy" -> "    instance" ++ sep ++ memberName ++ " = " ++ "0" ++ ";"
+    _ -> "    instance" ++ sep ++ memberName ++ " = " ++ memberName ++ ";"
   where
     sep = case allocationMode of
       StackAlloc -> "."

src/Primitives.hs

@@ -263,7 +263,10 @@ primitiveRegisterTypeWithFields ctx x t override members =
             Right ctx' = update ctx
         -- TODO: Another case where define does not get formally qualified deps!
         contextWithDefs <- liftIO $ foldM (define True) ctx' (map Qualified deps)
-        pure (contextWithDefs, dynamicNil)
+        autoDerive contextWithDefs (StructTy (ConcreteNameTy (unqualify path')) [])
+          [ lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "str")),
+            lookupBinderInTypeEnv contextWithDefs (markQualified (SymPath [] "prn"))
+          ]
     path = SymPath [] t
     preExistingModule = case lookupBinderInGlobalEnv ctx path of
       Right (Binder _ (XObj (Mod found et) _ _)) -> Just (found, et)
@@ -612,6 +615,10 @@ deftype ctx x@(XObj (Sym (SymPath [] name) _) _ _) constructor =
     case e of
       Left err -> pure (evalError ctx (show err) (xobjInfo x))
       Right t -> autoDerive ctxWithType t
+        [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
+        ]
 deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) constructor =
   do
     (ctxWithType, e) <-
@@ -623,6 +630,10 @@ deftype ctx x@(XObj (Lst ((XObj (Sym (SymPath [] name) _) _ _) : tyvars)) _ _) c
     case e of
       Left err -> pure (evalError ctx (show err) (xobjInfo x))
       Right t -> autoDerive ctxWithType t
+        [ lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "delete")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "str")),
+          lookupBinderInTypeEnv ctxWithType (markQualified (SymPath [] "copy"))
+        ]
 deftype ctx name _ = pure $ toEvalError ctx name (InvalidTypeName name)
 
 checkVariables :: [XObj] -> Maybe [Ty]
@@ -658,21 +669,17 @@ unwrapTypeErr ctx (Left err) = Left (typeErrorToString ctx err)
 unwrapTypeErr _ (Right x) = Right x
 
 -- | Automatically derive implementations of interfaces.
-autoDerive :: Context -> Ty -> IO (Context, Either EvalError XObj)
-autoDerive c ty =
+autoDerive :: Context -> Ty -> [Either ContextError Binder] -> IO (Context, Either EvalError XObj)
+autoDerive c ty interfaces =
   let (SymPath mods tyname) = (getStructPath ty)
       implBinder :: String -> Ty -> Binder
       implBinder name t = Binder emptyMeta (XObj (Sym (SymPath (mods ++ [tyname]) name) Symbol) (Just dummyInfo) (Just t))
       getSig :: String -> Ty
       getSig "delete" = FuncTy [ty] UnitTy StaticLifetimeTy
       getSig "str" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
+      getSig "prn" = FuncTy [RefTy ty (VarTy "q")] StringTy StaticLifetimeTy
       getSig "copy" = FuncTy [RefTy ty (VarTy "q")] ty StaticLifetimeTy
       getSig _ = VarTy "z"
-      interfaces =
-        [ lookupBinderInTypeEnv c (markQualified (SymPath [] "delete")),
-          lookupBinderInTypeEnv c (markQualified (SymPath [] "str")),
-          lookupBinderInTypeEnv c (markQualified (SymPath [] "copy"))
-        ]
       registration interface =
         let name = getSimpleName (binderXObj interface)
             sig = getSig name