@@ -24,12 +24,6 @@ import System.IO
2424import System.Directory
2525
2626
27−idrNamespace :: String
28−idrNamespace = "__IDR__"
29−idrRTNamespace = "__IDRRT__"
30−idrLTNamespace = "__IDRLT__"
31−idrCTRNamespace = "__IDRCTR__"
32−
3327data CompileInfo = CompileInfo { compileInfoApplyCases :: [Int]
3428 , compileInfoEvalCases :: [Int]
3529 , compileInfoNeedsBigInt :: Bool
@@ -44,16 +38,16 @@ initCompileInfo bc =
4438 lookupBigInt = any (needsBigInt . snd)
4539 where
4640 needsBigInt :: [BC] -> Bool
47− needsBigInt bc = any id $ map testBCForBigInt bc
41+ needsBigInt bc = or $ map testBCForBigInt bc
4842 where
4943 testBCForBigInt :: BC -> Bool
5044 testBCForBigInt (ASSIGNCONST _ c) =
5145 testConstForBigInt c
5246
5347 testBCForBigInt (CONSTCASE _ c d) =
54− (maybe False needsBigInt d)
55− || (any id $ map (needsBigInt . snd) c)
56− || (any id $ map (testConstForBigInt . fst) c)
48+ maybe False needsBigInt d
49+ || (or $ map (needsBigInt . snd) c)
50+ || (or $ map (testConstForBigInt . fst) c)
5751
5852 testBCForBigInt _ = False
5953
@@ -171,7 +165,7 @@ ffi code args = let parsed = ffiParse code in
171165 | isDigit s =
172166 FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
173167 | otherwise =
174− [FFIError $ "FFI - Invalid positional argument"]
168+ [FFIError "FFI - Invalid positional argument"]
175169 ffiParse (s:ss) = FFICode s : ffiParse ss
176170
177171
@@ -183,8 +177,8 @@ ffi code args = let parsed = ffiParse code in
183177
184178 renderFFI :: [FFI] -> [String] -> String
185179 renderFFI [] _ = ""
186− renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
187− renderFFI ((FFIArg i) : fs) args
180+ renderFFI (FFICode c : fs) args = c : renderFFI fs args
181+ renderFFI (FFIArg i : fs) args
188182 | i < length args && i >= 0 = args !! i ++ renderFFI fs args
189183 | otherwise = error "FFI - Argument index out of bounds"
190184
@@ -214,18 +208,18 @@ compileJS' indent (JSFunction args body) =
214208 ++ "\n}\n"
215209
216210compileJS' indent (JSType ty)
217− | JSIntTy <- ty = idrRTNamespace ++ "Int"
218− | JSStringTy <- ty = idrRTNamespace ++ "String"
219− | JSIntegerTy <- ty = idrRTNamespace ++ "Integer"
220− | JSFloatTy <- ty = idrRTNamespace ++ "Float"
221− | JSCharTy <- ty = idrRTNamespace ++ "Char"
222− | JSPtrTy <- ty = idrRTNamespace ++ "Ptr"
223− | JSForgotTy <- ty = idrRTNamespace ++ "Forgot"
211+ | JSIntTy <- ty = "i$Int"
212+ | JSStringTy <- ty = "i$String"
213+ | JSIntegerTy <- ty = "i$Integer"
214+ | JSFloatTy <- ty = "i$Float"
215+ | JSCharTy <- ty = "i$Char"
216+ | JSPtrTy <- ty = "i$Ptr"
217+ | JSForgotTy <- ty = "i$Forgot"
224218
225219compileJS' indent (JSSeq seq) =
226220 intercalate ";\n" (
227221 map (
228− ((replicate indent ' ') ++) . (compileJS' indent)
222+ (replicate indent ' ' ++) . (compileJS' indent)
229223 ) $ filter (/= JSNoop) seq
230224 ) ++ ";"
231225
@@ -284,10 +278,10 @@ compileJS' indent (JSString str) =
284278compileJS' indent (JSNum num)
285279 | JSInt i <- num = show i
286280 | JSFloat f <- num = show f
287− | JSInteger JSBigZero <- num = "__IDRRT__ZERO"
288− | JSInteger JSBigOne <- num = "__IDRRT__ONE"
281+ | JSInteger JSBigZero <- num = "i$ZERO"
282+ | JSInteger JSBigOne <- num = "i$ONE"
289283 | JSInteger (JSBigInt i) <- num = show i
290− | JSInteger (JSBigIntExpr e) <- num = "__IDRRT__bigInt(" ++ compileJS' indent e ++ ")"
284+ | JSInteger (JSBigIntExpr e) <- num = "i$bigInt(" ++ compileJS' indent e ++ ")"
291285
292286compileJS' indent (JSAssign lhs rhs) =
293287 compileJS' indent lhs ++ " = " ++ compileJS' indent rhs
@@ -318,14 +312,16 @@ compileJS' indent (JSCond branches) =
318312 ++ replicate (indent + 2) ' ' ++ compileJS' (indent + 2) e
319313 ++ ";\n" ++ replicate indent ' ' ++ "}"
320314
321−compileJS' indent (JSSwitch val [(_,seq)] Nothing) =
322− compileJS' indent seq
315+compileJS' indent (JSSwitch val [(_,JSSeq seq)] Nothing) =
316+ let (h,t) = splitAt 1 seq in
317+ (concatMap (compileJS' indent) h ++ ";\n")
318+ ++ (intercalate ";\n" $ map ((replicate indent ' ' ++) . compileJS' indent) t)
323319
324320compileJS' indent (JSSwitch val branches def) =
325321 "switch(" ++ compileJS' indent val ++ "){\n"
326322 ++ concatMap mkBranch branches
327323 ++ mkDefault def
328− ++ (replicate indent ' ') ++ "}"
324+ ++ replicate indent ' ' ++ "}"
329325 where
330326 mkBranch :: (JS, JS) -> String
331327 mkBranch (tag, code) =
@@ -359,7 +355,7 @@ compileJS' indent (JSWord word)
359355 | JSWord8 b <- word = "new Uint8Array([" ++ show b ++ "])"
360356 | JSWord16 b <- word = "new Uint16Array([" ++ show b ++ "])"
361357 | JSWord32 b <- word = "new Uint32Array([" ++ show b ++ "])"
362− | JSWord64 b <- word = idrRTNamespace ++ "bigInt(\"" ++ show b ++ "\")"
358+ | JSWord64 b <- word = "i$bigInt(\"" ++ show b ++ "\")"
363359
364360codegenJavaScript :: CodeGenerator
365361codegenJavaScript ci =
@@ -404,9 +400,9 @@ codegenJS_all target definitions includes libs filename outputType = do
404400 )
405401 writeFile filename $ runtime ++ concat code ++ main ++ invokeMain
406402 setPermissions filename (emptyPermissions { readable = True
407− , executable = target == Node
408− , writable = True
409− })
403+ , executable = target == Node
404+ , writable = True
405+ })
410406 where
411407 includeLibs :: [String] -> String
412408 includeLibs =
@@ -494,15 +490,15 @@ splitFunction (JSAlloc name (Just (JSFunction args body@(JSSeq _)))) = do
494490 where
495491 processBranches :: [(JS,JS)] -> RWS () [(Int,JS)] Int [(JS,JS)]
496492 processBranches =
497− traverse (runKleisli (arr id *** (Kleisli splitSequence)))
493+ traverse (runKleisli (arr id *** Kleisli splitSequence))
498494
499495 splitSequence :: JS -> RWS () [(Int, JS)] Int JS
500− splitSequence js@(JSSeq seq) = do
496+ splitSequence js@(JSSeq seq) =
501497 let (pre,post) = break isCall seq in
502498 case post of
503499 [] -> JSSeq <$> traverse splitCondition seq
504500 [js@(JSCond _)] -> splitCondition js
505− [js@(JSSwitch _ _ _)] -> splitCondition js
501+ [js@(JSSwitch {})] -> splitCondition js
506502 [_] -> return js
507503 (call:rest) -> do
508504 depth <- get
@@ -572,7 +568,7 @@ translateDecl info (name@(MN 0 fun), bc)
572568
573569 isCase :: BC -> Bool
574570 isCase bc
575− | CASE _ _ _ _ <- bc = True
571+ | CASE {} <- bc = True
576572 | otherwise = False
577573
578574 defaultCase :: [BC] -> [BC]
@@ -610,7 +606,7 @@ translateDecl info (name, bc) =
610606translateReg :: Reg -> JS
611607translateReg reg
612608 | RVal <- reg = jsRET
613− | Tmp <- reg = JSProj (JSIdent "vm") "reg1"
609+ | Tmp <- reg = JSRaw "//TMPREG"
614610 | L n <- reg = jsLOC n
615611 | T n <- reg = jsTOP n
616612
@@ -651,7 +647,7 @@ translateChar ch
651647 | '\\' <- ch = "\\\\"
652648 | '\"' <- ch = "\\\""
653649 | '\'' <- ch = "\\\'"
654− | ch `elem` asciiTab = "\\u00" ++ fill (showIntAtBase 16 intToDigit (ord ch) "")
650+ | ch `elem` asciiTab = "\\u00" ++ fill (showHex (ord ch) "")
655651 | otherwise = [ch]
656652 where
657653 fill :: String -> String
@@ -667,8 +663,8 @@ translateChar ch
667663
668664translateName :: Name -> String
669665translateName n = "_idris_" ++ concatMap cchar (showCG n)
670− where cchar x | isAlpha x || isDigit x = [x]
671− | otherwise = "_" ++ show (fromEnum x) ++ "_"
666+ where cchar x | isAlphaNum x = [x]
667+ | otherwise = "_" ++ show (fromEnum x) ++ "_"
672668
673669jsASSIGN :: CompileInfo -> Reg -> Reg -> JS
674670jsASSIGN _ r1 r2 = JSAssign (translateReg r1) (translateReg r2)
@@ -1538,6 +1534,5 @@ translateBC info bc
15381534 | PROJECT r l a <- bc = jsPROJECT info r l a
15391535 | OP r o a <- bc = jsOP info r o a
15401536 | ERROR e <- bc = jsERROR info e
1541− | otherwise = JSRaw $ show bc
1542− {- PROJECTINTO _ _ _ <- bc = undefined -}
1537+ | otherwise = JSRaw $ "//" ++ show bc
15431538