git.iko.soy/elk
on ef4d1db help sign in
elk/compiler/src/Types/Hints.hs
446 lines 19 kB history raw
1module Types.Hints (hints) where
3import Context
4import Control.Arrow (first)
5import Control.Monad (liftM,mapM)
6import Types.Types
7import Types.Substitutions (rescheme)
9ctx str = C (Just str) NoSpan
10prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
11hasType t = map (-: t)
14-------- Text and Elements --------
16textToText = [ "header", "italic", "bold", "underline"
17 , "overline", "strikeThrough", "monospace" ]
19textAttrs = [ "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)
25elements =
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 ]
52directions = hasType direction ["up","down","left","right","inward","outward"]
53positions =
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 ]
60lineTypes = [ 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"]
65shapes = [ 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" ]
74collages = [ 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 ]
82graphicsElement = prefix "Graphics"
83 (concat [elements,directions,positions,lineTypes,shapes,collages])
84graphicsColor = 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"]
92-------- Foreign --------
94casts =
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 ]
107castToTuple n = (,) name $ Forall [1..n] [] (jsTuple vs ==> tupleOf vs)
108 where vs = map VarT [1..n]
109 name = "castJSTupleToTuple" ++ show n
110castToJSTuple n = (,) name $ Forall [1..n] [] (tupleOf vs ==> jsTuple vs)
111 where vs = map VarT [1..n]
112 name = "castTupleToJSTuple" ++ show n
114polyCasts =
115 map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
116 [ "castJSArrayToList" -:: jsArray a ==> listOf a
117 , "castListToJSArray" -:: listOf a ==> jsArray a
118 ]
120javascript = prefix "JavaScript" (concat [casts,polyCasts])
122json = 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 ]
146-------- Signals --------
148lyft n = sig (n+1) ("lift" ++ show n)
149sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
150 where fn = foldr1 (==>)
151 ts = map VarT [1..n]
153signals = 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 ]
178http = 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]
190concreteSignals =
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 ]
211keyboards = 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 ]
221touches = 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 ]
228times = 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 ]
246dates =
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)
262-------- Math and Binops --------
264binop t = t ==> t ==> t
265scheme1 super t name =
266 (name, Forall [0] [ ctx name $ VarT 0 :<: super
267 ] (t (VarT 0)))
268scheme2 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)))
272numScheme t name = scheme1 number t name
273twoNums f name = scheme2 number number f name
275math =
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 ]
289bools =
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 ]
297chars = 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 ]
305-------- Polymorphic Functions --------
307[a,b,c] = map VarT [1,2,3]
309infix 8 -::
310name -:: tipe = (name, Forall [1,2,3] [] tipe)
312funcs =
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]
331tuple n = ("Tuple" ++ show n, Forall [1..n] [] $ foldr (==>) (tupleOf vs) vs)
332 where vs = map VarT [1..n]
334lists = 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" ]
367maybeFuncs = 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 ]
375eithers = 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 ]
384dictionary =
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 ]
406sets =
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 ]
424automaton =
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 ]
439-------- Everything --------
441hints = 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 ]