git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Make PSCi work again
cf17f6eGary Burgess
psci/IO.hsnew file+21
compare with golang
unifiedsplit
@@ -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.hsnew file+124
@@ -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+32−64
@@ -13,39 +13,35 @@
13--
13--
14-----------------------------------------------------------------------------
14-----------------------------------------------------------------------------
15
15
16−{-# LANGUAGE DataKinds #-}
17{-# LANGUAGE DoAndIfThenElse #-}
16{-# LANGUAGE DoAndIfThenElse #-}
18−{-# LANGUAGE FlexibleContexts #-}
19{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20{-# LANGUAGE RecordWildCards #-}
18{-# LANGUAGE RecordWildCards #-}
21
19
22module PSCi where
20module PSCi where
23
21
24import Data.Foldable (traverse_)
22import Data.Foldable (traverse_)
25−import Data.List (intercalate, nub, sort, isPrefixOf)
23+import Data.List (intercalate, nub, sort)
26import Data.Traversable (traverse)
24import Data.Traversable (traverse)
25+import Data.Tuple (swap)
27import Data.Version (showVersion)
26import Data.Version (showVersion)
28import qualified Data.Map as M
27import qualified Data.Map as M
29
28
30import Control.Applicative
29import Control.Applicative
30+import Control.Arrow (first)
31import Control.Monad
31import 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)
37import Control.Monad.Trans.Class
32import Control.Monad.Trans.Class
33+import Control.Monad.Trans.Except (runExceptT)
38import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
34import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
39import Control.Monad.Trans.State.Strict
35import Control.Monad.Trans.State.Strict
36+import Control.Monad.Writer (runWriter)
40import qualified Control.Monad.Trans.State.Lazy as L
37import qualified Control.Monad.Trans.State.Lazy as L
41
38
42import Options.Applicative as Opts
39import Options.Applicative as Opts
43
40
44import System.Console.Haskeline
41import System.Console.Haskeline
45−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
42+import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
46import System.Exit
43import System.Exit
47−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
44+import System.FilePath (pathSeparator, (</>), isPathSeparator)
48−import System.IO.Error (tryIOError)
49import System.Process (readProcessWithExitCode)
45import System.Process (readProcessWithExitCode)
50
46
51import qualified Language.PureScript as P
47import qualified Language.PureScript as P
@@ -53,8 +49,10 @@ import qualified Language.PureScript.Names as N
53import qualified Paths_purescript as Paths
49import qualified Paths_purescript as Paths
54
50
55import qualified Directive as D
51import qualified Directive as D
56−import Parser (parseCommand)
57import Completion (completion)
52import Completion (completion)
53+import IO (mkdirp)
54+import Make
55+import Parser (parseCommand)
58import Types
56import Types
59
57
60-- | The name of the PSCI support module
58-- | The name of the PSCI support module
@@ -88,6 +86,7 @@ supportModule =
88 ]
86 ]
89
87
90-- File helpers
88-- File helpers
89+
91-- |
90-- |
92-- Load the necessary modules.
91-- Load the necessary modules.
93--
92--
@@ -118,7 +117,7 @@ getHistoryFilename = do
118loadModule :: FilePath -> IO (Either String [P.Module])
117loadModule :: FilePath -> IO (Either String [P.Module])
119loadModule filename = do
118loadModule filename = do
120 content <- readFile filename
119 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)]
122
121
123-- |
122-- |
124-- Load all modules, including the Prelude
123-- Load all modules, including the Prelude
@@ -147,6 +146,7 @@ loadAllImportedModules = do
147expandTilde :: FilePath -> IO FilePath
146expandTilde :: FilePath -> IO FilePath
148expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
147expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
149expandTilde p = return p
148expandTilde p = return p
149+
150-- Messages
150-- Messages
151
151
152-- |
152-- |
@@ -160,13 +160,12 @@ helpMessage = "The following commands are available:\n\n " ++
160 line :: (Directive, String, String) -> String
160 line :: (Directive, String, String) -> String
161 line (dir, arg, desc) =
161 line (dir, arg, desc) =
162 let cmd = ':' : D.stringFor dir
162 let cmd = ':' : D.stringFor dir
163− in intercalate " "
164− [ cmd
163+ in unwords [ cmd
165− , replicate (11 - length cmd) ' '
164+ , replicate (11 - length cmd) ' '
166− , arg
165+ , arg
167− , replicate (11 - length arg) ' '
166+ , replicate (11 - length arg) ' '
168− , desc
167+ , desc
169− ]
168+ ]
170
169
171 extraHelp =
170 extraHelp =
172 "Further information is available on the PureScript wiki:\n" ++
171 "Further information is available on the PureScript wiki:\n" ++
@@ -194,14 +193,6 @@ prologueMessage = intercalate "\n"
194quitMessage :: String
193quitMessage :: String
195quitMessage = "See ya!"
194quitMessage = "See ya!"
196
195
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−
205-- |
196-- |
206-- PSCI monad
197-- PSCI monad
207--
198--
@@ -210,30 +201,6 @@ newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Fu
210psciIO :: IO a -> PSCI a
201psciIO :: IO a -> PSCI a
211psciIO io = PSCI . lift $ lift io
202psciIO io = PSCI . lift $ lift io
212
203
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−
237-- |
204-- |
238-- Makes a volatile module to execute the current expression.
205-- Makes a volatile module to execute the current expression.
239--
206--
@@ -274,12 +241,14 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
274importDecl :: ImportedModule -> P.Declaration
241importDecl :: ImportedModule -> P.Declaration
275importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
242importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
276
243
277−modulesDir :: FilePath
278−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
279−
280indexFile :: FilePath
244indexFile :: FilePath
281indexFile = ".psci_modules" ++ pathSeparator : "index.js"
245indexFile = ".psci_modules" ++ pathSeparator : "index.js"
282
246
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+
283-- |
252-- |
284-- Takes a value declaration and evaluates it with the current state.
253-- Takes a value declaration and evaluates it with the current state.
285--
254--
@@ -288,7 +257,7 @@ handleDeclaration val = do
288 st <- PSCI $ lift get
257 st <- PSCI $ lift get
289 let m = createTemporaryModule True st val
258 let m = createTemporaryModule True st val
290 let nodeArgs = psciNodeFlags st ++ [indexFile]
259 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)]
292 case e of
261 case e of
293 Left errs -> printErrors errs
262 Left errs -> printErrors errs
294 Right _ -> do
263 Right _ -> do
@@ -309,7 +278,7 @@ handleDecls ds = do
309 st <- PSCI $ lift get
278 st <- PSCI $ lift get
310 let st' = updateLets ds st
279 let st' = updateLets ds st
311 let m = createTemporaryModule False st' (P.ObjectLiteral [])
280 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)]
313 case e of
282 case e of
314 Left err -> printErrors err
283 Left err -> printErrors err
315 Right _ -> PSCI $ lift (put st')
284 Right _ -> PSCI $ lift (put st')
@@ -362,7 +331,7 @@ handleImport :: ImportedModule -> PSCI ()
362handleImport im = do
331handleImport im = do
363 st <- updateImportedModules im <$> PSCI (lift get)
332 st <- updateImportedModules im <$> PSCI (lift get)
364 let m = createTemporaryModuleForImports st
333 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)]
366 case e of
335 case e of
367 Left errs -> printErrors errs
336 Left errs -> printErrors errs
368 Right _ -> do
337 Right _ -> do
@@ -376,7 +345,7 @@ handleTypeOf :: P.Expr -> PSCI ()
376handleTypeOf val = do
345handleTypeOf val = do
377 st <- PSCI $ lift get
346 st <- PSCI $ lift get
378 let m = createTemporaryModule False st val
347 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)]
380 case e of
349 case e of
381 Left errs -> printErrors errs
350 Left errs -> printErrors errs
382 Right env' ->
351 Right env' ->
@@ -409,12 +378,11 @@ printModuleSignatures moduleName env =
409handleBrowse :: P.ModuleName -> PSCI ()
378handleBrowse :: P.ModuleName -> PSCI ()
410handleBrowse moduleName = do
379handleBrowse moduleName = do
411 st <- PSCI $ lift get
380 st <- PSCI $ lift get
412− let loadedModules = psciLoadedModules st
413− env <- psciIO . runMake $ P.make modulesDir loadedModules []
381+ env <- psciIO . runMake $ make st []
414 case env of
382 case env of
415 Left errs -> printErrors errs
383 Left errs -> printErrors errs
416 Right env' ->
384 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)
418 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
386 then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
419 else printModuleSignatures moduleName env'
387 else printModuleSignatures moduleName env'
420
388
@@ -430,7 +398,7 @@ handleKindOf typ = do
430 st <- PSCI $ lift get
398 st <- PSCI $ lift get
431 let m = createTemporaryModuleForKind st typ
399 let m = createTemporaryModuleForKind st typ
432 mName = P.ModuleName [P.ProperName "$PSCI"]
400 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)]
434 case e of
402 case e of
435 Left errs -> printErrors errs
403 Left errs -> printErrors errs
436 Right env' ->
404 Right env' ->
@@ -519,7 +487,7 @@ loop PSCiOptions{..} = do
519 config <- loadUserConfig
487 config <- loadUserConfig
520 modulesOrFirstError <- loadAllModules psciInputFile
488 modulesOrFirstError <- loadAllModules psciInputFile
521 case modulesOrFirstError of
489 case modulesOrFirstError of
522− Left err -> print err >> exitFailure
490+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
523 Right modules -> do
491 Right modules -> do
524 historyFilename <- getHistoryFilename
492 historyFilename <- getHistoryFilename
525 let settings = defaultSettings { historyFile = Just historyFilename }
493 let settings = defaultSettings { historyFile = Just historyFilename }
psci/Types.hs+2
@@ -15,6 +15,7 @@
15
15
16module Types where
16module Types where
17
17
18+import qualified Data.Map as M
18import qualified Language.PureScript as P
19import qualified Language.PureScript as P
19
20
20data PSCiOptions = PSCiOptions
21data PSCiOptions = PSCiOptions
@@ -33,6 +34,7 @@ data PSCiState = PSCiState
33 { psciImportedFilenames :: [FilePath]
34 { psciImportedFilenames :: [FilePath]
34 , psciImportedModules :: [ImportedModule]
35 , psciImportedModules :: [ImportedModule]
35 , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
36 , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
37+ --, psciForeignFiles :: M.Map P.ModuleName P.ForeignJS
36 , psciLetBindings :: [P.Declaration]
38 , psciLetBindings :: [P.Declaration]
37 , psciNodeFlags :: [String]
39 , psciNodeFlags :: [String]
38 }
40 }
purescript.cabal+1−1
@@ -166,7 +166,7 @@ executable psci
166 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
166 build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
167 mtl -any, optparse-applicative >= 0.10.0, parsec -any,
167 mtl -any, optparse-applicative >= 0.10.0, parsec -any,
168 haskeline >= 0.7.0.0, purescript -any, transformers -any,
168 haskeline >= 0.7.0.0, purescript -any, transformers -any,
169− transformers-compat -any, process -any
169+ transformers-compat -any, process -any, time -any
170
170
171 main-is: Main.hs
171 main-is: Main.hs
172 buildable: True
172 buildable: True