refactor: add a data type for type validation

scolsen · scolsen · commit df3947733ffc · 2021-10-13T13:04:28.000-04:00
This makes it easier to work with validation functions at call sites as
well as paves the way for permitting recursive types (we pass along the
type name to validation procedures).
diff --git a/src/Concretize.hs b/src/Concretize.hs
@@ -612,7 +612,8 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic
       let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
           validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
           concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
-      validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers
+          candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig}
+      validateMembers typeEnv env candidate
       deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
       let xobj =
             XObj
@@ -646,7 +647,8 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
           let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
               concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
               deps = mapM (depsForCase typeEnv env) concretelyTypedCases
-           in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation.
+              candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases }
+           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
diff --git a/src/Deftype.hs b/src/Deftype.hs
@@ -59,8 +59,13 @@ 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 = []}
    in do
-        validateMemberCases typeEnv env typeVariables rest
+        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})
+        --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
@@ -82,8 +87,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 = []}
    in do
-        validateMemberCases typeEnv env [] rest
+        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})
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
         (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
         okInit <- binderForInit insidePath structTy rest
diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs
@@ -11,31 +11,31 @@ data SumtypeCase = SumtypeCase
   }
   deriving (Show, Eq)
 
-toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
-toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars)
+toCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError [SumtypeCase]
+toCases typeEnv globalEnv candidate = mapM (toCase (typename candidate) typeEnv globalEnv (restriction candidate) (variables candidate)) (typemembers candidate)
 
-toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
-toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
+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 restriction typeEnv globalEnv typeVars t x) 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 = name,
+                      { caseName = pname,
                         caseTys = okTys
                       }
-toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
+toCase _ _ _ _ _ (XObj (Sym (SymPath [] pname) Symbol) _ _) =
   Right $
     SumtypeCase
-      { caseName = name,
+      { caseName = pname,
         caseTys = []
       }
-toCase _ _ _ _ x =
+toCase _ _ _ _ _ x =
   Left (InvalidSumtypeCase x)
diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs
@@ -17,7 +17,7 @@ import TypePredicates
 import Types
 import TypesToC
 import Util
-import Validate (TypeVarRestriction (..))
+import Validate (TypeVarRestriction (..), TypeCandidate (..))
 
 getCase :: [SumtypeCase] -> String -> Maybe SumtypeCase
 getCase cases caseNameToFind =
@@ -52,9 +52,10 @@ 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}
    in do
         let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
-        cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest
+        cases <- toCases typeEnv env candidate
         okIniters <- initers insidePath structTy cases
         okTag <- binderForTag insidePath structTy
         (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str"
diff --git a/src/Validate.hs b/src/Validate.hs
@@ -18,60 +18,79 @@ data TypeVarRestriction
   | AllowOnlyNamesInScope -- Used when checking a type definition, e.g. (deftype (Foo a) [x a]), requires a to be in scope
   deriving (Eq)
 
+-- | TypeCandidate represents a type that's possibly valid or invalid.
+data TypeCandidate = TypeCandidate {
+  -- the name of the type
+  typename :: String,
+  -- a list of all variables in the type head
+  variables :: [Ty],
+  -- all members of the type
+  typemembers :: [XObj],
+  -- what sort of type variables are permitted.
+  restriction :: TypeVarRestriction
+}
+
 -- | Make sure that the member declarations in a type definition
 -- | Follow the pattern [<name> <type>, <name> <type>, ...]
 -- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies.
-validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
-validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest
+validateMemberCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError ()
+validateMemberCases typeEnv globalEnv candidate = --mapM_ visit (members candidate)
+  validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope})
+  -- where
+  --  visit (XObj (Arr membersXObjs) _ _) =
+  --    validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope})
+  --  visit xobj =
+  --    Left (InvalidSumtypeCase xobj)
+
+validateMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError ()
+validateMembers typeEnv globalEnv candidate =
+  (checkUnevenMembers candidate) >>
+  (checkDuplicateMembers candidate) >>
+  (checkMembers typeEnv globalEnv candidate) >>
+  (checkKindConsistency candidate)
+
+-- | Returns an error if a type has an uneven number of members.
+checkUnevenMembers :: TypeCandidate -> Either TypeError ()
+checkUnevenMembers candidate =
+  if even (length (typemembers candidate))
+    then Right ()
+    else Left (UnevenMembers (typemembers candidate))
+
+-- | Returns an error if a type has more than one member with the same name.
+checkDuplicateMembers :: TypeCandidate -> Either TypeError ()
+checkDuplicateMembers candidate =
+  if length fields == length uniqueFields
+    then Right ()
+    else Left (DuplicatedMembers dups)
   where
-    visit (XObj (Arr membersXObjs) _ _) =
-      validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs
-    visit xobj =
-      Left (InvalidSumtypeCase xobj)
+    fields = fst <$> (pairwise (typemembers candidate))
+    uniqueFields = nubBy ((==) `on` xobjObj) fields
+    dups = fields \\ uniqueFields
 
-validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
-validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs =
-  checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency
+-- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds.
+checkKindConsistency :: TypeCandidate -> Either TypeError ()
+checkKindConsistency candidate =
+  case areKindsConsistent varsOnly of
+    Left var -> Left (InconsistentKinds var (typemembers candidate))
+    _ -> pure ()
   where
-    pairs = pairwise membersXObjs
-    -- Are the number of members even?
-    checkUnevenMembers :: Either TypeError ()
-    checkUnevenMembers =
-      if even (length membersXObjs)
-        then Right ()
-        else Left (UnevenMembers membersXObjs)
-    -- Are any members duplicated?
-    checkDuplicateMembers :: Either TypeError ()
-    checkDuplicateMembers =
-      if length fields == length uniqueFields
-        then Right ()
-        else Left (DuplicatedMembers dups)
-      where
-        fields = fst <$> pairs
-        uniqueFields = nubBy ((==) `on` xobjObj) fields
-        dups = fields \\ uniqueFields
-    -- Do all type variables have consistent kinds?
-    checkKindConsistency :: Either TypeError ()
-    checkKindConsistency =
-      case areKindsConsistent varsOnly of
-        Left var -> Left (InconsistentKinds var membersXObjs)
-        _ -> pure ()
-      where
-        -- fromJust is safe here; invalid types will be caught in the prior check.
-        -- todo? be safer anyway?
-        varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs)
-    checkMembers :: Either TypeError ()
-    checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv globalEnv typeVariables . snd) pairs
+    -- fromJust is safe here; invalid types will be caught in a prior check.
+    -- TODO: be safer.
+    varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) (pairwise (typemembers candidate)))
+
+-- | Returns an error if one of the types members can't be used as a member.
+checkMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError ()
+checkMembers typeEnv globalEnv candidate = mapM_ (okXObjForType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate) . snd) (pairwise (typemembers candidate))
 
-okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError ()
-okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj =
+okXObjForType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError ()
+okXObjForType tyname typeVarRestriction typeEnv globalEnv typeVariables xobj =
   case xobjToTy xobj of
-    Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj
+    Just t -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables t xobj
     Nothing -> Left (NotAType xobj)
 
 -- | Can this type be used as a member for a deftype?
-canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError ()
-canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj =
+canBeUsedAsMemberType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError ()
+canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables ty xobj =
   case ty of
     UnitTy -> pure ()
     IntTy -> pure ()
@@ -86,7 +105,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj
     FuncTy {} -> pure ()
     PointerTy UnitTy -> pure ()
     PointerTy inner ->
-      canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj
+      canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj
         >> pure ()
     -- Struct variables may appear as complete applications or individual
     -- components in the head of a definition; that is the forms:
@@ -105,23 +124,23 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj
     --     ((Foo (f a) (f b)) ...)
     -- differ.
     -- Attempt the first, more restrictive formulation first.
-    struct@(StructTy name tyVars) ->
-      checkVar struct <> checkStruct name tyVars
+    struct@(StructTy sname tyVars) ->
+      checkVar struct <> checkStruct sname tyVars
     v@(VarTy _) -> checkVar v
     _ -> Left (InvalidMemberType ty xobj)
   where
     checkStruct :: Ty -> [Ty] -> Either TypeError ()
     checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
-      canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj
+      canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj
         >> pure ()
-    checkStruct (ConcreteNameTy path@(SymPath _ name)) vars =
-      case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of
+    checkStruct (ConcreteNameTy path@(SymPath _ pname)) vars =
+      case E.getTypeBinder typeEnv pname <> E.findTypeBinder globalEnv path of
         Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
           pure ()
         Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
-          checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
+          checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
         Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
-          checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
+          checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
         _ -> Left (NotAmongRegisteredTypes ty xobj)
       where
         checkInhabitants :: Ty -> Either TypeError ()
@@ -131,8 +150,8 @@ canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj
             else Left (UninhabitedConstructor ty xobj (length vs) (length vars))
         checkInhabitants _ = Left (InvalidMemberType ty xobj)
     checkStruct v@(VarTy _) vars =
-      canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj
-        >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
+      canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables v xobj
+        >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
     checkStruct _ _ = error "checkstruct"
     checkVar :: Ty -> Either TypeError ()
     checkVar variable =
