From 500c2a857b7aab103c073ea44bd2c6e675c28d36 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Erik=20Sved=C3=A4ng?= Date: Thu, 1 Feb 2018 18:32:59 +0100 Subject: [PATCH] Preparation for being able to fix bug with validation of generic members. --- examples/bugs.carp | 5 ++++- src/Concretize.hs | 17 +++++++++------- src/Deftype.hs | 47 ++------------------------------------------ src/Lookup.hs | 49 ++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 65 insertions(+), 53 deletions(-) diff --git a/examples/bugs.carp b/examples/bugs.carp index 22ce8382..f1766c4c 100644 --- a/examples/bugs.carp +++ b/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))) diff --git a/src/Concretize.hs b/src/Concretize.hs index ac84de69..b2062981 100644 --- a/src/Concretize.hs +++ b/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,15 +224,18 @@ 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) - ] - ++ concatMap (\(v, tyXObj) -> case (xobjToTy tyXObj) of - Just okTy -> concretizeType typeEnv okTy - Nothing -> error ("Failed to convert " ++ pretty tyXObj ++ "to a type.")) - (pairwise concretelyTypedMembers) + ] + ++ concatMap (\(v, tyXObj) -> case (xobjToTy tyXObj) of + Just okTy -> concretizeType typeEnv okTy + Nothing -> error ("Failed to convert " ++ pretty tyXObj ++ "to a type.")) + (pairwise concretelyTypedMembers) -- | Get the type of a symbol at a given path. typeFromPath :: Env -> SymPath -> Ty diff --git a/src/Deftype.hs b/src/Deftype.hs index a4e85796..381dd6f8 100644 --- a/src/Deftype.hs +++ b/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 [ , , ...] --- | 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. diff --git a/src/Lookup.hs b/src/Lookup.hs index 076ef2aa..ad21a90b 100644 --- a/src/Lookup.hs +++ b/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 [ , , ...] +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)