module IRTS.CodegenJavaScript (codegenJavaScript, JSTarget(..)) where
import Idris.AbsSyntax hiding (TypeCase)
import IRTS.Bytecode
import IRTS.Lang
import IRTS.Simplified
import IRTS.CodegenCommon
import Idris.Core.TT
import Paths_idris
import Util.System
import Control.Arrow
import Control.Applicative ((<$>), (<*>), pure)
import Data.Char
import Data.List
import Data.Maybe
import System.IO
import System.Directory
idrNamespace :: String
idrNamespace = "__IDR__"
idrRTNamespace = "__IDRRT__"
idrLTNamespace = "__IDRLT__"
data JSTarget = Node | JavaScript deriving Eq
data JSType = JSIntTy
| JSStringTy
| JSIntegerTy
| JSFloatTy
| JSCharTy
| JSPtrTy
| JSForgotTy
deriving Eq
data JSInteger = JSBigZero
| JSBigOne
| JSBigInt Integer
deriving Eq
data JSNum = JSInt Int
| JSFloat Double
| JSInteger JSInteger
deriving Eq
data JS = JSRaw String
| JSIdent String
| JSFunction [String] JS
| JSType JSType
| JSSeq [JS]
| JSReturn JS
| JSApp JS [JS]
| JSNew String [JS]
| JSError String
| JSBinOp String JS JS
| JSPreOp String JS
| JSPostOp String JS
| JSProj JS String
| JSVar LVar
| JSNull
| JSThis
| JSTrue
| JSFalse
| JSArray [JS]
| JSString String
| JSChar String
| JSNum JSNum
| JSAssign JS JS
| JSAlloc String (Maybe JS)
| JSIndex JS JS
| JSCond [(JS, JS)]
| JSTernary JS JS JS
| JSParens JS
| JSWhile JS JS
deriving Eq
compileJS :: JS -> String
compileJS (JSRaw code) =
code
compileJS (JSIdent ident) =
ident
compileJS (JSFunction args body) =
"function("
++ intercalate "," args
++ "){\n"
++ compileJS body
++ "\n}"
compileJS (JSType ty)
| JSIntTy <- ty = idrRTNamespace ++ "Int"
| JSStringTy <- ty = idrRTNamespace ++ "String"
| JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
| JSFloatTy <- ty = idrRTNamespace ++ "Float"
| JSCharTy <- ty = idrRTNamespace ++ "Char"
| JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
| JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
compileJS (JSSeq seq) =
intercalate ";\n" (map compileJS seq)
compileJS (JSReturn val) =
"return " ++ compileJS val
compileJS (JSApp lhs rhs)
| JSFunction {} <- lhs =
concat ["(", compileJS lhs, ")(", args, ")"]
| otherwise =
concat [compileJS lhs, "(", args, ")"]
where args :: String
args = intercalate "," $ map compileJS rhs
compileJS (JSNew name args) =
"new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
compileJS (JSError exc) =
"throw new Error(\"" ++ exc ++ "\")"
compileJS (JSBinOp op lhs rhs) =
compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
compileJS (JSProj obj field)
| JSFunction {} <- obj =
concat ["(", compileJS obj, ").", field]
| JSAssign {} <- obj =
concat ["(", compileJS obj, ").", field]
| otherwise =
compileJS obj ++ '.' : field
compileJS (JSVar var) =
translateVariableName var
compileJS JSNull =
"null"
compileJS JSThis =
"this"
compileJS JSTrue =
"true"
compileJS JSFalse =
"false"
compileJS (JSArray elems) =
"[" ++ intercalate "," (map compileJS elems) ++ "]"
compileJS (JSString str) =
show str
compileJS (JSChar chr) =
chr
compileJS (JSNum num)
| JSInt i <- num = show i
| JSFloat f <- num = show f
| JSInteger JSBigZero <- num = "__IDRRT__ZERO"
| JSInteger JSBigOne <- num = "__IDRRT__ONE"
| JSInteger (JSBigInt i) <- num = show i
compileJS (JSAssign lhs rhs) =
compileJS lhs ++ "=" ++ compileJS rhs
compileJS (JSAlloc name val) =
"var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
compileJS (JSIndex lhs rhs) =
compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
compileJS (JSCond branches) =
intercalate " else " $ map createIfBlock branches
where
createIfBlock (JSTrue, e) =
"{\n"
++ compileJS e
++ ";\n}"
createIfBlock (cond, e) =
"if (" ++ compileJS cond ++") {\n"
++ compileJS e
++ ";\n}"
compileJS (JSTernary cond true false) =
let c = compileJS cond
t = compileJS true
f = compileJS false in
"(" ++ c ++ ")?(" ++ t ++ "):(" ++ f ++ ")"
compileJS (JSParens js) =
"(" ++ compileJS js ++ ")"
compileJS (JSWhile cond body) =
"while (" ++ compileJS cond ++ ") {\n"
++ compileJS body
++ "\n}"
jsTailcall :: JS -> JS
jsTailcall call =
jsCall (idrRTNamespace ++ "tailcall") [
JSFunction [] (JSReturn call)
]
jsCall :: String -> [JS] -> JS
jsCall fun = JSApp (JSIdent fun)
jsMeth :: JS -> String -> [JS] -> JS
jsMeth obj meth =
JSApp (JSProj obj meth)
jsInstanceOf :: JS -> JS -> JS
jsInstanceOf = JSBinOp "instanceof"
jsEq :: JS -> JS -> JS
jsEq = JSBinOp "=="
jsAnd :: JS -> JS -> JS
jsAnd = JSBinOp "&&"
jsType :: JS
jsType = JSIdent $ idrRTNamespace ++ "Type"
jsCon :: JS
jsCon = JSIdent $ idrRTNamespace ++ "Con"
jsTag :: JS -> JS
jsTag obj = JSProj obj "tag"
jsTypeTag :: JS -> JS
jsTypeTag obj = JSProj obj "type"
jsBigInt :: JS -> JS
jsBigInt (JSString "0") = JSNum $ JSInteger JSBigZero
jsBigInt (JSString "1") = JSNum $ JSInteger JSBigOne
jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
jsVar :: Int -> String
jsVar = ("__var_" ++) . show
jsLet :: String -> JS -> JS -> JS
jsLet name value body =
JSApp (
JSFunction [name] (
JSReturn body
)
) [value]
jsError :: String -> JS
jsError err = JSApp (JSFunction [] (JSError err)) []
foldJS :: (JS -> a) -> (a -> a -> a) -> a -> JS -> a
foldJS tr add acc js =
fold js
where
fold js
| JSFunction args body <- js =
add (tr js) (fold body)
| JSSeq seq <- js =
add (tr js) $ foldl' add acc (map fold seq)
| JSReturn ret <- js =
add (tr js) (fold ret)
| JSApp lhs rhs <- js =
add (tr js) $ add (fold lhs) (foldl' add acc $ map fold rhs)
| JSNew _ args <- js =
add (tr js) $ foldl' add acc $ map fold args
| JSBinOp _ lhs rhs <- js =
add (tr js) $ add (fold lhs) (fold rhs)
| JSPreOp _ val <- js =
add (tr js) $ fold val
| JSPostOp _ val <- js =
add (tr js) $ fold val
| JSProj obj _ <- js =
add (tr js) (fold obj)
| JSArray vals <- js =
add (tr js) $ foldl' add acc $ map fold vals
| JSAssign lhs rhs <- js =
add (tr js) $ add (fold lhs) (fold rhs)
| JSIndex lhs rhs <- js =
add (tr js) $ add (fold lhs) (fold rhs)
| JSAlloc _ val <- js =
add (tr js) $ fromMaybe acc $ fmap fold val
| JSTernary c t f <- js =
add (tr js) $ add (fold c) (add (fold t) (fold f))
| JSParens val <- js =
add (tr js) $ fold val
| JSCond conds <- js =
add (tr js) $ foldl' add acc $ map (uncurry add . (fold *** fold)) conds
| JSWhile cond body <- js =
add (tr js) $ add (fold cond) (fold body)
| otherwise =
tr js
transformJS :: (JS -> JS) -> JS -> JS
transformJS tr js =
transformHelper js
where
transformHelper :: JS -> JS
transformHelper js
| JSFunction args body <- js = JSFunction args $ tr body
| JSSeq seq <- js = JSSeq $ map tr seq
| JSReturn ret <- js = JSReturn $ tr ret
| JSApp lhs rhs <- js = JSApp (tr lhs) $ map tr rhs
| JSNew con args <- js = JSNew con $ map tr args
| JSBinOp op lhs rhs <- js = JSBinOp op (tr lhs) (tr rhs)
| JSPreOp op val <- js = JSPreOp op (tr val)
| JSPostOp op val <- js = JSPostOp op (tr val)
| JSProj obj field <- js = JSProj (tr obj) field
| JSArray vals <- js = JSArray $ map tr vals
| JSAssign lhs rhs <- js = JSAssign (tr lhs) (tr rhs)
| JSAlloc var val <- js = JSAlloc var $ fmap tr val
| JSIndex lhs rhs <- js = JSIndex (tr lhs) (tr rhs)
| JSCond conds <- js = JSCond $ map (tr *** tr) conds
| JSTernary c t f <- js = JSTernary (tr c) (tr t) (tr f)
| JSParens val <- js = JSParens $ tr val
| JSWhile cond body <- js = JSWhile(tr cond) (tr body)
| otherwise = js
moveJSDeclToTop :: String -> [JS] -> [JS]
moveJSDeclToTop decl js = move ([], js)
where
move :: ([JS], [JS]) -> [JS]
move (front, js@(JSAlloc name _):back)
| name == decl = js : front ++ back
move (front, js:back) =
move (front ++ [js], back)
jsSubst :: JS -> JS -> JS -> JS
jsSubst var new old
| var == old = new
jsSubst (JSIdent var) new (JSVar old)
| var == translateVariableName old = new
| otherwise = JSVar old
jsSubst var new old@(JSIdent _)
| var == old = new
| otherwise = old
jsSubst var new (JSArray fields) =
JSArray (map (jsSubst var new) fields)
jsSubst var new (JSNew con vals) =
JSNew con $ map (jsSubst var new) vals
jsSubst (JSIdent var) new (JSApp (JSProj (JSFunction args body) "apply") vals)
| var `notElem` args =
JSApp (JSProj (JSFunction args (jsSubst (JSIdent var) new body)) "apply") (
map (jsSubst (JSIdent var) new) vals
)
| otherwise =
JSApp (JSProj (JSFunction args body) "apply") (
map (jsSubst (JSIdent var) new) vals
)
jsSubst (JSIdent var) new (JSApp (JSFunction [arg] body) vals)
| var /= arg =
JSApp (JSFunction [arg] (
jsSubst (JSIdent var) new body
)) $ map (jsSubst (JSIdent var) new) vals
| otherwise =
JSApp (JSFunction [arg] (
body
)) $ map (jsSubst (JSIdent var) new) vals
jsSubst var new js = transformJS (jsSubst var new) js
removeAllocations :: JS -> JS
removeAllocations (JSSeq body) =
let opt = removeHelper (map removeAllocations body) in
case opt of
[ret] -> ret
_ -> JSSeq opt
where
removeHelper :: [JS] -> [JS]
removeHelper [js] = [js]
removeHelper ((JSAlloc name (Just val@(JSIdent _))):js) =
map (jsSubst (JSIdent name) val) (removeHelper js)
removeHelper (j:js) = j : removeHelper js
removeAllocations js = transformJS removeAllocations js
isJSConstant :: JS -> Bool
isJSConstant js
| JSString _ <- js = True
| JSChar _ <- js = True
| JSNum _ <- js = True
| JSType _ <- js = True
| JSNull <- js = True
| JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
| otherwise = False
inlineJS :: JS -> JS
inlineJS (JSReturn (JSApp (JSFunction [] err@(JSError _)) [])) = err
inlineJS (JSReturn (JSApp (JSFunction ["cse"] body) [val@(JSVar _)])) =
inlineJS $ jsSubst (JSIdent "cse") val body
inlineJS (JSReturn (JSApp (JSFunction [arg] cond@(JSCond _)) [val])) =
inlineJS $ JSSeq [ JSAlloc arg (Just val)
, cond
]
inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
JSThis,JSProj var "vars"
])
| var /= JSIdent "cse" =
inlineJS $ inlineApply args body 0
where
inlineApply [] body _ = inlineJS body
inlineApply (a:as) body n =
inlineApply as (
jsSubst (JSIdent a) (JSIndex (JSProj var "vars") (JSNum (JSInt n))) body
) (n + 1)
inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
| isJSConstant val = val
inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
JSFunction [] (JSReturn val)
])
| isJSConstant val = val
inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
| JSNew con [tag, vals] <- ret
, opt <- inlineJS val =
inlineJS $ JSNew con [tag, inlineJS $ jsSubst (JSIdent arg) opt vals]
| JSNew con [JSFunction [] (JSReturn (JSApp fun vars))] <- ret
, opt <- inlineJS val =
inlineJS $ JSNew con [JSFunction [] (
JSReturn (
JSApp (
inlineJS $ jsSubst (JSIdent arg) opt fun
) (
map (inlineJS . jsSubst (JSIdent arg) opt) vars
)
)
)]
| JSApp (JSProj obj field) args <- ret
, opt <- inlineJS val =
inlineJS $ JSApp (
inlineJS $ JSProj (jsSubst (JSIdent arg) opt obj) field
) (
map (inlineJS . jsSubst (JSIdent arg) opt) args
)
| JSIndex (JSProj obj field) idx <- ret
, opt <- inlineJS val =
inlineJS $ JSIndex (JSProj (
inlineJS $ jsSubst (JSIdent arg) opt obj
) field
) (inlineJS $ jsSubst (JSIdent arg) opt idx)
| JSBinOp op lhs rhs <- ret
, opt <- inlineJS val =
inlineJS $ JSBinOp op (inlineJS $ jsSubst (JSIdent arg) opt lhs) $
(inlineJS $ jsSubst (JSIdent arg) opt rhs)
| JSApp (JSIdent fun) args <- ret
, opt <- inlineJS val =
inlineJS $ JSApp (JSIdent fun) $ map (inlineJS . jsSubst (JSIdent arg) opt) args
inlineJS js = transformJS inlineJS js
reduceJS :: [JS] -> [JS]
reduceJS js = reduceLoop [] ([], js)
funName :: JS -> String
funName (JSAlloc fun _) = fun
elimDeadLoop :: [JS] -> [JS]
elimDeadLoop js
| ret <- deadEvalApplyCases js
, ret /= js = elimDeadLoop ret
| otherwise = js
deadEvalApplyCases :: [JS] -> [JS]
deadEvalApplyCases js =
let tags = sort $ nub $ concatMap (getTags) js in
map (removeHelper tags) js
where
getTags :: JS -> [Int]
getTags = foldJS match (++) []
where
match js
| JSNew "__IDRRT__Con" [JSNum (JSInt tag), _] <- js = [tag]
| otherwise = []
removeHelper :: [Int] -> JS -> JS
removeHelper tags (JSAlloc fun (Just (
JSApp (JSFunction [] (JSSeq seq)) []))
) =
(JSAlloc fun (Just (
JSApp (JSFunction [] (JSSeq $ remover tags seq)) []))
)
removeHelper _ js = js
remover :: [Int] -> [JS] -> [JS]
remover tags (
j@(JSAssign ((JSIndex (JSIdent "t") (JSNum (JSInt tag)))) _):js
)
| tag `notElem` tags = remover tags js
remover tags (j:js) = j : remover tags js
remover _ [] = []
initConstructors :: [JS] -> [JS]
initConstructors js =
let tags = nub $ sort $ concat (map getTags js) in
rearrangePrelude $ map createConstant tags ++ replaceConstructors tags js
where
rearrangePrelude :: [JS] -> [JS]
rearrangePrelude = moveJSDeclToTop $ idrRTNamespace ++ "Con"
getTags :: JS -> [Int]
getTags = foldJS match (++) []
where
match js
| JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []] <- js = [tag]
| otherwise = []
replaceConstructors :: [Int] -> [JS] -> [JS]
replaceConstructors tags js = map (replaceHelper tags) js
where
replaceHelper :: [Int] -> JS -> JS
replaceHelper tags (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray []])
| tag `elem` tags = JSIdent ("__IDRCTR__" ++ show tag)
replaceHelper tags js = transformJS (replaceHelper tags) js
createConstant :: Int -> JS
createConstant tag =
JSAlloc ("__IDRCTR__" ++ show tag) (Just (
JSNew (idrRTNamespace ++ "Con") [JSNum (JSInt tag), JSArray []]
))
removeIDs :: [JS] -> [JS]
removeIDs js =
case partition isID js of
([], rest) -> rest
(ids, rest) -> removeIDs $ map (removeIDCall (map idFor ids)) rest
where isID :: JS -> Bool
isID (JSAlloc _ (Just (JSFunction _ (JSSeq body))))
| JSReturn (JSVar _) <- last body = True
isID _ = False
idFor :: JS -> (String, Int)
idFor (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
| JSReturn (JSVar (Loc pos)) <- last body = (fun, pos)
removeIDCall :: [(String, Int)] -> JS -> JS
removeIDCall ids (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
JSReturn (JSApp (JSIdent fun) args)
)])
| Just pos <- lookup fun ids
, pos < length args = args !! pos
removeIDCall ids (JSNew _ [JSFunction [] (
JSReturn (JSApp (JSIdent fun) args)
)])
| Just pos <- lookup fun ids
, pos < length args = args !! pos
removeIDCall ids js@(JSApp id@(JSIdent fun) args)
| Just pos <- lookup fun ids
, pos < length args = args !! pos
removeIDCall ids js = transformJS (removeIDCall ids) js
inlineFunctions :: [JS] -> [JS]
inlineFunctions js =
inlineHelper ([], js)
where
inlineHelper :: ([JS], [JS]) -> [JS]
inlineHelper (front , (JSAlloc fun (Just (JSFunction args body))):back)
| countAll fun front + countAll fun back == 0 =
inlineHelper (front, back)
| Just new <- inlineAble (
countAll fun front + countAll fun back
) fun args body =
let f = map (inline fun args new) in
inlineHelper (f front, f back)
inlineHelper (front, next:back) = inlineHelper (front ++ [next], back)
inlineHelper (front, []) = front
inlineAble :: Int -> String -> [String] -> JS -> Maybe JS
inlineAble 1 fun args body
| nonRecur fun body =
inlineAble' body
where
inlineAble' :: JS -> Maybe JS
inlineAble' (
JSReturn js@(JSNew "__IDRRT__Con" [JSNum _, JSArray vals])
)
| and $ map (\x -> isJSIdent x || isJSConstant x) vals = Just js
inlineAble' (
JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] (
JSReturn (JSApp (JSIdent _) args)
)])
)
| and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
inlineAble' (
JSReturn js@(JSIndex (JSProj (JSApp (JSIdent _) args) "vars") _)
)
| and $ map (\x -> isJSIdent x || isJSConstant x) args = Just js
inlineAble' _ = Nothing
isJSIdent js
| JSIdent _ <- js = True
| otherwise = False
inlineAble _ _ _ _ = Nothing
inline :: String -> [String] -> JS -> JS -> JS
inline fun args body js = inline' js
where
inline' :: JS -> JS
inline' (JSApp (JSIdent name) vals)
| name == fun =
let (js, phs) = insertPlaceHolders args body in
inline' $ foldr (uncurry jsSubst) js (zip phs vals)
inline' js = transformJS inline' js
insertPlaceHolders :: [String] -> JS -> (JS, [JS])
insertPlaceHolders args body = insertPlaceHolders' args body []
where
insertPlaceHolders' :: [String] -> JS -> [JS] -> (JS, [JS])
insertPlaceHolders' (a:as) body ph
| (body', ph') <- insertPlaceHolders' as body ph =
let phvar = JSIdent $ "__PH_" ++ show (length ph') in
(jsSubst (JSIdent a) phvar body', phvar : ph')
insertPlaceHolders' [] body ph = (body, ph)
nonRecur :: String -> JS -> Bool
nonRecur name body = countInvokations name body == 0
countAll :: String -> [JS] -> Int
countAll name js = sum $ map (countInvokations name) js
countInvokations :: String -> JS -> Int
countInvokations name = foldJS match (+) 0
where
match :: JS -> Int
match js
| JSApp (JSIdent ident) _ <- js
, name == ident = 1
| JSNew con _ <- js
, name == con = 1
| otherwise = 0
reduceContinuations :: JS -> JS
reduceContinuations = transformJS reduceHelper
where
reduceHelper :: JS -> JS
reduceHelper (JSNew "__IDRRT__Cont" [JSFunction [] (
JSReturn js@(JSNew "__IDRRT__Cont" [JSFunction [] body])
)]) = js
reduceHelper js = transformJS reduceHelper js
reduceConstant :: JS -> JS
reduceConstant
(JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
JSReturn (JSApp (JSIdent "__IDR__mEVAL0") [val])
)])
| JSNum num <- val = val
| JSBinOp op lhs rhs <- val =
JSParens $ JSBinOp op (reduceConstant lhs) (reduceConstant rhs)
| JSApp (JSProj lhs op) [rhs] <- val
, op `elem` [ "subtract"
, "add"
, "multiply"
, "divide"
, "mod"
, "equals"
, "lesser"
, "lesserOrEquals"
, "greater"
, "greaterOrEquals"
] = val
reduceConstant (JSApp ident [(JSParens js)]) =
JSApp ident [reduceConstant js]
reduceConstant js = transformJS reduceConstant js
reduceConstants :: JS -> JS
reduceConstants js
| ret <- reduceConstant js
, ret /= js = reduceConstants ret
| otherwise = js
elimDuplicateEvals :: JS -> JS
elimDuplicateEvals (JSAlloc fun (Just (JSFunction args (JSSeq seq)))) =
JSAlloc fun $ Just (JSFunction args $ JSSeq (elimHelper seq))
where
elimHelper :: [JS] -> [JS]
elimHelper (j@(JSAlloc var (Just val)):js) =
j : map (jsSubst val (JSIdent var)) (elimHelper js)
elimHelper (j:js) =
j : elimHelper js
elimHelper [] = []
elimDuplicateEvals js = js
optimizeRuntimeCalls :: String -> String -> [JS] -> [JS]
optimizeRuntimeCalls fun tc js =
optTC tc : map optHelper js
where
optHelper :: JS -> JS
optHelper (JSApp (JSIdent "__IDRRT__tailcall") [
JSFunction [] (JSReturn (JSApp (JSIdent n) args))
])
| n == fun = JSApp (JSIdent tc) $ map optHelper args
optHelper js = transformJS optHelper js
optTC :: String -> JS
optTC tc@"__IDRRT__EVALTC" =
JSAlloc tc (Just $ JSFunction ["arg0"] (
JSSeq [ JSAlloc "ret" $ Just (
JSTernary (
(JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
(hasProp "__IDRLT__mEVAL0" "arg0")
) (JSApp
(JSIndex
(JSIdent "__IDRLT__mEVAL0")
(JSProj (JSIdent "arg0") "tag")
)
[JSIdent "arg0"]
) (JSIdent "arg0")
)
, JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
JSAssign (JSIdent "ret") (
JSApp (JSProj (JSIdent "ret") "k") []
)
)
, JSReturn $ JSIdent "ret"
]
))
optTC tc@"__IDRRT__APPLYTC" =
JSAlloc tc (Just $ JSFunction ["fn0", "arg0"] (
JSSeq [ JSAlloc "ev" $ Just (JSApp
(JSIdent "__IDRRT__EVALTC") [JSIdent "fn0"]
)
, JSAlloc "ret" $ Just (
JSTernary (
(JSIdent "ev" `jsInstanceOf` jsCon) `jsAnd`
(hasProp "__IDRLT__mAPPLY0" "ev")
) (JSApp
(JSIndex
(JSIdent "__IDRLT__mAPPLY0")
(JSProj (JSIdent "ev") "tag")
)
[JSIdent "fn0", JSIdent "arg0", JSIdent "ev"]
) JSNull
)
, JSWhile (JSIdent "ret" `jsInstanceOf` (JSIdent "__IDRRT__Cont")) (
JSAssign (JSIdent "ret") (
JSApp (JSProj (JSIdent "ret") "k") []
)
)
, JSReturn $ JSIdent "ret"
]
))
hasProp :: String -> String -> JS
hasProp table var =
JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
unfoldLookupTable :: [JS] -> [JS]
unfoldLookupTable input =
let (evals, evalunfold) = unfoldLT "__IDRLT__mEVAL0" input
(applys, applyunfold) = unfoldLT "__IDRLT__mAPPLY0" evalunfold
js = applyunfold in
adaptRuntime $ expandCons evals applys js
where
adaptRuntime :: [JS] -> [JS]
adaptRuntime =
adaptCon . adaptApply "__var_2" . adaptApply "ev" . adaptEval
adaptApply var = map (jsSubst (
JSIndex (JSIdent "__IDRLT__mAPPLY0") (JSProj (JSIdent var) "tag")
) (JSProj (JSIdent var) "app"))
adaptEval = map (jsSubst (
JSIndex (JSIdent "__IDRLT__mEVAL0") (JSProj (JSIdent "arg0") "tag")
) (JSProj (JSIdent "arg0") "eval"))
adaptCon js =
adaptCon' [] js
where
adaptCon' front ((JSAlloc "__IDRRT__Con" (Just body)):back) =
front ++ (new:back)
adaptCon' front (next:back) =
adaptCon' (front ++ [next]) back
adaptCon' front [] = front
new =
JSAlloc "__IDRRT__Con" (Just $
JSFunction newArgs (
JSSeq (map newVar newArgs)
)
)
where
newVar var = JSAssign (JSProj JSThis var) (JSIdent var)
newArgs = ["tag", "eval", "app", "vars"]
unfoldLT :: String -> [JS] -> ([Int], [JS])
unfoldLT lt js =
let (table, code) = extractLT lt js
expanded = expandLT lt table in
(map fst expanded, map snd expanded ++ code)
expandCons :: [Int] -> [Int] -> [JS] -> [JS]
expandCons evals applys js =
map expandCons' js
where
expandCons' :: JS -> JS
expandCons' (JSNew "__IDRRT__Con" [JSNum (JSInt tag), JSArray args])
| evalid <- getId "__IDRLT__mEVAL0" tag evals
, applyid <- getId "__IDRLT__mAPPLY0" tag applys =
JSNew "__IDRRT__Con" [ JSNum (JSInt tag)
, maybe JSNull JSIdent evalid
, maybe JSNull JSIdent applyid
, JSArray (map expandCons' args)
]
expandCons' js = transformJS expandCons' js
getId :: String -> Int -> [Int] -> Maybe String
getId lt tag entries
| tag `elem` entries = Just $ ltIdentifier lt tag
| otherwise = Nothing
ltIdentifier :: String -> Int -> String
ltIdentifier "__IDRLT__mEVAL0" id = idrLTNamespace ++ "EVAL" ++ show id
ltIdentifier "__IDRLT__mAPPLY0" id = idrLTNamespace ++ "APPLY" ++ show id
extractLT :: String -> [JS] -> (JS, [JS])
extractLT lt js =
extractLT' ([], js)
where
extractLT' :: ([JS], [JS]) -> (JS, [JS])
extractLT' (front, js@(JSAlloc fun _):back)
| fun == lt = (js, front ++ back)
extractLT' (front, js:back) = extractLT' (front ++ [js], back)
expandLT :: String -> JS -> [(Int, JS)]
expandLT lt (
JSAlloc _ (Just (JSApp (JSFunction [] (JSSeq seq)) []))
) = catMaybes (map expandEntry seq)
where
expandEntry :: JS -> Maybe (Int, JS)
expandEntry (JSAssign (JSIndex _ (JSNum (JSInt id))) body) =
Just $ (id, JSAlloc (ltIdentifier lt id) (Just body))
expandEntry js = Nothing
removeInstanceChecks :: JS -> JS
removeInstanceChecks (JSCond conds) =
JSCond $ eliminateDeadBranches $ map (
removeHelper *** removeInstanceChecks
) conds
where
removeHelper (
JSBinOp "&&" (JSBinOp "instanceof" _ (JSIdent "__IDRRT__Con")) check
) = removeHelper check
removeHelper js = js
eliminateDeadBranches (e@(JSTrue, _):_) = [e]
eliminateDeadBranches [(_, js)] = [(JSTrue, js)]
eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
eliminateDeadBranches [] = []
removeInstanceChecks js = transformJS removeInstanceChecks js
reduceLoop :: [String] -> ([JS], [JS]) -> [JS]
reduceLoop reduced (cons, program) =
case partition findConstructors program of
([], js) -> cons ++ js
(candidates, rest) ->
let names = reduced ++ map funName candidates in
reduceLoop names (
cons ++ map reduce candidates, map (reduceCall names) rest
)
where findConstructors :: JS -> Bool
findConstructors js
| (JSAlloc fun (Just (JSFunction _ (JSSeq body)))) <- js =
reducable $ last body
| otherwise = False
where reducable :: JS -> Bool
reducable js
| JSReturn ret <- js = reducable ret
| JSNew _ args <- js = and $ map reducable args
| JSArray fields <- js = and $ map reducable fields
| JSNum _ <- js = True
| JSNull <- js = True
| JSIdent _ <- js = True
| otherwise = False
reduce :: JS -> JS
reduce (JSAlloc fun (Just (JSFunction _ (JSSeq body))))
| JSReturn js <- last body = (JSAlloc fun (Just js))
reduce js = js
reduceCall :: [String] -> JS -> JS
reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
JSReturn (JSApp id@(JSIdent ret) _)
)])
| ret `elem` funs = id
reduceCall funs js@(JSApp id@(JSIdent fun) _)
| fun `elem` funs = id
reduceCall funs js = transformJS (reduceCall funs) js
optimizeJS :: JS -> JS
optimizeJS = inlineLoop
where inlineLoop :: JS -> JS
inlineLoop js
| opt <- inlineJS js
, opt /= js = inlineLoop opt
| otherwise = js
codegenJavaScript
:: JSTarget
-> [(Name, SDecl)]
-> FilePath
-> OutputType
-> IO ()
codegenJavaScript target definitions filename outputType = do
let (header, runtime) = case target of
Node ->
("#!/usr/bin/env node\n", "-node")
JavaScript ->
("", "-browser")
path <- (++) <$> getDataDir <*> (pure "/jsrts/")
idrRuntime <- readFile $ path ++ "Runtime-common.js"
tgtRuntime <- readFile $ concat [path, "Runtime", runtime, ".js"]
jsbn <- readFile $ path ++ "jsbn/jsbn.js"
writeFile filename $ header ++ (
intercalate "\n" $ [ jsbn
, idrRuntime
, tgtRuntime
] ++ functions
)
setPermissions filename (emptyPermissions { readable = True
, executable = target == Node
, writable = True
})
where
def :: [(String, SDecl)]
def = map (first translateNamespace) definitions
functions :: [String]
functions = translate >>> optimize >>> compile $ def
where
translate p =
prelude ++ concatMap translateDeclaration p ++ [mainLoop, invokeLoop]
optimize p =
foldl' (flip ($)) p opt
compile =
map compileJS
opt =
[ map optimizeJS
, removeIDs
, reduceJS
, map reduceConstants
, initConstructors
, map removeAllocations
, elimDeadLoop
, map elimDuplicateEvals
, optimizeRuntimeCalls "__IDR__mEVAL0" "__IDRRT__EVALTC"
, optimizeRuntimeCalls "__IDR__mAPPLY0" "__IDRRT__APPLYTC"
, map removeInstanceChecks
, inlineFunctions
, map reduceContinuations
, unfoldLookupTable
]
prelude :: [JS]
prelude =
[ JSAlloc (idrRTNamespace ++ "Cont") (Just $ JSFunction ["k"] (
JSAssign (JSProj JSThis "k") (JSIdent "k")
))
, JSAlloc (idrRTNamespace ++ "Con") (Just $ JSFunction ["tag", "vars"] (
JSSeq [ JSAssign (JSProj JSThis "tag") (JSIdent "tag")
, JSAssign (JSProj JSThis "vars") (JSIdent "vars")
]
))
]
mainLoop :: JS
mainLoop =
JSAlloc "main" $ Just $ JSFunction [] (
case target of
Node -> mainFun
JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
JSString "DOMContentLoaded", JSFunction [] (
mainFun
), JSFalse
]
)
where
mainFun :: JS
mainFun = jsTailcall $ jsCall runMain []
runMain :: String
runMain = idrNamespace ++ translateName (sMN 0 "runMain")
invokeLoop :: JS
invokeLoop = jsCall "main" []
translateIdentifier :: String -> String
translateIdentifier =
replaceReserved . concatMap replaceBadChars
where replaceBadChars :: Char -> String
replaceBadChars c
| ' ' <- c = "_"
| '_' <- c = "__"
| isDigit c = '_' : show (ord c)
| not (isLetter c && isAscii c) = '_' : show (ord c)
| otherwise = [c]
replaceReserved s
| s `elem` reserved = '_' : s
| otherwise = s
reserved = [ "break"
, "case"
, "catch"
, "continue"
, "debugger"
, "default"
, "delete"
, "do"
, "else"
, "finally"
, "for"
, "function"
, "if"
, "in"
, "instanceof"
, "new"
, "return"
, "switch"
, "this"
, "throw"
, "try"
, "typeof"
, "var"
, "void"
, "while"
, "with"
, "class"
, "enum"
, "export"
, "extends"
, "import"
, "super"
, "implements"
, "interface"
, "let"
, "package"
, "private"
, "protected"
, "public"
, "static"
, "yield"
]
translateNamespace :: Name -> String
translateNamespace (UN _) = idrNamespace
translateNamespace (NS _ ns) = idrNamespace ++ concatMap (translateIdentifier . str) ns
translateNamespace (MN _ _) = idrNamespace
translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
translateNamespace NErased = idrNamespace
translateName :: Name -> String
translateName (UN name) = 'u' : translateIdentifier (str name)
translateName (NS name _) = 'n' : translateName name
translateName (MN i name) = 'm' : translateIdentifier (str name) ++ show i
translateName (SN name) = 's' : translateSpecialName name
translateName NErased = "e"
translateSpecialName :: SpecialName -> String
translateSpecialName name
| WhereN i m n <- name =
'w' : translateName m ++ translateName n ++ show i
| InstanceN n s <- name =
'i' : translateName n ++ concatMap (translateIdentifier . str) s
| ParentN n s <- name =
'p' : translateName n ++ translateIdentifier (str s)
| MethodN n <- name =
'm' : translateName n
| CaseN n <- name =
'c' : translateName n
translateConstant :: Const -> JS
translateConstant (I i) = JSNum (JSInt i)
translateConstant (Fl f) = JSNum (JSFloat f)
translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
translateConstant (Ch '\a') = JSChar "'\\u0007'"
translateConstant (Ch '\SO') = JSChar "'\\u000E'"
translateConstant (Ch c) = JSString [c]
translateConstant (Str s) = JSString s
translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
translateConstant StrType = JSType JSStringTy
translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
translateConstant (AType ATFloat) = JSType JSFloatTy
translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
translateConstant PtrType = JSType JSPtrTy
translateConstant Forgot = JSType JSForgotTy
translateConstant (BI i) = jsBigInt $ JSString (show i)
translateConstant c =
jsError $ "Unimplemented Constant: " ++ show c
translateDeclaration :: (String, SDecl) -> [JS]
translateDeclaration (path, SFun name params stackSize body)
| (MN _ ap) <- name
, (SLet var val next) <- body
, (SChkCase cvar cases) <- next
, ap == txt "APPLY" =
let lvar = translateVariableName var
lookup t = (JSApp
(JSIndex (JSIdent t) (JSProj (JSIdent lvar) "tag"))
[JSIdent "fn0", JSIdent "arg0", JSIdent lvar]) in
[ lookupTable [(var, "chk")] var cases
, jsDecl $ JSFunction ["fn0", "arg0"] (
JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
, JSAlloc (translateVariableName var) (
Just $ translateExpression val
)
, JSReturn $ (JSTernary (
(JSVar var `jsInstanceOf` jsCon) `jsAnd`
(hasProp lookupTableName (translateVariableName var))
) (lookup lookupTableName) JSNull)
]
)
]
| (MN _ ev) <- name
, (SChkCase var cases) <- body
, ev == txt "EVAL" =
[ lookupTable [] var cases
, jsDecl $ JSFunction ["arg0"] (JSReturn $
JSTernary (
(JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
(hasProp lookupTableName "arg0")
) (JSApp
(JSIndex (JSIdent lookupTableName) (JSProj (JSIdent "arg0") "tag"))
[JSIdent "arg0"]
) (JSIdent "arg0")
)
]
| otherwise =
let fun = translateExpression body in
[jsDecl $ jsFun fun]
where
hasProp :: String -> String -> JS
hasProp table var =
JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
caseFun aux var cse =
let (JSReturn c) = translateCase (Just (translateVariableName var)) cse in
jsFunAux aux c
getTag :: SAlt -> Maybe Int
getTag (SConCase _ tag _ _ _) = Just tag
getTag _ = Nothing
lookupTableName :: String
lookupTableName = idrLTNamespace ++ translateName name
lookupTable :: [(LVar, String)] -> LVar -> [SAlt] -> JS
lookupTable aux var cases =
JSAlloc lookupTableName $ Just (
JSApp (JSFunction [] (
JSSeq $ [
JSAlloc "t" $ Just (JSArray [])
] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
JSReturn (JSIdent "t")
]
)) []
)
where
assignEntries :: [(Int, JS)] -> [JS]
assignEntries entries =
map (\(tag, fun) ->
JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
) entries
lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
lookupEntry aux var alt = do
tag <- getTag alt
return (tag, caseFun aux var alt)
jsDecl :: JS -> JS
jsDecl = JSAlloc (path ++ translateName name) . Just
jsFun body = jsFunAux [] body
jsFunAux :: [(LVar, String)] -> JS -> JS
jsFunAux aux body =
JSFunction (p ++ map snd aux) (
JSSeq $
zipWith assignVar [0..] p ++
map assignAux aux ++
[JSReturn body]
)
where
assignVar :: Int -> String -> JS
assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
assignAux :: (LVar, String) -> JS
assignAux (Loc var, val) =
JSAlloc (jsVar var) (Just $ JSIdent val)
p :: [String]
p = map translateName params
translateVariableName :: LVar -> String
translateVariableName (Loc i) =
jsVar i
translateExpression :: SExp -> JS
translateExpression (SLet name value body) =
jsLet (translateVariableName name) (
translateExpression value
) (translateExpression body)
translateExpression (SConst cst) =
translateConstant cst
translateExpression (SV var) =
JSVar var
translateExpression (SApp tc name vars)
| False <- tc =
jsTailcall $ translateFunctionCall name vars
| True <- tc =
JSNew (idrRTNamespace ++ "Cont") [JSFunction [] (
JSReturn $ translateFunctionCall name vars
)]
where
translateFunctionCall name vars =
jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
translateExpression (SOp op vars)
| LNoOp <- op = JSVar (last vars)
| (LZExt _ ITBig) <- op = jsBigInt $ jsCall "String" [JSVar (last vars)]
| (LPlus (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
| (LMinus (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "subtract" [rhs]
| (LTimes (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "multiply" [rhs]
| (LSDiv (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
| (LSRem (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
| (LEq (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
| (LSLt (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
| (LSLe (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
| (LSGt (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
| (LSGe (ATInt ITBig)) <- op
, (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
| (LPlus ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
| (LMinus ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
| (LTimes ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
| (LSDiv ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
| (LEq ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
| (LSLt ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
| (LSLe ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
| (LSGt ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
| (LSGe ATFloat) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
| (LPlus _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
| (LMinus _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
| (LTimes _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
| (LSDiv _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
| (LSRem _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
| (LEq _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
| (LSLt _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
| (LSLe _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
| (LSGt _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
| (LSGe _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
| (LAnd _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
| (LOr _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
| (LXOr _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
| (LSHL _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
| (LASHR _) <- op
, (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
| (LCompl _) <- op
, (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
| LStrConcat <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
| LStrEq <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
| LStrLt <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
| LStrLen <- op
, (arg:_) <- vars = JSProj (JSVar arg) "length"
| (LStrInt ITNative) <- op
, (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
| (LIntStr ITNative) <- op
, (arg:_) <- vars = jsCall "String" [JSVar arg]
| (LSExt ITNative ITBig) <- op
, (arg:_) <- vars = jsBigInt $ jsCall "String" [JSVar arg]
| (LTrunc ITBig ITNative) <- op
, (arg:_) <- vars = jsMeth (JSVar arg) "intValue" []
| (LIntStr ITBig) <- op
, (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
| (LStrInt ITBig) <- op
, (arg:_) <- vars = jsBigInt $ JSVar arg
| LFloatStr <- op
, (arg:_) <- vars = jsCall "String" [JSVar arg]
| LStrFloat <- op
, (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
| (LIntFloat ITNative) <- op
, (arg:_) <- vars = JSVar arg
| (LFloatInt ITNative) <- op
, (arg:_) <- vars = JSVar arg
| (LChInt ITNative) <- op
, (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
| (LIntCh ITNative) <- op
, (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
| LFExp <- op
, (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
| LFLog <- op
, (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
| LFSin <- op
, (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
| LFCos <- op
, (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
| LFTan <- op
, (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
| LFASin <- op
, (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
| LFACos <- op
, (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
| LFATan <- op
, (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
| LFSqrt <- op
, (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
| LFFloor <- op
, (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
| LFCeil <- op
, (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
| LStrCons <- op
, (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
| LStrHead <- op
, (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
| LStrRev <- op
, (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
| LStrIndex <- op
, (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
| LStrTail <- op
, (arg:_) <- vars = let v = translateVariableName arg in
JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
| LNullPtr <- op
, (_) <- vars = JSNull
where
translateBinaryOp :: String -> LVar -> LVar -> JS
translateBinaryOp f lhs rhs = JSBinOp f (JSVar lhs) (JSVar rhs)
invokeMeth :: LVar -> String -> [LVar] -> JS
invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
translateExpression (SError msg) =
jsError msg
translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
jsCall (idrRTNamespace ++ "print") [JSVar var]
translateExpression (SForeign _ _ fun args) =
ffi fun (map generateWrapper args)
where
generateWrapper (ffunc, name)
| FFunction <- ffunc =
idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
| FFunctionIO <- ffunc =
idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
generateWrapper (_, name) =
translateVariableName name
translateExpression patterncase
| (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
| (SCase var cases) <- patterncase = caseHelper var cases "cse"
where
caseHelper var cases param =
JSApp (JSFunction [param] (
JSCond $ map (expandCase param . translateCaseCond param) cases
)) [JSVar var]
expandCase :: String -> (Cond, JS) -> (JS, JS)
expandCase _ (RawCond cond, branch) = (cond, branch)
expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
expandCase var (CaseCond caseTy, branch)
| ConCase tag <- caseTy =
let checkCon = JSIdent var `jsInstanceOf` jsCon
checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
(checkCon `jsAnd` checkTag, branch)
| TypeCase ty <- caseTy =
let checkTy = JSIdent var `jsInstanceOf` jsType
checkTag = jsTypeTag (JSIdent var) `jsEq` JSType ty in
(checkTy `jsAnd` checkTag, branch)
translateExpression (SCon i name vars) =
JSNew (idrRTNamespace ++ "Con") [ JSNum $ JSInt i
, JSArray $ map JSVar vars
]
translateExpression (SUpdate var@(Loc i) e) =
JSAssign (JSVar var) (translateExpression e)
translateExpression (SProj var i) =
JSIndex (JSProj (JSVar var) "vars") (JSNum $ JSInt i)
translateExpression SNothing = JSNull
translateExpression e =
jsError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
data FFI = FFICode Char | FFIArg Int | FFIError String
ffi :: String -> [String] -> JS
ffi code args = let parsed = ffiParse code in
case ffiError parsed of
Just err -> jsError err
Nothing -> JSRaw $ renderFFI parsed args
where
ffiParse :: String -> [FFI]
ffiParse "" = []
ffiParse ['%'] = [FFIError "Invalid positional argument"]
ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
ffiParse ('%':s:ss)
| isDigit s =
FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
| otherwise =
[FFIError "Invalid positional argument"]
ffiParse (s:ss) = FFICode s : ffiParse ss
ffiError :: [FFI] -> Maybe String
ffiError [] = Nothing
ffiError ((FFIError s):xs) = Just s
ffiError (x:xs) = ffiError xs
renderFFI :: [FFI] -> [String] -> String
renderFFI [] _ = ""
renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
renderFFI ((FFIArg i) : fs) args
| i < length args && i >= 0 = args !! i ++ renderFFI fs args
| otherwise = "Argument index out of bounds"
data CaseType = ConCase Int
| TypeCase JSType
| DefaultCase
deriving Eq
data Cond = CaseCond CaseType
| RawCond JS
translateCaseCond :: String -> SAlt -> (Cond, JS)
translateCaseCond _ cse@(SDefaultCase _) =
(CaseCond DefaultCase, translateCase Nothing cse)
translateCaseCond var cse@(SConstCase ty _)
| StrType <- ty = matchHelper JSStringTy
| PtrType <- ty = matchHelper JSPtrTy
| Forgot <- ty = matchHelper JSForgotTy
| (AType ATFloat) <- ty = matchHelper JSFloatTy
| (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
| (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
| (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
where
matchHelper :: JSType -> (Cond, JS)
matchHelper ty = (CaseCond $ TypeCase ty, translateCase Nothing cse)
translateCaseCond var cse@(SConstCase cst@(BI _) _) =
let cond = jsMeth (JSIdent var) "equals" [translateConstant cst] in
(RawCond cond, translateCase Nothing cse)
translateCaseCond var cse@(SConstCase cst _) =
let cond = JSIdent var `jsEq` translateConstant cst in
(RawCond cond, translateCase Nothing cse)
translateCaseCond var cse@(SConCase _ tag _ _ _) =
(CaseCond $ ConCase tag, translateCase (Just var) cse)
translateCase :: Maybe String -> SAlt -> JS
translateCase _ (SDefaultCase e) = JSReturn $ translateExpression e
translateCase _ (SConstCase _ e) = JSReturn $ translateExpression e
translateCase (Just var) (SConCase a _ _ vars e) =
let params = map jsVar [a .. (a + length vars)] in
JSReturn $ jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
JSThis, JSProj (JSIdent var) "vars"
]