mirror of
https://github.com/carp-lang/Carp.git
synced 2024-10-11 12:37:32 +03:00
Preparation for being able to fix bug with validation of generic members.
This commit is contained in:
parent
9e6eb88194
commit
500c2a857b
@ -17,4 +17,7 @@
|
|||||||
|
|
||||||
;; Instantiating generic struct with ref-type fails:
|
;; Instantiating generic struct with ref-type fails:
|
||||||
(deftype (Triv a) [x a])
|
(deftype (Triv a) [x a])
|
||||||
(defn g [] (Triv.init "hej"))
|
(defn g [] (Triv.init &123))
|
||||||
|
|
||||||
|
(defn main []
|
||||||
|
(println* &(g)))
|
||||||
|
@ -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.
|
-- | 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 -> 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])
|
-- 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
|
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
|
||||||
fake2 = XObj (Sym (SymPath [] "b") 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)
|
Left e -> error (show e)
|
||||||
Right mappings ->
|
Right mappings ->
|
||||||
let concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
|
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 (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
|
||||||
[(XObj (Arr concretelyTypedMembers) Nothing Nothing)])
|
[(XObj (Arr concretelyTypedMembers) Nothing Nothing)])
|
||||||
) (Just dummyInfo) (Just TypeTy)
|
) (Just dummyInfo) (Just TypeTy)
|
||||||
]
|
]
|
||||||
++ concatMap (\(v, tyXObj) -> case (xobjToTy tyXObj) of
|
++ concatMap (\(v, tyXObj) -> case (xobjToTy tyXObj) of
|
||||||
Just okTy -> concretizeType typeEnv okTy
|
Just okTy -> concretizeType typeEnv okTy
|
||||||
Nothing -> error ("Failed to convert " ++ pretty tyXObj ++ "to a type."))
|
Nothing -> error ("Failed to convert " ++ pretty tyXObj ++ "to a type."))
|
||||||
(pairwise concretelyTypedMembers)
|
(pairwise concretelyTypedMembers)
|
||||||
|
|
||||||
-- | Get the type of a symbol at a given path.
|
-- | Get the type of a symbol at a given path.
|
||||||
typeFromPath :: Env -> SymPath -> Ty
|
typeFromPath :: Env -> SymPath -> Ty
|
||||||
|
@ -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'.
|
-- 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.
|
-- For example (module Vec2 [x Float]) creates bindings like Vec2.create, Vec2.x, etc.
|
||||||
insidePath = pathStrings ++ [typeModuleName]
|
insidePath = pathStrings ++ [typeModuleName]
|
||||||
in do validateMembers typeEnv typeVariables rest
|
in do validateMemberCases typeEnv typeVariables rest
|
||||||
let structTy = StructTy typeName typeVariables
|
let structTy = StructTy typeName typeVariables
|
||||||
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
|
(okMembers, membersDeps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||||
okInit <- binderForInit insidePath structTy rest
|
okInit <- binderForInit insidePath structTy rest
|
||||||
@ -49,7 +49,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i =
|
|||||||
let typeModuleName = typeName
|
let typeModuleName = typeName
|
||||||
emptyTypeModuleEnv = Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv
|
emptyTypeModuleEnv = Env (Map.fromList []) (Just env) (Just typeModuleName) [] ExternalEnv
|
||||||
insidePath = pathStrings ++ [typeModuleName]
|
insidePath = pathStrings ++ [typeModuleName]
|
||||||
in do validateMembers typeEnv [] rest
|
in do validateMemberCases typeEnv [] rest
|
||||||
let structTy = StructTy typeName []
|
let structTy = StructTy typeName []
|
||||||
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
|
||||||
okInit <- binderForInit 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)
|
typeModuleXObj = XObj (Mod moduleEnvWithBindings) i (Just ModuleTy)
|
||||||
return (typeModuleName, typeModuleXObj, deps ++ strDeps)
|
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.
|
-- | Generate all the templates for ALL the member variables in a deftype declaration.
|
||||||
|
@ -6,6 +6,7 @@ import Data.Maybe (mapMaybe, fromMaybe, fromJust)
|
|||||||
|
|
||||||
import Types
|
import Types
|
||||||
import Obj
|
import Obj
|
||||||
|
import Util
|
||||||
|
|
||||||
-- | Find the Binder at a specified path.
|
-- | Find the Binder at a specified path.
|
||||||
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
|
lookupInEnv :: SymPath -> Env -> Maybe (Env, Binder)
|
||||||
@ -180,3 +181,51 @@ isManaged typeEnv (StructTy name _) =
|
|||||||
)
|
)
|
||||||
isManaged _ StringTy = True
|
isManaged _ StringTy = True
|
||||||
isManaged _ _ = False
|
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)
|
||||||
|
Loading…
Reference in New Issue
Block a user