git.iko.soy/elk
on master help sign in
Load json representation of types with Template Haskell, so library files are the base truth of type information.
7dbb052evancz
Elm.cabal+10−2
compare with master
unifiedsplit
@@ -42,6 +42,8 @@ Library
42 GenerateHtml,
42 GenerateHtml,
43 Guid,
43 Guid,
44 LetBoundVars,
44 LetBoundVars,
45+ Libraries,
46+ LoadLibraries,
45 Optimize,
47 Optimize,
46 Initialize,
48 Initialize,
47 Rename,
49 Rename,
@@ -77,7 +79,9 @@ Library
77 bytestring,
79 bytestring,
78 hjsmin,
80 hjsmin,
79 indents,
81 indents,
80− filepath
82+ filepath,
83+ template-haskell,
84+ json
81
85
82Executable elm
86Executable elm
83 Main-is: Compiler.hs
87 Main-is: Compiler.hs
@@ -91,6 +95,8 @@ Executable elm
91 GenerateHtml,
95 GenerateHtml,
92 Guid,
96 Guid,
93 LetBoundVars,
97 LetBoundVars,
98+ Libraries,
99+ LoadLibraries,
94 Optimize,
100 Optimize,
95 Initialize,
101 Initialize,
96 Rename,
102 Rename,
@@ -124,7 +130,9 @@ Executable elm
124 bytestring,
130 bytestring,
125 hjsmin,
131 hjsmin,
126 indents,
132 indents,
127− filepath
133+ filepath,
134+ template-haskell,
135+ json
128
136
129Executable elm-doc
137Executable elm-doc
130 Main-is: Docs.hs
138 Main-is: Docs.hs
compiler/Docs.hs+3−2
@@ -3,13 +3,13 @@ module Main where
3
3
4import Ast
4import Ast
5import Control.Applicative ((<$>), (<*>))
5import Control.Applicative ((<$>), (<*>))
6−import Data.List as List
6+import Data.List (intercalate)
7import Parse.Library
7import Parse.Library
8import Parse.Modules (moduleDef)
8import Parse.Modules (moduleDef)
9import Parse.Types (typeAnnotation)
9import Parse.Types (typeAnnotation)
10+import Text.Parsec hiding (newline,spaces)
10import System.Environment
11import System.Environment
11import System.Exit
12import System.Exit
12−import Text.Parsec hiding (newline,spaces)
13import Types.Types
13import Types.Types
14
14
15
15
@@ -29,6 +29,7 @@ toModule (name, values) =
29toValue (name, tipe) =
29toValue (name, tipe) =
30 "{ \"name\" : " ++ show name ++ ",\n \"type\" : \"" ++ show tipe ++ "\"\n }"
30 "{ \"name\" : " ++ show name ++ ",\n \"type\" : \"" ++ show tipe ++ "\"\n }"
31
31
32+
32docParse :: String -> Either String (String, [(String, Type)])
33docParse :: String -> Either String (String, [(String, Type)])
33docParse = setupParser $ do
34docParse = setupParser $ do
34 optional freshLine
35 optional freshLine
compiler/Initialize.hs+3−3
@@ -27,9 +27,9 @@ checkTypes (Module name ex im stmts) =
27 let stmts' = dealias stmts
27 let stmts' = dealias stmts
28 modul = Module name ex im stmts'
28 modul = Module name ex im stmts'
29 in do subs <- unify hints modul
29 in do subs <- unify hints modul
30− let im' | any ((=="Prelude") . fst) im = im
30+ let --im' | any ((=="Prelude") . fst) im = im
31− | otherwise = ("Prelude", Importing []) : im
31+ -- | otherwise = ("Prelude", Importing []) : im
32− modul' = optimize . renameModule $ Module name ex im' stmts'
32+ modul' = optimize . renameModule $ Module name ex im stmts'
33 subs `seq` return modul'
33 subs `seq` return modul'
34
34
35check :: Module -> Either String Module
35check :: Module -> Either String Module
compiler/Language/Elm.hs+1−2
@@ -32,8 +32,7 @@ import qualified Data.Text.Lazy as TL
32
32
33-- |The absolute path to Elm's runtime system.
33-- |The absolute path to Elm's runtime system.
34runtimeLocation :: IO FilePath
34runtimeLocation :: IO FilePath
35−runtimeLocation =
36− getDataFileName ("elm-runtime-" ++ showVersion version ++ ".js")
35+runtimeLocation = getDataFileName "elm-runtime.js"
37
36
38class ElmSource a where
37class ElmSource a where
39 -- |This function compiles Elm code to three separate parts: HTML, CSS,
38 -- |This function compiles Elm code to three separate parts: HTML, CSS,
compiler/Model/Libraries.hsnew file+37
@@ -0,0 +1,37 @@
1+{-# LANGUAGE TemplateHaskell #-}
2+
3+module Libraries (libraries) where
4+
5+import qualified Data.Map as Map
6+import Text.JSON
7+import LoadLibraries
8+
9+libraries :: Map.Map String (Map.Map String String)
10+libraries = case getLibs of
11+ Ok libs -> libs
12+ Error err -> error err
13+
14+getLibs :: Result (Map.Map String (Map.Map String String))
15+getLibs = do
16+ obj <- decodeStrict $(docs) :: Result (JSObject JSValue)
17+ modules <- valFromObj "modules" obj :: Result [JSObject JSValue]
18+ Map.fromList `fmap` mapM getValues modules
19+
20+
21+getName :: JSObject JSValue -> Result String
22+getName obj = valFromObj "name" obj
23+
24+getType :: JSObject JSValue -> Result String
25+getType obj = valFromObj "type" obj
26+
27+getValue :: JSObject JSValue -> Result (String,String)
28+getValue obj = do n <- getName obj
29+ t <- getType obj
30+ return (n,t)
31+
32+getValues :: JSObject JSValue -> Result (String, Map.Map String String)
33+getValues obj = do
34+ name <- getName obj
35+ vs <- valFromObj "values" obj
36+ vals <- mapM getValue vs
37+ return (name, Map.fromList vals)
compiler/Model/LoadLibraries.hsnew file+13
@@ -0,0 +1,13 @@
1+
2+module LoadLibraries where
3+
4+import Language.Haskell.TH.Syntax
5+import Paths_Elm
6+
7+docs :: Q Exp
8+docs = liftString =<< qRunIO (do
9+ s <- readFile =<< getDataFileName "docs.json"
10+ putStrLn s
11+ return s
12+ )
13+
compiler/Types/Hints.hs+16−441
@@ -1,446 +1,21 @@
1module Types.Hints (hints) where
1module Types.Hints (hints) where
2
2
3−import Context
4import Control.Arrow (first)
3import Control.Arrow (first)
5−import Control.Monad (liftM,mapM)
4+import qualified Data.Map as Map
5+import Guid
6+import Libraries
7+import Parse.Library (iParse)
8+import Parse.Types
9+import Types.Substitutions
6import Types.Types
10import Types.Types
7−import Types.Substitutions (rescheme)
8
11
9−ctx str = C (Just str) NoSpan
12+hints :: GuidCounter [(String, Scheme)]
10−prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
13+hints = mapM toScheme values
11−hasType t = map (-: t)
14+ where
12−
15+ addPrefixes = concatMap (\(m,vs) -> map (first (\n -> m ++ "." ++ n)) vs)
13−
16+ values = addPrefixes (Map.toList (Map.map Map.toList libraries))
14−-------- Text and Elements --------
17+ toScheme (name, tipeString) =
15−
18+ case iParse (fmap toType typeExpr) "libraries" tipeString of
16−textToText = [ "header", "italic", "bold", "underline"
19+ Left err -> error (show err)
17− , "overline", "strikeThrough", "monospace" ]
20+ Right tipe -> do scheme <- generalize [] (Forall [] [] tipe)
18−
21+ return (name, scheme)
19−textAttrs = [ "toText" -: string ==> text
20− , "Text.typeface" -: string ==> text ==> text
21− , "Text.link" -:: string ==> text ==> text
22− , numScheme (\t -> t ==> text ==> text) "Text.height"
23− ] ++ prefix "Text" (hasType (text ==> text) textToText)
24−
25−elements =
26− let iee = int ==> element ==> element in
27− [ "plainText" -: string ==> element
28− , "link" -:: string ==> element ==> element
29− , "flow" -: direction ==> listOf element ==> element
30− , "layers" -: listOf element ==> element
31− , "text" -: text ==> element
32− , "image" -: int ==> int ==> string ==> element
33− , "video" -: int ==> int ==> string ==> element
34− , "opacity" -: float ==> element ==> element
35− , "width" -: iee
36− , "height" -: iee
37− , "size" -: int ==> iee
38− , "widthOf" -: element ==> int
39− , "heightOf"-: element ==> int
40− , "sizeOf" -: element ==> pairOf int
41− , "color" -: color ==> element ==> element
42− , "container" -: int ==> int ==> position ==> element ==> element
43− , "spacer" -: int ==> int ==> element
44− , "rightedText" -: text ==> element
45− , "centeredText" -: text ==> element
46− , "justifiedText" -: text ==> element
47− , "asText" -:: a ==> element
48− , "collage" -: int ==> int ==> listOf form ==> element
49− , "fittedImage" -: int ==> int ==> string ==> element
50− ]
51−
52−directions = hasType direction ["up","down","left","right","inward","outward"]
53−positions =
54− hasType position ["topLeft","midLeft","bottomLeft","midTop","middle"
55− ,"midBottom","topRight","midRight","bottomRight"] ++
56− hasType (location ==> location ==> position)
57− ["topLeftAt","bottomLeftAt","middleAt","topRightAt","bottomRightAt"] ++
58− [ "absolute" -: int ==> location, "relative" -: float ==> location ]
59−
60−lineTypes = [ numScheme (\n -> listOf (pairOf n) ==> line) "line"
61− , numScheme (\n -> pairOf n ==> pairOf n ==> line) "segment"
62− , "customLine" -: listOf int ==> color ==> line ==> form
63− ] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"]
64−
65−shapes = [ twoNums (\n m -> listOf (pairOf n) ==> pairOf m ==> shape) "polygon"
66− , "filled" -: color ==> shape ==> form
67− , "outlined" -: color ==> shape ==> form
68− , "textured" -: string ==> shape ==> form
69− , "customOutline" -: listOf int ==> color ==> shape ==> form
70− ] ++ map (twoNums (\n m -> n ==> n ==> pairOf m ==> shape)) [ "ngon"
71− , "rect"
72− , "oval" ]
73−
74−collages = [ numScheme (\n -> pairOf n ==> element ==> form) "toForm"
75− , numScheme (\n -> string ==> n ==> n ==> pairOf n ==> form) "sprite"
76− , numScheme (\n -> n ==> n ==> form ==> form) "move"
77− , numScheme (\n -> n ==> form ==> form) "rotate"
78− , numScheme (\n -> n ==> form ==> form) "scale"
79− , numScheme (\n -> pairOf n ==> form ==> bool) "isWithin"
80− ]
81−
82−graphicsElement = prefix "Graphics"
83− (concat [elements,directions,positions,lineTypes,shapes,collages])
84−graphicsColor = prefix "Color" clrs
85− where clrs = [ numScheme (\n -> n ==> n ==> n ==> color) "rgb"
86− , numScheme (\n -> n ==> n ==> n ==> n ==> color) "rgba"
87− , "complement" -: color ==> color
88− ] ++ hasType color ["red","green","blue","black","white"
89− ,"yellow","cyan","magenta","grey","gray"]
90−
91−
92−-------- Foreign --------
93−
94−casts =
95− [ "castJSBoolToBool" -: jsBool ==> bool
96− , "castBoolToJSBool" -: bool ==> jsBool
97− , "castJSNumberToInt" -: jsNumber ==> int
98− , "castIntToJSNumber" -: int ==> jsNumber
99− , "castJSElementToElement" -: int ==> int ==> jsElement ==> element
100− , "castElementToJSElement" -: element ==> jsElement
101− , "castJSStringToString" -: jsString ==> string
102− , "castStringToJSString" -: string ==> jsString
103− , "castJSNumberToFloat" -: jsNumber ==> float
104− , "castFloatToJSNumber" -: float ==> jsNumber
105− ]
106−
107−castToTuple n = (,) name $ Forall [1..n] [] (jsTuple vs ==> tupleOf vs)
108− where vs = map VarT [1..n]
109− name = "castJSTupleToTuple" ++ show n
110−castToJSTuple n = (,) name $ Forall [1..n] [] (tupleOf vs ==> jsTuple vs)
111− where vs = map VarT [1..n]
112− name = "castTupleToJSTuple" ++ show n
113−
114−polyCasts =
115− map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
116− [ "castJSArrayToList" -:: jsArray a ==> listOf a
117− , "castListToJSArray" -:: listOf a ==> jsArray a
118− ]
119−
120−javascript = prefix "JavaScript" (concat [casts,polyCasts])
121−
122−json = prefix "JSON"
123− [ "JsonString" -: string ==> jsonValue
124− , "JsonBool" -: bool ==> jsonValue
125− , "JsonNull" -: jsonValue
126− , "JsonArray" -: listOf jsonValue ==> jsonValue
127− , "JsonObject" -: jsonObject ==> jsonValue
128− , numScheme (\n -> n ==> jsonValue) "JsonNumber"
129− , "toString" -: jsonObject ==> string
130− , "fromString" -: string ==> maybeOf jsonObject
131− , "lookup" -: string ==> jsonObject ==> maybeOf jsonValue
132− , "findObject" -: string ==> jsonObject ==> jsonObject
133− , "findArray" -: string ==> jsonObject ==> listOf jsonValue
134− , "findString" -: string ==> jsonObject ==> string
135− , "findNumber" -: float ==> jsonObject ==> float
136− , "findWithDefault" -:: jsonValue ==> string ==> jsonObject ==> jsonValue
137− , "toPrettyString" -: string ==> jsonObject ==> string
138− , "toPrettyJSString" -: string ==> jsonObject ==> jsString
139− , "toList" -: jsonObject ==> listOf (tupleOf [string,jsonValue])
140− , "fromList" -: listOf (tupleOf [string,jsonValue]) ==> jsonObject
141− , "toJSString" -: jsonObject ==> jsString
142− , "fromJSString" -: jsString ==> jsonObject
143− ]
144−
145−
146−-------- Signals --------
147−
148−lyft n = sig (n+1) ("lift" ++ show n)
149−sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
150− where fn = foldr1 (==>)
151− ts = map VarT [1..n]
152−
153−signals = prefix "Signal"
154− [ sig 1 "constant"
155− , sig 2 "lift"
156− ] ++ map lyft [2..8] ++ [
157− "<~" -:: (a ==> b) ==> signalOf a ==> signalOf b
158− , "~" -:: signalOf (a ==> b) ==> signalOf a ==> signalOf b
159− , "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
160− , "foldp1" -:: (a ==> a ==> a) ==> signalOf a ==> signalOf a
161− , "foldp'" -:: (a ==> b ==> b) ==> (a ==> b) ==> signalOf a ==> signalOf b
162− , "count" -:: signalOf a ==> signalOf int
163− , "countIf" -:: (a ==> bool) ==> signalOf a ==> signalOf int
164− , "keepIf" -:: (a ==> bool) ==> a ==> signalOf a ==> signalOf a
165− , "dropIf" -:: (a ==> bool) ==> a ==> signalOf a ==> signalOf a
166− , "keepWhen" -:: signalOf bool ==> a ==> signalOf a ==> signalOf a
167− , "dropWhen" -:: signalOf bool ==> a ==> signalOf a ==> signalOf a
168− , "dropRepeats" -:: signalOf a ==> signalOf a
169− , "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
170− , "timestamp" -:: signalOf a ==> signalOf (tupleOf [time,a])
171− , "timeOf" -:: signalOf a ==> signalOf time
172− , "merge" -:: signalOf a ==> signalOf a ==> signalOf a
173− , "merges" -:: listOf (signalOf a) ==> signalOf a
174− , "mergeEither" -:: signalOf a ==> signalOf b ==> signalOf (eitherOf a b)
175− , numScheme (\n -> int ==> signalOf n ==> signalOf float) "average"
176− ]
177−
178−http = prefix "HTTP"
179− [ "send" -:: signalOf (request a) ==> signalOf (response string)
180− , "sendGet" -:: signalOf string ==> signalOf (response string)
181− , "get" -: string ==> request string
182− , "post" -: string ==> string ==> request string
183− , "request" -: string ==> string ==> string ==> listOf (pairOf string) ==> request string
184− , "Waiting" -:: response a
185− , "Failure" -:: int ==> string ==> response a
186− , "Success" -:: a ==> response a ]
187− where request t = ADT "Request" [t]
188− response t = ADT "Response" [t]
189−
190−concreteSignals =
191− [ "Random.inRange" -: int ==> int ==> signalOf int
192− , "Random.randomize" -:: int ==> int ==> signalOf a ==> signalOf int
193− , "Window.dimensions" -: signalOf point
194− , "Window.width" -: signalOf int
195− , "Window.height" -: signalOf int
196− , "Mouse.position" -: signalOf point
197− , "Mouse.x" -: signalOf int
198− , "Mouse.y" -: signalOf int
199− , "Mouse.isDown" -: signalOf bool
200− , "Mouse.isClicked" -: signalOf bool
201− , "Mouse.clicks" -: signalOf (tupleOf [])
202− , "Input.textField" -: string ==> tupleOf [element, signalOf string]
203− , "Input.password" -: string ==> tupleOf [element, signalOf string]
204− , "Input.textArea" -: int ==> int ==> tupleOf [element, signalOf string]
205− , "Input.checkBox" -: bool ==> tupleOf [element, signalOf bool]
206− , "Input.button" -: string ==> tupleOf [element, signalOf bool]
207− , "Input.stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
208− , "Input.dropDown" -:: listOf (tupleOf [string,a]) ==> tupleOf [element, signalOf a]
209− ]
210−
211−keyboards = prefix "Keyboard"
212− [ "Raw.keysDown" -: signalOf (listOf int)
213− , "Raw.charPressed" -: signalOf (maybeOf int)
214− , "arrows" -: signalOf (recordOf [("x",int),("y",int)])
215− , "wasd" -: signalOf (recordOf [("x",int),("y",int)])
216− , "ctrl" -: signalOf bool
217− , "space" -: signalOf bool
218− , "shift" -: signalOf bool
219− ]
220−
221−touches = prefix "Touch"
222− [ "touches" -: signalOf (listOf (recordOf [("x" ,int) ,("y" ,int)
223− ,("x0",int) ,("y0",int)
224− ,("t0",time),("id",int)]))
225− , "taps" -: signalOf (recordOf [("x",int),("y",int)])
226− ]
227−
228−times = prefix "Time"
229− [ numScheme (\n -> n ==> signalOf time) "fps"
230− , numScheme (\n -> n ==> signalOf bool ==> signalOf time) "fpsWhen"
231− , "every" -: time ==> signalOf time
232− , "delay" -:: time ==> signalOf a ==> signalOf a
233− , "since" -:: time ==> signalOf a ==> signalOf bool
234− , "hour" -: time
235− , "minute" -: time
236− , "second" -: time
237− , "ms" -: time
238− , "inHours" -: time ==> float
239− , "inMinutes" -: time ==> float
240− , "inSeconds" -: time ==> float
241− , "inMss" -: time ==> float
242− , "toDate" -: time ==> date
243− , "read" -: string ==> maybeOf time
244− ]
245−
246−dates =
247− let days = map (-: day) ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
248− months = map (-: month) [ "Jan", "Feb", "Mar", "Apr", "May", "Jun"
249− , "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ]
250− in prefix "Date"
251− ([ "read" -: string ==> maybeOf date
252− , "year" -: date ==> int
253− , "month" -: date ==> month
254− , "day" -: date ==> int
255− , "hour" -: date ==> int
256− , "minute" -: date ==> int
257− , "second" -: date ==> int
258− , "dayOfWeek" -: date ==> day
259− , "toTime" -: date ==> time
260− ] ++ days ++ months)
261−
262−-------- Math and Binops --------
263−
264−binop t = t ==> t ==> t
265−scheme1 super t name =
266− (name, Forall [0] [ ctx name $ VarT 0 :<: super
267− ] (t (VarT 0)))
268−scheme2 s1 s2 t name =
269− (name, Forall [0,1] [ ctx name $ VarT 0 :<: s1
270− , ctx name $ VarT 1 :<: s2
271− ] (t (VarT 0) (VarT 1)))
272−numScheme t name = scheme1 number t name
273−twoNums f name = scheme2 number number f name
274−
275−math =
276− map (numScheme (\t -> t ==> binop t)) ["clamp"] ++
277− map (numScheme (\t -> binop t)) ["+","-","*","max","min"] ++
278− [ numScheme (\t -> t ==> t) "abs" ] ++
279− hasType (binop float) [ "/", "logBase" ] ++
280− hasType (binop int) ["rem","div","mod"] ++
281− hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"] ++
282− hasType float ["pi","e"] ++
283− hasType (int ==> float) ["toFloat","castIntToFloat"] ++
284− hasType (float ==> int) ["round","floor","ceiling","truncate"] ++
285− [ "show" -:: a ==> string
286− , "readInt" -: string ==> maybeOf int
287− , "readFloat" -: string ==> maybeOf float ]
288−
289−bools =
290− [ "not" -: bool ==> bool ] ++
291− hasType (binop bool) ["&&","||","xor"] ++
292− map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++
293− [ ( "compare"
294− , Forall [0,1] [ ctx "compare" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
295− ]
296−
297−chars = prefix "Char" (classify ++ convert1 ++ convert2)
298− where classify = hasType (char ==> bool)
299− ["isDigit","isOctDigit","isHexDigit","isUpper","isLower"]
300− convert1 = hasType (char ==> char)
301− ["toUpper","toLower","toLocaleUpper","toLocaleLower"]
302− convert2 = [ "toCode" -: char ==> int, "fromCode" -: int ==> char ]
303−
304−
305−-------- Polymorphic Functions --------
306−
307−[a,b,c] = map VarT [1,2,3]
308−
309−infix 8 -::
310−name -:: tipe = (name, Forall [1,2,3] [] tipe)
311−
312−funcs =
313− [ "id" -:: a ==> a
314− , "==" -:: a ==> a ==> bool
315− , "/=" -:: a ==> a ==> bool
316− , "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
317− , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
318− , "$" -:: (a ==> b) ==> a ==> b
319− , ":" -:: a ==> listOf a ==> listOf a
320− , (,) "++" . Forall [0,1] [ ctx "++" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0
321− , "Cons" -:: a ==> listOf a ==> listOf a
322− , "Nil" -:: listOf a
323− , "Just" -:: a ==> maybeOf a
324− , "Nothing" -:: maybeOf a
325− , "Left" -:: a ==> eitherOf a b
326− , "Right" -:: b ==> eitherOf a b
327− , "curry" -:: (tupleOf [a,b] ==> c) ==> a ==> b ==> c
328− , "uncurry" -:: (a ==> b ==> c) ==> tupleOf [a,b] ==> c
329− ] ++ map tuple [0..8]
330−
331−tuple n = ("Tuple" ++ show n, Forall [1..n] [] $ foldr (==>) (tupleOf vs) vs)
332− where vs = map VarT [1..n]
333−
334−lists = prefix "List"
335− [ "and" -:: listOf bool ==> bool
336− , "or" -:: listOf bool ==> bool
337− , numScheme (\n -> listOf n ==> listOf n) "sort"
338− , "head" -:: listOf a ==> a
339− , "tail" -:: listOf a ==> listOf a
340− , "length" -:: listOf a ==> int
341− , "filter" -:: (a ==> bool) ==> listOf a ==> listOf a
342− , "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
343− , "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
344− , "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
345− , "all" -:: (a ==> bool) ==> listOf a ==> bool
346− , "any" -:: (a ==> bool) ==> listOf a ==> bool
347− , "reverse" -:: listOf a ==> listOf a
348− , "take" -:: int ==> listOf a ==> listOf a
349− , "drop" -:: int ==> listOf a ==> listOf a
350− , "partition" -:: (a ==> bool) ==> listOf a ==> tupleOf [listOf a,listOf a]
351− , "intersperse" -:: a ==> listOf a ==> listOf a
352− , "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
353− , "map" -:: (a ==> b) ==> listOf a ==> listOf b
354− , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
355− , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
356− , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
357− , (,) "concat" . Forall [0,1] [ ctx "concat" $ VarT 0 :<: appendable (VarT 1) ] $
358− listOf (VarT 0) ==> VarT 0
359− , (,) "concatMap" . Forall [0,1,2] [ ctx "concatMap" $ VarT 0 :<: appendable (VarT 1) ] $
360− (VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0
361− , (,) "intercalate" . Forall [0,1] [ ctx "intercalate" $ VarT 0 :<: appendable (VarT 1) ] $
362− VarT 0 ==> listOf (VarT 0) ==> VarT 0
363− , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
364− ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
365− , "maximum", "minimum" ]
366−
367−maybeFuncs = prefix "Maybe"
368− [ "maybe" -:: b ==> (a ==> b) ==> maybeOf a ==> b
369− , "isJust" -:: maybeOf a ==> bool
370− , "isNothing" -:: maybeOf a ==> bool
371− , "cons" -:: maybeOf a ==> listOf a ==> listOf a
372− , "justs" -:: listOf (maybeOf a) ==> listOf a
373− ]
374−
375−eithers = prefix "Either"
376− [ "isLeft" -:: eitherOf a b ==> bool
377− , "isRight" -:: eitherOf a b ==> bool
378− , "either" -:: (a ==> c) ==> (b ==> c) ==> eitherOf a b ==> c
379− , "lefts" -:: listOf (eitherOf a b) ==> listOf a
380− , "rights" -:: listOf (eitherOf a b) ==> listOf b
381− , "partition" -:: listOf (eitherOf a b) ==> tupleOf [listOf a,listOf b]
382− ]
383−
384−dictionary =
385− let dict k v = ADT "Dict" [k,v] in
386− prefix "Dict"
387− [ "empty" -:: dict a b
388− , "singleton" -:: a ==> b ==> dict a b
389− , "insert" -:: a ==> b ==> dict a b ==> dict a b
390− , "remove" -:: a ==> dict a b ==> dict a b
391− , "member" -:: a ==> dict a b ==> bool
392− , "lookup" -:: a ==> dict a b ==> maybeOf b
393− , "findWithDefault" -:: b ==> a ==> dict a b ==> b
394− , "intersect" -:: dict a b ==> dict a c ==> dict a b
395− , "union" -:: dict a b ==> dict a b ==> dict a b
396− , "diff" -:: dict a b ==> dict a c ==> dict a b
397− , "map" -:: (b ==> c) ==> dict a b ==> dict a c
398− , "foldl" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
399− , "foldr" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
400− , "keys" -:: dict a b ==> listOf a
401− , "values" -:: dict a b ==> listOf b
402− , "toList" -:: dict a b ==> listOf (tupleOf [a,b])
403− , "fromList" -:: listOf (tupleOf [a,b]) ==> dict a b
404− ]
405−
406−sets =
407− let set v = ADT "Set" [v] in
408− prefix "Set"
409− [ "empty" -:: set a
410− , "singleton" -:: a ==> set a
411− , "insert" -:: a ==> set a ==> set a
412− , "remove" -:: a ==> set a ==> set a
413− , "member" -:: a ==> set a ==> bool
414− , "intersect" -:: set a ==> set a ==> set a
415− , "union" -:: set a ==> set a ==> set a
416− , "diff" -:: set a ==> set a ==> set a
417− , "map" -:: (a ==> b) ==> set a ==> set b
418− , "foldl" -:: (a ==> b ==> b) ==> b ==> set a ==> b
419− , "foldr" -:: (a ==> b ==> b) ==> b ==> set a ==> b
420− , "toList" -:: set a ==> listOf a
421− , "fromList" -:: listOf a ==> set a
422− ]
423−
424−automaton =
425− let auto a b = ADT "Automaton" [a,b] in
426− prefix "Automaton"
427− [ "pure" -:: (a ==> b) ==> auto a b
428− , "init" -:: b ==> (a ==> b ==> b) ==> auto a b
429− , "init'" -:: c ==> (a ==> c ==> tupleOf [b,c]) ==> auto a b
430− , ">>>" -:: auto a b ==> auto b c ==> auto a c
431− , "<<<" -:: auto b c ==> auto a b ==> auto a c
432− , "combine" -:: listOf (auto a b) ==> auto a (listOf b)
433− , "run" -:: auto a b ==> signalOf a ==> signalOf b
434− , "step" -:: auto a b ==> a ==> tupleOf [b,auto a b]
435− , "count" -:: auto a int
436− , "draggable" -:: form ==> auto (tupleOf [bool,point]) form
437− ]
438−
439−-------- Everything --------
440−
441−hints = mapM (\(n,s) -> (,) n `liftM` rescheme s) (concat hs)
442− where hs = [ funcs, lists, signals, math, bools, textAttrs
443− , graphicsElement, graphicsColor, eithers, keyboards, touches
444− , concreteSignals, javascript, json, maybeFuncs
445− , http, dictionary, sets, automaton, times, dates
446− ]
libraries/Char.elmnew file+38
@@ -0,0 +1,38 @@
1+
2+module Char where
3+
4+import Native.Char as N
5+
6+-- Selects upper case letters.
7+isUpper : Char -> Bool
8+
9+-- Selects lower case letters.
10+isLower : Char -> Bool
11+
12+-- Selects ASCII digits (0..9).
13+isDigit : Char -> Bool
14+
15+-- Selects ASCII octal digits (0..7).
16+isOctDigit : Char -> Bool
17+
18+-- Selects ASCII hexadecimal digits (0..9a..fA..F).
19+isHexDigit : Char -> Bool
20+
21+-- Convert to upper case.
22+toUpper : Char -> Char
23+
24+-- Convert to lower case.
25+toLower : Char -> Char
26+
27+-- Convert to upper case, according to any locale-specific case mappings.
28+toLocaleUpper : Char -> Char
29+
30+-- Convert to lower case, according to any locale-specific case mappings.
31+toLocaleLower : Char -> Char
32+
33+-- Convert to unicode.
34+toCode : Char -> Int
35+
36+-- Convert from unicode.
37+fromCode : Int -> Char
38+
libraries/Dict.elm+119−116
@@ -10,13 +10,14 @@ module Dict (empty,singleton,insert
10
10
11import Maybe as Maybe
11import Maybe as Maybe
12import Native.Error as Error
12import Native.Error as Error
13+import List as List
13
14
14data NColor = Red | Black
15data NColor = Red | Black
15
16
16−data RBTree k v = RBNode NColor k v (RBTree k v) (RBTree k v) | RBEmpty
17+data Dict k v = Node NColor k v (Dict k v) (Dict k v) | Empty
17
18
18−empty : RBTree k v
19+empty : Dict k v
19−empty = RBEmpty
20+empty = Empty
20
21
21{-- Helpers for checking invariants
22{-- Helpers for checking invariants
22
23
@@ -24,8 +25,8 @@ empty = RBEmpty
24equal_pathLen t =
25equal_pathLen t =
25 let path_numBlacks t =
26 let path_numBlacks t =
26 case t of
27 case t of
27− { RBEmpty -> 1
28+ { Empty -> 1
28− ; RBNode col _ _ l r ->
29+ ; Node col _ _ l r ->
29 let { bl = path_numBlacks l ; br = path_numBlacks r } in
30 let { bl = path_numBlacks l ; br = path_numBlacks r } in
30 if bl /= br || bl == 0-1 || br == 0-1
31 if bl /= br || bl == 0-1 || br == 0-1
31 then 0-1
32 then 0-1
@@ -35,22 +36,22 @@ equal_pathLen t =
35
36
36rootBlack t =
37rootBlack t =
37 case t of
38 case t of
38− { RBEmpty -> True
39+ { Empty -> True
39− ; RBNode Black _ _ _ _ -> True
40+ ; Node Black _ _ _ _ -> True
40 ; _ -> False }
41 ; _ -> False }
41
42
42redBlack_children t =
43redBlack_children t =
43 case t of
44 case t of
44− { RBNode Red _ _ (RBNode Red _ _ _ _) _ -> False
45+ { Node Red _ _ (Node Red _ _ _ _) _ -> False
45− ; RBNode Red _ _ _ (RBNode Red _ _ _ _) -> False
46+ ; Node Red _ _ _ (Node Red _ _ _ _) -> False
46− ; RBEmpty -> True
47+ ; Empty -> True
47− ; RBNode _ _ _ l r -> redBlack_children l && redBlack_children r
48+ ; Node _ _ _ l r -> redBlack_children l && redBlack_children r
48 }
49 }
49
50
50findExtreme f t =
51findExtreme f t =
51 case t of
52 case t of
52− { RBEmpty -> Nothing
53+ { Empty -> Nothing
53− ; RBNode c k _ l r ->
54+ ; Node c k _ l r ->
54 case findExtreme f (f (l,r)) of
55 case findExtreme f (f (l,r)) of
55 { Nothing -> Just k
56 { Nothing -> Just k
56 ; Just k' -> Just k' }
57 ; Just k' -> Just k' }
@@ -74,8 +75,8 @@ olte xo yo = optionRelation (<=) True xo yo
74
75
75ordered t =
76ordered t =
76 case t of
77 case t of
77− { RBEmpty -> True
78+ { Empty -> True
78− ; RBNode c k v l r ->
79+ ; Node c k v l r ->
79 let (lmax,rmin) = (findmaxRbt l, findminRbt r) in
80 let (lmax,rmin) = (findmaxRbt l, findminRbt r) in
80 olte lmax (Just k) && olte (Just k) rmin && ordered l && ordered r
81 olte lmax (Just k) && olte (Just k) rmin && ordered l && ordered r
81 }
82 }
@@ -83,10 +84,10 @@ ordered t =
83-- Check that there aren't any right red nodes in the tree *)
84-- Check that there aren't any right red nodes in the tree *)
84leftLeaning t =
85leftLeaning t =
85 case t of
86 case t of
86− { RBEmpty -> True
87+ { Empty -> True
87− ; RBNode _ _ _ (RBNode Black _ _ _ _) (RBNode Red _ _ _ _) -> False
88+ ; Node _ _ _ (Node Black _ _ _ _) (Node Red _ _ _ _) -> False
88− ; RBNode _ _ _ RBEmpty (RBNode Red _ _ _ _) -> False
89+ ; Node _ _ _ Empty (Node Red _ _ _ _) -> False
89− ; RBNode _ _ _ l r -> (leftLeaning l) && (leftLeaning r)
90+ ; Node _ _ _ l r -> (leftLeaning l) && (leftLeaning r)
90 }
91 }
91
92
92invariants_hold t =
93invariants_hold t =
@@ -97,37 +98,37 @@ invariants_hold t =
97--}
98--}
98
99
99
100
100−min : RBTree k v -> (k,v)
101+min : Dict k v -> (k,v)
101min t =
102min t =
102 case t of
103 case t of
103− RBNode _ k v RBEmpty _ -> (k,v)
104+ Node _ k v Empty _ -> (k,v)
104− RBNode _ _ _ l _ -> min l
105+ Node _ _ _ l _ -> min l
105− RBEmpty -> Error.raise "(min RBEmpty) is not defined"
106+ Empty -> Error.raise "(min Empty) is not defined"
106
107
107{--
108{--
108max t =
109max t =
109 case t of
110 case t of
110− { RBNode _ k v _ RBEmpty -> (k,v)
111+ { Node _ k v _ Empty -> (k,v)
111− ; RBNode _ _ _ _ r -> max r
112+ ; Node _ _ _ _ r -> max r
112− ; RBEmpty -> Error.raise "(max RBEmpty) is not defined"
113+ ; Empty -> Error.raise "(max Empty) is not defined"
113 }
114 }
114--}
115--}
115
116
116−lookup : k -> RBTree k v -> Maybe v
117+lookup : k -> Dict k v -> Maybe v
117lookup k t =
118lookup k t =
118 case t of
119 case t of
119− RBEmpty -> Nothing
120+ Empty -> Nothing
120− RBNode _ k' v l r ->
121+ Node _ k' v l r ->
121 case compare k k' of
122 case compare k k' of
122 LT -> lookup k l
123 LT -> lookup k l
123 EQ -> Just v
124 EQ -> Just v
124 GT -> lookup k r
125 GT -> lookup k r
125
126
126−findWithDefault : v -> k -> RBTree k v -> v
127+findWithDefault : v -> k -> Dict k v -> v
127findWithDefault base k t =
128findWithDefault base k t =
128 case t of
129 case t of
129− RBEmpty -> base
130+ Empty -> base
130− RBNode _ k' v l r ->
131+ Node _ k' v l r ->
131 case compare k k' of
132 case compare k k' of
132 LT -> findWithDefault base k l
133 LT -> findWithDefault base k l
133 EQ -> v
134 EQ -> v
@@ -136,8 +137,8 @@ findWithDefault base k t =
136{--
137{--
137find k t =
138find k t =
138 case t of
139 case t of
139− { RBEmpty -> Error.raise "Key was not found in dictionary!"
140+ { Empty -> Error.raise "Key was not found in dictionary!"
140− ; RBNode _ k' v l r ->
141+ ; Node _ k' v l r ->
141 case compare k k' of
142 case compare k k' of
142 { LT -> find k l
143 { LT -> find k l
143 ; EQ -> v
144 ; EQ -> v
@@ -146,71 +147,71 @@ find k t =
146--}
147--}
147
148
148-- Does t contain k?
149-- Does t contain k?
149−member : k -> RBTree k v -> Bool
150+member : k -> Dict k v -> Bool
150member k t = Maybe.isJust $ lookup k t
151member k t = Maybe.isJust $ lookup k t
151
152
152−rotateLeft : RBTree k v -> RBTree k v
153+rotateLeft : Dict k v -> Dict k v
153rotateLeft t =
154rotateLeft t =
154 case t of
155 case t of
155− RBNode cy ky vy a (RBNode cz kz vz b c) -> RBNode cy kz vz (RBNode Red ky vy a b) c
156+ Node cy ky vy a (Node cz kz vz b c) -> Node cy kz vz (Node Red ky vy a b) c
156 _ -> Error.raise "rotateLeft of a node without enough children"
157 _ -> Error.raise "rotateLeft of a node without enough children"
157
158
158-- rotateRight -- the reverse, and
159-- rotateRight -- the reverse, and
159-- makes Y have Z's color, and makes Z Red.
160-- makes Y have Z's color, and makes Z Red.
160−rotateRight : RBTree k v -> RBTree k v
161+rotateRight : Dict k v -> Dict k v
161rotateRight t =
162rotateRight t =
162 case t of
163 case t of
163− RBNode cz kz vz (RBNode cy ky vy a b) c -> RBNode cz ky vy a (RBNode Red kz vz b c)
164+ Node cz kz vz (Node cy ky vy a b) c -> Node cz ky vy a (Node Red kz vz b c)
164 _ -> Error.raise "rotateRight of a node without enough children"
165 _ -> Error.raise "rotateRight of a node without enough children"
165
166
166−rotateLeftIfNeeded : RBTree k v -> RBTree k v
167+rotateLeftIfNeeded : Dict k v -> Dict k v
167rotateLeftIfNeeded t =
168rotateLeftIfNeeded t =
168 case t of
169 case t of
169− RBNode _ _ _ _ (RBNode Red _ _ _ _) -> rotateLeft t
170+ Node _ _ _ _ (Node Red _ _ _ _) -> rotateLeft t
170 _ -> t
171 _ -> t
171
172
172−rotateRightIfNeeded : RBTree k v -> RBTree k v
173+rotateRightIfNeeded : Dict k v -> Dict k v
173rotateRightIfNeeded t =
174rotateRightIfNeeded t =
174 case t of
175 case t of
175− RBNode _ _ _ (RBNode Red _ _ (RBNode Red _ _ _ _) _) _ -> rotateRight t
176+ Node _ _ _ (Node Red _ _ (Node Red _ _ _ _) _) _ -> rotateRight t
176 _ -> t
177 _ -> t
177
178
178otherColor c = case c of { Red -> Black ; Black -> Red }
179otherColor c = case c of { Red -> Black ; Black -> Red }
179
180
180−color_flip : RBTree k v -> RBTree k v
181+color_flip : Dict k v -> Dict k v
181color_flip t =
182color_flip t =
182 case t of
183 case t of
183− RBNode c1 bk bv (RBNode c2 ak av la ra) (RBNode c3 ck cv lc rc) ->
184+ Node c1 bk bv (Node c2 ak av la ra) (Node c3 ck cv lc rc) ->
184− RBNode (otherColor c1) bk bv
185+ Node (otherColor c1) bk bv
185− (RBNode (otherColor c2) ak av la ra)
186+ (Node (otherColor c2) ak av la ra)
186− (RBNode (otherColor c3) ck cv lc rc)
187+ (Node (otherColor c3) ck cv lc rc)
187− _ -> Error.raise "color_flip called on a RBEmpty or RBNode with a RBEmpty child"
188+ _ -> Error.raise "color_flip called on a Empty or Node with a Empty child"
188
189
189−color_flipIfNeeded : RBTree k v -> RBTree k v
190+color_flipIfNeeded : Dict k v -> Dict k v
190color_flipIfNeeded t =
191color_flipIfNeeded t =
191 case t of
192 case t of
192− RBNode _ _ _ (RBNode Red _ _ _ _) (RBNode Red _ _ _ _) -> color_flip t
193+ Node _ _ _ (Node Red _ _ _ _) (Node Red _ _ _ _) -> color_flip t
193 _ -> t
194 _ -> t
194
195
195fixUp t = color_flipIfNeeded (rotateRightIfNeeded (rotateLeftIfNeeded t))
196fixUp t = color_flipIfNeeded (rotateRightIfNeeded (rotateLeftIfNeeded t))
196
197
197−ensureBlackRoot : RBTree k v -> RBTree k v
198+ensureBlackRoot : Dict k v -> Dict k v
198ensureBlackRoot t =
199ensureBlackRoot t =
199 case t of
200 case t of
200− RBNode Red k v l r -> RBNode Black k v l r
201+ Node Red k v l r -> Node Black k v l r
201 _ -> t
202 _ -> t
202
203
203-- Invariant: t is a valid left-leaning rb tree *)
204-- Invariant: t is a valid left-leaning rb tree *)
204−insert : k -> v -> RBTree k v -> RBTree k v
205+insert : k -> v -> Dict k v -> Dict k v
205insert k v t =
206insert k v t =
206 let ins t =
207 let ins t =
207 case t of
208 case t of
208− RBEmpty -> RBNode Red k v RBEmpty RBEmpty
209+ Empty -> Node Red k v Empty Empty
209− RBNode c k' v' l r ->
210+ Node c k' v' l r ->
210 let h = case compare k k' of
211 let h = case compare k k' of
211− LT -> RBNode c k' v' (ins l) r
212+ LT -> Node c k' v' (ins l) r
212− EQ -> RBNode c k' v l r -- replace
213+ EQ -> Node c k' v l r -- replace
213− GT -> RBNode c k' v' l (ins r)
214+ GT -> Node c k' v' l (ins r)
214 in fixUp h
215 in fixUp h
215 in ensureBlackRoot (ins t)
216 in ensureBlackRoot (ins t)
216{--
217{--
@@ -222,71 +223,71 @@ insert k v t =
222 else new_t)
223 else new_t)
223--}
224--}
224
225
225−singleton : k -> v -> RBTree k v
226+singleton : k -> v -> Dict k v
226−singleton k v = insert k v RBEmpty
227+singleton k v = insert k v Empty
227
228
228−isRed : RBTree k v -> Bool
229+isRed : Dict k v -> Bool
229isRed t =
230isRed t =
230 case t of
231 case t of
231− RBNode Red _ _ _ _ -> True
232+ Node Red _ _ _ _ -> True
232 _ -> False
233 _ -> False
233
234
234−isRedLeft : RBTree k v -> Bool
235+isRedLeft : Dict k v -> Bool
235isRedLeft t =
236isRedLeft t =
236 case t of
237 case t of
237− RBNode _ _ _ (RBNode Red _ _ _ _) _ -> True
238+ Node _ _ _ (Node Red _ _ _ _) _ -> True
238 _ -> False
239 _ -> False
239
240
240−isRedLeftLeft : RBTree k v -> Bool
241+isRedLeftLeft : Dict k v -> Bool
241isRedLeftLeft t =
242isRedLeftLeft t =
242 case t of
243 case t of
243− RBNode _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) _ -> True
244+ Node _ _ _ (Node _ _ _ (Node Red _ _ _ _) _) _ -> True
244 _ -> False
245 _ -> False
245
246
246−isRedRight : RBTree k v -> Bool
247+isRedRight : Dict k v -> Bool
247isRedRight t =
248isRedRight t =
248 case t of
249 case t of
249− RBNode _ _ _ _ (RBNode Red _ _ _ _) -> True
250+ Node _ _ _ _ (Node Red _ _ _ _) -> True
250 _ -> False
251 _ -> False
251
252
252−isRedRightLeft : RBTree k v -> Bool
253+isRedRightLeft : Dict k v -> Bool
253isRedRightLeft t =
254isRedRightLeft t =
254 case t of
255 case t of
255− RBNode _ _ _ _ (RBNode _ _ _ (RBNode Red _ _ _ _) _) -> True
256+ Node _ _ _ _ (Node _ _ _ (Node Red _ _ _ _) _) -> True
256 _ -> False
257 _ -> False
257
258
258−moveRedLeft : RBTree k v -> RBTree k v
259+moveRedLeft : Dict k v -> Dict k v
259moveRedLeft t =
260moveRedLeft t =
260 let t' = color_flip t in
261 let t' = color_flip t in
261 case t' of
262 case t' of
262− RBNode c k v l r ->
263+ Node c k v l r ->
263 case r of
264 case r of
264− RBNode _ _ _ (RBNode Red _ _ _ _) _ ->
265+ Node _ _ _ (Node Red _ _ _ _) _ ->
265− color_flip (rotateLeft (RBNode c k v l (rotateRight r)))
266+ color_flip (rotateLeft (Node c k v l (rotateRight r)))
266 _ -> t'
267 _ -> t'
267 _ -> t'
268 _ -> t'
268
269
269−moveRedRight : RBTree k v -> RBTree k v
270+moveRedRight : Dict k v -> Dict k v
270moveRedRight t =
271moveRedRight t =
271 let t' = color_flip t in
272 let t' = color_flip t in
272 if isRedLeftLeft t' then color_flip (rotateRight t') else t'
273 if isRedLeftLeft t' then color_flip (rotateRight t') else t'
273
274
274−moveRedLeftIfNeeded : RBTree k v -> RBTree k v
275+moveRedLeftIfNeeded : Dict k v -> Dict k v
275moveRedLeftIfNeeded t =
276moveRedLeftIfNeeded t =
276 if not (isRedLeft t) && not (isRedLeftLeft t) then moveRedLeft t else t
277 if not (isRedLeft t) && not (isRedLeftLeft t) then moveRedLeft t else t
277
278
278−moveRedRightIfNeeded : RBTree k v -> RBTree k v
279+moveRedRightIfNeeded : Dict k v -> Dict k v
279moveRedRightIfNeeded t =
280moveRedRightIfNeeded t =
280 if not (isRedRight t) && not (isRedRightLeft t) then moveRedRight t else t
281 if not (isRedRight t) && not (isRedRightLeft t) then moveRedRight t else t
281
282
282−deleteMin : RBTree k v -> RBTree k v
283+deleteMin : Dict k v -> Dict k v
283deleteMin t =
284deleteMin t =
284 let del t =
285 let del t =
285 case t of
286 case t of
286− RBNode _ _ _ RBEmpty _ -> RBEmpty
287+ Node _ _ _ Empty _ -> Empty
287 _ -> case moveRedLeftIfNeeded t of
288 _ -> case moveRedLeftIfNeeded t of
288− RBNode c k v l r -> fixUp (RBNode c k v (del l) r)
289+ Node c k v l r -> fixUp (Node c k v (del l) r)
289− RBEmpty -> RBEmpty
290+ Empty -> Empty
290 in ensureBlackRoot (del t)
291 in ensureBlackRoot (del t)
291
292
292{--
293{--
@@ -294,35 +295,35 @@ deleteMax t =
294 let del t =
295 let del t =
295 let t' = if isRedLeft t then rotateRight t else t in
296 let t' = if isRedLeft t then rotateRight t else t in
296 case t' of
297 case t' of
297− { RBNode _ _ _ _ RBEmpty -> RBEmpty
298+ { Node _ _ _ _ Empty -> Empty
298 ; _ -> let t'' = moveRedRightIfNeeded t' in
299 ; _ -> let t'' = moveRedRightIfNeeded t' in
299 case t'' of
300 case t'' of
300− { RBNode c k v l r -> fixUp (RBNode c k v l (del r))
301+ { Node c k v l r -> fixUp (Node c k v l (del r))
301− ; RBEmpty -> RBEmpty } }
302+ ; Empty -> Empty } }
302 in ensureBlackRoot (del t)
303 in ensureBlackRoot (del t)
303--}
304--}
304
305
305−remove : k -> RBTree k v -> RBTree k v
306+remove : k -> Dict k v -> Dict k v
306remove k t =
307remove k t =
307 let eq_and_noRightNode t =
308 let eq_and_noRightNode t =
308− case t of { RBNode _ k' _ _ RBEmpty -> k == k' ; _ -> False }
309+ case t of { Node _ k' _ _ Empty -> k == k' ; _ -> False }
309− eq t = case t of { RBNode _ k' _ _ _ -> k == k' ; _ -> False }
310+ eq t = case t of { Node _ k' _ _ _ -> k == k' ; _ -> False }
310 delLT t = case moveRedLeftIfNeeded t of
311 delLT t = case moveRedLeftIfNeeded t of
311− RBNode c k' v l r -> fixUp (RBNode c k' v (del l) r)
312+ Node c k' v l r -> fixUp (Node c k' v (del l) r)
312− RBEmpty -> Error.raise "delLT on RBEmpty"
313+ Empty -> Error.raise "delLT on Empty"
313 delEQ t = case t of -- Replace with successor
314 delEQ t = case t of -- Replace with successor
314− RBNode c _ _ l r -> let (k',v') = min r in
315+ Node c _ _ l r -> let (k',v') = min r in
315− fixUp (RBNode c k' v' l (deleteMin r))
316+ fixUp (Node c k' v' l (deleteMin r))
316− RBEmpty -> Error.raise "delEQ called on a RBEmpty"
317+ Empty -> Error.raise "delEQ called on a Empty"
317 delGT t = case t of
318 delGT t = case t of
318− RBNode c k' v l r -> fixUp (RBNode c k' v l (del r))
319+ Node c k' v l r -> fixUp (Node c k' v l (del r))
319− RBEmpty -> Error.raise "delGT called on a RBEmpty"
320+ Empty -> Error.raise "delGT called on a Empty"
320 del t = case t of
321 del t = case t of
321− RBEmpty -> RBEmpty
322+ Empty -> Empty
322− RBNode _ k' _ _ _ ->
323+ Node _ k' _ _ _ ->
323 if k < k' then delLT t else
324 if k < k' then delLT t else
324 let u = if isRedLeft t then rotateRight t else t in
325 let u = if isRedLeft t then rotateRight t else t in
325− if eq_and_noRightNode u then RBEmpty else
326+ if eq_and_noRightNode u then Empty else
326 let t' = moveRedRightIfNeeded t in
327 let t' = moveRedRightIfNeeded t in
327 if eq t' then delEQ t' else delGT t'
328 if eq t' then delEQ t' else delGT t'
328 in if member k t then ensureBlackRoot (del t) else t
329 in if member k t then ensureBlackRoot (del t) else t
@@ -334,41 +335,43 @@ remove k t =
334 Error.raise "invariants broken after remove")
335 Error.raise "invariants broken after remove")
335--}
336--}
336
337
337−map : (a -> b) -> RBTree k a -> RBTree k b
338+map : (a -> b) -> Dict k a -> Dict k b
338map f t =
339map f t =
339 case t of
340 case t of
340− RBEmpty -> RBEmpty
341+ Empty -> Empty
341− RBNode c k v l r -> RBNode c k (f v) (map f l) (map f r)
342+ Node c k v l r -> Node c k (f v) (map f l) (map f r)
342
343
343−foldl : (k -> v -> b -> b) -> b -> RBTree k v -> b
344+foldl : (k -> v -> b -> b) -> b -> Dict k v -> b
344foldl f acc t =
345foldl f acc t =
345 case t of
346 case t of
346− RBEmpty -> acc
347+ Empty -> acc
347− RBNode _ k v l r -> foldl f (f k v (foldl f acc l)) r
348+ Node _ k v l r -> foldl f (f k v (foldl f acc l)) r
348
349
349−foldr : (k -> v -> b -> b) -> b -> RBTree k v -> b
350+foldr : (k -> v -> b -> b) -> b -> Dict k v -> b
350foldr f acc t =
351foldr f acc t =
351 case t of
352 case t of
352− RBEmpty -> acc
353+ Empty -> acc
353− RBNode _ k v l r -> foldr f (f k v (foldr f acc r)) l
354+ Node _ k v l r -> foldr f (f k v (foldr f acc r)) l
354
355
355−union : RBTree k v -> RBTree k v -> RBTree k v
356+union : Dict k v -> Dict k v -> Dict k v
356union t1 t2 = foldl insert t2 t1
357union t1 t2 = foldl insert t2 t1
357
358
358−intersect : RBTree k v -> RBTree k v -> RBTree k v
359+intersect : Dict k v -> Dict k v -> Dict k v
360+intersect t1 t2 =
359−intersect t1 t2 = foldl (\k v t -> if k `member` t2 then insert k v t else t) empty t1
361+ let combine k v t = if k `member` t2 then insert k v t else t
362+ in foldl combine empty t1
360
363
361−diff : RBTree k v -> RBTree k v -> RBTree k v
364+diff : Dict k v -> Dict k v -> Dict k v
362diff t1 t2 = foldl (\k v t -> remove k t) t1 t2
365diff t1 t2 = foldl (\k v t -> remove k t) t1 t2
363
366
364−keys : RBTree k v -> [k]
367+keys : Dict k v -> [k]
365keys t = foldr (\k v acc -> k :: acc) [] t
368keys t = foldr (\k v acc -> k :: acc) [] t
366
369
367−values : RBTree k v -> [v]
370+values : Dict k v -> [v]
368values t = foldr (\k v acc -> v :: acc) [] t
371values t = foldr (\k v acc -> v :: acc) [] t
369
372
370−toList : RBTree k v -> [(k,v)]
373+toList : Dict k v -> [(k,v)]
371toList t = foldr (\k v acc -> (k,v) :: acc) [] t
374toList t = foldr (\k v acc -> (k,v) :: acc) [] t
372
375
373−fromList : [(k,v)] -> RBTree k v
376+fromList : [(k,v)] -> Dict k v
374−fromList assocs = Elm.List.foldl (uncurry insert) empty assocs
377+fromList assocs = List.foldl (uncurry insert) empty assocs
libraries/Json.elm+1−1
@@ -1,7 +1,7 @@
1
1
2module Json where
2module Json where
3
3
4−import Dict
4+import Dict as Dict
5import JavaScript as JS
5import JavaScript as JS
6import Native.Json as Native
6import Native.Json as Native
7
7
libraries/Native/Char.jsnew file+31
@@ -0,0 +1,31 @@
1+
2+Elm.Native.Char = function(elm) {
3+ 'use strict';
4+
5+ elm.Native = elm.Native || {};
6+ if (elm.Native.Char) return elm.Native.Char;
7+
8+ function isBetween(lo,hi) { return function(chr) {
9+ var c = chr.charCodeAt(0);
10+ return lo <= c && c <= hi;
11+ };
12+ }
13+ var isDigit = isBetween('0'.charCodeAt(0),'9'.charCodeAt(0));
14+ var chk1 = isBetween('a'.charCodeAt(0),'f'.charCodeAt(0));
15+ var chk2 = isBetween('A'.charCodeAt(0),'F'.charCodeAt(0));
16+
17+ return elm.Native.Char = {
18+ fromCode : function(c) { return String.fromCharCode(c); },
19+ toCode : function(c) { return c.charCodeAt(0); },
20+ toUpper : function(c) { return c.toUpperCase(); },
21+ toLower : function(c) { return c.toLowerCase(); },
22+ toLocaleUpper : function(c) { return c.toLocaleUpperCase(); },
23+ toLocaleLower : function(c) { return c.toLocaleLowerCase(); },
24+ isLower : isBetween('a'.charCodeAt(0),'z'.charCodeAt(0)),
25+ isUpper : isBetween('A'.charCodeAt(0),'Z'.charCodeAt(0)),
26+ isDigit : isDigit,
27+ isOctDigit : isBetween('0'.charCodeAt(0),'7'.charCodeAt(0)),
28+ isHexDigit : function(c) { return isDigit(c) || chk1(c) || chk2(c); }
29+ };
30+
31+};
libraries/Native/Prelude.js+7−6
@@ -1,11 +1,12 @@
1
1
2−Elm.Prelude = function(elm) {
2+Elm.Native.Prelude = function(elm) {
3 'use strict';
3 'use strict';
4− if (elm.Prelude) return elm.Prelude;
4+ if (elm.Native.Prelude) return elm.Native.Prelude;
5
5
6 var JS = Elm.JavaScript(elm);
6 var JS = Elm.JavaScript(elm);
7 var Maybe = Elm.Maybe(elm);
7 var Maybe = Elm.Maybe(elm);
8 var Utils = Elm.Native.Utils(elm);
8 var Utils = Elm.Native.Utils(elm);
9+ var Char = Elm.Char(elm);
9
10
10 function div(a,b) { return (a/b)|0 }
11 function div(a,b) { return (a/b)|0 }
11 function rem(a,b) { return a % b }
12 function rem(a,b) { return a % b }
@@ -41,7 +42,7 @@ Elm.Prelude = function(elm) {
41 start = 1;
42 start = 1;
42 }
43 }
43 for (var i = start; i < len; ++i) {
44 for (var i = start; i < len; ++i) {
44− if (!Elm.Char.isDigit(s[i])) { return Maybe.Nothing }
45+ if (!Char.isDigit(s[i])) { return Maybe.Nothing }
45 }
46 }
46 return Maybe.Just(parseInt(s));
47 return Maybe.Just(parseInt(s));
47 }
48 }
@@ -57,7 +58,7 @@ Elm.Prelude = function(elm) {
57 }
58 }
58 var dotCount = 0;
59 var dotCount = 0;
59 for (var i = start; i < len; ++i) {
60 for (var i = start; i < len; ++i) {
60− if (Elm.Char.isDigit(s[i])) { continue; }
61+ if (Char.isDigit(s[i])) { continue; }
61 if (s[i] === '.') {
62 if (s[i] === '.') {
62 dotCount += 1;
63 dotCount += 1;
63 if (dotCount <= 1) { continue; }
64 if (dotCount <= 1) { continue; }
@@ -119,7 +120,7 @@ Elm.Prelude = function(elm) {
119 add(Elm.List);
120 add(Elm.List);
120 add(Elm.Maybe);
121 add(Elm.Maybe);
121 add(Elm.Time);
122 add(Elm.Time);
122− add(Elm.Graphics);
123+ add(Elm.Graphics.Element);
123
124
124− return elm.Prelude = prelude;
125+ return elm.Native.Prelude = prelude;
125};
126};
libraries/Prelude.elm+2
@@ -1,6 +1,8 @@
1
1
2module Prelude where
2module Prelude where
3
3
4+import Native.Prelude as N
5+
4radians : Float -> Float
6radians : Float -> Float
5radians t = t
7radians t = t
6
8
libraries/Set.elm+2−2
@@ -6,8 +6,8 @@ module Set (empty,singleton,insert,remove
6 ,toList,fromList
6 ,toList,fromList
7 ) where
7 ) where
8
8
9−import Dict
9+import Dict as Dict
10−import List
10+import List as List
11
11
12type Set t = Dict t ()
12type Set t = Dict t ()
13
13