Skip to content

Commit cf17f6e

Browse files
garybgaryb
committed
Make PSCi work again
1 parent aca96b2 commit cf17f6e

File tree

5 files changed

+180
-65
lines changed

5 files changed

+180
-65
lines changed

‎psci/IO.hs‎

Lines changed: 21 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,21 @@
1+
-----------------------------------------------------------------------------
2+
--
3+
-- Module : IO
4+
-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+
-- License : MIT
6+
--
7+
-- Maintainer : Phil Freeman <paf31@cantab.net>
8+
-- Stability : experimental
9+
-- Portability :
10+
--
11+
-- |
12+
--
13+
-----------------------------------------------------------------------------
14+
15+
module IO where
16+
17+
import System.Directory (createDirectoryIfMissing)
18+
import System.FilePath (takeDirectory)
19+
20+
mkdirp :: FilePath -> IO ()
21+
mkdirp = createDirectoryIfMissing True . takeDirectory

‎psci/Make.hs‎

Lines changed: 124 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,124 @@
1+
-----------------------------------------------------------------------------
2+
--
3+
-- Module : Make
4+
-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+
-- License : MIT
6+
--
7+
-- Maintainer : Phil Freeman <paf31@cantab.net>
8+
-- Stability : experimental
9+
-- Portability :
10+
--
11+
-- |
12+
--
13+
-----------------------------------------------------------------------------
14+
15+
{-# LANGUAGE DataKinds #-}
16+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+
{-# LANGUAGE TupleSections #-}
18+
19+
module Make where
20+
21+
import Data.List (isPrefixOf)
22+
import Data.Maybe (fromMaybe)
23+
import Data.Time.Clock
24+
import Data.Traversable (traverse)
25+
import qualified Data.Map as M
26+
27+
import Control.Applicative
28+
import Control.Monad
29+
import Control.Monad.Error.Class (MonadError(..))
30+
import Control.Monad.IO.Class (MonadIO, liftIO)
31+
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32+
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
33+
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT)
34+
35+
import System.Directory (getModificationTime, doesFileExist)
36+
import System.FilePath ((</>), pathSeparator)
37+
import System.IO.Error (tryIOError)
38+
39+
import qualified Language.PureScript as P
40+
import qualified Language.PureScript.CodeGen.JS as J
41+
import qualified Language.PureScript.CoreFn as CF
42+
43+
import IO (mkdirp)
44+
45+
options :: P.Options P.Make
46+
options = P.Options False False False Nothing False False False P.MakeOptions
47+
48+
modulesDir :: FilePath
49+
modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
50+
51+
newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
52+
deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
53+
54+
runMake :: Make a -> IO (Either P.MultipleErrors a)
55+
runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
56+
57+
makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
58+
makeIO f io = do
59+
e <- liftIO $ tryIOError io
60+
either (throwError . P.singleError . f) return e
61+
62+
-- Traverse (Either e) instance (base 4.7)
63+
traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
64+
traverseEither _ (Left x) = pure (Left x)
65+
traverseEither f (Right y) = Right <$> f y
66+
67+
buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)
68+
-> M.Map P.ModuleName P.ForeignJS
69+
-> P.MakeActions Make
70+
buildMakeActions filePathMap foreigns =
71+
P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72+
where
73+
74+
getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75+
getInputTimestamp mn = do
76+
let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77+
traverseEither getTimestamp path
78+
79+
getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
80+
getOutputTimestamp mn = do
81+
let filePath = P.runModuleName mn
82+
jsFile = modulesDir </> filePath </> "index.js"
83+
externsFile = modulesDir </> filePath </> "externs.purs"
84+
min <$> getTimestamp jsFile <*> getTimestamp externsFile
85+
86+
readExterns :: P.ModuleName -> Make (FilePath, String)
87+
readExterns mn = do
88+
let path = modulesDir </> P.runModuleName mn </> "externs.purs"
89+
(path, ) <$> readTextFile path
90+
91+
codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
92+
codegen m _ nextVar exts = do
93+
foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
94+
Just _ | not $ requiresForeign m -> error "Found unnecessary foreign module"
95+
| otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
96+
Nothing | requiresForeign m -> error "Foreign module missing"
97+
| otherwise -> return Nothing
98+
pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
99+
let filePath = P.runModuleName $ CF.moduleName m
100+
jsFile = modulesDir </> filePath </> "index.js"
101+
externsFile = modulesDir </> filePath </> "externs.purs"
102+
foreignFile = modulesDir </> filePath </> "foreign.js"
103+
writeTextFile jsFile pjs
104+
maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
105+
writeTextFile externsFile exts
106+
107+
requiresForeign :: CF.Module a -> Bool
108+
requiresForeign = not . null . CF.moduleForeign
109+
110+
getTimestamp :: FilePath -> Make (Maybe UTCTime)
111+
getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
112+
exists <- doesFileExist path
113+
traverse (const $ getModificationTime path) $ guard exists
114+
115+
readTextFile :: FilePath -> Make String
116+
readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
117+
118+
writeTextFile :: FilePath -> String -> Make ()
119+
writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
120+
mkdirp path
121+
writeFile path text
122+
123+
progress :: String -> Make ()
124+
progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s

‎psci/PSCi.hs‎

Lines changed: 32 additions & 64 deletions
Original file line numberDiff line numberDiff line change
@@ -13,48 +13,46 @@
1313
--
1414
-----------------------------------------------------------------------------
1515

16-
{-# LANGUAGE DataKinds #-}
1716
{-# LANGUAGE DoAndIfThenElse #-}
18-
{-# LANGUAGE FlexibleContexts #-}
1917
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2018
{-# LANGUAGE RecordWildCards #-}
2119

2220
module PSCi where
2321

2422
import Data.Foldable (traverse_)
25-
import Data.List (intercalate, nub, sort, isPrefixOf)
23+
import Data.List (intercalate, nub, sort)
2624
import Data.Traversable (traverse)
25+
import Data.Tuple (swap)
2726
import Data.Version (showVersion)
2827
import qualified Data.Map as M
2928

3029
import Control.Applicative
30+
import Control.Arrow (first)
3131
import Control.Monad
32-
import Control.Monad.IO.Class (MonadIO, liftIO)
33-
import Control.Monad.Error.Class (MonadError(..))
34-
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
35-
import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
36-
import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, runWriter)
3732
import Control.Monad.Trans.Class
33+
import Control.Monad.Trans.Except (runExceptT)
3834
import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
3935
import Control.Monad.Trans.State.Strict
36+
import Control.Monad.Writer (runWriter)
4037
import qualified Control.Monad.Trans.State.Lazy as L
4138

4239
import Options.Applicative as Opts
4340

4441
import System.Console.Haskeline
45-
import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
42+
import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
4643
import System.Exit
47-
import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
48-
import System.IO.Error (tryIOError)
44+
import System.FilePath (pathSeparator, (</>), isPathSeparator)
4945
import System.Process (readProcessWithExitCode)
5046

5147
import qualified Language.PureScript as P
5248
import qualified Language.PureScript.Names as N
5349
import qualified Paths_purescript as Paths
5450

5551
import qualified Directive as D
56-
import Parser (parseCommand)
5752
import Completion (completion)
53+
import IO (mkdirp)
54+
import Make
55+
import Parser (parseCommand)
5856
import Types
5957

6058
-- | The name of the PSCI support module
@@ -88,6 +86,7 @@ supportModule =
8886
]
8987

9088
-- File helpers
89+
9190
-- |
9291
-- Load the necessary modules.
9392
--
@@ -118,7 +117,7 @@ getHistoryFilename = do
118117
loadModule :: FilePath -> IO (Either String [P.Module])
119118
loadModule filename = do
120119
content <- readFile filename
121-
return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
120+
return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
122121

123122
-- |
124123
-- Load all modules, including the Prelude
@@ -147,6 +146,7 @@ loadAllImportedModules = do
147146
expandTilde :: FilePath -> IO FilePath
148147
expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
149148
expandTilde p = return p
149+
150150
-- Messages
151151

152152
-- |
@@ -160,13 +160,12 @@ helpMessage = "The following commands are available:\n\n " ++
160160
line :: (Directive, String, String) -> String
161161
line (dir, arg, desc) =
162162
let cmd = ':' : D.stringFor dir
163-
in intercalate " "
164-
[ cmd
165-
, replicate (11 - length cmd) ' '
166-
, arg
167-
, replicate (11 - length arg) ' '
168-
, desc
169-
]
163+
in unwords [ cmd
164+
, replicate (11 - length cmd) ' '
165+
, arg
166+
, replicate (11 - length arg) ' '
167+
, desc
168+
]
170169

171170
extraHelp =
172171
"Further information is available on the PureScript wiki:\n" ++
@@ -194,14 +193,6 @@ prologueMessage = intercalate "\n"
194193
quitMessage :: String
195194
quitMessage = "See ya!"
196195

197-
198-
-- Compilation
199-
200-
-- | Compilation options.
201-
--
202-
options :: P.Options P.Make
203-
options = P.Options False False False Nothing False False False P.MakeOptions
204-
205196
-- |
206197
-- PSCI monad
207198
--
@@ -210,30 +201,6 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu
210201
psciIO :: IO a -> PSCI a
211202
psciIO io = PSCI . lift $ lift io
212203

213-
newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
214-
deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
215-
216-
runMake :: Make a -> IO (Either P.MultipleErrors a)
217-
runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
218-
219-
makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
220-
makeIO f io = do
221-
e <- liftIO $ tryIOError io
222-
either (throwError . P.singleError . f) return e
223-
224-
instance P.MonadMake Make where
225-
getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
226-
exists <- doesFileExist path
227-
traverse (const $ getModificationTime path) $ guard exists
228-
readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
229-
writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
230-
mkdirp path
231-
writeFile path text
232-
progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
233-
234-
mkdirp :: FilePath -> IO ()
235-
mkdirp = createDirectoryIfMissing True . takeDirectory
236-
237204
-- |
238205
-- Makes a volatile module to execute the current expression.
239206
--
@@ -274,12 +241,14 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
274241
importDecl :: ImportedModule -> P.Declaration
275242
importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
276243

277-
modulesDir :: FilePath
278-
modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
279-
280244
indexFile :: FilePath
281245
indexFile = ".psci_modules" ++ pathSeparator : "index.js"
282246

247+
make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> Make P.Environment
248+
make PSCiState{..} ms =
249+
let filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
250+
in P.make (buildMakeActions filePathMap M.empty) (psciLoadedModules ++ ms)
251+
283252
-- |
284253
-- Takes a value declaration and evaluates it with the current state.
285254
--
@@ -288,7 +257,7 @@ handleDeclaration val = do
288257
st <- PSCI $ lift get
289258
let m = createTemporaryModule True st val
290259
let nodeArgs = psciNodeFlags st ++ [indexFile]
291-
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]) []
260+
e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]
292261
case e of
293262
Left errs -> printErrors errs
294263
Right _ -> do
@@ -309,7 +278,7 @@ handleDecls ds = do
309278
st <- PSCI $ lift get
310279
let st' = updateLets ds st
311280
let m = createTemporaryModule False st' (P.ObjectLiteral [])
312-
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
281+
e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]
313282
case e of
314283
Left err -> printErrors err
315284
Right _ -> PSCI $ lift (put st')
@@ -362,7 +331,7 @@ handleImport :: ImportedModule -> PSCI ()
362331
handleImport im = do
363332
st <- updateImportedModules im <$> PSCI (lift get)
364333
let m = createTemporaryModuleForImports st
365-
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
334+
e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
366335
case e of
367336
Left errs -> printErrors errs
368337
Right _ -> do
@@ -376,7 +345,7 @@ handleTypeOf :: P.Expr -> PSCI ()
376345
handleTypeOf val = do
377346
st <- PSCI $ lift get
378347
let m = createTemporaryModule False st val
379-
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
348+
e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
380349
case e of
381350
Left errs -> printErrors errs
382351
Right env' ->
@@ -409,12 +378,11 @@ printModuleSignatures moduleName env =
409378
handleBrowse :: P.ModuleName -> PSCI ()
410379
handleBrowse moduleName = do
411380
st <- PSCI $ lift get
412-
let loadedModules = psciLoadedModules st
413-
env <- psciIO . runMake $ P.make modulesDir loadedModules []
381+
env <- psciIO . runMake $ make st []
414382
case env of
415383
Left errs -> printErrors errs
416384
Right env' ->
417-
if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules
385+
if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
418386
then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
419387
else printModuleSignatures moduleName env'
420388

@@ -430,7 +398,7 @@ handleKindOf typ = do
430398
st <- PSCI $ lift get
431399
let m = createTemporaryModuleForKind st typ
432400
mName = P.ModuleName [P.ProperName "$PSCI"]
433-
e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
401+
e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
434402
case e of
435403
Left errs -> printErrors errs
436404
Right env' ->
@@ -519,7 +487,7 @@ loop PSCiOptions{..} = do
519487
config <- loadUserConfig
520488
modulesOrFirstError <- loadAllModules psciInputFile
521489
case modulesOrFirstError of
522-
Left err -> print err >> exitFailure
490+
Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
523491
Right modules -> do
524492
historyFilename <- getHistoryFilename
525493
let settings = defaultSettings { historyFile = Just historyFilename }

‎psci/Types.hs‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -15,6 +15,7 @@
1515

1616
module Types where
1717

18+
import qualified Data.Map as M
1819
import qualified Language.PureScript as P
1920

2021
data PSCiOptions = PSCiOptions
@@ -33,6 +34,7 @@ data PSCiState = PSCiState
3334
{ psciImportedFilenames :: [FilePath]
3435
, psciImportedModules :: [ImportedModule]
3536
, psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
37+
--, psciForeignFiles :: M.Map P.ModuleName P.ForeignJS
3638
, psciLetBindings :: [P.Declaration]
3739
, psciNodeFlags :: [String]
3840
}

0 commit comments

Comments
 (0)