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:
|
||||
(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.
|
||||
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)
|
||||
|
@ -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.
|
||||
|
@ -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)
|
||||
|
Loading…
Reference in New Issue
Block a user