git.iko.soy/Idris-dev
on master help sign in
Merge branch 'master' of github.com:edwinb/Idris-dev
5203e1bEdwin Brady
contribs/lib/SimpleParser/SimpleParser.idr+2−2
compare with master
unifiedsplit
@@ -97,7 +97,7 @@ many : Parser a -> Parser (List a)
97
97
98many1 p = [| p :: many p |]
98many1 p = [| p :: many p |]
99
99
100−many p = many1 p <|> pure []
100+many p = lazy (many1 p) <|> pure []
101
101
102bool : Parser Bool
102bool : Parser Bool
103bool = parseTrue <|> parseFalse
103bool = parseTrue <|> parseFalse
@@ -164,7 +164,7 @@ sepBy : Parser a -> Parser b -> Parser (List a)
164sepBy p s = sepBy1 p s <|> pure Nil
164sepBy p s = sepBy1 p s <|> pure Nil
165
165
166manyTil : Parser a -> Parser b -> Parser (List a)
166manyTil : Parser a -> Parser b -> Parser (List a)
167−manyTil p e = (e $> pure Nil) <|> [| p :: manyTil p e |]
167+manyTil p e = (e $> pure Nil) <|> lazy [| p :: manyTil p e |] <|> pure Nil
168
168
169--------------------------------------------------------------------------------
169--------------------------------------------------------------------------------
170-- Expressions
170-- Expressions
javascript/JavaScript.idr+16−13
@@ -2,12 +2,11 @@ module JavaScript
2
2
3%access public
3%access public
4
4
5−-- TODO: Get rid of this hack, and find a better way.
6private
5private
7isUndefined : Ptr -> IO Bool
6isUndefined : Ptr -> IO Bool
8isUndefined p = do
7isUndefined p = do
9 res <- mkForeign (
8 res <- mkForeign (
10− FFun "(function(arg) { return arg === undefined;})" [FPtr] FString) p
9+ FFun "%0 === undefined" [FPtr] FString) p
11 if res == "false"
10 if res == "false"
12 then (return False)
11 then (return False)
13 else (return True)
12 else (return True)
@@ -28,15 +27,15 @@ data Element : Type where
28
27
29setText : Element -> String -> IO ()
28setText : Element -> String -> IO ()
30setText (MkElem p) s =
29setText (MkElem p) s =
31− mkForeign (FFun ".textContent=" [FPtr, FString] FUnit) p s
30+ mkForeign (FFun "%0.textContent=%1" [FPtr, FString] FUnit) p s
32
31
33
32
34setOnClick : Element -> (Event -> IO Bool) -> IO ()
33setOnClick : Element -> (Event -> IO Bool) -> IO ()
35setOnClick (MkElem e) f =
34setOnClick (MkElem e) f =
36 mkForeign (
35 mkForeign (
37− FFun "['onclick']=" [ FPtr
36+ FFun "%0['onclick']=%1" [ FPtr
38− , FFunction (FAny Event) (FAny (IO Bool))
37+ , FFunction (FAny Event) (FAny (IO Bool))
39− ] FUnit) e f
38+ ] FUnit) e f
40--------------------------------------------------------------------------------
39--------------------------------------------------------------------------------
41-- Nodelists
40-- Nodelists
42--------------------------------------------------------------------------------
41--------------------------------------------------------------------------------
@@ -46,7 +45,9 @@ data NodeList : Type where
46
45
47elemAt : NodeList -> Nat -> IO (Maybe Element)
46elemAt : NodeList -> Nat -> IO (Maybe Element)
48elemAt (MkNodeList p) i = do
47elemAt (MkNodeList p) i = do
49− e <- mkForeign (FFun ".item" [FPtr, FInt] FPtr) p (prim__truncBigInt_Int (cast i))
48+ e <- mkForeign (FFun "%0.item(%1)" [FPtr, FInt] FPtr) p (
49+ prim__truncBigInt_Int (cast i)
50+ )
50 d <- isUndefined e
51 d <- isUndefined e
51 if d
52 if d
52 then return $ Just (MkElem e)
53 then return $ Just (MkElem e)
@@ -62,12 +63,13 @@ data Interval : Type where
62setInterval : (() -> IO ()) -> Float -> IO Interval
63setInterval : (() -> IO ()) -> Float -> IO Interval
63setInterval f t = do
64setInterval f t = do
64 e <- mkForeign (
65 e <- mkForeign (
65− FFun "setInterval" [FFunction FUnit (FAny (IO ())), FFloat] FPtr) f t
66+ FFun "setInterval(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr
67+ ) f t
66 return (MkInterval e)
68 return (MkInterval e)
67
69
68clearInterval : Interval -> IO ()
70clearInterval : Interval -> IO ()
69clearInterval (MkInterval p) =
71clearInterval (MkInterval p) =
70− mkForeign (FFun "clearInterval" [FPtr] FUnit) p
72+ mkForeign (FFun "clearInterval(%0)" [FPtr] FUnit) p
71
73
72--------------------------------------------------------------------------------
74--------------------------------------------------------------------------------
73-- Timeouts
75-- Timeouts
@@ -78,24 +80,25 @@ data Timeout : Type where
78setTimeout : (() -> IO ()) -> Float -> IO Timeout
80setTimeout : (() -> IO ()) -> Float -> IO Timeout
79setTimeout f t = do
81setTimeout f t = do
80 e <- mkForeign (
82 e <- mkForeign (
81− FFun "setTimeout" [FFunction FUnit (FAny (IO ())), FFloat] FPtr) f t
83+ FFun "setTimeout(%0,%1)" [FFunction FUnit (FAny (IO ())), FFloat] FPtr
84+ ) f t
82 return (MkTimeout e)
85 return (MkTimeout e)
83
86
84clearTimeout : Timeout -> IO ()
87clearTimeout : Timeout -> IO ()
85clearTimeout (MkTimeout p) =
88clearTimeout (MkTimeout p) =
86− mkForeign (FFun "clearTimeout" [FPtr] FUnit) p
89+ mkForeign (FFun "clearTimeout(%0)" [FPtr] FUnit) p
87
90
88--------------------------------------------------------------------------------
91--------------------------------------------------------------------------------
89-- Basic IO
92-- Basic IO
90--------------------------------------------------------------------------------
93--------------------------------------------------------------------------------
91alert : String -> IO ()
94alert : String -> IO ()
92alert msg =
95alert msg =
93− mkForeign (FFun "alert" [FString] FUnit) msg
96+ mkForeign (FFun "alert(%0)" [FString] FUnit) msg
94
97
95--------------------------------------------------------------------------------
98--------------------------------------------------------------------------------
96-- DOM
99-- DOM
97--------------------------------------------------------------------------------
100--------------------------------------------------------------------------------
98query : String -> IO NodeList
101query : String -> IO NodeList
99query q = do
102query q = do
100− e <- mkForeign (FFun "document.querySelectorAll" [FString] FPtr) q
103+ e <- mkForeign (FFun "document.querySelectorAll(%0)" [FString] FPtr) q
101 return (MkNodeList e)
104 return (MkNodeList e)
js/Runtime-common.js+13−5
@@ -16,11 +16,19 @@ var __IDRRT__Forgot = new __IDRRT__Type('Forgot');
16var __IDRRT__Tailcall = function(f) { this.f = f };
16var __IDRRT__Tailcall = function(f) { this.f = f };
17
17
18var __IDRRT__ffiWrap = function(fid) {
18var __IDRRT__ffiWrap = function(fid) {
19− return function(arg) {
19+ return function(){
20+ var res = fid;
21+ var i = 0;
22+ var arg;
23+ while (res instanceof __IDRRT__Con){
24+ arg = arguments[i];
20− return __IDRRT__tailcall(function(){
25+ res = __IDRRT__tailcall(function(){
21− return __IDR__APPLY0(fid, arg);
26+ return __IDR__mAPPLY0(res, arg);
22− });
27+ });
28+ ++i;
23− };
29+ }
30+ return res;
31+ }
24};
32};
25
33
26/** @constructor */
34/** @constructor */
src/IRTS/CodegenJavaScript.hs+58−68
@@ -224,7 +224,7 @@ codegenJavaScript target definitions filename outputType = do
224 ("#!/usr/bin/env node\n", "-node")
224 ("#!/usr/bin/env node\n", "-node")
225 JavaScript ->
225 JavaScript ->
226 ("", "-browser")
226 ("", "-browser")
227− path <- getDataDir
227+ path <- getDataDir
228 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
228 idrRuntime <- readFile $ path ++ "/js/Runtime-common.js"
229 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
229 tgtRuntime <- readFile $ concat [path, "/js/Runtime", runtime, ".js"]
230 writeFile filename $ intercalate "\n" $ [ header
230 writeFile filename $ intercalate "\n" $ [ header
@@ -246,19 +246,22 @@ codegenJavaScript target definitions filename outputType = do
246 mainLoop :: String
246 mainLoop :: String
247 mainLoop = compileJS $
247 mainLoop = compileJS $
248 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
248 JSSeq [ JSAlloc "main" $ Just $ JSFunction [] (
249− jsTailcall $ jsCall "__IDR__runMain0" []
249+ jsTailcall $ jsCall mainFun []
250 )
250 )
251 , jsCall "main" []
251 , jsCall "main" []
252 ]
252 ]
253
253
254+ mainFun :: String
255+ mainFun = idrNamespace ++ translateName (MN 0 "runMain")
256+
254translateIdentifier :: String -> String
257translateIdentifier :: String -> String
255translateIdentifier =
258translateIdentifier =
256 replaceReserved . concatMap replaceBadChars
259 replaceReserved . concatMap replaceBadChars
257 where replaceBadChars :: Char -> String
260 where replaceBadChars :: Char -> String
258 replaceBadChars c
261 replaceBadChars c
259− | ' ' <- c = "_"
262+ | ' ' <- c = "_"
260− | '_' <- c = "__"
263+ | '_' <- c = "__"
261− | isDigit c = "_" ++ [c] ++ "_"
264+ | isDigit c = '_' : show (ord c)
262 | not (isLetter c && isAscii c) = '_' : show (ord c)
265 | not (isLetter c && isAscii c) = '_' : show (ord c)
263 | otherwise = [c]
266 | otherwise = [c]
264 replaceReserved s
267 replaceReserved s
@@ -317,19 +320,24 @@ translateNamespace (SN name) = idrNamespace ++ translateSpecialName name
317translateNamespace NErased = idrNamespace
320translateNamespace NErased = idrNamespace
318
321
319translateName :: Name -> String
322translateName :: Name -> String
320−translateName (UN name) = translateIdentifier name
323+translateName (UN name) = 'u' : translateIdentifier name
321−translateName (NS name _) = translateName name
324+translateName (NS name _) = 'n' : translateName name
322−translateName (MN i name) = translateIdentifier name ++ show i
325+translateName (MN i name) = 'm' : translateIdentifier name ++ show i
323−translateName (SN name) = translateSpecialName name
326+translateName (SN name) = 's' : translateSpecialName name
324−translateName NErased = ""
327+translateName NErased = "e"
325
328
326translateSpecialName :: SpecialName -> String
329translateSpecialName :: SpecialName -> String
327translateSpecialName name
330translateSpecialName name
331+ | WhereN i m n <- name =
328− | WhereN i m n <- name = translateName m ++ translateName n ++ show i
332+ 'w' : translateName m ++ translateName n ++ show i
333+ | InstanceN n s <- name =
329− | InstanceN n s <- name = translateName n ++ concatMap translateIdentifier s
334+ 'i' : translateName n ++ concatMap translateIdentifier s
335+ | ParentN n s <- name =
330− | ParentN n s <- name = translateName n ++ translateIdentifier s
336+ 'p' : translateName n ++ translateIdentifier s
337+ | MethodN n <- name =
331− | MethodN n <- name = translateName n
338+ 'm' : translateName n
339+ | CaseN n <- name =
332− | CaseN n <- name = translateName n
340+ 'c' : translateName n
333
341
334translateConstant :: Const -> JS
342translateConstant :: Const -> JS
335translateConstant (I i) = JSNum (JSInt i)
343translateConstant (I i) = JSNum (JSInt i)
@@ -436,7 +444,8 @@ translateDeclaration (path, SFun name params stackSize body)
436 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
444 assignVar n s = JSAlloc (jsVar n) (Just $ JSRaw s)
437
445
438 assignAux :: (LVar, String) -> JS
446 assignAux :: (LVar, String) -> JS
447+ assignAux (var, val) =
439− assignAux (var, val) = JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
448+ JSAssign (JSRaw $ translateVariableName var) (JSRaw val)
440
449
441 p :: [String]
450 p :: [String]
442 p = map translateName params
451 p = map translateName params
@@ -626,59 +635,9 @@ translateExpression (SError msg) =
626translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
635translateExpression (SForeign _ _ "putStr" [(FString, var)]) =
627 jsCall (idrRTNamespace ++ "print") [JSVar var]
636 jsCall (idrRTNamespace ++ "print") [JSVar var]
628
637
629−translateExpression (SForeign _ _ fun args)
638+translateExpression (SForeign _ _ fun args) =
630− | "[]=" `isSuffixOf` fun
639+ ffi fun (map generateWrapper args)
631− , (obj:idx:val:[]) <- args =
632− JSRaw $ concat [object obj, index idx, assign val]
633−
634− | "[]" `isSuffixOf` fun
635− , (obj:idx:[]) <- args =
636− JSRaw $ object obj ++ index idx
637−
638− | "[" `isPrefixOf` fun && "]=" `isSuffixOf` fun
639− , (obj:val:[]) <- args =
640− JSRaw $ concat [object obj, '[' : name ++ "]", assign val]
641−
642− | "[" `isPrefixOf` fun && "]" `isSuffixOf` fun
643− , (obj:[]) <- args =
644− JSRaw $ object obj ++ '[' : name ++ "]"
645−
646− | "." `isPrefixOf` fun, "=" `isSuffixOf` fun
647− , (obj:val:[]) <- args =
648− JSRaw $ concat [object obj, field, assign val]
649−
650− | "." `isPrefixOf` fun
651− , (obj:[]) <- args =
652− JSRaw $ object obj ++ field
653−
654− | "." `isPrefixOf` fun
655− , (obj:[(FUnit, _)]) <- args =
656− JSRaw $ concat [object obj, method, "()"]
657−
658− | "." `isPrefixOf` fun
659− , (obj:as) <- args =
660− JSRaw $ concat [object obj, method, arguments as]
661−
662− | "[]=" `isSuffixOf` fun
663− , (idx:val:[]) <- args =
664− JSRaw $ concat [array, index idx, assign val]
665−
666− | "[]" `isSuffixOf` fun
667− , (idx:[]) <- args =
668− JSRaw $ array ++ index idx
669−
670− | otherwise = JSRaw $ fun ++ arguments args
671 where
640 where
672− name = filter (`notElem` "[]=") fun
673− method = name
674− field = name
675− array = name
676− object o = translateVariableName (snd o)
677− index i = "[" ++ translateVariableName (snd i) ++ "]"
678− assign v = '=' : generateWrapper v
679− arguments as =
680− '(' : intercalate "," (map generateWrapper as) ++ ")"
681−
682 generateWrapper (ffunc, name)
641 generateWrapper (ffunc, name)
683 | FFunction <- ffunc =
642 | FFunction <- ffunc =
684 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
643 idrRTNamespace ++ "ffiWrap(" ++ translateVariableName name ++ ")"
@@ -727,6 +686,37 @@ translateExpression SNothing = JSNull
727translateExpression e =
686translateExpression e =
728 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
687 JSError $ "Not yet implemented: " ++ filter (/= '\'') (show e)
729
688
689+data FFI = FFICode Char | FFIArg Int | FFIError String
690+
691+ffi :: String -> [String] -> JS
692+ffi code args = let parsed = ffiParse code in
693+ case ffiError parsed of
694+ Just err -> JSError err
695+ Nothing -> JSRaw $ renderFFI parsed args
696+ where
697+ ffiParse :: String -> [FFI]
698+ ffiParse "" = []
699+ ffiParse ['%'] = [FFIError "Invalid positional argument"]
700+ ffiParse ('%':'%':ss) = FFICode '%' : ffiParse ss
701+ ffiParse ('%':s:ss)
702+ | isDigit s =
703+ FFIArg (read $ s : takeWhile isDigit ss) : ffiParse (dropWhile isDigit ss)
704+ | otherwise =
705+ [FFIError "Invalid positional argument"]
706+ ffiParse (s:ss) = FFICode s : ffiParse ss
707+
708+ ffiError :: [FFI] -> Maybe String
709+ ffiError [] = Nothing
710+ ffiError ((FFIError s):xs) = Just s
711+ ffiError (x:xs) = ffiError xs
712+
713+ renderFFI :: [FFI] -> [String] -> String
714+ renderFFI [] _ = ""
715+ renderFFI ((FFICode c) : fs) args = c : renderFFI fs args
716+ renderFFI ((FFIArg i) : fs) args
717+ | i < length args && i >= 0 = args !! i ++ renderFFI fs args
718+ | otherwise = "Argument index out of bounds"
719+
730data CaseType = ConCase Int
720data CaseType = ConCase Int
731 | TypeCase JSType
721 | TypeCase JSType
732 | DefaultCase
722 | DefaultCase