refactor: alter type candidate, use it as an interface boundary

Instead of passing types and members separately to routines, we use type
candidates as input to recursivity checks. This simplifies both
validation and recursiveness checking on types and abstracts away
differences in structure between sum type and product type members.

I also had to adjust some test output, will restore them in a future
commit.

Author: scolsen

src/Concretize.hs

@@ -613,8 +613,8 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic
       let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
           validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
           concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
-          candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env  }
-      validateMembers typeEnv env candidate
+      candidate <- (fromDeftype (getStructName originalStructTy) renamedOrig typeEnv env validMembers)
+      validateMembers (candidate {restriction = AllowAnyTypeVariableNames})
       deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
       let xobj =
             XObj
@@ -642,30 +642,22 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
   let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
       fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
       rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
-   in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of
-        Left e -> error (show e)
-        Right mappings ->
-          let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
-              concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
-              deps = mapM (depsForCase typeEnv env) concretelyTypedCases
-              candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env }
-           in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation.
-                Left err -> Left err
-                Right _ ->
-                  case deps of
-                    Right okDeps ->
-                      Right $
-                        XObj
-                          ( Lst
-                              ( XObj (DefSumtype genericStructTy) Nothing Nothing :
-                                XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
-                                concretelyTypedCases
-                              )
-                          )
-                          (Just dummyInfo)
-                          (Just TypeTy) :
-                        concat okDeps
-                    Left err -> Left err
+   in do mappings <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym])
+         let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
+             concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
+         candidate <- fromSumtype (getStructName originalStructTy) renamedOrig typeEnv env concretelyTypedCases
+         _ <- toCases typeEnv env (candidate {restriction = AllowAnyTypeVariableNames})
+         deps <- mapM (depsForCase typeEnv env) concretelyTypedCases
+         pure (XObj
+                ( Lst
+                    ( XObj (DefSumtype genericStructTy) Nothing Nothing :
+                      XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
+                      concretelyTypedCases
+                    )
+                )
+                (Just dummyInfo)
+                (Just TypeTy) :
+                  concat deps)
 instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
 
 -- Resolves dependencies for sumtype cases.

src/Deftype.hs

@@ -61,7 +61,6 @@ 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]
-      candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = typeVariables, typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env}
       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.
@@ -75,11 +74,9 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
             ptrmembers = map (recursiveMembersToPointers structTy) rest
             ptrinitmembers = map (recursiveMembersToPointers structTy) initmembers
-        innermems <- case ptrmembers of
-                       [XObj (Arr membersXObjs) _ _] -> Right membersXObjs
-                       _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy))
-        okRecursive (candidate {typemembers = mems})
-        validateMembers typeEnv env (candidate {typemembers = innermems})
+        candidate <- fromDeftype typeName typeVariables typeEnv env mems
+        validateMembers candidate
+        okRecursive candidate
         (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy ptrmembers
         okInit <- if (any (isValueRecursive structTy) ptrmembers) then recursiveProductInitBinder insidePath structTy ptrinitmembers else binderForInit insidePath structTy initmembers
         okMake <- recursiveProductMakeBinder insidePath structTy ptrmembers
@@ -102,12 +99,12 @@ 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)
       insidePath = pathStrings ++ [typeName]
-      candidate = TypeCandidate {restriction = AllowOnlyNamesInScope, typename = typeName, variables = [], typemembers = [], interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env}
    in do
         mems <- case rest of
                   [XObj (Arr membersXObjs) _ _] -> Right membersXObjs
                   _ -> Left $ NotAValidType (XObj (Sym (SymPath pathStrings typeName) Symbol) i (Just TypeTy))
-        validateMembers typeEnv env (candidate {typemembers = mems})
+        candidate <- fromDeftype typeName [] typeEnv env mems
+        validateMembers candidate
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
         (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
         okInit <- binderForInit insidePath structTy rest

src/Emit.hs

@@ -15,6 +15,7 @@ where
 import Control.Monad.State
 import Data.Char (ord)
 import Data.Functor ((<&>))
+import Data.Either (fromRight)
 import Data.List (intercalate, isPrefixOf, sortOn)
 import Data.Maybe (fromJust, fromMaybe, isJust)
 import Env
@@ -31,6 +32,7 @@ import Template
 import TypePredicates
 import Types
 import TypesToC
+import TypeCandidate
 import Util
 
 addIndent :: Int -> String
@@ -843,48 +845,50 @@ memberToDecl recty indent (memberName, memberType) =
     Nothing -> error ("Invalid memberType: " ++ show memberType)
 
 defStructToDeclaration :: Ty -> SymPath -> [XObj] -> String
-defStructToDeclaration structTy@(StructTy _ _) _ rest =
+defStructToDeclaration structTy@(StructTy _ vars) _ rest@[XObj (Arr mems) _ _] =
   let indent = indentAmount
       typedefCaseToMemberDecl :: XObj -> State EmitterState [()]
       -- ANSI C doesn't allow empty structs, insert a dummy member to keep the compiler happy.
       typedefCaseToMemberDecl (XObj (Arr []) _ _) = sequence $ pure $ appendToSrc (addIndent indent ++ "char __dummy;\n")
       typedefCaseToMemberDecl (XObj (Arr members) _ _) = mapM (memberToDecl structTy indent) (remove (isUnit . fromJust . xobjToTy . snd) (pairwise members))
       typedefCaseToMemberDecl _ = error "Invalid case in typedef."
       pointerfix = map (recursiveMembersToPointers structTy) rest
+      candidate = fromDeftype (getStructName structTy) vars empty empty mems
+      isRec = fromRight False (fmap isRecursive candidate)
       -- Note: the names of types are not namespaced
       visit = do
         -- forward declaration for recursive types.
-        when (any (isRecursive structTy) pointerfix) $
+        when isRec $
           do appendToSrc ("// Recursive type \n")
              appendToSrc ("struct " ++ tyToC structTy ++ " {\n")
-        when (all (not . isRecursive structTy) pointerfix) $ appendToSrc "typedef struct {\n"
+        when (not isRec) $ appendToSrc "typedef struct {\n"
         mapM_ typedefCaseToMemberDecl pointerfix
         appendToSrc "}"
-        unless (any (isRecursive structTy) pointerfix)
-          (appendToSrc (" " ++ tyToC structTy))
+        unless isRec (appendToSrc (" " ++ tyToC structTy))
         appendToSrc ";\n"
    in if isTypeGeneric structTy
         then "" -- ("// " ++ show structTy ++ "\n")
         else emitterSrc (execState visit (EmitterState ""))
 defStructToDeclaration _ _ _ = error "defstructtodeclaration"
 
 defSumtypeToDeclaration :: Ty -> [XObj] -> String
-defSumtypeToDeclaration sumTy@(StructTy _ _) rest =
+defSumtypeToDeclaration sumTy@(StructTy _ vars) rest =
   let indent = indentAmount
       pointerfix = map (recursiveMembersToPointers sumTy) rest
+      candidate = fromSumtype (getStructName sumTy) vars empty empty rest
+      isRec = (fromRight False (fmap isRecursive candidate))
       visit = do
-        (if (any (isRecursive sumTy) pointerfix)
-           then do appendToSrc ("// Recursive type \n")
-                   appendToSrc ("struct " ++ tyToC sumTy ++ " {\n")
-           else appendToSrc "typedef struct {\n")
+        if isRec
+          then do appendToSrc ("// Recursive type \n")
+                  appendToSrc ("struct " ++ tyToC sumTy ++ " {\n")
+          else appendToSrc "typedef struct {\n"
         appendToSrc (addIndent indent ++ "union {\n")
         mapM_ (emitSumtypeCase indent) pointerfix
         appendToSrc (addIndent indent ++ "char __dummy;\n")
         appendToSrc (addIndent indent ++ "} u;\n")
         appendToSrc (addIndent indent ++ "char _tag;\n")
         appendToSrc "}"
-        unless (any (isRecursive sumTy) pointerfix)
-          (appendToSrc (" " ++ tyToC sumTy))
+        unless isRec (appendToSrc (" " ++ tyToC sumTy))
         appendToSrc ";\n"
         --appendToSrc ("// " ++ show typeVariables ++ "\n")
         mapM_ emitSumtypeCaseTagDefinition (zip [0 ..] pointerfix)

src/Primitives.hs

@@ -15,7 +15,7 @@ import Data.List (foldl')
 import Data.Maybe (fromJust, fromMaybe)
 import Deftype
 import Emit
-import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder)
+import Env (addUsePath, contextEnv, insert, lookupBinderEverywhere, lookupEverywhere, lookupMeta, searchValueBinder, empty)
 import EvalError
 import Infer
 import Info
@@ -35,6 +35,7 @@ import ToTemplate
 import TypeError
 import TypePredicates
 import Types
+import TypeCandidate
 import Util
 import Web.Browser (openBrowser)
 import RecType
@@ -647,8 +648,14 @@ makeType ctx name vars constructor =
   let qpath = (qualifyPath ctx (SymPath [] name))
       ty = StructTy (ConcreteNameTy (unqualify qpath)) vars
       (typeX, members, creator) = constructor ty
+      mems = case members of
+               [XObj (Arr xs) _ _] -> xs
+               --(Lst xs) -> xs
+               _ -> members
+      candidate = fromDeftype name vars Env.empty Env.empty mems <> fromSumtype name vars Env.empty Env.empty mems
+      isRec = fromRight False (fmap isRecursive candidate)
       -- if the type is recursive, tag it so we can easily find such types in the emitter.
-      tBinder = if any (isRecursive ty) members
+      tBinder = if isRec
                   then Meta.updateBinderMeta (toBinder typeX) "recursive" trueXObj
                   else (toBinder typeX)
    in case ( unwrapTypeErr ctx (creator ctx name vars members Nothing)

src/RecType.hs

@@ -1,3 +1,4 @@
+-- | Module RecType defines routines for working with recursive data types.
 module RecType
   (
    recursiveMembersToPointers,
@@ -24,49 +25,54 @@ import Concretize
 import ToTemplate
 import Validate
 
+-- | Returns true if a type candidate is recursive.
+isRecursive :: TypeCandidate -> Bool
+isRecursive candidate =
+  let memberTypes = concat $ map snd (typemembers candidate)
+      vars = variables candidate
+      name = typename candidate
+   in any (check name vars) memberTypes
+  where check :: String -> [Ty] -> Ty -> Bool
+        check name vars t = isDirectRecursion name vars t || isIndirectRecursion name vars t
+
+isDirectRecursion :: String -> [Ty] -> Ty -> Bool
+isDirectRecursion name vars (StructTy (ConcreteNameTy (SymPath [] n)) rest) =
+  (n == name && vars == rest)
+isDirectRecursion name vars (RecTy t) = isDirectRecursion name vars t
+isDirectRecursion _ _ _ = False
+
+isIndirectRecursion :: String -> [Ty] -> Ty -> Bool
+isIndirectRecursion name vars t@(StructTy _ rest) =
+  not (isDirectRecursion name vars t) && any (isDirectRecursion name vars) rest
+isIndirectRecursion name vars (PointerTy t) = isDirectRecursion name vars t
+isIndirectRecursion name vars (RefTy t _) = isDirectRecursion name vars t
+isIndirectRecursion _ _ _ = False
+
 --------------------------------------------------------------------------------
 -- Base indirection recursion
 
 -- | Returns true if a candidate type definition is a valid instance of recursivity.
 -- Types have valid recursion if they refer to themselves through indirection.
 okRecursive :: TypeCandidate -> Either TypeError ()
 okRecursive candidate =
-  if any go (typemembers candidate)
-    then validateInterfaceConstraints (candidate { interfaceConstraints = concat $ map go' (typemembers candidate)})
-    else Right ()
-  where go :: XObj -> Bool
-        go (XObj (Sym (SymPath _ name) _) _ _) = name == typename candidate
-        go (XObj (Lst xs) _ _) = any go xs
-        go _ = False
-        go' x@(XObj (Lst _) _ _) = if go x
-                                     then case xobjToTy x of
-                                            Just t@(PointerTy _) -> recInterfaceConstraints t
-                                            Just t@(RefTy _ _) -> recInterfaceConstraints t
-                                            Just t@(StructTy _ [_]) -> recInterfaceConstraints t
-                                            _ -> []
-                                     else []
-        go' _ = []
+  let name = typename candidate
+      vars = variables candidate
+      memberTypes = concat $ map snd (typemembers candidate)
+      recursives = (filter (isIndirectRecursion name vars) memberTypes)
+      ty = StructTy (ConcreteNameTy (SymPath [] name)) vars
+      constraints = map (recInterfaceConstraints ty) recursives
+   in validateInterfaceConstraints (candidate {interfaceConstraints = concat constraints})
 
 -- | Generates interface constraints for a recursive type.
 -- The recursive portion of recursive types must be wrapped in a type F that supports indirection.
 -- We enforce this with two interfaces:
 --   allocate: Heap allocates a value T and wraps it in type F<T>
 --   indirect: Returns T from a heap allocated F<T>
-recInterfaceConstraints :: Ty -> [InterfaceConstraint]
-recInterfaceConstraints t =
-  let members = tyMembers t
-   in case members of
-        [] -> []
-        _ -> [ InterfaceConstraint "indirect" [(FuncTy [t] (head members) StaticLifetimeTy)],
-               InterfaceConstraint "alloc" [(FuncTy [(head members)] t StaticLifetimeTy)]
-             ]
-
--- | Returns true if a type member xobj is recursive (either through indirect recursion or "value" recursion)
-isRecursive :: Ty -> XObj -> Bool
-isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path
-isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs
-isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs
-isRecursive _ _ = False
+recInterfaceConstraints :: Ty -> Ty -> [InterfaceConstraint]
+recInterfaceConstraints recTy t =
+  [ InterfaceConstraint "indirect" [(FuncTy [t] recTy StaticLifetimeTy)],
+    InterfaceConstraint "alloc" [(FuncTy [recTy] t StaticLifetimeTy)]
+  ]
 
 --------------------------------------------------------------------------------
 -- **Value recursion sugar**

src/SumtypeCase.hs

@@ -15,28 +15,14 @@ data SumtypeCase = SumtypeCase
 toCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError [SumtypeCase]
 toCases typeEnv globalEnv candidate = mapM (toCase (typename candidate) typeEnv globalEnv (restriction candidate) (variables candidate)) (typemembers candidate)
 
-toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
-toCase tyname typeEnv globalEnv varrestriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
-  let tys = map xobjToTy tyXObjs
-   in case sequence tys of
-        Nothing ->
-          Left (InvalidSumtypeCase x)
-        Just okTys ->
-          let validated = map (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t x) okTys
-           in case sequence validated of
-                Left e ->
-                  Left e
-                Right _ ->
-                  Right $
-                    SumtypeCase
-                      { caseName = pname,
-                        caseTys = okTys
-                      }
-toCase _ _ _ _ _ (XObj (Sym (SymPath [] pname) Symbol) _ _) =
-  Right $
-    SumtypeCase
-      { caseName = pname,
-        caseTys = []
-      }
-toCase _ _ _ _ _ x =
-  Left (InvalidSumtypeCase x)
+toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> (String, [Ty]) -> Either TypeError SumtypeCase
+toCase tyname typeEnv globalEnv varrestriction typeVars member =
+  let validated = mapM (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t) (snd member)
+   in case validated of
+        Left e -> Left e
+        Right _ ->
+          Right $
+            SumtypeCase
+              { caseName = fst member,
+                caseTys = snd member
+              }

src/Sumtypes.hs

@@ -53,12 +53,13 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
   let moduleValueEnv = fromMaybe (new innerEnv (Just typeName)) (fmap fst existingEnv)
       moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
       insidePath = pathStrings ++ [typeName]
-      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
+        candidate <- fromSumtype typeName typeVariables typeEnv env rest
         okRecursive candidate
-        cases <- toCases typeEnv env (candidate {typemembers = ptrFix})
+        candidate' <- fromSumtype typeName typeVariables typeEnv env ptrFix
+        cases <- toCases typeEnv env candidate'
         okIniters <- initers insidePath structTy cases
         okTag <- binderForTag insidePath structTy
         (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str"