git.iko.soy/elk
on 2eeac2f help sign in
elk/elm/src/Types/Hints.hs
381 lines 16 kB history raw
2module Types.Hints (hints) where
4import Control.Monad (liftM,mapM)
5import Control.Arrow (first)
6import Types.Types
7import Types.Substitutions (rescheme)
10prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
12-------- Text and Elements --------
14textToText = [ "header", "italic", "bold", "underline"
15 , "overline", "strikeThrough", "monospace" ]
17textAttrs = [ "toText" -: string ==> text
18 , "Text.typeface" -: string ==> text ==> text
19 , "Text.link" -:: string ==> text ==> text
20 , numScheme (\t -> t ==> text ==> text) "Text.height"
21 ] ++ prefix "Text" (hasType (text ==> text) textToText)
23elements =
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 ]
50directions = hasType direction ["up","down","left","right","inward","outward"]
51positions =
52 hasType position ["topLeft","midLeft","bottomLeft","midTop","middle"
53 ,"midBottom","topRight","midRight","bottomRight"] ++
54 hasType (location ==> location ==> position)
55 ["topLeftAt","bottomLeftAt","middleAt","topRightAt","bottomRightAt"] ++
56 [ "absolute" -: int ==> location, "relative" -: float ==> location ]
58lineTypes = [ numScheme (\n -> listOf (pairOf n) ==> line) "line"
59 , numScheme (\n -> pairOf n ==> pairOf n ==> line) "segment"
60 , "customLine" -: listOf int ==> color ==> line ==> form
61 ] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"]
63shapes = [ twoNums (\n m -> listOf (pairOf n) ==> pairOf m ==> shape) "polygon"
64 , "filled" -: color ==> shape ==> form
65 , "outlined" -: color ==> shape ==> form
66 , "textured" -: string ==> shape ==> form
67 , "customOutline" -: listOf int ==> color ==> shape ==> form
68 ] ++ map (twoNums (\n m -> n ==> n ==> pairOf m ==> shape)) [ "ngon"
69 , "rect"
70 , "oval" ]
72collages = [ numScheme (\n -> pairOf n ==> element ==> form) "toForm"
73 , numScheme (\n -> string ==> n ==> n ==> pairOf n ==> form) "sprite"
74 , numScheme (\n -> n ==> n ==> form ==> form) "move"
75 , numScheme (\n -> n ==> form ==> form) "rotate"
76 , numScheme (\n -> n ==> form ==> form) "scale"
77 , numScheme (\n -> pairOf n ==> form ==> bool) "isWithin"
78 ]
80graphicsElement = prefix "Graphics"
81 (concat [elements,directions,positions,lineTypes,shapes,collages])
82graphicsColor = prefix "Color" clrs
83 where clrs = [ numScheme (\n -> n ==> n ==> n ==> color) "rgb"
84 , numScheme (\n -> n ==> n ==> n ==> n ==> color) "rgba"
85 , "complement" -: color ==> color
86 ] ++ hasType color ["red","green","blue","black","white"
87 ,"yellow","cyan","magenta","grey","gray"]
90-------- Foreign --------
92casts =
93 [ "castJSBoolToBool" -: jsBool ==> bool
94 , "castBoolToJSBool" -: bool ==> jsBool
95 , "castJSNumberToInt" -: jsNumber ==> int
96 , "castIntToJSNumber" -: int ==> jsNumber
97 , "castJSElementToElement" -: int ==> int ==> jsElement ==> element
98 , "castElementToJSElement" -: element ==> jsElement
99 , "castJSStringToString" -: jsString ==> string
100 , "castStringToJSString" -: string ==> jsString
101 , "castJSNumberToFloat" -: jsNumber ==> float
102 , "castFloatToJSNumber" -: float ==> jsNumber
103 ]
105castToTuple n = (,) name $ Forall [1..n] [] (jsTuple vs ==> tupleOf vs)
106 where vs = map VarT [1..n]
107 name = "castJSTupleToTuple" ++ show n
108castToJSTuple n = (,) name $ Forall [1..n] [] (tupleOf vs ==> jsTuple vs)
109 where vs = map VarT [1..n]
110 name = "castTupleToJSTuple" ++ show n
112polyCasts =
113 map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
114 [ "castJSArrayToList" -:: jsArray a ==> listOf a
115 , "castListToJSArray" -:: listOf a ==> jsArray a
116 ]
118javascript = prefix "JavaScript" (concat [casts,polyCasts])
120json = prefix "JSON"
121 [ "JsonString" -: string ==> jsonValue
122 , "JsonBool" -: bool ==> jsonValue
123 , "JsonNull" -: jsonValue
124 , "JsonArray" -: listOf jsonValue ==> jsonValue
125 , "JsonObject" -: jsonObject ==> jsonValue
126 , numScheme (\n -> n ==> jsonValue) "JsonNumber"
127 , "toString" -: jsonObject ==> string
128 , "fromString" -: string ==> jsonObject
129 , "lookup" -: string ==> jsonObject ==> maybeOf jsonValue
130 , "findObject" -: string ==> jsonObject ==> jsonObject
131 , "findArray" -: string ==> jsonObject ==> listOf jsonValue
132 , "findString" -: string ==> jsonObject ==> string
133 , "findWithDefault" -:: jsonValue ==> string ==> jsonObject ==> jsonValue
134 , "toPrettyString" -: string ==> jsonObject ==> string
135 , "toPrettyJSString" -: string ==> jsonObject ==> jsString
136 , "toList" -: jsonObject ==> listOf (tupleOf [string,jsonValue])
137 , "fromList" -: listOf (tupleOf [string,jsonValue]) ==> jsonObject
138 , "toJSString" -: jsonObject ==> jsString
139 , "fromJSString" -: jsString ==> jsonObject
140 ]
143-------- Signals --------
145sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
146 where fn = foldr1 (==>)
147 ts = map VarT [1..n]
149signals = prefix "Signal"
150 [ sig 1 "constant"
151 , sig 2 "lift"
152 , sig 3 "lift2"
153 , sig 4 "lift3"
154 , sig 5 "lift4"
155 , "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
156 , "foldp1" -:: (a ==> a ==> a) ==> signalOf a ==> signalOf a
157 , "foldp'" -:: (a ==> b ==> b) ==> (a ==> b) ==> signalOf a ==> signalOf b
158 , "count" -:: signalOf a ==> signalOf int
159 , "keepIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
160 , "dropIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
161 , "keepWhen" -:: signalOf bool ==> a ==> signalOf a ==> signalOf a
162 , "dropWhen" -:: signalOf bool ==> a ==> signalOf a ==> signalOf a
163 , "dropRepeats" -:: signalOf a ==> signalOf a
164 , "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
165 ]
167http = prefix "HTTP"
168 [ "send" -:: signalOf (request a) ==> signalOf (response string)
169 , "sendGet" -:: signalOf string ==> signalOf (response string)
170 , "get" -: string ==> request string
171 , "post" -: string ==> string ==> request string
172 , "request" -: string ==> string ==> string ==> listOf (pairOf string) ==> request string
173 , "Waiting" -:: response a
174 , "Failure" -:: int ==> string ==> response a
175 , "Success" -:: a ==> response a ]
176 where request t = ADT "Request" [t]
177 response t = ADT "Response" [t]
179concreteSignals =
180 [ "Keyboard.Raw.keysDown" -: signalOf (listOf int)
181 , "Keyboard.Raw.charPressed" -: signalOf (maybeOf int)
182 , "Random.inRange" -: int ==> int ==> signalOf int
183 , "Random.randomize" -:: int ==> int ==> signalOf a ==> signalOf int
184 , timeScheme "Time.every" (\t -> t ==> signalOf t)
185 , timeScheme "Time.before" (\t -> t ==> signalOf bool)
186 , timeScheme "Time.after" (\t -> t ==> signalOf bool)
187 , "Window.dimensions" -: signalOf point
188 , "Window.width" -: signalOf int
189 , "Window.height" -: signalOf int
190 , "Mouse.position" -: signalOf point
191 , "Mouse.x" -: signalOf int
192 , "Mouse.y" -: signalOf int
193 , "Mouse.isDown" -: signalOf bool
194 , "Mouse.isClicked" -: signalOf bool
195 , "Mouse.clicks" -: signalOf (tupleOf [])
196 , "Input.textField" -: string ==> tupleOf [element, signalOf string]
197 , "Input.password" -: string ==> tupleOf [element, signalOf string]
198 , "Input.textArea" -: int ==> int ==> tupleOf [element, signalOf string]
199 , "Input.checkBox" -: bool ==> tupleOf [element, signalOf bool]
200 , "Input.button" -: string ==> tupleOf [element, signalOf bool]
201 , "Input.stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
202 , "Input.dropDown" -:: listOf (tupleOf [string,a]) ==> tupleOf [element, signalOf a]
203 ]
205-------- Math and Binops --------
207binop t = t ==> t ==> t
208scheme1 super t name =
209 (name, Forall [0] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: super
210 ] (t (VarT 0)))
211scheme2 s1 s2 t name =
212 (name, Forall [0,1] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: s1
213 , Context ("`" ++ name ++ "'") $ VarT 1 :<: s2
214 ] (t (VarT 0) (VarT 1)))
215numScheme t name = scheme1 number t name
216timeScheme name t = scheme1 time t name
217twoNums f name = scheme2 number number f name
219math =
220 map (numScheme (\t -> t ==> binop t)) ["clamp"] ++
221 map (numScheme (\t -> binop t)) ["+","-","*","max","min"] ++
222 [ numScheme (\t -> t ==> t) "abs" ] ++
223 hasType (binop float) [ "/", "logBase" ] ++
224 hasType (binop int) ["rem","div","mod"] ++
225 hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"] ++
226 hasType float ["pi","e"] ++
227 hasType (int ==> float) ["toFloat","castIntToFloat"] ++
228 hasType (float ==> int) ["round","floor","ceiling","truncate"] ++
229 [ "show" -:: a ==> string
230 , "readInt" -: string ==> maybeOf int
231 , "readFloat" -: string ==> maybeOf float ]
233bools =
234 [ "not" -: bool ==> bool ] ++
235 hasType (binop bool) ["&&","||"] ++
236 map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++
237 [ ( "compare"
238 , Forall [0,1] [ Context "`compare'" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
239 ]
241chars = prefix "Char" (classify ++ convert1 ++ convert2)
242 where classify = hasType (char ==> bool)
243 ["isDigit","isOctDigit","isHexDigit","isUpper","isLower"]
244 convert1 = hasType (char ==> char)
245 ["toUpper","toLower","toLocaleUpper","toLocaleLower"]
246 convert2 = [ "toCode" -: char ==> int, "fromCode" -: int ==> char ]
249-------- Polymorphic Functions --------
251[a,b,c] = map VarT [1,2,3]
253infix 8 -::
254name -:: tipe = (name, Forall [1,2,3] [] tipe)
256funcs =
257 [ "id" -:: a ==> a
258 , "==" -:: a ==> a ==> bool
259 , "/=" -:: a ==> a ==> bool
260 , "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
261 , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
262 , "$" -:: (a ==> b) ==> a ==> b
263 , ":" -:: a ==> listOf a ==> listOf a
264 , (,) "++" . Forall [0,1] [ Context "`++'" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0
265 , "Cons" -:: a ==> listOf a ==> listOf a
266 , "Nil" -:: listOf a
267 , "Just" -:: a ==> maybeOf a
268 , "Nothing" -:: maybeOf a
269 , "curry" -:: (tupleOf [a,b] ==> c) ==> a ==> b ==> c
270 , "uncurry" -:: (a ==> b ==> c) ==> tupleOf [a,b] ==> c
271 ] ++ map tuple [0..8]
273tuple n = ("Tuple" ++ show n, Forall [1..n] [] $ foldr (==>) (tupleOf vs) vs)
274 where vs = map VarT [1..n]
276lists = prefix "List"
277 [ "and" -:: listOf bool ==> bool
278 , "or" -:: listOf bool ==> bool
279 , numScheme (\n -> listOf n ==> listOf n) "sort"
280 , "head" -:: listOf a ==> a
281 , "tail" -:: listOf a ==> listOf a
282 , "length" -:: listOf a ==> int
283 , "filter" -:: (a ==> bool) ==> listOf a ==> listOf a
284 , "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
285 , "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
286 , "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
287 , "all" -:: (a ==> bool) ==> listOf a ==> bool
288 , "any" -:: (a ==> bool) ==> listOf a ==> bool
289 , "reverse" -:: listOf a ==> listOf a
290 , "take" -:: int ==> listOf a ==> listOf a
291 , "drop" -:: int ==> listOf a ==> listOf a
292 , "partition" -:: (a ==> bool) ==> listOf a ==> tupleOf [listOf a,listOf a]
293 , "intersperse" -:: a ==> listOf a ==> listOf a
294 , "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
295 , "map" -:: (a ==> b) ==> listOf a ==> listOf b
296 , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
297 , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
298 , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
299 , (,) "concat" . Forall [0,1] [ Context "`concat'" $ VarT 0 :<: appendable (VarT 1) ] $
300 listOf (VarT 0) ==> VarT 0
301 , (,) "concatMap" . Forall [0,1,2] [ Context "`concatMap'" $ VarT 0 :<: appendable (VarT 1) ] $
302 (VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0
303 , (,) "intercalate" . Forall [0,1] [ Context "`intercalate'" $ VarT 0 :<: appendable (VarT 1) ] $
304 VarT 0 ==> listOf (VarT 0) ==> VarT 0
305 , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
306 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
307 , "maximum", "minimum" ]
309maybeFuncs = prefix "Maybe"
310 [ "maybe" -:: b ==> (a ==> b) ==> maybeOf a ==> b
311 , "isJust" -:: maybeOf a ==> bool
312 , "isNothing" -:: maybeOf a ==> bool
313 , "fromMaybe" -:: a ==> maybeOf a ==> a
314 , "consMaybe" -:: maybeOf a ==> listOf a ==> listOf a
315 , "catMaybes" -:: listOf (maybeOf a) ==> listOf a
316 , "catMaybes" -:: (a ==> maybeOf b) ==> listOf a ==> listOf b
317 ]
319dictionary =
320 let dict k v = ADT "Dict" [k,v] in
321 prefix "Dict"
322 [ "empty" -:: dict a b
323 , "singleton" -:: a ==> b ==> dict a b
324 , "insert" -:: a ==> b ==> dict a b ==> dict a b
325 , "remove" -:: a ==> dict a b ==> dict a b
326 , "member" -:: a ==> dict a b ==> bool
327 , "lookup" -:: a ==> dict a b ==> maybeOf b
328 , "findWithDefault" -:: b ==> a ==> dict a b ==> b
329 , "intersect" -:: dict a b ==> dict a c ==> dict a b
330 , "union" -:: dict a b ==> dict a b ==> dict a b
331 , "diff" -:: dict a b ==> dict a c ==> dict a b
332 , "map" -:: (b ==> c) ==> dict a b ==> dict a c
333 , "foldl" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
334 , "foldr" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
335 , "keys" -:: dict a b ==> listOf a
336 , "values" -:: dict a b ==> listOf b
337 , "toList" -:: dict a b ==> listOf (tupleOf [a,b])
338 , "fromList" -:: listOf (tupleOf [a,b]) ==> dict a b
339 ]
341sets =
342 let set v = ADT "Set" [v] in
343 prefix "Set"
344 [ "empty" -:: set a
345 , "singleton" -:: a ==> set a
346 , "insert" -:: a ==> set a ==> set a
347 , "remove" -:: a ==> set a ==> set a
348 , "member" -:: a ==> set a ==> bool
349 , "intersect" -:: set a ==> set a ==> set a
350 , "union" -:: set a ==> set a ==> set a
351 , "diff" -:: set a ==> set a ==> set a
352 , "map" -:: (a ==> b) ==> set a ==> set b
353 , "foldl" -:: (a ==> b ==> b) ==> b ==> set a ==> b
354 , "foldr" -:: (a ==> b ==> b) ==> b ==> set a ==> b
355 , "toList" -:: set a ==> listOf a
356 , "fromList" -:: listOf a ==> set a
357 ]
359automaton =
360 let auto a b = ADT "Automaton" [a,b] in
361 prefix "Automaton"
362 [ "pure" -:: (a ==> b) ==> auto a b
363 , "init" -:: b ==> (a ==> b ==> b) ==> auto a b
364 , "init'" -:: c ==> (a ==> c ==> tupleOf [b,c]) ==> auto a b
365 , ">>>" -:: auto a b ==> auto b c ==> auto a c
366 , "<<<" -:: auto b c ==> auto a b ==> auto a c
367 , "combine" -:: listOf (auto a b) ==> auto a (listOf b)
368 , "run" -:: auto a b ==> signalOf a ==> signalOf b
369 , "step" -:: auto a b ==> a ==> tupleOf [b,auto a b]
370 , "count" -:: auto a int
371 , "draggable" -:: form ==> auto (tupleOf [bool,point]) form
372 ]
374-------- Everything --------
376hints = mapM (\(n,s) -> (,) n `liftM` rescheme s) hs
377 where hs = concat [ funcs, lists, signals, math, bools, textAttrs
378 , graphicsElement, graphicsColor
379 , concreteSignals, javascript, json, maybeFuncs
380 , http, dictionary, sets, automaton
381 ]