Skip to content

Commit b951a9a

Browse files
scolsenscolsen
committed
refactor: CHECKPOINT! Broken build. refactoring type candidates
1 parent 6ada67d commit b951a9a

File tree

6 files changed

+150
-110
lines changed

6 files changed

+150
-110
lines changed

‎src/Concretize.hs‎

Lines changed: 18 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -613,8 +613,8 @@ instantiateGenericStructType typeEnv env originalStructTy@(StructTy _ _) generic
613613
let nameFixedMembers = renameGenericTypeSymbolsOnProduct renamedOrig memberXObjs
614614
validMembers = replaceGenericTypeSymbolsOnMembers mappings' nameFixedMembers
615615
concretelyTypedMembers = replaceGenericTypeSymbolsOnMembers mappings memberXObjs
616-
candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), typemembers = validMembers, variables = renamedOrig, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env }
617-
validateMembers typeEnv env candidate
616+
candidate <- (fromDeftype (getStructName originalStructTy) renamedOrig typeEnv env validMembers)
617+
validateMembers (candidate {restriction = AllowAnyTypeVariableNames})
618618
deps <- mapM (depsForStructMemberPair typeEnv env) (pairwise concretelyTypedMembers)
619619
let xobj =
620620
XObj
@@ -642,30 +642,22 @@ instantiateGenericSumtype typeEnv env originalStructTy@(StructTy _ originalTyVar
642642
let fake1 = XObj (Sym (SymPath [] "a") Symbol) Nothing Nothing
643643
fake2 = XObj (Sym (SymPath [] "b") Symbol) Nothing Nothing
644644
rename@(StructTy _ renamedOrig) = evalState (renameVarTys originalStructTy) 0
645-
in case solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym] of
646-
Left e -> error (show e)
647-
Right mappings ->
648-
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
649-
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
650-
deps = mapM (depsForCase typeEnv env) concretelyTypedCases
651-
candidate = TypeCandidate {restriction = AllowAnyTypeVariableNames, typename = (getStructName originalStructTy), variables = renamedOrig, typemembers = concretelyTypedCases, interfaceConstraints = [], candidateTypeEnv = typeEnv, candidateEnv = env }
652-
in case toCases typeEnv env candidate of -- Don't care about the cases, this is done just for validation.
653-
Left err -> Left err
654-
Right _ ->
655-
case deps of
656-
Right okDeps ->
657-
Right $
658-
XObj
659-
( Lst
660-
( XObj (DefSumtype genericStructTy) Nothing Nothing :
661-
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
662-
concretelyTypedCases
663-
)
664-
)
665-
(Just dummyInfo)
666-
(Just TypeTy) :
667-
concat okDeps
668-
Left err -> Left err
645+
in do mappings <- replaceLeft (FailedToInstantiateGenericType originalStructTy) (solve [Constraint rename genericStructTy fake1 fake2 fake1 OrdMultiSym])
646+
let nameFixedCases = map (renameGenericTypeSymbolsOnSum (zip originalTyVars renamedOrig)) cases
647+
concretelyTypedCases = map (replaceGenericTypeSymbolsOnCase mappings) nameFixedCases
648+
candidate <- fromSumtype (getStructName originalStructTy) renamedOrig typeEnv env concretelyTypedCases
649+
_ <- toCases typeEnv env (candidate {restriction = AllowAnyTypeVariableNames})
650+
deps <- mapM (depsForCase typeEnv env) concretelyTypedCases
651+
pure (XObj
652+
( Lst
653+
( XObj (DefSumtype genericStructTy) Nothing Nothing :
654+
XObj (Sym (SymPath [] (tyToC genericStructTy)) Symbol) Nothing Nothing :
655+
concretelyTypedCases
656+
)
657+
)
658+
(Just dummyInfo)
659+
(Just TypeTy) :
660+
concat deps)
669661
instantiateGenericSumtype _ _ _ _ _ = error "instantiategenericsumtype"
670662

671663
-- Resolves dependencies for sumtype cases.

‎src/RecType.hs‎

Lines changed: 27 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
-- | Module RecType defines routines for working with recursive data types.
12
module RecType
23
(
34
recursiveMembersToPointers,
@@ -24,6 +25,32 @@ import Concretize
2425
import ToTemplate
2526
import Validate
2627

28+
-- | Returns true if a type candidate is recursive.
29+
--
30+
-- (deftype IntList [Int IntList]) --> True
31+
-- (deftype IntList (Nil []) (Cons [Int IntList])) --> True
32+
-- (deftype IntList [Int (Box IntList)]) --> True
33+
--isRecursive :: TypeCandidate -> Bool
34+
--isRecurisve TypeCandidate{typename=name,variables=vs,typemembers=ms} =
35+
-- let memberTypes = map xobjToTy
36+
-- case vs of
37+
-- [] -> any concreteRecursion ms
38+
-- _ -> any genericRecursion ms
39+
-- where concreteRecursion :: XObj -> Bool
40+
-- concreteRecursion (XObj (Lst xs) _ _) = any concreteRecursion xs
41+
-- concreteRecursion (XObj (Sym (SymPath _ n) _) _ _) = n == name
42+
-- concreteRecursion _ = False
43+
--
44+
-- genericRecursion :: XObj -> Bool
45+
-- genericRecursion (XObj (Lst xs) _ _) =
46+
-- genericRecursion _ = False
47+
48+
isRecursive :: Ty -> XObj -> Bool
49+
isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path
50+
isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs
51+
isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs
52+
isRecursive _ _ = False
53+
2754
--------------------------------------------------------------------------------
2855
-- Base indirection recursion
2956

@@ -61,13 +88,6 @@ recInterfaceConstraints t =
6188
InterfaceConstraint "alloc" [(FuncTy [(head members)] t StaticLifetimeTy)]
6289
]
6390

64-
-- | Returns true if a type member xobj is recursive (either through indirect recursion or "value" recursion)
65-
isRecursive :: Ty -> XObj -> Bool
66-
isRecursive (StructTy (ConcreteNameTy spath) []) (XObj (Sym path _) _ _) = spath == path
67-
isRecursive rec (XObj (Lst xs) _ _) = any (isRecursive rec) xs
68-
isRecursive rec (XObj (Arr xs) _ _) = any (isRecursive rec) xs
69-
isRecursive _ _ = False
70-
7191
--------------------------------------------------------------------------------
7292
-- **Value recursion sugar**
7393
--

‎src/SumtypeCase.hs‎

Lines changed: 11 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -15,28 +15,14 @@ data SumtypeCase = SumtypeCase
1515
toCases :: TypeEnv -> Env -> TypeCandidate -> Either TypeError [SumtypeCase]
1616
toCases typeEnv globalEnv candidate = mapM (toCase (typename candidate) typeEnv globalEnv (restriction candidate) (variables candidate)) (typemembers candidate)
1717

18-
toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> XObj -> Either TypeError SumtypeCase
19-
toCase tyname typeEnv globalEnv varrestriction typeVars x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
20-
let tys = map xobjToTy tyXObjs
21-
in case sequence tys of
22-
Nothing ->
23-
Left (InvalidSumtypeCase x)
24-
Just okTys ->
25-
let validated = map (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t x) okTys
26-
in case sequence validated of
27-
Left e ->
28-
Left e
29-
Right _ ->
30-
Right $
31-
SumtypeCase
32-
{ caseName = pname,
33-
caseTys = okTys
34-
}
35-
toCase _ _ _ _ _ (XObj (Sym (SymPath [] pname) Symbol) _ _) =
36-
Right $
37-
SumtypeCase
38-
{ caseName = pname,
39-
caseTys = []
40-
}
41-
toCase _ _ _ _ _ x =
42-
Left (InvalidSumtypeCase x)
18+
toCase :: String -> TypeEnv -> Env -> TypeVarRestriction -> [Ty] -> (String, [Ty]) -> Either TypeError SumtypeCase
19+
toCase tyname typeEnv globalEnv varrestriction typeVars member =
20+
let validated = mapM (\t -> canBeUsedAsMemberType tyname varrestriction typeEnv globalEnv typeVars t) (snd member)
21+
in case validated of
22+
Left e -> Left e
23+
Right _ ->
24+
Right $
25+
SumtypeCase
26+
{ caseName = fst member,
27+
caseTys = snd member
28+
}

‎src/TypeCandidate.hs‎

Lines changed: 54 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,12 @@
11
module TypeCandidate where
22

33
import Types
4+
import TypeError
45
import Obj
6+
import Util
7+
8+
--------------------------------------------------------------------------------
9+
-- Data types
510

611
data TypeVarRestriction
712
= AllowAnyTypeVariableNames -- Used when checking a type found in the code, e.g. (Foo a), any name is OK for 'a'
@@ -20,11 +25,59 @@ data TypeCandidate = TypeCandidate {
2025
-- a list of all variables in the type head
2126
variables :: [Ty],
2227
-- all members of the type
23-
typemembers :: [XObj],
28+
typemembers :: [(String, [Ty])],
2429
-- what sort of type variables are permitted.
2530
restriction :: TypeVarRestriction,
2631
-- what interfaces should types satisfy
2732
interfaceConstraints :: [InterfaceConstraint],
2833
candidateTypeEnv :: TypeEnv,
2934
candidateEnv :: Env
3035
}
36+
37+
--------------------------------------------------------------------------------
38+
-- Constructors
39+
40+
-- | Constructs a type candidate from the members of a product type definition.
41+
fromDeftype :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> Either TypeError TypeCandidate
42+
fromDeftype name vars tenv env members =
43+
let tMembers = mapM go (pairwise members)
44+
candidate = TypeCandidate {
45+
typename = name,
46+
variables = vars,
47+
typemembers = [],
48+
interfaceConstraints = [],
49+
restriction = AllowOnlyNamesInScope,
50+
candidateTypeEnv = tenv,
51+
candidateEnv = env
52+
}
53+
in if even (length members)
54+
then fmap (\ms -> candidate {typemembers = ms}) tMembers
55+
else Left (UnevenMembers members)
56+
where go :: (XObj, XObj) -> Either TypeError (String, [Ty])
57+
go ((XObj (Sym (SymPath [] fieldname) _) _ _), tyx) =
58+
case xobjToTy tyx of
59+
Just t -> Right (fieldname, [t])
60+
Nothing -> Left (NotAType tyx)
61+
go (x, _) = Left (InvalidProductField x)
62+
63+
-- | Constructs a type candidate from the members of a sum type definition.
64+
fromSumtype :: String -> [Ty] -> TypeEnv -> Env -> [XObj] -> Either TypeError TypeCandidate
65+
fromSumtype name vars tenv env members =
66+
let tMembers = mapM go members
67+
candidate = TypeCandidate {
68+
typename = name,
69+
variables = vars,
70+
typemembers = [],
71+
interfaceConstraints = [],
72+
restriction = AllowOnlyNamesInScope,
73+
candidateTypeEnv = tenv,
74+
candidateEnv = env
75+
}
76+
in fmap (\ms -> candidate {typemembers = ms}) tMembers
77+
where go :: XObj -> Either TypeError (String, [Ty])
78+
go x@(XObj (Lst [XObj (Sym (SymPath [] pname) Symbol) _ _, XObj (Arr tyXObjs) _ _]) _ _) =
79+
case mapM xobjToTy tyXObjs of
80+
Just ts -> Right (pname, ts)
81+
Nothing -> Left (InvalidSumtypeCase x)
82+
go (XObj (Sym (SymPath [] pname) Symbol) _ _) = Right (pname, [])
83+
go x = Left (InvalidSumtypeCase x)

‎src/TypeError.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,6 @@ import Obj
99
import Project
1010
import Text.EditDistance (defaultEditCosts, levenshteinDistance)
1111
import Types
12-
import TypeCandidate
1312
import Util
1413

1514
data TypeError
@@ -63,7 +62,8 @@ data TypeError
6362
| InconsistentKinds String [XObj]
6463
| FailedToAddLambdaStructToTyEnv SymPath XObj
6564
| FailedToInstantiateGenericType Ty
66-
| InterfaceNotImplemented [InterfaceConstraint]
65+
| InterfaceNotImplemented [String]
66+
| InvalidProductField XObj
6767

6868
instance Show TypeError where
6969
show (InterfaceNotImplemented is) =
@@ -283,6 +283,10 @@ instance Show TypeError where
283283
"I failed to read `" ++ pretty xobj ++ "` as a sumtype case at "
284284
++ prettyInfoFromXObj xobj
285285
++ ".\n\nSumtype cases look like this: `(Foo [Int typevar])`"
286+
show (InvalidProductField xobj) =
287+
"I failed to read `" ++ pretty xobj ++ "` as a product field at "
288+
++ prettyInfoFromXObj xobj
289+
++ ".\n\nProduct fields look like this: `[field-name Int]`"
286290
show (InvalidMemberType t xobj) =
287291
"I can’t use the type `" ++ show t ++ "` as a member type at "
288292
++ prettyInfoFromXObj xobj

0 commit comments

Comments
 (0)