git.iko.soy/rowtype-yoga/purescript-native
on 69c028d help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen/JS.hs
244 lines 10 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.CodeGen.JS
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.JS (
16 declToJs
17) where
19import Data.Char
20import Data.Maybe (fromMaybe)
21import Data.List (intercalate)
22import qualified Control.Arrow as A
23import Control.Applicative
25import PureScript.Types
26import PureScript.Values
27import PureScript.Names
28import PureScript.Declarations
29import PureScript.CodeGen.Common
30import PureScript.CodeGen.Common.Gen
32declToJs :: Declaration -> Maybe String
33declToJs (ValueDeclaration ident val) = Just $ "var " ++ identToJs ident ++ " = " ++ valueToJs val ++ ";"
34declToJs (DataDeclaration _ _ ctors) =
35 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
36 case maybeTy of
37 Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
38 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
39declToJs _ = Nothing
41literals :: Pattern Value String
42literals = Pattern $ A.Kleisli match
43 where
44 match (NumericLiteral n) = Just $ either show show n
45 match (StringLiteral s) = Just $ show s
46 match (BooleanLiteral True) = Just "true"
47 match (BooleanLiteral False) = Just "false"
48 match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"
49 match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
50 match (Constructor name) = Just name
51 match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
52 match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"
53 where
54 bindersToJs :: [(Binder, Value)] -> Gen String
55 bindersToJs binders = do
56 valName <- fresh
57 jss <- flip mapM binders $ \(binder, result) -> do
58 let js = valueToJs result
59 binderToJs valName ("return " ++ js ++ ";") binder
60 return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"
61 match (Var ident) = Just (identToJs ident)
62 match _ = Nothing
64accessor :: Pattern Value (String, Value)
65accessor = Pattern $ A.Kleisli match
66 where
67 match (Accessor prop val) = Just (prop, val)
68 match _ = Nothing
70indexer :: Pattern Value (String, Value)
71indexer = Pattern $ A.Kleisli match
72 where
73 match (Indexer index val) = Just (valueToJs index, val)
74 match _ = Nothing
76app :: Pattern Value (String, Value)
77app = Pattern $ A.Kleisli match
78 where
79 match (App val args) = Just (intercalate "," (map valueToJs args), val)
80 match _ = Nothing
82lam :: Pattern Value ([String], Value)
83lam = Pattern $ A.Kleisli match
84 where
85 match (Abs args val) = Just (map identToJs args, val)
86 match _ = Nothing
88unary :: UnaryOperator -> String -> Operator Value String
89unary op str = Wrap pattern (++)
90 where
91 pattern :: Pattern Value (String, Value)
92 pattern = Pattern $ A.Kleisli match
93 where
94 match (Unary op' val) | op' == op = Just (str, val)
95 match _ = Nothing
97binary :: BinaryOperator -> String -> Operator Value String
98binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
99 where
100 pattern :: Pattern Value (Value, Value)
101 pattern = Pattern $ A.Kleisli match
102 where
103 match (Binary op' v1 v2) | op' == op = Just (v1, v2)
104 match _ = Nothing
106valueToJs :: Value -> String
107valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
108 where
109 matchValue :: Pattern Value String
110 matchValue = buildPrettyPrinter operators (literals <|> fmap parens matchValue)
111 operators :: OperatorTable Value String
112 operators =
113 OperatorTable $ [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
114 , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
115 , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
116 , [ Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }" ]
117 , [ binary LessThan "<" ]
118 , [ binary LessThanOrEqualTo "<=" ]
119 , [ binary GreaterThan ">" ]
120 , [ binary GreaterThanOrEqualTo ">=" ]
121 , [ unary Not "!" ]
122 , [ unary BitwiseNot "~" ]
123 , [ unary Negate "-" ]
124 , [ binary Multiply "*" ]
125 , [ binary Divide "/" ]
126 , [ binary Modulus "%" ]
127 , [ binary Concat "+" ]
128 , [ binary Add "+" ]
129 , [ binary Subtract "-" ]
130 , [ binary ShiftLeft "<<" ]
131 , [ binary ShiftRight ">>" ]
132 , [ binary ZeroFillShiftRight ">>>" ]
133 , [ binary EqualTo "===" ]
134 , [ binary NotEqualTo "!==" ]
135 , [ binary BitwiseAnd "&" ]
136 , [ binary BitwiseXor "^" ]
137 , [ binary BitwiseOr "|" ]
138 , [ binary And "&&" ]
139 , [ binary Or "||" ]
140 ]
142unaryOperatorString :: UnaryOperator -> String
143unaryOperatorString Negate = "-"
144unaryOperatorString Not = "!"
145unaryOperatorString BitwiseNot = "~"
147binaryOperatorString :: BinaryOperator -> String
148binaryOperatorString Add = "+"
149binaryOperatorString Subtract = "-"
150binaryOperatorString Multiply = "*"
151binaryOperatorString Divide = "/"
152binaryOperatorString Modulus = "%"
153binaryOperatorString LessThan = "<"
154binaryOperatorString LessThanOrEqualTo = "<="
155binaryOperatorString GreaterThan = ">"
156binaryOperatorString GreaterThanOrEqualTo = ">="
157binaryOperatorString BitwiseAnd = "&"
158binaryOperatorString BitwiseOr = "|"
159binaryOperatorString BitwiseXor = "^"
160binaryOperatorString ShiftLeft = "<<"
161binaryOperatorString ShiftRight = ">>"
162binaryOperatorString ZeroFillShiftRight = ">>>"
163binaryOperatorString EqualTo = "==="
164binaryOperatorString NotEqualTo = "!=="
165binaryOperatorString And = "&&"
166binaryOperatorString Or = "||"
167binaryOperatorString Concat = "+"
169binderToJs :: String -> String -> Binder -> Gen String
170binderToJs varName done (StringBinder str) =
171 return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
172binderToJs varName done (NumberBinder num) =
173 return $ "if (" ++ varName ++ " === " ++ either show show num ++ ") {" ++ done ++ " }"
174binderToJs varName done (BooleanBinder True) =
175 return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
176binderToJs varName done (BooleanBinder False) =
177 return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
178binderToJs varName done (VarBinder ident) =
179 return $ "var " ++ identToJs ident ++ " = " ++ varName ++ "; " ++ done
180binderToJs varName done (NullaryBinder ctor) =
181 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
182binderToJs varName done (UnaryBinder ctor b) = do
183 value <- fresh
184 js <- binderToJs value done b
185 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
186binderToJs varName done (ObjectBinder bs) = go done bs
187 where
188 go done [] = return done
189 go done ((prop, binder):bs) = do
190 propVar <- fresh
191 done' <- go done bs
192 js <- binderToJs propVar done' binder
193 return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
194binderToJs done varName (ArrayBinder bs rest) = do
195 js <- go done rest 0 bs
196 return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"
197 where
198 cmp = maybe "===" (const ">=") rest
199 go done Nothing _ [] = return done
200 go done (Just binder) index [] = do
201 restVar <- fresh
202 js <- binderToJs restVar done binder
203 return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js
204 go done rest index (binder:bs) = do
205 elVar <- fresh
206 done' <- go done rest (index + 1) bs
207 js <- binderToJs elVar done' binder
208 return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
210objectPropertyToJs :: (String, Value) -> String
211objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
213statementToJs :: Statement -> String
214statementToJs (VariableIntroduction ident value) = "var " ++ identToJs ident ++ " = " ++ valueToJs value
215statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value
216statementToJs (While cond sts) = "while ("
217 ++ valueToJs cond ++ ") {"
218 ++ intercalate ";" (map statementToJs sts) ++ "}"
219statementToJs (For ident start end sts) = "for (" ++
220 identToJs ident ++ " = " ++ valueToJs start ++ ";"
221 ++ identToJs ident ++ " < " ++ valueToJs end ++ ";"
222 ++ identToJs ident ++ "++) {"
223 ++ intercalate ";" (map statementToJs sts) ++ "}"
224statementToJs (ForEach ident arr sts) = valueToJs arr
225 ++ ".forEach(function(" ++ identToJs ident ++ ") {"
226 ++ intercalate ";" (map statementToJs sts) ++ "})"
227statementToJs (If ifst) = ifStatementToJs ifst
228statementToJs (Return value) = "return " ++ valueToJs value
230ifStatementToJs :: IfStatement -> String
231ifStatementToJs (IfStatement cond thens elst) =
232 "if ("
233 ++ valueToJs cond ++ ") {"
234 ++ intercalate ";" (map statementToJs thens) ++ "}"
235 ++ maybe "" elseStatementToJs elst
237elseStatementToJs :: ElseStatement -> String
238elseStatementToJs (Else sts) = " else {" ++ intercalate ";" (map statementToJs sts) ++ "}"
239elseStatementToJs (ElseIf ifst) = " else " ++ ifStatementToJs ifst
241assignmentTargetToJs :: AssignmentTarget -> String
242assignmentTargetToJs (AssignVariable ident) = identToJs ident
243assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"
244assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop