git.iko.soy/rowtype-yoga/purescript-native
on ae6037f help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen.hs
292 lines 11 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) where
21import Data.Maybe (fromMaybe)
22import Data.List (nub, intersperse, intercalate)
23import Data.Function (fix)
24import Control.Monad.State
25import Control.Applicative (Applicative(..), Alternative(..))
26import qualified Control.Category as C
27import Control.Category ((>>>))
28import qualified Control.Arrow as A
29import Control.Arrow ((***))
31import PureScript.Values
32import PureScript.Declarations
34-- First Order Patterns
36newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)
38pattern :: Pattern a b -> a -> Maybe b
39pattern = A.runKleisli . runPattern
41instance Functor (Pattern a) where
42 fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p
44instance Applicative (Pattern a) where
45 pure = Pattern . A.Kleisli . const . pure
46 f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a
48instance Alternative (Pattern a) where
49 empty = Pattern $ A.Kleisli $ \a -> empty
50 (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a
52parens :: String -> String
53parens s = ('(':s) ++ ")"
55chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
56chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p
58chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
59chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p
61wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
62wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p
64split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
65split s f p = (s >>> A.arr (uncurry f)) <|> p
67data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }
69data Operator a r where
70 AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
71 AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
72 Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
73 Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
75buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
76buildPrettyPrinter table p = foldl (\p' op ->
77 case op of
78 AssocL pat g -> chainl pat g p'
79 AssocR pat g -> chainr pat g p'
80 Wrap pat g -> wrap pat g p'
81 Split pat g -> split pat g p'
82 ) p $ runOperatorTable table
84-- Variable Name Generation
86newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Monad, MonadState Int)
88runGen :: Gen a -> a
89runGen = flip evalState 0 . unGen
91fresh :: Gen String
92fresh = do
93 n <- get
94 modify (+ 1)
95 return $ "_" ++ show n
97-- Pretty Printing
99declToJs :: Declaration -> Maybe String
100declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"
101declToJs (DataDeclaration dcs@(DataConstructors { dataConstructors = ctors })) =
102 Just $ flip concatMap ctors $ \(ctor, maybeTy) ->
103 case maybeTy of
104 Nothing -> "var " ++ ctor ++ " = { ctor: '" ++ ctor ++ "' };"
105 Just _ -> "var " ++ ctor ++ " = function (value) { return { ctor: '" ++ ctor ++ "', value: value }; };"
106declToJs _ = Nothing
108literals :: Pattern Value String
109literals = Pattern $ A.Kleisli match
110 where
111 match (NumericLiteral n) = Just $ either show show n
112 match (StringLiteral s) = Just $ show s
113 match (BooleanLiteral True) = Just "true"
114 match (BooleanLiteral False) = Just "false"
115 match (ArrayLiteral xs) = Just $ "[" ++ intercalate "," (map valueToJs xs) ++ "]"
116 match (ObjectLiteral ps) = Just $ "{" ++ intercalate "," (map objectPropertyToJs ps) ++ "}"
117 match (Constructor name) = Just name
118 match (Block sts) = Just $ "(function () {" ++ intercalate ";" (map statementToJs sts) ++ "})()"
119 match (Case value binders) = Just $ "(" ++ runGen (bindersToJs binders) ++ ")(" ++ valueToJs value ++ ")"
120 where
121 bindersToJs :: [(Binder, Value)] -> Gen String
122 bindersToJs binders = do
123 valName <- fresh
124 jss <- flip mapM binders $ \(binder, result) -> do
125 let js = valueToJs result
126 binderToJs valName ("return " ++ js ++ ";") binder
127 return $ "function (" ++ valName ++ ") {" ++ concat jss ++ "throw \"Failed pattern match\"; }"
128 match (Var ident) = Just ident
129 match _ = Nothing
131accessor :: Pattern Value (String, Value)
132accessor = Pattern $ A.Kleisli match
133 where
134 match (Accessor prop val) = Just (prop, val)
135 match _ = Nothing
137indexer :: Pattern Value (String, Value)
138indexer = Pattern $ A.Kleisli match
139 where
140 match (Indexer index val) = Just (valueToJs index, val)
141 match _ = Nothing
143app :: Pattern Value (String, Value)
144app = Pattern $ A.Kleisli match
145 where
146 match (App val args) = Just (intercalate "," (map valueToJs args), val)
147 match _ = Nothing
149lam :: Pattern Value ([String], Value)
150lam = Pattern $ A.Kleisli match
151 where
152 match (Abs args val) = Just (args, val)
153 match _ = Nothing
155unary :: UnaryOperator -> String -> Operator Value String
156unary op str = Wrap pattern (++)
157 where
158 pattern :: Pattern Value (String, Value)
159 pattern = Pattern $ A.Kleisli match
160 where
161 match (Unary op' val) | op' == op = Just (str, val)
162 match _ = Nothing
164binary :: BinaryOperator -> String -> Operator Value String
165binary op str = AssocR pattern (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
166 where
167 pattern :: Pattern Value (Value, Value)
168 pattern = Pattern $ A.Kleisli match
169 where
170 match (Binary op' v1 v2) | op' == op = Just (v1, v2)
171 match _ = Nothing
173valueToJs :: Value -> String
174valueToJs = fromMaybe (error "Incomplete pattern") . pattern matchValue
175 where
176 matchValue :: Pattern Value String
177 matchValue = buildPrettyPrinter operators (literals <|> fmap parens matchValue)
178 operators :: OperatorTable Value String
179 operators =
180 OperatorTable $ [ Wrap accessor $ \prop val -> val ++ "." ++ prop
181 , Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]"
182 , Wrap app $ \args val -> val ++ "(" ++ args ++ ")"
183 , Split lam $ \args val -> "function (" ++ intercalate "," args ++ ") { return " ++ valueToJs val ++ "; }"
184 , unary Not "!"
185 , unary BitwiseNot "~"
186 , unary Negate "-"
187 , binary Multiply "*"
188 , binary Divide "/"
189 , binary Modulus "%"
190 , binary Concat "++"
191 , binary Add "+"
192 , binary Subtract "-"
193 , binary ShiftLeft "<<"
194 , binary ShiftRight ">>"
195 , binary ZeroFillShiftRight ">>>"
196 , binary EqualTo "==="
197 , binary NotEqualTo "!=="
198 , binary BitwiseAnd "&"
199 , binary BitwiseXor "^"
200 , binary BitwiseOr "|"
201 , binary And "&&"
202 , binary Or "||"
203 ]
205unaryOperatorString :: UnaryOperator -> String
206unaryOperatorString Negate = "-"
207unaryOperatorString Not = "!"
208unaryOperatorString BitwiseNot = "~"
210binaryOperatorString :: BinaryOperator -> String
211binaryOperatorString Add = "+"
212binaryOperatorString Subtract = "-"
213binaryOperatorString Multiply = "*"
214binaryOperatorString Divide = "/"
215binaryOperatorString Modulus = "%"
216binaryOperatorString LessThan = "<"
217binaryOperatorString LessThanOrEqualTo = "<="
218binaryOperatorString GreaterThan = ">"
219binaryOperatorString GreaterThanOrEqualTo = ">="
220binaryOperatorString BitwiseAnd = "&"
221binaryOperatorString BitwiseOr = "|"
222binaryOperatorString BitwiseXor = "^"
223binaryOperatorString ShiftLeft = "<<"
224binaryOperatorString ShiftRight = ">>"
225binaryOperatorString ZeroFillShiftRight = ">>>"
226binaryOperatorString EqualTo = "==="
227binaryOperatorString NotEqualTo = "!=="
228binaryOperatorString And = "&&"
229binaryOperatorString Or = "||"
230binaryOperatorString Concat = "+"
232binderToJs :: String -> String -> Binder -> Gen String
233binderToJs varName done (StringBinder str) =
234 return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
235binderToJs varName done (NumberBinder num) =
236 return $ "if (" ++ varName ++ " === \"" ++ either show show num ++ "\") {" ++ done ++ " }"
237binderToJs varName done (BooleanBinder True) =
238 return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
239binderToJs varName done (BooleanBinder False) =
240 return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
241binderToJs varName done (VarBinder s) =
242 return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done
243binderToJs varName done (NullaryBinder ctor) =
244 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
245binderToJs varName done (UnaryBinder ctor b) = do
246 value <- fresh
247 js <- binderToJs value done b
248 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
249binderToJs varName done (ObjectBinder bs) = go done bs
250 where
251 go done [] = return done
252 go done ((prop, binder):bs) = do
253 propVar <- fresh
254 done' <- go done bs
255 js <- binderToJs propVar done' binder
256 return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
257binderToJs done varName (ArrayBinder bs rest) = do
258 js <- go done rest 0 bs
259 return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"
260 where
261 cmp = maybe "===" (const ">=") rest
262 go done Nothing _ [] = return done
263 go done (Just binder) index [] = do
264 restVar <- fresh
265 js <- binderToJs restVar done binder
266 return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js
267 go done rest index (binder:bs) = do
268 elVar <- fresh
269 done' <- go done rest (index + 1) bs
270 js <- binderToJs elVar done' binder
271 return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
273objectPropertyToJs :: (String, Value) -> String
274objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
276statementToJs :: Statement -> String
277statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
278statementToJs (Assignment target value) = target ++ " = " ++ valueToJs value
279statementToJs (While cond sts) = "while ("
280 ++ valueToJs cond ++ ") {"
281 ++ intercalate ";" (map statementToJs sts) ++ "}"
282statementToJs (For (init, cond, done) sts) = "for (" ++
283 statementToJs init
284 ++ "; " ++ valueToJs cond
285 ++ "; " ++ statementToJs done
286 ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
287statementToJs (IfThenElse cond thens elses) = "if ("
288 ++ valueToJs cond ++ ") {"
289 ++ intercalate ";" (map statementToJs thens) ++ "}"
290 ++ flip (maybe "") elses (\sts ->
291 " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
292statementToJs (Return value) = "return " ++ valueToJs value