git.iko.soy/Idris-dev
on master help sign in
Merge pull request #462 from raichoo/javascript
205ebd0Edwin Brady
src/IRTS/CodegenJavaScript.hs+189−103
compare with master
unifiedsplit
@@ -14,12 +14,14 @@ import Util.System
14import Control.Arrow
14import Control.Arrow
15import Data.Char
15import Data.Char
16import Data.List
16import Data.List
17+import Data.Maybe
17import System.IO
18import System.IO
18import System.Directory
19import System.Directory
19
20
20idrNamespace :: String
21idrNamespace :: String
21idrNamespace = "__IDR__"
22idrNamespace = "__IDR__"
22idrRTNamespace = "__IDRRT__"
23idrRTNamespace = "__IDRRT__"
24+idrLTNamespace = "__IDRLT__"
23
25
24data JSTarget = Node | JavaScript deriving Eq
26data JSTarget = Node | JavaScript deriving Eq
25
27
@@ -58,6 +60,7 @@ data JS = JSRaw String
58 | JSAlloc String (Maybe JS)
60 | JSAlloc String (Maybe JS)
59 | JSIndex JS JS
61 | JSIndex JS JS
60 | JSCond [(JS, JS)]
62 | JSCond [(JS, JS)]
63+ | JSTernary JS JS JS
61
64
62compileJS :: JS -> String
65compileJS :: JS -> String
63compileJS (JSRaw code) =
66compileJS (JSRaw code) =
@@ -154,6 +157,12 @@ compileJS (JSCond branches) =
154 ++ "return " ++ compileJS e
157 ++ "return " ++ compileJS e
155 ++ ";\n}"
158 ++ ";\n}"
156
159
160+compileJS (JSTernary cond true false) =
161+ let c = compileJS cond
162+ t = compileJS true
163+ f = compileJS false in
164+ "(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
165+
157jsTailcall :: JS -> JS
166jsTailcall :: JS -> JS
158jsTailcall call =
167jsTailcall call =
159 jsCall (idrRTNamespace ++ "tailcall") [
168 jsCall (idrRTNamespace ++ "tailcall") [
@@ -183,10 +192,10 @@ jsCon :: JS
183jsCon = JSRaw $ idrRTNamespace ++ "Con"
192jsCon = JSRaw $ idrRTNamespace ++ "Con"
184
193
185jsTag :: JS -> JS
194jsTag :: JS -> JS
186−jsTag obj = (JSProj obj "tag")
195+jsTag obj = JSProj obj "tag"
187
196
188jsTypeTag :: JS -> JS
197jsTypeTag :: JS -> JS
189−jsTypeTag obj = (JSProj obj "type")
198+jsTypeTag obj = JSProj obj "type"
190
199
191jsBigInt :: JS -> JS
200jsBigInt :: JS -> JS
192jsBigInt val =
201jsBigInt val =
@@ -195,6 +204,14 @@ jsBigInt val =
195jsVar :: Int -> String
204jsVar :: Int -> String
196jsVar = ("__var_" ++) . show
205jsVar = ("__var_" ++) . show
197
206
207+jsLet :: String -> JS -> JS -> JS
208+jsLet name value body =
209+ JSApp (
210+ JSFunction [name] (
211+ JSReturn body
212+ )
213+ ) [value]
214+
198codegenJavaScript
215codegenJavaScript
199 :: JSTarget
216 :: JSTarget
200 -> [(Name, SDecl)]
217 -> [(Name, SDecl)]
@@ -319,31 +336,98 @@ translateConstant c =
319 JSError $ "Unimplemented Constant: " ++ show c
336 JSError $ "Unimplemented Constant: " ++ show c
320
337
321translateDeclaration :: (String, SDecl) -> JS
338translateDeclaration :: (String, SDecl) -> JS
322−translateDeclaration (path, SFun name params stackSize body) =
339+translateDeclaration (path, SFun name params stackSize body)
323− JSAlloc (path ++ translateName name) $ Just $ JSFunction p (
340+ | (MN _ "APPLY") <- name
324− JSSeq $
341+ , (SLet var val next) <- body
325− zipWith assignVar [0..] p ++
342+ , (SChkCase cvar cases) <- next =
326− map allocVar [numP .. (numP + stackSize - 1)] ++
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+ ]
360+
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 =
327− [JSReturn $ translateExpression body]
372+ let fun = translateExpression body in
328− )
373+ jsDecl $ jsFun fun
374+
329 where
375 where
330− numP :: Int
376+ hasProp :: String -> String -> JS
331− numP = length params
377+ hasProp table var =
378+ jsMeth (JSRaw table) "hasOwnProperty" [JSRaw $ var ++ ".tag"]
379+
380+ caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
381+ caseFun aux var cse =
382+ jsFunAux aux (translateCase (Just (translateVariableName var)) cse)
332
383
333− allocVar :: Int -> JS
384+ getTag :: SAlt -> Maybe String
334− allocVar n = JSAlloc (jsVar n) Nothing
385+ getTag (SConCase _ tag _ _ _) = Just $ show tag
386+ getTag _ = Nothing
335
387
336− assignVar :: Int -> String -> JS
388+ lookupTableName :: String
337− assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
389+ lookupTableName = idrLTNamespace ++ translateName name
338
390
339− p :: [String]
391+ lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
340− p = map translateParameter params
392+ lookupTable aux var cases =
393+ JSAlloc lookupTableName $ Just (
394+ JSObject $ catMaybes $ map (lookupEntry aux var) cases
395+ )
341 where
396 where
342− translateParameter :: Name -> String
397+ lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (String, JS)
343− translateParameter (MN i name) =
398+ lookupEntry aux var alt = do
344− translateIdentifier name ++ show i
399+ tag <- getTag alt
345− translateParameter (UN name) =
400+ return (tag, caseFun aux var alt)
346− translateIdentifier name
401+
402+ jsDecl :: JS -> JS
403+ jsDecl = JSAlloc (path ++ translateName name) . Just
404+
405+ jsFun body = jsFunAux [] body
406+
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
419+
420+ allocVar :: Int -> JS
421+ allocVar n = JSAlloc (jsVar n) Nothing
422+
423+ assignVar :: Int -> String -> JS
424+ assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
425+
426+ assignAux :: (LVar, String) -> JS
427+ assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
428+
429+ p :: [String]
430+ p = map translateName params
347
431
348translateVariableName :: LVar -> String
432translateVariableName :: LVar -> String
349translateVariableName (Loc i) =
433translateVariableName (Loc i) =
@@ -351,11 +435,9 @@ translateVariableName (Loc i) =
351
435
352translateExpression :: SExp -> JS
436translateExpression :: SExp -> JS
353translateExpression (SLet name value body) =
437translateExpression (SLet name value body) =
354− JSApp (
355− JSFunction [translateVariableName name] (
438+ jsLet (translateVariableName name) (
356− JSReturn $ translateExpression body
357− )
358− ) [translateExpression value]
439+ translateExpression value
440+ ) (translateExpression body)
359
441
360translateExpression (SConst cst) =
442translateExpression (SConst cst) =
361 translateConstant cst
443 translateConstant cst
@@ -377,46 +459,46 @@ translateExpression (SApp tc name vars)
377translateExpression (SOp op vars)
459translateExpression (SOp op vars)
378 | LNoOp <- op = JSVar (last vars)
460 | LNoOp <- op = JSVar (last vars)
379
461
380− | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
462+ | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
381− | (LPlus (ATInt ITBig)) <- op
463+ | (LPlus (ATInt ITBig)) <- op
382− , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
464+ , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
383 | (LMinus (ATInt ITBig)) <- op
465 | (LMinus (ATInt ITBig)) <- op
384− , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
466+ , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
385 | (LTimes (ATInt ITBig)) <- op
467 | (LTimes (ATInt ITBig)) <- op
386− , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
468+ , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
387− | (LSDiv (ATInt ITBig)) <- op
469+ | (LSDiv (ATInt ITBig)) <- op
388− , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
470+ , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
389− | (LSRem (ATInt ITBig)) <- op
471+ | (LSRem (ATInt ITBig)) <- op
390− , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
472+ , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
391− | (LEq (ATInt ITBig)) <- op
473+ | (LEq (ATInt ITBig)) <- op
392− , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
474+ , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
393− | (LSLt (ATInt ITBig)) <- op
475+ | (LSLt (ATInt ITBig)) <- op
394− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
476+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
395− | (LSLe (ATInt ITBig)) <- op
477+ | (LSLe (ATInt ITBig)) <- op
396− , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
478+ , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
397− | (LSGt (ATInt ITBig)) <- op
479+ | (LSGt (ATInt ITBig)) <- op
398− , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
480+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
399− | (LSGe (ATInt ITBig)) <- op
481+ | (LSGe (ATInt ITBig)) <- op
400− , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
482+ , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
401
483
402 | (LPlus ATFloat) <- op
484 | (LPlus ATFloat) <- op
403− , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
485+ , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
404 | (LMinus ATFloat) <- op
486 | (LMinus ATFloat) <- op
405− , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
487+ , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
406 | (LTimes ATFloat) <- op
488 | (LTimes ATFloat) <- op
407− , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
489+ , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
408 | (LSDiv ATFloat) <- op
490 | (LSDiv ATFloat) <- op
409− , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
491+ , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
410− | (LEq ATFloat) <- op
492+ | (LEq ATFloat) <- op
411− , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
493+ , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
412− | (LSLt ATFloat) <- op
494+ | (LSLt ATFloat) <- op
413− , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
495+ , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
414− | (LSLe ATFloat) <- op
496+ | (LSLe ATFloat) <- op
415− , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
497+ , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
416− | (LSGt ATFloat) <- op
498+ | (LSGt ATFloat) <- op
417− , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
499+ , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
418− | (LSGe ATFloat) <- op
500+ | (LSGe ATFloat) <- op
419− , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
501+ , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
420
502
421 | (LPlus _) <- op
503 | (LPlus _) <- op
422 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
504 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
@@ -430,13 +512,13 @@ translateExpression (SOp op vars)
430 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
512 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
431 | (LEq _) <- op
513 | (LEq _) <- op
432 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
514 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
433− | (LSLt _) <- op
515+ | (LSLt _) <- op
434 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
516 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
435− | (LSLe _) <- op
517+ | (LSLe _) <- op
436 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
518 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
437− | (LSGt _) <- op
519+ | (LSGt _) <- op
438 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
520 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
439− | (LSGe _) <- op
521+ | (LSGe _) <- op
440 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
522 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
441 | (LAnd _) <- op
523 | (LAnd _) <- op
442 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
524 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
@@ -460,30 +542,30 @@ translateExpression (SOp op vars)
460 | LStrLen <- op
542 | LStrLen <- op
461 , (arg:_) <- vars = JSProj (JSVar arg) "length"
543 , (arg:_) <- vars = JSProj (JSVar arg) "length"
462
544
463− | (LStrInt ITNative) <- op
545+ | (LStrInt ITNative) <- op
464− , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
546+ , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
465− | (LIntStr ITNative) <- op
547+ | (LIntStr ITNative) <- op
466− , (arg:_) <- vars = jsCall "String" [JSVar arg]
548+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
467− | (LSExt ITNative ITBig) <- op
549+ | (LSExt ITNative ITBig) <- op
468− , (arg:_) <- vars = jsBigInt $ JSVar arg
550+ , (arg:_) <- vars = jsBigInt $ JSVar arg
469 | (LTrunc ITBig ITNative) <- op
551 | (LTrunc ITBig ITNative) <- op
470− , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
552+ , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
471− | (LIntStr ITBig) <- op
553+ | (LIntStr ITBig) <- op
472− , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
554+ , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
473− | (LStrInt ITBig) <- op
555+ | (LStrInt ITBig) <- op
474− , (arg:_) <- vars = jsBigInt $ JSVar arg
556+ , (arg:_) <- vars = jsBigInt $ JSVar arg
475− | LFloatStr <- op
557+ | LFloatStr <- op
476− , (arg:_) <- vars = jsCall "String" [JSVar arg]
558+ , (arg:_) <- vars = jsCall "String" [JSVar arg]
477− | LStrFloat <- op
559+ | LStrFloat <- op
478− , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
560+ , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
479− | (LIntFloat ITNative) <- op
561+ | (LIntFloat ITNative) <- op
480− , (arg:_) <- vars = JSVar arg
562+ , (arg:_) <- vars = JSVar arg
481− | (LFloatInt ITNative) <- op
563+ | (LFloatInt ITNative) <- op
482− , (arg:_) <- vars = JSVar arg
564+ , (arg:_) <- vars = JSVar arg
483− | (LChInt ITNative) <- op
565+ | (LChInt ITNative) <- op
484− , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
566+ , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
485− | (LIntCh ITNative) <- op
567+ | (LIntCh ITNative) <- op
486− , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
568+ , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
487
569
488 | LFExp <- op
570 | LFExp <- op
489 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
571 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
@@ -600,7 +682,7 @@ translateExpression patterncase
600 where
682 where
601 caseHelper var cases param =
683 caseHelper var cases param =
602 JSApp (JSFunction [param] (
684 JSApp (JSFunction [param] (
603− JSCond $ map ((expandCase param) . translateCase param) cases
685+ JSCond $ map (expandCase param . translateCaseCond param) cases
604 )) [JSVar var]
686 )) [JSVar var]
605
687
606 expandCase :: String -> (Cond, JS) -> (JS, JS)
688 expandCase :: String -> (Cond, JS) -> (JS, JS)
@@ -641,11 +723,11 @@ data CaseType = ConCase Int
641data Cond = CaseCond CaseType
723data Cond = CaseCond CaseType
642 | RawCond JS
724 | RawCond JS
643
725
644−translateCase :: String -> SAlt -> (Cond, JS)
726+translateCaseCond :: String -> SAlt -> (Cond, JS)
645−translateCase _ (SDefaultCase e) =
727+translateCaseCond _ cse@(SDefaultCase _) =
646− (CaseCond DefaultCase, translateExpression e)
728+ (CaseCond DefaultCase, translateCase Nothing cse)
647
729
648−translateCase var (SConstCase ty e)
730+translateCaseCond var cse@(SConstCase ty _)
649 | StrType <- ty = matchHelper JSStringTy
731 | StrType <- ty = matchHelper JSStringTy
650 | PtrType <- ty = matchHelper JSPtrTy
732 | PtrType <- ty = matchHelper JSPtrTy
651 | Forgot <- ty = matchHelper JSForgotTy
733 | Forgot <- ty = matchHelper JSForgotTy
@@ -655,20 +737,24 @@ translateCase var (SConstCase ty e)
655 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
737 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
656 where
738 where
657 matchHelper :: JSType -> (Cond, JS)
739 matchHelper :: JSType -> (Cond, JS)
658− matchHelper ty = (CaseCond $ TypeCase ty, translateExpression e)
740+ matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
659
741
660−translateCase var (SConstCase cst@(BI _) e) =
742+translateCaseCond var cse@(SConstCase cst@(BI _) _) =
661 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
743 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
662− (RawCond cond, translateExpression e)
744+ (RawCond cond, translateCase Nothing cse)
663
745
664−translateCase var (SConstCase cst e) =
746+translateCaseCond var cse@(SConstCase cst _) =
665 let cond = JSRaw var `jsEq` translateConstant cst in
747 let cond = JSRaw var `jsEq` translateConstant cst in
666− (RawCond cond, translateExpression e)
748+ (RawCond cond, translateCase Nothing cse)
667
749
750+translateCaseCond var cse@(SConCase _ tag _ _ _) =
668−translateCase var (SConCase a tag name vars e) =
751+ (CaseCond $ ConCase tag, translateCase (Just var) cse)
752+
753+translateCase :: Maybe String -> SAlt -> JS
754+translateCase _ (SDefaultCase e) = translateExpression e
755+translateCase _ (SConstCase _ e) = translateExpression e
756+translateCase (Just var) (SConCase a _ _ vars e) =
669 let params = map jsVar [a .. (a + length vars)] in
757 let params = map jsVar [a .. (a + length vars)] in
670− (CaseCond $ ConCase tag,
671− jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
758+ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
672− JSThis, JSProj (JSRaw var) "vars"
759+ JSThis, JSProj (JSRaw var) "vars"
673− ]
760+ ]
674− )