git.iko.soy/Idris-dev
on master help sign in
Merge pull request #785 from raichoo/javascript
bee7fc8Edwin Brady
idris.cabal+2−2
compare with master
unifiedsplit
@@ -14,7 +14,7 @@ Description: Idris is a general purpose language with full dependent types.
14 Dependent types allow types to be predicated on values,
14 Dependent types allow types to be predicated on values,
15 meaning that some aspects of a program's behaviour can be
15 meaning that some aspects of a program's behaviour can be
16 specified precisely in the type. The language is closely
16 specified precisely in the type. The language is closely
17− related to Epigram and Agda. There is a tutorial at
17+ related to Epigram and Agda. There is a tutorial at
18 <http://www.idris-lang.org/documentation>.
18 <http://www.idris-lang.org/documentation>.
19 Features include:
19 Features include:
20 .
20 .
@@ -462,7 +462,7 @@ Library
462 if os(freebsd)
462 if os(freebsd)
463 cpp-options: -DFREEBSD
463 cpp-options: -DFREEBSD
464 build-depends: unix
464 build-depends: unix
465− if os(dragonfly)
465+ if os(dragonfly)
466 cpp-options: -DDRAGONFLY
466 cpp-options: -DDRAGONFLY
467 build-depends: unix
467 build-depends: unix
468 if os(darwin)
468 if os(darwin)
libs/prelude/Prelude.idr+3−3
@@ -334,7 +334,7 @@ instance Traversable (Vect n) where
334 traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]
334 traverse f (x::xs) = [| Vect.(::) (f x) (traverse f xs) |]
335
335
336---- some mathematical operations
336---- some mathematical operations
337−---- XXX this should probably go some place else,
337+---- XXX this should probably go some place else,
338pow : (Num a) => a -> Nat -> a
338pow : (Num a) => a -> Nat -> a
339pow x Z = 1
339pow x Z = 1
340pow x (S n) = x * (pow x n)
340pow x (S n) = x * (pow x n)
@@ -376,7 +376,7 @@ instance Enum Integer where
376 enumFromThen n inc = n :: enumFromThen (inc + n) inc
376 enumFromThen n inc = n :: enumFromThen (inc + n) inc
377 enumFromTo n m = if n <= m
377 enumFromTo n m = if n <= m
378 then go (natRange (S (cast {to = Nat} (m - n))))
378 then go (natRange (S (cast {to = Nat} (m - n))))
379− else []
379+ else []
380 where go : List Nat -> List Integer
380 where go : List Nat -> List Integer
381 go [] = []
381 go [] = []
382 go (x :: xs) = n + cast x :: go xs
382 go (x :: xs) = n + cast x :: go xs
@@ -392,7 +392,7 @@ instance Enum Int where
392 toNat n = cast n
392 toNat n = cast n
393 fromNat n = cast n
393 fromNat n = cast n
394 enumFromThen n inc = n :: enumFromThen (inc + n) inc
394 enumFromThen n inc = n :: enumFromThen (inc + n) inc
395− enumFromTo n m = if n <= m
395+ enumFromTo n m = if n <= m
396 then go (natRange (S (cast {to = Nat} (m - n))))
396 then go (natRange (S (cast {to = Nat} (m - n))))
397 else []
397 else []
398 where go : List Nat -> List Int
398 where go : List Nat -> List Int
src/IRTS/CodegenJavaScript.hs+69−10
@@ -64,6 +64,7 @@ data JS = JSRaw String
64 | JSArray [JS]
64 | JSArray [JS]
65 | JSObject [(String, JS)]
65 | JSObject [(String, JS)]
66 | JSString String
66 | JSString String
67+ | JSChar String
67 | JSNum JSNum
68 | JSNum JSNum
68 | JSAssign JS JS
69 | JSAssign JS JS
69 | JSAlloc String (Maybe JS)
70 | JSAlloc String (Maybe JS)
@@ -153,6 +154,9 @@ compileJS (JSObject fields) =
153compileJS (JSString str) =
154compileJS (JSString str) =
154 show str
155 show str
155
156
157+compileJS (JSChar chr) =
158+ chr
159+
156compileJS (JSNum num)
160compileJS (JSNum num)
157 | JSInt i <- num = show i
161 | JSInt i <- num = show i
158 | JSFloat f <- num = show f
162 | JSFloat f <- num = show f
@@ -170,8 +174,16 @@ compileJS (JSIndex lhs rhs) =
170 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
174 compileJS lhs ++ "[" ++ compileJS rhs ++ "]"
171
175
172compileJS (JSCond branches) =
176compileJS (JSCond branches) =
173− intercalate " else " $ map createIfBlock branches
177+ intercalate " else " $ map createIfBlock (eliminateDeadBranches branches)
174 where
178 where
179+ eliminateDeadBranches (e@(JSTrue, _):_) = [e]
180+ eliminateDeadBranches (x:xs) = x : eliminateDeadBranches xs
181+ eliminateDeadBranches [] = []
182+
183+ createIfBlock (JSTrue, e) =
184+ "{\n"
185+ ++ "return " ++ compileJS e
186+ ++ ";\n}"
175 createIfBlock (cond, e) =
187 createIfBlock (cond, e) =
176 "if (" ++ compileJS cond ++") {\n"
188 "if (" ++ compileJS cond ++") {\n"
177 ++ "return " ++ compileJS e
189 ++ "return " ++ compileJS e
@@ -233,6 +245,7 @@ jsLet name value body =
233 )
245 )
234 ) [value]
246 ) [value]
235
247
248+
236jsSubst :: String -> JS -> JS -> JS
249jsSubst :: String -> JS -> JS -> JS
237jsSubst var new (JSVar old)
250jsSubst var new (JSVar old)
238 | var == translateVariableName old = new
251 | var == translateVariableName old = new
@@ -260,6 +273,16 @@ jsSubst var new (JSApp (JSIdent "__IDRRT__tailcall") [JSFunction [] (
260 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
273 JSReturn $ JSApp (jsSubst var new fun) (map (jsSubst var new) args)
261 )]
274 )]
262
275
276+jsSubst var new (JSApp (JSProj (JSFunction args body) "apply") vals)
277+ | var `notElem` args =
278+ JSApp (JSProj (JSFunction args (jsSubst var new body)) "apply") (
279+ map (jsSubst var new) vals
280+ )
281+ | otherwise =
282+ JSApp (JSProj (JSFunction args body) "apply") (
283+ map (jsSubst var new) vals
284+ )
285+
263jsSubst var new (JSApp (JSProj obj field) args) =
286jsSubst var new (JSApp (JSProj obj field) args) =
264 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
287 JSApp (JSProj (jsSubst var new obj) field) $ map (jsSubst var new) args
265
288
@@ -293,7 +316,38 @@ jsSubst var new (JSCond conds) =
293
316
294jsSubst _ _ js = js
317jsSubst _ _ js = js
295
318
319+
320+isJSConstant :: JS -> Bool
321+isJSConstant js
322+ | JSString _ <- js = True
323+ | JSChar _ <- js = True
324+ | JSNum _ <- js = True
325+ | JSType _ <- js = True
326+
327+ | JSApp (JSIdent "__IDRRT__bigInt") _ <- js = True
328+ | otherwise = False
329+
296inlineJS :: JS -> JS
330inlineJS :: JS -> JS
331+inlineJS (JSApp (JSProj (JSFunction args (JSReturn body)) "apply") [
332+ JSThis,JSProj (JSIdent var) "vars"
333+ ])
334+ | var /= "cse" =
335+ inlineApply args body 0
336+ where
337+ inlineApply [] body _ = body
338+ inlineApply (a:as) body n =
339+ inlineApply as (
340+ jsSubst a (JSIndex (JSProj (JSIdent var) "vars") (JSNum (JSInt n))) body
341+ ) (n + 1)
342+
343+inlineJS (JSApp (JSIdent "__IDR__mEVAL0") [val])
344+ | isJSConstant val = val
345+
346+inlineJS (JSApp (JSIdent "__IDRRT__tailcall") [
347+ JSFunction [] (JSReturn val)
348+ ])
349+ | isJSConstant val = val
350+
297inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
351inlineJS (JSApp (JSFunction [] (JSSeq ret)) []) =
298 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
352 JSApp (JSFunction [] (JSSeq (map inlineJS ret))) []
299
353
@@ -365,6 +419,9 @@ inlineJS (JSCond cases) =
365inlineJS (JSObject fields) =
419inlineJS (JSObject fields) =
366 JSObject (map (second inlineJS) fields)
420 JSObject (map (second inlineJS) fields)
367
421
422+inlineJS (JSOp op lhs rhs) =
423+ JSOp op (inlineJS lhs) (inlineJS rhs)
424+
368inlineJS js = js
425inlineJS js = js
369
426
370reduceJS :: [JS] -> [JS]
427reduceJS :: [JS] -> [JS]
@@ -536,6 +593,12 @@ reduceLoop reduced (cons, program) =
536 reduceCall funs (JSProj obj field) =
593 reduceCall funs (JSProj obj field) =
537 JSProj (reduceCall funs obj) field
594 JSProj (reduceCall funs obj) field
538
595
596+ reduceCall funs (JSIndex obj idx) =
597+ JSIndex (reduceCall funs obj) (reduceCall funs idx)
598+
599+ reduceCall funs (JSOp op rhs lhs) =
600+ JSOp op (reduceCall funs rhs) (reduceCall funs lhs)
601+
539 reduceCall funs (JSCond conds) =
602 reduceCall funs (JSCond conds) =
540 JSCond $ map (reduceCall funs *** reduceCall funs) conds
603 JSCond $ map (reduceCall funs *** reduceCall funs) conds
541
604
@@ -699,6 +762,9 @@ translateSpecialName name
699translateConstant :: Const -> JS
762translateConstant :: Const -> JS
700translateConstant (I i) = JSNum (JSInt i)
763translateConstant (I i) = JSNum (JSInt i)
701translateConstant (Fl f) = JSNum (JSFloat f)
764translateConstant (Fl f) = JSNum (JSFloat f)
765+translateConstant (Ch '\DEL') = JSChar "'\\u007F'"
766+translateConstant (Ch '\a') = JSChar "'\\u0007'"
767+translateConstant (Ch '\SO') = JSChar "'\\u000E'"
702translateConstant (Ch c) = JSString [c]
768translateConstant (Ch c) = JSString [c]
703translateConstant (Str s) = JSString s
769translateConstant (Str s) = JSString s
704translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
770translateConstant (AType (ATInt ITNative)) = JSType JSIntTy
@@ -800,23 +866,16 @@ translateDeclaration (path, SFun name params stackSize body)
800 JSFunction (p ++ map snd aux) (
866 JSFunction (p ++ map snd aux) (
801 JSSeq $
867 JSSeq $
802 zipWith assignVar [0..] p ++
868 zipWith assignVar [0..] p ++
803− map allocVar [numP .. (numP + stackSize - 1)] ++
804 map assignAux aux ++
869 map assignAux aux ++
805 [JSReturn body]
870 [JSReturn body]
806 )
871 )
807 where
872 where
808− numP :: Int
809− numP = length params
810−
811− allocVar :: Int -> JS
812− allocVar n = JSAlloc (jsVar n) Nothing
813−
814 assignVar :: Int -> String -> JS
873 assignVar :: Int -> String -> JS
815 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
874 assignVar n s = JSAlloc (jsVar n) (Just $ JSIdent s)
816
875
817 assignAux :: (LVar, String) -> JS
876 assignAux :: (LVar, String) -> JS
818− assignAux (var, val) =
877+ assignAux (Loc var, val) =
819− JSAssign (JSIdent $ translateVariableName var) (JSIdent val)
878+ JSAlloc (jsVar var) (Just $ JSIdent val)
820
879
821 p :: [String]
880 p :: [String]
822 p = map translateName params
881 p = map translateName params