a64cb50 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Add a --comments option

commita64cb50754eaafc194bcf7dc051e8611103beaf5 authorNicolas Biri <nicolas@biri.name> dateThu 12 Feb 2015, 22:19 (12 years ago) parentaae1a07

14 files changed+199−131

compare with golang

unifiedsplit

psc-make/Main.hs+16−9

@@ -18,8 +18,10 @@ module Main where

1818

1919import Control.Applicative

2020import Control.Monad.Error

21+import Control.Monad.Reader

2122

2223import Data.Version (showVersion)

24+import Data.Traversable (traverse)

2325

2426import Options.Applicative as Opts

2527

@@ -50,20 +52,19 @@ readInput InputOptions{..} = do

5052 content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

5153 return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

5254

53−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)

55+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }

56+ deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))

5457

55−runMake :: Make a -> IO (Either String a)

56−runMake = runErrorT . unMake

58+runMake :: P.Options P.Make -> Make a -> IO (Either String a)

59+runMake opts = runErrorT . flip runReaderT opts . unMake

5760

5861makeIO :: 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

6063

6164instance P.MonadMake Make where

6265 getTimestamp path = makeIO $ do

6366 exists <- doesFileExist path

64− case exists of

65− True -> Just <$> getModificationTime path

66− False -> return Nothing

67+ traverse (const $ getModificationTime path) $ guard exists

6768 readTextFile path = makeIO $ do

6869 putStrLn $ "Reading " ++ path

6970 readFile path

@@ -71,7 +72,6 @@ instance P.MonadMake Make where

7172 mkdirp path

7273 putStrLn $ "Writing " ++ path

7374 writeFile path text

74− liftError = either throwError return

7575 progress = makeIO . putStrLn

7676

7777compile :: PSCMakeOptions -> IO ()

@@ -82,7 +82,7 @@ compile (PSCMakeOptions input outputDir opts usePrefix) = do

8282 print err

8383 exitFailure

8484 Right ms -> do

85− e <- runMake $ P.make outputDir opts ms prefix

85+ e <- runMake opts $ P.make outputDir ms prefix

8686 case e of

8787 Left err -> do

8888 putStrLn err

@@ -130,6 +130,12 @@ noOpts = switch $

130130 long "no-opts"

131131 <> help "Skip the optimization phase."

132132

133+comments :: Parser Bool

134+comments = switch $

135+ short 'c'

136+ <> long "comments"

137+ <> help "Include comments in the generated code."

138+

133139verboseErrors :: Parser Bool

134140verboseErrors = switch $

135141 short 'v'

@@ -149,6 +155,7 @@ options = P.Options <$> noPrelude

149155 <*> noMagicDo

150156 <*> pure Nothing

151157 <*> noOpts

158+ <*> comments

152159 <*> verboseErrors

153160 <*> pure P.MakeOptions

154161

psc/Main.hs+9−1

@@ -18,6 +18,7 @@ module Main where

1818

1919import Control.Applicative

2020import Control.Monad.Error

21+import Control.Monad.Reader

2122

2223import Data.Maybe (fromMaybe)

2324import Data.Version (showVersion)

@@ -61,7 +62,7 @@ compile (PSCOptions input opts stdin output externs usePrefix) = do

6162 hPutStrLn stderr $ show err

6263 exitFailure

6364 Right ms -> do

64− case P.compile opts (map snd ms) prefix of

65+ case P.compile (map snd ms) prefix `runReaderT` opts of

6566 Left err -> do

6667 hPutStrLn stderr err

6768 exitFailure

@@ -137,6 +138,12 @@ noPrelude = switch $

137138 long "no-prelude"

138139 <> help "Omit the Prelude"

139140

141+comments :: Parser Bool

142+comments = switch $

143+ short 'c'

144+ <> long "comments"

145+ <> help "Include comments in the generated code."

146+

140147useStdIn :: Parser Bool

141148useStdIn = switch $

142149 short 's'

@@ -173,6 +180,7 @@ options = P.Options <$> noPrelude

173180 <*> runMain

174181 <*> noOpts

175182 <*> verboseErrors

183+ <*> comments

176184 <*> additionalOptions

177185 where

178186 additionalOptions =

psci/Main.hs+16−18

@@ -28,7 +28,7 @@ import qualified Data.Map as M

2828import Control.Applicative

2929import Control.Monad

3030import Control.Monad.Error (ErrorT(..), MonadError)

31−import Control.Monad.Error.Class (MonadError(..))

31+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

3232import Control.Monad.Trans.Class

3333import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

3434import Control.Monad.Trans.State.Strict

@@ -150,7 +150,7 @@ loadAllImportedModules = do

150150 modulesOrFirstError <- psciIO $ loadAllModules files

151151 case modulesOrFirstError of

152152 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 }

154154

155155-- |

156156-- Expands tilde in path.

@@ -314,7 +314,7 @@ completion = completeWordWithPrev Nothing " \t\n\r" findCompletions

314314-- | Compilation options.

315315--

316316options :: 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

318318

319319-- |

320320-- PSCI monad

@@ -322,27 +322,25 @@ options = P.Options False False False Nothing False False P.MakeOptions

322322newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

323323

324324psciIO :: IO a -> PSCI a

325−psciIO io = PSCI (lift (lift io))

325+psciIO io = PSCI . lift $ lift io

326326

327−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)

327+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }

328+ deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))

328329

329330runMake :: Make a -> IO (Either String a)

330−runMake = runErrorT . unMake

331+runMake = runErrorT . flip runReaderT options . unMake

331332

332333makeIO :: 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

334335

335336instance P.MonadMake Make where

336337 getTimestamp path = makeIO $ do

337338 exists <- doesFileExist path

338− if exists

339− then Just <$> getModificationTime path

340− else return Nothing

339+ traverse (const $ getModificationTime path) $ guard exists

341340 readTextFile path = makeIO $ readFile path

342341 writeTextFile path text = makeIO $ do

343342 mkdirp path

344343 writeFile path text

345− liftError = either throwError return

346344 progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s

347345

348346mkdirp :: FilePath -> IO ()

@@ -402,7 +400,7 @@ handleDeclaration :: P.Expr -> PSCI ()

402400handleDeclaration val = do

403401 st <- PSCI $ lift get

404402 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)]) []

406404 case e of

407405 Left err -> PSCI $ outputStrLn err

408406 Right _ -> do

@@ -423,7 +421,7 @@ handleLet ds = do

423421 st <- PSCI $ lift get

424422 let st' = updateLets ds st

425423 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)]) []

427425 case e of

428426 Left err -> PSCI $ outputStrLn err

429427 Right _ -> PSCI $ lift (put st')

@@ -456,7 +454,7 @@ handleImport :: P.ModuleName -> PSCI ()

456454handleImport moduleName = do

457455 st <- updateImports moduleName <$> PSCI (lift get)

458456 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)]) []

460458 case e of

461459 Left err -> PSCI $ outputStrLn err

462460 Right _ -> do

@@ -470,7 +468,7 @@ handleTypeOf :: P.Expr -> PSCI ()

470468handleTypeOf val = do

471469 st <- PSCI $ lift get

472470 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)]) []

474472 case e of

475473 Left err -> PSCI $ outputStrLn err

476474 Right env' ->

@@ -504,7 +502,7 @@ handleBrowse :: P.ModuleName -> PSCI ()

504502handleBrowse moduleName = do

505503 st <- PSCI $ lift get

506504 let loadedModules = psciLoadedModules st

507− env <- psciIO . runMake $ P.make modulesDir options loadedModules []

505+ env <- psciIO . runMake $ P.make modulesDir loadedModules []

508506 case env of

509507 Left err -> PSCI $ outputStrLn err

510508 Right env' ->

@@ -520,7 +518,7 @@ handleKindOf typ = do

520518 st <- PSCI $ lift get

521519 let m = createTemporaryModuleForKind st typ

522520 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)]) []

524522 case e of

525523 Left err -> PSCI $ outputStrLn err

526524 Right env' ->

@@ -571,7 +569,7 @@ handleCommand (LoadFile filePath) = do

571569 PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

572570handleCommand Reset = do

573571 files <- psciImportedFilenames <$> PSCI (lift get)

574− PSCI . lift . modify $ \st -> st

572+ PSCI . lift . modify $ \st -> st

575573 { psciImportedFilenames = files

576574 , psciImportedModuleNames = defaultImports

577575 , psciLetBindings = []

src/Language/PureScript.hs+40−35

@@ -13,7 +13,7 @@

1313--

1414-----------------------------------------------------------------------------

1515

16−{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}

16+{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}

1717

1818module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where

1919

@@ -22,6 +22,7 @@ import Data.Function (on)

2222import Data.List (sortBy, groupBy, intercalate)

2323import Data.Maybe (fromMaybe)

2424import Data.Time.Clock

25+import qualified Data.Traversable as T (traverse)

2526import qualified Data.ByteString.UTF8 as BU

2627import qualified Data.Map as M

2728import qualified Data.Set as S

@@ -29,6 +30,7 @@ import qualified Data.Set as S

2930import Control.Applicative

3031import Control.Arrow ((&&&))

3132import Control.Monad.Error

33+import Control.Monad.Reader

3234

3335import System.FilePath ((</>))

3436

@@ -71,42 +73,47 @@ import qualified Language.PureScript.Constants as C

7173--

7274-- * Pretty-print the generated Javascript

7375--

74−compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

76+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

77+ => [Module] -> [String] -> m (String, String, Environment)

7578compile = compile' initEnvironment

7679

77−compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)

78−compile' env opts ms prefix = do

79− (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms

80+compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

81+ => Environment -> [Module] -> [String] -> m (String, String, Environment)

82+compile' env ms prefix = do

83+ noPrelude <- asks optionsNoPrelude

84+ additional <- asks optionsAdditional

85+ mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

86+ (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

8087 (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

8289 regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

8390 let corefn = map (CoreFn.moduleToCoreFn env') regrouped

84− let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)

91+ let entryPoints = moduleNameFromString `map` entryPointModules additional

8592 let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

8693 let renamed = renameInModules elim

87− let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)

94+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

8895 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)

9097 let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

91− js' <- generateMain env' opts js

98+ js' <- generateMain env' js

9299 let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

93100 return (pjs, exts, env')

94− where

95− mainModuleIdent = moduleNameFromString <$> optionsMain opts

96101

97−generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]

98−generateMain env opts js =

99− case moduleNameFromString <$> optionsMain opts of

102+generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]

103+generateMain env js = do

104+ main <- asks optionsMain

105+ additional <- asks optionsAdditional

106+ case moduleNameFromString <$> main of

100107 Just mmi -> do

101108 when ((mmi, Ident C.main) `M.notMember` names env) $

102− Left $ show mmi ++ "." ++ C.main ++ " is undefined"

103− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]

109+ throwError $ show mmi ++ "." ++ C.main ++ " is undefined"

110+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]

104111 _ -> return js

105112

106113-- |

107114-- A type class which collects the IO actions we need to be able to run in "make" mode

108115--

109−class MonadMake m where

116+class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where

110117 -- |

111118 -- Get a file timestamp

112119 --

@@ -122,11 +129,6 @@ class MonadMake m where

122129 --

123130 writeTextFile :: FilePath -> String -> m ()

124131

125− -- |

126− -- Report an error

127− --

128− liftError :: Either String a -> m a

129−

130132 -- |

131133 -- Respond to a progress update

132134 --

@@ -152,11 +154,13 @@ traverseEither f (Right y) = Right <$> f y

152154-- If timestamps have not changed, the externs file can be used to provide the module's types without

153155-- having to typecheck the module again.

154156--

155−make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

156−make outputDir opts ms prefix = do

157+make :: (Functor m, Applicative m, Monad m, MonadMake m)

158+ => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

159+make outputDir ms prefix = do

160+ noPrelude <- asks optionsNoPrelude

157161 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)

158162

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

160164

161165 toRebuild <- foldM (\s (Module moduleName' _ _) -> do

162166 let filePath = runModuleName moduleName'

@@ -176,15 +180,16 @@ make outputDir opts ms prefix = do

176180

177181 marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

178182

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)

180184

181− evalSupplyT nextVar (go initEnvironment desugared)

185+ evalSupplyT nextVar $ go initEnvironment desugared

182186

183187 where

184− go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment

188+ go :: (Functor m, Applicative m, Monad m, MonadMake m)

189+ => Environment -> [(Bool, Module)] -> SupplyT m Environment

185190 go env [] = return env

186191 go env ((False, m) : ms') = do

187− (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m

192+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

188193

189194 go env' ms'

190195 go env ((True, m@(Module moduleName' _ exps)) : ms') = do

@@ -194,15 +199,15 @@ make outputDir opts ms prefix = do

194199

195200 lift . progress $ "Compiling " ++ runModuleName moduleName'

196201

197− (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m

202+ (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m

198203

199− regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

204+ regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

200205

201206 let mod' = Module moduleName' regrouped exps

202207 let corefn = CoreFn.moduleToCoreFn env' mod'

203208 let [renamed] = renameInModules [corefn]

204209

205− pjs <- prettyPrintJS <$> moduleToJs opts renamed

210+ pjs <- prettyPrintJS <$> moduleToJs renamed

206211 let js = unlines $ map ("// " ++) prefix ++ [pjs]

207212 let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']

208213

@@ -220,10 +225,10 @@ make outputDir opts ms prefix = do

220225 rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do

221226 let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"

222227 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)]

224229 case externsModules of

225230 [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"

227232

228233reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]

229234reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

src/Language/PureScript/CodeGen/JS.hs+49−31

@@ -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 _ 0)) 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

@@ -194,7 +203,8 @@ valueToJs _ (Constructor _ _ (ProperName ctor) arity) =

194203iife :: String -> [JS] -> JS

195204iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

196205

197−literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS

206+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

207+ => ModuleName -> Literal (Expr Ann) -> SupplyT m JS

198208literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

199209literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

200210literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

@@ -241,9 +251,10 @@ qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

241251-- Generate code in the simplified Javascript intermediate representation for pattern match binders

242252-- and guards.

243253--

244−bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS

254+bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

255+ => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS

245256bindersToJs m binders vals = do

246− valNames <- replicateM (length vals) freshName

257+ valNames <- replicateM (length vals) $ freshName

247258 let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

248259 jss <- forM binders $ \(CaseAlternative bs result) -> do

249260 ret <- guardsToJs result

@@ -251,14 +262,16 @@ bindersToJs m binders vals = do

251262 return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

252263 []

253264 where

254− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]

265+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

266+ => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]

255267 go _ done [] = return done

256268 go (v:vs) done' (b:bs) = do

257269 done'' <- go vs done' bs

258270 binderToJs m v done'' b

259271 go _ _ _ = error "Invalid arguments to bindersToJs"

260272

261− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]

273+ guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

274+ => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]

262275 guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

263276 cond' <- valueToJs m cond

264277 done <- valueToJs m val

@@ -269,7 +282,8 @@ bindersToJs m binders vals = do

269282-- Generate code in the simplified Javascript intermediate representation for a pattern match

270283-- binder.

271284--

272−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]

285+binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

286+ => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]

273287binderToJs _ _ done (NullBinder{}) = return done

274288binderToJs m varName done (LiteralBinder _ l) =

275289 literalToBinderJS m varName done l

@@ -286,7 +300,8 @@ binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorT

286300 (JSBlock js)

287301 Nothing]

288302 where

289− go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]

303+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

304+ => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]

290305 go _ done' [] = return done'

291306 go index done' (binder:bs') = do

292307 argVar <- freshName

@@ -316,7 +331,8 @@ binderToJs m varName done (NamedBinder _ ident binder) = do

316331 js <- binderToJs m varName done binder

317332 return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

318333

319−literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]

334+literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

335+ => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]

320336literalToBinderJS _ varName done (NumericLiteral num) =

321337 return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

322338literalToBinderJS _ varName done (StringLiteral str) =

@@ -327,7 +343,8 @@ literalToBinderJS _ varName done (BooleanLiteral False) =

327343 return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

328344literalToBinderJS m varName done (ObjectLiteral bs) = go done bs

329345 where

330− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]

346+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

347+ => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]

331348 go done' [] = return done'

332349 go done' ((prop, binder):bs') = do

333350 propVar <- freshName

@@ -338,7 +355,8 @@ literalToBinderJS m varName done (ArrayLiteral bs) = do

338355 js <- go done 0 bs

339356 return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

340357 where

341− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]

358+ go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)

359+ => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]

342360 go done' _ [] = return done'

343361 go done' index (binder:bs') = do

344362 elVar <- freshName

src/Language/PureScript/CodeGen/JS/Optimizer.hs+29−20

@@ -31,10 +31,14 @@

3131--

3232-----------------------------------------------------------------------------

3333

34+{-# LANGUAGE FlexibleContexts #-}

35+

3436module Language.PureScript.CodeGen.JS.Optimizer (

3537 optimize

3638) where

3739

40+import Control.Monad.Reader (MonadReader, ask, asks)

41+

3842import Language.PureScript.CodeGen.JS.AST

3943import Language.PureScript.Options

4044import qualified Language.PureScript.Constants as C

@@ -49,29 +53,34 @@ import Language.PureScript.CodeGen.JS.Optimizer.Blocks

4953-- |

5054-- Apply a series of optimizer passes to simplified Javascript code

5155--

52−optimize :: Options mode -> JS -> JS

53−optimize opts | optionsNoOptimizations opts = id

54− | otherwise = untilFixedPoint (applyAll

55− [ collapseNestedBlocks

56− , collapseNestedIfs

57− , tco opts

58− , magicDo opts

59− , removeCodeAfterReturnStatements

60− , removeUnusedArg

61− , removeUndefinedApp

62− , unThunk

63− , etaConvert

64− , evaluateIifes

65− , inlineVariables

66− , inlineValues

67− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

68− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

69− , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer

70− , inlineCommonOperators ])

56+optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS

57+optimize js = do

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

64+ return $ untilFixedPoint (applyAll

65+ [ collapseNestedBlocks

66+ , collapseNestedIfs

67+ , tco opts

68+ , magicDo opts

69+ , removeCodeAfterReturnStatements

70+ , removeUnusedArg

71+ , removeUndefinedApp

72+ , unThunk

73+ , etaConvert

74+ , evaluateIifes

75+ , inlineVariables

76+ , inlineValues

77+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]

78+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]

79+ , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer

80+ , inlineCommonOperators ]) js

7181

7282untilFixedPoint :: (Eq a) => (a -> a) -> a -> a

7383untilFixedPoint f = go

7484 where

7585 go a = let a' = f a in

7686 if a' == a then a' else go a'

77−

src/Language/PureScript/CoreFn/Binders.hs+2−1

@@ -13,6 +13,7 @@

1313-----------------------------------------------------------------------------

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

1617

1718module Language.PureScript.CoreFn.Binders where

1819

@@ -44,4 +45,4 @@ data Binder a

4445 -- |

4546 -- A binder which binds its input to an identifier

4647 --

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 @@

1313-----------------------------------------------------------------------------

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

1617

1718module Language.PureScript.CoreFn.Expr where

1819

20+import Control.Arrow ((***))

21+

1922import qualified Data.Data as D

2023

2124import Language.PureScript.CoreFn.Binders

@@ -62,7 +65,7 @@ data Expr a

6265 -- |

6366 -- A let binding

6467 --

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)

6669

6770-- |

6871-- A let or module binding.

@@ -75,7 +78,7 @@ data Bind a

7578 -- |

7679 -- Mutually recursive binding group for several values

7780 --

78− | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)

81+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)

7982

8083-- |

8184-- A guard is just a boolean-valued expression that appears alongside a set of binders

@@ -96,6 +99,12 @@ data CaseAlternative a = CaseAlternative

9699 , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

97100 } deriving (Show, D.Data, D.Typeable)

98101

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+

99108-- |

100109-- Extract the annotation from a term

101110--

@@ -110,6 +119,7 @@ extractAnn (Var a _) = a

110119extractAnn (Case a _ _) = a

111120extractAnn (Let a _ _) = a

112121

122+

113123-- |

114124-- Modify the annotation on a term

115125--

src/Language/PureScript/CoreFn/Literals.hs+2−1

@@ -13,6 +13,7 @@

1313-----------------------------------------------------------------------------

1414

1515{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

1617

1718module Language.PureScript.CoreFn.Literals where

1819

@@ -42,4 +43,4 @@ data Literal a

4243 -- |

4344 -- An object literal

4445 --

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) =

9595prettyPrintErrorStack printFullStack (MultipleErrors es) =

9696 unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es

9797

98−stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a

99−stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right

98+stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a

99+stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return

100100

101101isErrorNonEmpty :: CompileError -> Bool

102102isErrorNonEmpty = not . null . compileErrorMessage

src/Language/PureScript/ModuleDependencies.hs+7−3

@@ -12,11 +12,15 @@

1212--

1313-----------------------------------------------------------------------------

1414

15+{-# LANGUAGE FlexibleContexts #-}

16+

1517module Language.PureScript.ModuleDependencies (

1618 sortModules,

1719 ModuleGraph

1820) where

1921

22+import Control.Monad.Error.Class

23+

2024import Data.Graph

2125import Data.List (nub)

2226import Data.Maybe (mapMaybe)

@@ -35,7 +39,7 @@ type ModuleGraph = [(ModuleName, [ModuleName])]

3539--

3640-- Reports an error if the module graph contains a cycle.

3741--

38−sortModules :: [Module] -> Either String ([Module], ModuleGraph)

42+sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)

3943sortModules ms = do

4044 let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

4145 ms' <- mapM toModule $ stronglyConnComp verts

@@ -66,7 +70,7 @@ usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (

6670-- |

6771-- Convert a strongly connected component of the module graph to a module

6872--

69−toModule :: SCC Module -> Either String Module

73+toModule :: (MonadError String m) => SCC Module -> m Module

7074toModule (AcyclicSCC m) = return m

7175toModule (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 {

6969 -- Verbose error message

7070 --

7171 , optionsVerboseErrors :: Bool

72+ -- |

73+ -- Remove the comments from the generated js

74+ , optionsNoComments :: Bool

7275 -- |

7376 -- Specify the namespace that PureScript modules will be exported to when running in the

7477 -- browser.

@@ -80,10 +83,10 @@ data Options mode = Options {

8083-- Default compiler options

8184--

8285defaultCompileOptions :: 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" [] [])

8487

8588-- |

8689-- Default make options

8790--

8891defaultMakeOptions :: 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

2323

2424import Control.Applicative

2525import Control.Monad.Error

26+import Control.Monad.Reader.Class

2627import Control.Monad.State

2728import Control.Monad.Unify

2829

@@ -194,14 +195,16 @@ modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })

194195-- |

195196-- Run a computation in the Check monad, starting with an empty @Environment@

196197--

197−runCheck :: Options mode -> Check a -> Either String (a, Environment)

198−runCheck opts = runCheck' opts initEnvironment

198+runCheck :: (MonadReader (Options mode) m, MonadError String m) => Check a -> m (a, Environment)

199+runCheck = runCheck' initEnvironment

199200

200201-- |

201202-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.

202203--

203−runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)

204−runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do

204+runCheck' :: (MonadReader (Options mode) m, MonadError String m) => Environment -> Check a -> m (a, Environment)

205+runCheck' env c = do

206+ verbose <- asks optionsVerboseErrors

207+ stringifyErrorStack verbose $ do

205208 (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c

206209 return (a, checkEnv s)

207210

tests/Main.hs+3−2

@@ -22,6 +22,7 @@ import Data.List (isSuffixOf)

2222import Data.Traversable (traverse)

2323import Control.Monad

2424import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

25+import Control.Monad.Reader (runReaderT)

2526import Control.Applicative

2627import System.Exit

2728import System.Process

@@ -38,7 +39,7 @@ loadPrelude :: Either String (String, String, P.Environment)

3839loadPrelude =

3940 case P.parseModulesFromFiles id [("", P.prelude)] of

4041 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" [] [] }

4243

4344compile :: P.Options P.Compile -> [FilePath] -> IO (Either String (String, String, P.Environment))

4445compile opts inputFiles = do

@@ -46,7 +47,7 @@ compile opts inputFiles = do

4647 case modules of

4748 Left parseError ->

4849 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

5051

5152assert :: FilePath -> P.Options P.Compile -> FilePath -> (Either String (String, String, P.Environment) -> IO (Maybe String)) -> IO ()

5253assert preludeExterns opts inputFile f = do