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