git.iko.soy/elk
on master help sign in
- Simplify basic types. Add more correct versions of Type Schemes and Super Types.
153d054evancz
elm/src/Types/Constrain.hs+12−15
compare with master
unifiedsplit
@@ -10,24 +10,19 @@ import Control.Monad (liftM,mapM)
10import Control.Monad.State (evalState)
10import Control.Monad.State (evalState)
11import Guid
11import Guid
12
12
13−data Constraint = Type :=: Type
14− | Type :<: Type
15− | Type :<<: Scheme
16− deriving (Eq, Ord, Show)
17−
18beta = VarT `liftM` guid
13beta = VarT `liftM` guid
19unionA = Map.unionWith (++)
14unionA = Map.unionWith (++)
20unionsA = Map.unionsWith (++)
15unionsA = Map.unionsWith (++)
21
16
22constrain hints expr = do
17constrain hints expr = do
23 (as,cs,t) <- inference expr
18 (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
26 return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap)
20 return $ Set.toList cs ++ (concat . map snd $ Map.toList cMap)
27
21
22+inference :: Expr -> GuidCounter (Map.Map String [X], Set.Set Constraint, Type)
28inference (Var x) =
23inference (Var x) =
29− do b <- beta
24+ do b <- guid
30− return (Map.singleton x [b], Set.empty, b)
25+ return (Map.singleton x [b], Set.empty, VarT b)
31inference (App e1 e2) =
26inference (App e1 e2) =
32 do (a1,c1,t1) <- inference e1
27 do (a1,c1,t1) <- inference e1
33 (a2,c2,t2) <- inference e2
28 (a2,c2,t2) <- inference e2
@@ -39,7 +34,7 @@ inference (Lambda x e) =
39 do (a,c,t) <- inference e
34 do (a,c,t) <- inference e
40 b <- beta
35 b <- beta
41 return ( Map.delete x a
36 return ( Map.delete x a
42− , Set.union c . Set.fromList . map (:=: b) $
37+ , Set.union c . Set.fromList . map (\x -> VarT x :=: b) $
43 Map.findWithDefault [] x a
38 Map.findWithDefault [] x a
44 , LambdaT b t )
39 , LambdaT b t )
45inference (Let defs e) =
40inference (Let defs e) =
@@ -47,7 +42,7 @@ inference (Let defs e) =
47 let (xs,es) = unzip defs
42 let (xs,es) = unzip defs
48 (as,cs,ts) <- unzip3 `liftM` mapM inference es
43 (as,cs,ts) <- unzip3 `liftM` mapM inference es
49 let assumptions = unionsA (a:as)
44 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
51 let constraints = Set.fromList . concat $ zipWith f xs ts
46 let constraints = Set.fromList . concat $ zipWith f xs ts
52 return ( foldr Map.delete assumptions xs
47 return ( foldr Map.delete assumptions xs
53 , Set.unions $ c:constraints:cs
48 , Set.unions $ c:constraints:cs
@@ -58,7 +53,7 @@ inference (If e1 e2 e3) =
58 (a2,c2,t2) <- inference e2
53 (a2,c2,t2) <- inference e2
59 (a3,c3,t3) <- inference e3
54 (a3,c3,t3) <- inference e3
60 return ( unionsA [a1,a2,a3]
55 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 ] ]
62 , t2 )
57 , t2 )
63
58
64inference (Data name es) = inference $ foldl' App (Var name) es
59inference (Data name es) = inference $ foldl' App (Var name) es
@@ -68,10 +63,12 @@ inference (Range e1 e2) = inference (Var "elmRange" `App` e1 `App` e2)
68
63
69inference other =
64inference other =
70 case other of
65 case other of
66+ IntNum _ -> do t <- beta
67+ return (Map.empty, Set.singleton (t :<: number), t)
71− Number _ -> primitive IntT
68+ FloatNum _ -> primitive float
72− Chr _ -> primitive CharT
69+ Chr _ -> primitive char
73 Str _ -> primitive string
70 Str _ -> primitive string
74− Boolean _ -> primitive BoolT
71+ Boolean _ -> primitive bool
75 _ -> beta >>= primitive
72 _ -> beta >>= primitive
76
73
77primitive t = return (Map.empty, Set.empty, t)
74primitive t = return (Map.empty, Set.empty, t)
elm/src/Types/Hints.hs+122−120
@@ -16,126 +16,130 @@ textToText = [ "header", "italic", "bold", "underline"
16
16
17textAttrs = [ "toText" -: string ==> text
17textAttrs = [ "toText" -: string ==> text
18 , "link" -: string ==> text ==> text
18 , "link" -: string ==> text ==> text
19− , "Text.height" -: IntT ==> text ==> text
19+ , "Text.height" -: int ==> text ==> text
20 ] ++ hasType (text ==> text) textToText
20 ] ++ hasType (text ==> text) textToText
21
21
22−elements = let iee = IntT ==> element ==> element in
22+elements = let iee = int ==> element ==> element in
23 [ "flow" -: direction ==> listOf element ==> element
23 [ "flow" -: direction ==> listOf element ==> element
24 , "layers" -: listOf element ==> element
24 , "layers" -: listOf element ==> element
25 , "text" -: text ==> element
25 , "text" -: text ==> element
26 , "opacity" -: iee
26 , "opacity" -: iee
27 , "width" -: iee
27 , "width" -: iee
28 , "height" -: iee
28 , "height" -: iee
29− , "size" -: IntT ==> iee
29+ , "size" -: int ==> iee
30 , "box" -: iee
30 , "box" -: iee
31 , "centeredText" -: text ==> element
31 , "centeredText" -: text ==> element
32 , "justifiedText" -: text ==> element
32 , "justifiedText" -: text ==> element
33− , "collage" -: IntT ==> IntT ==> listOf form ==> element
33+ , "collage" -: int ==> int ==> listOf form ==> element
34 ]
34 ]
35
35
36directions = hasType direction ["up","down","left","right","inward","outward"]
36directions = hasType direction ["up","down","left","right","inward","outward"]
37−colors = [ "rgb" -: IntT ==> IntT ==> IntT ==> color
37+colors = [ "rgb" -: int ==> int ==> int ==> color
38− , "rgba" -: IntT ==> IntT ==> IntT ==> IntT ==> color
38+ , "rgba" -: int ==> int ==> int ==> int ==> color
39 ] ++ hasType color ["red","green","blue","black","white"]
39 ] ++ hasType color ["red","green","blue","black","white"]
40
40
41lineTypes = [ "line" -: listOf point ==> line
41lineTypes = [ "line" -: listOf point ==> line
42− , "customLine" -: listOf IntT ==> color ==> line ==> form
42+ , "customLine" -: listOf int ==> color ==> line ==> form
43 ] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"]
43 ] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"]
44
44
45shapes = [ "polygon" -: listOf point ==> point ==> shape
45shapes = [ "polygon" -: listOf point ==> point ==> shape
46 , "filled" -: color ==> shape ==> form
46 , "filled" -: color ==> shape ==> form
47 , "outlined" -: color ==> shape ==> form
47 , "outlined" -: color ==> shape ==> form
48− , "customOutline" -: listOf IntT ==> color ==> shape ==> form
48+ , "customOutline" -: listOf int ==> color ==> shape ==> form
49− ] ++ hasType (IntT ==> IntT ==> point ==> shape) ["ngon","rect","oval"]
49+ ] ++ hasType (int ==> int ==> point ==> shape) ["ngon","rect","oval"]
50
50
51
51
52-------- Foreign --------
52-------- Foreign --------
53
53
54casts =
54casts =
55− [ "castJSBoolToBool" -: jsBool ==> BoolT
55+ [ "castJSBoolToBool" -: jsBool ==> bool
56− , "castBoolToJSBool" -: BoolT ==> jsBool
56+ , "castBoolToJSBool" -: bool ==> jsBool
57− , "castJSNumberToInt" -: jsNumber ==> IntT
57+ , "castJSNumberToInt" -: jsNumber ==> int
58− , "castIntToJSNumber" -: IntT ==> jsNumber
58+ , "castIntToJSNumber" -: int ==> jsNumber
59− , "castJSElementToElement" -: IntT ==> IntT ==> jsElement ==> element
59+ , "castJSElementToElement" -: int ==> int ==> jsElement ==> element
60 , "castElementToJSElement" -: element ==> jsElement
60 , "castElementToJSElement" -: element ==> jsElement
61 , "castJSStringToString" -: jsString ==> string
61 , "castJSStringToString" -: jsString ==> string
62 , "castStringToJSString" -: string ==> jsString
62 , "castStringToJSString" -: string ==> jsString
63− -- , "castJSNumberToFloat -:
63+ , "castJSNumberToFloat" -: jsNumber ==> float
64− -- , "castFloatToJSNumber -:
64+ , "castFloatToJSNumber" -: float ==> jsNumber
65 ]
65 ]
66
66
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+
67−polyCasts = sequence
74+polyCasts =
75+ map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
68− [ do a <- var ; "castJSArrayToList" -:: jsArray a ==> listOf a
76+ [ "castJSArrayToList" -:: jsArray a ==> listOf a
69− , do a <- var ; "castListToJSArray" -:: listOf a ==> jsArray a
77+ , "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
78 ]
78 ]
79
79
80
80
81-------- Signals --------
81-------- Signals --------
82
82
83−sig ts = fn ts ==> fn (map signalOf ts)
83+sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
84 where fn = foldr1 (==>)
84 where fn = foldr1 (==>)
85−
85+ ts = map VarT [1..n]
86+
86−signals = sequence
87+signals =
87− [ do ts <- vars 1 ; "constant" -:: sig ts
88+ [ sig 1 "constant"
88− , do ts <- vars 2 ; "lift" -:: sig ts
89+ , sig 2 "lift"
89− , do ts <- vars 3 ; "lift2" -:: sig ts
90+ , sig 3 "lift2"
90− , do ts <- vars 4 ; "lift3" -:: sig ts
91+ , sig 4 "lift3"
91− , do ts <- vars 5 ; "lift4" -:: sig ts
92+ , sig 5 "lift4"
92− , do [a,b] <- vars 2
93− "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
93+ , "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
94− , do a <- var ; "randomize" -:: IntT ==> IntT ==> signalOf a ==> signalOf IntT
94+ , "randomize" -:: int ==> int ==> signalOf a ==> signalOf int
95− , do a <- var ; "count" -:: signalOf a ==> signalOf IntT
95+ , "count" -:: signalOf a ==> signalOf int
96− , do a <- var ; "keepIf" -:: (a==>BoolT) ==> a ==> signalOf a ==> signalOf a
96+ , "keepIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
97− , do a <- var ; "dropIf" -:: (a==>BoolT) ==> a ==> signalOf a ==> signalOf a
97+ , "dropIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
98− , do a <- var ; "keepWhen" -:: signalOf BoolT ==>a==> signalOf a ==> signalOf a
98+ , "keepWhen" -:: signalOf bool ==>a==> signalOf a ==> signalOf a
99− , do a <- var ; "dropWhen" -:: signalOf BoolT ==>a==> signalOf a ==> signalOf a
99+ , "dropWhen" -:: signalOf bool ==>a==> signalOf a ==> signalOf a
100− , do a <- var ; "dropRepeats" -:: signalOf a ==> signalOf a
100+ , "dropRepeats" -:: signalOf a ==> signalOf a
101− , do [a,b] <- vars 2 ; "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
101+ , "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
102 ]
102 ]
103
103
104concreteSignals =
104concreteSignals =
105− [ "keysDown" -: signalOf (listOf IntT)
105+ [ "keysDown" -: signalOf (listOf int)
106− , "charPressed" -: signalOf (maybeOf IntT)
106+ , "charPressed" -: signalOf (maybeOf int)
107− , "inRange" -: IntT ==> IntT ==> signalOf IntT
107+ , "inRange" -: int ==> int ==> signalOf int
108− , "every" -: time ==> signalOf time
108+ , timeScheme "every" (\t -> t ==> signalOf t)
109− , "before" -: time ==> signalOf BoolT
109+ , timeScheme "before" (\t -> t ==> signalOf bool)
110− , "after" -: time ==> signalOf BoolT
110+ , timeScheme "after" (\t -> t ==> signalOf bool)
111 , "dimensions" -: signalOf point
111 , "dimensions" -: signalOf point
112 , "position" -: signalOf point
112 , "position" -: signalOf point
113− , "x" -: signalOf IntT
113+ , "x" -: signalOf int
114− , "y" -: signalOf IntT
114+ , "y" -: signalOf int
115− , "isDown" -: signalOf BoolT
115+ , "isDown" -: signalOf bool
116− , "isClicked" -: signalOf BoolT
116+ , "isClicked" -: signalOf bool
117 , "textField" -: string ==> tupleOf [element, signalOf string]
117 , "textField" -: string ==> tupleOf [element, signalOf string]
118 , "password" -: string ==> tupleOf [element, signalOf string]
118 , "password" -: string ==> tupleOf [element, signalOf string]
119− , "textArea" -: IntT ==> IntT ==> tupleOf [element, signalOf string]
119+ , "textArea" -: int ==> int ==> tupleOf [element, signalOf string]
120− , "checkBox" -: BoolT ==> tupleOf [element, signalOf BoolT]
120+ , "checkBox" -: bool ==> tupleOf [element, signalOf bool]
121− , "button" -: string ==> tupleOf [element, signalOf BoolT]
121+ , "button" -: string ==> tupleOf [element, signalOf bool]
122 , "stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
122 , "stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
123 ]
123 ]
124
124
125-------- Math and Binops --------
125-------- Math and Binops --------
126
126
127−iii = IntT ==> IntT ==> IntT
127+binop t = t ==> t ==> t
128−xxb x = x ==> x ==> BoolT
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)))
129
130
130math =
131math =
131− hasType (IntT ==> iii) ["clamp"] ++
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 ] ++
132− hasType iii ["+", "-", "*", "/","rem","mod","logBase","max","min"] ++
136+ hasType (binop int) ["rem","div","mod","logBase"] ++
133− hasType (IntT ==> IntT) ["sin","cos","tan","asin","acos","atan","sqrt","abs"]
137+ hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"]
134
138
135−bool =
139+bools =
136− [ "not" -: BoolT ==> BoolT ] ++
140+ [ "not" -: bool ==> bool ] ++
137− hasType (xxb BoolT) ["&&","||"] ++
141+ hasType (binop bool) ["&&","||"] ++
138− hasType (xxb IntT) ["<",">","<=",">="]
142+ hasType (int ==> int ==> bool) ["<",">","<=",">="]
139
143
140
144
141-------- Polymorphic Functions --------
145-------- Polymorphic Functions --------
@@ -144,62 +148,60 @@ var = VarT `liftM` guid
144vars n = mapM (const var) [1..n]
148vars n = mapM (const var) [1..n]
145
149
146infix 8 -::
150infix 8 -::
147−name -:: tipe = return $ name -: tipe
151+name -:: tipe = (name, Forall [1,2,3] [] tipe)
148−
152+
153+[a,b,c] = map VarT [1,2,3]
154+
149−funcs = sequence
155+funcs =
150− [ do a <- var ; "id" -:: a ==> a
156+ [ "id" -:: a ==> a
151− , do a <- var ; "==" -:: a ==> a ==> BoolT
157+ , "==" -:: a ==> a ==> bool
152− , do a <- var ; "/=" -:: a ==> a ==> BoolT
158+ , "/=" -:: a ==> a ==> bool
153− , do [a,b,c] <- vars 3 ; "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
159+ , "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
154− , do [a,b,c] <- vars 3 ; "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
160+ , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
155− , do [a,b] <- vars 2 ; "$" -:: (a ==> b) ==> a ==> b
161+ , "$" -:: (a ==> b) ==> a ==> b
156− , do a <- var ; ":" -:: a ==> listOf a ==> listOf a
162+ , ":" -:: a ==> listOf a ==> listOf a
157− , do a <- var ; "++" -:: a ==> a ==> a
163+ , "++" -:: a ==> a ==> a
158− , do a <- var ; "Cons" -:: a ==> listOf a ==> listOf a
164+ , "Cons" -:: a ==> listOf a ==> listOf a
159− , do a <- var ; "Nil" -:: listOf a
165+ , "Nil" -:: listOf a
160− , do a <- var ; "Just" -:: a ==> ADT "Maybe" [a]
166+ , "Just" -:: a ==> maybeOf a
161− , do a <- var ; "Nothing" -:: ADT "Maybe" [a]
167+ , "Nothing" -:: maybeOf a
162− , "elmRange" -:: IntT ==> IntT ==> listOf IntT
168+ , "elmRange" -:: int ==> int ==> listOf int
163 ]
169 ]
164
170
165−ints = map (-: (listOf IntT ==> IntT)) [ "sum","product","maximum","minimum" ]
171+lists =
166−
167−lists = liftM (++ints) . sequence $
168− [ "and" -:: listOf BoolT ==> BoolT
172+ [ "and" -:: listOf bool ==> bool
169− , "or" -:: listOf BoolT ==> BoolT
173+ , "or" -:: listOf bool ==> bool
170− , "sort" -:: listOf IntT ==> listOf IntT
174+ , "sort" -:: listOf int ==> listOf int
171− , do a <- var ; "head" -:: listOf a ==> a
175+ , "head" -:: listOf a ==> a
172− , do a <- var ; "tail" -:: listOf a ==> listOf a
176+ , "tail" -:: listOf a ==> listOf a
173− , do a <- var ; "length" -:: listOf a ==> IntT
177+ , "length" -:: listOf a ==> int
174− , do a <- var ; "filter" -:: (a ==> BoolT) ==> listOf a ==> listOf a
178+ , "filter" -:: (a ==> bool) ==> listOf a ==> listOf a
175− , do a <- var ; "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
179+ , "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
176− , do a <- var ; "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
180+ , "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
177− , do a <- var ; "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
181+ , "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
178− , do a <- var ; "forall" -:: (a ==> BoolT) ==> listOf a ==> BoolT
182+ , "forall" -:: (a ==> bool) ==> listOf a ==> bool
179− , do a <- var ; "exists" -:: (a ==> BoolT) ==> listOf a ==> BoolT
183+ , "exists" -:: (a ==> bool) ==> listOf a ==> bool
180− , do a <- var ; "concat" -:: listOf (listOf a) ==> listOf a
184+ , "concat" -:: listOf (listOf a) ==> listOf a
181− , do a <- var ; "reverse" -:: listOf a ==> listOf a
185+ , "reverse" -:: listOf a ==> listOf a
182− , do a <- var ; "take" -:: IntT ==> listOf a ==> listOf a
186+ , "take" -:: int ==> listOf a ==> listOf a
183− , do a <- var ; "drop" -:: IntT ==> listOf a ==> listOf a
187+ , "drop" -:: int ==> listOf a ==> listOf a
184− , do a <- var ; "partition" -:: (a==>BoolT)==>listOf a==>tupleOf [listOf a,listOf a]
188+ , "partition" -:: (a ==> bool) ==> listOf a ==> tupleOf [listOf a,listOf a]
185− , do a <- var ; "intersperse" -:: a ==> listOf a ==> listOf a
189+ , "intersperse" -:: a ==> listOf a ==> listOf a
186− , do a <- var ; "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a
190+ , "intercalate" -:: listOf a ==> listOf(listOf a) ==> listOf a
187− , do [a,b] <- vars 2 ; "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
191+ , "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
188− , do [a,b] <- vars 2 ; "map" -:: (a ==> b) ==> listOf a ==> listOf b
192+ , "map" -:: (a ==> b) ==> listOf a ==> listOf b
189− , do [a,b] <- vars 2 ; "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
193+ , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
190− , do [a,b] <- vars 2 ; "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
194+ , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
191− , do [a,b] <- vars 2 ; "scanl" -:: (a==>b==>b)==>b==>listOf a==>listOf b
195+ , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
192− , do [a,b] <- vars 2 ; "concatMap" -:: (a==>listOf b)==>listOf a ==> listOf b
196+ , "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
197+ , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
195− ]
198+ ] ++ map (-: (listOf int ==> int)) [ "sum","product","maximum","minimum" ]
196
199
197
200
198-------- Everything --------
201-------- Everything --------
199
202
200−hints = do
203+hints =
201− fs <- funcs ; ls <- lists ; ss <- signals ; pcasts <- polyCasts
202− return $ concat [ fs, ls, ss, math, bool, str2elem, textAttrs
204+ concat [ funcs, lists, signals, math, bools, str2elem, textAttrs
203− , elements, directions, colors, lineTypes, shapes
205+ , elements, directions, colors, lineTypes, shapes
204− , concreteSignals, casts, pcasts
206+ , concreteSignals, casts, polyCasts
205− ]
207+ ]
elm/src/Types/Types.hs+49−29
@@ -1,43 +1,58 @@
1
1
2module Types where
2module Types where
3
3
4+import Data.Char (isDigit)
4−import Data.List (intercalate)
5+import Data.List (intercalate,isPrefixOf)
5import qualified Data.Set as Set
6import qualified Data.Set as Set
6
7
7type X = Int
8type X = Int
8
9
9−data Type = IntT
10− | StringT
11− | CharT
12− | BoolT
13− | LambdaT Type Type
10+data Type = LambdaT Type Type
14 | VarT X
11 | VarT X
15 | ADT String [Type]
12 | ADT String [Type]
16 deriving (Eq, Ord)
13 deriving (Eq, Ord)
17
14
18−data Scheme = Forall (Set.Set X) Type deriving (Eq, Ord, Show)
15+data Scheme = Forall [X] [Constraint] Type deriving (Eq, Ord, Show)
19
16
20−element = ADT "Element" []
17+data SuperType = SuperType String (Set.Set Type) deriving (Eq, Ord)
21−direction = ADT "Direction" []
22
18
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"
23−form = ADT "Form" []
41+form = tipe "Form"
24−line = ADT "Line" []
42+line = tipe "Line"
25−shape = ADT "Shape" []
43+shape = tipe "Shape"
26−color = ADT "Color" []
44+color = tipe "Color"
27−text = ADT "List" [ADT "Text" []]
28−point = tupleOf [IntT,IntT]
45+point = tupleOf [int,int]
29
46
30listOf t = ADT "List" [t]
47listOf t = ADT "List" [t]
31signalOf t = ADT "Signal" [t]
48signalOf t = ADT "Signal" [t]
32tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
49tupleOf ts = ADT ("Tuple" ++ show (length ts)) ts
33maybeOf t = ADT "Maybe" [t]
50maybeOf t = ADT "Maybe" [t]
34−string = listOf CharT
35−time = IntT
36
51
37−jsBool = ADT "JSBool" []
52+jsBool = tipe "JSBool"
38−jsNumber = ADT "JSNumber" []
53+jsNumber = tipe "JSNumber"
39−jsString = ADT "JSString" []
54+jsString = tipe "JSString"
40−jsElement = ADT "JSElement" []
55+jsElement = tipe "JSElement"
41jsArray t = ADT "JSArray" [t]
56jsArray t = ADT "JSArray" [t]
42jsTuple ts = ADT ("JSTuple" ++ show (length ts)) ts
57jsTuple ts = ADT ("JSTuple" ++ show (length ts)) ts
43
58
@@ -45,7 +60,7 @@ infixr ==>
45t1 ==> t2 = LambdaT t1 t2
60t1 ==> t2 = LambdaT t1 t2
46
61
47infix 8 -:
62infix 8 -:
48−name -: tipe = (,) name tipe
63+name -: tipe = (,) name $ Forall [] [] tipe
49
64
50hasType t = map (-: t)
65hasType t = map (-: t)
51
66
@@ -54,14 +69,19 @@ parens = ("("++) . (++")")
54instance Show Type where
69instance Show Type where
55 show t =
70 show t =
56 case t of
71 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
62 ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
73 ; LambdaT t1 t2 -> show t1 ++ " -> " ++ show t2
63 ; VarT x -> show x
74 ; VarT x -> show x
64 ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
75 ; ADT "List" [tipe] -> "[" ++ show tipe ++ "]"
65− ; ADT name [] -> name
76+ ; ADT name cs ->
77+ if isTupleString name
78+ then parens . intercalate "," $ map show cs
79+ else case cs of [] -> name
66− ; ADT name cs -> parens $ name ++ " " ++ unwords (map show cs)
80+ _ -> parens $ name ++ " " ++ unwords (map show cs)
67 }
81 }
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 =
29
29
30solver ((VarT x :=: t) : cs) subs =
30solver ((VarT x :=: t) : cs) subs =
31 solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs
31 solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs
32−solver ((t :=: VarT x) : cs) subs =
32+solver ((t :=: VarT x) : cs) subs = solver ((VarT x :=: t) : cs) subs
33− solver (map (cSub x t) cs) . map (second $ tSub x t) $ (x,t):subs
34solver ((t1 :=: t2) : cs) subs =
33solver ((t1 :=: t2) : cs) subs =
35 if t1 /= t2 then uniError t1 t2 else solver cs subs
34 if t1 /= t2 then uniError t1 t2 else solver cs subs
36
35
37-------- subtypes --------
36-------- subtypes --------
38
37
39−solver ((t1 :<: t2) : cs) subs = do
38+solver (c@(VarT x :<: SuperType n ts) : cs) subs
40− let f x = do y <- guid ; return (x,VarT y)
39+ | all isSuper cs = solver ((VarT x :=: ADT n []) : cs) subs
41− pairs <- mapM f . Set.toList $ getVars t2
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
42− let t2' = foldr (uncurry tSub) t2 pairs
54+ let t2' = foldr (uncurry tSub) t2 pairs
55+ let cs'' = foldr (\(k,v) -> map (cSub k v)) cs' pairs
43− solver ((t1 :=: t2') : cs) subs
56+ solver ((t1 :=: t2') : cs'' ++ cs) subs
44
57
45
58
46cSub k v (t1 :=: t2) = force $ tSub k v t1 :=: tSub k v t2
59cSub 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
48
62
49tSub k v t@(VarT x) = if k == x then v else t
63tSub k v t@(VarT x) = if k == x then v else t
50tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)
64tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)
51tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)
65tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)
52tSub _ _ t = t
66tSub _ _ t = t
53
67
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−
59uniError t1 t2 =
68uniError t1 t2 =
60 return . Left $ "Type error: " ++ show t1 ++ " is not equal to " ++ show t2
69 return . Left $ "Type error: " ++ show t1 ++ " is not equal to " ++ show t2
61
70
@@ -63,7 +72,8 @@ force x = x `deepseq` x
63
72
64instance NFData Constraint where
73instance NFData Constraint where
65 rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` ()
74 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` ()
67
77
68instance NFData Type where
78instance NFData Type where
69 rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` ()
79 rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` ()