Preparation for being able to fix bug with validation of generic members.

examples/bugs.carp

@@ -17,4 +17,7 @@
 
 ;; Instantiating generic struct with ref-type fails:
 (deftype (Triv a) [x a])
-(defn g [] (Triv.init "hej"))
+(defn g [] (Triv.init &123))
+
+(defn main []
+  (println* &(g)))

src/Concretize.hs

@@ -215,7 +215,7 @@ concretizeType _ t =
 
 -- | Given an generic struct type and a concrete version of it, generate all dependencies needed to use the concrete one.
 instantiateGenericStructType :: TypeEnv -> Ty -> Ty -> [XObj] -> [XObj]
-instantiateGenericStructType typeEnv originalStructTy genericStructTy membersXObjs =
+instantiateGenericStructType typeEnv originalStructTy@(StructTy _ originalTyVars) genericStructTy membersXObjs =
   -- Turn (deftype (A a) [x a, y a]) into (deftype (A Int) [x Int, y Int])
   let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
       fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
@@ -224,7 +224,10 @@ instantiateGenericStructType typeEnv originalStructTy genericStructTy membersXOb
         Left e -> error (show e)
         Right mappings ->
           let concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
-          in  [ XObj (Lst (XObj (Typ genericStructTy) Nothing Nothing :
+          in  case validateMembers typeEnv originalTyVars concretelyTypedMembers of
+                Left err -> error err
+                Right () ->
+                  [ XObj (Lst (XObj (Typ genericStructTy) Nothing Nothing :
                            XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
                            [(XObj (Arr concretelyTypedMembers) Nothing Nothing)])
                      ) (Just dummyInfo) (Just TypeTy)

src/Deftype.hs

@@ -27,7 +27,7 @@ moduleForDeftype 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 ++ [typeModuleName]
-  in do validateMembers typeEnv typeVariables rest
+  in do validateMemberCases typeEnv typeVariables rest
         let structTy = StructTy typeName typeVariables
         (okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
         okInit <- binderForInit insidePath structTy rest
@@ -49,7 +49,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i =
   let typeModuleName = typeName
       emptyTypeModuleEnv = Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv
       insidePath = pathStrings ++ [typeModuleName]
-  in do validateMembers typeEnv [] rest
+  in do validateMemberCases typeEnv [] rest
         let structTy = StructTy typeName []
         (binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
         okInit <- binderForInit insidePath structTy rest
@@ -59,49 +59,6 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i =
             typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
         return (typeModuleName, typeModuleXObj, deps ++ strDeps)
 
-{-# ANN validateMembers "HLint: ignore Eta reduce" #-}
--- | Make sure that the member declarations in a type definition
--- | Follow the pattern [<name> <type>, <name> <type>, ...]
--- | TODO: What a mess this function is, clean it up!
-validateMembers :: TypeEnv -> [Ty] -> [XObj] -> Either String ()
-validateMembers typeEnv typeVariables rest = mapM_ validateOneCase rest
-  where
-    validateOneCase :: XObj -> Either String ()
-    validateOneCase (XObj (Arr arr) _ _) =
-      if length arr `mod` 2 == 0
-      then mapM_ (okXObjForType . snd) (pairwise arr)
-      else Left "Uneven nr of members / types."
-    validateOneCase XObj {} =
-      Left "Type members must be defined using array syntax: [member1 type1 member2 type2 ...]"
-
-    okXObjForType :: XObj -> Either String ()
-    okXObjForType xobj =
-      case xobjToTy xobj of
-        Just t -> okMemberType t
-        Nothing -> Left ("Can't interpret this as a type: " ++ pretty xobj)
-
-    okMemberType :: Ty -> Either String ()
-    okMemberType t = case t of
-                       IntTy    -> return ()
-                       FloatTy  -> return ()
-                       DoubleTy -> return ()
-                       LongTy   -> return ()
-                       BoolTy   -> return ()
-                       StringTy -> return ()
-                       CharTy   -> return ()
-                       PointerTy inner -> do _ <- okMemberType inner
-                                             return ()
-                       StructTy "Array" [inner] -> do _ <- okMemberType inner
-                                                      return ()
-                       StructTy name tyVars ->
-                         case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
-                           Just _ -> return ()
-                           Nothing -> Left ("Can't find '" ++ name ++ "' among registered types.")
-                       VarTy _ -> if t `elem` typeVariables
-                                  then return ()
-                                  else Left ("Invalid type variable as member type: " ++ show t)
-                       _ -> Left ("Invalid member type: " ++ show t)
-
 
 
 -- | Generate all the templates for ALL the member variables in a deftype declaration.

src/Lookup.hs

@@ -6,6 +6,7 @@ import Data.Maybe (mapMaybe, fromMaybe, fromJust)
 
 import Types
 import Obj
+import Util
 
 -- | Find the Binder at a specified path.
 lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
@@ -180,3 +181,51 @@ isManaged typeEnv (StructTy name _) =
     )
 isManaged _ StringTy = True
 isManaged _ _ = False
+
+{-# ANN validateMembers "HLint: ignore Eta reduce" #-}
+-- | Make sure that the member declarations in a type definition
+-- | Follow the pattern [<name> <type>, <name> <type>, ...]
+validateMemberCases :: TypeEnv -> [Ty] -> [XObj] -> Either String ()
+validateMemberCases typeEnv typeVariables rest = mapM_ visit rest
+  where visit (XObj (Arr membersXObjs) _ _) =
+          validateMembers typeEnv typeVariables membersXObjs
+        visit xobj =
+          Left ("Invalid case in deftype: " ++ pretty xobj ++ " at " ++ prettyInfoFromXObj xobj)
+
+validateMembers :: TypeEnv -> [Ty] -> [XObj] -> Either String ()
+validateMembers typeEnv typeVariables membersXObjs =
+  if length membersXObjs `mod` 2 == 0
+  then mapM_ (okXObjForType typeEnv typeVariables . snd) (pairwise membersXObjs)
+  else Left ("Uneven nr of members / types: " ++ joinWithComma (map pretty membersXObjs))
+validateOneCase _ XObj {} =
+  Left "Type members must be defined using array syntax: [member1 type1 member2 type2 ...]"
+
+okXObjForType :: TypeEnv -> [Ty] -> XObj -> Either String ()
+okXObjForType typeEnv typeVariables xobj =
+  case xobjToTy xobj of
+    Just t -> canBeUsedAsMemberType typeEnv typeVariables t
+    Nothing -> Left ("Can't interpret this as a type: " ++ pretty xobj)
+
+-- | Can this type be used as a member for a deftype?
+canBeUsedAsMemberType :: TypeEnv -> [Ty] -> Ty -> Either String ()
+canBeUsedAsMemberType typeEnv typeVariables t =
+  case t of
+    IntTy    -> return ()
+    FloatTy  -> return ()
+    DoubleTy -> return ()
+    LongTy   -> return ()
+    BoolTy   -> return ()
+    StringTy -> return ()
+    CharTy   -> return ()
+    PointerTy inner -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner
+                          return ()
+    StructTy "Array" [inner] -> do _ <- canBeUsedAsMemberType typeEnv typeVariables inner
+                                   return ()
+    StructTy name tyVars ->
+      case lookupInEnv (SymPath [] name) (getTypeEnv typeEnv) of
+        Just _ -> return ()
+        Nothing -> Left ("Can't find '" ++ name ++ "' among registered types.")
+    VarTy _ -> if t `elem` typeVariables
+               then return ()
+               else Left ("Invalid type variable as member type: " ++ show t)
+    _ -> Left ("Invalid member type: " ++ show t)