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