git.iko.soy/Idris-dev
on ae95dc6 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
798 lines 26 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 :: String -> [JS] -> JS
167jsTailcall fun args =
168 jsCall (idrRTNamespace ++ "tailcall") [JSRaw fun, JSArray args]
170jsCall :: String -> [JS] -> JS
171jsCall fun = JSApp (JSRaw fun)
173jsMeth :: JS -> String -> [JS] -> JS
174jsMeth obj meth =
175 JSApp (JSProj obj meth)
177jsInstanceOf :: JS -> JS -> JS
178jsInstanceOf = JSOp "instanceof"
180jsEq :: JS -> JS -> JS
181jsEq = JSOp "=="
183jsAnd :: JS -> JS -> JS
184jsAnd = JSOp "&&"
186jsType :: JS
187jsType = JSRaw $ idrRTNamespace ++ "Type"
189jsCon :: JS
190jsCon = JSRaw $ idrRTNamespace ++ "Con"
192jsTag :: JS -> JS
193jsTag obj = JSProj obj "tag"
195jsTypeTag :: JS -> JS
196jsTypeTag obj = JSProj obj "type"
198jsBigInt :: JS -> JS
199jsBigInt val =
200 JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
202jsVar :: Int -> String
203jsVar = ("__var_" ++) . show
205jsLet :: String -> JS -> JS -> JS
206jsLet name value body =
207 JSApp (
208 JSFunction [name] (
209 JSReturn body
210 )
211 ) [value]
213jsSubst :: String -> [JS] -> JS -> [JS]
214jsSubst _ [] _ = []
215jsSubst var (x@(JSVar old) : xs) new
216 | var == translateVariableName old = new : xs
217 | otherwise = x : jsSubst var xs new
218jsSubst _ xs _ = xs
220optimizeJS :: JS -> JS
221optimizeJS (JSApp
222 (JSFunction [arg] (JSReturn ret))
223 [val]
224 )
225 | JSNew con [tag, JSArray vals] <- ret =
226 JSNew con [tag, JSArray $ jsSubst arg vals (optimizeJS val)]
227 | JSApp (JSRaw tc@"__IDRRT__tailcall") [fun, JSArray args] <- ret =
228 JSApp (JSRaw tc) [fun, JSArray $ jsSubst arg args (optimizeJS val)]
230optimizeJS (JSSeq seq) =
231 JSSeq (map optimizeJS seq)
233optimizeJS (JSFunction args body) =
234 JSFunction args (optimizeJS body)
236optimizeJS (JSApp fun args) =
237 JSApp (optimizeJS fun) (map optimizeJS args)
239optimizeJS (JSReturn js) =
240 JSReturn $ optimizeJS js
242optimizeJS (JSAlloc name (Just js)) =
243 JSAlloc name (Just $ optimizeJS js)
245optimizeJS js = js
247optJS :: Int -> JS -> JS
248optJS c = foldr (.) id $ take c $ repeat optimizeJS
250codegenJavaScript
251 :: JSTarget
252 -> [(Name, SDecl)]
253 -> FilePath
254 -> OutputType
255 -> IO ()
256codegenJavaScript target definitions filename outputType = do
257 let (header, runtime) = case target of
258 Node ->
259 ("#!/usr/bin/env node\n", "-node")
260 JavaScript ->
261 ("", "-browser")
262 path <- getDataDir
263 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
264 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
265 writeFile filename $ intercalate "\n" $ [ header
266 , idrRuntime
267 , tgtRuntime
268 ] ++ functions ++ [mainLoop]
270 setPermissions filename (emptyPermissions { readable = True
271 , executable = target == Node
272 , writable = True
273 })
274 where
275 def :: [(String, SDecl)]
276 def = map (first translateNamespace) definitions
278 functions :: [String]
279 functions = map (compileJS . optJS 1 . translateDeclaration) def
281 mainLoop :: String
282 mainLoop = compileJS $
283 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
284 jsTailcall mainFun []
285 )
286 , jsCall "main" []
287 ]
289 mainFun :: String
290 mainFun = idrNamespace ++ translateName (MN 0 "runMain")
292translateIdentifier :: String -> String
293translateIdentifier =
294 replaceReserved . concatMap replaceBadChars
295 where replaceBadChars :: Char -> String
296 replaceBadChars c
297 | ' ' <- c = "_"
298 | '_' <- c = "__"
299 | isDigit c = '_' : show (ord c)
300 | not (isLetter c && isAscii c) = '_' : show (ord c)
301 | otherwise = [c]
302 replaceReserved s
303 | s `elem` reserved = '_' : s
304 | otherwise = s
305 reserved = [ "break"
306 , "case"
307 , "catch"
308 , "continue"
309 , "debugger"
310 , "default"
311 , "delete"
312 , "do"
313 , "else"
314 , "finally"
315 , "for"
316 , "function"
317 , "if"
318 , "in"
319 , "instanceof"
320 , "new"
321 , "return"
322 , "switch"
323 , "this"
324 , "throw"
325 , "try"
326 , "typeof"
327 , "var"
328 , "void"
329 , "while"
330 , "with"
332 , "class"
333 , "enum"
334 , "export"
335 , "extends"
336 , "import"
337 , "super"
339 , "implements"
340 , "interface"
341 , "let"
342 , "package"
343 , "private"
344 , "protected"
345 , "public"
346 , "static"
347 , "yield"
348 ]
350translateNamespace :: Name -> String
351translateNamespace (UN _) = idrNamespace
352translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
353translateNamespace (MN _ _) = idrNamespace
354translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
355translateNamespace NErased = idrNamespace
357translateName :: Name -> String
358translateName (UN name) = 'u' : translateIdentifier name
359translateName (NS name _) = 'n' : translateName name
360translateName (MN i name) = 'm' : translateIdentifier name ++ show i
361translateName (SN name) = 's' : translateSpecialName name
362translateName NErased = "e"
364translateSpecialName :: SpecialName -> String
365translateSpecialName name
366 | WhereN i m n <- name =
367 'w' : translateName m ++ translateName n ++ show i
368 | InstanceN n s <- name =
369 'i' : translateName n ++ concatMap translateIdentifier s
370 | ParentN n s <- name =
371 'p' : translateName n ++ translateIdentifier s
372 | MethodN n <- name =
373 'm' : translateName n
374 | CaseN n <- name =
375 'c' : translateName n
377translateConstant :: Const -> JS
378translateConstant (I i) = JSNum (JSInt i)
379translateConstant (Fl f) = JSNum (JSFloat f)
380translateConstant (Ch c) = JSString [c]
381translateConstant (Str s) = JSString s
382translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
383translateConstant StrType = JSType JSStringTy
384translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
385translateConstant (AType ATFloat) = JSType JSFloatTy
386translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
387translateConstant PtrType = JSType JSPtrTy
388translateConstant Forgot = JSType JSForgotTy
389translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
390translateConstant c =
391 JSError $ "Unimplemented Constant: " ++ show c
393translateDeclaration :: (String, SDecl) -> JS
394translateDeclaration (path, SFun name params stackSize body)
395 | (MN _ "APPLY") <- name
396 , (SLet var val next) <- body
397 , (SChkCase cvar cases) <- next =
398 let lvar = translateVariableName var
399 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
400 JSSeq [ lookupTable [(var, "chk")] var cases
401 , jsDecl $ JSFunction ["fn0", "arg0"] (
402 JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
403 , JSReturn $ jsLet (translateVariableName var) (
404 translateExpression val
405 ) (JSTernary (
406 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
407 (hasProp lookupTableName (translateVariableName var))
408 ) (JSRaw $
409 lookupTableName ++ lookup
410 ) JSNull
411 )
412 ]
413 )
414 ]
416 | (MN _ "EVAL") <- name
417 , (SChkCase var cases) <- body =
418 JSSeq [ lookupTable [] var cases
419 , jsDecl $ JSFunction ["arg0"] (JSReturn $
420 JSTernary (
421 (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
422 (hasProp lookupTableName "arg0")
423 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
424 )
425 ]
426 | otherwise =
427 let fun = translateExpression body in
428 jsDecl $ jsFun fun
430 where
431 hasProp :: String -> String -> JS
432 hasProp table var =
433 jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]
435 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
436 caseFun aux var cse =
437 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
439 getTag :: SAlt -> Maybe String
440 getTag (SConCase _ tag _ _ _) = Just $ show tag
441 getTag _ = Nothing
443 lookupTableName :: String
444 lookupTableName = idrLTNamespace ++ translateName name
446 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
447 lookupTable aux var cases =
448 JSAlloc lookupTableName $ Just (
449 JSObject $ catMaybes $ map (lookupEntry aux var) cases
450 )
451 where
452 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
453 lookupEntry aux var alt = do
454 tag <- getTag alt
455 return (tag, caseFun aux var alt)
457 jsDecl :: JS -> JS
458 jsDecl = JSAlloc (path ++ translateName name) . Just
460 jsFun body = jsFunAux [] body
462 jsFunAux :: [(LVar, String)] -> JS -> JS
463 jsFunAux aux body =
464 JSFunction (p ++ map snd aux) (
465 JSSeq $
466 zipWith assignVar [0..] p ++
467 map allocVar [numP .. (numP + stackSize - 1)] ++
468 map assignAux aux ++
469 [JSReturn body]
470 )
471 where
472 numP :: Int
473 numP = length params
475 allocVar :: Int -> JS
476 allocVar n = JSAlloc (jsVar n) Nothing
478 assignVar :: Int -> String -> JS
479 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
481 assignAux :: (LVar, String) -> JS
482 assignAux (var, val) =
483 JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
485 p :: [String]
486 p = map translateName params
488translateVariableName :: LVar -> String
489translateVariableName (Loc i) =
490 jsVar i
492translateExpression :: SExp -> JS
493translateExpression (SLet name value body) =
494 jsLet (translateVariableName name) (
495 translateExpression value
496 ) (translateExpression body)
498translateExpression (SConst cst) =
499 translateConstant cst
501translateExpression (SV var) =
502 JSVar var
504translateExpression (SApp tc name vars)
505 | False <- tc =
506 jsTailcall (translateFunctionCall name) (map JSVar vars)
507 | True <- tc =
508 JSNew (idrRTNamespace ++ "Tailcall")
509 [ JSRaw $ translateFunctionCall name
510 , JSArray $ map JSVar vars
511 ]
512 where
513 translateFunctionCall name =
514 translateNamespace name ++ translateName name
516translateExpression (SOp op vars)
517 | LNoOp <- op = JSVar (last vars)
519 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
520 | (LPlus (ATInt ITBig)) <- op
521 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
522 | (LMinus (ATInt ITBig)) <- op
523 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
524 | (LTimes (ATInt ITBig)) <- op
525 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
526 | (LSDiv (ATInt ITBig)) <- op
527 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
528 | (LSRem (ATInt ITBig)) <- op
529 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
530 | (LEq (ATInt ITBig)) <- op
531 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
532 | (LSLt (ATInt ITBig)) <- op
533 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
534 | (LSLe (ATInt ITBig)) <- op
535 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
536 | (LSGt (ATInt ITBig)) <- op
537 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
538 | (LSGe (ATInt ITBig)) <- op
539 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
541 | (LPlus ATFloat) <- op
542 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
543 | (LMinus ATFloat) <- op
544 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
545 | (LTimes ATFloat) <- op
546 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
547 | (LSDiv ATFloat) <- op
548 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
549 | (LEq ATFloat) <- op
550 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
551 | (LSLt ATFloat) <- op
552 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
553 | (LSLe ATFloat) <- op
554 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
555 | (LSGt ATFloat) <- op
556 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
557 | (LSGe ATFloat) <- op
558 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
560 | (LPlus _) <- op
561 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
562 | (LMinus _) <- op
563 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
564 | (LTimes _) <- op
565 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
566 | (LSDiv _) <- op
567 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
568 | (LSRem _) <- op
569 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
570 | (LEq _) <- op
571 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
572 | (LSLt _) <- op
573 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
574 | (LSLe _) <- op
575 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
576 | (LSGt _) <- op
577 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
578 | (LSGe _) <- op
579 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
580 | (LAnd _) <- op
581 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
582 | (LOr _) <- op
583 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
584 | (LXOr _) <- op
585 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
586 | (LSHL _) <- op
587 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
588 | (LASHR _) <- op
589 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
590 | (LCompl _) <- op
591 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
593 | LStrConcat <- op
594 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
595 | LStrEq <- op
596 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
597 | LStrLt <- op
598 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
599 | LStrLen <- op
600 , (arg:_) <- vars = JSProj (JSVar arg) "length"
602 | (LStrInt ITNative) <- op
603 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
604 | (LIntStr ITNative) <- op
605 , (arg:_) <- vars = jsCall "String" [JSVar arg]
606 | (LSExt ITNative ITBig) <- op
607 , (arg:_) <- vars = jsBigInt $ JSVar arg
608 | (LTrunc ITBig ITNative) <- op
609 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
610 | (LIntStr ITBig) <- op
611 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
612 | (LStrInt ITBig) <- op
613 , (arg:_) <- vars = jsBigInt $ JSVar arg
614 | LFloatStr <- op
615 , (arg:_) <- vars = jsCall "String" [JSVar arg]
616 | LStrFloat <- op
617 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
618 | (LIntFloat ITNative) <- op
619 , (arg:_) <- vars = JSVar arg
620 | (LFloatInt ITNative) <- op
621 , (arg:_) <- vars = JSVar arg
622 | (LChInt ITNative) <- op
623 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
624 | (LIntCh ITNative) <- op
625 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
627 | LFExp <- op
628 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
629 | LFLog <- op
630 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
631 | LFSin <- op
632 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
633 | LFCos <- op
634 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
635 | LFTan <- op
636 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
637 | LFASin <- op
638 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
639 | LFACos <- op
640 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
641 | LFATan <- op
642 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
643 | LFSqrt <- op
644 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
645 | LFFloor <- op
646 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
647 | LFCeil <- op
648 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
650 | LStrCons <- op
651 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
652 | LStrHead <- op
653 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
654 | LStrRev <- op
655 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
656 | LStrIndex <- op
657 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
658 | LStrTail <- op
659 , (arg:_) <- vars = let v = translateVariableName arg in
660 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
661 where
662 translateBinaryOp :: String -> LVar -> LVar -> JS
663 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
665 invokeMeth :: LVar -> String -> [LVar] -> JS
666 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
668translateExpression (SError msg) =
669 JSError msg
671translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
672 jsCall (idrRTNamespace ++ "print") [JSVar var]
674translateExpression (SForeign _ _ fun args) =
675 ffi fun (map generateWrapper args)
676 where
677 generateWrapper (ffunc, name)
678 | FFunction <- ffunc =
679 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
680 | FFunctionIO <- ffunc =
681 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
683 generateWrapper (_, name) =
684 translateVariableName name
686translateExpression patterncase
687 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
688 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
689 where
690 caseHelper var cases param =
691 JSApp (JSFunction [param] (
692 JSCond $ map (expandCase param . translateCaseCond param) cases
693 )) [JSVar var]
695 expandCase :: String -> (Cond, JS) -> (JS, JS)
696 expandCase _ (RawCond cond, branch) = (cond, branch)
697 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
698 expandCase var (CaseCond caseTy, branch)
699 | ConCase tag <- caseTy =
700 let checkCon = JSRaw var `jsInstanceOf` jsCon
701 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
702 (checkCon `jsAnd` checkTag, branch)
704 | TypeCase ty <- caseTy =
705 let checkTy = JSRaw var `jsInstanceOf` jsType
706 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
707 (checkTy `jsAnd` checkTag, branch)
709translateExpression (SCon i name vars) =
710 JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
711 , JSArray $ map JSVar vars
712 ]
714translateExpression (SUpdate var e) =
715 JSAssign (JSVar var) (translateExpression e)
717translateExpression (SProj var i) =
718 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
720translateExpression SNothing = JSNull
722translateExpression e =
723 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
725data FFI = FFICode Char | FFIArg Int | FFIError String
727ffi :: String -> [String] -> JS
728ffi code args = let parsed = ffiParse code in
729 case ffiError parsed of
730 Just err -> JSError err
731 Nothing -> JSRaw $ renderFFI parsed args
732 where
733 ffiParse :: String -> [FFI]
734 ffiParse "" = []
735 ffiParse ['%'] = [FFIError "Invalid positional argument"]
736 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
737 ffiParse ('%':s:ss)
738 | isDigit s =
739 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
740 | otherwise =
741 [FFIError "Invalid positional argument"]
742 ffiParse (s:ss) = FFICode s : ffiParse ss
744 ffiError :: [FFI] -> Maybe String
745 ffiError [] = Nothing
746 ffiError ((FFIError s):xs) = Just s
747 ffiError (x:xs) = ffiError xs
749 renderFFI :: [FFI] -> [String] -> String
750 renderFFI [] _ = ""
751 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
752 renderFFI ((FFIArg i) : fs) args
753 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
754 | otherwise = "Argument index out of bounds"
756data CaseType = ConCase Int
757 | TypeCase JSType
758 | DefaultCase
759 deriving Eq
761data Cond = CaseCond CaseType
762 | RawCond JS
764translateCaseCond :: String -> SAlt -> (Cond, JS)
765translateCaseCond _ cse@(SDefaultCase _) =
766 (CaseCond DefaultCase, translateCase Nothing cse)
768translateCaseCond var cse@(SConstCase ty _)
769 | StrType <- ty = matchHelper JSStringTy
770 | PtrType <- ty = matchHelper JSPtrTy
771 | Forgot <- ty = matchHelper JSForgotTy
772 | (AType ATFloat) <- ty = matchHelper JSFloatTy
773 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
774 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
775 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
776 where
777 matchHelper :: JSType -> (Cond, JS)
778 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
780translateCaseCond var cse@(SConstCase cst@(BI _) _) =
781 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
782 (RawCond cond, translateCase Nothing cse)
784translateCaseCond var cse@(SConstCase cst _) =
785 let cond = JSRaw var `jsEq` translateConstant cst in
786 (RawCond cond, translateCase Nothing cse)
788translateCaseCond var cse@(SConCase _ tag _ _ _) =
789 (CaseCond $ ConCase tag, translateCase (Just var) cse)
791translateCase :: Maybe String -> SAlt -> JS
792translateCase _ (SDefaultCase e) = translateExpression e
793translateCase _ (SConstCase _ e) = translateExpression e
794translateCase (Just var) (SConCase a _ _ vars e) =
795 let params = map jsVar [a .. (a + length vars)] in
796 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
797 JSThis, JSProj (JSRaw var) "vars"
798 ]