git.iko.soy/Idris-dev
on master help sign in
javascript: added jsident for identifiers
f2309ddraichoo
src/IRTS/CodegenJavaScript.hs+33−29
compare with master
unifiedsplit
@@ -41,6 +41,7 @@ data JSNum = JSInt Int
41 deriving Eq
41 deriving Eq
42
42
43data JS = JSRaw String
43data JS = JSRaw String
44+ | JSIdent String
44 | JSFunction [String] JS
45 | JSFunction [String] JS
45 | JSType JSType
46 | JSType JSType
46 | JSSeq [JS]
47 | JSSeq [JS]
@@ -70,6 +71,9 @@ compileJS :: JS -> String
70compileJS (JSRaw code) =
71compileJS (JSRaw code) =
71 code
72 code
72
73
74+compileJS (JSIdent ident) =
75+ ident
76+
73compileJS (JSFunction args body) =
77compileJS (JSFunction args body) =
74 "function("
78 "function("
75 ++ intercalate "," args
79 ++ intercalate "," args
@@ -179,7 +183,7 @@ jsTailcall call =
179 ]
183 ]
180
184
181jsCall :: String -> [JS] -> JS
185jsCall :: String -> [JS] -> JS
182−jsCall fun = JSApp (JSRaw fun)
186+jsCall fun = JSApp (JSIdent fun)
183
187
184jsMeth :: JS -> String -> [JS] -> JS
188jsMeth :: JS -> String -> [JS] -> JS
185jsMeth obj meth =
189jsMeth obj meth =
@@ -195,10 +199,10 @@ jsAnd :: JS -> JS -> JS
195jsAnd = JSOp "&&"
199jsAnd = JSOp "&&"
196
200
197jsType :: JS
201jsType :: JS
198−jsType = JSRaw $ idrRTNamespace ++ "Type"
202+jsType = JSIdent $ idrRTNamespace ++ "Type"
199
203
200jsCon :: JS
204jsCon :: JS
201−jsCon = JSRaw $ idrRTNamespace ++ "Con"
205+jsCon = JSIdent $ idrRTNamespace ++ "Con"
202
206
203jsTag :: JS -> JS
207jsTag :: JS -> JS
204jsTag obj = JSProj obj "tag"
208jsTag obj = JSProj obj "tag"
@@ -207,9 +211,9 @@ jsTypeTag :: JS -> JS
207jsTypeTag obj = JSProj obj "type"
211jsTypeTag obj = JSProj obj "type"
208
212
209jsBigInt :: JS -> JS
213jsBigInt :: JS -> JS
210−jsBigInt (JSString "0") = JSRaw "__IDRRT__ZERO"
214+jsBigInt (JSString "0") = JSIdent "__IDRRT__ZERO"
211−jsBigInt (JSString "1") = JSRaw "__IDRRT__ONE"
215+jsBigInt (JSString "1") = JSIdent "__IDRRT__ONE"
212−jsBigInt val = JSApp (JSRaw $ idrRTNamespace ++ "bigInt") [val]
216+jsBigInt val = JSApp (JSIdent $ idrRTNamespace ++ "bigInt") [val]
213
217
214jsVar :: Int -> String
218jsVar :: Int -> String
215jsVar = ("__var_" ++) . show
219jsVar = ("__var_" ++) . show
@@ -226,7 +230,7 @@ jsSubst :: String -> JS -> JS -> JS
226jsSubst var new (JSVar old)
230jsSubst var new (JSVar old)
227 | var == translateVariableName old = new
231 | var == translateVariableName old = new
228
232
229−jsSubst var new (JSRaw old)
233+jsSubst var new (JSIdent old)
230 | var == old = new
234 | var == old = new
231
235
232jsSubst var new (JSArray fields) =
236jsSubst var new (JSArray fields) =
@@ -240,10 +244,10 @@ jsSubst var new (JSNew con [JSFunction [] (JSReturn (JSApp fun vars))]) =
240 JSReturn $ JSApp fun (map (jsSubst var new) vars)
244 JSReturn $ JSApp fun (map (jsSubst var new) vars)
241 )]
245 )]
242
246
243−jsSubst var new (JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
247+jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
244 JSReturn (JSApp fun args)
248 JSReturn (JSApp fun args)
245 )]) =
249 )]) =
246− JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
250+ JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
247 JSReturn $ JSApp fun (map (jsSubst var new) args)
251 JSReturn $ JSApp fun (map (jsSubst var new) args)
248 )]
252 )]
249
253
@@ -273,11 +277,11 @@ inlineJS (JSApp (JSFunction [arg] (JSReturn ret)) [val])
273 JSReturn $ JSApp fun (map (jsSubst arg opt) vars)
277 JSReturn $ JSApp fun (map (jsSubst arg opt) vars)
274 )]
278 )]
275
279
276− | JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
280+ | JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
277 JSReturn (JSApp fun args)
281 JSReturn (JSApp fun args)
278 )] <- ret
282 )] <- ret
279 , opt <- inlineJS val =
283 , opt <- inlineJS val =
280− JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
284+ JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
281 JSReturn $ JSApp fun (map (jsSubst arg opt) args)
285 JSReturn $ JSApp fun (map (jsSubst arg opt) args)
282 )]
286 )]
283
287
@@ -353,13 +357,13 @@ reduceJS program =
353 funNames (JSAlloc fun _) = fun
357 funNames (JSAlloc fun _) = fun
354
358
355 reduceCall :: [String] -> JS -> JS
359 reduceCall :: [String] -> JS -> JS
356− reduceCall funs (JSApp (JSRaw "__IDRRT__tailcall") [JSFunction [] (
360+ reduceCall funs (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
357− JSReturn (JSApp (JSRaw ret) [])
361+ JSReturn (JSApp (JSIdent ret) [])
358 )])
362 )])
359− | ret `elem` funs = JSRaw ret
363+ | ret `elem` funs = JSIdent ret
360
364
361− reduceCall funs js@(JSApp (JSRaw fun) [])
365+ reduceCall funs js@(JSApp (JSIdent fun) [])
362− | fun `elem` funs = JSRaw fun
366+ | fun `elem` funs = JSIdent fun
363 | otherwise = js
367 | otherwise = js
364
368
365 reduceCall funs (JSAlloc fun (Just body)) =
369 reduceCall funs (JSAlloc fun (Just body)) =
@@ -442,7 +446,7 @@ codegenJavaScript target definitions filename outputType = do
442 JSAlloc "main" $ Just $ JSFunction [] (
446 JSAlloc "main" $ Just $ JSFunction [] (
443 case target of
447 case target of
444 Node -> mainFun
448 Node -> mainFun
445− JavaScript -> jsMeth (JSRaw "window") "addEventListener" [
449+ JavaScript -> jsMeth (JSIdent "window") "addEventListener" [
446 JSString "DOMContentLoaded", JSFunction [] (
450 JSString "DOMContentLoaded", JSFunction [] (
447 mainFun
451 mainFun
448 ), JSFalse
452 ), JSFalse
@@ -568,13 +572,13 @@ translateDeclaration (path, SFun name params stackSize body)
568 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
572 lookup = "[" ++ lvar ++ ".tag](fn0,arg0," ++ lvar ++ ")" in
569 JSSeq [ lookupTable [(var, "chk")] var cases
573 JSSeq [ lookupTable [(var, "chk")] var cases
570 , jsDecl $ JSFunction ["fn0", "arg0"] (
574 , jsDecl $ JSFunction ["fn0", "arg0"] (
571− JSSeq [ JSAlloc "__var_0" (Just $ JSRaw "fn0")
575+ JSSeq [ JSAlloc "__var_0" (Just $ JSIdent "fn0")
572 , JSReturn $ jsLet (translateVariableName var) (
576 , JSReturn $ jsLet (translateVariableName var) (
573 translateExpression val
577 translateExpression val
574 ) (JSTernary (
578 ) (JSTernary (
575 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
579 (JSVar var `jsInstanceOf` jsCon) `jsAnd`
576 (hasProp lookupTableName (translateVariableName var))
580 (hasProp lookupTableName (translateVariableName var))
577− ) (JSRaw $
581+ ) (JSIdent $
578 lookupTableName ++ lookup
582 lookupTableName ++ lookup
579 ) JSNull
583 ) JSNull
580 )
584 )
@@ -587,9 +591,9 @@ translateDeclaration (path, SFun name params stackSize body)
587 JSSeq [ lookupTable [] var cases
591 JSSeq [ lookupTable [] var cases
588 , jsDecl $ JSFunction ["arg0"] (JSReturn $
592 , jsDecl $ JSFunction ["arg0"] (JSReturn $
589 JSTernary (
593 JSTernary (
590− (JSRaw "arg0" `jsInstanceOf` jsCon) `jsAnd`
594+ (JSIdent "arg0" `jsInstanceOf` jsCon) `jsAnd`
591 (hasProp lookupTableName "arg0")
595 (hasProp lookupTableName "arg0")
592− ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSRaw "arg0")
596+ ) (JSRaw $ lookupTableName ++ "[arg0.tag](arg0)") (JSIdent "arg0")
593 )
597 )
594 ]
598 ]
595 | otherwise =
599 | otherwise =
@@ -599,7 +603,7 @@ translateDeclaration (path, SFun name params stackSize body)
599 where
603 where
600 hasProp :: String -> String -> JS
604 hasProp :: String -> String -> JS
601 hasProp table var =
605 hasProp table var =
602− JSIndex (JSRaw table) (JSProj (JSRaw var) "tag")
606+ JSIndex (JSIdent table) (JSProj (JSIdent var) "tag")
603
607
604 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
608 caseFun :: [(LVar, String)] -> LVar -> SAlt -> JS
605 caseFun aux var cse =
609 caseFun aux var cse =
@@ -619,7 +623,7 @@ translateDeclaration (path, SFun name params stackSize body)
619 JSSeq $ [
623 JSSeq $ [
620 JSAlloc "t" $ Just (JSArray [])
624 JSAlloc "t" $ Just (JSArray [])
621 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
625 ] ++ assignEntries (catMaybes $ map (lookupEntry aux var) cases) ++ [
622− JSReturn (JSRaw "t")
626+ JSReturn (JSIdent "t")
623 ]
627 ]
624 )) []
628 )) []
625 )
629 )
@@ -627,7 +631,7 @@ translateDeclaration (path, SFun name params stackSize body)
627 assignEntries :: [(Int, JS)] -> [JS]
631 assignEntries :: [(Int, JS)] -> [JS]
628 assignEntries entries =
632 assignEntries entries =
629 map (\(tag, fun) ->
633 map (\(tag, fun) ->
630− JSAssign (JSIndex (JSRaw "t") (JSNum $ JSInt tag)) fun
634+ JSAssign (JSIndex (JSIdent "t") (JSNum $ JSInt tag)) fun
631 ) entries
635 ) entries
632
636
633 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
637 lookupEntry :: [(LVar, String)] -> LVar -> SAlt -> Maybe (Int, JS)
@@ -657,11 +661,11 @@ translateDeclaration (path, SFun name params stackSize body)
657 allocVar n = JSAlloc (jsVar n) Nothing
661 allocVar n = JSAlloc (jsVar n) Nothing
658
662
659 assignVar :: Int -> String -> JS
663 assignVar :: Int -> String -> JS
660− assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
664+ assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
661
665
662 assignAux :: (LVar, String) -> JS
666 assignAux :: (LVar, String) -> JS
663 assignAux (var, val) =
667 assignAux (var, val) =
664− JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
668+ JSAssign (JSIdent $ translateVariableName var) (JSIdent val)
665
669
666 p :: [String]
670 p :: [String]
667 p = map translateName params
671 p = map translateName params
@@ -830,7 +834,7 @@ translateExpression (SOp op vars)
830 | LStrCons <- op
834 | LStrCons <- op
831 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
835 , (lhs:rhs:_) <- vars = translateBinaryOp "+" lhs rhs
832 | LStrHead <- op
836 | LStrHead <- op
833− , (arg:_) <- vars = JSIndex (JSVar arg) (JSRaw "0")
837+ , (arg:_) <- vars = JSIndex (JSVar arg) (JSNum (JSInt 0))
834 | LStrRev <- op
838 | LStrRev <- op
835 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
839 , (arg:_) <- vars = JSProj (JSVar arg) "split('').reverse().join('')"
836 | LStrIndex <- op
840 | LStrIndex <- op
@@ -877,8 +881,8 @@ translateExpression patterncase
877 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
881 expandCase _ (CaseCond DefaultCase, branch) = (JSTrue , branch)
878 expandCase var (CaseCond caseTy, branch)
882 expandCase var (CaseCond caseTy, branch)
879 | ConCase tag <- caseTy =
883 | ConCase tag <- caseTy =
880− let checkCon = JSRaw var `jsInstanceOf` jsCon
884+ let checkCon = JSIdent var `jsInstanceOf` jsCon
881− checkTag = (JSRaw $ show tag) `jsEq` jsTag (JSRaw var) in
885+ checkTag = (JSNum $ JSInt tag) `jsEq` jsTag (JSIdent var) in
882 (checkCon `jsAnd` checkTag, branch)
886 (checkCon `jsAnd` checkTag, branch)
883
887
884 | TypeCase ty <- caseTy =
888 | TypeCase ty <- caseTy =