git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Some tidying of the code gen module
294b01dPhil Freeman
PureScript.cabal+13−9
compare with golang
unifiedsplit
@@ -11,7 +11,7 @@ synopsis: PureScript Programming Language Compiler
11description: A small compile-to-JS language with extensible records and type-safe blocks
11description: A small compile-to-JS language with extensible records and type-safe blocks
12author: Phil Freeman <paf31@cantab.net>
12author: Phil Freeman <paf31@cantab.net>
13data-dir: ""
13data-dir: ""
14−
14+
15library
15library
16 build-depends: base -any, cmdtheline -any, containers -any,
16 build-depends: base -any, cmdtheline -any, containers -any,
17 mtl -any, parsec -any, utf8-string -any
17 mtl -any, parsec -any, utf8-string -any
@@ -19,17 +19,21 @@ library
19 exposed: True
19 exposed: True
20 buildable: True
20 buildable: True
21 hs-source-dirs: src
21 hs-source-dirs: src
22+ other-modules: PureScript.CodeGen.Externs PureScript.CodeGen.JS
23+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common Main
22− other-modules: Main PureScript.CodeGen PureScript.Kinds
24+ PureScript.CodeGen PureScript.Kinds PureScript.Parser
23− PureScript.Parser PureScript.TypeChecker PureScript.Types
25+ PureScript.TypeChecker PureScript.Types PureScript.Values
24− PureScript.Values PureScript.Parser.Common
25− PureScript.Parser.Declarations PureScript.Parser.Types
26+ PureScript.Parser.Common PureScript.Parser.Declarations
27+ PureScript.Parser.Types PureScript.Parser.Values
26− PureScript.Parser.Values PureScript.TypeChecker.Kinds
28+ PureScript.TypeChecker.Kinds PureScript.TypeChecker.Monad
27− PureScript.TypeChecker.Monad PureScript.TypeChecker.Types
29+ PureScript.TypeChecker.Types
28−
30+
29executable psc
31executable psc
30 build-depends: base -any, cmdtheline -any, containers -any,
32 build-depends: base -any, cmdtheline -any, containers -any,
31 mtl -any, parsec -any, utf8-string -any
33 mtl -any, parsec -any, utf8-string -any
32 main-is: Main.hs
34 main-is: Main.hs
33 buildable: True
35 buildable: True
34 hs-source-dirs: src
36 hs-source-dirs: src
35−
37+ other-modules: PureScript.CodeGen.Externs PureScript.CodeGen.JS
38+ PureScript.CodeGen.Common.Gen PureScript.CodeGen.Common
39+
src/Main.hs+1−1
@@ -43,7 +43,7 @@ compile inputFiles outputFile externsFile = do
43 Nothing -> U.putStrLn js
43 Nothing -> U.putStrLn js
44 case externsFile of
44 case externsFile of
45 Nothing -> return ()
45 Nothing -> return ()
46− Just filePath -> U.writeFile filePath $ intercalate "\n\n" $ map externToJs $ M.toList $ names env
46+ Just filePath -> U.writeFile filePath $ intercalate "\n\n" $ map externToPs $ M.toList $ names env
47 exitSuccess
47 exitSuccess
48
48
49inputFiles :: Term [FilePath]
49inputFiles :: Term [FilePath]
src/PureScript/CodeGen.hs+4−338
@@ -12,344 +12,10 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15−{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
16−
17module PureScript.CodeGen (
15module PureScript.CodeGen (
18− declToJs,
16+ module PureScript.CodeGen.JS,
19− externToJs
17+ module PureScript.CodeGen.Externs
20) where
18) where
21
19
22−import Data.Maybe (fromMaybe)
20+import PureScript.CodeGen.JS
23−import Data.List (nub, intersperse, intercalate)
21+import PureScript.CodeGen.Externs
24−import Data.Function (fix)
25−import Control.Monad.State
26−import Control.Applicative (Applicative(..), Alternative(..))
27−import qualified Control.Category as C
28−import Control.Category ((>>>))
29−import qualified Control.Arrow as A
30−import Control.Arrow ((***))
31−
32−import PureScript.Values
33−import PureScript.Types
34−import PureScript.Declarations
35−
36−-- First Order Patterns
37−
38−newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)
39−
40−pattern :: Pattern a b -> a -> Maybe b
41−pattern = A.runKleisli . runPattern
42−
43−instance Functor (Pattern a) where
44− fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p
45−
46−instance Applicative (Pattern a) where
47− pure = Pattern . A.Kleisli . const . pure
48− f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a
49−
50−instance 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
53−
54−parens :: String -> String
55−parens s = ('(':s) ++ ")"
56−
57−chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
58−chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p
59−
60−chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
61−chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p
62−
63−wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
64−wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p
65−
66−split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
67−split s f p = (s >>> A.arr (uncurry f)) <|> p
68−
69−data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }
70−
71−data 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
76−
77−buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
78−buildPrettyPrinter 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
85−
86−-- Variable Name Generation
87−
88−newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Monad, MonadState Int)
89−
90−runGen :: Gen a -> a
91−runGen = flip evalState 0 . unGen
92−
93−fresh :: Gen String
94−fresh = do
95− n <- get
96− modify (+ 1)
97− return $ "_" ++ show n
98−
99−-- Pretty Printing
100−
101−declToJs :: Declaration -> Maybe String
102−declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"
103−declToJs (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 }; };"
108−declToJs _ = Nothing
109−
110−literals :: Pattern Value String
111−literals = 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
132−
133−accessor :: Pattern Value (String, Value)
134−accessor = Pattern $ A.Kleisli match
135− where
136− match (Accessor prop val) = Just (prop, val)
137− match _ = Nothing
138−
139−indexer :: Pattern Value (String, Value)
140−indexer = Pattern $ A.Kleisli match
141− where
142− match (Indexer index val) = Just (valueToJs index, val)
143− match _ = Nothing
144−
145−app :: Pattern Value (String, Value)
146−app = Pattern $ A.Kleisli match
147− where
148− match (App val args) = Just (intercalate "," (map valueToJs args), val)
149− match _ = Nothing
150−
151−lam :: Pattern Value ([String], Value)
152−lam = Pattern $ A.Kleisli match
153− where
154− match (Abs args val) = Just (args, val)
155− match _ = Nothing
156−
157−unary :: UnaryOperator -> String -> Operator Value String
158−unary 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
165−
166−binary :: BinaryOperator -> String -> Operator Value String
167−binary 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
174−
175−valueToJs :: Value -> String
176−valueToJs = 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− ]
210−
211−unaryOperatorString :: UnaryOperator -> String
212−unaryOperatorString Negate = "-"
213−unaryOperatorString Not = "!"
214−unaryOperatorString BitwiseNot = "~"
215−
216−binaryOperatorString :: BinaryOperator -> String
217−binaryOperatorString Add = "+"
218−binaryOperatorString Subtract = "-"
219−binaryOperatorString Multiply = "*"
220−binaryOperatorString Divide = "/"
221−binaryOperatorString Modulus = "%"
222−binaryOperatorString LessThan = "<"
223−binaryOperatorString LessThanOrEqualTo = "<="
224−binaryOperatorString GreaterThan = ">"
225−binaryOperatorString GreaterThanOrEqualTo = ">="
226−binaryOperatorString BitwiseAnd = "&"
227−binaryOperatorString BitwiseOr = "|"
228−binaryOperatorString BitwiseXor = "^"
229−binaryOperatorString ShiftLeft = "<<"
230−binaryOperatorString ShiftRight = ">>"
231−binaryOperatorString ZeroFillShiftRight = ">>>"
232−binaryOperatorString EqualTo = "==="
233−binaryOperatorString NotEqualTo = "!=="
234−binaryOperatorString And = "&&"
235−binaryOperatorString Or = "||"
236−binaryOperatorString Concat = "+"
237−
238−binderToJs :: String -> String -> Binder -> Gen String
239−binderToJs varName done (StringBinder str) =
240− return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
241−binderToJs varName done (NumberBinder num) =
242− return $ "if (" ++ varName ++ " === \"" ++ either show show num ++ "\") {" ++ done ++ " }"
243−binderToJs varName done (BooleanBinder True) =
244− return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
245−binderToJs varName done (BooleanBinder False) =
246− return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
247−binderToJs varName done (VarBinder s) =
248− return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done
249−binderToJs varName done (NullaryBinder ctor) =
250− return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
251−binderToJs 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 ++ " }"
255−binderToJs 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
263−binderToJs 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
278−
279−objectPropertyToJs :: (String, Value) -> String
280−objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
281−
282−statementToJs :: Statement -> String
283−statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
284−statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value
285−statementToJs (While cond sts) = "while ("
286− ++ valueToJs cond ++ ") {"
287− ++ intercalate ";" (map statementToJs sts) ++ "}"
288−statementToJs (For (init, cond, done) sts) = "for (" ++
289− statementToJs init
290− ++ "; " ++ valueToJs cond
291− ++ "; " ++ statementToJs done
292− ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
293−statementToJs (IfThenElse cond thens elses) = "if ("
294− ++ valueToJs cond ++ ") {"
295− ++ intercalate ";" (map statementToJs thens) ++ "}"
296− ++ flip (maybe "") elses (\sts ->
297− " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
298−statementToJs (Return value) = "return " ++ valueToJs value
299−
300−assignmentTargetToJs :: AssignmentTarget -> String
301−assignmentTargetToJs (AssignVariable var) = var
302−assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"
303−assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop
304−
305−-- Externs
306−
307−typeLiterals :: Pattern Type String
308−typeLiterals = 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
318−
319−rowToPs :: Row -> String
320−rowToPs = (\(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)
331−
332−typeApp :: Pattern Type (Type, Type)
333−typeApp = Pattern $ A.Kleisli match
334− where
335− match (TypeApp f x) = Just (f, x)
336− match _ = Nothing
337−
338−function :: Pattern Type ([Type], Type)
339−function = Pattern $ A.Kleisli match
340− where
341− match (Function args ret) = Just (args, ret)
342− match _ = Nothing
343−
344−typeToPs :: Type -> String
345−typeToPs = 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 ]
353−
354−externToJs :: (String, Type) -> String
355−externToJs (name, ty) = "extern " ++ name ++ " :: " ++ typeToPs ty
src/PureScript/CodeGen/Common.hsnew file+79
@@ -0,0 +1,79 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.CodeGen.Common
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+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs #-}
16+
17+module PureScript.CodeGen.Common where
18+
19+import Data.Maybe (fromMaybe)
20+import Data.List (nub, intersperse, intercalate)
21+import Data.Function (fix)
22+import Control.Monad.State
23+import Control.Applicative (Applicative(..), Alternative(..))
24+import qualified Control.Category as C
25+import Control.Category ((>>>))
26+import qualified Control.Arrow as A
27+import Control.Arrow ((***))
28+
29+import PureScript.Values
30+import PureScript.Types
31+import PureScript.Declarations
32+
33+newtype Pattern a b = Pattern { runPattern :: A.Kleisli Maybe a b } deriving (C.Category, A.Arrow)
34+
35+pattern :: Pattern a b -> a -> Maybe b
36+pattern = A.runKleisli . runPattern
37+
38+instance Functor (Pattern a) where
39+ fmap f p = Pattern $ A.Kleisli $ fmap f . pattern p
40+
41+instance Applicative (Pattern a) where
42+ pure = Pattern . A.Kleisli . const . pure
43+ f <*> x = Pattern . A.Kleisli $ \a -> pattern f a <*> pattern x a
44+
45+instance Alternative (Pattern a) where
46+ empty = Pattern $ A.Kleisli $ \a -> empty
47+ (Pattern (A.Kleisli p)) <|> (Pattern (A.Kleisli q)) = Pattern $ A.Kleisli $ \a -> p a <|> q a
48+
49+parens :: String -> String
50+parens s = ('(':s) ++ ")"
51+
52+chainl :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
53+chainl split f p = fix $ \c -> (split >>> (c *** p) >>> A.arr (uncurry f)) <|> p
54+
55+chainr :: Pattern a (a, a) -> (r -> r -> r) -> Pattern a r -> Pattern a r
56+chainr split f p = fix $ \c -> (split >>> (p *** c) >>> A.arr (uncurry f)) <|> p
57+
58+wrap :: Pattern a (s, a) -> (s -> r -> r) -> Pattern a r -> Pattern a r
59+wrap split f p = fix $ \c -> (split >>> (C.id *** c) >>> A.arr (uncurry f)) <|> p
60+
61+split :: Pattern a (s, t) -> (s -> t -> r) -> Pattern a r -> Pattern a r
62+split s f p = (s >>> A.arr (uncurry f)) <|> p
63+
64+data OperatorTable a r = OperatorTable { runOperatorTable :: [Operator a r] }
65+
66+data Operator a r where
67+ AssocL :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
68+ AssocR :: Pattern a (a, a) -> (r -> r -> r) -> Operator a r
69+ Wrap :: Pattern a (s, a) -> (s -> r -> r) -> Operator a r
70+ Split :: Pattern a (s, t) -> (s -> t -> r) -> Operator a r
71+
72+buildPrettyPrinter :: OperatorTable a r -> Pattern a r -> Pattern a r
73+buildPrettyPrinter table p = foldl (\p' op ->
74+ case op of
75+ AssocL pat g -> chainl pat g p'
76+ AssocR pat g -> chainr pat g p'
77+ Wrap pat g -> wrap pat g p'
78+ Split pat g -> split pat g p'
79+ ) p $ runOperatorTable table
src/PureScript/CodeGen/Common/Gen.hsnew file+31
@@ -0,0 +1,31 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.CodeGen.Common.Gen
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+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+
17+module PureScript.CodeGen.Common.Gen where
18+
19+import Control.Monad.State
20+import Control.Applicative
21+
22+newtype Gen a = Gen { unGen :: State Int a } deriving (Functor, Applicative, Monad, MonadState Int)
23+
24+runGen :: Gen a -> a
25+runGen = flip evalState 0 . unGen
26+
27+fresh :: Gen String
28+fresh = do
29+ n <- get
30+ modify (+ 1)
31+ return $ "_" ++ show n
src/PureScript/CodeGen/Externs.hsnew file+80
@@ -0,0 +1,80 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PureScript.CodeGen.Externs
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+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-}
16+
17+module PureScript.CodeGen.Externs (
18+ externToPs
19+) where
20+
21+import Data.Maybe (fromMaybe)
22+import Data.List (intersperse, intercalate)
23+import qualified Control.Arrow as A
24+import Control.Applicative
25+
26+import PureScript.Values
27+import PureScript.Types
28+import PureScript.Declarations
29+import PureScript.CodeGen.Common
30+
31+externToPs :: (String, Type) -> String
32+externToPs (name, ty) = "extern " ++ name ++ " :: " ++ typeToPs ty
33+
34+typeLiterals :: Pattern Type String
35+typeLiterals = Pattern $ A.Kleisli match
36+ where
37+ match Number = Just "Number"
38+ match String = Just "String"
39+ match Boolean = Just "Boolean"
40+ match (Array ty) = Just $ "[" ++ typeToPs ty ++ "]"
41+ match (Object row) = Just $ "{ " ++ rowToPs row ++ " }"
42+ match (TypeVar var) = Just var
43+ match (TypeConstructor ctor) = Just ctor
44+ match _ = Nothing
45+
46+rowToPs :: Row -> String
47+rowToPs = (\(tys, tail) -> intercalate "; " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs tail) . toList
48+ where
49+ nameAndTypeToPs :: String -> Type -> String
50+ nameAndTypeToPs name ty = name ++ " :: " ++ typeToPs ty
51+ tailToPs :: Row -> String
52+ tailToPs REmpty = ""
53+ tailToPs (RowVar var) = " | " ++ var
54+ toList :: Row -> ([(String, Type)], Row)
55+ toList (RCons name ty row) = let (tys, rest) = toList row
56+ in ((name, ty):tys, rest)
57+ toList r = ([], r)
58+
59+typeApp :: Pattern Type (Type, Type)
60+typeApp = Pattern $ A.Kleisli match
61+ where
62+ match (TypeApp f x) = Just (f, x)
63+ match _ = Nothing
64+
65+function :: Pattern Type ([Type], Type)
66+function = Pattern $ A.Kleisli match
67+ where
68+ match (Function args ret) = Just (args, ret)
69+ match _ = Nothing
70+
71+typeToPs :: Type -> String
72+typeToPs = fromMaybe (error "Incomplete pattern") . pattern matchType
73+ where
74+ matchType :: Pattern Type String
75+ matchType = buildPrettyPrinter operators (typeLiterals <|> fmap parens matchType)
76+ operators :: OperatorTable Type String
77+ operators =
78+ OperatorTable $ [ AssocL typeApp $ \f x -> f ++ " " ++ x
79+ , Split function $ \args ret -> "(" ++ intercalate ", " (map typeToPs args) ++ ") -> " ++ typeToPs ret ]
80+
src/PureScript/CodeGen/JS.hsnew file+232
@@ -0,0 +1,232 @@
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+-----------------------------------------------------------------------------
14+
15+module PureScript.CodeGen.JS (
16+ declToJs
17+) where
18+
19+import Data.Maybe (fromMaybe)
20+import Data.List (intercalate)
21+import qualified Control.Arrow as A
22+import Control.Applicative
23+
24+import PureScript.Types
25+import PureScript.Values
26+import PureScript.Declarations
27+import PureScript.CodeGen.Common
28+import PureScript.CodeGen.Common.Gen
29+
30+declToJs :: Declaration -> Maybe String
31+declToJs (ValueDeclaration name val) = Just $ "var " ++ name ++ " = " ++ valueToJs val ++ ";"
32+declToJs (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 }; };"
37+declToJs _ = Nothing
38+
39+literals :: Pattern Value String
40+literals = 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
61+
62+accessor :: Pattern Value (String, Value)
63+accessor = Pattern $ A.Kleisli match
64+ where
65+ match (Accessor prop val) = Just (prop, val)
66+ match _ = Nothing
67+
68+indexer :: Pattern Value (String, Value)
69+indexer = Pattern $ A.Kleisli match
70+ where
71+ match (Indexer index val) = Just (valueToJs index, val)
72+ match _ = Nothing
73+
74+app :: Pattern Value (String, Value)
75+app = Pattern $ A.Kleisli match
76+ where
77+ match (App val args) = Just (intercalate "," (map valueToJs args), val)
78+ match _ = Nothing
79+
80+lam :: Pattern Value ([String], Value)
81+lam = Pattern $ A.Kleisli match
82+ where
83+ match (Abs args val) = Just (args, val)
84+ match _ = Nothing
85+
86+unary :: UnaryOperator -> String -> Operator Value String
87+unary 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
94+
95+binary :: BinaryOperator -> String -> Operator Value String
96+binary 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
103+
104+valueToJs :: Value -> String
105+valueToJs = 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+ ]
139+
140+unaryOperatorString :: UnaryOperator -> String
141+unaryOperatorString Negate = "-"
142+unaryOperatorString Not = "!"
143+unaryOperatorString BitwiseNot = "~"
144+
145+binaryOperatorString :: BinaryOperator -> String
146+binaryOperatorString Add = "+"
147+binaryOperatorString Subtract = "-"
148+binaryOperatorString Multiply = "*"
149+binaryOperatorString Divide = "/"
150+binaryOperatorString Modulus = "%"
151+binaryOperatorString LessThan = "<"
152+binaryOperatorString LessThanOrEqualTo = "<="
153+binaryOperatorString GreaterThan = ">"
154+binaryOperatorString GreaterThanOrEqualTo = ">="
155+binaryOperatorString BitwiseAnd = "&"
156+binaryOperatorString BitwiseOr = "|"
157+binaryOperatorString BitwiseXor = "^"
158+binaryOperatorString ShiftLeft = "<<"
159+binaryOperatorString ShiftRight = ">>"
160+binaryOperatorString ZeroFillShiftRight = ">>>"
161+binaryOperatorString EqualTo = "==="
162+binaryOperatorString NotEqualTo = "!=="
163+binaryOperatorString And = "&&"
164+binaryOperatorString Or = "||"
165+binaryOperatorString Concat = "+"
166+
167+binderToJs :: String -> String -> Binder -> Gen String
168+binderToJs varName done (StringBinder str) =
169+ return $ "if (" ++ varName ++ " === \"" ++ str ++ "\") {" ++ done ++ " }"
170+binderToJs varName done (NumberBinder num) =
171+ return $ "if (" ++ varName ++ " === \"" ++ either show show num ++ "\") {" ++ done ++ " }"
172+binderToJs varName done (BooleanBinder True) =
173+ return $ "if (" ++ varName ++ ") {" ++ done ++ " }"
174+binderToJs varName done (BooleanBinder False) =
175+ return $ "if (!" ++ varName ++ ") {" ++ done ++ " }"
176+binderToJs varName done (VarBinder s) =
177+ return $ "var " ++ s ++ " = " ++ varName ++ "; " ++ done
178+binderToJs varName done (NullaryBinder ctor) =
179+ return $ "if (" ++ varName ++ ".ctor === \"" ++ ctor ++ "\") { " ++ done ++ " }"
180+binderToJs 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 ++ " }"
184+binderToJs 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
192+binderToJs 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
207+
208+objectPropertyToJs :: (String, Value) -> String
209+objectPropertyToJs (key, value) = key ++ ":" ++ valueToJs value
210+
211+statementToJs :: Statement -> String
212+statementToJs (VariableIntroduction name value) = "var " ++ name ++ " = " ++ valueToJs value
213+statementToJs (Assignment target value) = assignmentTargetToJs target ++ " = " ++ valueToJs value
214+statementToJs (While cond sts) = "while ("
215+ ++ valueToJs cond ++ ") {"
216+ ++ intercalate ";" (map statementToJs sts) ++ "}"
217+statementToJs (For (init, cond, done) sts) = "for (" ++
218+ statementToJs init
219+ ++ "; " ++ valueToJs cond
220+ ++ "; " ++ statementToJs done
221+ ++ ") {" ++ intercalate ";" (map statementToJs sts) ++ "}"
222+statementToJs (IfThenElse cond thens elses) = "if ("
223+ ++ valueToJs cond ++ ") {"
224+ ++ intercalate ";" (map statementToJs thens) ++ "}"
225+ ++ flip (maybe "") elses (\sts ->
226+ " else {" ++ intercalate ";" (map statementToJs sts) ++ "}")
227+statementToJs (Return value) = "return " ++ valueToJs value
228+
229+assignmentTargetToJs :: AssignmentTarget -> String
230+assignmentTargetToJs (AssignVariable var) = var
231+assignmentTargetToJs (AssignArrayIndex index tgt) = assignmentTargetToJs tgt ++ "[" ++ valueToJs index ++ "]"
232+assignmentTargetToJs (AssignObjectProperty prop tgt) = assignmentTargetToJs tgt ++ "." ++ prop