git.iko.soy/Idris-dev
on 417f040 help sign in
Idris-dev/src/IRTS/CodegenJavaScript.hs
674 lines 21 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 System.IO
18import System.Directory
20idrNamespace :: String
21idrNamespace = "__IDR__"
22idrRTNamespace = "__IDRRT__"
24data JSTarget = Node | JavaScript deriving Eq
26data JSType = JSIntTy
27 | JSStringTy
28 | JSIntegerTy
29 | JSFloatTy
30 | JSCharTy
31 | JSPtrTy
32 | JSForgotTy
33 deriving Eq
35data JSNum = JSInt Int
36 | JSFloat Double
37 | JSInteger Integer
39data JS = JSRaw String
40 | JSFunction [String] JS
41 | JSType JSType
42 | JSSeq [JS]
43 | JSReturn JS
44 | JSApp JS [JS]
45 | JSNew String [JS]
46 | JSError String
47 | JSOp String JS JS
48 | JSProj JS String
49 | JSVar LVar
50 | JSNull
51 | JSThis
52 | JSTrue
53 | JSArray [JS]
54 | JSObject [(String, JS)]
55 | JSString String
56 | JSNum JSNum
57 | JSAssign JS JS
58 | JSAlloc String (Maybe JS)
59 | JSIndex JS JS
60 | JSCond [(JS, JS)]
62compileJS :: JS -> String
63compileJS (JSRaw code) =
64 code
66compileJS (JSFunction args body) =
67 "function("
68 ++ intercalate "," args
69 ++ "){\n"
70 ++ compileJS body
71 ++ "\n}"
73compileJS (JSType ty)
74 | JSIntTy <- ty = idrRTNamespace ++ "Int"
75 | JSStringTy <- ty = idrRTNamespace ++ "String"
76 | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
77 | JSFloatTy <- ty = idrRTNamespace ++ "Float"
78 | JSCharTy <- ty = idrRTNamespace ++ "Char"
79 | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
80 | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
82compileJS (JSSeq seq) =
83 intercalate ";\n" (map compileJS seq)
85compileJS (JSReturn val) =
86 "return " ++ compileJS val
88compileJS (JSApp lhs rhs)
89 | JSFunction {} <- lhs =
90 concat ["(", compileJS lhs, ")(", args, ")"]
91 | otherwise =
92 concat [compileJS lhs, "(", args, ")"]
93 where args :: String
94 args = intercalate "," $ map compileJS rhs
96compileJS (JSNew name args) =
97 "new " ++ name ++ "(" ++ intercalate "," (map compileJS args) ++ ")"
99compileJS (JSError exc) =
100 "(function(){throw '" ++ exc ++ "';})()"
102compileJS (JSOp op lhs rhs) =
103 compileJS lhs ++ " " ++ op ++ " " ++ compileJS rhs
105compileJS (JSProj obj field)
106 | JSFunction {} <- obj =
107 concat ["(", compileJS obj, ").", field]
108 | otherwise =
109 compileJS obj ++ '.' : field
111compileJS (JSVar var) =
112 translateVariableName var
114compileJS JSNull =
115 "null"
117compileJS JSThis =
118 "this"
120compileJS JSTrue =
121 "true"
123compileJS (JSArray elems) =
124 "[" ++ intercalate "," (map compileJS elems) ++ "]"
126compileJS (JSObject fields) =
127 "{" ++ intercalate ",\n" (map compileField fields) ++ "}"
128 where
129 compileField :: (String, JS) -> String
130 compileField (name, val) = '\'' : name ++ "' : " ++ compileJS val
132compileJS (JSString str) =
133 show str
135compileJS (JSNum num)
136 | JSInt i <- num = show i
137 | JSFloat f <- num = show f
138 | JSInteger i <- num = show i
140compileJS (JSAssign lhs rhs) =
141 compileJS lhs ++ "=" ++ compileJS rhs
143compileJS (JSAlloc name val) =
144 "var " ++ name ++ maybe "" ((" = " ++) . compileJS) val
146compileJS (JSIndex lhs rhs) =
147 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
149compileJS (JSCond branches) =
150 intercalate " else " $ map createIfBlock branches
151 where
152 createIfBlock (cond, e) =
153 "if (" ++ compileJS cond ++") {\n"
154 ++ "return " ++ compileJS e
155 ++ ";\n}"
157jsTailcall :: JS -> JS
158jsTailcall call =
159 jsCall (idrRTNamespace ++ "tailcall") [
160 JSFunction [] (JSReturn call)
161 ]
163jsCall :: String -> [JS] -> JS
164jsCall fun = JSApp (JSRaw fun)
166jsMeth :: JS -> String -> [JS] -> JS
167jsMeth obj meth =
168 JSApp (JSProj obj meth)
170jsInstanceOf :: JS -> JS -> JS
171jsInstanceOf = JSOp "instanceof"
173jsEq :: JS -> JS -> JS
174jsEq = JSOp "=="
176jsAnd :: JS -> JS -> JS
177jsAnd = JSOp "&&"
179jsType :: JS
180jsType = JSRaw $ idrRTNamespace ++ "Type"
182jsCon :: JS
183jsCon = JSRaw $ idrRTNamespace ++ "Con"
185jsTag :: JS -> JS
186jsTag obj = (JSProj obj "tag")
188jsTypeTag :: JS -> JS
189jsTypeTag obj = (JSProj obj "type")
191jsBigInt :: JS -> JS
192jsBigInt val =
193 JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
195jsVar :: Int -> String
196jsVar = ("__var_" ++) . show
198codegenJavaScript
199 :: JSTarget
200 -> [(Name, SDecl)]
201 -> FilePath
202 -> OutputType
203 -> IO ()
204codegenJavaScript target definitions filename outputType = do
205 let (header, runtime) = case target of
206 Node ->
207 ("#!/usr/bin/env node\n", "-node")
208 JavaScript ->
209 ("", "-browser")
210 path <- getDataDir
211 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
212 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
213 writeFile filename $ intercalate "\n" $ [ header
214 , idrRuntime
215 , tgtRuntime
216 ] ++ functions ++ [mainLoop]
218 setPermissions filename (emptyPermissions { readable = True
219 , executable = target == Node
220 , writable = True
221 })
222 where
223 def :: [(String, SDecl)]
224 def = map (first translateNamespace) definitions
226 functions :: [String]
227 functions = map (compileJS . translateDeclaration) def
229 mainLoop :: String
230 mainLoop = compileJS $
231 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
232 jsTailcall $ jsCall "__IDR__runMain0" []
233 )
234 , jsCall "main" []
235 ]
237translateIdentifier :: String -> String
238translateIdentifier =
239 replaceReserved . concatMap replaceBadChars
240 where replaceBadChars :: Char -> String
241 replaceBadChars c
242 | ' ' <- c = "_"
243 | '_' <- c = "__"
244 | isDigit c = "_" ++ [c] ++ "_"
245 | not (isLetter c && isAscii c) = '_' : show (ord c)
246 | otherwise = [c]
247 replaceReserved s
248 | s `elem` reserved = '_' : s
249 | otherwise = s
250 reserved = [ "break"
251 , "case"
252 , "catch"
253 , "continue"
254 , "debugger"
255 , "default"
256 , "delete"
257 , "do"
258 , "else"
259 , "finally"
260 , "for"
261 , "function"
262 , "if"
263 , "in"
264 , "instanceof"
265 , "new"
266 , "return"
267 , "switch"
268 , "this"
269 , "throw"
270 , "try"
271 , "typeof"
272 , "var"
273 , "void"
274 , "while"
275 , "with"
277 , "class"
278 , "enum"
279 , "export"
280 , "extends"
281 , "import"
282 , "super"
284 , "implements"
285 , "interface"
286 , "let"
287 , "package"
288 , "private"
289 , "protected"
290 , "public"
291 , "static"
292 , "yield"
293 ]
295translateNamespace :: Name -> String
296translateNamespace (UN _) = idrNamespace
297translateNamespace (NS _ ns) = idrNamespace ++ concatMap translateIdentifier ns
298translateNamespace (MN _ _) = idrNamespace
300translateName :: Name -> String
301translateName (UN name) = translateIdentifier name
302translateName (NS name _) = translateName name
303translateName (MN i name) = translateIdentifier name ++ show i
305translateConstant :: Const -> JS
306translateConstant (I i) = JSNum (JSInt i)
307translateConstant (Fl f) = JSNum (JSFloat f)
308translateConstant (Ch c) = JSString [c]
309translateConstant (Str s) = JSString s
310translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
311translateConstant StrType = JSType JSStringTy
312translateConstant (AType (ATInt ITBig)) = JSType JSIntegerTy
313translateConstant (AType ATFloat) = JSType JSFloatTy
314translateConstant (AType (ATInt ITChar)) = JSType JSCharTy
315translateConstant PtrType = JSType JSPtrTy
316translateConstant Forgot = JSType JSForgotTy
317translateConstant (BI i) = jsBigInt $ JSNum (JSInteger i)
318translateConstant c =
319 JSError $ "Unimplemented Constant: " ++ show c
321translateDeclaration :: (String, SDecl) -> JS
322translateDeclaration (path, SFun name params stackSize body) =
323 JSAlloc (path ++ translateName name) $ Just $ JSFunction p (
324 JSSeq $
325 zipWith assignVar [0..] p ++
326 map allocVar [numP .. (numP + stackSize - 1)] ++
327 [JSReturn $ translateExpression body]
328 )
329 where
330 numP :: Int
331 numP = length params
333 allocVar :: Int -> JS
334 allocVar n = JSAlloc (jsVar n) Nothing
336 assignVar :: Int -> String -> JS
337 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
339 p :: [String]
340 p = map translateParameter params
341 where
342 translateParameter :: Name -> String
343 translateParameter (MN i name) =
344 translateIdentifier name ++ show i
345 translateParameter (UN name) =
346 translateIdentifier name
348translateVariableName :: LVar -> String
349translateVariableName (Loc i) =
350 jsVar i
352translateExpression :: SExp -> JS
353translateExpression (SLet name value body) =
354 JSApp (
355 JSFunction [translateVariableName name] (
356 JSReturn $ translateExpression body
357 )
358 ) [translateExpression value]
360translateExpression (SConst cst) =
361 translateConstant cst
363translateExpression (SV var) =
364 JSVar var
366translateExpression (SApp tc name vars)
367 | False <- tc =
368 jsTailcall $ translateFunctionCall name vars
369 | True <- tc =
370 JSNew (idrRTNamespace ++ "Tailcall") [JSFunction [] (
371 JSReturn $ translateFunctionCall name vars
372 )]
373 where
374 translateFunctionCall name vars =
375 jsCall (translateNamespace name ++ translateName name) (map JSVar vars)
377translateExpression (SOp op vars)
378 | LNoOp <- op = JSVar (last vars)
380 | (LZExt _ ITBig) <- op = jsBigInt $ JSVar (last vars)
381 | (LPlus (ATInt ITBig)) <- op
382 , (lhs:rhs:_) <- vars = invokeMeth lhs "add" [rhs]
383 | (LMinus (ATInt ITBig)) <- op
384 , (lhs:rhs:_) <- vars = invokeMeth lhs "minus" [rhs]
385 | (LTimes (ATInt ITBig)) <- op
386 , (lhs:rhs:_) <- vars = invokeMeth lhs "times" [rhs]
387 | (LSDiv (ATInt ITBig)) <- op
388 , (lhs:rhs:_) <- vars = invokeMeth lhs "divide" [rhs]
389 | (LSRem (ATInt ITBig)) <- op
390 , (lhs:rhs:_) <- vars = invokeMeth lhs "mod" [rhs]
391 | (LEq (ATInt ITBig)) <- op
392 , (lhs:rhs:_) <- vars = invokeMeth lhs "equals" [rhs]
393 | (LSLt (ATInt ITBig)) <- op
394 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesser" [rhs]
395 | (LSLe (ATInt ITBig)) <- op
396 , (lhs:rhs:_) <- vars = invokeMeth lhs "lesserOrEquals" [rhs]
397 | (LSGt (ATInt ITBig)) <- op
398 , (lhs:rhs:_) <- vars = invokeMeth lhs "greater" [rhs]
399 | (LSGe (ATInt ITBig)) <- op
400 , (lhs:rhs:_) <- vars = invokeMeth lhs "greaterOrEquals" [rhs]
402 | (LPlus ATFloat) <- op
403 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
404 | (LMinus ATFloat) <- op
405 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
406 | (LTimes ATFloat) <- op
407 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
408 | (LSDiv ATFloat) <- op
409 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
410 | (LEq ATFloat) <- op
411 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
412 | (LSLt ATFloat) <- op
413 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
414 | (LSLe ATFloat) <- op
415 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
416 | (LSGt ATFloat) <- op
417 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
418 | (LSGe ATFloat) <- op
419 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
421 | (LPlus _) <- op
422 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
423 | (LMinus _) <- op
424 , (lhs:rhs:_) <- vars = translateBinaryOp "-" lhs rhs
425 | (LTimes _) <- op
426 , (lhs:rhs:_) <- vars = translateBinaryOp "*" lhs rhs
427 | (LSDiv _) <- op
428 , (lhs:rhs:_) <- vars = translateBinaryOp "/" lhs rhs
429 | (LSRem _) <- op
430 , (lhs:rhs:_) <- vars = translateBinaryOp "%" lhs rhs
431 | (LEq _) <- op
432 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
433 | (LSLt _) <- op
434 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
435 | (LSLe _) <- op
436 , (lhs:rhs:_) <- vars = translateBinaryOp "<=" lhs rhs
437 | (LSGt _) <- op
438 , (lhs:rhs:_) <- vars = translateBinaryOp ">" lhs rhs
439 | (LSGe _) <- op
440 , (lhs:rhs:_) <- vars = translateBinaryOp ">=" lhs rhs
441 | (LAnd _) <- op
442 , (lhs:rhs:_) <- vars = translateBinaryOp "&" lhs rhs
443 | (LOr _) <- op
444 , (lhs:rhs:_) <- vars = translateBinaryOp "|" lhs rhs
445 | (LXOr _) <- op
446 , (lhs:rhs:_) <- vars = translateBinaryOp "^" lhs rhs
447 | (LSHL _) <- op
448 , (lhs:rhs:_) <- vars = translateBinaryOp "<<" rhs lhs
449 | (LASHR _) <- op
450 , (lhs:rhs:_) <- vars = translateBinaryOp ">>" rhs lhs
451 | (LCompl _) <- op
452 , (arg:_) <- vars = JSRaw $ '~' : translateVariableName arg
454 | LStrConcat <- op
455 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
456 | LStrEq <- op
457 , (lhs:rhs:_) <- vars = translateBinaryOp "==" lhs rhs
458 | LStrLt <- op
459 , (lhs:rhs:_) <- vars = translateBinaryOp "<" lhs rhs
460 | LStrLen <- op
461 , (arg:_) <- vars = JSProj (JSVar arg) "length"
463 | (LStrInt ITNative) <- op
464 , (arg:_) <- vars = jsCall "parseInt" [JSVar arg]
465 | (LIntStr ITNative) <- op
466 , (arg:_) <- vars = jsCall "String" [JSVar arg]
467 | (LSExt ITNative ITBig) <- op
468 , (arg:_) <- vars = jsBigInt $ JSVar arg
469 | (LTrunc ITBig ITNative) <- op
470 , (arg:_) <- vars = jsMeth (JSVar arg) "valueOf" []
471 | (LIntStr ITBig) <- op
472 , (arg:_) <- vars = jsMeth (JSVar arg) "toString" []
473 | (LStrInt ITBig) <- op
474 , (arg:_) <- vars = jsBigInt $ JSVar arg
475 | LFloatStr <- op
476 , (arg:_) <- vars = jsCall "String" [JSVar arg]
477 | LStrFloat <- op
478 , (arg:_) <- vars = jsCall "parseFloat" [JSVar arg]
479 | (LIntFloat ITNative) <- op
480 , (arg:_) <- vars = JSVar arg
481 | (LFloatInt ITNative) <- op
482 , (arg:_) <- vars = JSVar arg
483 | (LChInt ITNative) <- op
484 , (arg:_) <- vars = JSProj (JSVar arg) "charCodeAt(0)"
485 | (LIntCh ITNative) <- op
486 , (arg:_) <- vars = jsCall "String.fromCharCode" [JSVar arg]
488 | LFExp <- op
489 , (arg:_) <- vars = jsCall "Math.exp" [JSVar arg]
490 | LFLog <- op
491 , (arg:_) <- vars = jsCall "Math.log" [JSVar arg]
492 | LFSin <- op
493 , (arg:_) <- vars = jsCall "Math.sin" [JSVar arg]
494 | LFCos <- op
495 , (arg:_) <- vars = jsCall "Math.cos" [JSVar arg]
496 | LFTan <- op
497 , (arg:_) <- vars = jsCall "Math.tan" [JSVar arg]
498 | LFASin <- op
499 , (arg:_) <- vars = jsCall "Math.asin" [JSVar arg]
500 | LFACos <- op
501 , (arg:_) <- vars = jsCall "Math.acos" [JSVar arg]
502 | LFATan <- op
503 , (arg:_) <- vars = jsCall "Math.atan" [JSVar arg]
504 | LFSqrt <- op
505 , (arg:_) <- vars = jsCall "Math.sqrt" [JSVar arg]
506 | LFFloor <- op
507 , (arg:_) <- vars = jsCall "Math.floor" [JSVar arg]
508 | LFCeil <- op
509 , (arg:_) <- vars = jsCall "Math.ceil" [JSVar arg]
511 | LStrCons <- op
512 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
513 | LStrHead <- op
514 , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
515 | LStrRev <- op
516 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
517 | LStrIndex <- op
518 , (lhs:rhs:_) <- vars = JSIndex (JSVar lhs) (JSVar rhs)
519 | LStrTail <- op
520 , (arg:_) <- vars = let v = translateVariableName arg in
521 JSRaw $ v ++ ".substr(1," ++ v ++ ".length-1)"
522 where
523 translateBinaryOp :: String -> LVar -> LVar -> JS
524 translateBinaryOp f lhs rhs = JSOp f (JSVar lhs) (JSVar rhs)
526 invokeMeth :: LVar -> String -> [LVar] -> JS
527 invokeMeth obj meth args = jsMeth (JSVar obj) meth (map JSVar args)
529translateExpression (SError msg) =
530 JSError msg
532translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
533 jsCall (idrRTNamespace ++ "print") [JSVar var]
535translateExpression (SForeign _ _ fun args)
536 | "[]=" `isSuffixOf` fun
537 , (obj:idx:val:[]) <- args =
538 JSRaw $ concat [object obj, index idx, assign val]
540 | "[]" `isSuffixOf` fun
541 , (obj:idx:[]) <- args =
542 JSRaw $ object obj ++ index idx
544 | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
545 , (obj:val:[]) <- args =
546 JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
548 | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
549 , (obj:[]) <- args =
550 JSRaw $ object obj ++ '[' : name ++ "]"
552 | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
553 , (obj:val:[]) <- args =
554 JSRaw $ concat [object obj, field, assign val]
556 | "." `isPrefixOf` fun
557 , (obj:[]) <- args =
558 JSRaw $ object obj ++ field
560 | "." `isPrefixOf` fun
561 , (obj:[(FUnit, _)]) <- args =
562 JSRaw $ concat [object obj, method, "()"]
564 | "." `isPrefixOf` fun
565 , (obj:as) <- args =
566 JSRaw $ concat [object obj, method, arguments as]
568 | "[]=" `isSuffixOf` fun
569 , (idx:val:[]) <- args =
570 JSRaw $ concat [array, index idx, assign val]
572 | "[]" `isSuffixOf` fun
573 , (idx:[]) <- args =
574 JSRaw $ array ++ index idx
576 | otherwise = JSRaw $ fun ++ arguments args
577 where
578 name = filter (`notElem` "[]=") fun
579 method = name
580 field = name
581 array = name
582 object o = translateVariableName (snd o)
583 index i = "[" ++ translateVariableName (snd i) ++ "]"
584 assign v = '=' : generateWrapper v
585 arguments as =
586 '(' : intercalate "," (map generateWrapper as) ++ ")"
588 generateWrapper (ffunc, name)
589 | FFunction <- ffunc =
590 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
591 | FFunctionIO <- ffunc =
592 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
594 generateWrapper (_, name) =
595 translateVariableName name
597translateExpression patterncase
598 | (SChkCase var cases) <- patterncase = caseHelper var cases "chk"
599 | (SCase var cases) <- patterncase = caseHelper var cases "cse"
600 where
601 caseHelper var cases param =
602 JSApp (JSFunction [param] (
603 JSCond $ map ((expandCase param) . translateCase param) cases
604 )) [JSVar var]
606 expandCase :: String -> (Cond, JS) -> (JS, JS)
607 expandCase _ (RawCond cond, branch) = (cond, branch)
608 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
609 expandCase var (CaseCond caseTy, branch)
610 | ConCase tag <- caseTy =
611 let checkCon = JSRaw var `jsInstanceOf` jsCon
612 checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
613 (checkCon `jsAnd` checkTag, branch)
615 | TypeCase ty <- caseTy =
616 let checkTy = JSRaw var `jsInstanceOf` jsType
617 checkTag = jsTypeTag (JSRaw var) `jsEq` JSType ty in
618 (checkTy `jsAnd` checkTag, branch)
620translateExpression (SCon i name vars) =
621 JSNew (idrRTNamespace ++ "Con") [ JSRaw $ show i
622 , JSArray $ map JSVar vars
623 ]
625translateExpression (SUpdate var e) =
626 JSAssign (JSVar var) (translateExpression e)
628translateExpression (SProj var i) =
629 JSIndex (JSProj (JSVar var) "vars") (JSRaw $ show i)
631translateExpression SNothing = JSNull
633translateExpression e =
634 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
636data CaseType = ConCase Int
637 | TypeCase JSType
638 | DefaultCase
639 deriving Eq
641data Cond = CaseCond CaseType
642 | RawCond JS
644translateCase :: String -> SAlt -> (Cond, JS)
645translateCase _ (SDefaultCase e) =
646 (CaseCond DefaultCase, translateExpression e)
648translateCase var (SConstCase ty e)
649 | StrType <- ty = matchHelper JSStringTy
650 | PtrType <- ty = matchHelper JSPtrTy
651 | Forgot <- ty = matchHelper JSForgotTy
652 | (AType ATFloat) <- ty = matchHelper JSFloatTy
653 | (AType (ATInt ITBig)) <- ty = matchHelper JSIntegerTy
654 | (AType (ATInt ITNative)) <- ty = matchHelper JSIntTy
655 | (AType (ATInt ITChar)) <- ty = matchHelper JSCharTy
656 where
657 matchHelper :: JSType -> (Cond, JS)
658 matchHelper ty = (CaseCond $ TypeCase ty, translateExpression e)
660translateCase var (SConstCase cst@(BI _) e) =
661 let cond = jsMeth (JSRaw var) "equals" [translateConstant cst] in
662 (RawCond cond, translateExpression e)
664translateCase var (SConstCase cst e) =
665 let cond = JSRaw var `jsEq` translateConstant cst in
666 (RawCond cond, translateExpression e)
668translateCase var (SConCase a tag name vars e) =
669 let params = map jsVar [a .. (a + length vars)] in
670 (CaseCond $ ConCase tag,
671 jsMeth (JSFunction params (JSReturn $ translateExpression e)) "apply" [
672 JSThis, JSProj (JSRaw var) "vars"
673 ]
674 )