git.iko.soy/rowtype-yoga/purescript-native
on fb48912 help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen.hs
355 lines 14 kB history raw
1-----------------------------------------------------------------------------
2--
3-- Module : PureScript.CodeGen
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-----------------------------------------------------------------------------
15{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
17module PureScript.CodeGen (
18 declToJs,
19 externToJs
20) where
22import Data.Maybe (fromMaybe)
23import Data.List (nub, intersperse, intercalate)
24import Data.Function (fix)
25import Control.Monad.State
26import Control.Applicative (Applicative(..), Alternative(..))
27import qualified Control.Category as C
28import Control.Category ((>>>))
29import qualified Control.Arrow as A
30import Control.Arrow ((***))
32import PureScript.Values
33import PureScript.Types
34import PureScript.Declarations
36-- First Order Patterns
38newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)
40pattern :: Pattern a b -> a -> Maybe b
41pattern = A.runKleisli . runPattern
43instance Functor (Pattern a) where
44 fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p
46instance Applicative (Pattern a) where
47 pure = Pattern . A.Kleisli . const . pure
48 f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a
50instance Alternative (Pattern a) where
51 empty = Pattern $ A.Kleisli $ \a -> empty
52 (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a
54parens :: String -> String
55parens s = ('(':s) ++ ")"
57chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
58chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p
60chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
61chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p
63wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
64wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p
66split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
67split s f p = (s >>> A.arr (uncurry f)) <|> p
69data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }
71data Operator a r where
72 AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
73 AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
74 Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
75 Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
77buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
78buildPrettyPrinter table p = foldl (\p' op ->
79 case op of
80 AssocL pat g -> chainl pat g p'
81 AssocR pat g -> chainr pat g p'
82 Wrap pat g -> wrap pat g p'
83 Split pat g -> split pat g p'
84 ) p $ runOperatorTable table
86-- Variable Name Generation
88newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Monad, MonadState Int)
90runGen :: Gen a -> a
91runGen = flip evalState 0 . unGen
93fresh :: Gen String
94fresh = do
95 n <- get
96 modify (+ 1)
97 return $ "_" ++ show n
99-- Pretty Printing
101declToJs :: Declaration -> Maybe String
102declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"
103declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =
104 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
105 case maybeTy of
106 Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
107 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
108declToJs _ = Nothing
110literals :: Pattern Value String
111literals = Pattern $ A.Kleisli match
112 where
113 match (NumericLiteral n) = Just $ either show show n
114 match (StringLiteral s) = Just $ show s
115 match (BooleanLiteral True) = Just "true"
116 match (BooleanLiteral False) = Just "false"
117 match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"
118 match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
119 match (Constructor name) = Just name
120 match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
121 match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"
122 where
123 bindersToJs :: [(Binder, Value)] -> Gen String
124 bindersToJs binders = do
125 valName <- fresh
126 jss <- flip mapM binders $ \(binder, result) -> do
127 let js = valueToJs result
128 binderToJs valName ("return " ++ js ++ ";") binder
129 return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"
130 match (Var ident) = Just ident
131 match _ = Nothing
133accessor :: Pattern Value (String, Value)
134accessor = Pattern $ A.Kleisli match
135 where
136 match (Accessor prop val) = Just (prop, val)
137 match _ = Nothing
139indexer :: Pattern Value (String, Value)
140indexer = Pattern $ A.Kleisli match
141 where
142 match (Indexer index val) = Just (valueToJs index, val)
143 match _ = Nothing
145app :: Pattern Value (String, Value)
146app = Pattern $ A.Kleisli match
147 where
148 match (App val args) = Just (intercalate "," (map valueToJs args), val)
149 match _ = Nothing
151lam :: Pattern Value ([String], Value)
152lam = Pattern $ A.Kleisli match
153 where
154 match (Abs args val) = Just (args, val)
155 match _ = Nothing
157unary :: UnaryOperator -> String -> Operator Value String
158unary op str = Wrap pattern (++)
159 where
160 pattern :: Pattern Value (String, Value)
161 pattern = Pattern $ A.Kleisli match
162 where
163 match (Unary op' val) | op' == op = Just (str, val)
164 match _ = Nothing
166binary :: BinaryOperator -> String -> Operator Value String
167binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
168 where
169 pattern :: Pattern Value (Value, Value)
170 pattern = Pattern $ A.Kleisli match
171 where
172 match (Binary op' v1 v2) | op' == op = Just (v1, v2)
173 match _ = Nothing
175valueToJs :: Value -> String
176valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
177 where
178 matchValue :: Pattern Value String
179 matchValue = buildPrettyPrinter operators (literals <|> fmap parens matchValue)
180 operators :: OperatorTable Value String
181 operators =
182 OperatorTable $ [ Wrap accessor $ \prop val -> val ++ "." ++ prop
183 , Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]"
184 , Wrap app $ \args val -> val ++ "(" ++ args ++ ")"
185 , Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }"
186 , binary LessThan "<"
187 , binary LessThanOrEqualTo "<="
188 , binary GreaterThan ">"
189 , binary GreaterThanOrEqualTo ">="
190 , unary Not "!"
191 , unary BitwiseNot "~"
192 , unary Negate "-"
193 , binary Multiply "*"
194 , binary Divide "/"
195 , binary Modulus "%"
196 , binary Concat "++"
197 , binary Add "+"
198 , binary Subtract "-"
199 , binary ShiftLeft "<<"
200 , binary ShiftRight ">>"
201 , binary ZeroFillShiftRight ">>>"
202 , binary EqualTo "==="
203 , binary NotEqualTo "!=="
204 , binary BitwiseAnd "&"
205 , binary BitwiseXor "^"
206 , binary BitwiseOr "|"
207 , binary And "&&"
208 , binary Or "||"
209 ]
211unaryOperatorString :: UnaryOperator -> String
212unaryOperatorString Negate = "-"
213unaryOperatorString Not = "!"
214unaryOperatorString BitwiseNot = "~"
216binaryOperatorString :: BinaryOperator -> String
217binaryOperatorString Add = "+"
218binaryOperatorString Subtract = "-"
219binaryOperatorString Multiply = "*"
220binaryOperatorString Divide = "/"
221binaryOperatorString Modulus = "%"
222binaryOperatorString LessThan = "<"
223binaryOperatorString LessThanOrEqualTo = "<="
224binaryOperatorString GreaterThan = ">"
225binaryOperatorString GreaterThanOrEqualTo = ">="
226binaryOperatorString BitwiseAnd = "&"
227binaryOperatorString BitwiseOr = "|"
228binaryOperatorString BitwiseXor = "^"
229binaryOperatorString ShiftLeft = "<<"
230binaryOperatorString ShiftRight = ">>"
231binaryOperatorString ZeroFillShiftRight = ">>>"
232binaryOperatorString EqualTo = "==="
233binaryOperatorString NotEqualTo = "!=="
234binaryOperatorString And = "&&"
235binaryOperatorString Or = "||"
236binaryOperatorString Concat = "+"
238binderToJs :: String -> String -> Binder -> Gen String
239binderToJs varName done (StringBinder str) =
240 return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
241binderToJs varName done (NumberBinder num) =
242 return $ "if (" ++ varName ++ " === \"" ++ either show show num ++ "\") {" ++ done ++ " }"
243binderToJs varName done (BooleanBinder True) =
244 return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
245binderToJs varName done (BooleanBinder False) =
246 return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
247binderToJs varName done (VarBinder s) =
248 return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done
249binderToJs varName done (NullaryBinder ctor) =
250 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
251binderToJs varName done (UnaryBinder ctor b) = do
252 value <- fresh
253 js <- binderToJs value done b
254 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
255binderToJs varName done (ObjectBinder bs) = go done bs
256 where
257 go done [] = return done
258 go done ((prop, binder):bs) = do
259 propVar <- fresh
260 done' <- go done bs
261 js <- binderToJs propVar done' binder
262 return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
263binderToJs done varName (ArrayBinder bs rest) = do
264 js <- go done rest 0 bs
265 return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"
266 where
267 cmp = maybe "===" (const ">=") rest
268 go done Nothing _ [] = return done
269 go done (Just binder) index [] = do
270 restVar <- fresh
271 js <- binderToJs restVar done binder
272 return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js
273 go done rest index (binder:bs) = do
274 elVar <- fresh
275 done' <- go done rest (index + 1) bs
276 js <- binderToJs elVar done' binder
277 return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
279objectPropertyToJs :: (String, Value) -> String
280objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
282statementToJs :: Statement -> String
283statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
284statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value
285statementToJs (While cond sts) = "while ("
286 ++ valueToJs cond ++ ") {"
287 ++ intercalate ";" (map statementToJs sts) ++ "}"
288statementToJs (For (init, cond, done) sts) = "for (" ++
289 statementToJs init
290 ++ "; " ++ valueToJs cond
291 ++ "; " ++ statementToJs done
292 ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
293statementToJs (IfThenElse cond thens elses) = "if ("
294 ++ valueToJs cond ++ ") {"
295 ++ intercalate ";" (map statementToJs thens) ++ "}"
296 ++ flip (maybe "") elses (\sts ->
297 " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
298statementToJs (Return value) = "return " ++ valueToJs value
300assignmentTargetToJs :: AssignmentTarget -> String
301assignmentTargetToJs (AssignVariable var) = var
302assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"
303assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop
305-- Externs
307typeLiterals :: Pattern Type String
308typeLiterals = Pattern $ A.Kleisli match
309 where
310 match Number = Just "Number"
311 match String = Just "String"
312 match Boolean = Just "Boolean"
313 match (Array ty) = Just $ "[" ++ typeToPs ty ++ "]"
314 match (Object row) = Just $ "{ " ++ rowToPs row ++ " }"
315 match (TypeVar var) = Just var
316 match (TypeConstructor ctor) = Just ctor
317 match _ = Nothing
319rowToPs :: Row -> String
320rowToPs = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList
321 where
322 nameAndTypeToPs :: String -> Type -> String
323 nameAndTypeToPs name ty = name ++ " :: " ++ typeToPs ty
324 tailToPs :: Row -> String
325 tailToPs REmpty = ""
326 tailToPs (RowVar var) = " | " ++ var
327 toList :: Row -> ([(String, Type)], Row)
328 toList (RCons name ty row) = let (tys, rest) = toList row
329 in ((name, ty):tys, rest)
330 toList r = ([], r)
332typeApp :: Pattern Type (Type, Type)
333typeApp = Pattern $ A.Kleisli match
334 where
335 match (TypeApp f x) = Just (f, x)
336 match _ = Nothing
338function :: Pattern Type ([Type], Type)
339function = Pattern $ A.Kleisli match
340 where
341 match (Function args ret) = Just (args, ret)
342 match _ = Nothing
344typeToPs :: Type -> String
345typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType
346 where
347 matchType :: Pattern Type String
348 matchType = buildPrettyPrinter operators (typeLiterals <|> fmap parens matchType)
349 operators :: OperatorTable Type String
350 operators =
351 OperatorTable $ [ AssocL typeApp $ \f x -> f ++ " " ++ x
352 , Split function $ \args ret -> "(" ++ intercalate "," (map typeToPs args) ++ ") -> " ++ typeToPs ret ]
354externToJs :: (String, Type) -> String
355externToJs (name, ty) = "extern " ++ name ++ " :: " ++ typeToPs ty