git.iko.soy/Idris-dev
on f2f0eed help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
762 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 mainFun []
250 )
251 , jsCall "main" []
252 ]
254 mainFun :: String
255 mainFun = idrNamespace ++ translateName (MN 0 "runMain")
257translateIdentifier :: String -> String
258translateIdentifier =
259 replaceReserved . concatMap replaceBadChars
260 where replaceBadChars :: Char -> String
261 replaceBadChars c
262 | ' ' <- c = "_"
263 | '_' <- c = "__"
264 | isDigit c = '_' : show (ord c)
265 | not (isLetter c && isAscii c) = '_' : show (ord c)
266 | otherwise = [c]
267 replaceReserved s
268 | s `elem` reserved = '_' : s
269 | otherwise = s
270 reserved = [ "break"
271 , "case"
272 , "catch"
273 , "continue"
274 , "debugger"
275 , "default"
276 , "delete"
277 , "do"
278 , "else"
279 , "finally"
280 , "for"
281 , "function"
282 , "if"
283 , "in"
284 , "instanceof"
285 , "new"
286 , "return"
287 , "switch"
288 , "this"
289 , "throw"
290 , "try"
291 , "typeof"
292 , "var"
293 , "void"
294 , "while"
295 , "with"
297 , "class"
298 , "enum"
299 , "export"
300 , "extends"
301 , "import"
302 , "super"
304 , "implements"
305 , "interface"
306 , "let"
307 , "package"
308 , "private"
309 , "protected"
310 , "public"
311 , "static"
312 , "yield"
313 ]
315translateNamespace :: Name -> String
316translateNamespace (UN _) = idrNamespace
317translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
318translateNamespace (MN _ _) = idrNamespace
319translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
320translateNamespace NErased = idrNamespace
322translateName :: Name -> String
323translateName (UN name) = 'u' : translateIdentifier name
324translateName (NS name _) = 'n' : translateName name
325translateName (MN i name) = 'm' : translateIdentifier name ++ show i
326translateName (SN name) = 's' : translateSpecialName name
327translateName NErased = "e"
329translateSpecialName :: SpecialName -> String
330translateSpecialName name
331 | WhereN i m n <- name =
332 'w' : translateName m ++ translateName n ++ show i
333 | InstanceN n s <- name =
334 'i' : translateName n ++ concatMap translateIdentifier s
335 | ParentN n s <- name =
336 'p' : translateName n ++ translateIdentifier s
337 | MethodN n <- name =
338 'm' : translateName n
339 | CaseN n <- name =
340 'c' : translateName n
342translateConstant :: Const -> JS
343translateConstant (I i) = JSNum (JSInt i)
344translateConstant (Fl f) = JSNum (JSFloat f)
345translateConstant (Ch c) = JSString [c]
346translateConstant (Str s) = JSString s
347translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
348translateConstant StrType = JSType JSStringTy
349translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
350translateConstant (AType ATFloat) = JSType JSFloatTy
351translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
352translateConstant PtrType = JSType JSPtrTy
353translateConstant Forgot = JSType JSForgotTy
354translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
355translateConstant c =
356 JSError $ "Unimplemented Constant: " ++ show c
358translateDeclaration :: (String, SDecl) -> JS
359translateDeclaration (path, SFun name params stackSize body)
360 | (MN _ "APPLY") <- name
361 , (SLet var val next) <- body
362 , (SChkCase cvar cases) <- next =
363 let lvar = translateVariableName var
364 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
365 JSSeq [ lookupTable [(var, "chk")] var cases
366 , jsDecl $ JSFunction ["fn0", "arg0"] (
367 JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
368 , JSReturn $ jsLet (translateVariableName var) (
369 translateExpression val
370 ) (JSTernary (
371 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
372 (hasProp lookupTableName (translateVariableName var))
373 ) (JSRaw $
374 lookupTableName ++ lookup
375 ) JSNull
376 )
377 ]
378 )
379 ]
381 | (MN _ "EVAL") <- name
382 , (SChkCase var cases) <- body =
383 JSSeq [ lookupTable [] var cases
384 , jsDecl $ JSFunction ["arg0"] (JSReturn $
385 JSTernary (
386 (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
387 (hasProp lookupTableName "arg0")
388 ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
389 )
390 ]
391 | otherwise =
392 let fun = translateExpression body in
393 jsDecl $ jsFun fun
395 where
396 hasProp :: String -> String -> JS
397 hasProp table var =
398 jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]
400 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
401 caseFun aux var cse =
402 jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
404 getTag :: SAlt -> Maybe String
405 getTag (SConCase _ tag _ _ _) = Just $ show tag
406 getTag _ = Nothing
408 lookupTableName :: String
409 lookupTableName = idrLTNamespace ++ translateName name
411 lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
412 lookupTable aux var cases =
413 JSAlloc lookupTableName $ Just (
414 JSObject $ catMaybes $ map (lookupEntry aux var) cases
415 )
416 where
417 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
418 lookupEntry aux var alt = do
419 tag <- getTag alt
420 return (tag, caseFun aux var alt)
422 jsDecl :: JS -> JS
423 jsDecl = JSAlloc (path ++ translateName name) . Just
425 jsFun body = jsFunAux [] body
427 jsFunAux :: [(LVar, String)] -> JS -> JS
428 jsFunAux aux body =
429 JSFunction (p ++ map snd aux) (
430 JSSeq $
431 zipWith assignVar [0..] p ++
432 map allocVar [numP .. (numP + stackSize - 1)] ++
433 map assignAux aux ++
434 [JSReturn body]
435 )
436 where
437 numP :: Int
438 numP = length params
440 allocVar :: Int -> JS
441 allocVar n = JSAlloc (jsVar n) Nothing
443 assignVar :: Int -> String -> JS
444 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
446 assignAux :: (LVar, String) -> JS
447 assignAux (var, val) =
448 JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
450 p :: [String]
451 p = map translateName params
453translateVariableName :: LVar -> String
454translateVariableName (Loc i) =
455 jsVar i
457translateExpression :: SExp -> JS
458translateExpression (SLet name value body) =
459 jsLet (translateVariableName name) (
460 translateExpression value
461 ) (translateExpression body)
463translateExpression (SConst cst) =
464 translateConstant cst
466translateExpression (SV var) =
467 JSVar var
469translateExpression (SApp tc name vars)
470 | False <- tc =
471 jsTailcall $ translateFunctionCall name vars
472 | True <- tc =
473 JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (
474 JSReturn $ translateFunctionCall name vars
475 )]
476 where
477 translateFunctionCall name vars =
478 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
480translateExpression (SOp op vars)
481 | LNoOp <- op = JSVar (last vars)
483 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
484 | (LPlus (ATInt ITBig)) <- op
485 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
486 | (LMinus (ATInt ITBig)) <- op
487 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
488 | (LTimes (ATInt ITBig)) <- op
489 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
490 | (LSDiv (ATInt ITBig)) <- op
491 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
492 | (LSRem (ATInt ITBig)) <- op
493 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
494 | (LEq (ATInt ITBig)) <- op
495 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
496 | (LSLt (ATInt ITBig)) <- op
497 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
498 | (LSLe (ATInt ITBig)) <- op
499 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
500 | (LSGt (ATInt ITBig)) <- op
501 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
502 | (LSGe (ATInt ITBig)) <- op
503 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
505 | (LPlus ATFloat) <- op
506 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
507 | (LMinus ATFloat) <- op
508 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
509 | (LTimes ATFloat) <- op
510 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
511 | (LSDiv ATFloat) <- op
512 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
513 | (LEq ATFloat) <- op
514 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
515 | (LSLt ATFloat) <- op
516 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
517 | (LSLe ATFloat) <- op
518 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
519 | (LSGt ATFloat) <- op
520 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
521 | (LSGe ATFloat) <- op
522 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
524 | (LPlus _) <- op
525 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
526 | (LMinus _) <- op
527 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
528 | (LTimes _) <- op
529 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
530 | (LSDiv _) <- op
531 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
532 | (LSRem _) <- op
533 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
534 | (LEq _) <- op
535 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
536 | (LSLt _) <- op
537 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
538 | (LSLe _) <- op
539 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
540 | (LSGt _) <- op
541 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
542 | (LSGe _) <- op
543 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
544 | (LAnd _) <- op
545 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
546 | (LOr _) <- op
547 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
548 | (LXOr _) <- op
549 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
550 | (LSHL _) <- op
551 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
552 | (LASHR _) <- op
553 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
554 | (LCompl _) <- op
555 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
557 | LStrConcat <- op
558 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
559 | LStrEq <- op
560 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
561 | LStrLt <- op
562 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
563 | LStrLen <- op
564 , (arg:_) <- vars = JSProj (JSVar arg) "length"
566 | (LStrInt ITNative) <- op
567 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
568 | (LIntStr ITNative) <- op
569 , (arg:_) <- vars = jsCall "String" [JSVar arg]
570 | (LSExt ITNative ITBig) <- op
571 , (arg:_) <- vars = jsBigInt $ JSVar arg
572 | (LTrunc ITBig ITNative) <- op
573 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
574 | (LIntStr ITBig) <- op
575 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
576 | (LStrInt ITBig) <- op
577 , (arg:_) <- vars = jsBigInt $ JSVar arg
578 | LFloatStr <- op
579 , (arg:_) <- vars = jsCall "String" [JSVar arg]
580 | LStrFloat <- op
581 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
582 | (LIntFloat ITNative) <- op
583 , (arg:_) <- vars = JSVar arg
584 | (LFloatInt ITNative) <- op
585 , (arg:_) <- vars = JSVar arg
586 | (LChInt ITNative) <- op
587 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
588 | (LIntCh ITNative) <- op
589 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
591 | LFExp <- op
592 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
593 | LFLog <- op
594 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
595 | LFSin <- op
596 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
597 | LFCos <- op
598 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
599 | LFTan <- op
600 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
601 | LFASin <- op
602 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
603 | LFACos <- op
604 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
605 | LFATan <- op
606 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
607 | LFSqrt <- op
608 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
609 | LFFloor <- op
610 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
611 | LFCeil <- op
612 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
614 | LStrCons <- op
615 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
616 | LStrHead <- op
617 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
618 | LStrRev <- op
619 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
620 | LStrIndex <- op
621 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
622 | LStrTail <- op
623 , (arg:_) <- vars = let v = translateVariableName arg in
624 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
625 where
626 translateBinaryOp :: String -> LVar -> LVar -> JS
627 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
629 invokeMeth :: LVar -> String -> [LVar] -> JS
630 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
632translateExpression (SError msg) =
633 JSError msg
635translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
636 jsCall (idrRTNamespace ++ "print") [JSVar var]
638translateExpression (SForeign _ _ fun args) =
639 ffi fun (map generateWrapper args)
640 where
641 generateWrapper (ffunc, name)
642 | FFunction <- ffunc =
643 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
644 | FFunctionIO <- ffunc =
645 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
647 generateWrapper (_, name) =
648 translateVariableName name
650translateExpression patterncase
651 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
652 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
653 where
654 caseHelper var cases param =
655 JSApp (JSFunction [param] (
656 JSCond $ map (expandCase param . translateCaseCond param) cases
657 )) [JSVar var]
659 expandCase :: String -> (Cond, JS) -> (JS, JS)
660 expandCase _ (RawCond cond, branch) = (cond, branch)
661 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
662 expandCase var (CaseCond caseTy, branch)
663 | ConCase tag <- caseTy =
664 let checkCon = JSRaw var `jsInstanceOf` jsCon
665 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
666 (checkCon `jsAnd` checkTag, branch)
668 | TypeCase ty <- caseTy =
669 let checkTy = JSRaw var `jsInstanceOf` jsType
670 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
671 (checkTy `jsAnd` checkTag, branch)
673translateExpression (SCon i name vars) =
674 JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
675 , JSArray $ map JSVar vars
676 ]
678translateExpression (SUpdate var e) =
679 JSAssign (JSVar var) (translateExpression e)
681translateExpression (SProj var i) =
682 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
684translateExpression SNothing = JSNull
686translateExpression e =
687 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
689data FFI = FFICode Char | FFIArg Int | FFIError String
691ffi :: String -> [String] -> JS
692ffi code args = let parsed = ffiParse code in
693 case ffiError parsed of
694 Just err -> JSError err
695 Nothing -> JSRaw $ renderFFI parsed args
696 where
697 ffiParse :: String -> [FFI]
698 ffiParse "" = []
699 ffiParse ['%'] = [FFIError "Invalid positional argument"]
700 ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
701 ffiParse ('%':s:ss)
702 | isDigit s =
703 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
704 | otherwise =
705 [FFIError "Invalid positional argument"]
706 ffiParse (s:ss) = FFICode s : ffiParse ss
708 ffiError :: [FFI] -> Maybe String
709 ffiError [] = Nothing
710 ffiError ((FFIError s):xs) = Just s
711 ffiError (x:xs) = ffiError xs
713 renderFFI :: [FFI] -> [String] -> String
714 renderFFI [] _ = ""
715 renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
716 renderFFI ((FFIArg i) : fs) args
717 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
718 | otherwise = "Argument index out of bounds"
720data CaseType = ConCase Int
721 | TypeCase JSType
722 | DefaultCase
723 deriving Eq
725data Cond = CaseCond CaseType
726 | RawCond JS
728translateCaseCond :: String -> SAlt -> (Cond, JS)
729translateCaseCond _ cse@(SDefaultCase _) =
730 (CaseCond DefaultCase, translateCase Nothing cse)
732translateCaseCond var cse@(SConstCase ty _)
733 | StrType <- ty = matchHelper JSStringTy
734 | PtrType <- ty = matchHelper JSPtrTy
735 | Forgot <- ty = matchHelper JSForgotTy
736 | (AType ATFloat) <- ty = matchHelper JSFloatTy
737 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
738 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
739 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
740 where
741 matchHelper :: JSType -> (Cond, JS)
742 matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
744translateCaseCond var cse@(SConstCase cst@(BI _) _) =
745 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
746 (RawCond cond, translateCase Nothing cse)
748translateCaseCond var cse@(SConstCase cst _) =
749 let cond = JSRaw var `jsEq` translateConstant cst in
750 (RawCond cond, translateCase Nothing cse)
752translateCaseCond var cse@(SConCase _ tag _ _ _) =
753 (CaseCond $ ConCase tag, translateCase (Just var) cse)
755translateCase :: Maybe String -> SAlt -> JS
756translateCase _ (SDefaultCase e) = translateExpression e
757translateCase _ (SConstCase _ e) = translateExpression e
758translateCase (Just var) (SConCase a _ _ vars e) =
759 let params = map jsVar [a .. (a + length vars)] in
760 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
761 JSThis, JSProj (JSRaw var) "vars"
762 ]