git.iko.soy/elk
on d178521 help sign in
elk/elm/src/Types/Hints.hs
300 lines 13 kB history raw
2module Types.Hints (hints) where
4import Control.Monad (liftM,mapM)
5import Control.Arrow (first)
6import Types
7import Types.Substitutions (rescheme)
10-------- Text and Elements --------
12str2elem = hasType (string ==> element) [ "plainText" ]
14textToText = [ "header", "italic", "bold", "underline"
15 , "overline", "strikeThrough", "monospace" ]
17textAttrs = [ "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
23elements = 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 ]
48directions = hasType direction ["up","down","left","right","inward","outward"]
49positions =
50 hasType position ["topLeft","midLeft","bottomLeft","midTop","middle"
51 ,"midBottom","topRight","midRight","bottomRight"] ++
52 hasType (location ==> location ==> position)
53 ["topLeftAt","bottomLeftAt","middleAt","topRightAt","bottomRightAt"] ++
54 [ "absolute" -: int ==> location, "relative" -: float ==> location ]
55colors = [ 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"]
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 ]
82-------- Foreign --------
84casts =
85 [ "castJSBoolToBool" -: jsBool ==> bool
86 , "castBoolToJSBool" -: bool ==> jsBool
87 , "castJSNumberToInt" -: jsNumber ==> int
88 , "castIntToJSNumber" -: int ==> jsNumber
89 , "castJSElementToElement" -: int ==> int ==> jsElement ==> element
90 , "castElementToJSElement" -: element ==> jsElement
91 , "castJSStringToString" -: jsString ==> string
92 , "castStringToJSString" -: string ==> jsString
93 , "castJSNumberToFloat" -: jsNumber ==> float
94 , "castFloatToJSNumber" -: float ==> jsNumber
95 ]
97castToTuple n = (,) name $ Forall [1..n] [] (jsTuple vs ==> tupleOf vs)
98 where vs = map VarT [1..n]
99 name = "castJSTupleToTuple" ++ show n
100castToJSTuple n = (,) name $ Forall [1..n] [] (tupleOf vs ==> jsTuple vs)
101 where vs = map VarT [1..n]
102 name = "castTupleToJSTuple" ++ show n
104polyCasts =
105 map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
106 [ "castJSArrayToList" -:: jsArray a ==> listOf a
107 , "castListToJSArray" -:: listOf a ==> jsArray a
108 ]
110json =
111 [ "JsonString" -: string ==> jsonValue
112 , "JsonBool" -: bool ==> jsonValue
113 , "JsonNull" -: jsonValue
114 , "JsonArray" -: listOf jsonValue ==> jsonValue
115 , "JsonObject" -: jsonObject ==> jsonValue
116 , numScheme (\n -> n ==> jsonValue) "JsonNumber"
117 , "toPrettyString" -: string ==> jsonObject ==> string
118 , "toPrettyJSString" -: string ==> jsonObject ==> jsString
119 , "toJSString" -: jsonObject ==> jsString
120 ]
123-------- Signals --------
125sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
126 where fn = foldr1 (==>)
127 ts = map VarT [1..n]
129signals =
130 [ sig 1 "constant"
131 , sig 2 "lift"
132 , sig 3 "lift2"
133 , sig 4 "lift3"
134 , sig 5 "lift4"
135 , "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
136 , "foldp1" -:: (a ==> a ==> a) ==> signalOf a ==> signalOf a
137 , "foldp'" -:: (a ==> b ==> b) ==> (a ==> b) ==> signalOf a ==> signalOf b
138 , "randomize" -:: int ==> int ==> signalOf a ==> signalOf int
139 , "count" -:: signalOf a ==> signalOf int
140 , "keepIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
141 , "dropIf" -:: (a==>bool) ==> a ==> signalOf a ==> signalOf a
142 , "keepWhen" -:: signalOf bool ==>a==> signalOf a ==> signalOf a
143 , "dropWhen" -:: signalOf bool ==>a==> signalOf a ==> signalOf a
144 , "dropRepeats" -:: signalOf a ==> signalOf a
145 , "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
146 ]
148http =
149 [ "send" -:: signalOf (request a) -> signalOf (response string)
150 , "sendGet" -:: signalOf string -> signalOf (response string)
151 , "get" -: string ==> request string
152 , "post" -: string ==> string ==> request string
153 , "request" -: string ==> string ==> string ==> listOf (pairOf string) ==> request string
154 , "Waiting" -:: response a
155 , "Failure" -:: int ==> string ==> response a
156 , "Success" -:: a -> response a ]
157 where request t = ADT "Request" [t]
158 response t = ADT "Response" [t]
160concreteSignals =
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 ]
181-------- Math and Binops --------
183binop t = t ==> t ==> t
184scheme1 super t name =
185 (name, Forall [0] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: super
186 ] (t (VarT 0)))
187scheme2 s1 s2 t name =
188 (name, Forall [0,1] [ Context ("`" ++ name ++ "'") $ VarT 0 :<: s1
189 , Context ("`" ++ name ++ "'") $ VarT 1 :<: s2
190 ] (t (VarT 0) (VarT 1)))
191numScheme t name = scheme1 number t name
192timeScheme name t = scheme1 time t name
193twoNums f name = scheme2 number number f name
195math =
196 map (numScheme (\t -> t ==> binop t)) ["clamp"] ++
197 map (numScheme (\t -> binop t)) ["+","-","*","max","min"] ++
198 [ numScheme (\t -> t ==> t) "abs" ] ++
199 hasType (binop float) [ "/", "logBase" ] ++
200 hasType (binop int) ["rem","div","mod"] ++
201 hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"] ++
202 hasType float ["pi","e"] ++
203 hasType (int ==> float) ["toFloat","castIntToFloat"] ++
204 hasType (float ==> int) ["round","floor","ceiling","truncate"]
206bools =
207 [ "not" -: bool ==> bool ] ++
208 hasType (binop bool) ["&&","||"] ++
209 map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++
210 [ ( "compare"
211 , Forall [0,1] [ Context "`compare'" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
212 ]
214chars =
215 [ hasType (char ==> bool)
216 ["isDigit","isOctDigit","isHexDigit","isUpper","isLower"]
217 , hasType (char ==> char)
218 ["toUpper","toLower","toLocaleUpper","toLocaleLower"]
219 , "toCode" -: char ==> int
220 , "fromCode" -: int ==> char
221 ]
223-------- Polymorphic Functions --------
225[a,b,c] = map VarT [1,2,3]
227infix 8 -::
228name -:: tipe = (name, Forall [1,2,3] [] tipe)
230funcs =
231 [ "id" -:: a ==> a
232 , "==" -:: a ==> a ==> bool
233 , "/=" -:: a ==> a ==> bool
234 , "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
235 , "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
236 , "$" -:: (a ==> b) ==> a ==> b
237 , ":" -:: a ==> listOf a ==> listOf a
238 , (,) "++" . Forall [0,1] [ Context "`++'" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0
239 , "Cons" -:: a ==> listOf a ==> listOf a
240 , "Nil" -:: listOf a
241 , "Just" -:: a ==> maybeOf a
242 , "Nothing" -:: maybeOf a
243 , "curry" -:: (tupleOf [a,b] ==> c) ==> a ==> b ==> c
244 , "uncurry" -:: (a ==> b ==> c) ==> tupleOf [a,b] ==> c
245 ] ++ map tuple [0..8]
247tuple n = ("Tuple" ++ show n, Forall [1..n] [] $ foldr (==>) (tupleOf vs) vs)
248 where vs = map VarT [1..n]
250lists =
251 [ "and" -:: listOf bool ==> bool
252 , "or" -:: listOf bool ==> bool
253 , numScheme (\n -> listOf n ==> listOf n) "sort"
254 , "head" -:: listOf a ==> a
255 , "tail" -:: listOf a ==> listOf a
256 , "length" -:: listOf a ==> int
257 , "filter" -:: (a ==> bool) ==> listOf a ==> listOf a
258 , "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
259 , "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
260 , "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
261 , "all" -:: (a ==> bool) ==> listOf a ==> bool
262 , "any" -:: (a ==> bool) ==> listOf a ==> bool
263 , "reverse" -:: listOf a ==> listOf a
264 , "take" -:: int ==> listOf a ==> listOf a
265 , "drop" -:: int ==> listOf a ==> listOf a
266 , "partition" -:: (a ==> bool) ==> listOf a ==> tupleOf [listOf a,listOf a]
267 , "intersperse" -:: a ==> listOf a ==> listOf a
268 , "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
269 , "map" -:: (a ==> b) ==> listOf a ==> listOf b
270 , "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
271 , "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
272 , "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
273 , (,) "concat" . Forall [0,1] [ Context "`concat'" $ VarT 0 :<: appendable (VarT 1) ] $
274 listOf (VarT 0) ==> VarT 0
275 , (,) "concatMap" . Forall [0,1,2] [ Context "`concatMap'" $ VarT 0 :<: appendable (VarT 1) ] $
276 (VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0
277 , (,) "intercalate" . Forall [0,1] [ Context "`intercalate'" $ VarT 0 :<: appendable (VarT 1) ] $
278 VarT 0 ==> listOf (VarT 0) ==> VarT 0
279 , "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
280 ] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
281 , "maximum", "minimum" ]
283maybeFuncs =
284 [ "maybe" -:: b ==> (a ==> b) ==> maybeOf a ==> b
285 , "isJust" -:: maybeOf a ==> bool
286 , "isNothing" -:: maybeOf a ==> bool
287 , "fromMaybe" -:: a ==> maybeOf a ==> a
288 , "consMaybe" -:: maybeOf a ==> listOf a ==> listOf a
289 , "catMaybes" -:: listOf (maybeOf a) ==> listOf a
290 , "catMaybes" -:: (a ==> maybeOf b) ==> listOf a ==> listOf b
291 ]
293-------- Everything --------
295hints = mapM (\(n,s) -> (,) n `liftM` rescheme s) hs
296 where hs = concat [ funcs, lists, signals, math, bools, str2elem, textAttrs
297 , elements, directions, colors, lineTypes, shapes
298 , concreteSignals, casts, polyCasts, json, maybeFuncs
299 , positions, collages, http
300 ]