git.iko.soy/rowtype-yoga/purescript-native
on adc70ed help sign in
rowtype-yoga/purescript-native/src/PureScript/CodeGen.hs
301 lines 12 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 , binary LessThan "<"
185 , binary LessThanOrEqualTo "<="
186 , binary GreaterThan ">"
187 , binary GreaterThanOrEqualTo ">="
188 , unary Not "!"
189 , unary BitwiseNot "~"
190 , unary Negate "-"
191 , binary Multiply "*"
192 , binary Divide "/"
193 , binary Modulus "%"
194 , binary Concat "++"
195 , binary Add "+"
196 , binary Subtract "-"
197 , binary ShiftLeft "<<"
198 , binary ShiftRight ">>"
199 , binary ZeroFillShiftRight ">>>"
200 , binary EqualTo "==="
201 , binary NotEqualTo "!=="
202 , binary BitwiseAnd "&"
203 , binary BitwiseXor "^"
204 , binary BitwiseOr "|"
205 , binary And "&&"
206 , binary Or "||"
207 ]
209unaryOperatorString :: UnaryOperator -> String
210unaryOperatorString Negate = "-"
211unaryOperatorString Not = "!"
212unaryOperatorString BitwiseNot = "~"
214binaryOperatorString :: BinaryOperator -> String
215binaryOperatorString Add = "+"
216binaryOperatorString Subtract = "-"
217binaryOperatorString Multiply = "*"
218binaryOperatorString Divide = "/"
219binaryOperatorString Modulus = "%"
220binaryOperatorString LessThan = "<"
221binaryOperatorString LessThanOrEqualTo = "<="
222binaryOperatorString GreaterThan = ">"
223binaryOperatorString GreaterThanOrEqualTo = ">="
224binaryOperatorString BitwiseAnd = "&"
225binaryOperatorString BitwiseOr = "|"
226binaryOperatorString BitwiseXor = "^"
227binaryOperatorString ShiftLeft = "<<"
228binaryOperatorString ShiftRight = ">>"
229binaryOperatorString ZeroFillShiftRight = ">>>"
230binaryOperatorString EqualTo = "==="
231binaryOperatorString NotEqualTo = "!=="
232binaryOperatorString And = "&&"
233binaryOperatorString Or = "||"
234binaryOperatorString Concat = "+"
236binderToJs :: String -> String -> Binder -> Gen String
237binderToJs varName done (StringBinder str) =
238 return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
239binderToJs varName done (NumberBinder num) =
240 return $ "if (" ++ varName ++ " === \"" ++ either show show num ++ "\") {" ++ done ++ " }"
241binderToJs varName done (BooleanBinder True) =
242 return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
243binderToJs varName done (BooleanBinder False) =
244 return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
245binderToJs varName done (VarBinder s) =
246 return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done
247binderToJs varName done (NullaryBinder ctor) =
248 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
249binderToJs varName done (UnaryBinder ctor b) = do
250 value <- fresh
251 js <- binderToJs value done b
252 return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ "var " ++ value ++ " = " ++ varName ++ ".value; " ++ js ++ " }"
253binderToJs varName done (ObjectBinder bs) = go done bs
254 where
255 go done [] = return done
256 go done ((prop, binder):bs) = do
257 propVar <- fresh
258 done' <- go done bs
259 js <- binderToJs propVar done' binder
260 return $ "var " ++ propVar ++ " = " ++ varName ++ "." ++ prop ++ ";" ++ js
261binderToJs done varName (ArrayBinder bs rest) = do
262 js <- go done rest 0 bs
263 return $ "if (" ++ varName ++ ".length " ++ cmp ++ " " ++ show (length bs) ++ ") { " ++ js ++ " }"
264 where
265 cmp = maybe "===" (const ">=") rest
266 go done Nothing _ [] = return done
267 go done (Just binder) index [] = do
268 restVar <- fresh
269 js <- binderToJs restVar done binder
270 return $ "var " ++ restVar ++ " = " ++ varName ++ ".slice(" ++ show index ++ "); " ++ js
271 go done rest index (binder:bs) = do
272 elVar <- fresh
273 done' <- go done rest (index + 1) bs
274 js <- binderToJs elVar done' binder
275 return $ "var " ++ elVar ++ " = " ++ varName ++ "[" ++ show index ++ "]; " ++ js
277objectPropertyToJs :: (String, Value) -> String
278objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
280statementToJs :: Statement -> String
281statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
282statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value
283statementToJs (While cond sts) = "while ("
284 ++ valueToJs cond ++ ") {"
285 ++ intercalate ";" (map statementToJs sts) ++ "}"
286statementToJs (For (init, cond, done) sts) = "for (" ++
287 statementToJs init
288 ++ "; " ++ valueToJs cond
289 ++ "; " ++ statementToJs done
290 ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
291statementToJs (IfThenElse cond thens elses) = "if ("
292 ++ valueToJs cond ++ ") {"
293 ++ intercalate ";" (map statementToJs thens) ++ "}"
294 ++ flip (maybe "") elses (\sts ->
295 " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
296statementToJs (Return value) = "return " ++ valueToJs value
298assignmentTargetToJs :: AssignmentTarget -> String
299assignmentTargetToJs (AssignVariable var) = var
300assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"
301assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop