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