git.iko.soy/Idris-dev
on master help sign in
Idris-dev/src/IRTS/JavaScript/PrimOp.hs
246 lines 15 kB history raw
1{-|
2Module : IRTS.JavaScript.PrimOp
3Description : The JavaScript primitive operations.
5License : BSD3
6Maintainer : The Idris Community.
7-}
9{-# LANGUAGE OverloadedStrings, PatternGuards, StandaloneDeriving #-}
11module IRTS.JavaScript.PrimOp
12 ( PrimF
13 , PrimDec
14 , JsPrimTy(..)
15 , primDB
16 , jsPrimCoerce
17 ) where
19import qualified Data.Map.Strict as Map
20import Idris.Core.TT
21import IRTS.JavaScript.AST
22import IRTS.Lang
24data JsPrimTy = PTBool | PTAny deriving (Eq, Ord)
26type PrimF = [JsExpr] -> JsExpr
27type PrimDec = (Bool, JsPrimTy, PrimF) -- the bool indicates if bigint library is used or not
29primDB :: Map.Map PrimFn PrimDec
30primDB =
31 Map.fromList [
32 item (LPlus ATFloat) False PTAny $ binop "+"
33 , item (LPlus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) + %1.charCodeAt(0))"
34 , item (LPlus (ATInt ITNative)) False PTAny $ binop "+"
35 , item (LPlus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 + %1 & 0xFF"
36 , item (LPlus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 + %1 & 0xFFFF"
37 , item (LPlus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0+%1|0"
38 , item (LPlus (ATInt ITBig)) True PTAny $ method "add"
39 , item (LPlus (ATInt (ITFixed IT64))) True PTAny $
40 \[l, r] -> JsForeign "%0.add(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
41 , item (LMinus ATFloat) False PTAny $ binop "-"
42 , item (LMinus (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) - %1.charCodeAt(0))"
43 , item (LMinus (ATInt ITNative)) False PTAny $ binop "-"
44 , item (LMinus (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 - %1 & 0xFF"
45 , item (LMinus (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 - %1 & 0xFFFF"
46 , item (LMinus (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0-%1|0"
47 , item (LMinus (ATInt ITBig)) True PTAny $ method "subtract"
48 , item (LMinus (ATInt (ITFixed IT64))) True PTAny $
49 \[l, r] -> JsForeign "%0.subtract(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
50 , item (LTimes ATFloat) False PTAny $ binop "*"
51 , item (LTimes (ATInt ITChar)) False PTAny $ JsForeign "String.fromCharCode(%0.charCodeAt(0) * %1.charCodeAt(0))"
52 , item (LTimes (ATInt ITNative)) False PTAny $ binop "*"
53 , item (LTimes (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 * %1 & 0xFF"
54 , item (LTimes (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 * %1 & 0xFFFF"
55 , item (LTimes (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0*%1|0"
56 , item (LTimes (ATInt ITBig)) True PTAny $ method "multiply"
57 , item (LTimes (ATInt (ITFixed IT64))) True PTAny $
58 \[l, r] -> JsForeign "%0.multiply(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
59 , item (LUDiv (ITFixed IT8)) False PTAny $ JsForeign "%0 / %1"
60 , item (LUDiv (ITFixed IT16)) False PTAny $ JsForeign "%0 / %1"
61 , item (LUDiv (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) / (%1>>>0) |0"
62 , item (LUDiv (ITFixed IT64)) True PTAny $ JsForeign "%0.divide(%1)"
63 , item (LSDiv ATFloat) False PTAny $ binop "/"
64 , item (LSDiv (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 / %1"
65 , item (LSDiv (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 / %1"
66 , item (LSDiv (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 / %1 |0"
67 , item (LSDiv (ATInt (ITFixed IT64))) True PTAny $ JsForeign "%0.divide(%1)"
68 , item (LSDiv (ATInt ITNative)) False PTAny $ JsForeign "%0/%1|0" -- we need "|0" in this
69 , item (LSDiv (ATInt ITBig)) True PTAny $ method "divide"
70 , item (LURem (ITFixed IT8)) False PTAny $ JsForeign "%0 % %1"
71 , item (LURem (ITFixed IT16)) False PTAny $ JsForeign "%0 % %1"
72 , item (LURem (ITFixed IT32)) False PTAny $ JsForeign "(%0>>>0) % (%1>>>0) |0"
73 , item (LURem (ITFixed IT64)) True PTAny $ method "remainder"
74 , item (LSRem ATFloat) False PTAny $ binop "%"
75 , item (LSRem (ATInt ITNative)) False PTAny $ binop "%"
76 , item (LSRem (ATInt (ITFixed IT8))) False PTAny $ JsForeign "%0 % %1"
77 , item (LSRem (ATInt (ITFixed IT16))) False PTAny $ JsForeign "%0 % %1"
78 , item (LSRem (ATInt (ITFixed IT32))) False PTAny $ JsForeign "%0 % %1 |0"
79 , item (LSRem (ATInt (ITFixed IT64))) True PTAny $ method "remainder"
80 , item (LSRem (ATInt ITBig)) True PTAny $ method "remainder"
81 , item (LAnd ITNative) False PTAny $ JsForeign "%0 & %1"
82 , item (LAnd (ITFixed IT8)) False PTAny $ JsForeign "%0 & %1"
83 , item (LAnd (ITFixed IT16)) False PTAny $ JsForeign "%0 & %1"
84 , item (LAnd (ITFixed IT32)) False PTAny $ JsForeign "%0 & %1"
85 , item (LAnd (ITFixed IT64)) True PTAny $ method "and"
86 , item (LAnd ITBig) True PTAny $ method "and"
87 , item (LOr ITNative) False PTAny $ JsForeign "%0 | %1"
88 , item (LOr (ITFixed IT8)) False PTAny $ JsForeign "%0 | %1"
89 , item (LOr (ITFixed IT16)) False PTAny $ JsForeign "%0 | %1"
90 , item (LOr (ITFixed IT32)) False PTAny $ JsForeign "%0 | %1"
91 , item (LOr (ITFixed IT64)) True PTAny $ method "or"
92 , item (LOr ITBig) True PTAny $ method "or"
93 , item (LXOr ITNative) False PTAny $ JsForeign "%0 ^ %1"
94 , item (LXOr (ITFixed IT8)) False PTAny $ JsForeign "%0 ^ %1"
95 , item (LXOr (ITFixed IT16)) False PTAny $ JsForeign "%0 ^ %1"
96 , item (LXOr (ITFixed IT32)) False PTAny $ JsForeign "%0 ^ %1"
97 , item (LXOr (ITFixed IT64)) True PTAny $ method "xor"
98 , item (LXOr ITBig) True PTAny $ method "xor"
99 , item (LSHL ITNative) False PTAny $ JsForeign "%0 << %1 |0"
100 , item (LSHL (ITFixed IT8)) False PTAny $ JsForeign "%0 << %1 & 0xFF"
101 , item (LSHL (ITFixed IT16)) False PTAny $ JsForeign "%0 << %1 & 0xFFFF"
102 , item (LSHL (ITFixed IT32)) False PTAny $ JsForeign "%0 << %1 | 0"
103 , item (LSHL (ITFixed IT64)) True PTAny $
104 \[l, r] -> JsForeign "%0.shiftLeft(%1).and(new $JSRTS.jsbn.BigInteger(%2))" [l,r, JsStr $ show 0xFFFFFFFFFFFFFFFF]
105 , item (LSHL ITBig) True PTAny $ method "shiftLeft"
106 , item (LLSHR ITNative) False PTAny $ JsForeign "%0 >>> %1 |0"
107 , item (LLSHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >>> %1"
108 , item (LLSHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >>> %1"
109 , item (LLSHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >>> %1|0"
110 , item (LLSHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"
111 , item (LASHR ITNative) False PTAny $ JsForeign "%0 >> %1 |0"
112 , item (LASHR (ITFixed IT8)) False PTAny $ JsForeign "%0 >> %1"
113 , item (LASHR (ITFixed IT16)) False PTAny $ JsForeign "%0 >> %1"
114 , item (LASHR (ITFixed IT32)) False PTAny $ JsForeign "%0 >> %1|0"
115 , item (LASHR (ITFixed IT64)) True PTAny $ JsForeign "%0.shiftRight(%1)"
116 , item (LCompl (ITFixed IT8)) False PTAny $ JsForeign "~%0"
117 , item (LCompl (ITFixed IT16)) False PTAny $ JsForeign "~%0"
118 , item (LCompl (ITFixed IT32)) False PTAny $ JsForeign "~%0|0"
119 , item (LCompl (ITFixed IT64)) True PTAny $ method "not"
120 , item (LEq ATFloat) False PTBool $ binop "==="
121 , item (LEq (ATInt ITNative)) False PTBool $ binop "==="
122 , item (LEq (ATInt ITChar)) False PTBool $ binop "==="
123 , item (LEq (ATInt ITBig)) True PTBool $ method "equals"
124 , item (LEq (ATInt (ITFixed IT8))) False PTBool $ binop "==="
125 , item (LEq (ATInt (ITFixed IT16))) False PTBool $ binop "==="
126 , item (LEq (ATInt (ITFixed IT32))) False PTBool $ binop "==="
127 , item (LEq (ATInt (ITFixed IT64))) True PTBool $ method "equals"
128 , item (LLt (ITFixed IT8)) False PTBool $ JsForeign "%0 < %1"
129 , item (LLt (ITFixed IT16)) False PTBool $ JsForeign "%0 < %1"
130 , item (LLt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) < (%1>>>0)"
131 , item (LLt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
132 , item (LLe (ITFixed IT8)) False PTBool $ JsForeign "%0 <= %1"
133 , item (LLe (ITFixed IT16)) False PTBool $ JsForeign "%0 <= %1"
134 , item (LLe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) <= (%1>>>0)"
135 , item (LLe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
136 , item (LGt (ITFixed IT8)) False PTBool $ JsForeign "%0 > %1"
137 , item (LGt (ITFixed IT16)) False PTBool $ JsForeign "%0 > %1"
138 , item (LGt (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) > (%1>>>0)"
139 , item (LGt (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
140 , item (LGe (ITFixed IT8)) False PTBool $ JsForeign "%0 >= %1"
141 , item (LGe (ITFixed IT16)) False PTBool $ JsForeign "%0 >= %1"
142 , item (LGe (ITFixed IT32)) False PTBool $ JsForeign "(%0>>>0) >= (%1>>>0)"
143 , item (LGe (ITFixed IT64)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
144 , item (LSLt ATFloat) False PTBool $ binop "<"
145 , item (LSLt (ATInt ITChar)) False PTBool $ binop "<"
146 , item (LSLt (ATInt ITNative)) False PTBool $ binop "<"
147 , item (LSLt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
148 , item (LSLt (ATInt (ITFixed IT8))) False PTBool $ binop "<"
149 , item (LSLt (ATInt (ITFixed IT16))) False PTBool $ binop "<"
150 , item (LSLt (ATInt (ITFixed IT32))) False PTBool $ binop "<"
151 , item (LSLt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) < 0"
152 , item (LSLe ATFloat) False PTBool $ binop "<="
153 , item (LSLe (ATInt ITNative)) False PTBool $ binop "<="
154 , item (LSLe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
155 , item (LSLe (ATInt (ITFixed IT8))) False PTBool $ binop "<="
156 , item (LSLe (ATInt (ITFixed IT16))) False PTBool $ binop "<="
157 , item (LSLe (ATInt (ITFixed IT32))) False PTBool $ binop "<="
158 , item (LSLe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) <= 0"
159 , item (LSGt ATFloat) False PTBool $ binop ">"
160 , item (LSGt (ATInt ITNative)) False PTBool $ binop ">"
161 , item (LSGt (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
162 , item (LSGt (ATInt (ITFixed IT8))) False PTBool $ binop ">"
163 , item (LSGt (ATInt (ITFixed IT16))) False PTBool $ binop ">"
164 , item (LSGt (ATInt (ITFixed IT32))) False PTBool $ binop ">"
165 , item (LSGt (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) > 0"
166 , item (LSGe ATFloat) False PTBool $ binop ">="
167 , item (LSGe (ATInt ITNative)) False PTBool $ binop ">="
168 , item (LSGe (ATInt ITBig)) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
169 , item (LSGe (ATInt (ITFixed IT8))) False PTBool $ binop ">="
170 , item (LSGe (ATInt (ITFixed IT16))) False PTBool $ binop ">="
171 , item (LSGe (ATInt (ITFixed IT32))) False PTBool $ binop ">="
172 , item (LSGe (ATInt (ITFixed IT64))) True PTBool $ JsForeign "%0.compareTo(%1) >= 0"
173 , item (LSExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
174 , item (LZExt (ITFixed IT8) ITNative) False PTAny $ head
175 , item (LZExt (ITFixed IT16) ITNative) False PTAny $ head
176 , item (LZExt (ITFixed IT32) ITNative) False PTAny $ head
177 , item (LZExt ITNative ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
178 , item (LZExt (ITFixed IT8) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
179 , item (LZExt (ITFixed IT16) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
180 , item (LZExt (ITFixed IT32) ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(''+%0)"
181 , item (LZExt (ITFixed IT64) ITBig) True PTAny $ head
182 , item (LTrunc ITBig ITNative) True PTAny $ JsForeign "%0.intValue()|0"
183 , item (LTrunc ITBig (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"
184 , item (LTrunc ITBig (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"
185 , item (LTrunc ITBig (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"
186 , item (LTrunc ITBig (ITFixed IT64)) True PTAny $
187 \[x] -> JsForeign "%0.and(new $JSRTS.jsbn.BigInteger(%1))" [x, JsStr $ show 0xFFFFFFFFFFFFFFFF]
188 , item (LTrunc (ITFixed IT16) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
189 , item (LTrunc (ITFixed IT32) (ITFixed IT8)) False PTAny $ JsForeign "%0 & 0xFF"
190 , item (LTrunc (ITFixed IT64) (ITFixed IT8)) True PTAny $ JsForeign "%0.intValue() & 0xFF"
191 , item (LTrunc (ITFixed IT32) (ITFixed IT16)) False PTAny $ JsForeign "%0 & 0xFFFF"
192 , item (LTrunc (ITFixed IT64) (ITFixed IT16)) True PTAny $ JsForeign "%0.intValue() & 0xFFFF"
193 , item (LTrunc (ITFixed IT64) (ITFixed IT32)) True PTAny $ JsForeign "%0.intValue() & 0xFFFFFFFF"
194 , item LStrConcat False PTAny $ binop "+"
195 , item LStrLt False PTBool $ binop "<"
196 , item LStrEq False PTBool $ binop "=="
197 , item LStrLen False PTAny $ JsForeign "%0.length"
198 , item (LIntFloat ITNative) False PTAny $ head
199 , item (LIntFloat ITBig) True PTAny $ JsForeign "%0.intValue()"
200 , item (LFloatInt ITNative) False PTAny $ JsForeign "%0|0"
201 , item (LFloatInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(Math.trunc(%0)+ '')"
202 , item (LIntStr ITNative) False PTAny $ JsForeign "''+%0"
203 , item (LIntStr ITBig) True PTAny $ JsForeign "%0.toString()"
204 , item (LStrInt ITNative) False PTAny $ JsForeign "parseInt(%0)|0"
205 , item (LStrInt ITBig) True PTAny $ JsForeign "new $JSRTS.jsbn.BigInteger(%0)"
206 , item (LFloatStr) False PTAny $ JsForeign "''+%0"
207 , item (LStrFloat) False PTAny $ jsAppN "parseFloat"
208 , item (LChInt ITNative) False PTAny $ JsForeign "%0.charCodeAt(0)|0"
209 , item (LIntCh ITNative) False PTAny $ jsAppN "String.fromCharCode"
210 , item LFExp False PTAny $ jsAppN "Math.exp"
211 , item LFLog False PTAny $ jsAppN "Math.log"
212 , item LFSin False PTAny $ jsAppN "Math.sin"
213 , item LFCos False PTAny $ jsAppN "Math.cos"
214 , item LFTan False PTAny $ jsAppN "Math.tan"
215 , item LFASin False PTAny $ jsAppN "Math.asin"
216 , item LFACos False PTAny $ jsAppN "Math.acos"
217 , item LFATan False PTAny $ jsAppN "Math.atan"
218 , item LFATan2 False PTAny $ jsAppN "Math.atan2"
219 , item LFSqrt False PTAny $ jsAppN "Math.sqrt"
220 , item LFFloor False PTAny $ jsAppN "Math.floor"
221 , item LFCeil False PTAny $ jsAppN "Math.ceil"
222 , item LFNegate False PTAny $ JsForeign "-%0"
223 , item LStrHead False PTAny $ \[x] -> JsArrayProj (JsInt 0) x
224 , item LStrTail False PTAny $ \[x] -> JsMethod x "slice" [JsInt 1]
225 , item LStrCons False PTAny $ JsForeign "%0+%1"
226 , item LStrIndex False PTAny $ \[x, y] -> JsArrayProj y x
227 , item LStrRev False PTAny $ JsForeign "%0.split('').reverse().join('')"
228 , item LStrSubstr False PTAny $ JsForeign "$JSRTS.prim_strSubstr(%0, %1, %2)"
229 , item LSystemInfo False PTAny $ JsApp (JsProp (JsVar "$JSRTS") "prim_systemInfo")
230 , item LCrash False PTAny $ \[l] -> JsErrorExp l
231 , item LReadStr False PTAny $ \[_] -> JsApp (JsProp (JsVar "$JSRTS") "prim_readStr") []
232 , item LWriteStr False PTAny $ \[_, str] -> JsApp (JsProp (JsVar "$JSRTS") "prim_writeStr") [str]
233 , item LNoOp False PTAny $ head
234 ]
235 where
236 item :: PrimFn -> Bool -> JsPrimTy -> PrimF -> (PrimFn, PrimDec)
237 item fn ubi pty c = (fn, (ubi, pty, c))
238 binop op [l, r] = JsBinOp op l r
239 method op (l:r) = JsMethod l op r
241jsB2I :: JsExpr -> JsExpr
242jsB2I x = JsForeign "%0 ? 1|0 : 0|0" [x]
244jsPrimCoerce :: JsPrimTy -> JsPrimTy -> JsExpr -> JsExpr
245jsPrimCoerce PTBool PTAny x = jsB2I x
246jsPrimCoerce _ _ x = x