git.iko.soy/rowtype-yoga/purescript-native
on 100d787 help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen.hs
119 lines 4.9 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.CodeGen
4-- Copyright : (c) Phil Freeman 2013
5-- License : MIT
6--
7-- Maintainer : Phil Freeman <paf31@cantab.net>
8-- Stability : experimental
9-- Portability :
10--
11-- |
12--
13-----------------------------------------------------------------------------
15module PureScript.CodeGen (
16 declToJs
17) where
19import Data.List (nub, intersperse, intercalate)
20import PureScript.Values
21import PureScript.Declarations
23declToJs :: Declaration -> Maybe String
24declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"
25declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =
26 Just $ concatMap (\(ctor, _) -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };") ctors
27declToJs _ = Nothing
29valueToJs :: Value -> String
30valueToJs (NumericLiteral n) = show n
31valueToJs (StringLiteral s) = show s
32valueToJs (BooleanLiteral True) = "true"
33valueToJs (BooleanLiteral False) = "false"
34valueToJs (Unary op value) = unaryOperatorString op ++ "(" ++ valueToJs value ++ ")"
35valueToJs (Binary op left right) = "(" ++ valueToJs left ++ ") " ++ binaryOperatorString op ++ " (" ++ valueToJs right ++ ")"
36valueToJs (ArrayLiteral xs) = "[" ++ intercalate "," (map valueToJs xs) ++ "]"
37valueToJs (ObjectLiteral ps) = "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
38valueToJs (Accessor prop val) = "(" ++ valueToJs val ++ ")." ++ prop
39valueToJs (Abs args value) = "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs value ++ "; }"
40valueToJs (Var ident) = ident
41valueToJs (App f xs) = "(" ++ valueToJs f ++ ") (" ++ intercalate "," (map valueToJs xs) ++ ")"
42valueToJs (Block sts) = "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
43valueToJs (Constructor name) = name
44valueToJs (Case value binders) =
45 "(function (_0) {"
46 ++ concatMap (\(b, val) -> fst $ binderToJs 0 0 b $ "return " ++ valueToJs val ++ ";") binders
47 ++ "throw \"Failed pattern match\";"
48 ++ "})(" ++ valueToJs value ++ ")"
49valueToJs (TypedValue value _) = valueToJs value
51unaryOperatorString :: UnaryOperator -> String
52unaryOperatorString Negate = "-"
53unaryOperatorString Not = "!"
54unaryOperatorString BitwiseNot = "~"
56binaryOperatorString :: BinaryOperator -> String
57binaryOperatorString Add = "+"
58binaryOperatorString Subtract = "-"
59binaryOperatorString Multiply = "*"
60binaryOperatorString Divide = "/"
61binaryOperatorString Modulus = "%"
62binaryOperatorString LessThan = "<"
63binaryOperatorString LessThanOrEqualTo = "<="
64binaryOperatorString GreaterThan = ">"
65binaryOperatorString GreaterThanOrEqualTo = ">="
66binaryOperatorString BitwiseAnd = "&"
67binaryOperatorString BitwiseOr = "|"
68binaryOperatorString BitwiseXor = "^"
69binaryOperatorString ShiftLeft = "<<"
70binaryOperatorString ShiftRight = ">>"
71binaryOperatorString ZeroFillShiftRight = ">>>"
72binaryOperatorString EqualTo = "==="
73binaryOperatorString NotEqualTo = "!=="
74binaryOperatorString And = "&&"
75binaryOperatorString Or = "||"
76binaryOperatorString Concat = "+"
78binderToJs :: Int -> Int -> Binder -> String -> (String, Int)
79binderToJs varName fresh (VarBinder s) done = ("var " ++ s ++ " = _" ++ show varName ++ "; " ++ done, fresh)
80binderToJs varName fresh (ConstructorBinder ctor b) done =
81 ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"
82 ++ "var _" ++ show fresh' ++ " = _" ++ show varName ++ ".value;"
83 ++ js
84 ++ "}", fresh'')
85 where
86 fresh' = succ fresh
87 (js, fresh'') = binderToJs fresh' fresh' b done
88binderToJs varName fresh (ObjectBinder bs) done = go fresh bs done
89 where
90 go fresh [] done = (done, fresh)
91 go fresh ((prop, binder):bs') done =
92 ( "var _" ++ show fresh' ++ " = _" ++ show varName ++ "." ++ prop ++ ";"
93 ++ js
94 , fresh''')
95 where
96 fresh' = succ fresh
97 (done', fresh'') = go fresh' bs' done
98 (js, fresh''') = binderToJs fresh' fresh'' binder done'
100objectPropertyToJs :: (String, Value) -> String
101objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
103statementToJs :: Statement -> String
104statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
105statementToJs (Assignment target value) = target ++ " = " ++ valueToJs value
106statementToJs (While cond sts) = "while ("
107 ++ valueToJs cond ++ ") {"
108 ++ intercalate ";" (map statementToJs sts) ++ "}"
109statementToJs (For (init, cond, done) sts) = "for (" ++
110 statementToJs init
111 ++ "; " ++ valueToJs cond
112 ++ "; " ++ statementToJs done
113 ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
114statementToJs (IfThenElse cond thens elses) = "if ("
115 ++ valueToJs cond ++ ") {"
116 ++ intercalate ";" (map statementToJs thens) ++ "}"
117 ++ flip (maybe "") elses (\sts ->
118 " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
119statementToJs (Return value) = "return " ++ valueToJs value