Skip to content

Commit

Permalink
refactor: CHECKPOINT! Broken build. refactoring type candidates
Browse files Browse the repository at this point in the history
  • Loading branch information
scolsen committed Oct 26, 2021
1 parent 6ada67d commit b951a9a
Show file tree
Hide file tree
Showing 6 changed files with 150 additions and 110 deletions.
44 changes: 18 additions & 26 deletions src/Concretize.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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.
Expand Down
34 changes: 27 additions & 7 deletions src/RecType.hs
Original file line number Diff line number Diff line change
@@ -1,3 +1,4 @@
-- | Module RecType defines routines for working with recursive data types.
module RecType
(
recursiveMembersToPointers,
Expand All @@ -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

Expand Down Expand Up @@ -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**
--
Expand Down
36 changes: 11 additions & 25 deletions src/SumtypeCase.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
}
55 changes: 54 additions & 1 deletion src/TypeCandidate.hs
Original file line number Diff line number Diff line change
@@ -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'
Expand All @@ -20,11 +25,59 @@ 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
interfaceConstraints :: [InterfaceConstraint],
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)
8 changes: 6 additions & 2 deletions src/TypeError.hs
Original file line number Diff line number Diff line change
Expand Up @@ -9,7 +9,6 @@ import Obj
import Project
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
import Types
import TypeCandidate
import Util

data TypeError
Expand Down Expand Up @@ -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) =
Expand Down Expand Up @@ -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
Expand Down
Loading

0 comments on commit b951a9a

Please sign in to comment.