git.iko.soy/elk
on master help sign in
- Simplify basic types. Add more correct versions of Type Schemes and Super Types.

- Adjust type hints to use type schemes. - Adjust constraint generation to use type schemes and super types properly. - Modify unification algorithm to properly handle type schemes and super types.

commit153d05438c2ce1087f888c13c0143086184f1632 authorevancz <info@elm-lang.org> dateThu 19 Jul 2012, 11:51 (14 years ago) parent6c47a84
4 files changed+207−178
compare with master
unifiedsplit
elm/src/Types/Constrain.hs+12−15 elm/src/Types/Hints.hs+122−120 elm/src/Types/Types.hs+49−29 elm/src/Types/Unify.hs+24−14
elm/src/Types/Constrain.hs+12−15
@@ -10,24 +10,19 @@ import Control.Monad (liftM,mapM)
1010import Control.Monad.State (evalState)
1111import Guid
1212
13−data Constraint = Type :=: Type
14− | Type :<: Type
15− | Type :<<: Scheme
16− deriving (Eq, Ord, Show)
17−
1813beta = VarT `liftM` guid
1914unionA = Map.unionWith (++)
2015unionsA = Map.unionsWith (++)
2116
2217constrain hints expr = do
2318 (as,cs,t) <- inference expr
24− hs <- hints
25− let cMap = Map.intersectionWith (\t -> map (:<: t)) (Map.fromList hs) as
19+ let cMap = Map.intersectionWith (\s -> map (\v -> VarT v:<<: s)) (Map.fromList hints) as
2620 return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap)
2721
22+inference :: Expr -> GuidCounter (Map.Map String [X], Set.Set Constraint, Type)
2823inference (Var x) =
29− do b <- beta
30− return (Map.singleton x [b], Set.empty, b)
24+ do b <- guid
25+ return (Map.singleton x [b], Set.empty, VarT b)
3126inference (App e1 e2) =
3227 do (a1,c1,t1) <- inference e1
3328 (a2,c2,t2) <- inference e2
@@ -39,7 +34,7 @@ inference (Lambda x e) =
3934 do (a,c,t) <- inference e
4035 b <- beta
4136 return ( Map.delete x a
42− , Set.union c . Set.fromList . map (:=: b) $
37+ , Set.union c . Set.fromList . map (\x -> VarT x :=: b) $
4338 Map.findWithDefault [] x a
4439 , LambdaT b t )
4540inference (Let defs e) =
@@ -47,7 +42,7 @@ inference (Let defs e) =
4742 let (xs,es) = unzip defs
4843 (as,cs,ts) <- unzip3 `liftM` mapM inference es
4944 let assumptions = unionsA (a:as)
50− let f x t = map (:<: t) $ Map.findWithDefault [] x assumptions
45+ let f x t = map (:=: t) . map VarT $ Map.findWithDefault [] x assumptions
5146 let constraints = Set.fromList . concat $ zipWith f xs ts
5247 return ( foldr Map.delete assumptions xs
5348 , Set.unions $ c:constraints:cs
@@ -58,7 +53,7 @@ inference (If e1 e2 e3) =
5853 (a2,c2,t2) <- inference e2
5954 (a3,c3,t3) <- inference e3
6055 return ( unionsA [a1,a2,a3]
61− , Set.unions [c1,c2,c3, Set.fromList [ t1 :=: BoolT, t2 :=: t3 ] ]
56+ , Set.unions [c1,c2,c3, Set.fromList [ t1 :=: bool, t2 :=: t3 ] ]
6257 , t2 )
6358
6459inference (Data name es) = inference $ foldl' App (Var name) es
@@ -68,10 +63,12 @@ inference (Range e1 e2) = inference (Var "elmRange" `App` e1 `App` e2)
6863
6964inference other =
7065 case other of
71− Number _ -> primitive IntT
72− Chr _ -> primitive CharT
66+ IntNum _ -> do t <- beta
67+ return (Map.empty, Set.singleton (t :<: number), t)
68+ FloatNum _ -> primitive float
69+ Chr _ -> primitive char
7370 Str _ -> primitive string
74− Boolean _ -> primitive BoolT
71+ Boolean _ -> primitive bool
7572 _ -> beta >>= primitive
7673
7774primitive t = return (Map.empty, Set.empty, t)
elm/src/Types/Hints.hs+122−120
@@ -16,126 +16,130 @@ textToText = [ "header", "italic", "bold", "underline"
1616
1717textAttrs = [ "toText" -: string ==> text
1818 , "link" -: string ==> text ==> text
19− , "Text.height" -: IntT ==> text ==> text
19+ , "Text.height" -: int ==> text ==> text
2020 ] ++ hasType (text ==> text) textToText
2121
22−elements = let iee = IntT ==> element ==> element in
22+elements = let iee = int ==> element ==> element in
2323 [ "flow" -: direction ==> listOf element ==> element
2424 , "layers" -: listOf element ==> element
2525 , "text" -: text ==> element
2626 , "opacity" -: iee
2727 , "width" -: iee
2828 , "height" -: iee
29− , "size" -: IntT ==> iee
29+ , "size" -: int ==> iee
3030 , "box" -: iee
3131 , "centeredText" -: text ==> element
3232 , "justifiedText" -: text ==> element
33− , "collage" -: IntT ==> IntT ==> listOf form ==> element
33+ , "collage" -: int ==> int ==> listOf form ==> element
3434 ]
3535
3636directions = hasType direction ["up","down","left","right","inward","outward"]
37−colors = [ "rgb" -: IntT ==> IntT ==> IntT ==> color
38− , "rgba" -: IntT ==> IntT ==> IntT ==> IntT ==> color
37+colors = [ "rgb" -: int ==> int ==> int ==> color
38+ , "rgba" -: int ==> int ==> int ==> int ==> color
3939 ] ++ hasType color ["red","green","blue","black","white"]
4040
4141lineTypes = [ "line" -: listOf point ==> line
42− , "customLine" -: listOf IntT ==> color ==> line ==> form
42+ , "customLine" -: listOf int ==> color ==> line ==> form
4343 ] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"]
4444
4545shapes = [ "polygon" -: listOf point ==> point ==> shape
4646 , "filled" -: color ==> shape ==> form
4747 , "outlined" -: color ==> shape ==> form
48− , "customOutline" -: listOf IntT ==> color ==> shape ==> form
49− ] ++ hasType (IntT ==> IntT ==> point ==> shape) ["ngon","rect","oval"]
48+ , "customOutline" -: listOf int ==> color ==> shape ==> form
49+ ] ++ hasType (int ==> int ==> point ==> shape) ["ngon","rect","oval"]
5050
5151
5252-------- Foreign --------
5353
5454casts =
55− [ "castJSBoolToBool" -: jsBool ==> BoolT
56− , "castBoolToJSBool" -: BoolT ==> jsBool
57− , "castJSNumberToInt" -: jsNumber ==> IntT
58− , "castIntToJSNumber" -: IntT ==> jsNumber
59− , "castJSElementToElement" -: IntT ==> IntT ==> jsElement ==> element
55+ [ "castJSBoolToBool" -: jsBool ==> bool
56+ , "castBoolToJSBool" -: bool ==> jsBool
57+ , "castJSNumberToInt" -: jsNumber ==> int
58+ , "castIntToJSNumber" -: int ==> jsNumber
59+ , "castJSElementToElement" -: int ==> int ==> jsElement ==> element
6060 , "castElementToJSElement" -: element ==> jsElement
6161 , "castJSStringToString" -: jsString ==> string
6262 , "castStringToJSString" -: string ==> jsString
63− -- , "castJSNumberToFloat -:
64− -- , "castFloatToJSNumber -:
63+ , "castJSNumberToFloat" -: jsNumber ==> float
64+ , "castFloatToJSNumber" -: float ==> jsNumber
6565 ]
6666
67−polyCasts = sequence
68− [ do a <- var ; "castJSArrayToList" -:: jsArray a ==> listOf a
69− , do a <- var ; "castListToJSArray" -:: listOf a ==> jsArray a
70− , do vs <- vars 2 ; "castTupleToJSTuple2" -:: tupleOf vs ==> jsTuple vs
71− , do vs <- vars 3 ; "castTupleToJSTuple3" -:: tupleOf vs ==> jsTuple vs
72− , do vs <- vars 4 ; "castTupleToJSTuple4" -:: tupleOf vs ==> jsTuple vs
73− , do vs <- vars 5 ; "castTupleToJSTuple5" -:: tupleOf vs ==> jsTuple vs
74− , do vs <- vars 2 ; "castJSTupleToTuple2" -:: jsTuple vs ==> tupleOf vs
75− , do vs <- vars 3 ; "castJSTupleToTuple3" -:: jsTuple vs ==> tupleOf vs
76− , do vs <- vars 4 ; "castJSTupleToTuple4" -:: jsTuple vs ==> tupleOf vs
77− , do vs <- vars 5 ; "castJSTupleToTuple5" -:: jsTuple vs ==> tupleOf vs
67+castToTuple n = (,) name $ Forall [1..n] [] (jsTuple vs ==> tupleOf vs)
68+ where vs = map VarT [1..n]
69+ name = "castJSTupleToTuple" ++ show n
70+castToJSTuple n = (,) name $ Forall [1..n] [] (tupleOf vs ==> jsTuple vs)
71+ where vs = map VarT [1..n]
72+ name = "castTupleToJSTuple" ++ show n
73+
74+polyCasts =
75+ map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
76+ [ "castJSArrayToList" -:: jsArray a ==> listOf a
77+ , "castListToJSArray" -:: listOf a ==> jsArray a
7878 ]
7979
8080
8181-------- Signals --------
8282
83−sig ts = fn ts ==> fn (map signalOf ts)
83+sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
8484 where fn = foldr1 (==>)
85−
86−signals = sequence
87− [ do ts <- vars 1 ; "constant" -:: sig ts
88− , do ts <- vars 2 ; "lift" -:: sig ts
89− , do ts <- vars 3 ; "lift2" -:: sig ts
90− , do ts <- vars 4 ; "lift3" -:: sig ts
91− , do ts <- vars 5 ; "lift4" -:: sig ts
92− , do [a,b] <- vars 2
93− "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
94− , do a <- var ; "randomize" -:: IntT ==> IntT ==> signalOf a ==> signalOf IntT
95− , do a <- var ; "count" -:: signalOf a ==> signalOf IntT
96− , do a <- var ; "keepIf" -:: (a==>BoolT) ==> a ==> signalOf a ==> signalOf a
97− , do a <- var ; "dropIf" -:: (a==>BoolT) ==> a ==> signalOf a ==> signalOf a
98− , do a <- var ; "keepWhen" -:: signalOf BoolT ==>a==> signalOf a ==> signalOf a
99− , do a <- var ; "dropWhen" -:: signalOf BoolT ==>a==> signalOf a ==> signalOf a
100− , do a <- var ; "dropRepeats" -:: signalOf a ==> signalOf a
101− , do [a,b] <- vars 2 ; "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
85+ ts = map VarT [1..n]
86+
87+signals =
88+ [ sig 1 "constant"
89+ , sig 2 "lift"
90+ , sig 3 "lift2"
91+ , sig 4 "lift3"
92+ , sig 5 "lift4"
93+ , "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
94+ , "randomize" -:: int ==> int ==> signalOf a ==> signalOf int
95+ , "count" -:: signalOf a ==> signalOf int
96+ , "keepIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
97+ , "dropIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
98+ , "keepWhen" -:: signalOf bool ==>a==> signalOf a ==> signalOf a
99+ , "dropWhen" -:: signalOf bool ==>a==> signalOf a ==> signalOf a
100+ , "dropRepeats" -:: signalOf a ==> signalOf a
101+ , "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
102102 ]
103103
104104concreteSignals =
105− [ "keysDown" -: signalOf (listOf IntT)
106− , "charPressed" -: signalOf (maybeOf IntT)
107− , "inRange" -: IntT ==> IntT ==> signalOf IntT
108− , "every" -: time ==> signalOf time
109− , "before" -: time ==> signalOf BoolT
110− , "after" -: time ==> signalOf BoolT
105+ [ "keysDown" -: signalOf (listOf int)
106+ , "charPressed" -: signalOf (maybeOf int)
107+ , "inRange" -: int ==> int ==> signalOf int
108+ , timeScheme "every" (\t -> t ==> signalOf t)
109+ , timeScheme "before" (\t -> t ==> signalOf bool)
110+ , timeScheme "after" (\t -> t ==> signalOf bool)
111111 , "dimensions" -: signalOf point
112112 , "position" -: signalOf point
113− , "x" -: signalOf IntT
114− , "y" -: signalOf IntT
115− , "isDown" -: signalOf BoolT
116− , "isClicked" -: signalOf BoolT
113+ , "x" -: signalOf int
114+ , "y" -: signalOf int
115+ , "isDown" -: signalOf bool
116+ , "isClicked" -: signalOf bool
117117 , "textField" -: string ==> tupleOf [element, signalOf string]
118118 , "password" -: string ==> tupleOf [element, signalOf string]
119− , "textArea" -: IntT ==> IntT ==> tupleOf [element, signalOf string]
120− , "checkBox" -: BoolT ==> tupleOf [element, signalOf BoolT]
121− , "button" -: string ==> tupleOf [element, signalOf BoolT]
119+ , "textArea" -: int ==> int ==> tupleOf [element, signalOf string]
120+ , "checkBox" -: bool ==> tupleOf [element, signalOf bool]
121+ , "button" -: string ==> tupleOf [element, signalOf bool]
122122 , "stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
123123 ]
124124
125125-------- Math and Binops --------
126126
127−iii = IntT ==> IntT ==> IntT
128−xxb x = x ==> x ==> BoolT
127+binop t = t ==> t ==> t
128+numScheme t name = (name, Forall [0] [VarT 0 :<: number] (t (VarT 0)))
129+timeScheme name t = (name, Forall [0] [VarT 0 :<: time] (t (VarT 0)))
129130
130131math =
131− hasType (IntT ==> iii) ["clamp"] ++
132− hasType iii ["+", "-", "*", "/","rem","mod","logBase","max","min"] ++
133− hasType (IntT ==> IntT) ["sin","cos","tan","asin","acos","atan","sqrt","abs"]
132+ map (numScheme (\t -> t ==> binop t)) ["clamp"] ++
133+ map (numScheme (\t -> binop t)) ["+","-","*","max","min"] ++
134+ [ numScheme (\t -> t ==> t) "abs" ] ++
135+ [ "/" -: binop float ] ++
136+ hasType (binop int) ["rem","div","mod","logBase"] ++
137+ hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"]
134138
135−bool =
136− [ "not" -: BoolT ==> BoolT ] ++
137− hasType (xxb BoolT) ["&&","||"] ++
138− hasType (xxb IntT) ["<",">","<=",">="]
139+bools =
140+ [ "not" -: bool ==> bool ] ++
141+ hasType (binop bool) ["&&","||"] ++
142+ hasType (int ==> int ==> bool) ["<",">","<=",">="]
139143
140144
141145-------- Polymorphic Functions --------
@@ -144,62 +148,60 @@ var = VarT `liftM` guid
144148vars n = mapM (const var) [1..n]
145149
146150infix 8 -::
147−name -:: tipe = return $ name -: tipe
148−
149−funcs = sequence
150− [ do a <- var ; "id" -:: a ==> a
151− , do a <- var ; "==" -:: a ==> a ==> BoolT
152− , do a <- var ; "/=" -:: a ==> a ==> BoolT
153− , do [a,b,c] <- vars 3 ; "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
154− , do [a,b,c] <- vars 3 ; "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
155− , do [a,b] <- vars 2 ; "$" -:: (a ==> b) ==> a ==> b
156− , do a <- var ; ":" -:: a ==> listOf a ==> listOf a
157− , do a <- var ; "++" -:: a ==> a ==> a
158− , do a <- var ; "Cons" -:: a ==> listOf a ==> listOf a
159− , do a <- var ; "Nil" -:: listOf a
160− , do a <- var ; "Just" -:: a ==> ADT "Maybe" [a]
161− , do a <- var ; "Nothing" -:: ADT "Maybe" [a]
162− , "elmRange" -:: IntT ==> IntT ==> listOf IntT
151+name -:: tipe = (name, Forall [1,2,3] [] tipe)
152+
153+[a,b,c] = map VarT [1,2,3]
154+
155+funcs =
156+ [ "id" -:: a ==> a
157+ , "==" -:: a ==> a ==> bool
158+ , "/=" -:: a ==> a ==> bool
159+ , "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
160+ , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
161+ , "$" -:: (a ==> b) ==> a ==> b
162+ , ":" -:: a ==> listOf a ==> listOf a
163+ , "++" -:: a ==> a ==> a
164+ , "Cons" -:: a ==> listOf a ==> listOf a
165+ , "Nil" -:: listOf a
166+ , "Just" -:: a ==> maybeOf a
167+ , "Nothing" -:: maybeOf a
168+ , "elmRange" -:: int ==> int ==> listOf int
163169 ]
164170
165−ints = map (-: (listOf IntT ==> IntT)) [ "sum","product","maximum","minimum" ]
166−
167−lists = liftM (++ints) . sequence $
168− [ "and" -:: listOf BoolT ==> BoolT
169− , "or" -:: listOf BoolT ==> BoolT
170− , "sort" -:: listOf IntT ==> listOf IntT
171− , do a <- var ; "head" -:: listOf a ==> a
172− , do a <- var ; "tail" -:: listOf a ==> listOf a
173− , do a <- var ; "length" -:: listOf a ==> IntT
174− , do a <- var ; "filter" -:: (a ==> BoolT) ==> listOf a ==> listOf a
175− , do a <- var ; "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
176− , do a <- var ; "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
177− , do a <- var ; "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
178− , do a <- var ; "forall" -:: (a ==> BoolT) ==> listOf a ==> BoolT
179− , do a <- var ; "exists" -:: (a ==> BoolT) ==> listOf a ==> BoolT
180− , do a <- var ; "concat" -:: listOf (listOf a) ==> listOf a
181− , do a <- var ; "reverse" -:: listOf a ==> listOf a
182− , do a <- var ; "take" -:: IntT ==> listOf a ==> listOf a
183− , do a <- var ; "drop" -:: IntT ==> listOf a ==> listOf a
184− , do a <- var ; "partition" -:: (a==>BoolT)==>listOf a==>tupleOf [listOf a,listOf a]
185− , do a <- var ; "intersperse" -:: a ==> listOf a ==> listOf a
186− , do a <- var ; "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a
187− , do [a,b] <- vars 2 ; "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
188− , do [a,b] <- vars 2 ; "map" -:: (a ==> b) ==> listOf a ==> listOf b
189− , do [a,b] <- vars 2 ; "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
190− , do [a,b] <- vars 2 ; "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
191− , do [a,b] <- vars 2 ; "scanl" -:: (a==>b==>b)==>b==>listOf a==>listOf b
192− , do [a,b] <- vars 2 ; "concatMap" -:: (a==>listOf b)==>listOf a ==> listOf b
193− , do [a,b,c] <- vars 3
194− "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
195− ]
171+lists =
172+ [ "and" -:: listOf bool ==> bool
173+ , "or" -:: listOf bool ==> bool
174+ , "sort" -:: listOf int ==> listOf int
175+ , "head" -:: listOf a ==> a
176+ , "tail" -:: listOf a ==> listOf a
177+ , "length" -:: listOf a ==> int
178+ , "filter" -:: (a ==> bool) ==> listOf a ==> listOf a
179+ , "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
180+ , "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
181+ , "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
182+ , "forall" -:: (a ==> bool) ==> listOf a ==> bool
183+ , "exists" -:: (a ==> bool) ==> listOf a ==> bool
184+ , "concat" -:: listOf (listOf a) ==> listOf a
185+ , "reverse" -:: listOf a ==> listOf a
186+ , "take" -:: int ==> listOf a ==> listOf a
187+ , "drop" -:: int ==> listOf a ==> listOf a
188+ , "partition" -:: (a ==> bool) ==> listOf a ==> tupleOf [listOf a,listOf a]
189+ , "intersperse" -:: a ==> listOf a ==> listOf a
190+ , "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a
191+ , "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
192+ , "map" -:: (a ==> b) ==> listOf a ==> listOf b
193+ , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
194+ , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
195+ , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
196+ , "concatMap" -:: (a ==> listOf b) ==> listOf a ==> listOf b
197+ , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
198+ ] ++ map (-: (listOf int ==> int)) [ "sum","product","maximum","minimum" ]
196199
197200
198201-------- Everything --------
199202
200−hints = do
201− fs <- funcs ; ls <- lists ; ss <- signals ; pcasts <- polyCasts
202− return $ concat [ fs, ls, ss, math, bool, str2elem, textAttrs
203− , elements, directions, colors, lineTypes, shapes
204− , concreteSignals, casts, pcasts
205− ]
203+hints =
204+ concat [ funcs, lists, signals, math, bools, str2elem, textAttrs
205+ , elements, directions, colors, lineTypes, shapes
206+ , concreteSignals, casts, polyCasts
207+ ]
elm/src/Types/Types.hs+49−29
@@ -1,43 +1,58 @@
11
22module Types where
33
4−import Data.List (intercalate)
4+import Data.Char (isDigit)
5+import Data.List (intercalate,isPrefixOf)
56import qualified Data.Set as Set
67
78type X = Int
89
9−data Type = IntT
10− | StringT
11− | CharT
12− | BoolT
13− | LambdaT Type Type
10+data Type = LambdaT Type Type
1411 | VarT X
1512 | ADT String [Type]
1613 deriving (Eq, Ord)
1714
18−data Scheme = Forall (Set.Set X) Type deriving (Eq, Ord, Show)
15+data Scheme = Forall [X] [Constraint] Type deriving (Eq, Ord, Show)
1916
20−element = ADT "Element" []
21−direction = ADT "Direction" []
17+data SuperType = SuperType String (Set.Set Type) deriving (Eq, Ord)
2218
23−form = ADT "Form" []
24−line = ADT "Line" []
25−shape = ADT "Shape" []
26−color = ADT "Color" []
27−text = ADT "List" [ADT "Text" []]
28−point = tupleOf [IntT,IntT]
19+data Constraint = Type :=: Type
20+ | Type :<: SuperType
21+ | Type :<<: Scheme
22+ deriving (Eq, Ord, Show)
23+
24+tipe t = ADT t []
25+
26+
27+int = tipe "Int"
28+float = tipe "Float"
29+number = SuperType "Number" (Set.fromList [ int, float ])
30+
31+char = tipe "Char"
32+bool = tipe "Bool"
33+
34+string = tipe "String"
35+text = tipe "Text"
36+
37+time = SuperType "Time" (Set.fromList [ int, float ])
38+
39+element = tipe "Element"
40+direction = tipe "Direction"
41+form = tipe "Form"
42+line = tipe "Line"
43+shape = tipe "Shape"
44+color = tipe "Color"
45+point = tupleOf [int,int]
2946
3047listOf t = ADT "List" [t]
3148signalOf t = ADT "Signal" [t]
3249tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
3350maybeOf t = ADT "Maybe" [t]
34−string = listOf CharT
35−time = IntT
3651
37−jsBool = ADT "JSBool" []
38−jsNumber = ADT "JSNumber" []
39−jsString = ADT "JSString" []
40−jsElement = ADT "JSElement" []
52+jsBool = tipe "JSBool"
53+jsNumber = tipe "JSNumber"
54+jsString = tipe "JSString"
55+jsElement = tipe "JSElement"
4156jsArray t = ADT "JSArray" [t]
4257jsTuple ts = ADT ("JSTuple" ++ show (length ts)) ts
4358
@@ -45,7 +60,7 @@ infixr ==>
4560t1 ==> t2 = LambdaT t1 t2
4661
4762infix 8 -:
48−name -: tipe = (,) name tipe
63+name -: tipe = (,) name $ Forall [] [] tipe
4964
5065hasType t = map (-: t)
5166
@@ -54,14 +69,19 @@ parens = ("("++) . (++")")
5469instance Show Type where
5570 show t =
5671 case t of
57− { IntT -> "Int"
58− ; StringT -> "String"
59− ; CharT -> "Char"
60− ; BoolT -> "Bool"
61− ; LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
72+ { LambdaT t1@(LambdaT _ _) t2 -> parens (show t1) ++ " -> " ++ show t2
6273 ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
6374 ; VarT x -> show x
6475 ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
65− ; ADT name [] -> name
66− ; ADT name cs -> parens $ name ++ " " ++ unwords (map show cs)
76+ ; ADT name cs ->
77+ if isTupleString name
78+ then parens . intercalate "," $ map show cs
79+ else case cs of [] -> name
80+ _ -> parens $ name ++ " " ++ unwords (map show cs)
6781 }
82+
83+instance Show SuperType where
84+ show (SuperType n ts) = "" ++ n ++ " (a type in {" ++ subs ++ "})"
85+ where subs = intercalate "," . map show $ Set.toList ts
86+
87+isTupleString str = "Tuple" `isPrefixOf` str && all isDigit (drop 5 str)
elm/src/Types/Unify.hs+24−14
@@ -29,33 +29,42 @@ solver ((LambdaT t1 t2 :=: LambdaT t1' t2') : cs) subs =
2929
3030solver ((VarT x :=: t) : cs) subs =
3131 solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs
32−solver ((t :=: VarT x) : cs) subs =
33− solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs
32+solver ((t :=: VarT x) : cs) subs = solver ((VarT x :=: t) : cs) subs
3433solver ((t1 :=: t2) : cs) subs =
3534 if t1 /= t2 then uniError t1 t2 else solver cs subs
3635
3736-------- subtypes --------
3837
39−solver ((t1 :<: t2) : cs) subs = do
40− let f x = do y <- guid ; return (x,VarT y)
41− pairs <- mapM f . Set.toList $ getVars t2
42− let t2' = foldr (uncurry tSub) t2 pairs
43− solver ((t1 :=: t2') : cs) subs
38+solver (c@(VarT x :<: SuperType n ts) : cs) subs
39+ | all isSuper cs = solver ((VarT x :=: ADT n []) : cs) subs
40+ | otherwise = solver (cs ++ [c]) subs
41+ where isSuper (VarT _ :<: _) = True
42+ isSuper _ = False
43+solver ((t@(ADT n1 []) :<: st@(SuperType n2 ts)) : cs) subs
44+ | n1 == n2 || Set.member t ts = solver cs subs
45+ | otherwise = return . Left $ "Type error: " ++ show t ++
46+ " is not a subtype of " ++ show st
47+solver ((t :<: st@(SuperType n ts)) : cs) subs
48+ | Set.member t ts = solver cs subs
49+ | otherwise = return . Left $ "Type error: " ++ show t ++
50+ " is not a subtype of " ++ show st
51+
52+solver ((t1 :<<: Forall xs cs' t2) : cs) subs = do
53+ pairs <- mapM (\x -> liftM ((,) x . VarT) guid) xs
54+ let t2' = foldr (uncurry tSub) t2 pairs
55+ let cs'' = foldr (\(k,v) -> map (cSub k v)) cs' pairs
56+ solver ((t1 :=: t2') : cs'' ++ cs) subs
4457
4558
4659cSub k v (t1 :=: t2) = force $ tSub k v t1 :=: tSub k v t2
47−cSub k v (t1 :<: t2) = force $ tSub k v t1 :<: tSub k v t2
60+cSub k v (t :<: super) = force $ tSub k v t :<: super
61+cSub k v (t :<<: poly) = force $ tSub k v t :<<: poly
4862
4963tSub k v t@(VarT x) = if k == x then v else t
5064tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)
5165tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)
5266tSub _ _ t = t
5367
54−getVars (VarT x) = Set.singleton x
55−getVars (LambdaT t1 t2) = Set.union (getVars t1) (getVars t2)
56−getVars (ADT name ts) = Set.unions $ map getVars ts
57−getVars _ = Set.empty
58−
5968uniError t1 t2 =
6069 return . Left $ "Type error: " ++ show t1 ++ " is not equal to " ++ show t2
6170
@@ -63,7 +72,8 @@ force x = x `deepseq` x
6372
6473instance NFData Constraint where
6574 rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` ()
66− rnf (t1 :<: t2) = t1 `deepseq` t2 `deepseq` ()
75+ rnf (t :<: _) = t `deepseq` ()
76+ rnf (t :<<: _) = t `deepseq` ()
6777
6878instance NFData Type where
6979 rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` ()