git.iko.soy/Idris-dev
on 7ca1ca0 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
903 lines 29 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
40 deriving Eq
42data JS = JSRaw String
43 | JSFunction [String] JS
44 | JSType JSType
45 | JSSeq [JS]
46 | JSReturn JS
47 | JSApp JS [JS]
48 | JSNew String [JS]
49 | JSError String
50 | JSOp String JS JS
51 | JSProj JS String
52 | JSVar LVar
53 | JSNull
54 | JSThis
55 | JSTrue
56 | JSFalse
57 | JSArray [JS]
58 | JSObject [(String, JS)]
59 | JSString String
60 | JSNum JSNum
61 | JSAssign JS JS
62 | JSAlloc String (Maybe JS)
63 | JSIndex JS JS
64 | JSCond [(JS, JS)]
65 | JSTernary JS JS JS
66 deriving Eq
68compileJS :: JS -> String
69compileJS (JSRaw code) =
70 code
72compileJS (JSFunction args body) =
73 "function("
74 ++ intercalate "," args
75 ++ "){\n"
76 ++ compileJS body
77 ++ "\n}"
79compileJS (JSType ty)
80 | JSIntTy <- ty = idrRTNamespace ++ "Int"
81 | JSStringTy <- ty = idrRTNamespace ++ "String"
82 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
83 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
84 | JSCharTy <- ty = idrRTNamespace ++ "Char"
85 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
86 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
88compileJS (JSSeq seq) =
89 intercalate ";\n" (map compileJS seq)
91compileJS (JSReturn val) =
92 "return " ++ compileJS val
94compileJS (JSApp lhs rhs)
95 | JSFunction {} <- lhs =
96 concat ["(", compileJS lhs, ")(", args, ")"]
97 | otherwise =
98 concat [compileJS lhs, "(", args, ")"]
99 where args :: String
100 args = intercalate "," $ map compileJS rhs
102compileJS (JSNew name args) =
103 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
105compileJS (JSError exc) =
106 "(function(){throw '" ++ exc ++ "';})()"
108compileJS (JSOp op lhs rhs) =
109 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
111compileJS (JSProj obj field)
112 | JSFunction {} <- obj =
113 concat ["(", compileJS obj, ").", field]
114 | JSAssign {} <- obj =
115 concat ["(", compileJS obj, ").", field]
116 | otherwise =
117 compileJS obj ++ '.' : field
119compileJS (JSVar var) =
120 translateVariableName var
122compileJS JSNull =
123 "null"
125compileJS JSThis =
126 "this"
128compileJS JSTrue =
129 "true"
131compileJS JSFalse =
132 "false"
134compileJS (JSArray elems) =
135 "[" ++ intercalate "," (map compileJS elems) ++ "]"
137compileJS (JSObject fields) =
138 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
139 where
140 compileField :: (String, JS) -> String
141 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
143compileJS (JSString str) =
144 show str
146compileJS (JSNum num)
147 | JSInt i <- num = show i
148 | JSFloat f <- num = show f
149 | JSInteger i <- num = show i
151compileJS (JSAssign lhs rhs) =
152 compileJS lhs ++ "=" ++ compileJS rhs
154compileJS (JSAlloc name val) =
155 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
157compileJS (JSIndex lhs rhs) =
158 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
160compileJS (JSCond branches) =
161 intercalate " else " $ map createIfBlock branches
162 where
163 createIfBlock (cond, e) =
164 "if (" ++ compileJS cond ++") {\n"
165 ++ "return " ++ compileJS e
166 ++ ";\n}"
168compileJS (JSTernary cond true false) =
169 let c = compileJS cond
170 t = compileJS true
171 f = compileJS false in
172 "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
174jsTailcall :: JS -> JS
175jsTailcall call =
176 jsCall (idrRTNamespace ++ "tailcall") [
177 JSFunction [] (JSReturn call)
178 ]
180jsCall :: String -> [JS] -> JS
181jsCall fun = JSApp (JSRaw fun)
183jsMeth :: JS -> String -> [JS] -> JS
184jsMeth obj meth =
185 JSApp (JSProj obj meth)
187jsInstanceOf :: JS -> JS -> JS
188jsInstanceOf = JSOp "instanceof"
190jsEq :: JS -> JS -> JS
191jsEq = JSOp "=="
193jsAnd :: JS -> JS -> JS
194jsAnd = JSOp "&&"
196jsType :: JS
197jsType = JSRaw $ idrRTNamespace ++ "Type"
199jsCon :: JS
200jsCon = JSRaw $ idrRTNamespace ++ "Con"
202jsTag :: JS -> JS
203jsTag obj = JSProj obj "tag"
205jsTypeTag :: JS -> JS
206jsTypeTag obj = JSProj obj "type"
208jsBigInt :: JS -> JS
209jsBigInt val =
210 JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
212jsVar :: Int -> String
213jsVar = ("__var_" ++) . show
215jsLet :: String -> JS -> JS -> JS
216jsLet name value body =
217 JSApp (
218 JSFunction [name] (
219 JSReturn body
220 )
221 ) [value]
223jsSubst :: String -> JS -> JS -> JS
224jsSubst var new (JSVar old)
225 | var == translateVariableName old = new
227jsSubst var new (JSRaw old)
228 | var == old = new
230jsSubst var new (JSArray fields) =
231 JSArray (map (jsSubst var new) fields)
233jsSubst var new (JSNew con [tag, vals]) =
234 JSNew con [tag, jsSubst var new vals]
236jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
237 JSNew con [JSFunction [] (
238 JSReturn $ JSApp fun (map (jsSubst var new) vars)
239 )]
241jsSubst var new (JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
242 JSReturn (JSApp fun args)
243 )]) =
244 JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
245 JSReturn $ JSApp fun (map (jsSubst var new) args)
246 )]
248jsSubst var new (JSApp (JSFunction [arg] body) vals)
249 | var /= arg =
250 JSApp (JSFunction [arg] (
251 jsSubst var new body
252 )) $ map (jsSubst var new) vals
254jsSubst var new (JSReturn ret) =
255 JSReturn $ jsSubst var new ret
257jsSubst _ _ js = js
259inlineJS :: JS -> JS
260inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
261 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
263inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
264 | JSNew con [tag, vals] <- ret
265 , opt <- inlineJS val =
266 JSNew con [tag, jsSubst arg opt vals]
268 | JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
269 , opt <- inlineJS val =
270 JSNew con [JSFunction [] (
271 JSReturn $ JSApp fun (map (jsSubst arg opt) vars)
272 )]
274 | JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
275 JSReturn (JSApp fun args)
276 )] <- ret
277 , opt <- inlineJS val =
278 JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
279 JSReturn $ JSApp fun (map (jsSubst arg opt) args)
280 )]
282 | JSIndex (JSProj obj field) idx <- ret
283 , opt <- inlineJS val =
284 JSIndex (JSProj (
285 jsSubst arg opt obj
286 ) field
287 ) (jsSubst arg opt idx)
289 | JSOp op lhs rhs <- ret =
290 JSOp op (jsSubst arg (inlineJS val) lhs) $
291 (jsSubst arg (inlineJS val) rhs)
293inlineJS (JSApp fun args) =
294 JSApp (inlineJS fun) (map inlineJS args)
296inlineJS (JSNew con args) =
297 JSNew con $ map inlineJS args
299inlineJS (JSAssign lhs rhs) =
300 JSAssign lhs (inlineJS rhs)
302inlineJS (JSSeq seq) =
303 JSSeq (map inlineJS seq)
305inlineJS (JSFunction args body) =
306 JSFunction args (inlineJS body)
308inlineJS (JSProj (JSFunction args body) "apply") =
309 JSProj (JSFunction args (inlineJS body)) "apply"
311inlineJS (JSReturn js) =
312 JSReturn $ inlineJS js
314inlineJS (JSAlloc name (Just js)) =
315 JSAlloc name (Just $ inlineJS js)
317inlineJS (JSCond cases) =
318 JSCond (map (second inlineJS) cases)
320inlineJS (JSObject fields) =
321 JSObject (map (second inlineJS) fields)
323inlineJS js = js
325optimizeJS :: JS -> JS
326optimizeJS = inlineLoop
327 where inlineLoop :: JS -> JS
328 inlineLoop js
329 | opt <- inlineJS js
330 , opt /= js = inlineLoop opt
331 | otherwise = js
333codegenJavaScript
334 :: JSTarget
335 -> [(Name, SDecl)]
336 -> FilePath
337 -> OutputType
338 -> IO ()
339codegenJavaScript target definitions filename outputType = do
340 let (header, runtime) = case target of
341 Node ->
342 ("#!/usr/bin/env node\n", "-node")
343 JavaScript ->
344 ("", "-browser")
345 path <- getDataDir
346 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
347 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
348 writeFile filename $ header ++ (
349 intercalate "\n" $ [ idrRuntime
350 , tgtRuntime
351 ] ++ functions ++ [mainLoop, invokeLoop]
352 )
354 setPermissions filename (emptyPermissions { readable = True
355 , executable = target == Node
356 , writable = True
357 })
358 where
359 def :: [(String, SDecl)]
360 def = map (first translateNamespace) definitions
362 functions :: [String]
363 functions = map (compileJS . optimizeJS . translateDeclaration) def
365 mainLoop :: String
366 mainLoop = compileJS $
367 JSAlloc "main" $ Just $ JSFunction [] (
368 case target of
369 Node -> mainFun
370 JavaScript -> jsMeth (JSRaw "window") "addEventListener" [
371 JSString "DOMContentLoaded", JSFunction [] (
372 mainFun
373 ), JSFalse
374 ]
375 )
376 where
377 mainFun :: JS
378 mainFun = jsTailcall $ jsCall runMain []
380 runMain :: String
381 runMain = idrNamespace ++ translateName (MN 0 "runMain")
383 invokeLoop :: String
384 invokeLoop = compileJS $ jsCall "main" []
386translateIdentifier :: String -> String
387translateIdentifier =
388 replaceReserved . concatMap replaceBadChars
389 where replaceBadChars :: Char -> String
390 replaceBadChars c
391 | ' ' <- c = "_"
392 | '_' <- c = "__"
393 | isDigit c = '_' : show (ord c)
394 | not (isLetter c && isAscii c) = '_' : show (ord c)
395 | otherwise = [c]
396 replaceReserved s
397 | s `elem` reserved = '_' : s
398 | otherwise = s
399 reserved = [ "break"
400 , "case"
401 , "catch"
402 , "continue"
403 , "debugger"
404 , "default"
405 , "delete"
406 , "do"
407 , "else"
408 , "finally"
409 , "for"
410 , "function"
411 , "if"
412 , "in"
413 , "instanceof"
414 , "new"
415 , "return"
416 , "switch"
417 , "this"
418 , "throw"
419 , "try"
420 , "typeof"
421 , "var"
422 , "void"
423 , "while"
424 , "with"
426 , "class"
427 , "enum"
428 , "export"
429 , "extends"
430 , "import"
431 , "super"
433 , "implements"
434 , "interface"
435 , "let"
436 , "package"
437 , "private"
438 , "protected"
439 , "public"
440 , "static"
441 , "yield"
442 ]
444translateNamespace :: Name -> String
445translateNamespace (UN _) = idrNamespace
446translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
447translateNamespace (MN _ _) = idrNamespace
448translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
449translateNamespace NErased = idrNamespace
451translateName :: Name -> String
452translateName (UN name) = 'u' : translateIdentifier name
453translateName (NS name _) = 'n' : translateName name
454translateName (MN i name) = 'm' : translateIdentifier name ++ show i
455translateName (SN name) = 's' : translateSpecialName name
456translateName NErased = "e"
458translateSpecialName :: SpecialName -> String
459translateSpecialName name
460 | WhereN i m n <- name =
461 'w' : translateName m ++ translateName n ++ show i
462 | InstanceN n s <- name =
463 'i' : translateName n ++ concatMap translateIdentifier s
464 | ParentN n s <- name =
465 'p' : translateName n ++ translateIdentifier s
466 | MethodN n <- name =
467 'm' : translateName n
468 | CaseN n <- name =
469 'c' : translateName n
471translateConstant :: Const -> JS
472translateConstant (I i) = JSNum (JSInt i)
473translateConstant (Fl f) = JSNum (JSFloat f)
474translateConstant (Ch c) = JSString [c]
475translateConstant (Str s) = JSString s
476translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
477translateConstant StrType = JSType JSStringTy
478translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
479translateConstant (AType ATFloat) = JSType JSFloatTy
480translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
481translateConstant PtrType = JSType JSPtrTy
482translateConstant Forgot = JSType JSForgotTy
483translateConstant (BI i) = jsBigInt $ JSString (show i)
484translateConstant c =
485 JSError $ "Unimplemented Constant: " ++ show c
487translateDeclaration :: (String, SDecl) -> JS
488translateDeclaration (path, SFun name params stackSize body)
489 | (MN _ "APPLY") <- name
490 , (SLet var val next) <- body
491 , (SChkCase cvar cases) <- next =
492 let lvar = translateVariableName var
493 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
494 JSSeq [ lookupTable [(var, "chk")] var cases
495 , jsDecl $ JSFunction ["fn0", "arg0"] (
496 JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
497 , JSReturn $ jsLet (translateVariableName var) (
498 translateExpression val
499 ) (JSTernary (
500 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
501 (hasProp lookupTableName (translateVariableName var))
502 ) (JSRaw $
503 lookupTableName ++ lookup
504 ) JSNull
505 )
506 ]
507 )
508 ]
510 | (MN _ "EVAL") <- name
511 , (SChkCase var cases) <- body =
512 JSSeq [ lookupTable [] var cases
513 , jsDecl $ JSFunction ["arg0"] (JSReturn $
514 JSTernary (
515 (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
516 (hasProp lookupTableName "arg0")
517 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
518 )
519 ]
520 | otherwise =
521 let fun = translateExpression body in
522 jsDecl $ jsFun fun
524 where
525 hasProp :: String -> String -> JS
526 hasProp table var =
527 JSIndex (JSRaw table) (JSProj (JSRaw var) "tag")
529 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
530 caseFun aux var cse =
531 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
533 getTag :: SAlt -> Maybe Int
534 getTag (SConCase _ tag _ _ _) = Just tag
535 getTag _ = Nothing
537 lookupTableName :: String
538 lookupTableName = idrLTNamespace ++ translateName name
540 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
541 lookupTable aux var cases =
542 JSAlloc lookupTableName $ Just (
543 JSApp (JSFunction [] (
544 JSSeq $ [
545 JSAlloc "t" $ Just (JSArray [])
546 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
547 JSReturn (JSRaw "t")
548 ]
549 )) []
550 )
551 where
552 assignEntries :: [(Int, JS)] -> [JS]
553 assignEntries entries =
554 map (\(tag, fun) ->
555 JSAssign (JSIndex (JSRaw "t") (JSNum $ JSInt tag)) fun
556 ) entries
558 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
559 lookupEntry aux var alt = do
560 tag <- getTag alt
561 return (tag, caseFun aux var alt)
563 jsDecl :: JS -> JS
564 jsDecl = JSAlloc (path ++ translateName name) . Just
566 jsFun body = jsFunAux [] body
568 jsFunAux :: [(LVar, String)] -> JS -> JS
569 jsFunAux aux body =
570 JSFunction (p ++ map snd aux) (
571 JSSeq $
572 zipWith assignVar [0..] p ++
573 map allocVar [numP .. (numP + stackSize - 1)] ++
574 map assignAux aux ++
575 [JSReturn body]
576 )
577 where
578 numP :: Int
579 numP = length params
581 allocVar :: Int -> JS
582 allocVar n = JSAlloc (jsVar n) Nothing
584 assignVar :: Int -> String -> JS
585 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
587 assignAux :: (LVar, String) -> JS
588 assignAux (var, val) =
589 JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
591 p :: [String]
592 p = map translateName params
594translateVariableName :: LVar -> String
595translateVariableName (Loc i) =
596 jsVar i
598translateExpression :: SExp -> JS
599translateExpression (SLet name value body) =
600 jsLet (translateVariableName name) (
601 translateExpression value
602 ) (translateExpression body)
604translateExpression (SConst cst) =
605 translateConstant cst
607translateExpression (SV var) =
608 JSVar var
610translateExpression (SApp tc name vars)
611 | False <- tc =
612 jsTailcall $ translateFunctionCall name vars
613 | True <- tc =
614 JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
615 JSReturn $ translateFunctionCall name vars
616 )]
617 where
618 translateFunctionCall name vars =
619 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
621translateExpression (SOp op vars)
622 | LNoOp <- op = JSVar (last vars)
624 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
625 | (LPlus (ATInt ITBig)) <- op
626 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
627 | (LMinus (ATInt ITBig)) <- op
628 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
629 | (LTimes (ATInt ITBig)) <- op
630 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
631 | (LSDiv (ATInt ITBig)) <- op
632 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
633 | (LSRem (ATInt ITBig)) <- op
634 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
635 | (LEq (ATInt ITBig)) <- op
636 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
637 | (LSLt (ATInt ITBig)) <- op
638 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
639 | (LSLe (ATInt ITBig)) <- op
640 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
641 | (LSGt (ATInt ITBig)) <- op
642 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
643 | (LSGe (ATInt ITBig)) <- op
644 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
646 | (LPlus ATFloat) <- op
647 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
648 | (LMinus ATFloat) <- op
649 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
650 | (LTimes ATFloat) <- op
651 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
652 | (LSDiv ATFloat) <- op
653 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
654 | (LEq ATFloat) <- op
655 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
656 | (LSLt ATFloat) <- op
657 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
658 | (LSLe ATFloat) <- op
659 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
660 | (LSGt ATFloat) <- op
661 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
662 | (LSGe ATFloat) <- op
663 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
665 | (LPlus _) <- op
666 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
667 | (LMinus _) <- op
668 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
669 | (LTimes _) <- op
670 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
671 | (LSDiv _) <- op
672 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
673 | (LSRem _) <- op
674 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
675 | (LEq _) <- op
676 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
677 | (LSLt _) <- op
678 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
679 | (LSLe _) <- op
680 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
681 | (LSGt _) <- op
682 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
683 | (LSGe _) <- op
684 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
685 | (LAnd _) <- op
686 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
687 | (LOr _) <- op
688 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
689 | (LXOr _) <- op
690 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
691 | (LSHL _) <- op
692 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
693 | (LASHR _) <- op
694 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
695 | (LCompl _) <- op
696 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
698 | LStrConcat <- op
699 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
700 | LStrEq <- op
701 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
702 | LStrLt <- op
703 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
704 | LStrLen <- op
705 , (arg:_) <- vars = JSProj (JSVar arg) "length"
707 | (LStrInt ITNative) <- op
708 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
709 | (LIntStr ITNative) <- op
710 , (arg:_) <- vars = jsCall "String" [JSVar arg]
711 | (LSExt ITNative ITBig) <- op
712 , (arg:_) <- vars = jsBigInt $ JSVar arg
713 | (LTrunc ITBig ITNative) <- op
714 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
715 | (LIntStr ITBig) <- op
716 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
717 | (LStrInt ITBig) <- op
718 , (arg:_) <- vars = jsBigInt $ JSVar arg
719 | LFloatStr <- op
720 , (arg:_) <- vars = jsCall "String" [JSVar arg]
721 | LStrFloat <- op
722 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
723 | (LIntFloat ITNative) <- op
724 , (arg:_) <- vars = JSVar arg
725 | (LFloatInt ITNative) <- op
726 , (arg:_) <- vars = JSVar arg
727 | (LChInt ITNative) <- op
728 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
729 | (LIntCh ITNative) <- op
730 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
732 | LFExp <- op
733 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
734 | LFLog <- op
735 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
736 | LFSin <- op
737 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
738 | LFCos <- op
739 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
740 | LFTan <- op
741 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
742 | LFASin <- op
743 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
744 | LFACos <- op
745 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
746 | LFATan <- op
747 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
748 | LFSqrt <- op
749 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
750 | LFFloor <- op
751 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
752 | LFCeil <- op
753 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
755 | LStrCons <- op
756 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
757 | LStrHead <- op
758 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
759 | LStrRev <- op
760 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
761 | LStrIndex <- op
762 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
763 | LStrTail <- op
764 , (arg:_) <- vars = let v = translateVariableName arg in
765 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
766 where
767 translateBinaryOp :: String -> LVar -> LVar -> JS
768 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
770 invokeMeth :: LVar -> String -> [LVar] -> JS
771 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
773translateExpression (SError msg) =
774 JSError msg
776translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
777 jsCall (idrRTNamespace ++ "print") [JSVar var]
779translateExpression (SForeign _ _ fun args) =
780 ffi fun (map generateWrapper args)
781 where
782 generateWrapper (ffunc, name)
783 | FFunction <- ffunc =
784 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
785 | FFunctionIO <- ffunc =
786 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
788 generateWrapper (_, name) =
789 translateVariableName name
791translateExpression patterncase
792 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
793 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
794 where
795 caseHelper var cases param =
796 JSApp (JSFunction [param] (
797 JSCond $ map (expandCase param . translateCaseCond param) cases
798 )) [JSVar var]
800 expandCase :: String -> (Cond, JS) -> (JS, JS)
801 expandCase _ (RawCond cond, branch) = (cond, branch)
802 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
803 expandCase var (CaseCond caseTy, branch)
804 | ConCase tag <- caseTy =
805 let checkCon = JSRaw var `jsInstanceOf` jsCon
806 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
807 (checkCon `jsAnd` checkTag, branch)
809 | TypeCase ty <- caseTy =
810 let checkTy = JSRaw var `jsInstanceOf` jsType
811 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
812 (checkTy `jsAnd` checkTag, branch)
814translateExpression (SCon i name vars) =
815 JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
816 , JSArray $ map JSVar vars
817 ]
819translateExpression (SUpdate var e) =
820 JSAssign (JSVar var) (translateExpression e)
822translateExpression (SProj var i) =
823 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
825translateExpression SNothing = JSNull
827translateExpression e =
828 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
830data FFI = FFICode Char | FFIArg Int | FFIError String
832ffi :: String -> [String] -> JS
833ffi code args = let parsed = ffiParse code in
834 case ffiError parsed of
835 Just err -> JSError err
836 Nothing -> JSRaw $ renderFFI parsed args
837 where
838 ffiParse :: String -> [FFI]
839 ffiParse "" = []
840 ffiParse ['%'] = [FFIError "Invalid positional argument"]
841 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
842 ffiParse ('%':s:ss)
843 | isDigit s =
844 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
845 | otherwise =
846 [FFIError "Invalid positional argument"]
847 ffiParse (s:ss) = FFICode s : ffiParse ss
849 ffiError :: [FFI] -> Maybe String
850 ffiError [] = Nothing
851 ffiError ((FFIError s):xs) = Just s
852 ffiError (x:xs) = ffiError xs
854 renderFFI :: [FFI] -> [String] -> String
855 renderFFI [] _ = ""
856 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
857 renderFFI ((FFIArg i) : fs) args
858 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
859 | otherwise = "Argument index out of bounds"
861data CaseType = ConCase Int
862 | TypeCase JSType
863 | DefaultCase
864 deriving Eq
866data Cond = CaseCond CaseType
867 | RawCond JS
869translateCaseCond :: String -> SAlt -> (Cond, JS)
870translateCaseCond _ cse@(SDefaultCase _) =
871 (CaseCond DefaultCase, translateCase Nothing cse)
873translateCaseCond var cse@(SConstCase ty _)
874 | StrType <- ty = matchHelper JSStringTy
875 | PtrType <- ty = matchHelper JSPtrTy
876 | Forgot <- ty = matchHelper JSForgotTy
877 | (AType ATFloat) <- ty = matchHelper JSFloatTy
878 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
879 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
880 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
881 where
882 matchHelper :: JSType -> (Cond, JS)
883 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
885translateCaseCond var cse@(SConstCase cst@(BI _) _) =
886 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
887 (RawCond cond, translateCase Nothing cse)
889translateCaseCond var cse@(SConstCase cst _) =
890 let cond = JSRaw var `jsEq` translateConstant cst in
891 (RawCond cond, translateCase Nothing cse)
893translateCaseCond var cse@(SConCase _ tag _ _ _) =
894 (CaseCond $ ConCase tag, translateCase (Just var) cse)
896translateCase :: Maybe String -> SAlt -> JS
897translateCase _ (SDefaultCase e) = translateExpression e
898translateCase _ (SConstCase _ e) = translateExpression e
899translateCase (Just var) (SConCase a _ _ vars e) =
900 let params = map jsVar [a .. (a + length vars)] in
901 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
902 JSThis, JSProj (JSRaw var) "vars"
903 ]