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