git.iko.soy/rowtype-yoga/purescript-native
on 78f85b3 help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen.hs
126 lines 5.2 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 $ flip concatMap ctors $ \(ctor, maybeTy) ->
27 case maybeTy of
28 Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
29 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
30declToJs _ = Nothing
32valueToJs :: Value -> String
33valueToJs (NumericLiteral n) = show n
34valueToJs (StringLiteral s) = show s
35valueToJs (BooleanLiteral True) = "true"
36valueToJs (BooleanLiteral False) = "false"
37valueToJs (Unary op value) = unaryOperatorString op ++ "(" ++ valueToJs value ++ ")"
38valueToJs (Binary op left right) = "(" ++ valueToJs left ++ ") " ++ binaryOperatorString op ++ " (" ++ valueToJs right ++ ")"
39valueToJs (ArrayLiteral xs) = "[" ++ intercalate "," (map valueToJs xs) ++ "]"
40valueToJs (ObjectLiteral ps) = "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
41valueToJs (Accessor prop val) = "(" ++ valueToJs val ++ ")." ++ prop
42valueToJs (Abs args value) = "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs value ++ "; }"
43valueToJs (Var ident) = ident
44valueToJs (App f xs) = "(" ++ valueToJs f ++ ") (" ++ intercalate "," (map valueToJs xs) ++ ")"
45valueToJs (Block sts) = "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
46valueToJs (Constructor name) = name
47valueToJs (Case value binders) =
48 "(function (_0) {"
49 ++ concatMap (\(b, val) -> fst $ binderToJs 0 0 b $ "return " ++ valueToJs val ++ ";") binders
50 ++ "throw \"Failed pattern match\";"
51 ++ "})(" ++ valueToJs value ++ ")"
52valueToJs (TypedValue value _) = valueToJs value
54unaryOperatorString :: UnaryOperator -> String
55unaryOperatorString Negate = "-"
56unaryOperatorString Not = "!"
57unaryOperatorString BitwiseNot = "~"
59binaryOperatorString :: BinaryOperator -> String
60binaryOperatorString Add = "+"
61binaryOperatorString Subtract = "-"
62binaryOperatorString Multiply = "*"
63binaryOperatorString Divide = "/"
64binaryOperatorString Modulus = "%"
65binaryOperatorString LessThan = "<"
66binaryOperatorString LessThanOrEqualTo = "<="
67binaryOperatorString GreaterThan = ">"
68binaryOperatorString GreaterThanOrEqualTo = ">="
69binaryOperatorString BitwiseAnd = "&"
70binaryOperatorString BitwiseOr = "|"
71binaryOperatorString BitwiseXor = "^"
72binaryOperatorString ShiftLeft = "<<"
73binaryOperatorString ShiftRight = ">>"
74binaryOperatorString ZeroFillShiftRight = ">>>"
75binaryOperatorString EqualTo = "==="
76binaryOperatorString NotEqualTo = "!=="
77binaryOperatorString And = "&&"
78binaryOperatorString Or = "||"
79binaryOperatorString Concat = "+"
81binderToJs :: Int -> Int -> Binder -> String -> (String, Int)
82binderToJs varName fresh (VarBinder s) done = ("var " ++ s ++ " = _" ++ show varName ++ "; " ++ done, fresh)
83binderToJs varName fresh (NullaryBinder ctor) done =
84 ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"
85 ++ done
86 ++ "}", fresh)
87binderToJs varName fresh (UnaryBinder ctor b) done =
88 ("if (_" ++ show varName ++ ".ctor === \"" ++ ctor ++ "\") {"
89 ++ "var _" ++ show fresh' ++ " = _" ++ show varName ++ ".value;"
90 ++ js
91 ++ "}", fresh'')
92 where
93 fresh' = succ fresh
94 (js, fresh'') = binderToJs fresh' fresh' b done
95binderToJs varName fresh (ObjectBinder bs) done = go fresh bs done
96 where
97 go fresh [] done = (done, fresh)
98 go fresh ((prop, binder):bs') done =
99 ( "var _" ++ show fresh' ++ " = _" ++ show varName ++ "." ++ prop ++ ";"
100 ++ js
101 , fresh''')
102 where
103 fresh' = succ fresh
104 (done', fresh'') = go fresh' bs' done
105 (js, fresh''') = binderToJs fresh' fresh'' binder done'
107objectPropertyToJs :: (String, Value) -> String
108objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
110statementToJs :: Statement -> String
111statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
112statementToJs (Assignment target value) = target ++ " = " ++ valueToJs value
113statementToJs (While cond sts) = "while ("
114 ++ valueToJs cond ++ ") {"
115 ++ intercalate ";" (map statementToJs sts) ++ "}"
116statementToJs (For (init, cond, done) sts) = "for (" ++
117 statementToJs init
118 ++ "; " ++ valueToJs cond
119 ++ "; " ++ statementToJs done
120 ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
121statementToJs (IfThenElse cond thens elses) = "if ("
122 ++ valueToJs cond ++ ") {"
123 ++ intercalate ";" (map statementToJs thens) ++ "}"
124 ++ flip (maybe "") elses (\sts ->
125 " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
126statementToJs (Return value) = "return " ++ valueToJs value