git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Add a --comments option
a64cb50Nicolas Biri
psc-make/Main.hs+16−9
compare with golang
unifiedsplit
@@ -18,8 +18,10 @@ module Main where
18
18
19import Control.Applicative
19import Control.Applicative
20import Control.Monad.Error
20import Control.Monad.Error
21+import Control.Monad.Reader
21
22
22import Data.Version (showVersion)
23import Data.Version (showVersion)
24+import Data.Traversable (traverse)
23
25
24import Options.Applicative as Opts
26import Options.Applicative as Opts
25
27
@@ -50,20 +52,19 @@ readInput InputOptions{..} = do
50 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
52 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
51 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)
53 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)
52
54
55+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }
53−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
56+ deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))
54
57
55−runMake :: Make a -> IO (Either String a)
58+runMake :: P.Options P.Make -> Make a -> IO (Either String a)
56−runMake = runErrorT . unMake
59+runMake opts = runErrorT . flip runReaderT opts . unMake
57
60
58makeIO :: IO a -> Make a
61makeIO :: IO a -> Make a
59−makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
62+makeIO = Make . lift . ErrorT . fmap (either (Left . show) Right) . tryIOError
60
63
61instance P.MonadMake Make where
64instance P.MonadMake Make where
62 getTimestamp path = makeIO $ do
65 getTimestamp path = makeIO $ do
63 exists <- doesFileExist path
66 exists <- doesFileExist path
64− case exists of
65− True -> Just <$> getModificationTime path
67+ traverse (const $ getModificationTime path) $ guard exists
66− False -> return Nothing
67 readTextFile path = makeIO $ do
68 readTextFile path = makeIO $ do
68 putStrLn $ "Reading " ++ path
69 putStrLn $ "Reading " ++ path
69 readFile path
70 readFile path
@@ -71,7 +72,6 @@ instance P.MonadMake Make where
71 mkdirp path
72 mkdirp path
72 putStrLn $ "Writing " ++ path
73 putStrLn $ "Writing " ++ path
73 writeFile path text
74 writeFile path text
74− liftError = either throwError return
75 progress = makeIO . putStrLn
75 progress = makeIO . putStrLn
76
76
77compile :: PSCMakeOptions -> IO ()
77compile :: PSCMakeOptions -> IO ()
@@ -82,7 +82,7 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do
82 print err
82 print err
83 exitFailure
83 exitFailure
84 Right ms -> do
84 Right ms -> do
85− e <- runMake $ P.make outputDir opts ms prefix
85+ e <- runMake opts $ P.make outputDir ms prefix
86 case e of
86 case e of
87 Left err -> do
87 Left err -> do
88 putStrLn err
88 putStrLn err
@@ -130,6 +130,12 @@ noOpts = switch $
130 long "no-opts"
130 long "no-opts"
131 <> help "Skip the optimization phase."
131 <> help "Skip the optimization phase."
132
132
133+comments :: Parser Bool
134+comments = switch $
135+ short 'c'
136+ <> long "comments"
137+ <> help "Include comments in the generated code."
138+
133verboseErrors :: Parser Bool
139verboseErrors :: Parser Bool
134verboseErrors = switch $
140verboseErrors = switch $
135 short 'v'
141 short 'v'
@@ -149,6 +155,7 @@ options = P.Options <$> noPrelude
149 <*> noMagicDo
155 <*> noMagicDo
150 <*> pure Nothing
156 <*> pure Nothing
151 <*> noOpts
157 <*> noOpts
158+ <*> comments
152 <*> verboseErrors
159 <*> verboseErrors
153 <*> pure P.MakeOptions
160 <*> pure P.MakeOptions
154
161
psc/Main.hs+9−1
@@ -18,6 +18,7 @@ module Main where
18
18
19import Control.Applicative
19import Control.Applicative
20import Control.Monad.Error
20import Control.Monad.Error
21+import Control.Monad.Reader
21
22
22import Data.Maybe (fromMaybe)
23import Data.Maybe (fromMaybe)
23import Data.Version (showVersion)
24import Data.Version (showVersion)
@@ -61,7 +62,7 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do
61 hPutStrLn stderr $ show err
62 hPutStrLn stderr $ show err
62 exitFailure
63 exitFailure
63 Right ms -> do
64 Right ms -> do
64− case P.compile opts (map snd ms) prefix of
65+ case P.compile (map snd ms) prefix `runReaderT` opts of
65 Left err -> do
66 Left err -> do
66 hPutStrLn stderr err
67 hPutStrLn stderr err
67 exitFailure
68 exitFailure
@@ -137,6 +138,12 @@ noPrelude = switch $
137 long "no-prelude"
138 long "no-prelude"
138 <> help "Omit the Prelude"
139 <> help "Omit the Prelude"
139
140
141+comments :: Parser Bool
142+comments = switch $
143+ short 'c'
144+ <> long "comments"
145+ <> help "Include comments in the generated code."
146+
140useStdIn :: Parser Bool
147useStdIn :: Parser Bool
141useStdIn = switch $
148useStdIn = switch $
142 short 's'
149 short 's'
@@ -173,6 +180,7 @@ options = P.Options <$> noPrelude
173 <*> runMain
180 <*> runMain
174 <*> noOpts
181 <*> noOpts
175 <*> verboseErrors
182 <*> verboseErrors
183+ <*> comments
176 <*> additionalOptions
184 <*> additionalOptions
177 where
185 where
178 additionalOptions =
186 additionalOptions =
psci/Main.hs+16−18
@@ -28,7 +28,7 @@ import qualified Data.Map as M
28import Control.Applicative
28import Control.Applicative
29import Control.Monad
29import Control.Monad
30import Control.Monad.Error (ErrorT(..), MonadError)
30import Control.Monad.Error (ErrorT(..), MonadError)
31−import Control.Monad.Error.Class (MonadError(..))
31+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32import Control.Monad.Trans.Class
32import Control.Monad.Trans.Class
33import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
33import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
34import Control.Monad.Trans.State.Strict
34import Control.Monad.Trans.State.Strict
@@ -150,7 +150,7 @@ loadAllImportedModules = do
150 modulesOrFirstError <- psciIO $ loadAllModules files
150 modulesOrFirstError <- psciIO $ loadAllModules files
151 case modulesOrFirstError of
151 case modulesOrFirstError of
152 Left err -> psciIO $ print err
152 Left err -> psciIO $ print err
153− Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
153+ Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
154
154
155-- |
155-- |
156-- Expands tilde in path.
156-- Expands tilde in path.
@@ -314,7 +314,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
314-- | Compilation options.
314-- | Compilation options.
315--
315--
316options :: P.Options P.Make
316options :: P.Options P.Make
317−options = P.Options False False False Nothing False False P.MakeOptions
317+options = P.Options False False False Nothing False False False P.MakeOptions
318
318
319-- |
319-- |
320-- PSCI monad
320-- PSCI monad
@@ -322,27 +322,25 @@ options = P.Options False False False Nothing False False P.MakeOptions
322newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
322newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
323
323
324psciIO :: IO a -> PSCI a
324psciIO :: IO a -> PSCI a
325−psciIO io = PSCI (lift (lift io))
325+psciIO io = PSCI . lift $ lift io
326
326
327+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }
327−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)
328+ deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))
328
329
329runMake :: Make a -> IO (Either String a)
330runMake :: Make a -> IO (Either String a)
330−runMake = runErrorT . unMake
331+runMake = runErrorT . flip runReaderT options . unMake
331
332
332makeIO :: IO a -> Make a
333makeIO :: IO a -> Make a
333−makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
334+makeIO = Make . lift . ErrorT . fmap (either (Left . show) Right) . tryIOError
334
335
335instance P.MonadMake Make where
336instance P.MonadMake Make where
336 getTimestamp path = makeIO $ do
337 getTimestamp path = makeIO $ do
337 exists <- doesFileExist path
338 exists <- doesFileExist path
338− if exists
339− then Just <$> getModificationTime path
339+ traverse (const $ getModificationTime path) $ guard exists
340− else return Nothing
341 readTextFile path = makeIO $ readFile path
340 readTextFile path = makeIO $ readFile path
342 writeTextFile path text = makeIO $ do
341 writeTextFile path text = makeIO $ do
343 mkdirp path
342 mkdirp path
344 writeFile path text
343 writeFile path text
345− liftError = either throwError return
346 progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s
344 progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s
347
345
348mkdirp :: FilePath -> IO ()
346mkdirp :: FilePath -> IO ()
@@ -402,7 +400,7 @@ handleDeclaration :: P.Expr -> PSCI ()
402handleDeclaration val = do
400handleDeclaration val = do
403 st <- PSCI $ lift get
401 st <- PSCI $ lift get
404 let m = createTemporaryModule True st val
402 let m = createTemporaryModule True st val
405− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
403+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
406 case e of
404 case e of
407 Left err -> PSCI $ outputStrLn err
405 Left err -> PSCI $ outputStrLn err
408 Right _ -> do
406 Right _ -> do
@@ -423,7 +421,7 @@ handleLet ds = do
423 st <- PSCI $ lift get
421 st <- PSCI $ lift get
424 let st' = updateLets ds st
422 let st' = updateLets ds st
425 let m = createTemporaryModule False st' (P.ObjectLiteral [])
423 let m = createTemporaryModule False st' (P.ObjectLiteral [])
426− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
424+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
427 case e of
425 case e of
428 Left err -> PSCI $ outputStrLn err
426 Left err -> PSCI $ outputStrLn err
429 Right _ -> PSCI $ lift (put st')
427 Right _ -> PSCI $ lift (put st')
@@ -456,7 +454,7 @@ handleImport :: P.ModuleName -> PSCI ()
456handleImport moduleName = do
454handleImport moduleName = do
457 st <- updateImports moduleName <$> PSCI (lift get)
455 st <- updateImports moduleName <$> PSCI (lift get)
458 let m = createTemporaryModuleForImports st
456 let m = createTemporaryModuleForImports st
459− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
457+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
460 case e of
458 case e of
461 Left err -> PSCI $ outputStrLn err
459 Left err -> PSCI $ outputStrLn err
462 Right _ -> do
460 Right _ -> do
@@ -470,7 +468,7 @@ handleTypeOf :: P.Expr -> PSCI ()
470handleTypeOf val = do
468handleTypeOf val = do
471 st <- PSCI $ lift get
469 st <- PSCI $ lift get
472 let m = createTemporaryModule False st val
470 let m = createTemporaryModule False st val
473− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
471+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
474 case e of
472 case e of
475 Left err -> PSCI $ outputStrLn err
473 Left err -> PSCI $ outputStrLn err
476 Right env' ->
474 Right env' ->
@@ -504,7 +502,7 @@ handleBrowse :: P.ModuleName -> PSCI ()
504handleBrowse moduleName = do
502handleBrowse moduleName = do
505 st <- PSCI $ lift get
503 st <- PSCI $ lift get
506 let loadedModules = psciLoadedModules st
504 let loadedModules = psciLoadedModules st
507− env <- psciIO . runMake $ P.make modulesDir options loadedModules []
505+ env <- psciIO . runMake $ P.make modulesDir loadedModules []
508 case env of
506 case env of
509 Left err -> PSCI $ outputStrLn err
507 Left err -> PSCI $ outputStrLn err
510 Right env' ->
508 Right env' ->
@@ -520,7 +518,7 @@ handleKindOf typ = do
520 st <- PSCI $ lift get
518 st <- PSCI $ lift get
521 let m = createTemporaryModuleForKind st typ
519 let m = createTemporaryModuleForKind st typ
522 mName = P.ModuleName [P.ProperName "$PSCI"]
520 mName = P.ModuleName [P.ProperName "$PSCI"]
523− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
521+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
524 case e of
522 case e of
525 Left err -> PSCI $ outputStrLn err
523 Left err -> PSCI $ outputStrLn err
526 Right env' ->
524 Right env' ->
@@ -571,7 +569,7 @@ handleCommand (LoadFile filePath) = do
571 PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
569 PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
572handleCommand Reset = do
570handleCommand Reset = do
573 files <- psciImportedFilenames <$> PSCI (lift get)
571 files <- psciImportedFilenames <$> PSCI (lift get)
574− PSCI . lift . modify $ \st -> st
572+ PSCI . lift . modify $ \st -> st
575 { psciImportedFilenames = files
573 { psciImportedFilenames = files
576 , psciImportedModuleNames = defaultImports
574 , psciImportedModuleNames = defaultImports
577 , psciLetBindings = []
575 , psciLetBindings = []
src/Language/PureScript.hs+40−35
@@ -13,7 +13,7 @@
13--
13--
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16−{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}
16+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}
17
17
18module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
18module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
19
19
@@ -22,6 +22,7 @@ import Data.Function (on)
22import Data.List (sortBy, groupBy, intercalate)
22import Data.List (sortBy, groupBy, intercalate)
23import Data.Maybe (fromMaybe)
23import Data.Maybe (fromMaybe)
24import Data.Time.Clock
24import Data.Time.Clock
25+import qualified Data.Traversable as T (traverse)
25import qualified Data.ByteString.UTF8 as BU
26import qualified Data.ByteString.UTF8 as BU
26import qualified Data.Map as M
27import qualified Data.Map as M
27import qualified Data.Set as S
28import qualified Data.Set as S
@@ -29,6 +30,7 @@ import qualified Data.Set as S
29import Control.Applicative
30import Control.Applicative
30import Control.Arrow ((&&&))
31import Control.Arrow ((&&&))
31import Control.Monad.Error
32import Control.Monad.Error
33+import Control.Monad.Reader
32
34
33import System.FilePath ((</>))
35import System.FilePath ((</>))
34
36
@@ -71,42 +73,47 @@ import qualified Language.PureScript.Constants as C
71--
73--
72-- * Pretty-print the generated Javascript
74-- * Pretty-print the generated Javascript
73--
75--
76+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
74−compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
77+ => [Module] -> [String] -> m (String, String, Environment)
75compile = compile' initEnvironment
78compile = compile' initEnvironment
76
79
80+compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
77−compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
81+ => Environment -> [Module] -> [String] -> m (String, String, Environment)
78−compile' env opts ms prefix = do
82+compile' env ms prefix = do
83+ noPrelude <- asks optionsNoPrelude
84+ additional <- asks optionsAdditional
85+ mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
79− (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms
86+ (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
80 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
87 (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
81− (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
88+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
82 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
89 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
83 let corefn = map (CoreFn.moduleToCoreFn env') regrouped
90 let corefn = map (CoreFn.moduleToCoreFn env') regrouped
84− let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)
91+ let entryPoints = moduleNameFromString `map` entryPointModules additional
85 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
92 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
86 let renamed = renameInModules elim
93 let renamed = renameInModules elim
87− let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)
94+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
88 let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
95 let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
89− let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen
96+ js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
90 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
97 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
91− js' <- generateMain env' opts js
98+ js' <- generateMain env' js
92 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
99 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
93 return (pjs, exts, env')
100 return (pjs, exts, env')
94− where
95− mainModuleIdent = moduleNameFromString <$> optionsMain opts
96
101
97−generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]
102+generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
98−generateMain env opts js =
103+generateMain env js = do
104+ main <- asks optionsMain
105+ additional <- asks optionsAdditional
99− case moduleNameFromString <$> optionsMain opts of
106+ case moduleNameFromString <$> main of
100 Just mmi -> do
107 Just mmi -> do
101 when ((mmi, Ident C.main) `M.notMember` names env) $
108 when ((mmi, Ident C.main) `M.notMember` names env) $
102− Left $ show mmi ++ "." ++ C.main ++ " is undefined"
109+ throwError $ show mmi ++ "." ++ C.main ++ " is undefined"
103− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]
110+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
104 _ -> return js
111 _ -> return js
105
112
106-- |
113-- |
107-- A type class which collects the IO actions we need to be able to run in "make" mode
114-- A type class which collects the IO actions we need to be able to run in "make" mode
108--
115--
109−class MonadMake m where
116+class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where
110 -- |
117 -- |
111 -- Get a file timestamp
118 -- Get a file timestamp
112 --
119 --
@@ -122,11 +129,6 @@ class MonadMake m where
122 --
129 --
123 writeTextFile :: FilePath -> String -> m ()
130 writeTextFile :: FilePath -> String -> m ()
124
131
125− -- |
126− -- Report an error
127− --
128− liftError :: Either String a -> m a
129−
130 -- |
132 -- |
131 -- Respond to a progress update
133 -- Respond to a progress update
132 --
134 --
@@ -152,11 +154,13 @@ traverseEither f (Right y) = Right <$> f y
152-- If timestamps have not changed, the externs file can be used to provide the module's types without
154-- If timestamps have not changed, the externs file can be used to provide the module's types without
153-- having to typecheck the module again.
155-- having to typecheck the module again.
154--
156--
157+make :: (Functor m, Applicative m, Monad m, MonadMake m)
155−make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
158+ => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
156−make outputDir opts ms prefix = do
159+make outputDir ms prefix = do
160+ noPrelude <- asks optionsNoPrelude
157 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
161 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
158
162
159− (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms
163+ (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
160
164
161 toRebuild <- foldM (\s (Module moduleName' _ _) -> do
165 toRebuild <- foldM (\s (Module moduleName' _ _) -> do
162 let filePath = runModuleName moduleName'
166 let filePath = runModuleName moduleName'
@@ -176,15 +180,16 @@ make outputDir opts ms prefix = do
176
180
177 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
181 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
178
182
179− (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
183+ (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
180
184
181− evalSupplyT nextVar (go initEnvironment desugared)
185+ evalSupplyT nextVar $ go initEnvironment desugared
182
186
183 where
187 where
188+ go :: (Functor m, Applicative m, Monad m, MonadMake m)
184− go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment
189+ => Environment -> [(Bool, Module)] -> SupplyT m Environment
185 go env [] = return env
190 go env [] = return env
186 go env ((False, m) : ms') = do
191 go env ((False, m) : ms') = do
187− (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
192+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
188
193
189 go env' ms'
194 go env' ms'
190 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
195 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
@@ -194,15 +199,15 @@ make outputDir opts ms prefix = do
194
199
195 lift . progress $ "Compiling " ++ runModuleName moduleName'
200 lift . progress $ "Compiling " ++ runModuleName moduleName'
196
201
197− (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
202+ (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
198
203
199− regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
204+ regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
200
205
201 let mod' = Module moduleName' regrouped exps
206 let mod' = Module moduleName' regrouped exps
202 let corefn = CoreFn.moduleToCoreFn env' mod'
207 let corefn = CoreFn.moduleToCoreFn env' mod'
203 let [renamed] = renameInModules [corefn]
208 let [renamed] = renameInModules [corefn]
204
209
205− pjs <- prettyPrintJS <$> moduleToJs opts renamed
210+ pjs <- prettyPrintJS <$> moduleToJs renamed
206 let js = unlines $ map ("// " ++) prefix ++ [pjs]
211 let js = unlines $ map ("// " ++) prefix ++ [pjs]
207 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
212 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
208
213
@@ -220,10 +225,10 @@ make outputDir opts ms prefix = do
220 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
225 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
221 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
226 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
222 externs <- readTextFile externsFile
227 externs <- readTextFile externsFile
223− externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)]
228+ externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
224 case externsModules of
229 case externsModules of
225 [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
230 [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
226− _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
231+ _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
227
232
228reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
233reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
229reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
234reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
src/Language/PureScript/CodeGen/JS.hs+49−31
@@ -13,21 +13,22 @@
13--
13--
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16−{-# LANGUAGE GADTs, ViewPatterns #-}
16+{-# LANGUAGE GADTs, ViewPatterns, FlexibleContexts #-}
17
17
18module Language.PureScript.CodeGen.JS (
18module Language.PureScript.CodeGen.JS (
19 module AST,
19 module AST,
20 module Common,
20 module Common,
21− bindToJs,
22 moduleToJs
21 moduleToJs
23) where
22) where
24
23
25import Data.List ((\\), delete)
24import Data.List ((\\), delete)
26import Data.Maybe (mapMaybe)
25import Data.Maybe (mapMaybe)
26+import qualified Data.Traversable as T (traverse)
27
27
28import Control.Applicative
28import Control.Applicative
29import Control.Arrow ((&&&))
29import Control.Arrow ((&&&))
30import Control.Monad (foldM, replicateM, forM)
30import Control.Monad (foldM, replicateM, forM)
31+import Control.Monad.Reader (MonadReader, asks, lift)
31
32
32import Language.PureScript.CodeGen.JS.AST as AST
33import Language.PureScript.CodeGen.JS.AST as AST
33import Language.PureScript.CodeGen.JS.Common as Common
34import Language.PureScript.CodeGen.JS.Common as Common
@@ -43,16 +44,18 @@ import qualified Language.PureScript.Constants as C
43-- Generate code in the simplified Javascript intermediate representation for all declarations in a
44-- Generate code in the simplified Javascript intermediate representation for all declarations in a
44-- module.
45-- module.
45--
46--
46−moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]
47+moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
48+ => Module Ann -> SupplyT m [JS]
47−moduleToJs opts (Module name imps exps foreigns decls) = do
49+moduleToJs (Module name imps exps foreigns decls) = do
50+ additional <- lift $ asks optionsAdditional
48− let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
51+ jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
49 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
52 let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
50 jsDecls <- mapM (bindToJs name) decls
53 jsDecls <- mapM (bindToJs name) decls
51− let optimized = concatMap (map $ optimize opts) jsDecls
54+ optimized <- lift $ T.traverse (T.traverse optimize) jsDecls
52 let isModuleEmpty = null exps
55 let isModuleEmpty = null exps
53− let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized
56+ let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized
54 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
57 let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
55− return $ case optionsAdditional opts of
58+ return $ case additional of
56 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
59 MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
57 CompileOptions ns _ _ | not isModuleEmpty ->
60 CompileOptions ns _ _ | not isModuleEmpty ->
58 [ JSVariableIntroduction ns
61 [ JSVariableIntroduction ns
@@ -65,18 +68,19 @@ moduleToJs opts (Module name imps exps foreigns decls) = do
65-- |
68-- |
66-- Generates Javascript code for a module import.
69-- Generates Javascript code for a module import.
67--
70--
68−importToJs :: Options mode -> ModuleName -> JS
71+importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS
69−importToJs opts mn =
72+importToJs mn = do
70− JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
71− where
72− moduleBody = case optionsAdditional opts of
73+ additional <- asks optionsAdditional
74+ let moduleBody = case additional of
73− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
75+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
74− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
76+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
77+ return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
75
78
76-- |
79-- |
77-- Generate code in the simplified Javascript intermediate representation for a declaration
80-- Generate code in the simplified Javascript intermediate representation for a declaration
78--
81--
82+bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
79−bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m [JS]
83+ => ModuleName -> Bind Ann -> SupplyT m [JS]
80bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
84bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
81bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
85bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
82
86
@@ -86,9 +90,13 @@ bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
86--
90--
87-- The main purpose of this function is to handle code generation for comments.
91-- The main purpose of this function is to handle code generation for comments.
88--
92--
93+nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
89−nonRecToJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Ident -> Expr Ann -> SupplyT m JS
94+ => ModuleName -> Ident -> Expr Ann -> SupplyT m JS
90−nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) =
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)
91− JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
99+ else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
92nonRecToJS mp ident val = do
100nonRecToJS mp ident val = do
93 js <- valueToJs mp val
101 js <- valueToJs mp val
94 return $ JSVariableIntroduction (identToJs ident) (Just js)
102 return $ JSVariableIntroduction (identToJs ident) (Just js)
@@ -117,7 +125,8 @@ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
117-- |
125-- |
118-- Generate code in the simplified Javascript intermediate representation for a value or expression.
126-- Generate code in the simplified Javascript intermediate representation for a value or expression.
119--
127--
128+valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
120−valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
129+ => ModuleName -> Expr Ann -> SupplyT m JS
121valueToJs m (Literal _ l) =
130valueToJs m (Literal _ l) =
122 literalToValueJS m l
131 literalToValueJS m l
123valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =
132valueToJs m (Var (_, _, _, Just (IsConstructor _ 0)) name) =
@@ -128,7 +137,7 @@ valueToJs m (Accessor _ prop val) =
128 accessorString prop <$> valueToJs m val
137 accessorString prop <$> valueToJs m val
129valueToJs m (ObjectUpdate _ o ps) = do
138valueToJs m (ObjectUpdate _ o ps) = do
130 obj <- valueToJs m o
139 obj <- valueToJs m o
131− sts <- mapM (sndM (valueToJs m)) ps
140+ sts <- mapM (sndM $ valueToJs m) ps
132 extendObj obj sts
141 extendObj obj sts
133valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
142valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
134 let args = unAbs e
143 let args = unAbs e
@@ -194,7 +203,8 @@ valueToJs _ (Constructor _ _ (ProperName ctor) arity) =
194iife :: String -> [JS] -> JS
203iife :: String -> [JS] -> JS
195iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
204iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
196
205
206+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
197−literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
207+ => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
198literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
208literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
199literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
209literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
200literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
210literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
@@ -241,9 +251,10 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
241-- Generate code in the simplified Javascript intermediate representation for pattern match binders
251-- Generate code in the simplified Javascript intermediate representation for pattern match binders
242-- and guards.
252-- and guards.
243--
253--
254+bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
244−bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
255+ => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
245bindersToJs m binders vals = do
256bindersToJs m binders vals = do
246− valNames <- replicateM (length vals) freshName
257+ valNames <- replicateM (length vals) $ freshName
247 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
258 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
248 jss <- forM binders $ \(CaseAlternative bs result) -> do
259 jss <- forM binders $ \(CaseAlternative bs result) -> do
249 ret <- guardsToJs result
260 ret <- guardsToJs result
@@ -251,14 +262,16 @@ bindersToJs m binders vals = do
251 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
262 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
252 []
263 []
253 where
264 where
265+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
254− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
266+ => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
255 go _ done [] = return done
267 go _ done [] = return done
256 go (v:vs) done' (b:bs) = do
268 go (v:vs) done' (b:bs) = do
257 done'' <- go vs done' bs
269 done'' <- go vs done' bs
258 binderToJs m v done'' b
270 binderToJs m v done'' b
259 go _ _ _ = error "Invalid arguments to bindersToJs"
271 go _ _ _ = error "Invalid arguments to bindersToJs"
260
272
273+ guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
261− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
274+ => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
262 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
275 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
263 cond' <- valueToJs m cond
276 cond' <- valueToJs m cond
264 done <- valueToJs m val
277 done <- valueToJs m val
@@ -269,7 +282,8 @@ bindersToJs m binders vals = do
269-- Generate code in the simplified Javascript intermediate representation for a pattern match
282-- Generate code in the simplified Javascript intermediate representation for a pattern match
270-- binder.
283-- binder.
271--
284--
285+binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
272−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
286+ => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
273binderToJs _ _ done (NullBinder{}) = return done
287binderToJs _ _ done (NullBinder{}) = return done
274binderToJs m varName done (LiteralBinder _ l) =
288binderToJs m varName done (LiteralBinder _ l) =
275 literalToBinderJS m varName done l
289 literalToBinderJS m varName done l
@@ -286,7 +300,8 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT
286 (JSBlock js)
300 (JSBlock js)
287 Nothing]
301 Nothing]
288 where
302 where
303+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
289− go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]
304+ => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]
290 go _ done' [] = return done'
305 go _ done' [] = return done'
291 go index done' (binder:bs') = do
306 go index done' (binder:bs') = do
292 argVar <- freshName
307 argVar <- freshName
@@ -316,7 +331,8 @@ binderToJs m varName done (NamedBinder _ ident binder) = do
316 js <- binderToJs m varName done binder
331 js <- binderToJs m varName done binder
317 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
332 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
318
333
334+literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
319−literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
335+ => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
320literalToBinderJS _ varName done (NumericLiteral num) =
336literalToBinderJS _ varName done (NumericLiteral num) =
321 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
337 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
322literalToBinderJS _ varName done (StringLiteral str) =
338literalToBinderJS _ varName done (StringLiteral str) =
@@ -327,7 +343,8 @@ literalToBinderJS _ varName done (BooleanLiteral False) =
327 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
343 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
328literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
344literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
329 where
345 where
346+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
330− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
347+ => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
331 go done' [] = return done'
348 go done' [] = return done'
332 go done' ((prop, binder):bs') = do
349 go done' ((prop, binder):bs') = do
333 propVar <- freshName
350 propVar <- freshName
@@ -338,7 +355,8 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do
338 js <- go done 0 bs
355 js <- go done 0 bs
339 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
356 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
340 where
357 where
358+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
341− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
359+ => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
342 go done' _ [] = return done'
360 go done' _ [] = return done'
343 go done' index (binder:bs') = do
361 go done' index (binder:bs') = do
344 elVar <- freshName
362 elVar <- freshName
src/Language/PureScript/CodeGen/JS/Optimizer.hs+29−20
@@ -31,10 +31,14 @@
31--
31--
32-----------------------------------------------------------------------------
32-----------------------------------------------------------------------------
33
33
34+{-# LANGUAGE FlexibleContexts #-}
35+
34module Language.PureScript.CodeGen.JS.Optimizer (
36module Language.PureScript.CodeGen.JS.Optimizer (
35 optimize
37 optimize
36) where
38) where
37
39
40+import Control.Monad.Reader (MonadReader, ask, asks)
41+
38import Language.PureScript.CodeGen.JS.AST
42import Language.PureScript.CodeGen.JS.AST
39import Language.PureScript.Options
43import Language.PureScript.Options
40import qualified Language.PureScript.Constants as C
44import qualified Language.PureScript.Constants as C
@@ -49,29 +53,34 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks
49-- |
53-- |
50-- Apply a series of optimizer passes to simplified Javascript code
54-- Apply a series of optimizer passes to simplified Javascript code
51--
55--
52−optimize :: Options mode -> JS -> JS
56+optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
57+optimize js = do
53−optimize opts | optionsNoOptimizations opts = id
58+ noOpt <- asks optionsNoOptimizations
59+ if noOpt then return js else optimize' js
60+
61+optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
62+optimize' js = do
63+ opts <- ask
54− | otherwise = untilFixedPoint (applyAll
64+ return $ untilFixedPoint (applyAll
55− [ collapseNestedBlocks
65+ [ collapseNestedBlocks
56− , collapseNestedIfs
66+ , collapseNestedIfs
57− , tco opts
67+ , tco opts
58− , magicDo opts
68+ , magicDo opts
59− , removeCodeAfterReturnStatements
69+ , removeCodeAfterReturnStatements
60− , removeUnusedArg
70+ , removeUnusedArg
61− , removeUndefinedApp
71+ , removeUndefinedApp
62− , unThunk
72+ , unThunk
63− , etaConvert
73+ , etaConvert
64− , evaluateIifes
74+ , evaluateIifes
65− , inlineVariables
75+ , inlineVariables
66− , inlineValues
76+ , inlineValues
67− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
77+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
68− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
78+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
69− , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
79+ , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
70− , inlineCommonOperators ])
80+ , inlineCommonOperators ]) js
71
81
72untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
82untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
73untilFixedPoint f = go
83untilFixedPoint f = go
74 where
84 where
75 go a = let a' = f a in
85 go a = let a' = f a in
76 if a' == a then a' else go a'
86 if a' == a then a' else go a'
77−
src/Language/PureScript/CoreFn/Binders.hs+2−1
@@ -13,6 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15{-# LANGUAGE DeriveDataTypeable #-}
15{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE DeriveFunctor #-}
16
17
17module Language.PureScript.CoreFn.Binders where
18module Language.PureScript.CoreFn.Binders where
18
19
@@ -44,4 +45,4 @@ data Binder a
44 -- |
45 -- |
45 -- A binder which binds its input to an identifier
46 -- A binder which binds its input to an identifier
46 --
47 --
47− | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)
48+ | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Expr.hs+12−2
@@ -13,9 +13,12 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15{-# LANGUAGE DeriveDataTypeable #-}
15{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE DeriveFunctor #-}
16
17
17module Language.PureScript.CoreFn.Expr where
18module Language.PureScript.CoreFn.Expr where
18
19
20+import Control.Arrow ((***))
21+
19import qualified Data.Data as D
22import qualified Data.Data as D
20
23
21import Language.PureScript.CoreFn.Binders
24import Language.PureScript.CoreFn.Binders
@@ -62,7 +65,7 @@ data Expr a
62 -- |
65 -- |
63 -- A let binding
66 -- A let binding
64 --
67 --
65− | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)
68+ | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)
66
69
67-- |
70-- |
68-- A let or module binding.
71-- A let or module binding.
@@ -75,7 +78,7 @@ data Bind a
75 -- |
78 -- |
76 -- Mutually recursive binding group for several values
79 -- Mutually recursive binding group for several values
77 --
80 --
78− | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)
81+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)
79
82
80-- |
83-- |
81-- A guard is just a boolean-valued expression that appears alongside a set of binders
84-- A guard is just a boolean-valued expression that appears alongside a set of binders
@@ -96,6 +99,12 @@ data CaseAlternative a = CaseAlternative
96 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
99 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
97 } deriving (Show, D.Data, D.Typeable)
100 } deriving (Show, D.Data, D.Typeable)
98
101
102+instance Functor CaseAlternative where
103+
104+ fmap f (CaseAlternative cabs car) = CaseAlternative
105+ (fmap (fmap f) $ cabs)
106+ (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)
107+
99-- |
108-- |
100-- Extract the annotation from a term
109-- Extract the annotation from a term
101--
110--
@@ -110,6 +119,7 @@ extractAnn (Var a _) = a
110extractAnn (Case a _ _) = a
119extractAnn (Case a _ _) = a
111extractAnn (Let a _ _) = a
120extractAnn (Let a _ _) = a
112
121
122+
113-- |
123-- |
114-- Modify the annotation on a term
124-- Modify the annotation on a term
115--
125--
src/Language/PureScript/CoreFn/Literals.hs+2−1
@@ -13,6 +13,7 @@
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15{-# LANGUAGE DeriveDataTypeable #-}
15{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE DeriveFunctor #-}
16
17
17module Language.PureScript.CoreFn.Literals where
18module Language.PureScript.CoreFn.Literals where
18
19
@@ -42,4 +43,4 @@ data Literal a
42 -- |
43 -- |
43 -- An object literal
44 -- An object literal
44 --
45 --
45− | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)
46+ | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/Errors.hs+2−2
@@ -95,8 +95,8 @@ prettyPrintErrorStack printFullStack (ErrorStack es) =
95prettyPrintErrorStack printFullStack (MultipleErrors es) =
95prettyPrintErrorStack printFullStack (MultipleErrors es) =
96 unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
96 unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
97
97
98−stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a
98+stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
99−stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right
99+stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
100
100
101isErrorNonEmpty :: CompileError -> Bool
101isErrorNonEmpty :: CompileError -> Bool
102isErrorNonEmpty = not . null . compileErrorMessage
102isErrorNonEmpty = not . null . compileErrorMessage
src/Language/PureScript/ModuleDependencies.hs+7−3
@@ -12,11 +12,15 @@
12--
12--
13-----------------------------------------------------------------------------
13-----------------------------------------------------------------------------
14
14
15+{-# LANGUAGE FlexibleContexts #-}
16+
15module Language.PureScript.ModuleDependencies (
17module Language.PureScript.ModuleDependencies (
16 sortModules,
18 sortModules,
17 ModuleGraph
19 ModuleGraph
18) where
20) where
19
21
22+import Control.Monad.Error.Class
23+
20import Data.Graph
24import Data.Graph
21import Data.List (nub)
25import Data.List (nub)
22import Data.Maybe (mapMaybe)
26import Data.Maybe (mapMaybe)
@@ -35,7 +39,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]
35--
39--
36-- Reports an error if the module graph contains a cycle.
40-- Reports an error if the module graph contains a cycle.
37--
41--
38−sortModules :: [Module] -> Either String ([Module], ModuleGraph)
42+sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)
39sortModules ms = do
43sortModules ms = do
40 let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
44 let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
41 ms' <- mapM toModule $ stronglyConnComp verts
45 ms' <- mapM toModule $ stronglyConnComp verts
@@ -66,7 +70,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (
66-- |
70-- |
67-- Convert a strongly connected component of the module graph to a module
71-- Convert a strongly connected component of the module graph to a module
68--
72--
69−toModule :: SCC Module -> Either String Module
73+toModule :: (MonadError String m) => SCC Module -> m Module
70toModule (AcyclicSCC m) = return m
74toModule (AcyclicSCC m) = return m
71toModule (CyclicSCC [m]) = return m
75toModule (CyclicSCC [m]) = return m
72−toModule (CyclicSCC ms) = Left $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
76+toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
src/Language/PureScript/Options.hs+5−2
@@ -69,6 +69,9 @@ data Options mode = Options {
69 -- Verbose error message
69 -- Verbose error message
70 --
70 --
71 , optionsVerboseErrors :: Bool
71 , optionsVerboseErrors :: Bool
72+ -- |
73+ -- Remove the comments from the generated js
74+ , optionsNoComments :: Bool
72 -- |
75 -- |
73 -- Specify the namespace that PureScript modules will be exported to when running in the
76 -- Specify the namespace that PureScript modules will be exported to when running in the
74 -- browser.
77 -- browser.
@@ -80,10 +83,10 @@ data Options mode = Options {
80-- Default compiler options
83-- Default compiler options
81--
84--
82defaultCompileOptions :: Options Compile
85defaultCompileOptions :: Options Compile
83−defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])
86+defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] [])
84
87
85-- |
88-- |
86-- Default make options
89-- Default make options
87--
90--
88defaultMakeOptions :: Options Make
91defaultMakeOptions :: Options Make
89−defaultMakeOptions = Options False False False Nothing False False MakeOptions
92+defaultMakeOptions = Options False False False Nothing False False False MakeOptions
src/Language/PureScript/TypeChecker/Monad.hs+7−4
@@ -23,6 +23,7 @@ import qualified Data.Map as M
23
23
24import Control.Applicative
24import Control.Applicative
25import Control.Monad.Error
25import Control.Monad.Error
26+import Control.Monad.Reader.Class
26import Control.Monad.State
27import Control.Monad.State
27import Control.Monad.Unify
28import Control.Monad.Unify
28
29
@@ -194,14 +195,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
194-- |
195-- |
195-- Run a computation in the Check monad, starting with an empty @Environment@
196-- Run a computation in the Check monad, starting with an empty @Environment@
196--
197--
197−runCheck :: Options mode -> Check a -> Either String (a, Environment)
198+runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)
198−runCheck opts = runCheck' opts initEnvironment
199+runCheck = runCheck' initEnvironment
199
200
200-- |
201-- |
201-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
202-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
202--
203--
203−runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)
204+runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)
205+runCheck' env c = do
206+ verbose <- asks optionsVerboseErrors
204−runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do
207+ stringifyErrorStack verbose $ do
205 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
208 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
206 return (a, checkEnv s)
209 return (a, checkEnv s)
207
210
tests/Main.hs+3−2
@@ -22,6 +22,7 @@ import Data.List (isSuffixOf)
22import Data.Traversable (traverse)
22import Data.Traversable (traverse)
23import Control.Monad
23import Control.Monad
24import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
24import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
25+import Control.Monad.Reader (runReaderT)
25import Control.Applicative
26import Control.Applicative
26import System.Exit
27import System.Exit
27import System.Process
28import System.Process
@@ -38,7 +39,7 @@ loadPrelude :: Either String (String, String, P.Environment)
38loadPrelude =
39loadPrelude =
39 case P.parseModulesFromFiles id [("", P.prelude)] of
40 case P.parseModulesFromFiles id [("", P.prelude)] of
40 Left parseError -> Left (show parseError)
41 Left parseError -> Left (show parseError)
41− Right ms -> P.compile (P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }) (map snd ms) []
42+ Right ms -> runReaderT (P.compile (map snd ms) []) $ P.defaultCompileOptions { P.optionsAdditional = P.CompileOptions "Tests" [] [] }
42
43
43compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
44compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))
44compile opts inputFiles = do
45compile opts inputFiles = do
@@ -46,7 +47,7 @@ compile opts inputFiles = do
46 case modules of
47 case modules of
47 Left parseError ->
48 Left parseError ->
48 return (Left $ show parseError)
49 return (Left $ show parseError)
49− Right ms -> return $ P.compile opts (map snd ms) []
50+ Right ms -> return $ runReaderT (P.compile (map snd ms) []) opts
50
51
51assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
52assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()
52assert preludeExterns opts inputFile f = do
53assert preludeExterns opts inputFile f = do