feat: support direct recursion sugar for concrete sumtypes

Enables users to use "direct" recursion on sumtypes and abstracts away
pointers in function signatures such as case initers.

Author: scolsen

src/Deftype.hs

@@ -465,6 +465,7 @@ 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 (RecTy t) = t
 templatizeTy (PointerTy t) = PointerTy (templatizeTy t)
 templatizeTy t = t
 

src/Emit.hs

@@ -867,7 +867,7 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
                    appendToSrc ("struct " ++ tyToC sumTy ++ " {\n")
            else appendToSrc "typedef struct {\n")
         appendToSrc (addIndent indent ++ "union {\n")
-        mapM_ (emitSumtypeCase indent) rest
+        mapM_ (emitSumtypeCase indent) pointerfix
         appendToSrc (addIndent indent ++ "char __dummy;\n")
         appendToSrc (addIndent indent ++ "} u;\n")
         appendToSrc (addIndent indent ++ "char _tag;\n")
@@ -876,7 +876,7 @@ defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
           (appendToSrc (" " ++ tyToC sumTy))
         appendToSrc ";\n"
         --appendToSrc ("// " ++ show typeVariables ++ "\n")
-        mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] rest)
+        mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] pointerfix)
       emitSumtypeCase :: Int -> XObj -> State EmitterState ()
       emitSumtypeCase ind (XObj (Lst [XObj (Sym (SymPath [] caseName) _) _ _, XObj (Arr []) _ _]) _ _) =
         appendToSrc (addIndent ind ++ "// " ++ caseName ++ "\n")

src/Sumtypes.hs

@@ -56,8 +56,9 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
       candidate = TypeCandidate {typename = typeName, variables = typeVariables, restriction = AllowOnlyNamesInScope, typemembers = rest, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env}
    in do
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
+            ptrFix = map (recursiveMembersToPointers structTy) rest
         okRecursive candidate
-        cases <- toCases typeEnv env candidate
+        cases <- toCases typeEnv env (candidate {typemembers = ptrFix})
         okIniters <- initers insidePath structTy cases
         okTag <- binderForTag insidePath structTy
         (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str"
@@ -91,19 +92,21 @@ binderForCaseInit _ _ _ = error "binderforcaseinit"
 
 concreteCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
 concreteCaseInit allocationMode insidePath structTy sumtypeCase =
-  instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (caseTys sumtypeCase) structTy StaticLifetimeTy) template doc
+  instanceBinder (SymPath insidePath (caseName sumtypeCase)) (FuncTy (map removeRec (caseTys sumtypeCase)) structTy StaticLifetimeTy) template doc
   where
     doc = "creates a `" ++ caseName sumtypeCase ++ "`."
     template =
       Template
-        (FuncTy (caseTys sumtypeCase) (VarTy "p") StaticLifetimeTy)
+        (FuncTy (map removeRec (caseTys sumtypeCase)) (VarTy "p") StaticLifetimeTy)
         ( \(FuncTy _ concreteStructTy _) ->
             let mappings = unifySignatures structTy concreteStructTy
-                correctedTys = map (replaceTyVars mappings) (caseTys sumtypeCase)
+                correctedTys = map (replaceTyVars mappings) (map removeRec (caseTys sumtypeCase))
              in (toTemplate $ "$p $NAME(" ++ joinWithComma (zipWith (curry memberArg) anonMemberNames (remove isUnit correctedTys)) ++ ")")
         )
         (const (tokensForCaseInit allocationMode structTy sumtypeCase))
         (\FuncTy {} -> [])
+    removeRec (RecTy t) = t
+    removeRec t = t
 
 genericCaseInit :: AllocationMode -> [String] -> Ty -> SumtypeCase -> (String, Binder)
 genericCaseInit allocationMode pathStrings originalStructTy sumtypeCase =
@@ -141,13 +144,15 @@ tokensForCaseInit allocationMode sumTy@(StructTy (ConcreteNameTy _) _) sumtypeCa
           StackAlloc -> "    $p instance;"
           HeapAlloc -> "    $p instance = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));",
         joinLines $ caseMemberAssignment allocationMode correctedName . fst <$> unitless,
+        joinLines $ recCaseMemberAssignment allocationMode correctedName sumTy . fst <$> recursive,
         "    instance._tag = " ++ tagName sumTy correctedName ++ ";",
         "    return instance;",
         "}"
       ]
   where
     correctedName = caseName sumtypeCase
-    unitless = zip anonMemberNames $ remove isUnit (caseTys sumtypeCase)
+    unitless  = remove (isRecType . snd) $ zip anonMemberNames  $ remove isUnit (caseTys sumtypeCase)
+    recursive = filter (isRecType . snd) $ zip anonMemberNames (caseTys sumtypeCase)
 tokensForCaseInit _ _ _ = error "tokensforcaseinit"
 
 caseMemberAssignment :: AllocationMode -> String -> String -> String
@@ -158,6 +163,15 @@ caseMemberAssignment allocationMode caseNm memberName =
       StackAlloc -> ".u."
       HeapAlloc -> "->u."
 
+recCaseMemberAssignment :: AllocationMode -> String -> Ty -> String -> String
+recCaseMemberAssignment allocationMode caseNm sumTy memberName =
+  "    instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = CARP_MALLOC(sizeof(" ++ show sumTy ++ "));\n"
+  ++ "    *instance" ++ sep ++ caseNm ++ "." ++ memberName ++ " = " ++ memberName ++ ";"
+  where
+    sep = case allocationMode of
+      StackAlloc -> ".u."
+      HeapAlloc -> "->u."
+
 binderForTag :: [String] -> Ty -> Either TypeError (String, Binder)
 binderForTag insidePath originalStructTy@(StructTy (ConcreteNameTy _) _) =
   Right $ instanceBinder path (FuncTy [RefTy originalStructTy (VarTy "q")] IntTy StaticLifetimeTy) template doc