git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Merge branch 'commonjs1'
commit81bb633fdf028bc0210e5901496ac3632dcbbbc9 authorPhil Freeman <paf31@cantab.net> dateSat 12 Apr 2014, 14:42 (13 years ago) parent807426a3248a2b
12 files changed+217−180
compare with golang
unifiedsplit
prelude/prelude.purs+1−1 psc-make/Main.hs+10−9 psc/Main.hs+2−1 psci/Main.hs+101−47 src/Language/PureScript.hs+35−33 src/Language/PureScript/CodeGen/JS.hs+43−39 src/Language/PureScript/Constants.hs−3 src/Language/PureScript/Names.hs+4 src/Language/PureScript/Optimizer/Inliner.hs+7−20 src/Language/PureScript/Optimizer/MagicDo.hs+7−21 src/Language/PureScript/Options.hs+2−2 tests/Main.hs+5−4
prelude/prelude.purs+1−1
@@ -271,7 +271,7 @@ module Prelude where
271271 foreign import numCompare
272272 "function numCompare(n1) {\
273273 \ return function(n2) {\
274− \ return n1 < n2 ? module.LT : n1 > n2 ? module.GT : module.EQ;\
274+ \ return n1 < n2 ? LT : n1 > n2 ? GT : EQ;\
275275 \ };\
276276 \}" :: Number -> Number -> Ordering
277277
psc-make/Main.hs+10−9
@@ -67,16 +67,17 @@ instance P.MonadMake Make where
6767 U.putStrLn $ "Writing " ++ path
6868 U.writeFile path text
6969 liftError = either throwError return
70+ progress = makeIO . U.putStrLn
7071
71−compile :: P.Options -> [FilePath] -> IO ()
72−compile opts input = do
72+compile :: FilePath -> P.Options -> [FilePath] -> IO ()
73+compile outputDir opts input = do
7374 modules <- readInput input
7475 case modules of
7576 Left err -> do
7677 U.print err
7778 exitFailure
7879 Right ms -> do
79− e <- runMake $ P.make opts ms
80+ e <- runMake $ P.make outputDir opts ms
8081 case e of
8182 Left err -> do
8283 U.putStrLn err
@@ -91,6 +92,10 @@ inputFiles :: Term [FilePath]
9192inputFiles = value $ posAny [] $ posInfo
9293 { posDoc = "The input .ps files" }
9394
95+outputDirectory :: Term FilePath
96+outputDirectory = value $ opt "output" $ (optInfo [ "o", "output" ])
97+ { optDoc = "The output directory" }
98+
9499noTco :: Term Bool
95100noTco = value $ flag $ (optInfo [ "no-tco" ])
96101 { optDoc = "Disable tail call optimizations" }
@@ -111,16 +116,12 @@ noOpts :: Term Bool
111116noOpts = value $ flag $ (optInfo [ "no-opts" ])
112117 { optDoc = "Skip the optimization phase." }
113118
114−browserNamespace :: Term String
115−browserNamespace = value $ opt "PS" $ (optInfo [ "browser-namespace" ])
116− { optDoc = "Specify the namespace that PureScript modules will be exported to when running in the browser." }
117−
118119verboseErrors :: Term Bool
119120verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
120121 { optDoc = "Display verbose error messages" }
121122
122123options :: Term P.Options
123−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> browserNamespace <*> pure [] <*> pure [] <*> verboseErrors
124+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> pure Nothing <*> noOpts <*> pure Nothing <*> pure [] <*> pure [] <*> verboseErrors
124125
125126inputFilesAndPrelude :: FilePath -> Term [FilePath]
126127inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
@@ -129,7 +130,7 @@ inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
129130 combine False input = input
130131
131132term :: FilePath -> Term (IO ())
132−term prelude = compile <$> options <*> inputFilesAndPrelude prelude
133+term prelude = compile <$> outputDirectory <*> options <*> inputFilesAndPrelude prelude
133134
134135termInfo :: TermInfo
135136termInfo = defTI
psc/Main.hs+2−1
@@ -127,7 +127,7 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
127127 { optDoc = "Display verbose error messages" }
128128
129129options :: Term P.Options
130−options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> browserNamespace <*> dceModules <*> codeGenModules <*> verboseErrors
130+options = P.Options <$> noPrelude <*> noTco <*> performRuntimeTypeChecks <*> noMagicDo <*> runMain <*> noOpts <*> (Just <$> browserNamespace) <*> dceModules <*> codeGenModules <*> verboseErrors
131131
132132stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
133133stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
@@ -150,3 +150,4 @@ main :: IO ()
150150main = do
151151 prelude <- preludeFilename
152152 run (term prelude, termInfo)
153+
psci/Main.hs+101−47
@@ -13,7 +13,7 @@
1313--
1414-----------------------------------------------------------------------------
1515
16−{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}
16+{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
1717
1818module Main where
1919
@@ -24,29 +24,36 @@ import Control.Monad
2424import Control.Monad.Trans.Class
2525import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
2626import Control.Monad.Trans.State.Strict
27+import Control.Monad.Error (ErrorT(..), MonadError)
28+import Control.Monad.Error.Class (MonadError(..))
2729
2830import Data.List (intercalate, isPrefixOf, nub, sortBy)
2931import Data.Maybe (mapMaybe)
3032import Data.Foldable (traverse_)
31−import Data.Traversable (traverse)
3233import Data.Version (showVersion)
34+import Data.Traversable (traverse)
3335
3436import Parser
3537
38+import System.IO.Error (tryIOError)
3639import System.Console.Haskeline
37−import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
40+import System.Directory
41+ (createDirectoryIfMissing, getModificationTime, doesFileExist,
42+ findExecutable, getHomeDirectory, getCurrentDirectory)
43+import System.Process (readProcessWithExitCode)
3844import System.Exit
3945import System.Environment.XDG.BaseDir
40−import System.FilePath ((</>), isPathSeparator)
46+import System.FilePath
47+ (pathSeparator, takeDirectory, (</>), isPathSeparator)
4148import qualified System.Console.CmdTheLine as Cmd
42−import System.Process
4349
4450import Text.Parsec (ParseError)
4551
4652import qualified Data.Map as M
4753import qualified Language.PureScript as P
4854import qualified Paths_purescript as Paths
49−import qualified System.IO.UTF8 as U (print, readFile)
55+import qualified System.IO.UTF8 as U
56+ (writeFile, putStrLn, print, readFile)
5057
5158-- |
5259-- The PSCI state.
@@ -57,7 +64,7 @@ import qualified System.IO.UTF8 as U (print, readFile)
5764data PSCiState = PSCiState
5865 { psciImportedFilenames :: [FilePath]
5966 , psciImportedModuleNames :: [P.ModuleName]
60− , psciLoadedModules :: [P.Module]
67+ , psciLoadedModules :: [(FilePath, P.Module)]
6168 , psciLetBindings :: [P.Value -> P.Value]
6269 }
6370
@@ -78,7 +85,7 @@ updateImports name st = st { psciImportedModuleNames = name : psciImportedModule
7885-- |
7986-- Updates the state to have more loaded files.
8087--
81−updateModules :: [P.Module] -> PSCiState -> PSCiState
88+updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState
8289updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
8390
8491-- |
@@ -168,7 +175,7 @@ completion = completeWord Nothing " \t\n\r" findCompletions
168175 where
169176 findCompletions :: String -> StateT PSCiState IO [Completion]
170177 findCompletions str = do
171− ms <- psciLoadedModules <$> get
178+ ms <- map snd . psciLoadedModules <$> get
172179 files <- listFiles str
173180 let matches = filter (isPrefixOf str) (names ms)
174181 return $ sortBy sorter $ map simpleCompletion matches ++ files
@@ -197,7 +204,39 @@ completion = completeWord Nothing " \t\n\r" findCompletions
197204-- | Compilation options.
198205--
199206options :: P.Options
200−options = P.Options False True False True (Just "Main") True "PS" [] [] False
207+options = P.Options False True False True Nothing True Nothing [] [] False
208+
209+-- |
210+-- PSCI monad
211+--
212+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
213+
214+psciIO :: IO a -> PSCI a
215+psciIO io = PSCI (lift (lift io))
216+
217+newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)
218+
219+runMake :: Make a -> IO (Either String a)
220+runMake = runErrorT . unMake
221+
222+makeIO :: IO a -> Make a
223+makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
224+
225+instance P.MonadMake Make where
226+ getTimestamp path = makeIO $ do
227+ exists <- doesFileExist path
228+ case exists of
229+ True -> Just <$> getModificationTime path
230+ False -> return Nothing
231+ readTextFile path = makeIO $ U.readFile path
232+ writeTextFile path text = makeIO $ do
233+ mkdirp path
234+ U.writeFile path text
235+ liftError = either throwError return
236+ progress s = unless (s == "Compiling Main") $ makeIO . U.putStrLn $ s
237+
238+mkdirp :: FilePath -> IO ()
239+mkdirp = createDirectoryIfMissing True . takeDirectory
201240
202241-- |
203242-- Makes a volatile module to execute the current expression.
@@ -217,34 +256,45 @@ createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetB
217256 in
218257 P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
219258
259+modulesDir :: FilePath
260+modulesDir = "psci_modules" ++ pathSeparator : "node_modules"
261+
262+indexFile :: FilePath
263+indexFile = "psci_modules" ++ pathSeparator : "index.js"
264+
220265-- |
221266-- Takes a value declaration and evaluates it with the current state.
222267--
223−handleDeclaration :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
224−handleDeclaration value st = do
268+handleDeclaration :: P.Value -> PSCI ()
269+handleDeclaration value = do
270+ st <- PSCI $ lift get
225271 let m = createTemporaryModule True st value
226− case P.compile options (psciLoadedModules st ++ [m]) of
227− Left err -> outputStrLn err
228− Right (js, _, _) -> do
229− process <- lift . lift $ findNodeProcess
230− result <- lift . lift $ traverse (\node -> readProcessWithExitCode node [] js) process
272+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
273+ case e of
274+ Left err -> PSCI $ outputStrLn err
275+ Right _ -> do
276+ psciIO $ writeFile indexFile $ "require('Main').main();"
277+ process <- psciIO findNodeProcess
278+ result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
231279 case result of
232− Just (ExitSuccess, out, _) -> outputStrLn out
233− Just (ExitFailure _, _, err) -> outputStrLn err
234− Nothing -> outputStrLn "Couldn't find node.js"
280+ Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
281+ Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
282+ Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
235283
236284-- |
237285-- Takes a value and prints its type
238286--
239−handleTypeOf :: P.Value -> PSCiState -> InputT (StateT PSCiState IO) ()
240−handleTypeOf value st = do
287+handleTypeOf :: P.Value -> PSCI ()
288+handleTypeOf value = do
289+ st <- PSCI $ lift get
241290 let m = createTemporaryModule False st value
242− case P.compile options { P.optionsMain = Nothing } (psciLoadedModules st ++ [m]) of
243− Left err -> outputStrLn err
244− Right (_, _, env') ->
291+ e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [("Main.purs", m)])
292+ case e of
293+ Left err -> PSCI $ outputStrLn err
294+ Right env' ->
245295 case M.lookup (P.ModuleName [P.ProperName "Main"], P.Ident "it") (P.names env') of
246− Just (ty, _) -> outputStrLn . P.prettyPrintType $ ty
247− Nothing -> outputStrLn "Could not find type"
296+ Just (ty, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
297+ Nothing -> PSCI $ outputStrLn "Could not find type"
248298
249299-- Commands
250300
@@ -265,27 +315,31 @@ getCommand = do
265315-- |
266316-- Performs an action for each meta-command given, and also for expressions..
267317--
268−handleCommand :: Command -> InputT (StateT PSCiState IO) ()
269−handleCommand (Expression val) = lift get >>= handleDeclaration val
270−handleCommand Help = outputStrLn helpMessage
271−handleCommand (Import moduleName) = lift $ modify (updateImports moduleName)
272−handleCommand (Let l) = lift $ modify (updateLets l)
318+handleCommand :: Command -> PSCI ()
319+handleCommand (Expression val) = handleDeclaration val
320+handleCommand Help = PSCI $ outputStrLn helpMessage
321+handleCommand (Import moduleName) = PSCI $ lift $ modify (updateImports moduleName)
322+handleCommand (Let l) = PSCI $ lift $ modify (updateLets l)
273323handleCommand (LoadFile filePath) = do
274− absPath <- lift . lift $ expandTilde filePath
275− exists <- lift . lift $ doesFileExist absPath
324+ absPath <- psciIO $ expandTilde filePath
325+ exists <- psciIO $ doesFileExist absPath
276326 if exists then do
277− lift $ modify (updateImportedFiles absPath)
278− either outputStrLn (lift . modify . updateModules) =<< (lift . lift $ loadModule absPath)
327+ PSCI . lift $ modify (updateImportedFiles absPath)
328+ m <- psciIO $ loadModule absPath
329+ case m of
330+ Left err -> PSCI $ outputStrLn err
331+ Right mods -> PSCI . lift $ modify (updateModules (map ((,) absPath) mods))
279332 else
280− outputStrLn $ "Couldn't locate: " ++ filePath
333+ PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
281334handleCommand Reset = do
282− files <- psciImportedFilenames <$> lift get
283− modulesOrFirstError <- fmap concat . sequence <$> mapM (lift . lift . loadModule) files
335+ files <- psciImportedFilenames <$> PSCI (lift get)
336+ filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . psciIO . loadModule $ file) files
337+ let modulesOrFirstError = fmap concat $ sequence filesAndModules
284338 case modulesOrFirstError of
285− Left err -> lift . lift $ putStrLn err >> exitFailure
286− Right modules -> lift $ put (PSCiState files defaultImports modules [])
287−handleCommand (TypeOf val) = lift get >>= handleTypeOf val
288−handleCommand _ = outputStrLn "Unknown command"
339+ Left err -> psciIO $ putStrLn err >> exitFailure
340+ Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])
341+handleCommand (TypeOf val) = handleTypeOf val
342+handleCommand _ = PSCI $ outputStrLn "Unknown command"
289343
290344inputFiles :: Cmd.Term [FilePath]
291345inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
@@ -311,7 +365,8 @@ loop :: [FilePath] -> IO ()
311365loop files = do
312366 config <- loadUserConfig
313367 preludeFilename <- getPreludeFilename
314− modulesOrFirstError <- fmap concat . sequence <$> mapM loadModule (preludeFilename : files)
368+ filesAndModules <- mapM (\file -> fmap (fmap (map ((,) file))) . loadModule $ file) (preludeFilename : files)
369+ let modulesOrFirstError = fmap concat $ sequence filesAndModules
315370 case modulesOrFirstError of
316371 Left err -> putStrLn err >> exitFailure
317372 Right modules -> do
@@ -319,7 +374,7 @@ loop files = do
319374 let settings = defaultSettings {historyFile = Just historyFilename}
320375 flip evalStateT (PSCiState (preludeFilename : files) defaultImports modules []) . runInputT (setComplete completion settings) $ do
321376 outputStrLn prologueMessage
322− traverse_ (mapM_ handleCommand) config
377+ traverse_ (mapM_ (runPSCI . handleCommand)) config
323378 go
324379 where
325380 go :: InputT (StateT PSCiState IO) ()
@@ -329,7 +384,7 @@ loop files = do
329384 Left err -> outputStrLn (show err) >> go
330385 Right Nothing -> go
331386 Right (Just Quit) -> outputStrLn quitMessage
332− Right (Just c') -> handleCommand c' >> go
387+ Right (Just c') -> runPSCI (handleCommand c') >> go
333388
334389term :: Cmd.Term (IO ())
335390term = loop <$> inputFiles
@@ -343,4 +398,3 @@ termInfo = Cmd.defTI
343398
344399main :: IO ()
345400main = Cmd.run (term, termInfo)
346−
src/Language/PureScript.hs+35−33
@@ -37,7 +37,7 @@ import Data.List (find, sortBy, groupBy, intercalate)
3737import Data.Time.Clock
3838import Data.Function (on)
3939import Data.Generics (mkQ, everything)
40−import Data.Maybe (fromMaybe, mapMaybe)
40+import Data.Maybe (fromJust, fromMaybe)
4141import Control.Monad.Error
4242import Control.Monad.State.Lazy
4343import Control.Arrow ((&&&))
@@ -78,10 +78,10 @@ compile' env opts ms = do
7878 let elim = if null entryPoints then regrouped else eliminateDeadCode entryPoints regrouped
7979 let codeGenModules = moduleNameFromString `map` optionsCodeGenModules opts
8080 let modulesToCodeGen = if null codeGenModules then elim else filter (\(Module mn _ _) -> mn `elem` codeGenModules) elim
81− let js = mapMaybe (flip (moduleToJs opts) env') modulesToCodeGen
81+ let js = concatMap (\m -> moduleToJs Globals opts m env') modulesToCodeGen
8282 let exts = intercalate "\n" . map (`moduleToPs` env') $ modulesToCodeGen
8383 js' <- generateMain env' opts js
84− return (prettyPrintJS [wrapExportsContainer opts js'], exts, env')
84+ return (prettyPrintJS js', exts, env')
8585 where
8686 mainModuleIdent = moduleNameFromString <$> optionsMain opts
8787
@@ -128,7 +128,7 @@ generateMain env opts js =
128128 Just mmi -> do
129129 when ((mmi, Ident C.main) `M.notMember` names env) $
130130 Left $ show mmi ++ "." ++ C.main ++ " is undefined"
131− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar C._ps))) []]
131+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (fromJust (optionsBrowserNamespace opts))))) []]
132132 _ -> return js
133133
134134-- |
@@ -155,6 +155,10 @@ class MonadMake m where
155155 --
156156 liftError :: Either String a -> m a
157157
158+ -- |
159+ -- Respond to a progress update
160+ --
161+ progress :: String -> m ()
158162
159163-- |
160164-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
@@ -162,17 +166,17 @@ class MonadMake m where
162166-- If timestamps have not changed, the externs file can be used to provide the module's types without
163167-- having to typecheck the module again.
164168--
165−make :: (Functor m, Monad m, MonadMake m) => Options -> [(FilePath, Module)] -> m ()
166−make opts ms = do
169+make :: (Functor m, Monad m, MonadMake m) => FilePath -> Options -> [(FilePath, Module)] -> m Environment
170+make outputDir opts ms = do
167171 let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
168172
169173 (sorted, graph) <- liftError $ sortModules $ if optionsNoPrelude opts then map snd ms else (map (importPrelude . snd) ms)
170174
171175 toRebuild <- foldM (\s (Module moduleName' _ _) -> do
172− let filePath = toFileName moduleName'
176+ let filePath = runModuleName moduleName'
173177
174− jsFile = "js" ++ pathSeparator : filePath ++ ".js"
175− externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
178+ jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
179+ externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
176180 inputFile = fromMaybe (error "Input file is undefined in make") $ M.lookup moduleName' filePathMap
177181
178182 jsTimestamp <- getTimestamp jsFile
@@ -190,47 +194,45 @@ make opts ms = do
190194 go initEnvironment desugared
191195
192196 where
193− go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m ()
194− go _ [] = return ()
197+ go :: (Functor m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> m Environment
198+ go env [] = return env
195199 go env ((False, m) : ms') = do
196200 (_, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
197201
198202 go env' ms'
199203 go env ((True, m@(Module moduleName' _ exps)) : ms') = do
200− let filePath = toFileName moduleName'
201− jsFile = "js" ++ pathSeparator : filePath ++ ".js"
202− externsFile = "externs" ++ pathSeparator : filePath ++ ".externs"
204+ let filePath = runModuleName moduleName'
205+ jsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "index.js"
206+ externsFile = outputDir ++ pathSeparator : filePath ++ pathSeparator : "externs.purs"
207+
208+ progress $ "Compiling " ++ runModuleName moduleName'
203209
204210 (Module _ elaborated _, env') <- liftError . runCheck' opts env $ typeCheckModule Nothing m
205211
206212 regrouped <- liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
207213
208214 let mod' = Module moduleName' regrouped exps
209− js = moduleToJs opts mod' env'
215+ js = prettyPrintJS $ moduleToJs CommonJS opts mod' env'
210216 exts = moduleToPs mod' env'
211− js' = maybe "" (prettyPrintJS . return . wrapExportsContainer opts . return) js
212217
213− writeTextFile jsFile js'
218+ writeTextFile jsFile js
214219 writeTextFile externsFile exts
215220
216221 go env' ms'
217222
218−toFileName :: ModuleName -> FilePath
219−toFileName (ModuleName ps) = intercalate [pathSeparator] . map runProperName $ ps
220−
221−rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
222−rebuildIfNecessary _ _ [] = return []
223−rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms) | moduleName' `S.member` toRebuild = do
224− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
225− toRebuild' = toRebuild `S.union` S.fromList deps
226− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms
227−rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms) = do
228− let externsFile = "externs" ++ pathSeparator : toFileName moduleName' ++ ".externs"
229− externs <- readTextFile externsFile
230− externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
231− case externsModules of
232− [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms
233− _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
223+ rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
224+ rebuildIfNecessary _ _ [] = return []
225+ rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
226+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
227+ toRebuild' = toRebuild `S.union` S.fromList deps
228+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
229+ rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
230+ let externsFile = outputDir ++ pathSeparator : runModuleName moduleName' ++ pathSeparator : "externs.purs"
231+ externs <- readTextFile externsFile
232+ externsModules <- liftError . either (Left . show) Right $ P.runIndentParser externsFile P.parseModules externs
233+ case externsModules of
234+ [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
235+ _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
234236
235237reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
236238reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
src/Language/PureScript/CodeGen/JS.hs+43−39
@@ -17,14 +17,16 @@
1717
1818module Language.PureScript.CodeGen.JS (
1919 module AST,
20+ ModuleType(..),
2021 declToJs,
2122 moduleToJs,
22− wrapExportsContainer,
2323 isIdent
2424) where
2525
26−import Data.Maybe (fromMaybe, mapMaybe)
26+import Data.Maybe (fromJust, fromMaybe, mapMaybe)
2727import Data.Function (on)
28+import Data.List (nub, (\\))
29+import Data.Generics (mkQ, everything)
2830
2931import Control.Arrow (second)
3032import Control.Monad (replicateM, forM)
@@ -41,26 +43,46 @@ import Language.PureScript.Types
4143import Language.PureScript.Optimizer
4244import Language.PureScript.CodeGen.Common
4345import Language.PureScript.Environment
44−import qualified Language.PureScript.Constants as C
46+
47+-- |
48+-- Different types of modules which are supported
49+--
50+data ModuleType = CommonJS | Globals
4551
4652-- |
4753-- Generate code in the simplified Javascript intermediate representation for all declarations in a
4854-- module.
4955--
50−moduleToJs :: Options -> Module -> Environment -> Maybe JS
51−moduleToJs opts (Module name decls (Just exps)) env =
52− case jsDecls of
53− [] -> Nothing
54− _ -> Just $ JSAssignment (JSAccessor (moduleNameToJs name) (JSVar C._ps)) $
55− JSApp (JSFunction Nothing [] (JSBlock $
56− JSVariableIntroduction "module" (Just $ JSObjectLiteral []) :
57− jsDecls ++
58− jsExports ++
59− [JSReturn $ JSVar "module"])) []
56+moduleToJs :: ModuleType -> Options -> Module -> Environment -> [JS]
57+moduleToJs mt opts (Module name decls (Just exps)) env = case mt of
58+ CommonJS -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) moduleExports]
59+ Globals ->
60+ [ JSVariableIntroduction (fromJust (optionsBrowserNamespace opts))
61+ (Just (JSBinary Or (JSVar (fromJust (optionsBrowserNamespace opts))) (JSObjectLiteral [])) )
62+ , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar (fromJust (optionsBrowserNamespace opts))))
63+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn moduleExports]))) [])
64+ ]
6065 where
66+ moduleBody = JSStringLiteral "use strict" : jsImports ++ jsDecls
67+ moduleExports = JSObjectLiteral $ concatMap exportToJs exps
6168 jsDecls = (concat $ mapMaybe (\decl -> fmap (map $ optimize opts) $ declToJs opts name decl env) decls)
62− jsExports = concatMap exportToJs exps
63−moduleToJs _ _ _ = error "Exports should have been elaborated in name desugaring"
69+ jsImports = map (importToJs mt opts) . (\\ [name]) . nub $ concatMap imports decls
70+moduleToJs _ _ _ _ = error "Exports should have been elaborated in name desugaring"
71+
72+importToJs :: ModuleType -> Options -> ModuleName -> JS
73+importToJs mt opts mn = JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
74+ where
75+ moduleBody = case mt of
76+ CommonJS -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
77+ Globals -> JSAccessor (moduleNameToJs mn) (JSVar (fromJust (optionsBrowserNamespace opts)))
78+
79+imports :: Declaration -> [ModuleName]
80+imports = everything (++) (mkQ [] collect)
81+ where
82+ collect :: Value -> [ModuleName]
83+ collect (Var (Qualified (Just mn) _)) = [mn]
84+ collect (Constructor (Qualified (Just mn) _)) = [mn]
85+ collect _ = []
6486
6587-- |
6688-- Generate code in the simplified Javascript intermediate representation for a declaration
@@ -87,22 +109,14 @@ declToJs opts mp (PositionedDeclaration _ d) e = declToJs opts mp d e
87109declToJs _ _ _ _ = Nothing
88110
89111-- |
90−-- Generate code in the simplified Javascript intermediate representation for an export from a
91−-- module.
112+-- Generate key//value pairs for an object literal exporting values from a module.
92113--
93−exportToJs :: DeclarationRef -> [JS]
94−exportToJs (TypeRef _ (Just dctors)) = flip map dctors (export . Ident . runProperName)
95−exportToJs (ValueRef name) = [export name]
96−exportToJs (TypeInstanceRef name) = [export name]
114+exportToJs :: DeclarationRef -> [(String, JS)]
115+exportToJs (TypeRef _ (Just dctors)) = map ((\n -> (n, var (Ident n))) . runProperName) dctors
116+exportToJs (ValueRef name) = [(runIdent name, var name)]
117+exportToJs (TypeInstanceRef name) = [(runIdent name, var name)]
97118exportToJs _ = []
98119
99−-- |
100−-- Generate code in the simplified Javascript intermediate representation for assigning an exported
101−-- value to the current module object.
102−--
103−export :: Ident -> JS
104−export ident = JSAssignment (accessor ident (JSVar "module")) (var ident)
105−
106120-- |
107121-- Generate code in the simplified Javascript intermediate representation for a variable based on a
108122-- PureScript identifier.
@@ -225,7 +239,7 @@ varToJs m qual = qualifiedToJS m id qual
225239-- variable that may have a qualified name.
226240--
227241qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
228−qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSAccessor (moduleNameToJs m') $ JSVar C._ps)
242+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
229243qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
230244
231245-- |
@@ -328,13 +342,3 @@ isOnlyConstructor e ctor =
328342 numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors e
329343 typeConstructor (Qualified (Just moduleName) _, (tyCtor, _)) = (moduleName, tyCtor)
330344 typeConstructor _ = error "Invalid argument to isOnlyConstructor"
331−
332−wrapExportsContainer :: Options -> [JS] -> JS
333−wrapExportsContainer opts modules = JSApp (JSFunction Nothing [C._ps] $ JSBlock $ JSStringLiteral "use strict" : modules) [exportSelector]
334− where
335− exportSelector = JSConditional (JSBinary And (JSBinary NotEqualTo (JSTypeOf $ JSVar "module") (JSStringLiteral "undefined")) (JSAccessor "exports" (JSVar "module")))
336− (JSAccessor "exports" (JSVar "module"))
337− (JSConditional (JSBinary NotEqualTo (JSTypeOf $ JSVar "window") (JSStringLiteral "undefined"))
338− (JSAssignment (JSAccessor browserNamespace (JSVar "window")) (JSBinary Or (JSAccessor browserNamespace (JSVar "window")) (JSObjectLiteral [])))
339− (JSApp (JSFunction Nothing [] $ JSBlock [JSThrow $ JSStringLiteral "PureScript doesn't know how to export modules in the current environment"]) []))
340− browserNamespace = optionsBrowserNamespace opts
src/Language/PureScript/Constants.hs−3
@@ -180,9 +180,6 @@ main = "main"
180180
181181-- Code Generation
182182
183−_ps :: String
184−_ps = "_ps"
185−
186183__superclasses :: String
187184__superclasses = "__superclasses"
188185
src/Language/PureScript/Names.hs+4
@@ -33,6 +33,10 @@ data Ident
3333 --
3434 | Op String deriving (Eq, Ord, Data, Typeable)
3535
36+runIdent :: Ident -> String
37+runIdent (Ident i) = i
38+runIdent (Op op) = op
39+
3640instance Show Ident where
3741 show (Ident s) = s
3842 show (Op op) = '(':op ++ ")"
src/Language/PureScript/Optimizer/Inliner.hs+7−20
@@ -81,12 +81,8 @@ inlineOperator (m, op) f = everywhere (mkT convert)
8181 convert :: JS -> JS
8282 convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
8383 convert other = other
84− isOp (JSAccessor longForm (JSAccessor m' (JSVar _ps))) | m == m' &&
85− _ps == C._ps &&
86− longForm == identToJs (Op op) = True
87− isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
88− _ps == C._ps &&
89− op == op' = True
84+ isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
85+ isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
9086 isOp _ = False
9187
9288inlineCommonOperators :: JS -> JS
@@ -131,11 +127,8 @@ inlineCommonOperators = applyAll
131127 convert :: JS -> JS
132128 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
133129 convert other = other
134− isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) | prelude == C.prelude &&
135− longForm == identToJs (Op opString) = True
136− isOp (JSIndexer (JSStringLiteral op') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
137− _ps == C._ps &&
138− opString == op' = True
130+ isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)
131+ isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
139132 isOp _ = False
140133 binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
141134 binaryFunction dictName fnName op = everywhere (mkT convert)
@@ -143,9 +136,7 @@ inlineCommonOperators = applyAll
143136 convert :: JS -> JS
144137 convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
145138 convert other = other
146− isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
147− _ps == C._ps &&
148− fnName == fnName' = True
139+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
149140 isOp _ = False
150141 unary :: String -> String -> UnaryOperator -> JS -> JS
151142 unary dictName fnName op = everywhere (mkT convert)
@@ -153,11 +144,7 @@ inlineCommonOperators = applyAll
153144 convert :: JS -> JS
154145 convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
155146 convert other = other
156− isOp (JSAccessor fnName' (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
157− _ps == C._ps &&
158− fnName' == fnName = True
147+ isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
159148 isOp _ = False
160− isOpDict dictName (JSApp (JSAccessor prop (JSAccessor prelude (JSVar _ps))) [JSObjectLiteral []]) | prelude == C.prelude &&
161− _ps == C._ps &&
162− prop == dictName = True
149+ isOpDict dictName (JSApp (JSAccessor prop (JSVar prelude)) [JSObjectLiteral []]) = prelude == C.prelude && prop == dictName
163150 isOpDict _ _ = False
src/Language/PureScript/Optimizer/MagicDo.hs+7−21
@@ -80,31 +80,19 @@ magicDo' = everywhere (mkT undo) . everywhere' (mkT convert)
8080 isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
8181 isReturn _ = False
8282 -- Check if an expression represents the polymorphic >>= function
83− isBindPoly (JSAccessor prop (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
84− _ps == C._ps &&
85− prop == identToJs (Op (C.>>=)) = True
86− isBindPoly (JSIndexer (JSStringLiteral bind) (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
87− _ps == C._ps &&
88− bind == (C.>>=) = True
83+ isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == identToJs (Op (C.>>=))
84+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && bind == (C.>>=)
8985 isBindPoly _ = False
9086 -- Check if an expression represents the polymorphic return function
91− isRetPoly (JSAccessor returnEscaped (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
92− _ps == C._ps &&
93− returnEscaped == C.returnEscaped = True
94− isRetPoly (JSIndexer (JSStringLiteral return') (JSAccessor prelude (JSVar _ps))) | prelude == C.prelude &&
95− _ps == C._ps &&
96− return' == C.return = True
87+ isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
88+ isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
9789 isRetPoly _ = False
9890 -- Check if an expression represents a function in the Ef module
99− isEffFunc name (JSAccessor name' (JSAccessor eff (JSVar _ps))) | eff == C.eff &&
100− _ps == C._ps &&
101− name == name' = True
91+ isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
10292 isEffFunc _ _ = False
10393 -- Check if an expression represents the Monad Eff dictionary
10494 isEffDict name (JSApp (JSVar ident) [JSObjectLiteral []]) | ident == name = True
105− isEffDict name (JSApp (JSAccessor prop (JSAccessor eff (JSVar _ps))) [JSObjectLiteral []]) | eff == C.eff &&
106− _ps == C._ps &&
107− prop == name = True
95+ isEffDict name (JSApp (JSAccessor prop (JSVar eff)) [JSObjectLiteral []]) = eff == C.eff && prop == name
10896 isEffDict _ _ = False
10997 -- Remove __do function applications which remain after desugaring
11098 undo :: JS -> JS
@@ -147,9 +135,7 @@ inlineST = everywhere (mkT convertBlock)
147135 JSAssignment (JSIndexer i arr) val
148136 convert _ other = other
149137 -- Check if an expression represents a function in the ST module
150− isSTFunc name (JSAccessor name' (JSAccessor st (JSVar _ps))) | st == C.st &&
151− _ps == C._ps &&
152− name == name' = True
138+ isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
153139 isSTFunc _ _ = False
154140 -- Find all ST Refs initialized in this block
155141 findSTRefsIn = everything (++) (mkQ [] isSTRef)
src/Language/PureScript/Options.hs+2−2
@@ -48,7 +48,7 @@ data Options = Options {
4848 -- Specify the namespace that PureScript modules will be exported to when running in the
4949 -- browser.
5050 --
51− , optionsBrowserNamespace :: String
51+ , optionsBrowserNamespace :: Maybe String
5252 -- |
5353 -- The modules to keep while enabling dead code elimination
5454 --
@@ -67,4 +67,4 @@ data Options = Options {
6767-- Default compiler options
6868--
6969defaultOptions :: Options
70−defaultOptions = Options False False False False Nothing False "PS" [] [] False
70+defaultOptions = Options False False False False Nothing False Nothing [] [] False
tests/Main.hs+5−4
@@ -54,12 +54,13 @@ assert preludeExterns opts inputFile f = do
5454 Just err -> putStrLn err >> exitFailure
5555 Nothing -> return ()
5656
57−assertCompiles :: FilePath -> FilePath -> FilePath -> IO ()
57+assertCompiles :: String -> FilePath -> FilePath -> IO ()
5858assertCompiles preludeJs preludeExterns inputFile = do
5959 putStrLn $ "Assert " ++ inputFile ++ " compiles successfully"
60− let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"] }
60+ let options = P.defaultOptions { P.optionsMain = Just "Main", P.optionsModules = ["Main"], P.optionsCodeGenModules = ["Main"], P.optionsBrowserNamespace = Just "Tests" }
6161 assert preludeExterns options inputFile $ either (return . Just) $ \(js, _, _) -> do
6262 process <- findNodeProcess
63+ putStrLn $ preludeJs ++ js
6364 result <- traverse (\node -> readProcessWithExitCode node [] (preludeJs ++ js)) process
6465 case result of
6566 Just (ExitSuccess, out, _) -> putStrLn out >> return Nothing
@@ -69,7 +70,7 @@ assertCompiles preludeJs preludeExterns inputFile = do
6970assertDoesNotCompile :: FilePath -> FilePath -> IO ()
7071assertDoesNotCompile preludeExterns inputFile = do
7172 putStrLn $ "Assert " ++ inputFile ++ " does not compile"
72− assert preludeExterns P.defaultOptions inputFile $ \e ->
73+ assert preludeExterns (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) inputFile $ \e ->
7374 case e of
7475 Left _ -> return Nothing
7576 Right _ -> return $ Just "Should not have compiled"
@@ -82,7 +83,7 @@ main :: IO ()
8283main = do
8384 prelude <- preludeFilename
8485 putStrLn "Compiling Prelude"
85− preludeResult <- compile P.defaultOptions [prelude]
86+ preludeResult <- compile (P.defaultOptions { P.optionsBrowserNamespace = Just "Tests" }) [prelude]
8687 case preludeResult of
8788 Left err -> putStrLn err >> exitFailure
8889 Right (preludeJs, exts, _) -> do