carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-17 16:38:14 +03:00
Code Issues Projects Releases Wiki Activity

fix: Allow types defined in modules to be members (#1303)

Browse Source 
This commit fixes issue #1302, whereby types defined in modules were not
recognized as valid member types by our validation routines.

We simply need to account for types defined in modules in the global
env, threading the global env along through validation (previously we
only passed the top-level type env, which contains no modules).
This commit is contained in:
Scott Olsen 2021-09-04 07:27:48 -05:00 committed by GitHub
parent 03b453cb36
commit ae2186f4b7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
5 changed files with 31 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
src/Concretize.hs
View File

@ -612,7 +612,7 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic
let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers
deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
let xobj = let xobj =
XObj XObj
@ -646,7 +646,7 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
deps = mapM (depsForCase typeEnv env) concretelyTypedCases deps = mapM (depsForCase typeEnv env) concretelyTypedCases
in case toCases typeEnv AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation. in case toCases typeEnv env AllowAnyTypeVariableNames renamedOrig concretelyTypedCases of -- Don't care about the cases, this is done just for validation.
Left err -> Left err Left err -> Left err
Right _ -> Right _ ->
case deps of case deps of

4
src/Deftype.hs
View File

@ -60,7 +60,7 @@ moduleForDeftype innerEnv typeEnv env pathStrings typeName typeVariables rest i
-- 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 ++ [typeName] insidePath = pathStrings ++ [typeName]
in do in do
validateMemberCases typeEnv typeVariables rest validateMemberCases typeEnv env typeVariables rest
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables let structTy = StructTy (ConcreteNameTy (SymPath pathStrings 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
@ -83,7 +83,7 @@ bindingsForRegisteredType typeEnv env pathStrings typeName rest i existingEnv =
moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv) moduleTypeEnv = fromMaybe (new (Just typeEnv) (Just typeName)) (fmap snd existingEnv)
insidePath = pathStrings ++ [typeName] insidePath = pathStrings ++ [typeName]
in do in do
validateMemberCases typeEnv [] rest validateMemberCases typeEnv env [] rest
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) [] let structTy = StructTy (ConcreteNameTy (SymPath pathStrings 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

14
src/SumtypeCase.hs
View File

@ -11,17 +11,17 @@ data SumtypeCase = SumtypeCase
} }
deriving (Show, Eq) deriving (Show, Eq)
toCases :: TypeEnv -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase] toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv restriction typeVars = mapM (toCase typeEnv restriction typeVars) toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars)
toCase :: TypeEnv -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
let tys = map xobjToTy tyXObjs let tys = map xobjToTy tyXObjs
in case sequence tys of in case sequence tys of
Nothing -> Nothing ->
Left (InvalidSumtypeCase x) Left (InvalidSumtypeCase x)
Just okTys -> Just okTys ->
let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv typeVars t x) okTys let validated = map (\t -> canBeUsedAsMemberType restriction typeEnv globalEnv typeVars t x) okTys
in case sequence validated of in case sequence validated of
Left e -> Left e ->
Left e Left e
@ -31,11 +31,11 @@ toCase typeEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Sy
{ caseName = name, { caseName = name,
caseTys = okTys caseTys = okTys
} }
toCase _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) = toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
Right $ Right $
SumtypeCase SumtypeCase
{ caseName = name, { caseName = name,
caseTys = [] caseTys = []
} }
toCase _ _ _ x = toCase _ _ _ _ x =
Left (InvalidSumtypeCase x) Left (InvalidSumtypeCase x)

2
src/Sumtypes.hs
View File

@ -54,7 +54,7 @@ moduleForSumtype innerEnv typeEnv env pathStrings typeName typeVariables rest i
insidePath = pathStrings ++ [typeName] insidePath = pathStrings ++ [typeName]
in do in do
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
cases <- toCases typeEnv AllowOnlyNamesInScope typeVariables rest cases <- toCases typeEnv env AllowOnlyNamesInScope typeVariables rest
okIniters <- initers insidePath structTy cases okIniters <- initers insidePath structTy cases
okTag <- binderForTag insidePath structTy okTag <- binderForTag insidePath structTy
(okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str" (okStr, okStrDeps) <- binderForStrOrPrn typeEnv env insidePath structTy cases "str"

38
src/Validate.hs
View File

@ -21,16 +21,16 @@ data TypeVarRestriction
-- | Make sure that the member declarations in a type definition -- | Make sure that the member declarations in a type definition
-- | Follow the pattern [<name> <type>, <name> <type>, ...] -- | 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. -- | TODO: This function is only called by the deftype parts of the codebase, which is more specific than the following check implies.
validateMemberCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError () validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
validateMemberCases typeEnv typeVariables rest = mapM_ visit rest validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest
where where
visit (XObj (Arr membersXObjs) _ _) = visit (XObj (Arr membersXObjs) _ _) =
validateMembers AllowOnlyNamesInScope typeEnv typeVariables membersXObjs validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs
visit xobj = visit xobj =
Left (InvalidSumtypeCase xobj) Left (InvalidSumtypeCase xobj)
validateMembers :: TypeVarRestriction -> TypeEnv -> [Ty] -> [XObj] -> Either TypeError () validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
validateMembers typeVarRestriction typeEnv typeVariables membersXObjs = validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs =
checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency
where where
pairs = pairwise membersXObjs pairs = pairwise membersXObjs
@ -61,17 +61,17 @@ validateMembers typeVarRestriction typeEnv typeVariables membersXObjs =
-- todo? be safer anyway? -- todo? be safer anyway?
varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs) varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs)
checkMembers :: Either TypeError () checkMembers :: Either TypeError ()
checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv typeVariables . snd) pairs checkMembers = mapM_ (okXObjForType typeVarRestriction typeEnv globalEnv typeVariables . snd) pairs
okXObjForType :: TypeVarRestriction -> TypeEnv -> [Ty] -> XObj -> Either TypeError () okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError ()
okXObjForType typeVarRestriction typeEnv typeVariables xobj = okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj =
case xobjToTy xobj of case xobjToTy xobj of
Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables t xobj Just t -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables t xobj
Nothing -> Left (NotAType xobj) Nothing -> Left (NotAType xobj)
-- | Can this type be used as a member for a deftype? -- | Can this type be used as a member for a deftype?
canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError () canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError ()
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj = canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj =
case ty of case ty of
UnitTy -> pure () UnitTy -> pure ()
IntTy -> pure () IntTy -> pure ()
@ -86,7 +86,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
FuncTy {} -> pure () FuncTy {} -> pure ()
PointerTy UnitTy -> pure () PointerTy UnitTy -> pure ()
PointerTy inner -> PointerTy inner ->
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables inner xobj canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj
>> pure () >> pure ()
-- Struct variables may appear as complete applications or individual -- Struct variables may appear as complete applications or individual
-- components in the head of a definition; that is the forms: -- components in the head of a definition; that is the forms:
@ -112,16 +112,16 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
where where
checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct :: Ty -> [Ty] -> Either TypeError ()
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables innerType xobj canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj
>> pure () >> pure ()
checkStruct (ConcreteNameTy (SymPath _ name)) vars = checkStruct (ConcreteNameTy path@(SymPath _ name)) vars =
case E.getTypeBinder typeEnv name of case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
pure () pure ()
Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) ->
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) ->
checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
_ -> Left (NotAmongRegisteredTypes ty xobj) _ -> Left (NotAmongRegisteredTypes ty xobj)
where where
checkInhabitants :: Ty -> Either TypeError () checkInhabitants :: Ty -> Either TypeError ()
@ -131,8 +131,8 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
else Left (UninhabitedConstructor ty xobj (length vs) (length vars)) else Left (UninhabitedConstructor ty xobj (length vs) (length vars))
checkInhabitants _ = Left (InvalidMemberType ty xobj) checkInhabitants _ = Left (InvalidMemberType ty xobj)
checkStruct v@(VarTy _) vars = checkStruct v@(VarTy _) vars =
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables v xobj canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj
>> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars >> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
checkStruct _ _ = error "checkstruct" checkStruct _ _ = error "checkstruct"
checkVar :: Ty -> Either TypeError () checkVar :: Ty -> Either TypeError ()
checkVar variable = checkVar variable =