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