carp-lang/Carp
1
1
Fork 0
mirror of https://github.com/carp-lang/Carp.git synced 2024-09-11 05:25:28 +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
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
validateMembers AllowAnyTypeVariableNames typeEnv renamedOrig validMembers
validateMembers AllowAnyTypeVariableNames typeEnv env renamedOrig validMembers
deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
let xobj =
XObj
@ -646,7 +646,7 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
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
Right _ ->
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.
insidePath = pathStrings ++ [typeName]
in do
validateMemberCases typeEnv typeVariables rest
validateMemberCases typeEnv env typeVariables rest
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) typeVariables
(okMembers, membersDeps) <- templatesForMembers typeEnv env 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)
insidePath = pathStrings ++ [typeName]
in do
validateMemberCases typeEnv [] rest
validateMemberCases typeEnv env [] rest
let structTy = StructTy (ConcreteNameTy (SymPath pathStrings typeName)) []
(binders, deps) <- templatesForMembers typeEnv env insidePath structTy rest
okInit <- binderForInit insidePath structTy rest

14
src/SumtypeCase.hs
View File

@ -11,17 +11,17 @@ data SumtypeCase = SumtypeCase
}
deriving (Show, Eq)
toCases :: TypeEnv -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv restriction typeVars = mapM (toCase typeEnv restriction typeVars)
toCases :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> [XObj] -> Either TypeError [SumtypeCase]
toCases typeEnv globalEnv restriction typeVars = mapM (toCase typeEnv globalEnv restriction typeVars)
toCase :: TypeEnv -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
toCase :: TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
toCase typeEnv globalEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
let tys = map xobjToTy tyXObjs
in case sequence tys of
Nothing ->
Left (InvalidSumtypeCase x)
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
Left e ->
Left e
@ -31,11 +31,11 @@ toCase typeEnv restriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] name) Sy
{ caseName = name,
caseTys = okTys
}
toCase _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
toCase _ _ _ _ (XObj (Sym (SymPath [] name) Symbol) _ _) =
Right $
SumtypeCase
{ caseName = name,
caseTys = []
}
toCase _ _ _ x =
toCase _ _ _ _ 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]
in do
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
okTag <- binderForTag insidePath structTy
(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
-- | 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.
validateMemberCases :: TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
validateMemberCases typeEnv typeVariables rest = mapM_ visit rest
validateMemberCases :: TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
validateMemberCases typeEnv globalEnv typeVariables rest = mapM_ visit rest
where
visit (XObj (Arr membersXObjs) _ _) =
validateMembers AllowOnlyNamesInScope typeEnv typeVariables membersXObjs
validateMembers AllowOnlyNamesInScope typeEnv globalEnv typeVariables membersXObjs
visit xobj =
Left (InvalidSumtypeCase xobj)
validateMembers :: TypeVarRestriction -> TypeEnv -> [Ty] -> [XObj] -> Either TypeError ()
validateMembers typeVarRestriction typeEnv typeVariables membersXObjs =
validateMembers :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> [XObj] -> Either TypeError ()
validateMembers typeVarRestriction typeEnv globalEnv typeVariables membersXObjs =
checkUnevenMembers >> checkDuplicateMembers >> checkMembers >> checkKindConsistency
where
pairs = pairwise membersXObjs
@ -61,17 +61,17 @@ validateMembers typeVarRestriction typeEnv typeVariables membersXObjs =
-- todo? be safer anyway?
varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) pairs)
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 typeVariables xobj =
okXObjForType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError ()
okXObjForType typeVarRestriction typeEnv globalEnv typeVariables xobj =
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)
-- | Can this type be used as a member for a deftype?
canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> [Ty] -> Ty -> XObj -> Either TypeError ()
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
canBeUsedAsMemberType :: TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError ()
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables ty xobj =
case ty of
UnitTy -> pure ()
IntTy -> pure ()
@ -86,7 +86,7 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
FuncTy {} -> pure ()
PointerTy UnitTy -> pure ()
PointerTy inner ->
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables inner xobj
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables inner xobj
>> pure ()
-- Struct variables may appear as complete applications or individual
-- components in the head of a definition; that is the forms:
@ -112,16 +112,16 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
where
checkStruct :: Ty -> [Ty] -> Either TypeError ()
checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] =
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables innerType xobj
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables innerType xobj
>> pure ()
checkStruct (ConcreteNameTy (SymPath _ name)) vars =
case E.getTypeBinder typeEnv name of
checkStruct (ConcreteNameTy path@(SymPath _ name)) vars =
case E.getTypeBinder typeEnv name <> E.findTypeBinder globalEnv path of
Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) ->
pure ()
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) _ _ : _)) _ _)) ->
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)
where
checkInhabitants :: Ty -> Either TypeError ()
@ -131,8 +131,8 @@ canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables ty xobj =
else Left (UninhabitedConstructor ty xobj (length vs) (length vars))
checkInhabitants _ = Left (InvalidMemberType ty xobj)
checkStruct v@(VarTy _) vars =
canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables v xobj
>> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv typeVariables typ xobj) () vars
canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables v xobj
>> foldM (\_ typ -> canBeUsedAsMemberType typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars
checkStruct _ _ = error "checkstruct"
checkVar :: Ty -> Either TypeError ()
checkVar variable =