Skip to content

Commit 81bb633

Browse files
paf31paf31
committed
Merge branch 'commonjs1'
2 parents 807426a + 3248a2b commit 81bb633

File tree

12 files changed

+217
-180
lines changed

12 files changed

+217
-180
lines changed

‎prelude/prelude.purs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -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‎

Lines changed: 10 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -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]
9192
inputFiles = 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+
9499
noTco :: Term Bool
95100
noTco = value $ flag $ (optInfo [ "no-tco" ])
96101
{ optDoc = "Disable tail call optimizations" }
@@ -111,16 +116,12 @@ noOpts :: Term Bool
111116
noOpts = 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-
118119
verboseErrors :: Term Bool
119120
verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
120121
{ optDoc = "Display verbose error messages" }
121122

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

125126
inputFilesAndPrelude :: FilePath -> Term [FilePath]
126127
inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
@@ -129,7 +130,7 @@ inputFilesAndPrelude prelude = combine <$> (not <$> noPrelude) <*> inputFiles
129130
combine False input = input
130131

131132
term :: FilePath -> Term (IO ())
132-
term prelude = compile <$> options <*> inputFilesAndPrelude prelude
133+
term prelude = compile <$> outputDirectory <*> options <*> inputFilesAndPrelude prelude
133134

134135
termInfo :: TermInfo
135136
termInfo = defTI

‎psc/Main.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -127,7 +127,7 @@ verboseErrors = value $ flag $ (optInfo [ "v", "verbose-errors" ])
127127
{ optDoc = "Display verbose error messages" }
128128

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

132132
stdInOrInputFiles :: FilePath -> Term (Maybe [FilePath])
133133
stdInOrInputFiles prelude = combine <$> useStdIn <*> (not <$> noPrelude) <*> inputFiles
@@ -150,3 +150,4 @@ main :: IO ()
150150
main = do
151151
prelude <- preludeFilename
152152
run (term prelude, termInfo)
153+

‎psci/Main.hs‎

Lines changed: 101 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -13,7 +13,7 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

16-
{-# LANGUAGE DoAndIfThenElse, FlexibleContexts #-}
16+
{-# LANGUAGE DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
1717

1818
module Main where
1919

@@ -24,29 +24,36 @@ import Control.Monad
2424
import Control.Monad.Trans.Class
2525
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
2626
import Control.Monad.Trans.State.Strict
27+
import Control.Monad.Error (ErrorT(..), MonadError)
28+
import Control.Monad.Error.Class (MonadError(..))
2729

2830
import Data.List (intercalate, isPrefixOf, nub, sortBy)
2931
import Data.Maybe (mapMaybe)
3032
import Data.Foldable (traverse_)
31-
import Data.Traversable (traverse)
3233
import Data.Version (showVersion)
34+
import Data.Traversable (traverse)
3335

3436
import Parser
3537

38+
import System.IO.Error (tryIOError)
3639
import 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)
3844
import System.Exit
3945
import System.Environment.XDG.BaseDir
40-
import System.FilePath ((</>), isPathSeparator)
46+
import System.FilePath
47+
(pathSeparator, takeDirectory, (</>), isPathSeparator)
4148
import qualified System.Console.CmdTheLine as Cmd
42-
import System.Process
4349

4450
import Text.Parsec (ParseError)
4551

4652
import qualified Data.Map as M
4753
import qualified Language.PureScript as P
4854
import 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)
5764
data 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
8289
updateModules 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
--
199206
options :: 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)
273323
handleCommand (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
281334
handleCommand 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

290344
inputFiles :: Cmd.Term [FilePath]
291345
inputFiles = Cmd.value $ Cmd.posAny [] $ Cmd.posInfo { Cmd.posName = "file(s)"
@@ -311,15 +365,16 @@ loop :: [FilePath] -> IO ()
311365
loop 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
318373
historyFilename <- getHistoryFilename
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

334389
term :: Cmd.Term (IO ())
335390
term = loop <$> inputFiles
@@ -343,4 +398,3 @@ termInfo = Cmd.defTI
343398

344399
main :: IO ()
345400
main = Cmd.run (term, termInfo)
346-

0 commit comments

Comments
 (0)