From b951a9af6eb3f6048c1be4fe66814bef60707e03 Mon Sep 17 00:00:00 2001 From: scottolsen Date: Tue, 26 Oct 2021 17:27:56 -0400 Subject: [PATCH] refactor: CHECKPOINT! Broken build. refactoring type candidates --- src/Concretize.hs | 44 ++++++++++------------- src/RecType.hs | 34 ++++++++++++++---- src/SumtypeCase.hs | 36 ++++++------------- src/TypeCandidate.hs | 55 ++++++++++++++++++++++++++++- src/TypeError.hs | 8 +++-- src/Validate.hs | 83 ++++++++++++++++++-------------------------- 6 files changed, 150 insertions(+), 110 deletions(-) diff --git a/src/Concretize.hs b/src/Concretize.hs index e02792653..bed846c7d 100644 --- a/src/Concretize.hs +++ b/src/Concretize.hs @@ -613,8 +613,8 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs - candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env } - validateMembers typeEnv env candidate + candidate <- (fromDeftype (getStructName originalStructTy) renamedOrig typeEnv env validMembers) + validateMembers (candidate {restriction = AllowAnyTypeVariableNames}) deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers) let xobj = XObj @@ -642,30 +642,22 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0 - in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of - Left e -> error (show e) - Right mappings -> - let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases - concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases - deps = mapM (depsForCase typeEnv env) concretelyTypedCases - candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env } - in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation. - Left err -> Left err - Right _ -> - case deps of - Right okDeps -> - Right $ - XObj - ( Lst - ( XObj (DefSumtype genericStructTy) Nothing Nothing : - XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : - concretelyTypedCases - ) - ) - (Just dummyInfo) - (Just TypeTy) : - concat okDeps - Left err -> Left err + in do mappings <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym]) + let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases + concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases + candidate <- fromSumtype (getStructName originalStructTy) renamedOrig typeEnv env concretelyTypedCases + _ <- toCases typeEnv env (candidate {restriction = AllowAnyTypeVariableNames}) + deps <- mapM (depsForCase typeEnv env) concretelyTypedCases + pure (XObj + ( Lst + ( XObj (DefSumtype genericStructTy) Nothing Nothing : + XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing : + concretelyTypedCases + ) + ) + (Just dummyInfo) + (Just TypeTy) : + concat deps) instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype" -- Resolves dependencies for sumtype cases. diff --git a/src/RecType.hs b/src/RecType.hs index 448ab78d9..e9291e079 100644 --- a/src/RecType.hs +++ b/src/RecType.hs @@ -1,3 +1,4 @@ +-- | Module RecType defines routines for working with recursive data types. module RecType ( recursiveMembersToPointers, @@ -24,6 +25,32 @@ import Concretize import ToTemplate import Validate +-- | Returns true if a type candidate is recursive. +-- +-- (deftype IntList [Int IntList]) --> True +-- (deftype IntList (Nil []) (Cons [Int IntList])) --> True +-- (deftype IntList [Int (Box IntList)]) --> True +--isRecursive :: TypeCandidate -> Bool +--isRecurisve TypeCandidate{typename=name,variables=vs,typemembers=ms} = +-- let memberTypes = map xobjToTy +-- case vs of +-- [] -> any concreteRecursion ms +-- _ -> any genericRecursion ms +-- where concreteRecursion :: XObj -> Bool +-- concreteRecursion (XObj (Lst xs) _ _) = any concreteRecursion xs +-- concreteRecursion (XObj (Sym (SymPath _ n) _) _ _) = n == name +-- concreteRecursion _ = False +-- +-- genericRecursion :: XObj -> Bool +-- genericRecursion (XObj (Lst xs) _ _) = +-- genericRecursion _ = False + +isRecursive :: Ty -> XObj -> Bool +isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path +isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs +isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs +isRecursive _ _ = False + -------------------------------------------------------------------------------- -- Base indirection recursion @@ -61,13 +88,6 @@ recInterfaceConstraints t = InterfaceConstraint "alloc" [(FuncTy [(head members)] t StaticLifetimeTy)] ] --- | Returns true if a type member xobj is recursive (either through indirect recursion or "value" recursion) -isRecursive :: Ty -> XObj -> Bool -isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path -isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs -isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs -isRecursive _ _ = False - -------------------------------------------------------------------------------- -- **Value recursion sugar** -- diff --git a/src/SumtypeCase.hs b/src/SumtypeCase.hs index b995db5c7..9d69a1cf3 100644 --- a/src/SumtypeCase.hs +++ b/src/SumtypeCase.hs @@ -15,28 +15,14 @@ data SumtypeCase = SumtypeCase toCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError [SumtypeCase] toCases typeEnv globalEnv candidate = mapM (toCase (typename candidate) typeEnv globalEnv (restriction candidate) (variables candidate)) (typemembers candidate) -toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase -toCase tyname typeEnv globalEnv varrestriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] pname) 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 tyname varrestriction typeEnv globalEnv typeVars t x) okTys - in case sequence validated of - Left e -> - Left e - Right _ -> - Right $ - SumtypeCase - { caseName = pname, - caseTys = okTys - } -toCase _ _ _ _ _ (XObj (Sym (SymPath [] pname) Symbol) _ _) = - Right $ - SumtypeCase - { caseName = pname, - caseTys = [] - } -toCase _ _ _ _ _ x = - Left (InvalidSumtypeCase x) +toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> (String, [Ty]) -> Either TypeError SumtypeCase +toCase tyname typeEnv globalEnv varrestriction typeVars member = + let validated = mapM (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t) (snd member) + in case validated of + Left e -> Left e + Right _ -> + Right $ + SumtypeCase + { caseName = fst member, + caseTys = snd member + } diff --git a/src/TypeCandidate.hs b/src/TypeCandidate.hs index 9154b4985..0876561e0 100644 --- a/src/TypeCandidate.hs +++ b/src/TypeCandidate.hs @@ -1,7 +1,12 @@ module TypeCandidate where import Types +import TypeError import Obj +import Util + +-------------------------------------------------------------------------------- +-- Data types data TypeVarRestriction = AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a' @@ -20,7 +25,7 @@ data TypeCandidate = TypeCandidate { -- a list of all variables in the type head variables :: [Ty], -- all members of the type - typemembers :: [XObj], + typemembers :: [(String, [Ty])], -- what sort of type variables are permitted. restriction :: TypeVarRestriction, -- what interfaces should types satisfy @@ -28,3 +33,51 @@ data TypeCandidate = TypeCandidate { candidateTypeEnv :: TypeEnv, candidateEnv :: Env } + +-------------------------------------------------------------------------------- +-- Constructors + +-- | Constructs a type candidate from the members of a product type definition. +fromDeftype :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> Either TypeError TypeCandidate +fromDeftype name vars tenv env members = + let tMembers = mapM go (pairwise members) + candidate = TypeCandidate { + typename = name, + variables = vars, + typemembers = [], + interfaceConstraints = [], + restriction = AllowOnlyNamesInScope, + candidateTypeEnv = tenv, + candidateEnv = env + } + in if even (length members) + then fmap (\ms -> candidate {typemembers = ms}) tMembers + else Left (UnevenMembers members) + where go :: (XObj, XObj) -> Either TypeError (String, [Ty]) + go ((XObj (Sym (SymPath [] fieldname) _) _ _), tyx) = + case xobjToTy tyx of + Just t -> Right (fieldname, [t]) + Nothing -> Left (NotAType tyx) + go (x, _) = Left (InvalidProductField x) + +-- | Constructs a type candidate from the members of a sum type definition. +fromSumtype :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> Either TypeError TypeCandidate +fromSumtype name vars tenv env members = + let tMembers = mapM go members + candidate = TypeCandidate { + typename = name, + variables = vars, + typemembers = [], + interfaceConstraints = [], + restriction = AllowOnlyNamesInScope, + candidateTypeEnv = tenv, + candidateEnv = env + } + in fmap (\ms -> candidate {typemembers = ms}) tMembers + where go :: XObj -> Either TypeError (String, [Ty]) + go x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) = + case mapM xobjToTy tyXObjs of + Just ts -> Right (pname, ts) + Nothing -> Left (InvalidSumtypeCase x) + go (XObj (Sym (SymPath [] pname) Symbol) _ _) = Right (pname, []) + go x = Left (InvalidSumtypeCase x) diff --git a/src/TypeError.hs b/src/TypeError.hs index 837f3114b..718f9baed 100644 --- a/src/TypeError.hs +++ b/src/TypeError.hs @@ -9,7 +9,6 @@ import Obj import Project import Text.EditDistance (defaultEditCosts, levenshteinDistance) import Types -import TypeCandidate import Util data TypeError @@ -63,7 +62,8 @@ data TypeError | InconsistentKinds String [XObj] | FailedToAddLambdaStructToTyEnv SymPath XObj | FailedToInstantiateGenericType Ty - | InterfaceNotImplemented [InterfaceConstraint] + | InterfaceNotImplemented [String] + | InvalidProductField XObj instance Show TypeError where show (InterfaceNotImplemented is) = @@ -283,6 +283,10 @@ instance Show TypeError where "I failed to read `" ++ pretty xobj ++ "` as a sumtype case at " ++ prettyInfoFromXObj xobj ++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`" + show (InvalidProductField xobj) = + "I failed to read `" ++ pretty xobj ++ "` as a product field at " + ++ prettyInfoFromXObj xobj + ++ ".\n\nProduct fields look like this: `[field-name Int]`" show (InvalidMemberType t xobj) = "I can’t use the type `" ++ show t ++ "` as a member type at " ++ prettyInfoFromXObj xobj diff --git a/src/Validate.hs b/src/Validate.hs index 5193d6bf2..ffae81724 100644 --- a/src/Validate.hs +++ b/src/Validate.hs @@ -1,85 +1,73 @@ module Validate where import Control.Monad (foldM) -import Data.Function (on) import Data.List (nubBy, (\\)) -import Data.Maybe (fromJust) import qualified Env as E import Obj import TypeError import TypePredicates import Types -import Util import TypeCandidate import Interfaces +import Reify {-# ANN validateMemberCases "HLint: ignore Eta reduce" #-} -- | 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 -> Env -> TypeCandidate -> Either TypeError () -validateMemberCases typeEnv globalEnv candidate = - validateMembers typeEnv globalEnv (candidate {restriction = AllowOnlyNamesInScope}) +validateMemberCases :: TypeCandidate -> Either TypeError () +validateMemberCases candidate = + validateMembers (candidate {restriction = AllowOnlyNamesInScope}) -validateMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () -validateMembers typeEnv globalEnv candidate = - (checkUnevenMembers candidate) >> +-- | Validates whether or not all the members of a type candidate can be used as member types. +validateMembers :: TypeCandidate -> Either TypeError () +validateMembers candidate = (checkDuplicateMembers candidate) >> - (checkMembers typeEnv globalEnv candidate) >> + (checkMembers (candidateTypeEnv candidate) (candidateEnv candidate) candidate) >> (checkKindConsistency candidate) +-- | Validates whether or not a candidate's types implement interfaces. validateInterfaceConstraints :: TypeCandidate -> Either TypeError () validateInterfaceConstraints candidate = let impls = map go (interfaceConstraints candidate) in if all (==True) impls then Right () - else Left $ InterfaceNotImplemented (interfaceConstraints candidate) + else Left $ InterfaceNotImplemented (map interfaceName (interfaceConstraints candidate)) where go ic = all (interfaceImplementedForTy (candidateTypeEnv candidate) (candidateEnv candidate) (interfaceName ic)) (types ic) --- | Returns an error if a type has an uneven number of members. -checkUnevenMembers :: TypeCandidate -> Either TypeError () -checkUnevenMembers candidate = - if even (length (typemembers candidate)) - then Right () - else Left (UnevenMembers (typemembers candidate)) +-------------------------------------------------------------------------------- +-- Private -- | Returns an error if a type has more than one member with the same name. checkDuplicateMembers :: TypeCandidate -> Either TypeError () checkDuplicateMembers candidate = if length fields == length uniqueFields then Right () - else Left (DuplicatedMembers dups) + else Left (DuplicatedMembers (map symbol dups)) where - fields = fst <$> (pairwise (typemembers candidate)) - uniqueFields = nubBy ((==) `on` xobjObj) fields + fields = fmap fst (typemembers candidate) + uniqueFields = nubBy (==) fields dups = fields \\ uniqueFields -- | Returns an error if the type variables in the body of the type and variables in the head of the type are of incompatible kinds. checkKindConsistency :: TypeCandidate -> Either TypeError () checkKindConsistency candidate = case areKindsConsistent varsOnly of - Left var -> Left (InconsistentKinds var (typemembers candidate)) + Left var -> Left (InconsistentKinds var (map reify (concat (map snd (typemembers candidate))))) _ -> pure () where - -- fromJust is safe here; invalid types will be caught in a prior check. - -- TODO: be safer. - varsOnly = filter isTypeGeneric (map (fromJust . xobjToTy . snd) (pairwise (typemembers candidate))) + varsOnly = filter isTypeGeneric $ concat (map snd (typemembers candidate)) -- | Returns an error if one of the types members can't be used as a member. checkMembers :: TypeEnv -> Env -> TypeCandidate -> Either TypeError () checkMembers typeEnv globalEnv candidate = - mapM_ (okXObjForType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate) . snd) (pairwise (typemembers candidate)) - -okXObjForType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> XObj -> Either TypeError () -okXObjForType tyname typeVarRestriction typeEnv globalEnv typeVariables xobj = - case xobjToTy xobj of - Just t -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables t xobj - Nothing -> Left (NotAType xobj) + let tys = concat $ map snd (typemembers candidate) + in mapM_ (canBeUsedAsMemberType (typename candidate) (restriction candidate) typeEnv globalEnv (variables candidate)) tys -- | Can this type be used as a member for a deftype? -canBeUsedAsMemberType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> XObj -> Either TypeError () -canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables ty xobj = +canBeUsedAsMemberType :: String -> TypeVarRestriction -> TypeEnv -> Env -> [Ty] -> Ty -> Either TypeError () +canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables ty = case ty of UnitTy -> pure () IntTy -> pure () @@ -94,11 +82,8 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables FuncTy {} -> pure () PointerTy UnitTy -> pure () PointerTy inner -> - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables inner >> pure () - --BoxTy inner -> - -- canBeUsedAsMemberType tyname 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: -- ((Foo (f a b)) [x (f a b)]) @@ -120,37 +105,37 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables checkVar struct <> checkStruct sname tyVars v@(VarTy _) -> checkVar v (RecTy _) -> pure () - _ -> Left (InvalidMemberType ty xobj) + _ -> Left (InvalidMemberType ty (reify ty)) where checkStruct :: Ty -> [Ty] -> Either TypeError () checkStruct (ConcreteNameTy (SymPath [] "Array")) [innerType] = - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType >> pure () checkStruct (ConcreteNameTy (SymPath [] "Box")) [innerType] = - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType xobj + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables innerType >> pure () checkStruct (ConcreteNameTy path@(SymPath _ pname)) vars = if pname == tyname && length vars == length typeVariables - then foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + then foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars else case E.getTypeBinder typeEnv pname <> E.findTypeBinder globalEnv path of Right (Binder _ (XObj (Lst (XObj (ExternalType _) _ _ : _)) _ _)) -> pure () Right (Binder _ (XObj (Lst (XObj (Deftype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars Right (Binder _ (XObj (Lst (XObj (DefSumtype t) _ _ : _)) _ _)) -> - checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars - _ -> Left (NotAmongRegisteredTypes ty xobj) + checkInhabitants t >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars + _ -> Left (NotAmongRegisteredTypes ty (reify ty)) where checkInhabitants :: Ty -> Either TypeError () checkInhabitants (StructTy _ vs) = if length vs == length vars then pure () - else Left (UninhabitedConstructor ty xobj (length vs) (length vars)) - checkInhabitants _ = Left (InvalidMemberType ty xobj) + else Left (UninhabitedConstructor ty (reify ty) (length vs) (length vars)) + checkInhabitants _ = Left (InvalidMemberType ty (reify ty)) checkStruct v@(VarTy _) vars = - canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables v xobj - >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ xobj) () vars + canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables v + >> foldM (\_ typ -> canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables typ) () vars checkStruct _ _ = error "checkstruct" checkVar :: Ty -> Either TypeError () checkVar variable = @@ -160,7 +145,7 @@ canBeUsedAsMemberType tyname typeVarRestriction typeEnv globalEnv typeVariables AllowOnlyNamesInScope -> if any (isCaptured variable) typeVariables then pure () - else Left (InvalidMemberType ty xobj) + else Left (InvalidMemberType ty (reify ty)) where -- If a variable `a` appears in a higher-order polymorphic form, such as `(f a)` -- `a` may be used as a member, sans `f`, but `f` may not appear