git.iko.soy/elk
on master help sign in
Detect ambiguous variable usage and report this to the user. Make the compiler match up import aliases with the underlying type hints. Add a ton of type hints.
commit56b5e53d2cefc20aabc41c33f94a9658f40d0a90 authorevancz <info@elm-lang.org> dateSun 21 Oct 2012, 04:50 (14 years ago) parent962e6ac
6 files changed+195−84
compare with master
unifiedsplit
elm/src/Ast.hs+1 elm/src/Gen/CompileToJS.hs−1 elm/src/Parse/ParseModules.hs+2−2 elm/src/Types/Constrain.hs+37−10 elm/src/Types/Hints.hs+149−68 elm/src/Types/Unify.hs+6−3
elm/src/Ast.hs+1
@@ -13,6 +13,7 @@ type Exports = [String]
1313
1414type Imports = [(String, ImportMethod)]
1515data ImportMethod = As String | Hiding [String] | Importing [String]
16+ deriving (Eq,Ord)
1617
1718
1819data Pattern = PData String [Pattern] | PVar String | PAnything
elm/src/Gen/CompileToJS.hs−1
@@ -90,7 +90,6 @@ jsImport (modul, how) =
9090 jsImport' (modul, how)
9191
9292jsImport' (modul, As name) = assign name modul
93−jsImport' (modul, Importing []) = jsImport' (modul, Hiding [])
9493jsImport' (modul, Importing vs) =
9594 concatMap (\v -> assign v $ modul ++ "." ++ v) vs
9695jsImport' (modul, Hiding vs) =
elm/src/Parse/ParseModules.hs+2−2
@@ -28,8 +28,8 @@ import' = do
2828 reserved "import"
2929 whitespace
3030 name <- intercalate "." <$> dotSep1 capVar
31− method <- option (Importing []) $ try (whitespace >>
32− (as' <|> hiding' <|> importing'))
31+ method <- option (Hiding []) $ try (whitespace >>
32+ (as' <|> hiding' <|> importing'))
3333 return (name, method)
3434
3535
elm/src/Types/Constrain.hs+37−10
@@ -3,7 +3,7 @@ module Types.Constrain (constrain) where
33
44import Ast
55import Types
6−import Data.List (foldl')
6+import Data.List (foldl',sort,group,isPrefixOf,intercalate,isSuffixOf)
77import qualified Data.Set as Set
88import qualified Data.Map as Map
99import Control.Arrow (second)
@@ -20,15 +20,42 @@ beta = VarT `liftM` guid
2020unionA = Map.unionWith (++)
2121unionsA = Map.unionsWith (++)
2222
23−constrain hints (Module _ _ _ stmts) = do
24− (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
25− allHints <- liftM (Map.fromList . (++ concat schemess)) hints
26− let insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
27− assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
28− let cs = let f k s vs = map (\v -> Context k $ v :<<: s) vs in
29− concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
30− let escapees = Map.keys $ Map.difference assumptions allHints
31− return . (,) escapees $ cs ++ Set.toList (Set.unions css)
23+getAliases imports hints = hints ++ concatMap aliasesFrom imports'
24+ where imports' = map head . group $ sort imports
25+ aliasesFrom (name,method) =
26+ case method of
27+ As alias -> concatMap (findAlias name alias) hints
28+ Hiding [] -> concatMap (findAlias name "") hints
29+ _ -> []
30+ findAlias mName' mAlias (name,tipe) =
31+ let mName = mName' ++ "." in
32+ case mName `isPrefixOf` name of
33+ True -> [ (mAlias ++ drop (length mName) name, tipe) ]
34+ False -> []
35+
36+findAmbiguous hints hints' assumptions continue =
37+ let potentialDups = map head . filter (\g -> length g > 1) . group $ sort hints'
38+ dups = filter (\k -> Map.member k assumptions) potentialDups
39+ in case dups of
40+ n:_ -> return . Left $ "Error: Ambiguous occurrence of '" ++ n ++ "' could refer to " ++
41+ intercalate ", " (filter (isSuffixOf n) hints)
42+ _ -> continue
43+
44+constrain typeHints (Module _ _ imports stmts) = do
45+ (ass,css,schemess) <- unzip3 `liftM` mapM stmtGen stmts
46+ hints <- typeHints
47+ let aliasHints = getAliases (imports ++ extraImports) hints
48+ let allHints = Map.fromList (aliasHints ++ concat schemess)
49+ assumptions <- foldM insert (unionsA ass) $ map fst (concat schemess)
50+ findAmbiguous (map fst hints) (map fst aliasHints) assumptions $
51+ do let cs = let f k s vs = map (\v -> Context k $ v :<<: s) vs in
52+ concat . Map.elems $ Map.intersectionWithKey f allHints assumptions
53+ let escapees = Map.keys $ Map.difference assumptions allHints
54+ return . Right . (,) escapees $ cs ++ Set.toList (Set.unions css)
55+ where extraImports =
56+ map (\n -> (n, Hiding []))
57+ ["List","Signal","Graphics.Text","Graphics.Element","Graphics.Color"]
58+ insert as n = do v <- guid; return $ Map.insertWith' (\_ x -> x) n [v] as
3259
3360gen :: Expr -> GuidCounter (Map.Map String [X], Set.Set (Context String Constraint), Type)
3461
elm/src/Types/Hints.hs+149−68
@@ -7,43 +7,45 @@ import Types
77import Types.Substitutions (rescheme)
88
99
10−-------- Text and Elements --------
10+prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
1111
12−str2elem = hasType (string ==> element) [ "plainText" ]
12+-------- Text and Elements --------
1313
1414textToText = [ "header", "italic", "bold", "underline"
1515 , "overline", "strikeThrough", "monospace" ]
1616
1717textAttrs = [ "toText" -: string ==> text
18− , "typeface" -: string ==> text ==> text
19− , "link" -:: string ==> a ==> a
20− , numScheme (\t -> t ==> text ==> text) "Text.height"
21− ] ++ hasType (text ==> text) textToText
22−
23−elements = let iee = int ==> element ==> element in
24− [ "flow" -: direction ==> listOf element ==> element
25− , "layers" -: listOf element ==> element
26− , "text" -: text ==> element
27− , "image" -: int ==> int ==> string ==> element
28− , "video" -: int ==> int ==> string ==> element
29− , "opacity" -: float ==> element ==> element
30− , "width" -: iee
31− , "height" -: iee
32− , "size" -: int ==> iee
33− , "widthOf" -: element ==> int
34− , "heightOf"-: element ==> int
35− , "sizeOf" -: element ==> pairOf int
36− , "color" -: color ==> element ==> element
37− , "container" -: int ==> int ==> position ==> element ==> element
38− , "spacer" -: int ==> int ==> element
39− , "rightedText" -: text ==> element
40− , "centeredText" -: text ==> element
41− , "justifiedText" -: text ==> element
42− , "asText" -:: a ==> element
43− , "show" -:: a ==> string
44− , "collage" -: int ==> int ==> listOf form ==> element
45− , "fittedImage" -: int ==> int ==> string ==> element
46− ]
18+ , "Graphics.Text.typeface" -: string ==> text ==> text
19+ , "Graphics.Text.link" -:: string ==> text ==> text
20+ , numScheme (\t -> t ==> text ==> text) "Graphics.Text.height"
21+ ] ++ prefix "Graphics.Text" (hasType (text ==> text) textToText)
22+
23+elements =
24+ let iee = int ==> element ==> element in
25+ [ "plainText" -: string ==> element
26+ , "link" -:: string ==> element ==> element
27+ , "flow" -: direction ==> listOf element ==> element
28+ , "layers" -: listOf element ==> element
29+ , "text" -: text ==> element
30+ , "image" -: int ==> int ==> string ==> element
31+ , "video" -: int ==> int ==> string ==> element
32+ , "opacity" -: float ==> element ==> element
33+ , "width" -: iee
34+ , "height" -: iee
35+ , "size" -: int ==> iee
36+ , "widthOf" -: element ==> int
37+ , "heightOf"-: element ==> int
38+ , "sizeOf" -: element ==> pairOf int
39+ , "color" -: color ==> element ==> element
40+ , "container" -: int ==> int ==> position ==> element ==> element
41+ , "spacer" -: int ==> int ==> element
42+ , "rightedText" -: text ==> element
43+ , "centeredText" -: text ==> element
44+ , "justifiedText" -: text ==> element
45+ , "asText" -:: a ==> element
46+ , "collage" -: int ==> int ==> listOf form ==> element
47+ , "fittedImage" -: int ==> int ==> string ==> element
48+ ]
4749
4850directions = hasType direction ["up","down","left","right","inward","outward"]
4951positions =
@@ -52,10 +54,6 @@ positions =
5254 hasType (location ==> location ==> position)
5355 ["topLeftAt","bottomLeftAt","middleAt","topRightAt","bottomRightAt"] ++
5456 [ "absolute" -: int ==> location, "relative" -: float ==> location ]
55−colors = [ numScheme (\n -> n ==> n ==> n ==> color) "rgb"
56− , numScheme (\n -> n ==> n ==> n ==> n ==> color) "rgba"
57− ] ++ hasType color ["red","green","blue","black","white"
58− ,"yellow","cyan","magenta","grey","gray"]
5957
6058lineTypes = [ numScheme (\n -> listOf (pairOf n) ==> line) "line"
6159 , numScheme (\n -> pairOf n ==> pairOf n ==> line) "segment"
@@ -79,6 +77,15 @@ collages = [ numScheme (\n -> pairOf n ==> element ==> form) "toForm"
7977 , numScheme (\n -> pairOf n ==> form ==> bool) "isWithin"
8078 ]
8179
80+graphicsElement = prefix "Graphics.Element"
81+ (concat [elements,directions,positions,lineTypes,shapes,collages])
82+graphicsColor = prefix "Graphics.Color" clrs
83+ where clrs = [ numScheme (\n -> n ==> n ==> n ==> color) "rgb"
84+ , numScheme (\n -> n ==> n ==> n ==> n ==> color) "rgba"
85+ ] ++ hasType color ["red","green","blue","black","white"
86+ ,"yellow","cyan","magenta","grey","gray"]
87+
88+
8289-------- Foreign --------
8390
8491casts =
@@ -107,16 +114,28 @@ polyCasts =
107114 , "castListToJSArray" -:: listOf a ==> jsArray a
108115 ]
109116
110−json =
117+javascript = prefix "JavaScript" (concat [casts,polyCasts])
118+
119+json = prefix "JSON"
111120 [ "JsonString" -: string ==> jsonValue
112121 , "JsonBool" -: bool ==> jsonValue
113122 , "JsonNull" -: jsonValue
114123 , "JsonArray" -: listOf jsonValue ==> jsonValue
115124 , "JsonObject" -: jsonObject ==> jsonValue
116125 , numScheme (\n -> n ==> jsonValue) "JsonNumber"
117− , "toPrettyString" -: string ==> jsonObject ==> string
126+ , "toString" -: jsonObject ==> string
127+ , "fromString" -: string ==> jsonObject
128+ , "lookup" -: string ==> jsonObject ==> maybeOf jsonValue
129+ , "findObject" -: string ==> jsonObject ==> jsonObject
130+ , "findArray" -: string ==> jsonObject ==> listOf jsonObject
131+ , "findString" -: string ==> jsonObject ==> string
132+ , "findWithDefault" -:: jsonValue ==> string ==> jsonObject ==> jsonValue
133+ , "toPrettyString" -: string ==> jsonObject ==> string
118134 , "toPrettyJSString" -: string ==> jsonObject ==> jsString
119− , "toJSString" -: jsonObject ==> jsString
135+ , "toList" -: jsonObject ==> listOf (tupleOf [string,jsonValue])
136+ , "fromList" -: listOf (tupleOf [string,jsonValue]) ==> jsonObject
137+ , "toJSString" -: jsonObject ==> jsString
138+ , "fromJSString" -: jsString ==> jsonObject
120139 ]
121140
122141
@@ -126,7 +145,7 @@ sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
126145 where fn = foldr1 (==>)
127146 ts = map VarT [1..n]
128147
129−signals =
148+signals = prefix "Signal"
130149 [ sig 1 "constant"
131150 , sig 2 "lift"
132151 , sig 3 "lift2"
@@ -135,7 +154,6 @@ signals =
135154 , "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
136155 , "foldp1" -:: (a ==> a ==> a) ==> signalOf a ==> signalOf a
137156 , "foldp'" -:: (a ==> b ==> b) ==> (a ==> b) ==> signalOf a ==> signalOf b
138− , "randomize" -:: int ==> int ==> signalOf a ==> signalOf int
139157 , "count" -:: signalOf a ==> signalOf int
140158 , "keepIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
141159 , "dropIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
@@ -145,7 +163,7 @@ signals =
145163 , "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
146164 ]
147165
148−http =
166+http = prefix "HTTP"
149167 [ "send" -:: signalOf (request a) ==> signalOf (response string)
150168 , "sendGet" -:: signalOf string ==> signalOf (response string)
151169 , "get" -: string ==> request string
@@ -158,24 +176,29 @@ http =
158176 response t = ADT "Response" [t]
159177
160178concreteSignals =
161− [ "keysDown" -: signalOf (listOf int)
162− , "charPressed" -: signalOf (maybeOf int)
163− , "inRange" -: int ==> int ==> signalOf int
164− , timeScheme "every" (\t -> t ==> signalOf t)
165− , timeScheme "before" (\t -> t ==> signalOf bool)
166− , timeScheme "after" (\t -> t ==> signalOf bool)
167− , "dimensions" -: signalOf point
168− , "position" -: signalOf point
169− , "x" -: signalOf int
170− , "y" -: signalOf int
171− , "isDown" -: signalOf bool
172− , "isClicked" -: signalOf bool
173− , "textField" -: string ==> tupleOf [element, signalOf string]
174− , "password" -: string ==> tupleOf [element, signalOf string]
175− , "textArea" -: int ==> int ==> tupleOf [element, signalOf string]
176− , "checkBox" -: bool ==> tupleOf [element, signalOf bool]
177− , "button" -: string ==> tupleOf [element, signalOf bool]
178− , "stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
179+ [ "Keyboard.Raw.keysDown" -: signalOf (listOf int)
180+ , "Keyboard.Raw.charPressed" -: signalOf (maybeOf int)
181+ , "Random.inRange" -: int ==> int ==> signalOf int
182+ , "Random.randomize" -:: int ==> int ==> signalOf a ==> signalOf int
183+ , timeScheme "Time.every" (\t -> t ==> signalOf t)
184+ , timeScheme "Time.before" (\t -> t ==> signalOf bool)
185+ , timeScheme "Time.after" (\t -> t ==> signalOf bool)
186+ , "Window.dimensions" -: signalOf point
187+ , "Window.width" -: signalOf int
188+ , "Window.height" -: signalOf int
189+ , "Mouse.position" -: signalOf point
190+ , "Mouse.x" -: signalOf int
191+ , "Mouse.y" -: signalOf int
192+ , "Mouse.isDown" -: signalOf bool
193+ , "Mouse.isClicked" -: signalOf bool
194+ , "Mouse.clicks" -: signalOf (tupleOf [])
195+ , "Input.textField" -: string ==> tupleOf [element, signalOf string]
196+ , "Input.password" -: string ==> tupleOf [element, signalOf string]
197+ , "Input.textArea" -: int ==> int ==> tupleOf [element, signalOf string]
198+ , "Input.checkBox" -: bool ==> tupleOf [element, signalOf bool]
199+ , "Input.button" -: string ==> tupleOf [element, signalOf bool]
200+ , "Input.stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
201+ , "Input.dropDown" -:: listOf (tupleOf [string,a]) ==> tupleOf [element, signalOf a]
179202 ]
180203
181204-------- Math and Binops --------
@@ -201,7 +224,10 @@ math =
201224 hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"] ++
202225 hasType float ["pi","e"] ++
203226 hasType (int ==> float) ["toFloat","castIntToFloat"] ++
204− hasType (float ==> int) ["round","floor","ceiling","truncate"]
227+ hasType (float ==> int) ["round","floor","ceiling","truncate"] ++
228+ [ "show" -:: a ==> string
229+ , "readInt" -: string ==> maybeOf int
230+ , "readFloat" -: string ==> maybeOf float ]
205231
206232bools =
207233 [ "not" -: bool ==> bool ] ++
@@ -211,7 +237,7 @@ bools =
211237 , Forall [0,1] [ Context "`compare'" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
212238 ]
213239
214−chars = classify ++ convert1 ++ convert2
240+chars = prefix "Char" (classify ++ convert1 ++ convert2)
215241 where classify = hasType (char ==> bool)
216242 ["isDigit","isOctDigit","isHexDigit","isUpper","isLower"]
217243 convert1 = hasType (char ==> char)
@@ -246,7 +272,7 @@ funcs =
246272tuple n = ("Tuple" ++ show n, Forall [1..n] [] $ foldr (==>) (tupleOf vs) vs)
247273 where vs = map VarT [1..n]
248274
249−lists =
275+lists = prefix "List"
250276 [ "and" -:: listOf bool ==> bool
251277 , "or" -:: listOf bool ==> bool
252278 , numScheme (\n -> listOf n ==> listOf n) "sort"
@@ -279,7 +305,7 @@ lists =
279305 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
280306 , "maximum", "minimum" ]
281307
282−maybeFuncs =
308+maybeFuncs = prefix "Maybe"
283309 [ "maybe" -:: b ==> (a ==> b) ==> maybeOf a ==> b
284310 , "isJust" -:: maybeOf a ==> bool
285311 , "isNothing" -:: maybeOf a ==> bool
@@ -289,11 +315,66 @@ maybeFuncs =
289315 , "catMaybes" -:: (a ==> maybeOf b) ==> listOf a ==> listOf b
290316 ]
291317
318+dictionary =
319+ let dict k v = ADT "Dict" [k,v] in
320+ prefix "Dict"
321+ [ "empty" -:: dict a b
322+ , "singleton" -:: a ==> b ==> dict a b
323+ , "insert" -:: a ==> b ==> dict a b ==> dict a b
324+ , "remove" -:: a ==> dict a b ==> dict a b
325+ , "member" -:: a ==> dict a b ==> bool
326+ , "lookup" -:: a ==> dict a b ==> maybeOf b
327+ , "findWithDefault" -:: b ==> a ==> dict a b ==> b
328+ , "intersect" -:: dict a b ==> dict a c ==> dict a b
329+ , "union" -:: dict a b ==> dict a b ==> dict a b
330+ , "diff" -:: dict a b ==> dict a c ==> dict a b
331+ , "map" -:: (b ==> c) ==> dict a b ==> dict a c
332+ , "foldl" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
333+ , "foldr" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
334+ , "keys" -:: dict a b ==> listOf a
335+ , "values" -:: dict a b ==> listOf b
336+ , "toList" -:: dict a b ==> listOf (tupleOf [a,b])
337+ , "fromList" -:: listOf (tupleOf [a,b]) ==> dict a b
338+ ]
339+
340+sets =
341+ let set v = ADT "Set" [v] in
342+ prefix "Set"
343+ [ "empty" -:: set a
344+ , "singleton" -:: a ==> set a
345+ , "insert" -:: a ==> set a ==> set a
346+ , "remove" -:: a ==> set a ==> set a
347+ , "member" -:: a ==> set a ==> bool
348+ , "intersect" -:: set a ==> set a ==> set a
349+ , "union" -:: set a ==> set a ==> set a
350+ , "diff" -:: set a ==> set a ==> set a
351+ , "map" -:: (a ==> b) ==> set a ==> set b
352+ , "foldl" -:: (a ==> b ==> b) ==> b ==> set a ==> b
353+ , "foldr" -:: (a ==> b ==> b) ==> b ==> set a ==> b
354+ , "toList" -:: set a ==> listOf a
355+ , "fromList" -:: listOf a ==> set a
356+ ]
357+
358+automaton =
359+ let auto a b = ADT "Automaton" [a,b] in
360+ prefix "Automaton"
361+ [ "pure" -:: (a ==> b) ==> auto a b
362+ , "init" -:: b ==> (a ==> b ==> b) ==> auto a b
363+ , "init'" -:: c ==> (a ==> c ==> tupleOf [b,c]) ==> auto a b
364+ , ">>>" -:: auto a b ==> auto b c ==> auto a c
365+ , "<<<" -:: auto b c ==> auto a b ==> auto a c
366+ , "combine" -:: listOf (auto a b) ==> auto a (listOf b)
367+ , "run" -:: auto a b ==> signalOf a ==> signalOf b
368+ , "step" -:: auto a b ==> a ==> tupleOf [b,auto a b]
369+ , "count" -:: auto a int
370+ , "draggable" -:: form ==> auto (tupleOf [bool,point]) form
371+ ]
372+
292373-------- Everything --------
293374
294375hints = mapM (\(n,s) -> (,) n `liftM` rescheme s) hs
295− where hs = concat [ funcs, lists, signals, math, bools, str2elem, textAttrs
296− , elements, directions, colors, lineTypes, shapes
297− , concreteSignals, casts, polyCasts, json, maybeFuncs
298− , positions, collages, http
299− ]
376+ where hs = concat [ funcs, lists, signals, math, bools, textAttrs
377+ , graphicsElement, graphicsColor
378+ , concreteSignals, javascript, json, maybeFuncs
379+ , http, dictionary, sets, automaton
380+ ]
elm/src/Types/Unify.hs+6−3
@@ -17,9 +17,12 @@ import Control.DeepSeq (deepseq)
1717prints xs v = v --} unsafePerformIO (putStrLn "----------" >> mapM print xs) `seq` v
1818
1919unify hints modul = run $ do
20− (escapees, cs) <- constrain hints modul
21− subs <- solver cs Map.empty
22− prints cs $ return ((,) escapees `liftM` subs)
20+ constraints <- constrain hints modul
21+ case constraints of
22+ Left msg -> return (Left msg)
23+ Right (escapees, cs) ->
24+ do subs <- solver cs Map.empty
25+ return ((,) escapees `liftM` subs)
2326
2427eq ctx t1 t2 = Context ctx (t1 :=: t2)
2528