git.iko.soy/elk
on master help sign in
Get type dealiasing working.
87fa86cevancz
compiler/Initialize.hs+4−7
compare with master
unifiedsplit
@@ -14,7 +14,7 @@ import Libraries (libraries)
14import Types.Types ((-:))
14import Types.Types ((-:))
15import Types.Hints (hints)
15import Types.Hints (hints)
16import Types.Unify
16import Types.Unify
17−import Types.Alias
17+import Types.Alias (dealias, mistakes)
18import Optimize
18import Optimize
19import CompileToJS (jsModule)
19import CompileToJS (jsModule)
20
20
@@ -25,12 +25,9 @@ checkMistakes modul@(Module name ex im stmts) =
25 [] -> return modul
25 [] -> return modul
26
26
27checkTypes :: Module -> Either String Module
27checkTypes :: Module -> Either String Module
28−checkTypes (Module name ex im stmts) =
28+checkTypes modul =
29− let stmts' = dealias stmts
30− modul = Module name ex im stmts'
31− in do subs <- unify hints modul
29+ do subs <- unify hints modul
32− let modul' = optimize . renameModule $ Module name ex im stmts'
33− subs `seq` return modul'
30+ subs `seq` return (optimize (renameModule modul))
34
31
35check :: Module -> Either String Module
32check :: Module -> Either String Module
36check = checkMistakes >=> checkTypes
33check = checkMistakes >=> checkTypes
compiler/Parse/Types.hs+2−5
@@ -11,7 +11,7 @@ import Text.Parsec.Indent
11
11
12import Context
12import Context
13import Parse.Library
13import Parse.Library
14−import Types.Types hiding (string,parens)
14+import Types.Types hiding (parens,string)
15import Guid
15import Guid
16
16
17data ParseType = VarPT String
17data ParseType = VarPT String
@@ -47,10 +47,7 @@ typeUnambiguous :: IParser ParseType
47typeUnambiguous = typeList <|> typeTuple <|> typeRecord
47typeUnambiguous = typeList <|> typeTuple <|> typeRecord
48
48
49typeSimple :: IParser ParseType
49typeSimple :: IParser ParseType
50−typeSimple = dealias <$> var
50+typeSimple = VarPT <$> var
51− where dealias "String" = listPT (VarPT "Char")
52− dealias "Time" = VarPT "Float"
53− dealias v = VarPT v
54
51
55typeApp :: IParser ParseType
52typeApp :: IParser ParseType
56typeApp = do name <- capVar <?> "type constructor"
53typeApp = do name <- capVar <?> "type constructor"
compiler/Types/Alias.hs+16−28
@@ -1,5 +1,5 @@
1
1
2−module Types.Alias (dealias, mistakes) where
2+module Types.Alias (dealias, get, mistakes) where
3
3
4import Ast
4import Ast
5import Control.Arrow (second)
5import Control.Arrow (second)
@@ -10,37 +10,25 @@ import Types.Substitutions (subst)
10import Types.Types
10import Types.Types
11
11
12builtins :: [(String,([X],Type))]
12builtins :: [(String,([X],Type))]
13−builtins = [ ("String", ([], string)) ]
13+builtins = [ ("String", ([], listOf char))
14+ , ("Time", ([], float)) ]
14
15
15−getAliases :: [Statement] -> Map.Map String ([X],Type)
16+get :: [Statement] -> Map.Map String ([X],Type)
16−getAliases stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
17+get stmts = Map.fromList (builtins ++ concatMap getAlias stmts)
17 where getAlias stmt = case stmt of
18 where getAlias stmt = case stmt of
18 TypeAlias alias xs t -> [(alias, (xs,t))]
19 TypeAlias alias xs t -> [(alias, (xs,t))]
19 _ -> []
20 _ -> []
20
21
21−
22+dealias :: Map.Map String ([X],Type) -> Type -> Type
22−dealias :: [Statement] -> [Statement]
23+dealias aliases t =
23−dealias stmts = map dealiasS stmts
24+ let f = dealias aliases in
24− where
25− dealiasT :: Type -> Type
26− dealiasT t =
27− case t of
25+ case t of
28− ADT name ts -> case Map.lookup name (getAliases stmts) of
26+ ADT name ts -> case Map.lookup name aliases of
29− Just (xs,t) -> dealiasT (subst (zip xs ts) t)
27+ Just (xs,t) -> f (subst (zip xs ts) t)
30− Nothing -> ADT name (map dealiasT ts)
28+ Nothing -> ADT name (map f ts)
31− LambdaT t u -> LambdaT (dealiasT t) (dealiasT u)
29+ LambdaT t u -> LambdaT (f t) (f u)
32− RecordT r t -> RecordT (Map.map (map dealiasT) r) (dealiasT t)
30+ RecordT r t -> RecordT (Map.map (map f) r) (f t)
33− _ -> t
31+ _ -> t
34−
35− dealiasS :: Statement -> Statement
36− dealiasS s =
37− case s of
38− Datatype n xs tcs -> Datatype n xs (map (second (map dealiasT)) tcs)
39− ExportEvent js elm tipe -> ExportEvent js elm (dealiasT tipe)
40− ImportEvent js e elm tipe -> ImportEvent js e elm (dealiasT tipe)
41− TypeAnnotation name tipe -> TypeAnnotation name (dealiasT tipe)
42− TypeAlias alias xs tipe -> TypeAlias alias xs (dealiasT tipe)
43− Definition _ -> s
44
32
45mistakes :: [Statement] -> [String]
33mistakes :: [Statement] -> [String]
46mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
34mistakes stmts = badKinds stmts ++ dups stmts ++ badOrder stmts
@@ -55,7 +43,7 @@ badKinds stmts = map msg (concatMap badS stmts)
55 badT t =
43 badT t =
56 case t of
44 case t of
57 ADT name ts ->
45 ADT name ts ->
58− case Map.lookup name (getAliases stmts) of
46+ case Map.lookup name (get stmts) of
59 Just (xs,t) | length xs == length ts -> []
47 Just (xs,t) | length xs == length ts -> []
60 | otherwise -> [name]
48 | otherwise -> [name]
61 Nothing -> concatMap badT ts
49 Nothing -> concatMap badT ts
compiler/Types/Solver.hs+47−38
@@ -13,14 +13,17 @@ import Guid
13import Types.Types
13import Types.Types
14import Types.Constrain
14import Types.Constrain
15import Types.Substitutions
15import Types.Substitutions
16+import Types.Alias (dealias)
16
17
17isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2
18isSolved ss (C _ _ (t1 :=: t2)) = t1 == t2
18isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)
19isSolved ss (C _ _ (x :<<: _)) = isJust (lookup x ss)
19isSolved ss c = False
20isSolved ss c = False
20
21
22+type Aliases = Map.Map String ([X],Type)
23+
21−crush :: Scheme -> GuidCounter (Either String Scheme)
24+crush :: Aliases -> Scheme -> GuidCounter (Either String Scheme)
22−crush (Forall xs cs t) =
25+crush aliases (Forall xs cs t) =
23− do subs <- solver cs Map.empty
26+ do subs <- solver aliases Map.empty cs
24 return $ do ss' <- subs
27 return $ do ss' <- subs
25 let ss = Map.toList ss'
28 let ss = Map.toList ss'
26 cs' = filter (not . isSolved ss) (subst ss cs)
29 cs' = filter (not . isSolved ss) (subst ss cs)
@@ -34,10 +37,11 @@ schemeSubHelp txt span x s t1 rltn t2 = do
34 | otherwise = do (st, cs) <- concretize s
37 | otherwise = do (st, cs) <- concretize s
35 return (subst [(x,st)] t, cs)
38 return (subst [(x,st)] t, cs)
36
39
37−schemeSub x s c = do s' <- crush s
40+schemeSub aliases x s c =
41+ do s' <- crush aliases s
38− case s' of
42+ case s' of
39− Right s'' -> Right `liftM` schemeSub' x s'' c
43+ Right s'' -> Right `liftM` schemeSub' x s'' c
40− Left err -> return $ Left err
44+ Left err -> return $ Left err
41
45
42schemeSub' x s c@(C txt span constraint) =
46schemeSub' x s c@(C txt span constraint) =
43 case constraint of
47 case constraint of
@@ -77,29 +81,34 @@ recordConstraints eq fs t fs' t' =
77 let tipe = RecordT (Map.singleton k bs) (VarT x)
81 let tipe = RecordT (Map.singleton k bs) (VarT x)
78 return (cs ++ [eq t tipe])
82 return (cs ++ [eq t tipe])
79
83
80−solver :: [Context Constraint]
84+solver :: Aliases
81 -> Map.Map X Type
85 -> Map.Map X Type
86+ -> [Context Constraint]
82 -> GuidCounter (Either String (Map.Map X Type))
87 -> GuidCounter (Either String (Map.Map X Type))
83−solver [] subs = return $ Right subs
88+solver _ subs [] = return $ Right subs
84−solver (C txt span c : cs) subs =
89+solver aliases subs (C txt span c : cs) =
85 let ctx = C txt span
90 let ctx = C txt span
86 eq t1 t2 = ctx (t1 :=: t2)
91 eq t1 t2 = ctx (t1 :=: t2)
92+ solv = solver aliases subs
87 in case c of
93 in case c of
88 -- Destruct Type-constructors
94 -- Destruct Type-constructors
89 t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
95 t1@(ADT n1 ts1) :=: t2@(ADT n2 ts2) ->
90− if n1 /= n2 then uniError txt span t1 t2 else
91− solver (zipWith eq ts1 ts2 ++ cs) subs
96+ if n1 == n2 then solv (zipWith eq ts1 ts2 ++ cs)
97+ else let t1' = dealias aliases t1
98+ t2' = dealias aliases t2
99+ in if t1 == t1' && t2 == t2' then uniError txt span t1 t2
100+ else solv (ctx (t1' :=: t2') : cs)
92
101
93 LambdaT t1 t2 :=: LambdaT t1' t2' ->
102 LambdaT t1 t2 :=: LambdaT t1' t2' ->
94− solver ([ eq t1 t1', eq t2 t2' ] ++ cs) subs
103+ solv ([ eq t1 t1', eq t2 t2' ] ++ cs)
95
104
96 RecordT fs t :=: RecordT fs' t' ->
105 RecordT fs t :=: RecordT fs' t' ->
97 do cs' <- recordConstraints eq fs t fs' t'
106 do cs' <- recordConstraints eq fs t fs' t'
98− solver (cs' ++ cs) subs
107+ solv (cs' ++ cs)
99
108
100 -- Type-equality
109 -- Type-equality
101 VarT x :=: VarT y
110 VarT x :=: VarT y
102− | x == y -> solver cs subs
111+ | x == y -> solv cs
103 | otherwise ->
112 | otherwise ->
104 case (Map.lookup x subs, Map.lookup y subs) of
113 case (Map.lookup x subs, Map.lookup y subs) of
105 (Just (Super xts), Just (Super yts)) ->
114 (Just (Super xts), Just (Super yts)) ->
@@ -108,68 +117,68 @@ solver (C txt span c : cs) subs =
108 in case Set.toList ts of
117 in case Set.toList ts of
109 [] -> unionError txt span xts yts
118 [] -> unionError txt span xts yts
110 [t] -> let cs1 = subst [(x,t),(y,t)] cs in
119 [t] -> let cs1 = subst [(x,t),(y,t)] cs in
111− cs1 `seq` solver cs1 (setXY t subs)
120+ cs1 `seq` solver aliases (setXY t subs) cs1
112− _ -> solver cs $ setXY (Super ts) subs
121+ _ -> solver aliases (setXY (Super ts) subs) cs
113 (Just (Super xts), _) ->
122 (Just (Super xts), _) ->
114 let cs2 = subst [(y,VarT x)] cs in
123 let cs2 = subst [(y,VarT x)] cs in
115− solver cs2 $ Map.insert y (VarT x) subs
124+ solver aliases (Map.insert y (VarT x) subs) cs2
116 (_, _) ->
125 (_, _) ->
117 let cs3 = subst [(x,VarT y)] cs in
126 let cs3 = subst [(x,VarT y)] cs in
118− solver cs3 $ Map.insert x (VarT y) subs
127+ solver aliases (Map.insert x (VarT y) subs) cs3
119
128
120 VarT x :=: t -> do
129 VarT x :=: t -> do
121 if x `occurs` t then occursError txt span (VarT x) t else
130 if x `occurs` t then occursError txt span (VarT x) t else
122 (case Map.lookup x subs of
131 (case Map.lookup x subs of
132+ Nothing ->
123− Nothing -> let cs4 = subst [(x,t)] cs in
133+ let cs4 = subst [(x,t)] cs
124− solver cs4 . Map.map (subst [(x,t)]) $
125− Map.insert x t subs
134+ subs' = Map.map (subst [(x,t)]) $ Map.insert x t subs
135+ in solver aliases subs' cs4
126 Just (Super ts) ->
136 Just (Super ts) ->
127 let ts' = Set.intersection ts (Set.singleton t) in
137 let ts' = Set.intersection ts (Set.singleton t) in
128 case Set.toList ts' of
138 case Set.toList ts' of
129− [] -> solver (ctx (t :<: Super ts) : cs) subs
139+ [] -> solv (ctx (t :<: Super ts) : cs)
130 [t'] -> let cs5 = subst [(x,t)] cs in
140 [t'] -> let cs5 = subst [(x,t)] cs in
131− solver cs5 $ Map.insert x t' subs
141+ solver aliases (Map.insert x t' subs) cs5
132− _ -> solver cs $ Map.insert x (Super ts') subs
142+ _ -> solver aliases (Map.insert x (Super ts') subs) cs
133− Just t' -> solver (ctx (t' :=: t) : cs) subs
143+ Just t' -> solv (ctx (t' :=: t) : cs)
134 )
144 )
135
145
136− t :=: VarT x -> solver ((ctx (VarT x :=: t)) : cs) subs
146+ t :=: VarT x -> solv ((ctx (VarT x :=: t)) : cs)
137
147
138− t1 :=: t2 | t1 == t2 -> solver cs subs
148+ t1 :=: t2 | t1 == t2 -> solv cs
139 | otherwise -> uniError txt span t1 t2
149 | otherwise -> uniError txt span t1 t2
140
150
141 -- subtypes
151 -- subtypes
142 VarT x :<: Super ts ->
152 VarT x :<: Super ts ->
143 case Map.lookup x subs of
153 case Map.lookup x subs of
144− Nothing -> solver cs $ Map.insert x (Super ts) subs
154+ Nothing -> solver aliases (Map.insert x (Super ts) subs) cs
145 Just (Super ts') ->
155 Just (Super ts') ->
146 case Set.toList $ Set.intersection ts ts' of
156 case Set.toList $ Set.intersection ts ts' of
147 [] -> unionError txt span ts ts'
157 [] -> unionError txt span ts ts'
148− [t] -> solver (subst [(x,t)] cs) $ Map.insert x t subs
158+ [t] -> solver aliases (Map.insert x t subs) (subst [(x,t)] cs)
149− ts'' -> solver cs $
159+ ts'' -> solver aliases subs' cs
150− Map.insert x (Super $ Set.fromList ts'') subs
160+ where subs' = Map.insert x (Super $ Set.fromList ts'') subs
151
161
152 ADT "List" [t] :<: Super ts
162 ADT "List" [t] :<: Super ts
153− | any f (Set.toList ts) -> solver cs subs
163+ | any f (Set.toList ts) -> solv cs
154 | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
164 | otherwise -> subtypeError txt span (ADT "List" [t]) (Super ts)
155 where f (ADT "List" [VarT _]) = True
165 where f (ADT "List" [VarT _]) = True
156 f (ADT "List" [t']) = t == t'
166 f (ADT "List" [t']) = t == t'
157 f _ = False
167 f _ = False
158
168
159 t :<: Super ts
169 t :<: Super ts
160− | Set.member t ts -> solver cs subs
170+ | Set.member t ts -> solv cs
161 | otherwise -> subtypeError txt span t (Super ts)
171 | otherwise -> subtypeError txt span t (Super ts)
162
172
163 x :<<: s
173 x :<<: s
164 | any (occurs x) cs ->
174 | any (occurs x) cs ->
165− do css <- mapM (schemeSub x s) cs
175+ do css <- mapM (schemeSub aliases x s) cs
166 case lefts css of
176 case lefts css of
167 err : _ -> return $ Left err
177 err : _ -> return $ Left err
168− [] -> solver (concat (rights css)) subs
178+ [] -> solv (concat (rights css))
169 | otherwise ->
179 | otherwise ->
170 do (t,cs7) <- concretize s
180 do (t,cs7) <- concretize s
171− let cs'' = (cs ++ ctx (VarT x :=: t) : cs7)
181+ solv (cs ++ ctx (VarT x :=: t) : cs7)
172− solver cs'' subs
173
182
174showMsg msg = case msg of
183showMsg msg = case msg of
175 Just str -> "\nIn context: " ++ str
184 Just str -> "\nIn context: " ++ str
compiler/Types/Types.hs+3−24
@@ -40,22 +40,10 @@ number = Super (Set.fromList [ int, float ])
40char = tipe "Char"
40char = tipe "Char"
41bool = tipe "Bool"
41bool = tipe "Bool"
42
42
43−string = listOf char -- tipe "String"
43+string = tipe "String"
44text = tipe "Text"
44text = tipe "Text"
45
45
46−time = float --tipe "Time"
47−date = tipe "Date"
48−month = tipe "Month"
49−day = tipe "Day"
50−
51element = tipe "Element"
46element = tipe "Element"
52−direction = tipe "Direction"
53−form = tipe "Form"
54−line = tipe "Line"
55−shape = tipe "Shape"
56−color = tipe "Color"
57−position = tipe "Position"
58−location = tipe "Location"
59
47
60listOf t = ADT "List" [t]
48listOf t = ADT "List" [t]
61signalOf t = ADT "Signal" [t]
49signalOf t = ADT "Signal" [t]
@@ -65,16 +53,7 @@ eitherOf a b = ADT "Either" [a,b]
65pairOf t = tupleOf [t,t]
53pairOf t = tupleOf [t,t]
66point = pairOf int
54point = pairOf int
67appendable t = Super (Set.fromList [ string, text, listOf t ])
55appendable t = Super (Set.fromList [ string, text, listOf t ])
68−comparable = Super (Set.fromList [ int, float, char, string, time, date ])
56+--comparable = Super (Set.fromList [ int, float, char, string, time, date ])
69−
70−jsBool = tipe "JSBool"
71−jsNumber = tipe "JSNumber"
72−jsString = tipe "JSString"
73−jsElement = tipe "JSElement"
74−jsArray t = ADT "JSArray" [t]
75−jsTuple ts = ADT ("JSTuple" ++ show (length ts)) ts
76−jsonValue = tipe "JsonValue"
77−jsonObject = tipe "JsonObject"
78
57
79infixr ==>
58infixr ==>
80t1 ==> t2 = LambdaT t1 t2
59t1 ==> t2 = LambdaT t1 t2
@@ -91,7 +70,7 @@ instance Show Type where
91 LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2
70 LambdaT t1@(LambdaT _ _) t2 -> show' t1 ++ " -> " ++ show t2
92 LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
71 LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
93 VarT x -> 't' : show x
72 VarT x -> 't' : show x
94− ADT "List" [ADT "Char" []] -> "String"
73+ --ADT "List" [ADT "Char" []] -> "String"
95 ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
74 ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
96 ADT name cs ->
75 ADT name cs ->
97 if isTupleString name
76 if isTupleString name
compiler/Types/Unify.hs+4−2
@@ -4,11 +4,13 @@ module Types.Unify (unify) where
4import Control.Monad (liftM)
4import Control.Monad (liftM)
5import qualified Data.Map as Map
5import qualified Data.Map as Map
6
6
7+import Ast
7import Guid
8import Guid
8import Types.Constrain
9import Types.Constrain
9import Types.Solver
10import Types.Solver
11+import Types.Alias as Alias
10
12
11−unify hints modul = run $ do
13+unify hints modul@(Module _ _ _ stmts) = run $ do
12 constraints <- constrain hints modul
14 constraints <- constrain hints modul
13− either (return . Left) (\cs -> solver cs Map.empty) constraints
15+ either (return . Left) (solver (Alias.get stmts) Map.empty) constraints
14
16