git.iko.soy/Idris-dev
on ef93607 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
760 lines 25 kB history raw
1{-# LANGUAGE PatternGuards #-}
3module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
5import Idris.AbsSyntax hiding (TypeCase)
6import IRTS.Bytecode
7import IRTS.Lang
8import IRTS.Simplified
9import IRTS.CodegenCommon
10import Core.TT
11import Paths_idris
12import Util.System
14import Control.Arrow
15import Data.Char
16import Data.List
17import Data.Maybe
18import System.IO
19import System.Directory
21idrNamespace :: String
22idrNamespace = "__IDR__"
23idrRTNamespace = "__IDRRT__"
24idrLTNamespace = "__IDRLT__"
26data JSTarget = Node | JavaScript deriving Eq
28data JSType = JSIntTy
29 | JSStringTy
30 | JSIntegerTy
31 | JSFloatTy
32 | JSCharTy
33 | JSPtrTy
34 | JSForgotTy
35 deriving Eq
37data JSNum = JSInt Int
38 | JSFloat Double
39 | JSInteger Integer
41data JS = JSRaw String
42 | JSFunction [String] JS
43 | JSType JSType
44 | JSSeq [JS]
45 | JSReturn JS
46 | JSApp JS [JS]
47 | JSNew String [JS]
48 | JSError String
49 | JSOp String JS JS
50 | JSProj JS String
51 | JSVar LVar
52 | JSNull
53 | JSThis
54 | JSTrue
55 | JSArray [JS]
56 | JSObject [(String, JS)]
57 | JSString String
58 | JSNum JSNum
59 | JSAssign JS JS
60 | JSAlloc String (Maybe JS)
61 | JSIndex JS JS
62 | JSCond [(JS, JS)]
63 | JSTernary JS JS JS
65compileJS :: JS -> String
66compileJS (JSRaw code) =
67 code
69compileJS (JSFunction args body) =
70 "function("
71 ++ intercalate "," args
72 ++ "){\n"
73 ++ compileJS body
74 ++ "\n}"
76compileJS (JSType ty)
77 | JSIntTy <- ty = idrRTNamespace ++ "Int"
78 | JSStringTy <- ty = idrRTNamespace ++ "String"
79 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
80 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
81 | JSCharTy <- ty = idrRTNamespace ++ "Char"
82 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
83 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
85compileJS (JSSeq seq) =
86 intercalate ";\n" (map compileJS seq)
88compileJS (JSReturn val) =
89 "return " ++ compileJS val
91compileJS (JSApp lhs rhs)
92 | JSFunction {} <- lhs =
93 concat ["(", compileJS lhs, ")(", args, ")"]
94 | otherwise =
95 concat [compileJS lhs, "(", args, ")"]
96 where args :: String
97 args = intercalate "," $ map compileJS rhs
99compileJS (JSNew name args) =
100 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
102compileJS (JSError exc) =
103 "(function(){throw '" ++ exc ++ "';})()"
105compileJS (JSOp op lhs rhs) =
106 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
108compileJS (JSProj obj field)
109 | JSFunction {} <- obj =
110 concat ["(", compileJS obj, ").", field]
111 | otherwise =
112 compileJS obj ++ '.' : field
114compileJS (JSVar var) =
115 translateVariableName var
117compileJS JSNull =
118 "null"
120compileJS JSThis =
121 "this"
123compileJS JSTrue =
124 "true"
126compileJS (JSArray elems) =
127 "[" ++ intercalate "," (map compileJS elems) ++ "]"
129compileJS (JSObject fields) =
130 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
131 where
132 compileField :: (String, JS) -> String
133 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
135compileJS (JSString str) =
136 show str
138compileJS (JSNum num)
139 | JSInt i <- num = show i
140 | JSFloat f <- num = show f
141 | JSInteger i <- num = show i
143compileJS (JSAssign lhs rhs) =
144 compileJS lhs ++ "=" ++ compileJS rhs
146compileJS (JSAlloc name val) =
147 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
149compileJS (JSIndex lhs rhs) =
150 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
152compileJS (JSCond branches) =
153 intercalate " else " $ map createIfBlock branches
154 where
155 createIfBlock (cond, e) =
156 "if (" ++ compileJS cond ++") {\n"
157 ++ "return " ++ compileJS e
158 ++ ";\n}"
160compileJS (JSTernary cond true false) =
161 let c = compileJS cond
162 t = compileJS true
163 f = compileJS false in
164 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
166jsTailcall :: JS -> JS
167jsTailcall call =
168 jsCall (idrRTNamespace ++ "tailcall") [
169 JSFunction [] (JSReturn call)
170 ]
172jsCall :: String -> [JS] -> JS
173jsCall fun = JSApp (JSRaw fun)
175jsMeth :: JS -> String -> [JS] -> JS
176jsMeth obj meth =
177 JSApp (JSProj obj meth)
179jsInstanceOf :: JS -> JS -> JS
180jsInstanceOf = JSOp "instanceof"
182jsEq :: JS -> JS -> JS
183jsEq = JSOp "=="
185jsAnd :: JS -> JS -> JS
186jsAnd = JSOp "&&"
188jsType :: JS
189jsType = JSRaw $ idrRTNamespace ++ "Type"
191jsCon :: JS
192jsCon = JSRaw $ idrRTNamespace ++ "Con"
194jsTag :: JS -> JS
195jsTag obj = JSProj obj "tag"
197jsTypeTag :: JS -> JS
198jsTypeTag obj = JSProj obj "type"
200jsBigInt :: JS -> JS
201jsBigInt val =
202 JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
204jsVar :: Int -> String
205jsVar = ("__var_" ++) . show
207jsLet :: String -> JS -> JS -> JS
208jsLet name value body =
209 JSApp (
210 JSFunction [name] (
211 JSReturn body
212 )
213 ) [value]
215codegenJavaScript
216 :: JSTarget
217 -> [(Name, SDecl)]
218 -> FilePath
219 -> OutputType
220 -> IO ()
221codegenJavaScript target definitions filename outputType = do
222 let (header, runtime) = case target of
223 Node ->
224 ("#!/usr/bin/env node\n", "-node")
225 JavaScript ->
226 ("", "-browser")
227 path <- getDataDir
228 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
229 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
230 writeFile filename $ intercalate "\n" $ [ header
231 , idrRuntime
232 , tgtRuntime
233 ] ++ functions ++ [mainLoop]
235 setPermissions filename (emptyPermissions { readable = True
236 , executable = target == Node
237 , writable = True
238 })
239 where
240 def :: [(String, SDecl)]
241 def = map (first translateNamespace) definitions
243 functions :: [String]
244 functions = map (compileJS . translateDeclaration) def
246 mainLoop :: String
247 mainLoop = compileJS $
248 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
249 jsTailcall $ jsCall "__IDR__runMain0" []
250 )
251 , jsCall "main" []
252 ]
254translateIdentifier :: String -> String
255translateIdentifier =
256 replaceReserved . concatMap replaceBadChars
257 where replaceBadChars :: Char -> String
258 replaceBadChars c
259 | ' ' <- c = "_"
260 | '_' <- c = "__"
261 | isDigit c = "_" ++ [c] ++ "_"
262 | not (isLetter c && isAscii c) = '_' : show (ord c)
263 | otherwise = [c]
264 replaceReserved s
265 | s `elem` reserved = '_' : s
266 | otherwise = s
267 reserved = [ "break"
268 , "case"
269 , "catch"
270 , "continue"
271 , "debugger"
272 , "default"
273 , "delete"
274 , "do"
275 , "else"
276 , "finally"
277 , "for"
278 , "function"
279 , "if"
280 , "in"
281 , "instanceof"
282 , "new"
283 , "return"
284 , "switch"
285 , "this"
286 , "throw"
287 , "try"
288 , "typeof"
289 , "var"
290 , "void"
291 , "while"
292 , "with"
294 , "class"
295 , "enum"
296 , "export"
297 , "extends"
298 , "import"
299 , "super"
301 , "implements"
302 , "interface"
303 , "let"
304 , "package"
305 , "private"
306 , "protected"
307 , "public"
308 , "static"
309 , "yield"
310 ]
312translateNamespace :: Name -> String
313translateNamespace (UN _) = idrNamespace
314translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
315translateNamespace (MN _ _) = idrNamespace
317translateName :: Name -> String
318translateName (UN name) = translateIdentifier name
319translateName (NS name _) = translateName name
320translateName (MN i name) = translateIdentifier name ++ show i
322translateConstant :: Const -> JS
323translateConstant (I i) = JSNum (JSInt i)
324translateConstant (Fl f) = JSNum (JSFloat f)
325translateConstant (Ch c) = JSString [c]
326translateConstant (Str s) = JSString s
327translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
328translateConstant StrType = JSType JSStringTy
329translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
330translateConstant (AType ATFloat) = JSType JSFloatTy
331translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
332translateConstant PtrType = JSType JSPtrTy
333translateConstant Forgot = JSType JSForgotTy
334translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
335translateConstant c =
336 JSError $ "Unimplemented Constant: " ++ show c
338translateDeclaration :: (String, SDecl) -> JS
339translateDeclaration (path, SFun name params stackSize body)
340 | (MN _ "APPLY") <- name
341 , (SLet var val next) <- body
342 , (SChkCase cvar cases) <- next =
343 let lvar = translateVariableName var
344 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
345 JSSeq [ lookupTable [(var, "chk")] var cases
346 , jsDecl $ JSFunction ["fn0", "arg0"] (
347 JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
348 , JSReturn $ jsLet (translateVariableName var) (
349 translateExpression val
350 ) (JSTernary (
351 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
352 (hasProp lookupTableName (translateVariableName var))
353 ) (JSRaw $
354 lookupTableName ++ lookup
355 ) JSNull
356 )
357 ]
358 )
359 ]
361 | (MN _ "EVAL") <- name
362 , (SChkCase var cases) <- body =
363 JSSeq [ lookupTable [] var cases
364 , jsDecl $ JSFunction ["arg0"] (JSReturn $
365 JSTernary (
366 (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
367 (hasProp lookupTableName "arg0")
368 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
369 )
370 ]
371 | otherwise =
372 let fun = translateExpression body in
373 jsDecl $ jsFun fun
375 where
376 hasProp :: String -> String -> JS
377 hasProp table var =
378 jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]
380 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
381 caseFun aux var cse =
382 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
384 getTag :: SAlt -> Maybe String
385 getTag (SConCase _ tag _ _ _) = Just $ show tag
386 getTag _ = Nothing
388 lookupTableName :: String
389 lookupTableName = idrLTNamespace ++ translateName name
391 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
392 lookupTable aux var cases =
393 JSAlloc lookupTableName $ Just (
394 JSObject $ catMaybes $ map (lookupEntry aux var) cases
395 )
396 where
397 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
398 lookupEntry aux var alt = do
399 tag <- getTag alt
400 return (tag, caseFun aux var alt)
402 jsDecl :: JS -> JS
403 jsDecl = JSAlloc (path ++ translateName name) . Just
405 jsFun body = jsFunAux [] body
407 jsFunAux :: [(LVar, String)] -> JS -> JS
408 jsFunAux aux body =
409 JSFunction (p ++ map snd aux) (
410 JSSeq $
411 zipWith assignVar [0..] p ++
412 map allocVar [numP .. (numP + stackSize - 1)] ++
413 map assignAux aux ++
414 [JSReturn body]
415 )
416 where
417 numP :: Int
418 numP = length params
420 allocVar :: Int -> JS
421 allocVar n = JSAlloc (jsVar n) Nothing
423 assignVar :: Int -> String -> JS
424 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
426 assignAux :: (LVar, String) -> JS
427 assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
429 p :: [String]
430 p = map translateName params
432translateVariableName :: LVar -> String
433translateVariableName (Loc i) =
434 jsVar i
436translateExpression :: SExp -> JS
437translateExpression (SLet name value body) =
438 jsLet (translateVariableName name) (
439 translateExpression value
440 ) (translateExpression body)
442translateExpression (SConst cst) =
443 translateConstant cst
445translateExpression (SV var) =
446 JSVar var
448translateExpression (SApp tc name vars)
449 | False <- tc =
450 jsTailcall $ translateFunctionCall name vars
451 | True <- tc =
452 JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (
453 JSReturn $ translateFunctionCall name vars
454 )]
455 where
456 translateFunctionCall name vars =
457 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
459translateExpression (SOp op vars)
460 | LNoOp <- op = JSVar (last vars)
462 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
463 | (LPlus (ATInt ITBig)) <- op
464 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
465 | (LMinus (ATInt ITBig)) <- op
466 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
467 | (LTimes (ATInt ITBig)) <- op
468 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
469 | (LSDiv (ATInt ITBig)) <- op
470 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
471 | (LSRem (ATInt ITBig)) <- op
472 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
473 | (LEq (ATInt ITBig)) <- op
474 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
475 | (LSLt (ATInt ITBig)) <- op
476 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
477 | (LSLe (ATInt ITBig)) <- op
478 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
479 | (LSGt (ATInt ITBig)) <- op
480 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
481 | (LSGe (ATInt ITBig)) <- op
482 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
484 | (LPlus ATFloat) <- op
485 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
486 | (LMinus ATFloat) <- op
487 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
488 | (LTimes ATFloat) <- op
489 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
490 | (LSDiv ATFloat) <- op
491 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
492 | (LEq ATFloat) <- op
493 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
494 | (LSLt ATFloat) <- op
495 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
496 | (LSLe ATFloat) <- op
497 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
498 | (LSGt ATFloat) <- op
499 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
500 | (LSGe ATFloat) <- op
501 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
503 | (LPlus _) <- op
504 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
505 | (LMinus _) <- op
506 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
507 | (LTimes _) <- op
508 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
509 | (LSDiv _) <- op
510 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
511 | (LSRem _) <- op
512 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
513 | (LEq _) <- op
514 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
515 | (LSLt _) <- op
516 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
517 | (LSLe _) <- op
518 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
519 | (LSGt _) <- op
520 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
521 | (LSGe _) <- op
522 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
523 | (LAnd _) <- op
524 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
525 | (LOr _) <- op
526 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
527 | (LXOr _) <- op
528 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
529 | (LSHL _) <- op
530 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
531 | (LASHR _) <- op
532 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
533 | (LCompl _) <- op
534 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
536 | LStrConcat <- op
537 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
538 | LStrEq <- op
539 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
540 | LStrLt <- op
541 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
542 | LStrLen <- op
543 , (arg:_) <- vars = JSProj (JSVar arg) "length"
545 | (LStrInt ITNative) <- op
546 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
547 | (LIntStr ITNative) <- op
548 , (arg:_) <- vars = jsCall "String" [JSVar arg]
549 | (LSExt ITNative ITBig) <- op
550 , (arg:_) <- vars = jsBigInt $ JSVar arg
551 | (LTrunc ITBig ITNative) <- op
552 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
553 | (LIntStr ITBig) <- op
554 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
555 | (LStrInt ITBig) <- op
556 , (arg:_) <- vars = jsBigInt $ JSVar arg
557 | LFloatStr <- op
558 , (arg:_) <- vars = jsCall "String" [JSVar arg]
559 | LStrFloat <- op
560 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
561 | (LIntFloat ITNative) <- op
562 , (arg:_) <- vars = JSVar arg
563 | (LFloatInt ITNative) <- op
564 , (arg:_) <- vars = JSVar arg
565 | (LChInt ITNative) <- op
566 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
567 | (LIntCh ITNative) <- op
568 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
570 | LFExp <- op
571 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
572 | LFLog <- op
573 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
574 | LFSin <- op
575 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
576 | LFCos <- op
577 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
578 | LFTan <- op
579 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
580 | LFASin <- op
581 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
582 | LFACos <- op
583 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
584 | LFATan <- op
585 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
586 | LFSqrt <- op
587 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
588 | LFFloor <- op
589 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
590 | LFCeil <- op
591 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
593 | LStrCons <- op
594 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
595 | LStrHead <- op
596 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
597 | LStrRev <- op
598 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
599 | LStrIndex <- op
600 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
601 | LStrTail <- op
602 , (arg:_) <- vars = let v = translateVariableName arg in
603 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
604 where
605 translateBinaryOp :: String -> LVar -> LVar -> JS
606 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
608 invokeMeth :: LVar -> String -> [LVar] -> JS
609 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
611translateExpression (SError msg) =
612 JSError msg
614translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
615 jsCall (idrRTNamespace ++ "print") [JSVar var]
617translateExpression (SForeign _ _ fun args)
618 | "[]=" `isSuffixOf` fun
619 , (obj:idx:val:[]) <- args =
620 JSRaw $ concat [object obj, index idx, assign val]
622 | "[]" `isSuffixOf` fun
623 , (obj:idx:[]) <- args =
624 JSRaw $ object obj ++ index idx
626 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
627 , (obj:val:[]) <- args =
628 JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
630 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
631 , (obj:[]) <- args =
632 JSRaw $ object obj ++ '[' : name ++ "]"
634 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
635 , (obj:val:[]) <- args =
636 JSRaw $ concat [object obj, field, assign val]
638 | "." `isPrefixOf` fun
639 , (obj:[]) <- args =
640 JSRaw $ object obj ++ field
642 | "." `isPrefixOf` fun
643 , (obj:[(FUnit, _)]) <- args =
644 JSRaw $ concat [object obj, method, "()"]
646 | "." `isPrefixOf` fun
647 , (obj:as) <- args =
648 JSRaw $ concat [object obj, method, arguments as]
650 | "[]=" `isSuffixOf` fun
651 , (idx:val:[]) <- args =
652 JSRaw $ concat [array, index idx, assign val]
654 | "[]" `isSuffixOf` fun
655 , (idx:[]) <- args =
656 JSRaw $ array ++ index idx
658 | otherwise = JSRaw $ fun ++ arguments args
659 where
660 name = filter (`notElem` "[]=") fun
661 method = name
662 field = name
663 array = name
664 object o = translateVariableName (snd o)
665 index i = "[" ++ translateVariableName (snd i) ++ "]"
666 assign v = '=' : generateWrapper v
667 arguments as =
668 '(' : intercalate "," (map generateWrapper as) ++ ")"
670 generateWrapper (ffunc, name)
671 | FFunction <- ffunc =
672 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
673 | FFunctionIO <- ffunc =
674 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
676 generateWrapper (_, name) =
677 translateVariableName name
679translateExpression patterncase
680 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
681 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
682 where
683 caseHelper var cases param =
684 JSApp (JSFunction [param] (
685 JSCond $ map (expandCase param . translateCaseCond param) cases
686 )) [JSVar var]
688 expandCase :: String -> (Cond, JS) -> (JS, JS)
689 expandCase _ (RawCond cond, branch) = (cond, branch)
690 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
691 expandCase var (CaseCond caseTy, branch)
692 | ConCase tag <- caseTy =
693 let checkCon = JSRaw var `jsInstanceOf` jsCon
694 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
695 (checkCon `jsAnd` checkTag, branch)
697 | TypeCase ty <- caseTy =
698 let checkTy = JSRaw var `jsInstanceOf` jsType
699 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
700 (checkTy `jsAnd` checkTag, branch)
702translateExpression (SCon i name vars) =
703 JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
704 , JSArray $ map JSVar vars
705 ]
707translateExpression (SUpdate var e) =
708 JSAssign (JSVar var) (translateExpression e)
710translateExpression (SProj var i) =
711 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
713translateExpression SNothing = JSNull
715translateExpression e =
716 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
718data CaseType = ConCase Int
719 | TypeCase JSType
720 | DefaultCase
721 deriving Eq
723data Cond = CaseCond CaseType
724 | RawCond JS
726translateCaseCond :: String -> SAlt -> (Cond, JS)
727translateCaseCond _ cse@(SDefaultCase _) =
728 (CaseCond DefaultCase, translateCase Nothing cse)
730translateCaseCond var cse@(SConstCase ty _)
731 | StrType <- ty = matchHelper JSStringTy
732 | PtrType <- ty = matchHelper JSPtrTy
733 | Forgot <- ty = matchHelper JSForgotTy
734 | (AType ATFloat) <- ty = matchHelper JSFloatTy
735 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
736 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
737 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
738 where
739 matchHelper :: JSType -> (Cond, JS)
740 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
742translateCaseCond var cse@(SConstCase cst@(BI _) _) =
743 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
744 (RawCond cond, translateCase Nothing cse)
746translateCaseCond var cse@(SConstCase cst _) =
747 let cond = JSRaw var `jsEq` translateConstant cst in
748 (RawCond cond, translateCase Nothing cse)
750translateCaseCond var cse@(SConCase _ tag _ _ _) =
751 (CaseCond $ ConCase tag, translateCase (Just var) cse)
753translateCase :: Maybe String -> SAlt -> JS
754translateCase _ (SDefaultCase e) = translateExpression e
755translateCase _ (SConstCase _ e) = translateExpression e
756translateCase (Just var) (SConCase a _ _ vars e) =
757 let params = map jsVar [a .. (a + length vars)] in
758 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
759 JSThis, JSProj (JSRaw var) "vars"
760 ]