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