2012-08-09 14:38:18 +00:00
|
|
|
module Types.Hints (hints) where
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
import Context
|
2012-05-15 06:12:18 +00:00
|
|
|
import Control.Arrow (first)
|
2012-12-25 08:39:18 +00:00
|
|
|
import Control.Monad (liftM,mapM)
|
2012-11-23 04:30:37 +00:00
|
|
|
import Types.Types
|
2012-08-09 14:38:18 +00:00
|
|
|
import Types.Substitutions (rescheme)
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-12-25 08:39:18 +00:00
|
|
|
ctx str = C (Just str) NoSpan
|
2012-10-21 11:50:40 +00:00
|
|
|
prefix pre xs = map (first (\x -> pre ++ "." ++ x)) xs
|
2013-02-04 10:56:22 +00:00
|
|
|
hasType t = map (-: t)
|
|
|
|
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
-------- Text and Elements --------
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-05-20 05:10:16 +00:00
|
|
|
textToText = [ "header", "italic", "bold", "underline"
|
2012-05-12 04:27:59 +00:00
|
|
|
, "overline", "strikeThrough", "monospace" ]
|
|
|
|
|
|
|
|
textAttrs = [ "toText" -: string ==> text
|
2012-10-22 07:17:18 +00:00
|
|
|
, "Text.typeface" -: string ==> text ==> text
|
|
|
|
, "Text.link" -:: string ==> text ==> text
|
|
|
|
, numScheme (\t -> t ==> text ==> text) "Text.height"
|
|
|
|
] ++ prefix "Text" (hasType (text ==> text) textToText)
|
2012-10-21 11:50:40 +00:00
|
|
|
|
|
|
|
elements =
|
|
|
|
let iee = int ==> element ==> element in
|
|
|
|
[ "plainText" -: string ==> element
|
|
|
|
, "link" -:: string ==> element ==> element
|
|
|
|
, "flow" -: direction ==> listOf element ==> element
|
|
|
|
, "layers" -: listOf element ==> element
|
|
|
|
, "text" -: text ==> element
|
|
|
|
, "image" -: int ==> int ==> string ==> element
|
|
|
|
, "video" -: int ==> int ==> string ==> element
|
|
|
|
, "opacity" -: float ==> element ==> element
|
|
|
|
, "width" -: iee
|
|
|
|
, "height" -: iee
|
|
|
|
, "size" -: int ==> iee
|
|
|
|
, "widthOf" -: element ==> int
|
|
|
|
, "heightOf"-: element ==> int
|
|
|
|
, "sizeOf" -: element ==> pairOf int
|
|
|
|
, "color" -: color ==> element ==> element
|
|
|
|
, "container" -: int ==> int ==> position ==> element ==> element
|
|
|
|
, "spacer" -: int ==> int ==> element
|
|
|
|
, "rightedText" -: text ==> element
|
|
|
|
, "centeredText" -: text ==> element
|
|
|
|
, "justifiedText" -: text ==> element
|
|
|
|
, "asText" -:: a ==> element
|
|
|
|
, "collage" -: int ==> int ==> listOf form ==> element
|
|
|
|
, "fittedImage" -: int ==> int ==> string ==> element
|
|
|
|
]
|
2012-04-19 06:32:10 +00:00
|
|
|
|
2012-05-21 02:24:35 +00:00
|
|
|
directions = hasType direction ["up","down","left","right","inward","outward"]
|
2012-09-18 15:18:49 +00:00
|
|
|
positions =
|
|
|
|
hasType position ["topLeft","midLeft","bottomLeft","midTop","middle"
|
|
|
|
,"midBottom","topRight","midRight","bottomRight"] ++
|
2012-10-03 02:02:50 +00:00
|
|
|
hasType (location ==> location ==> position)
|
2012-09-18 15:18:49 +00:00
|
|
|
["topLeftAt","bottomLeftAt","middleAt","topRightAt","bottomRightAt"] ++
|
|
|
|
[ "absolute" -: int ==> location, "relative" -: float ==> location ]
|
2012-05-21 02:24:35 +00:00
|
|
|
|
2012-07-19 12:22:31 +00:00
|
|
|
lineTypes = [ numScheme (\n -> listOf (pairOf n) ==> line) "line"
|
2012-09-18 15:18:49 +00:00
|
|
|
, numScheme (\n -> pairOf n ==> pairOf n ==> line) "segment"
|
2012-07-19 11:51:57 +00:00
|
|
|
, "customLine" -: listOf int ==> color ==> line ==> form
|
2012-05-21 02:24:35 +00:00
|
|
|
] ++ hasType (color ==> line ==> form) ["solid","dashed","dotted"]
|
|
|
|
|
2012-07-21 23:50:35 +00:00
|
|
|
shapes = [ twoNums (\n m -> listOf (pairOf n) ==> pairOf m ==> shape) "polygon"
|
2012-05-21 02:24:35 +00:00
|
|
|
, "filled" -: color ==> shape ==> form
|
|
|
|
, "outlined" -: color ==> shape ==> form
|
2012-09-18 15:18:49 +00:00
|
|
|
, "textured" -: string ==> shape ==> form
|
2012-07-19 11:51:57 +00:00
|
|
|
, "customOutline" -: listOf int ==> color ==> shape ==> form
|
2012-07-21 23:50:35 +00:00
|
|
|
] ++ map (twoNums (\n m -> n ==> n ==> pairOf m ==> shape)) [ "ngon"
|
2012-07-19 12:26:35 +00:00
|
|
|
, "rect"
|
|
|
|
, "oval" ]
|
2012-05-21 02:24:35 +00:00
|
|
|
|
2012-09-18 15:18:49 +00:00
|
|
|
collages = [ numScheme (\n -> pairOf n ==> element ==> form) "toForm"
|
|
|
|
, numScheme (\n -> string ==> n ==> n ==> pairOf n ==> form) "sprite"
|
|
|
|
, numScheme (\n -> n ==> n ==> form ==> form) "move"
|
|
|
|
, numScheme (\n -> n ==> form ==> form) "rotate"
|
|
|
|
, numScheme (\n -> n ==> form ==> form) "scale"
|
2012-10-03 02:57:52 +00:00
|
|
|
, numScheme (\n -> pairOf n ==> form ==> bool) "isWithin"
|
2012-09-18 15:18:49 +00:00
|
|
|
]
|
2012-05-21 02:24:35 +00:00
|
|
|
|
2012-10-22 07:17:18 +00:00
|
|
|
graphicsElement = prefix "Graphics"
|
2012-10-21 11:50:40 +00:00
|
|
|
(concat [elements,directions,positions,lineTypes,shapes,collages])
|
2012-10-22 07:17:18 +00:00
|
|
|
graphicsColor = prefix "Color" clrs
|
2012-10-21 11:50:40 +00:00
|
|
|
where clrs = [ numScheme (\n -> n ==> n ==> n ==> color) "rgb"
|
|
|
|
, numScheme (\n -> n ==> n ==> n ==> n ==> color) "rgba"
|
2012-10-23 08:17:34 +00:00
|
|
|
, "complement" -: color ==> color
|
2012-10-21 11:50:40 +00:00
|
|
|
] ++ hasType color ["red","green","blue","black","white"
|
|
|
|
,"yellow","cyan","magenta","grey","gray"]
|
|
|
|
|
|
|
|
|
2012-06-28 08:52:47 +00:00
|
|
|
-------- Foreign --------
|
|
|
|
|
|
|
|
casts =
|
2012-07-19 11:51:57 +00:00
|
|
|
[ "castJSBoolToBool" -: jsBool ==> bool
|
|
|
|
, "castBoolToJSBool" -: bool ==> jsBool
|
|
|
|
, "castJSNumberToInt" -: jsNumber ==> int
|
|
|
|
, "castIntToJSNumber" -: int ==> jsNumber
|
|
|
|
, "castJSElementToElement" -: int ==> int ==> jsElement ==> element
|
2012-06-28 08:52:47 +00:00
|
|
|
, "castElementToJSElement" -: element ==> jsElement
|
|
|
|
, "castJSStringToString" -: jsString ==> string
|
|
|
|
, "castStringToJSString" -: string ==> jsString
|
2012-07-19 11:51:57 +00:00
|
|
|
, "castJSNumberToFloat" -: jsNumber ==> float
|
|
|
|
, "castFloatToJSNumber" -: float ==> jsNumber
|
2012-06-28 08:52:47 +00:00
|
|
|
]
|
|
|
|
|
2012-07-19 11:51:57 +00:00
|
|
|
castToTuple n = (,) name $ Forall [1..n] [] (jsTuple vs ==> tupleOf vs)
|
|
|
|
where vs = map VarT [1..n]
|
|
|
|
name = "castJSTupleToTuple" ++ show n
|
|
|
|
castToJSTuple n = (,) name $ Forall [1..n] [] (tupleOf vs ==> jsTuple vs)
|
|
|
|
where vs = map VarT [1..n]
|
|
|
|
name = "castTupleToJSTuple" ++ show n
|
|
|
|
|
|
|
|
polyCasts =
|
|
|
|
map castToTuple [2..5] ++ map castToJSTuple [2..5] ++
|
|
|
|
[ "castJSArrayToList" -:: jsArray a ==> listOf a
|
|
|
|
, "castListToJSArray" -:: listOf a ==> jsArray a
|
2012-06-28 08:52:47 +00:00
|
|
|
]
|
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
javascript = prefix "JavaScript" (concat [casts,polyCasts])
|
|
|
|
|
|
|
|
json = prefix "JSON"
|
2012-07-28 20:59:51 +00:00
|
|
|
[ "JsonString" -: string ==> jsonValue
|
|
|
|
, "JsonBool" -: bool ==> jsonValue
|
|
|
|
, "JsonNull" -: jsonValue
|
|
|
|
, "JsonArray" -: listOf jsonValue ==> jsonValue
|
|
|
|
, "JsonObject" -: jsonObject ==> jsonValue
|
|
|
|
, numScheme (\n -> n ==> jsonValue) "JsonNumber"
|
2012-10-21 11:50:40 +00:00
|
|
|
, "toString" -: jsonObject ==> string
|
2013-02-03 00:37:05 +00:00
|
|
|
, "fromString" -: string ==> maybeOf jsonObject
|
2012-10-21 11:50:40 +00:00
|
|
|
, "lookup" -: string ==> jsonObject ==> maybeOf jsonValue
|
|
|
|
, "findObject" -: string ==> jsonObject ==> jsonObject
|
2012-10-30 07:48:47 +00:00
|
|
|
, "findArray" -: string ==> jsonObject ==> listOf jsonValue
|
2012-10-21 11:50:40 +00:00
|
|
|
, "findString" -: string ==> jsonObject ==> string
|
2013-02-03 10:39:42 +00:00
|
|
|
, "findNumber" -: float ==> jsonObject ==> float
|
2012-10-21 11:50:40 +00:00
|
|
|
, "findWithDefault" -:: jsonValue ==> string ==> jsonObject ==> jsonValue
|
|
|
|
, "toPrettyString" -: string ==> jsonObject ==> string
|
2012-07-28 20:59:51 +00:00
|
|
|
, "toPrettyJSString" -: string ==> jsonObject ==> jsString
|
2012-10-21 11:50:40 +00:00
|
|
|
, "toList" -: jsonObject ==> listOf (tupleOf [string,jsonValue])
|
|
|
|
, "fromList" -: listOf (tupleOf [string,jsonValue]) ==> jsonObject
|
|
|
|
, "toJSString" -: jsonObject ==> jsString
|
|
|
|
, "fromJSString" -: jsString ==> jsonObject
|
2012-07-28 20:59:51 +00:00
|
|
|
]
|
|
|
|
|
2012-06-28 08:52:47 +00:00
|
|
|
|
2012-05-21 02:24:35 +00:00
|
|
|
-------- Signals --------
|
|
|
|
|
2012-12-02 04:43:37 +00:00
|
|
|
lyft n = sig (n+1) ("lift" ++ show n)
|
2012-07-19 11:51:57 +00:00
|
|
|
sig n name = (,) name $ Forall [1..n] [] (fn ts ==> fn (map signalOf ts))
|
2012-05-21 02:24:35 +00:00
|
|
|
where fn = foldr1 (==>)
|
2012-07-19 11:51:57 +00:00
|
|
|
ts = map VarT [1..n]
|
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
signals = prefix "Signal"
|
2012-07-19 11:51:57 +00:00
|
|
|
[ sig 1 "constant"
|
|
|
|
, sig 2 "lift"
|
2012-12-02 04:43:37 +00:00
|
|
|
] ++ map lyft [2..8] ++ [
|
2012-12-15 03:59:50 +00:00
|
|
|
"<~" -:: (a ==> b) ==> signalOf a ==> signalOf b
|
|
|
|
, "~" -:: signalOf (a ==> b) ==> signalOf a ==> signalOf b
|
|
|
|
, "foldp" -:: (a ==> b ==> b) ==> b ==> signalOf a ==> signalOf b
|
2012-10-03 02:57:52 +00:00
|
|
|
, "foldp1" -:: (a ==> a ==> a) ==> signalOf a ==> signalOf a
|
|
|
|
, "foldp'" -:: (a ==> b ==> b) ==> (a ==> b) ==> signalOf a ==> signalOf b
|
2012-07-19 11:51:57 +00:00
|
|
|
, "count" -:: signalOf a ==> signalOf int
|
2012-12-02 04:43:37 +00:00
|
|
|
, "countIf" -:: (a ==> bool) ==> signalOf a ==> signalOf int
|
|
|
|
, "keepIf" -:: (a ==> bool) ==> a ==> signalOf a ==> signalOf a
|
|
|
|
, "dropIf" -:: (a ==> bool) ==> a ==> signalOf a ==> signalOf a
|
2012-10-16 06:03:14 +00:00
|
|
|
, "keepWhen" -:: signalOf bool ==> a ==> signalOf a ==> signalOf a
|
|
|
|
, "dropWhen" -:: signalOf bool ==> a ==> signalOf a ==> signalOf a
|
2012-07-19 11:51:57 +00:00
|
|
|
, "dropRepeats" -:: signalOf a ==> signalOf a
|
2012-12-04 06:23:32 +00:00
|
|
|
, "sampleOn" -:: signalOf a ==> signalOf b ==> signalOf b
|
|
|
|
, "timestamp" -:: signalOf a ==> signalOf (tupleOf [time,a])
|
|
|
|
, "timeOf" -:: signalOf a ==> signalOf time
|
|
|
|
, "merge" -:: signalOf a ==> signalOf a ==> signalOf a
|
|
|
|
, "merges" -:: listOf (signalOf a) ==> signalOf a
|
2013-01-14 08:15:14 +00:00
|
|
|
, "mergeEither" -:: signalOf a ==> signalOf b ==> signalOf (eitherOf a b)
|
2012-12-02 04:43:37 +00:00
|
|
|
, numScheme (\n -> int ==> signalOf n ==> signalOf float) "average"
|
2012-05-21 02:24:35 +00:00
|
|
|
]
|
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
http = prefix "HTTP"
|
2012-10-07 06:13:03 +00:00
|
|
|
[ "send" -:: signalOf (request a) ==> signalOf (response string)
|
|
|
|
, "sendGet" -:: signalOf string ==> signalOf (response string)
|
2012-10-04 04:55:39 +00:00
|
|
|
, "get" -: string ==> request string
|
|
|
|
, "post" -: string ==> string ==> request string
|
|
|
|
, "request" -: string ==> string ==> string ==> listOf (pairOf string) ==> request string
|
|
|
|
, "Waiting" -:: response a
|
|
|
|
, "Failure" -:: int ==> string ==> response a
|
2012-10-07 06:13:03 +00:00
|
|
|
, "Success" -:: a ==> response a ]
|
2012-10-04 04:55:39 +00:00
|
|
|
where request t = ADT "Request" [t]
|
|
|
|
response t = ADT "Response" [t]
|
|
|
|
|
2012-06-28 08:52:47 +00:00
|
|
|
concreteSignals =
|
2013-01-14 08:15:14 +00:00
|
|
|
[ "Random.inRange" -: int ==> int ==> signalOf int
|
2012-11-29 06:16:08 +00:00
|
|
|
, "Random.randomize" -:: int ==> int ==> signalOf a ==> signalOf int
|
2012-10-21 11:50:40 +00:00
|
|
|
, "Window.dimensions" -: signalOf point
|
|
|
|
, "Window.width" -: signalOf int
|
|
|
|
, "Window.height" -: signalOf int
|
|
|
|
, "Mouse.position" -: signalOf point
|
|
|
|
, "Mouse.x" -: signalOf int
|
|
|
|
, "Mouse.y" -: signalOf int
|
|
|
|
, "Mouse.isDown" -: signalOf bool
|
|
|
|
, "Mouse.isClicked" -: signalOf bool
|
|
|
|
, "Mouse.clicks" -: signalOf (tupleOf [])
|
|
|
|
, "Input.textField" -: string ==> tupleOf [element, signalOf string]
|
|
|
|
, "Input.password" -: string ==> tupleOf [element, signalOf string]
|
|
|
|
, "Input.textArea" -: int ==> int ==> tupleOf [element, signalOf string]
|
|
|
|
, "Input.checkBox" -: bool ==> tupleOf [element, signalOf bool]
|
|
|
|
, "Input.button" -: string ==> tupleOf [element, signalOf bool]
|
|
|
|
, "Input.stringDropDown" -: listOf string ==> tupleOf [element, signalOf string]
|
|
|
|
, "Input.dropDown" -:: listOf (tupleOf [string,a]) ==> tupleOf [element, signalOf a]
|
2012-06-28 08:52:47 +00:00
|
|
|
]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2013-01-14 08:15:14 +00:00
|
|
|
keyboards = prefix "Keyboard"
|
|
|
|
[ "Raw.keysDown" -: signalOf (listOf int)
|
|
|
|
, "Raw.charPressed" -: signalOf (maybeOf int)
|
2013-01-16 05:40:12 +00:00
|
|
|
, "arrows" -: signalOf (recordOf [("x",int),("y",int)])
|
|
|
|
, "wasd" -: signalOf (recordOf [("x",int),("y",int)])
|
2013-01-14 08:15:14 +00:00
|
|
|
, "ctrl" -: signalOf bool
|
|
|
|
, "space" -: signalOf bool
|
|
|
|
, "shift" -: signalOf bool
|
|
|
|
]
|
|
|
|
|
|
|
|
touches = prefix "Touch"
|
|
|
|
[ "touches" -: signalOf (listOf (recordOf [("x" ,int) ,("y" ,int)
|
|
|
|
,("x0",int) ,("y0",int)
|
|
|
|
,("t0",time),("id",int)]))
|
|
|
|
, "taps" -: signalOf (recordOf [("x",int),("y",int)])
|
|
|
|
]
|
|
|
|
|
2012-11-29 06:16:08 +00:00
|
|
|
times = prefix "Time"
|
2013-01-14 08:15:14 +00:00
|
|
|
[ numScheme (\n -> n ==> signalOf time) "fps"
|
|
|
|
, numScheme (\n -> n ==> signalOf bool ==> signalOf time) "fpsWhen"
|
2012-12-02 04:43:37 +00:00
|
|
|
, "every" -: time ==> signalOf time
|
|
|
|
, "delay" -:: time ==> signalOf a ==> signalOf a
|
|
|
|
, "since" -:: time ==> signalOf a ==> signalOf bool
|
|
|
|
, "hour" -: time
|
|
|
|
, "minute" -: time
|
|
|
|
, "second" -: time
|
2012-12-04 06:23:32 +00:00
|
|
|
, "ms" -: time
|
2012-11-29 06:16:08 +00:00
|
|
|
, "inHours" -: time ==> float
|
|
|
|
, "inMinutes" -: time ==> float
|
|
|
|
, "inSeconds" -: time ==> float
|
2012-12-02 04:43:37 +00:00
|
|
|
, "inMss" -: time ==> float
|
|
|
|
, "toDate" -: time ==> date
|
|
|
|
, "read" -: string ==> maybeOf time
|
2012-11-29 06:16:08 +00:00
|
|
|
]
|
|
|
|
|
|
|
|
dates =
|
|
|
|
let days = map (-: day) ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
|
|
|
|
months = map (-: month) [ "Jan", "Feb", "Mar", "Apr", "May", "Jun"
|
|
|
|
, "Jul", "Aug", "Sep", "Oct", "Nov", "Dec" ]
|
|
|
|
in prefix "Date"
|
2012-12-02 04:43:37 +00:00
|
|
|
([ "read" -: string ==> maybeOf date
|
2012-11-29 06:16:08 +00:00
|
|
|
, "year" -: date ==> int
|
|
|
|
, "month" -: date ==> month
|
|
|
|
, "day" -: date ==> int
|
|
|
|
, "hour" -: date ==> int
|
|
|
|
, "minute" -: date ==> int
|
|
|
|
, "second" -: date ==> int
|
|
|
|
, "dayOfWeek" -: date ==> day
|
|
|
|
, "toTime" -: date ==> time
|
|
|
|
] ++ days ++ months)
|
|
|
|
|
2012-05-12 04:27:59 +00:00
|
|
|
-------- Math and Binops --------
|
|
|
|
|
2012-07-19 11:51:57 +00:00
|
|
|
binop t = t ==> t ==> t
|
2012-08-09 14:38:18 +00:00
|
|
|
scheme1 super t name =
|
2012-12-25 08:39:18 +00:00
|
|
|
(name, Forall [0] [ ctx name $ VarT 0 :<: super
|
2012-08-09 14:38:18 +00:00
|
|
|
] (t (VarT 0)))
|
2012-07-31 13:36:26 +00:00
|
|
|
scheme2 s1 s2 t name =
|
2012-12-25 08:39:18 +00:00
|
|
|
(name, Forall [0,1] [ ctx name $ VarT 0 :<: s1
|
|
|
|
, ctx name $ VarT 1 :<: s2
|
2012-08-09 14:38:18 +00:00
|
|
|
] (t (VarT 0) (VarT 1)))
|
2012-07-28 18:36:29 +00:00
|
|
|
numScheme t name = scheme1 number t name
|
2012-07-31 13:36:26 +00:00
|
|
|
twoNums f name = scheme2 number number f name
|
2012-05-12 04:27:59 +00:00
|
|
|
|
|
|
|
math =
|
2012-07-19 11:51:57 +00:00
|
|
|
map (numScheme (\t -> t ==> binop t)) ["clamp"] ++
|
|
|
|
map (numScheme (\t -> binop t)) ["+","-","*","max","min"] ++
|
|
|
|
[ numScheme (\t -> t ==> t) "abs" ] ++
|
2012-07-19 12:22:31 +00:00
|
|
|
hasType (binop float) [ "/", "logBase" ] ++
|
|
|
|
hasType (binop int) ["rem","div","mod"] ++
|
2012-07-21 23:50:35 +00:00
|
|
|
hasType (float ==> float) ["sin","cos","tan","asin","acos","atan","sqrt"] ++
|
|
|
|
hasType float ["pi","e"] ++
|
|
|
|
hasType (int ==> float) ["toFloat","castIntToFloat"] ++
|
2012-10-21 11:50:40 +00:00
|
|
|
hasType (float ==> int) ["round","floor","ceiling","truncate"] ++
|
|
|
|
[ "show" -:: a ==> string
|
|
|
|
, "readInt" -: string ==> maybeOf int
|
|
|
|
, "readFloat" -: string ==> maybeOf float ]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-07-19 11:51:57 +00:00
|
|
|
bools =
|
|
|
|
[ "not" -: bool ==> bool ] ++
|
2013-02-03 10:39:42 +00:00
|
|
|
hasType (binop bool) ["&&","||","xor"] ++
|
2012-07-28 18:36:29 +00:00
|
|
|
map (scheme1 comparable (\t -> t ==> t ==> bool)) ["<",">","<=",">="] ++
|
|
|
|
[ ( "compare"
|
2012-12-25 08:39:18 +00:00
|
|
|
, Forall [0,1] [ ctx "compare" $ VarT 0 :<: comparable ] (VarT 0 ==> VarT 0 ==> VarT 1) )
|
2012-07-28 18:36:29 +00:00
|
|
|
]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
chars = prefix "Char" (classify ++ convert1 ++ convert2)
|
2012-10-07 06:13:03 +00:00
|
|
|
where classify = hasType (char ==> bool)
|
|
|
|
["isDigit","isOctDigit","isHexDigit","isUpper","isLower"]
|
|
|
|
convert1 = hasType (char ==> char)
|
|
|
|
["toUpper","toLower","toLocaleUpper","toLocaleLower"]
|
|
|
|
convert2 = [ "toCode" -: char ==> int, "fromCode" -: int ==> char ]
|
|
|
|
|
2012-10-04 04:55:39 +00:00
|
|
|
|
2012-05-12 04:27:59 +00:00
|
|
|
-------- Polymorphic Functions --------
|
|
|
|
|
2012-08-09 14:38:18 +00:00
|
|
|
[a,b,c] = map VarT [1,2,3]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
|
|
|
infix 8 -::
|
2012-07-19 11:51:57 +00:00
|
|
|
name -:: tipe = (name, Forall [1,2,3] [] tipe)
|
|
|
|
|
|
|
|
funcs =
|
|
|
|
[ "id" -:: a ==> a
|
|
|
|
, "==" -:: a ==> a ==> bool
|
|
|
|
, "/=" -:: a ==> a ==> bool
|
|
|
|
, "flip" -:: (a ==> b ==> c) ==> (b ==> a ==> c)
|
|
|
|
, "." -:: (b ==> c) ==> (a ==> b) ==> (a ==> c)
|
|
|
|
, "$" -:: (a ==> b) ==> a ==> b
|
2013-02-03 10:39:42 +00:00
|
|
|
, ":" -:: a ==> listOf a ==> listOf a
|
2012-12-25 08:39:18 +00:00
|
|
|
, (,) "++" . Forall [0,1] [ ctx "++" $ VarT 0 :<: appendable (VarT 1) ] $ VarT 0 ==> VarT 0 ==> VarT 0
|
2012-07-19 11:51:57 +00:00
|
|
|
, "Cons" -:: a ==> listOf a ==> listOf a
|
|
|
|
, "Nil" -:: listOf a
|
|
|
|
, "Just" -:: a ==> maybeOf a
|
|
|
|
, "Nothing" -:: maybeOf a
|
2013-01-14 08:15:14 +00:00
|
|
|
, "Left" -:: a ==> eitherOf a b
|
|
|
|
, "Right" -:: b ==> eitherOf a b
|
2012-08-10 20:16:30 +00:00
|
|
|
, "curry" -:: (tupleOf [a,b] ==> c) ==> a ==> b ==> c
|
|
|
|
, "uncurry" -:: (a ==> b ==> c) ==> tupleOf [a,b] ==> c
|
|
|
|
] ++ map tuple [0..8]
|
|
|
|
|
|
|
|
tuple n = ("Tuple" ++ show n, Forall [1..n] [] $ foldr (==>) (tupleOf vs) vs)
|
|
|
|
where vs = map VarT [1..n]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
lists = prefix "List"
|
2012-07-19 11:51:57 +00:00
|
|
|
[ "and" -:: listOf bool ==> bool
|
|
|
|
, "or" -:: listOf bool ==> bool
|
2012-07-19 12:22:31 +00:00
|
|
|
, numScheme (\n -> listOf n ==> listOf n) "sort"
|
2012-07-19 11:51:57 +00:00
|
|
|
, "head" -:: listOf a ==> a
|
|
|
|
, "tail" -:: listOf a ==> listOf a
|
|
|
|
, "length" -:: listOf a ==> int
|
|
|
|
, "filter" -:: (a ==> bool) ==> listOf a ==> listOf a
|
|
|
|
, "foldr1" -:: (a ==> a ==> a) ==> listOf a ==> a
|
|
|
|
, "foldl1" -:: (a ==> a ==> a) ==> listOf a ==> a
|
|
|
|
, "scanl1" -:: (a ==> a ==> a) ==> listOf a ==> a
|
2012-10-04 04:55:39 +00:00
|
|
|
, "all" -:: (a ==> bool) ==> listOf a ==> bool
|
|
|
|
, "any" -:: (a ==> bool) ==> listOf a ==> bool
|
2012-07-19 11:51:57 +00:00
|
|
|
, "reverse" -:: listOf a ==> listOf a
|
|
|
|
, "take" -:: int ==> listOf a ==> listOf a
|
|
|
|
, "drop" -:: int ==> listOf a ==> listOf a
|
|
|
|
, "partition" -:: (a ==> bool) ==> listOf a ==> tupleOf [listOf a,listOf a]
|
|
|
|
, "intersperse" -:: a ==> listOf a ==> listOf a
|
|
|
|
, "zip" -:: listOf a ==>listOf b ==>listOf(tupleOf [a,b])
|
|
|
|
, "map" -:: (a ==> b) ==> listOf a ==> listOf b
|
|
|
|
, "foldr" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
|
|
|
|
, "foldl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> b
|
|
|
|
, "scanl" -:: (a ==> b ==> b) ==> b ==> listOf a ==> listOf b
|
2012-12-25 08:39:18 +00:00
|
|
|
, (,) "concat" . Forall [0,1] [ ctx "concat" $ VarT 0 :<: appendable (VarT 1) ] $
|
2012-07-21 23:50:35 +00:00
|
|
|
listOf (VarT 0) ==> VarT 0
|
2012-12-25 08:39:18 +00:00
|
|
|
, (,) "concatMap" . Forall [0,1,2] [ ctx "concatMap" $ VarT 0 :<: appendable (VarT 1) ] $
|
2012-07-21 23:50:35 +00:00
|
|
|
(VarT 2 ==> VarT 0) ==> listOf (VarT 2) ==> VarT 0
|
2012-12-25 08:39:18 +00:00
|
|
|
, (,) "intercalate" . Forall [0,1] [ ctx "intercalate" $ VarT 0 :<: appendable (VarT 1) ] $
|
2012-07-21 23:50:35 +00:00
|
|
|
VarT 0 ==> listOf (VarT 0) ==> VarT 0
|
2012-07-19 11:51:57 +00:00
|
|
|
, "zipWith" -:: (a ==> b ==> c) ==> listOf a ==> listOf b ==> listOf c
|
2012-07-19 12:22:31 +00:00
|
|
|
] ++ map (numScheme (\n -> listOf n ==> n)) [ "sum", "product"
|
|
|
|
, "maximum", "minimum" ]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
maybeFuncs = prefix "Maybe"
|
2012-08-10 20:16:30 +00:00
|
|
|
[ "maybe" -:: b ==> (a ==> b) ==> maybeOf a ==> b
|
|
|
|
, "isJust" -:: maybeOf a ==> bool
|
|
|
|
, "isNothing" -:: maybeOf a ==> bool
|
2013-01-14 08:15:14 +00:00
|
|
|
, "cons" -:: maybeOf a ==> listOf a ==> listOf a
|
|
|
|
, "justs" -:: listOf (maybeOf a) ==> listOf a
|
|
|
|
]
|
|
|
|
|
|
|
|
eithers = prefix "Either"
|
|
|
|
[ "isLeft" -:: eitherOf a b ==> bool
|
|
|
|
, "isRight" -:: eitherOf a b ==> bool
|
|
|
|
, "either" -:: (a ==> c) ==> (b ==> c) ==> eitherOf a b ==> c
|
|
|
|
, "lefts" -:: listOf (eitherOf a b) ==> listOf a
|
|
|
|
, "rights" -:: listOf (eitherOf a b) ==> listOf b
|
|
|
|
, "partition" -:: listOf (eitherOf a b) ==> tupleOf [listOf a,listOf b]
|
2012-08-10 20:16:30 +00:00
|
|
|
]
|
2012-05-12 04:27:59 +00:00
|
|
|
|
2012-10-21 11:50:40 +00:00
|
|
|
dictionary =
|
|
|
|
let dict k v = ADT "Dict" [k,v] in
|
|
|
|
prefix "Dict"
|
|
|
|
[ "empty" -:: dict a b
|
|
|
|
, "singleton" -:: a ==> b ==> dict a b
|
|
|
|
, "insert" -:: a ==> b ==> dict a b ==> dict a b
|
|
|
|
, "remove" -:: a ==> dict a b ==> dict a b
|
|
|
|
, "member" -:: a ==> dict a b ==> bool
|
|
|
|
, "lookup" -:: a ==> dict a b ==> maybeOf b
|
|
|
|
, "findWithDefault" -:: b ==> a ==> dict a b ==> b
|
|
|
|
, "intersect" -:: dict a b ==> dict a c ==> dict a b
|
|
|
|
, "union" -:: dict a b ==> dict a b ==> dict a b
|
|
|
|
, "diff" -:: dict a b ==> dict a c ==> dict a b
|
|
|
|
, "map" -:: (b ==> c) ==> dict a b ==> dict a c
|
|
|
|
, "foldl" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
|
|
|
|
, "foldr" -:: (a ==> b ==> c ==> c) ==> c ==> dict a b ==> c
|
|
|
|
, "keys" -:: dict a b ==> listOf a
|
|
|
|
, "values" -:: dict a b ==> listOf b
|
|
|
|
, "toList" -:: dict a b ==> listOf (tupleOf [a,b])
|
|
|
|
, "fromList" -:: listOf (tupleOf [a,b]) ==> dict a b
|
|
|
|
]
|
|
|
|
|
|
|
|
sets =
|
|
|
|
let set v = ADT "Set" [v] in
|
|
|
|
prefix "Set"
|
|
|
|
[ "empty" -:: set a
|
|
|
|
, "singleton" -:: a ==> set a
|
|
|
|
, "insert" -:: a ==> set a ==> set a
|
|
|
|
, "remove" -:: a ==> set a ==> set a
|
|
|
|
, "member" -:: a ==> set a ==> bool
|
|
|
|
, "intersect" -:: set a ==> set a ==> set a
|
|
|
|
, "union" -:: set a ==> set a ==> set a
|
|
|
|
, "diff" -:: set a ==> set a ==> set a
|
|
|
|
, "map" -:: (a ==> b) ==> set a ==> set b
|
|
|
|
, "foldl" -:: (a ==> b ==> b) ==> b ==> set a ==> b
|
|
|
|
, "foldr" -:: (a ==> b ==> b) ==> b ==> set a ==> b
|
|
|
|
, "toList" -:: set a ==> listOf a
|
|
|
|
, "fromList" -:: listOf a ==> set a
|
|
|
|
]
|
|
|
|
|
|
|
|
automaton =
|
|
|
|
let auto a b = ADT "Automaton" [a,b] in
|
|
|
|
prefix "Automaton"
|
|
|
|
[ "pure" -:: (a ==> b) ==> auto a b
|
|
|
|
, "init" -:: b ==> (a ==> b ==> b) ==> auto a b
|
|
|
|
, "init'" -:: c ==> (a ==> c ==> tupleOf [b,c]) ==> auto a b
|
|
|
|
, ">>>" -:: auto a b ==> auto b c ==> auto a c
|
|
|
|
, "<<<" -:: auto b c ==> auto a b ==> auto a c
|
|
|
|
, "combine" -:: listOf (auto a b) ==> auto a (listOf b)
|
|
|
|
, "run" -:: auto a b ==> signalOf a ==> signalOf b
|
|
|
|
, "step" -:: auto a b ==> a ==> tupleOf [b,auto a b]
|
|
|
|
, "count" -:: auto a int
|
|
|
|
, "draggable" -:: form ==> auto (tupleOf [bool,point]) form
|
|
|
|
]
|
|
|
|
|
2012-05-12 04:27:59 +00:00
|
|
|
-------- Everything --------
|
|
|
|
|
2013-01-14 08:15:14 +00:00
|
|
|
hints = mapM (\(n,s) -> (,) n `liftM` rescheme s) (concat hs)
|
|
|
|
where hs = [ funcs, lists, signals, math, bools, textAttrs
|
|
|
|
, graphicsElement, graphicsColor, eithers, keyboards, touches
|
|
|
|
, concreteSignals, javascript, json, maybeFuncs
|
|
|
|
, http, dictionary, sets, automaton, times, dates
|
|
|
|
]
|