@@ -13,21 +13,22 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−{-# LANGUAGE GADTs, ViewPatterns #-}
16+{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-}
1717
1818module Language.PureScript.CodeGen.JS (
1919 module AST,
2020 module Common,
21− bindToJs,
2221 moduleToJs
2322) where
2423
2524import Data.List ((\\), delete)
2625import Data.Maybe (mapMaybe)
26+import qualified Data.Traversable as T (traverse)
2727
2828import Control.Applicative
2929import Control.Arrow ((&&&))
3030import Control.Monad (foldM, replicateM, forM)
31+import Control.Monad.Reader (MonadReader, asks, lift)
3132
3233import Language.PureScript.CodeGen.JS.AST as AST
3334import Language.PureScript.CodeGen.JS.Common as Common
@@ -43,16 +44,18 @@ import qualified Language.PureScript.Constants as C
4344-- Generate code in the simplified Javascript intermediate representation for all declarations in a
4445-- module.
4546--
46−moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]
47−moduleToJs opts (Module name imps exps foreigns decls) = do
48− let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
47+moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
48+ => Module Ann -> SupplyT m [JS]
49+moduleToJs (Module name imps exps foreigns decls) = do
50+ additional <- lift $ asks optionsAdditional
51+ jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
4952 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
5053 jsDecls <- mapM (bindToJs name) decls
51− let optimized = concatMap (map $ optimize opts) jsDecls
54+ optimized <- lift $ T.traverse (T.traverse optimize) jsDecls
5255 let isModuleEmpty = null exps
53− let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized
56+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized
5457 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
55− return $ case optionsAdditional opts of
58+ return $ case additional of
5659 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
5760 CompileOptions ns _ _ | not isModuleEmpty ->
5861 [ JSVariableIntroduction ns
@@ -65,18 +68,19 @@ moduleToJs opts (Module name imps exps foreigns decls) = do
6568-- |
6669-- Generates Javascript code for a module import.
6770--
68−importToJs :: Options mode -> ModuleName -> JS
69−importToJs opts mn =
70− JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
71− where
72− moduleBody = case optionsAdditional opts of
73− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
74− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
71+importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS
72+importToJs mn = do
73+ additional <- asks optionsAdditional
74+ let moduleBody = case additional of
75+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
76+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
77+ return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
7578
7679-- |
7780-- Generate code in the simplified Javascript intermediate representation for a declaration
7881--
79−bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m [JS]
82+bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
83+ => ModuleName -> Bind Ann -> SupplyT m [JS]
8084bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
8185bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
8286
@@ -86,9 +90,13 @@ bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
8690--
8791-- The main purpose of this function is to handle code generation for comments.
8892--
89−nonRecToJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Ident -> Expr Ann -> SupplyT m JS
90−nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) =
91− JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
93+nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
94+ => ModuleName -> Ident -> Expr Ann -> SupplyT m JS
95+nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
96+ withoutComment <- lift $ asks optionsNoComments
97+ if withoutComment
98+ then nonRecToJS m i (modifyAnn removeComments e)
99+ else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
92100nonRecToJS mp ident val = do
93101 js <- valueToJs mp val
94102 return $ JSVariableIntroduction (identToJs ident) (Just js)
@@ -117,7 +125,8 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
117125-- |
118126-- Generate code in the simplified Javascript intermediate representation for a value or expression.
119127--
120−valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
128+valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
129+ => ModuleName -> Expr Ann -> SupplyT m JS
121130valueToJs m (Literal _ l) =
122131 literalToValueJS m l
123132valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
@@ -128,7 +137,7 @@ valueToJs m (Accessor _ prop val) =
128137 accessorString prop <$> valueToJs m val
129138valueToJs m (ObjectUpdate _ o ps) = do
130139 obj <- valueToJs m o
131− sts <- mapM (sndM (valueToJs m)) ps
140+ sts <- mapM (sndM $ valueToJs m) ps
132141 extendObj obj sts
133142valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
134143 let args = unAbs e
@@ -191,7 +200,8 @@ valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
191200iife :: String -> [JS] -> JS
192201iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
193202
194−literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
203+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
204+ => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
195205literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
196206literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
197207literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
@@ -238,7 +248,8 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
238248-- Generate code in the simplified Javascript intermediate representation for pattern match binders
239249-- and guards.
240250--
241−bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
251+bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
252+ => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
242253bindersToJs m binders vals = do
243254 valNames <- replicateM (length vals) freshName
244255 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
@@ -248,14 +259,16 @@ bindersToJs m binders vals = do
248259 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
249260 []
250261 where
251− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
262+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
263+ => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
252264 go _ done [] = return done
253265 go (v:vs) done' (b:bs) = do
254266 done'' <- go vs done' bs
255267 binderToJs m v done'' b
256268 go _ _ _ = error "Invalid arguments to bindersToJs"
257269
258− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
270+ guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
271+ => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
259272 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
260273 cond' <- valueToJs m cond
261274 done <- valueToJs m val
@@ -266,7 +279,8 @@ bindersToJs m binders vals = do
266279-- Generate code in the simplified Javascript intermediate representation for a pattern match
267280-- binder.
268281--
269−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
282+binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
283+ => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
270284binderToJs _ _ done (NullBinder{}) = return done
271285binderToJs m varName done (LiteralBinder _ l) =
272286 literalToBinderJS m varName done l
@@ -283,7 +297,8 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT
283297 (JSBlock js)
284298 Nothing]
285299 where
286− go :: (Functor m, Applicative m, Monad m) => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]
300+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
301+ => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]
287302 go [] done' = return done'
288303 go ((field, binder) : remain) done' = do
289304 argVar <- freshName
@@ -313,7 +328,8 @@ binderToJs m varName done (NamedBinder _ ident binder) = do
313328 js <- binderToJs m varName done binder
314329 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
315330
316−literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
331+literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
332+ => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
317333literalToBinderJS _ varName done (NumericLiteral num) =
318334 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
319335literalToBinderJS _ varName done (StringLiteral str) =
@@ -324,7 +340,8 @@ literalToBinderJS _ varName done (BooleanLiteral False) =
324340 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
325341literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
326342 where
327− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
343+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
344+ => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
328345 go done' [] = return done'
329346 go done' ((prop, binder):bs') = do
330347 propVar <- freshName
@@ -335,7 +352,8 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do
335352 js <- go done 0 bs
336353 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
337354 where
338− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
355+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
356+ => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
339357 go done' _ [] = return done'
340358 go done' index (binder:bs') = do
341359 elVar <- freshName