From ae2186f4b7bfac1034c70762431eb543905ad22f Mon Sep 17 00:00:00 2001 From: Scott Olsen Date: Sat, 4 Sep 2021 07:27:48 -0500 Subject: [PATCH] fix: Allow types defined in modules to be members (#1303) 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). --- src/Concretize.hs | 4 ++-- src/Deftype.hs | 4 ++-- src/SumtypeCase.hs | 14 +++++++------- src/Sumtypes.hs | 2 +- src/Validate.hs | 38 +++++++++++++++++++------------------- 5 files changed, 31 insertions(+), 31 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index 11686164..7b4a5462 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -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 diff --git a/src/Deftype.hs b/src/Deftype.hs index 699ce631..c4dbc87d 100644 --- a/src/Deftype.hs +++ b/src/Deftype.hs @@ -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 diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs index 5e0bf26f..43cf45c8 100644 --- a/src/SumtypeCase.hs +++ b/src/SumtypeCase.hs @@ -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) diff --git a/src/Sumtypes.hs b/src/Sumtypes.hs index 2cceaf68..113b0097 100644 --- a/src/Sumtypes.hs +++ b/src/Sumtypes.hs @@ -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" diff --git a/src/Validate.hs b/src/Validate.hs index 43a3fd90..7b810a8a 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -21,16 +21,16 @@ data TypeVarRestriction -- | Make sure that the member declarations in a type definition -- | Follow the pattern [ , , ...] -- | 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 =