git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
PSCi speed improvements and design changes (#2088)
9e56266Phil Freeman
psci/Main.hsnew file+144
compare with golang
unifiedsplit
@@ -0,0 +1,144 @@
1+{-# LANGUAGE DataKinds #-}
2+{-# LANGUAGE DoAndIfThenElse #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE ScopedTypeVariables #-}
7+{-# LANGUAGE TupleSections #-}
8+
9+module Main (main) where
10+
11+import Prelude ()
12+import Prelude.Compat
13+
14+import Data.Monoid ((<>))
15+import Data.Version (showVersion)
16+
17+import Control.Applicative (many)
18+import Control.Monad
19+import Control.Monad.IO.Class (liftIO)
20+import Control.Monad.Trans.Class
21+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
22+import Control.Monad.Trans.State.Strict (StateT, evalStateT)
23+import Control.Monad.Trans.Reader (ReaderT, runReaderT)
24+
25+import qualified Language.PureScript as P
26+import Language.PureScript.Interactive
27+
28+import qualified Options.Applicative as Opts
29+
30+import qualified Paths_purescript as Paths
31+
32+import System.Console.Haskeline
33+import System.Exit
34+import System.FilePath.Glob (glob)
35+
36+-- | Command line options
37+data PSCiOptions = PSCiOptions
38+ { psciMultiLineMode :: Bool
39+ , psciInputFile :: [FilePath]
40+ , psciForeignInputFiles :: [FilePath]
41+ , psciInputNodeFlags :: [String]
42+ }
43+
44+multiLineMode :: Opts.Parser Bool
45+multiLineMode = Opts.switch $
46+ Opts.long "multi-line-mode"
47+ <> Opts.short 'm'
48+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
49+
50+inputFile :: Opts.Parser FilePath
51+inputFile = Opts.strArgument $
52+ Opts.metavar "FILE"
53+ <> Opts.help "Optional .purs files to load on start"
54+
55+inputForeignFile :: Opts.Parser FilePath
56+inputForeignFile = Opts.strOption $
57+ Opts.short 'f'
58+ <> Opts.long "ffi"
59+ <> Opts.help "The input .js file(s) providing foreign import implementations"
60+
61+nodeFlagsFlag :: Opts.Parser [String]
62+nodeFlagsFlag = Opts.option parser $
63+ Opts.long "node-opts"
64+ <> Opts.metavar "NODE_OPTS"
65+ <> Opts.value []
66+ <> Opts.help "Flags to pass to node, separated by spaces"
67+ where
68+ parser = words <$> Opts.str
69+
70+psciOptions :: Opts.Parser PSCiOptions
71+psciOptions = PSCiOptions <$> multiLineMode
72+ <*> many inputFile
73+ <*> many inputForeignFile
74+ <*> nodeFlagsFlag
75+
76+version :: Opts.Parser (a -> a)
77+version = Opts.abortOption (Opts.InfoMsg (showVersion Paths.version)) $
78+ Opts.long "version" <>
79+ Opts.help "Show the version number" <>
80+ Opts.hidden
81+
82+getOpt :: IO PSCiOptions
83+getOpt = Opts.execParser opts
84+ where
85+ opts = Opts.info (version <*> Opts.helper <*> psciOptions) infoModList
86+ infoModList = Opts.fullDesc <> headerInfo <> footerInfo
87+ headerInfo = Opts.header "psci - Interactive mode for PureScript"
88+ footerInfo = Opts.footer $ "psci " ++ showVersion Paths.version
89+
90+-- | Parses the input and returns either a command, or an error as a 'String'.
91+getCommand :: forall m. MonadException m => Bool -> InputT m (Either String (Maybe Command))
92+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
93+ firstLine <- withInterrupt $ getInputLine "> "
94+ case firstLine of
95+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
96+ Just "" -> return (Right Nothing)
97+ Just s | singleLineMode || head s == ':' -> return . fmap Just $ parseCommand s
98+ Just s -> fmap Just . parseCommand <$> go [s]
99+ where
100+ go :: [String] -> InputT m String
101+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
102+
103+-- | Get command line options and drop into the REPL
104+main :: IO ()
105+main = getOpt >>= loop
106+ where
107+ loop :: PSCiOptions -> IO ()
108+ loop PSCiOptions{..} = do
109+ inputFiles <- concat <$> traverse glob psciInputFile
110+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles
111+ e <- runExceptT $ do
112+ modules <- ExceptT (loadAllModules inputFiles)
113+ unless (supportModuleIsDefined (map snd modules)) . liftIO $ do
114+ putStrLn supportModuleMessage
115+ exitFailure
116+ foreigns <- ExceptT . runMake $ do
117+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> P.readTextFile inFile)
118+ P.parseForeignModulesFromFiles foreignFilesContent
119+ (externs, env) <- ExceptT . runMake . make foreigns . map snd $ modules
120+ return (modules, foreigns, externs, env)
121+ case e of
122+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
123+ Right (modules, foreigns, externs, env) -> do
124+ historyFilename <- getHistoryFilename
125+ let settings = defaultSettings { historyFile = Just historyFilename }
126+ initialState = PSCiState [] [] (zip (map snd modules) externs)
127+ config = PSCiConfig inputFiles foreigns psciInputNodeFlags env
128+ runner = flip runReaderT config
129+ . flip evalStateT initialState
130+ . runInputT (setComplete completion settings)
131+ putStrLn prologueMessage
132+ runner go
133+ where
134+ go :: InputT (StateT PSCiState (ReaderT PSCiConfig IO)) ()
135+ go = do
136+ c <- getCommand (not psciMultiLineMode)
137+ case c of
138+ Left err -> outputStrLn err >> go
139+ Right Nothing -> go
140+ Right (Just QuitPSCi) -> outputStrLn quitMessage
141+ Right (Just c') -> do
142+ handleInterrupt (outputStrLn "Interrupted.")
143+ (withInterrupt (lift (handleCommand c')))
144+ go
psci/PSCi.hsdeleted−374
@@ -1,374 +0,0 @@
1−{-# LANGUAGE DoAndIfThenElse #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3−{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE TupleSections #-}
5−{-# LANGUAGE DataKinds #-}
6−
7−-- |
8−-- PureScript Compiler Interactive.
9−--
10−module PSCi (runPSCi) where
11−
12−import Prelude ()
13−import Prelude.Compat
14−
15−import Data.Foldable (traverse_)
16−import Data.List (intercalate, nub, sort, find, foldl')
17−import Data.Tuple (swap)
18−import qualified Data.Map as M
19−
20−import Control.Arrow (first)
21−import Control.Monad
22−import Control.Monad.Error.Class (MonadError(..))
23−import Control.Monad.Trans.Class
24−import Control.Monad.Trans.Except (ExceptT(), runExceptT)
25−import Control.Monad.Trans.State.Strict
26−import Control.Monad.IO.Class (liftIO)
27−import Control.Monad.Writer.Strict (Writer(), runWriter)
28−
29−import System.Console.Haskeline
30−import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)
31−import System.Exit
32−import System.FilePath ((</>))
33−import System.FilePath.Glob (glob)
34−import System.Process (readProcessWithExitCode)
35−import System.IO.Error (tryIOError)
36−import System.IO.UTF8 (readUTF8File)
37−
38−import qualified Language.PureScript as P
39−import qualified Language.PureScript.Names as N
40−
41−import PSCi.Completion (completion)
42−import PSCi.Parser (parseCommand)
43−import PSCi.Option
44−import PSCi.Types
45−import PSCi.Message
46−import PSCi.IO
47−import PSCi.Printer
48−import PSCi.Module
49−
50−-- |
51−-- PSCI monad
52−--
53−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
54−
55−psciIO :: IO a -> PSCI a
56−psciIO io = PSCI . lift $ lift io
57−
58−-- |
59−-- The runner
60−--
61−runPSCi :: IO ()
62−runPSCi = getOpt >>= loop
63−
64−-- |
65−-- The PSCI main loop.
66−--
67−loop :: PSCiOptions -> IO ()
68−loop PSCiOptions{..} = do
69− config <- loadUserConfig
70− inputFiles <- concat <$> traverse glob psciInputFile
71− foreignFiles <- concat <$> traverse glob psciForeignInputFiles
72− modulesOrFirstError <- loadAllModules inputFiles
73− case modulesOrFirstError of
74− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
75− Right modules -> do
76− historyFilename <- getHistoryFilename
77− let settings = defaultSettings { historyFile = Just historyFilename }
78− foreignsOrError <- runMake $ do
79− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readUTF8File inFile))
80− P.parseForeignModulesFromFiles foreignFilesContent
81− case foreignsOrError of
82− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
83− Right foreigns ->
84− flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
85− outputStrLn prologueMessage
86− traverse_ (traverse_ (runPSCI . handleCommand)) config
87− modules' <- lift $ gets psciLoadedModules
88− unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
89− [ "PSCi requires the purescript-console module to be installed."
90− , "For help getting started, visit http://wiki.purescript.org/PSCi"
91− ]
92− go
93− where
94− go :: InputT (StateT PSCiState IO) ()
95− go = do
96− c <- getCommand (not psciMultiLineMode)
97− case c of
98− Left err -> outputStrLn err >> go
99− Right Nothing -> go
100− Right (Just QuitPSCi) -> outputStrLn quitMessage
101− Right (Just c') -> do
102− handleInterrupt (outputStrLn "Interrupted.")
103− (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
104− go
105−
106−-- Compile the module
107−
108−-- |
109−-- Load all modules, updating the application state
110−--
111−loadAllImportedModules :: PSCI ()
112−loadAllImportedModules = do
113− files <- PSCI . lift $ fmap psciImportedFilenames get
114− modulesOrFirstError <- psciIO $ loadAllModules files
115− case modulesOrFirstError of
116− Left errs -> PSCI $ printErrors errs
117− Right modules -> PSCI . lift . modify $ updateModules modules
118−
119−-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
120−-- options and ignores the warning messages.
121−runMake :: P.Make a -> IO (Either P.MultipleErrors a)
122−runMake mk = fst <$> P.runMake P.defaultOptions mk
123−
124−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> P.Make a
125−makeIO f io = do
126− e <- liftIO $ tryIOError io
127− either (throwError . P.singleError . f) return e
128−
129−make :: PSCiState -> [P.Module] -> P.Make P.Environment
130−make st@PSCiState{..} ms = do
131− externs <- P.make actions' (map snd loadedModules ++ ms)
132− return $ foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs
133− where
134− filePathMap = M.fromList $ (first P.getModuleName . swap) `map` allModules
135− actions = P.buildMakeActions modulesDir filePathMap psciForeignFiles False
136− actions' = actions { P.progress = const (return ()) }
137− loadedModules = psciLoadedModules st
138− allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms
139−
140−
141−-- Commands
142−
143−-- |
144−-- Parses the input and returns either a Metacommand, or an error as a string.
145−--
146−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
147−getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
148− firstLine <- withInterrupt $ getInputLine "> "
149− case firstLine of
150− Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
151− Just "" -> return (Right Nothing)
152− Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
153− Just s -> fmap Just . parseCommand <$> go [s]
154− where
155− go :: [String] -> InputT (StateT PSCiState IO) String
156− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
157−
158−-- |
159−-- Performs an action for each meta-command given, and also for expressions.
160−--
161−handleCommand :: Command -> PSCI ()
162−handleCommand (Expression val) = handleExpression val
163−handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
164−handleCommand (Import im) = handleImport im
165−handleCommand (Decls l) = handleDecls l
166−handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
167− m <- lift . lift $ loadModule absPath
168− case m of
169− Left err -> outputStrLn err
170− Right mods -> lift $ modify (updateModules (map (absPath,) mods))
171−handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
172− foreignsOrError <- lift . lift . runMake $ do
173− foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readUTF8File absPath)
174− P.parseForeignModulesFromFiles [(absPath, foreignFile)]
175− case foreignsOrError of
176− Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err
177− Right foreigns -> lift $ modify (updateForeignFiles foreigns)
178−handleCommand ResetState = do
179− PSCI . lift . modify $ \st ->
180− st { psciImportedModules = []
181− , psciLetBindings = []
182− }
183− loadAllImportedModules
184−handleCommand (TypeOf val) = handleTypeOf val
185−handleCommand (KindOf typ) = handleKindOf typ
186−handleCommand (BrowseModule moduleName) = handleBrowse moduleName
187−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
188−handleCommand (ShowInfo QueryImport) = handleShowImportedModules
189−handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
190−
191−
192−-- |
193−-- Takes a value expression and evaluates it with the current state.
194−--
195−handleExpression :: P.Expr -> PSCI ()
196−handleExpression val = do
197− st <- PSCI $ lift get
198− let m = createTemporaryModule True st val
199− let nodeArgs = psciNodeFlags st ++ [indexFile]
200− e <- psciIO . runMake $ make st [supportModule, m]
201− case e of
202− Left errs -> PSCI $ printErrors errs
203− Right _ -> do
204− psciIO $ writeFile indexFile "require('$PSCI')['$main']();"
205− process <- psciIO findNodeProcess
206− result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
207− case result of
208− Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
209− Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
210− Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
211−
212−-- |
213−-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
214−-- restore the original environment.
215−--
216−handleDecls :: [P.Declaration] -> PSCI ()
217−handleDecls ds = do
218− st <- PSCI $ lift get
219− let st' = updateLets ds st
220− let m = createTemporaryModule False st' (P.Literal (P.ObjectLiteral []))
221− e <- psciIO . runMake $ make st' [m]
222− case e of
223− Left err -> PSCI $ printErrors err
224− Right _ -> PSCI $ lift (put st')
225−
226−-- |
227−-- Show actual loaded modules in psci.
228−--
229−handleShowLoadedModules :: PSCI ()
230−handleShowLoadedModules = do
231− loadedModules <- PSCI $ lift $ gets psciLoadedModules
232− psciIO $ readModules loadedModules >>= putStrLn
233− return ()
234− where readModules = return . unlines . sort . nub . map toModuleName
235− toModuleName = N.runModuleName . (\ (P.Module _ _ mdName _ _) -> mdName) . snd
236−
237−-- |
238−-- Show the imported modules in psci.
239−--
240−handleShowImportedModules :: PSCI ()
241−handleShowImportedModules = do
242− PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get
243− psciIO $ showModules importedModules >>= putStrLn
244− return ()
245− where
246− showModules = return . unlines . sort . map showModule
247− showModule (mn, declType, asQ) =
248− "import " ++ N.runModuleName mn ++ showDeclType declType ++
249− foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ
250−
251− showDeclType P.Implicit = ""
252− showDeclType (P.Explicit refs) = refsList refs
253− showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
254− refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
255−
256− showRef :: P.DeclarationRef -> String
257− showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
258− showRef (P.TypeOpRef op) = "type " ++ N.showOp op
259− showRef (P.ValueRef ident) = N.runIdent ident
260− showRef (P.ValueOpRef op) = N.showOp op
261− showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn
262− showRef (P.TypeInstanceRef ident) = N.runIdent ident
263− showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
264− showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
265−
266− commaList :: [String] -> String
267− commaList = intercalate ", "
268−
269−-- |
270−-- Imports a module, preserving the initial state on failure.
271−--
272−handleImport :: ImportedModule -> PSCI ()
273−handleImport im = do
274− st <- updateImportedModules im <$> PSCI (lift get)
275− let m = createTemporaryModuleForImports st
276− e <- psciIO . runMake $ make st [m]
277− case e of
278− Left errs -> PSCI $ printErrors errs
279− Right _ -> do
280− PSCI $ lift $ put st
281− return ()
282−
283−-- |
284−-- Takes a value and prints its type
285−--
286−handleTypeOf :: P.Expr -> PSCI ()
287−handleTypeOf val = do
288− st <- PSCI $ lift get
289− let m = createTemporaryModule False st val
290− e <- psciIO . runMake $ make st [m]
291− case e of
292− Left errs -> PSCI $ printErrors errs
293− Right env' ->
294− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
295− Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
296− Nothing -> PSCI $ outputStrLn "Could not find type"
297−
298−-- |
299−-- Browse a module and displays its signature (if module exists).
300−--
301−handleBrowse :: P.ModuleName -> PSCI ()
302−handleBrowse moduleName = do
303− st <- PSCI $ lift get
304− env <- psciIO . runMake $ make st []
305− case env of
306− Left errs -> PSCI $ printErrors errs
307− Right env' ->
308− if isModInEnv moduleName st
309− then PSCI $ printModuleSignatures moduleName env'
310− else case lookupUnQualifiedModName moduleName st of
311− Just unQualifiedName ->
312− if isModInEnv unQualifiedName st
313− then PSCI $ printModuleSignatures unQualifiedName env'
314− else failNotInEnv moduleName
315− Nothing ->
316− failNotInEnv moduleName
317− where
318− isModInEnv modName =
319− any ((== modName) . P.getModuleName . snd) . psciLoadedModules
320− failNotInEnv modName =
321− PSCI $ outputStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."
322− lookupUnQualifiedModName quaModName st =
323− (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
324−
325−-- |
326−-- Takes a value and prints its kind
327−--
328−handleKindOf :: P.Type -> PSCI ()
329−handleKindOf typ = do
330− st <- PSCI $ lift get
331− let m = createTemporaryModuleForKind st typ
332− mName = P.ModuleName [P.ProperName "$PSCI"]
333− e <- psciIO . runMake $ make st [m]
334− case e of
335− Left errs -> PSCI $ printErrors errs
336− Right env' ->
337− case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
338− Just (_, typ') -> do
339− let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
340− k = check (P.kindOf typ') chk
341−
342− check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
343− check sew = fst . runWriter . runExceptT . runStateT sew
344− case k of
345− Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
346− Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
347− Nothing -> PSCI $ outputStrLn "Could not find kind"
348−
349−-- Misc
350−
351−-- |
352−-- Attempts to read initial commands from '.psci' in the present working
353−-- directory then the user's home
354−--
355−loadUserConfig :: IO (Maybe [Command])
356−loadUserConfig = onFirstFileMatching readCommands pathGetters
357− where
358− pathGetters = [getCurrentDirectory, getHomeDirectory]
359− readCommands :: IO FilePath -> IO (Maybe [Command])
360− readCommands path = do
361− configFile <- (</> ".psci") <$> path
362− exists <- doesFileExist configFile
363− if exists
364− then do
365− ls <- lines <$> readUTF8File configFile
366− case traverse parseCommand ls of
367− Left err -> print err >> exitFailure
368− Right cs -> return $ Just cs
369− else
370− return Nothing
371−
372−-- | Checks if the Console module is defined
373−consoleIsDefined :: [P.Module] -> Bool
374−consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)
psci/PSCi/Message.hsdeleted−52
@@ -1,52 +0,0 @@
1−module PSCi.Message where
2−
3−import Data.List (intercalate)
4−
5−import PSCi.Types
6−import qualified PSCi.Directive as D
7−
8−-- Messages
9−
10−-- |
11−-- The help message.
12−--
13−helpMessage :: String
14−helpMessage = "The following commands are available:\n\n " ++
15− intercalate "\n " (map line D.help) ++
16− "\n\n" ++ extraHelp
17− where
18− line :: (Directive, String, String) -> String
19− line (dir, arg, desc) =
20− let cmd = ':' : D.stringFor dir
21− in unwords [ cmd
22− , replicate (11 - length cmd) ' '
23− , arg
24− , replicate (11 - length arg) ' '
25− , desc
26− ]
27−
28− extraHelp =
29− "Further information is available on the PureScript wiki:\n" ++
30− " --> https://github.com/purescript/purescript/wiki/psci"
31−
32−
33−-- |
34−-- The welcome prologue.
35−--
36−prologueMessage :: String
37−prologueMessage = intercalate "\n"
38− [ " ____ ____ _ _ "
39− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
40− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
41− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
42− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
43− , " |_| "
44− , ""
45− , ":? shows help"
46− ]
47−
48−-- |
49−-- The quit message.
50−--
51−quitMessage :: String
52−quitMessage = "See ya!"
psci/PSCi/Option.hsdeleted−57
@@ -1,57 +0,0 @@
1−module PSCi.Option (
2− getOpt
3−) where
4−
5−import Prelude ()
6−import Prelude.Compat
7−
8−import Options.Applicative as Opts
9−import Data.Version (showVersion)
10−
11−import PSCi.Types
12−import qualified Paths_purescript as Paths
13−
14−-- Parse Command line option
15−
16−multiLineMode :: Parser Bool
17−multiLineMode = switch $
18− long "multi-line-mode"
19− <> short 'm'
20− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
21−
22−inputFile :: Parser FilePath
23−inputFile = strArgument $
24− metavar "FILE"
25− <> Opts.help "Optional .purs files to load on start"
26−
27−inputForeignFile :: Parser FilePath
28−inputForeignFile = strOption $
29− short 'f'
30− <> long "ffi"
31− <> help "The input .js file(s) providing foreign import implementations"
32−
33−nodeFlagsFlag :: Parser [String]
34−nodeFlagsFlag = option parser $
35− long "node-opts"
36− <> metavar "NODE_OPTS"
37− <> value []
38− <> Opts.help "Flags to pass to node, separated by spaces"
39− where
40− parser = words <$> str
41−
42−psciOptions :: Parser PSCiOptions
43−psciOptions = PSCiOptions <$> multiLineMode
44− <*> many inputFile
45− <*> many inputForeignFile
46− <*> nodeFlagsFlag
47−
48−version :: Parser (a -> a)
49−version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
50−
51−getOpt :: IO PSCiOptions
52−getOpt = execParser opts
53− where
54− opts = info (version <*> helper <*> psciOptions) infoModList
55− infoModList = fullDesc <> headerInfo <> footerInfo
56− headerInfo = header "psci - Interactive mode for PureScript"
57− footerInfo = footer $ "psci " ++ showVersion Paths.version
psci/main/Main.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−import PSCi
4−
5−main :: IO ()
6−main = runPSCi
purescript.cabal+150−95
@@ -88,47 +88,48 @@ source-repository head
88
88
89library
89library
90 build-depends: base >=4.8 && <5,
90 build-depends: base >=4.8 && <5,
91+ aeson >= 0.8 && < 0.12,
92+ aeson-better-errors >= 0.8,
91 base-compat >=0.6.0,
93 base-compat >=0.6.0,
92− lifted-base >= 0.2.3 && < 0.2.4,
94+ bower-json >= 0.8,
93− monad-control >= 1.0.0.0 && < 1.1,
95+ boxes >= 0.1.4 && < 0.2.0,
94− transformers-base >= 0.4.0 && < 0.5,
96+ bytestring -any,
95 containers -any,
97 containers -any,
96− unordered-containers -any,
97− dlist -any,
98 directory >= 1.2,
98 directory >= 1.2,
99+ dlist -any,
100+ edit-distance -any,
99 filepath -any,
101 filepath -any,
102+ fsnotify >= 0.2.1,
103+ Glob >= 0.7 && < 0.8,
104+ haskeline >= 0.7.0.0,
105+ http-types -any,
106+ language-javascript == 0.6.*,
107+ lifted-base >= 0.2.3 && < 0.2.4,
108+ monad-control >= 1.0.0.0 && < 1.1,
109+ monad-logger >= 0.3 && < 0.4,
100 mtl >= 2.1.0 && < 2.3.0,
110 mtl >= 2.1.0 && < 2.3.0,
111+ parallel >= 3.2 && < 3.3,
101 parsec -any,
112 parsec -any,
102− transformers >= 0.3.0 && < 0.6,
103− transformers-compat >= 0.3.0,
104− utf8-string >= 1 && < 2,
105 pattern-arrows >= 0.0.2 && < 0.1,
113 pattern-arrows >= 0.0.2 && < 0.1,
106− time -any,
114+ pipes >= 4.0.0 && < 4.2.0,
107− boxes >= 0.1.4 && < 0.2.0,
115+ pipes-http -any,
108− aeson >= 0.8 && < 0.12,
109− vector -any,
110− bower-json >= 0.8,
111− aeson-better-errors >= 0.8,
112− bytestring -any,
113− text -any,
114− split -any,
115− language-javascript == 0.6.*,
116− syb -any,
117− Glob >= 0.7 && < 0.8,
118 process >= 1.2.0 && < 1.5,
116 process >= 1.2.0 && < 1.5,
117+ regex-tdfa -any,
119 safe >= 0.3.9 && < 0.4,
118 safe >= 0.3.9 && < 0.4,
120 semigroups >= 0.16.2 && < 0.19,
119 semigroups >= 0.16.2 && < 0.19,
121− parallel >= 3.2 && < 3.3,
122 sourcemap >= 0.1.6,
120 sourcemap >= 0.1.6,
121+ spdx == 0.2.*,
122+ split -any,
123 stm >= 0.2.4.0,
123 stm >= 0.2.4.0,
124− regex-tdfa -any,
124+ syb -any,
125− edit-distance -any,
125+ text -any,
126− fsnotify >= 0.2.1,
126+ time -any,
127− monad-logger >= 0.3 && < 0.4,
127+ transformers >= 0.3.0 && < 0.6,
128− pipes >= 4.0.0 && < 4.2.0 ,
128+ transformers-base >= 0.4.0 && < 0.5,
129− pipes-http -any,
129+ transformers-compat >= 0.3.0,
130− http-types -any,
130+ unordered-containers -any,
131− spdx == 0.2.*
131+ utf8-string >= 1 && < 2,
132+ vector -any
132
133
133 exposed-modules: Language.PureScript
134 exposed-modules: Language.PureScript
134 Language.PureScript.AST
135 Language.PureScript.AST
@@ -257,6 +258,16 @@ library
257 Language.PureScript.Ide.Util
258 Language.PureScript.Ide.Util
258 Language.PureScript.Ide.Rebuild
259 Language.PureScript.Ide.Rebuild
259
260
261+ Language.PureScript.Interactive
262+ Language.PureScript.Interactive.Types
263+ Language.PureScript.Interactive.Parser
264+ Language.PureScript.Interactive.Directive
265+ Language.PureScript.Interactive.Completion
266+ Language.PureScript.Interactive.IO
267+ Language.PureScript.Interactive.Message
268+ Language.PureScript.Interactive.Module
269+ Language.PureScript.Interactive.Printer
270+
260 Control.Monad.Logger
271 Control.Monad.Logger
261 Control.Monad.Supply
272 Control.Monad.Supply
262 Control.Monad.Supply.Class
273 Control.Monad.Supply.Class
@@ -286,11 +297,22 @@ library
286 ghc-options: -Wall -O2
297 ghc-options: -Wall -O2
287
298
288executable psc
299executable psc
289− build-depends: base >=4 && <5, base-compat >=0.6.0,
300+ build-depends: base >=4 && <5,
301+ purescript -any,
302+ aeson >= 0.8 && < 0.12,
303+ base-compat >=0.6.0,
304+ bytestring -any,
290− containers -any, directory -any, filepath -any,
305+ containers -any,
306+ directory -any,
307+ filepath -any,
308+ Glob >= 0.7 && < 0.8,
309+ mtl -any,
291− mtl -any, optparse-applicative >= 0.12.1, parsec -any, purescript -any,
310+ optparse-applicative >= 0.12.1,
311+ parsec -any,
312+ time -any,
313+ transformers -any,
292− time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8,
314+ transformers-compat -any,
293− aeson >= 0.8 && < 0.12, bytestring -any, utf8-string >= 1 && < 2
315+ utf8-string >= 1 && < 2
294 main-is: Main.hs
316 main-is: Main.hs
295 buildable: True
317 buildable: True
296 hs-source-dirs: psc
318 hs-source-dirs: psc
@@ -298,33 +320,40 @@ executable psc
298 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
320 ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts "-with-rtsopts=-N"
299
321
300executable psci
322executable psci
301− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
323+ build-depends: base >=4 && <5,
324+ purescript -any,
325+ base-compat >=0.6.0,
326+ boxes >= 0.1.4 && < 0.2.0,
327+ containers -any,
328+ directory -any,
329+ filepath -any,
330+ Glob -any,
331+ haskeline >= 0.7.0.0,
332+ mtl -any,
302− mtl -any, optparse-applicative >= 0.12.1, parsec -any,
333+ optparse-applicative >= 0.12.1,
303− haskeline >= 0.7.0.0, purescript -any, transformers -any,
334+ parsec -any,
304− transformers-compat -any, process -any, time -any, Glob -any, base-compat >=0.6.0,
335+ process -any,
305− boxes >= 0.1.4 && < 0.2.0
336+ time -any,
306−
337+ transformers -any,
338+ transformers-compat -any
307 main-is: Main.hs
339 main-is: Main.hs
308 buildable: True
340 buildable: True
309− hs-source-dirs: psci psci/main
341+ hs-source-dirs: psci
310− other-modules: PSCi
311− PSCi.Types
312− PSCi.Parser
313− PSCi.Directive
314− PSCi.Completion
315− PSCi.IO
316− PSCi.Message
317− PSCi.Option
318− PSCi.Module
319− PSCi.Printer
320− Paths_purescript
342+ other-modules: Paths_purescript
321 ghc-options: -Wall -O2
343 ghc-options: -Wall -O2
322
344
323executable psc-docs
345executable psc-docs
324− build-depends: base >=4 && <5, purescript -any,
346+ build-depends: base >=4 && <5,
347+ purescript -any,
348+ ansi-wl-pprint -any,
349+ directory -any,
350+ filepath -any,
351+ Glob -any,
352+ mtl -any,
325− optparse-applicative >= 0.12.1, process -any, mtl -any,
353+ optparse-applicative >= 0.12.1,
326− split -any, ansi-wl-pprint -any, directory -any,
354+ process -any,
355+ split -any,
327− filepath -any, Glob -any, transformers -any,
356+ transformers -any,
328 transformers-compat -any
357 transformers-compat -any
329 main-is: Main.hs
358 main-is: Main.hs
330 other-modules: Paths_purescript
359 other-modules: Paths_purescript
@@ -336,7 +365,11 @@ executable psc-docs
336 ghc-options: -Wall -O2
365 ghc-options: -Wall -O2
337
366
338executable psc-publish
367executable psc-publish
368+ build-depends: base >=4 && <5,
369+ purescript -any,
370+ aeson -any,
371+ bytestring -any,
339− build-depends: base >=4 && <5, purescript -any, bytestring -any, aeson -any, optparse-applicative -any
372+ optparse-applicative -any
340 main-is: Main.hs
373 main-is: Main.hs
341 other-modules: Paths_purescript
374 other-modules: Paths_purescript
342 buildable: True
375 buildable: True
@@ -344,9 +377,15 @@ executable psc-publish
344 ghc-options: -Wall -O2
377 ghc-options: -Wall -O2
345
378
346executable psc-hierarchy
379executable psc-hierarchy
380+ build-depends: base >=4 && <5,
381+ purescript -any,
382+ directory -any,
383+ filepath -any,
384+ Glob -any,
385+ mtl -any,
347− build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.12.1,
386+ optparse-applicative >= 0.12.1,
348− process -any, mtl -any, parsec -any, filepath -any, directory -any,
387+ parsec -any,
349− Glob -any
388+ process -any
350 main-is: Main.hs
389 main-is: Main.hs
351 other-modules: Paths_purescript
390 other-modules: Paths_purescript
352 buildable: True
391 buildable: True
@@ -360,13 +399,13 @@ executable psc-bundle
360 other-extensions:
399 other-extensions:
361 build-depends: base >=4 && <5,
400 build-depends: base >=4 && <5,
362 purescript -any,
401 purescript -any,
363− filepath -any,
364 directory -any,
402 directory -any,
403+ filepath -any,
404+ Glob -any,
365 mtl -any,
405 mtl -any,
366− transformers -any,
367− transformers-compat -any,
368 optparse-applicative >= 0.12.1,
406 optparse-applicative >= 0.12.1,
369− Glob -any
407+ transformers -any,
408+ transformers-compat -any
370 ghc-options: -Wall -O2
409 ghc-options: -Wall -O2
371 hs-source-dirs: psc-bundle
410 hs-source-dirs: psc-bundle
372
411
@@ -374,19 +413,19 @@ executable psc-ide-server
374 main-is: Main.hs
413 main-is: Main.hs
375 other-modules: Paths_purescript
414 other-modules: Paths_purescript
376 other-extensions:
415 other-extensions:
377− build-depends: base >=4 && <5
416+ build-depends: base >=4 && <5,
378− , purescript -any
417+ purescript -any,
418+ base-compat >=0.6.0,
379− , directory -any
419+ directory -any,
380− , filepath -any
420+ filepath -any,
381− , monad-logger -any
421+ monad-logger -any,
382− , mtl -any
422+ mtl -any,
383− , transformers -any
384− , transformers-compat -any
385− , network -any
423+ network -any,
386− , optparse-applicative >= 0.12.1
424+ optparse-applicative >= 0.12.1,
387− , stm -any
425+ stm -any,
388− , text -any
426+ text -any,
389− , base-compat >=0.6.0
427+ transformers -any,
428+ transformers-compat -any
390 ghc-options: -Wall -O2 -threaded
429 ghc-options: -Wall -O2 -threaded
391 hs-source-dirs: psc-ide-server
430 hs-source-dirs: psc-ide-server
392
431
@@ -394,23 +433,43 @@ executable psc-ide-client
394 main-is: Main.hs
433 main-is: Main.hs
395 other-modules: Paths_purescript
434 other-modules: Paths_purescript
396 other-extensions:
435 other-extensions:
397− build-depends: base >=4 && <5
436+ build-depends: base >=4 && <5,
437+ base-compat >=0.6.0,
398− , mtl -any
438+ mtl -any,
399− , text -any
439+ network -any,
400− , optparse-applicative >= 0.12.1
440+ optparse-applicative >= 0.12.1,
401− , network -any
441+ text -any
402− , base-compat >=0.6.0
403 ghc-options: -Wall -O2
442 ghc-options: -Wall -O2
404 hs-source-dirs: psc-ide-client
443 hs-source-dirs: psc-ide-client
405
444
406test-suite tests
445test-suite tests
407− build-depends: base >=4 && <5, containers -any, directory -any,
446+ build-depends: base >=4 && <5,
408− filepath -any, mtl -any, parsec -any, purescript -any,
447+ purescript -any,
409− transformers -any, process -any, transformers-compat -any, time -any,
448+ aeson -any,
410− Glob -any, aeson-better-errors -any, bytestring -any, aeson -any,
449+ aeson-better-errors -any,
450+ base-compat -any,
451+ boxes -any,
452+ bytestring -any,
453+ containers -any,
454+ directory -any,
455+ filepath -any,
456+ Glob -any,
457+ haskeline >= 0.7.0.0,
458+ hspec -any,
459+ hspec-discover -any,
460+ HUnit -any,
461+ mtl -any,
411− base-compat -any, haskeline >= 0.7.0.0, optparse-applicative -any,
462+ optparse-applicative -any,
412− boxes -any, HUnit -any, hspec -any, hspec-discover -any, stm -any, text -any,
463+ parsec -any,
464+ process -any,
465+ silently -any,
466+ stm -any,
467+ text -any,
468+ time -any,
469+ transformers -any,
470+ transformers-compat -any,
413− vector -any, utf8-string -any, silently -any
471+ utf8-string -any,
472+ vector -any
414 ghc-options: -Wall
473 ghc-options: -Wall
415 type: exitcode-stdio-1.0
474 type: exitcode-stdio-1.0
416 main-is: Main.hs
475 main-is: Main.hs
@@ -429,9 +488,5 @@ test-suite tests
429 Language.PureScript.Ide.RebuildSpec
488 Language.PureScript.Ide.RebuildSpec
430 Language.PureScript.Ide.ReexportsSpec
489 Language.PureScript.Ide.ReexportsSpec
431 Language.PureScript.IdeSpec
490 Language.PureScript.IdeSpec
432− PSCi.Completion
433− PSCi.Directive
434− PSCi.Module
435− PSCi.Types
436 buildable: True
491 buildable: True
437− hs-source-dirs: tests psci
492+ hs-source-dirs: tests
src/Language/PureScript/Interactive.hsnew file+288
@@ -0,0 +1,288 @@
1+{-# LANGUAGE DoAndIfThenElse #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
5+{-# LANGUAGE RecordWildCards #-}
6+{-# LANGUAGE TupleSections #-}
7+{-# LANGUAGE DataKinds #-}
8+
9+module Language.PureScript.Interactive
10+ ( handleCommand
11+ , module Interactive
12+
13+ -- TODO: remove these exports
14+ , make
15+ , runMake
16+ ) where
17+
18+import Prelude ()
19+import Prelude.Compat
20+
21+import Data.List (intercalate, nub, sort, find, foldl')
22+import qualified Data.Map as M
23+
24+import Control.Monad.IO.Class (MonadIO, liftIO)
25+import Control.Monad.State.Class
26+import Control.Monad.Reader.Class
27+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
28+import Control.Monad.Trans.State.Strict (StateT, runStateT)
29+import Control.Monad.Writer.Strict (Writer(), runWriter)
30+
31+import qualified Language.PureScript as P
32+import qualified Language.PureScript.Names as N
33+
34+import Language.PureScript.Interactive.Completion as Interactive
35+import Language.PureScript.Interactive.IO as Interactive
36+import Language.PureScript.Interactive.Message as Interactive
37+import Language.PureScript.Interactive.Module as Interactive
38+import Language.PureScript.Interactive.Parser as Interactive
39+import Language.PureScript.Interactive.Printer as Interactive
40+import Language.PureScript.Interactive.Types as Interactive
41+
42+import System.Exit
43+import System.Process (readProcessWithExitCode)
44+
45+-- | Pretty-print errors
46+printErrors :: MonadIO m => P.MultipleErrors -> m ()
47+printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors False
48+
49+-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
50+-- options and ignores the warning messages.
51+runMake :: P.Make a -> IO (Either P.MultipleErrors a)
52+runMake mk = fst <$> P.runMake P.defaultOptions mk
53+
54+-- | Rebuild a module, using the cached externs data for dependencies.
55+rebuild
56+ :: M.Map P.ModuleName FilePath
57+ -> [P.ExternsFile]
58+ -> P.Module
59+ -> P.Make (P.ExternsFile, P.Environment)
60+rebuild foreignFiles loadedExterns m = do
61+ externs <- P.rebuildModule buildActions loadedExterns m
62+ return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))
63+ where
64+ buildActions :: P.MakeActions P.Make
65+ buildActions = (P.buildMakeActions modulesDir
66+ filePathMap
67+ foreignFiles
68+ False) { P.progress = const (return ()) }
69+
70+ filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
71+ filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
72+
73+-- | Build the collection of modules from scratch. This is usually done on startup.
74+make
75+ :: M.Map P.ModuleName FilePath
76+ -> [P.Module]
77+ -> P.Make ([P.ExternsFile], P.Environment)
78+make foreignFiles ms = do
79+ externs <- P.make buildActions ms
80+ return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
81+ where
82+ buildActions :: P.MakeActions P.Make
83+ buildActions = (P.buildMakeActions modulesDir
84+ filePathMap
85+ foreignFiles
86+ False)
87+
88+ filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
89+ filePathMap = M.fromList $ map (\m -> (P.getModuleName m, Left P.RebuildAlways)) ms
90+
91+-- | Performs a PSCi command
92+handleCommand
93+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
94+ => Command
95+ -> m ()
96+handleCommand ShowHelp = liftIO $ putStrLn helpMessage
97+handleCommand ResetState = handleResetState
98+handleCommand (Expression val) = handleExpression val
99+handleCommand (Import im) = handleImport im
100+handleCommand (Decls l) = handleDecls l
101+handleCommand (TypeOf val) = handleTypeOf val
102+handleCommand (KindOf typ) = handleKindOf typ
103+handleCommand (BrowseModule moduleName) = handleBrowse moduleName
104+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
105+handleCommand (ShowInfo QueryImport) = handleShowImportedModules
106+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
107+
108+-- | Reset the application state
109+handleResetState
110+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
111+ => m ()
112+handleResetState = do
113+ modify $ updateImportedModules (const [])
114+ . updateLets (const [])
115+ files <- asks psciLoadedFiles
116+ e <- runExceptT $ do
117+ modules <- ExceptT . liftIO $ loadAllModules files
118+ foreignFiles <- asks psciForeignFiles
119+ (externs, _) <- ExceptT . liftIO . runMake . make foreignFiles . map snd $ modules
120+ return (map snd modules, externs)
121+ case e of
122+ Left errs -> printErrors errs
123+ Right (modules, externs) -> modify (updateLoadedExterns (const (zip modules externs)))
124+
125+-- | Takes a value expression and evaluates it with the current state.
126+--
127+-- TODO: factor out the Node process runner, so that we can use PSCi in other settings.
128+handleExpression
129+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
130+ => P.Expr
131+ -> m ()
132+handleExpression val = do
133+ st <- get
134+ let m = createTemporaryModule True st val
135+ foreignFiles <- asks psciForeignFiles
136+ nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags)
137+ e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m
138+ case e of
139+ Left errs -> printErrors errs
140+ Right _ -> do
141+ liftIO $ writeFile indexFile "require('$PSCI')['$main']();"
142+ process <- liftIO findNodeProcess
143+ result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
144+ case result of
145+ Just (ExitSuccess, out, _) -> liftIO $ putStrLn out
146+ Just (ExitFailure _, _, err) -> liftIO $ putStrLn err
147+ Nothing -> liftIO $ putStrLn "Couldn't find node.js"
148+
149+-- |
150+-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
151+-- restore the original environment.
152+--
153+handleDecls
154+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
155+ => [P.Declaration]
156+ -> m ()
157+handleDecls ds = do
158+ st <- gets (updateLets (++ ds))
159+ let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral []))
160+ foreignFiles <- asks psciForeignFiles
161+ e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m
162+ case e of
163+ Left err -> printErrors err
164+ Right _ -> put st
165+
166+-- | Show actual loaded modules in psci.
167+handleShowLoadedModules
168+ :: (MonadState PSCiState m, MonadIO m)
169+ => m ()
170+handleShowLoadedModules = do
171+ loadedModules <- gets psciLoadedExterns
172+ liftIO $ putStrLn (readModules loadedModules)
173+ where
174+ readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst)
175+
176+-- | Show the imported modules in psci.
177+handleShowImportedModules
178+ :: (MonadState PSCiState m, MonadIO m)
179+ => m ()
180+handleShowImportedModules = do
181+ PSCiState { psciImportedModules = importedModules } <- get
182+ liftIO $ showModules importedModules >>= putStrLn
183+ return ()
184+ where
185+ showModules = return . unlines . sort . map showModule
186+ showModule (mn, declType, asQ) =
187+ "import " ++ N.runModuleName mn ++ showDeclType declType ++
188+ foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ
189+
190+ showDeclType P.Implicit = ""
191+ showDeclType (P.Explicit refs) = refsList refs
192+ showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
193+ refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
194+
195+ showRef :: P.DeclarationRef -> String
196+ showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
197+ showRef (P.TypeOpRef op) = "type " ++ N.showOp op
198+ showRef (P.ValueRef ident) = N.runIdent ident
199+ showRef (P.ValueOpRef op) = N.showOp op
200+ showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn
201+ showRef (P.TypeInstanceRef ident) = N.runIdent ident
202+ showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
203+ showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
204+
205+ commaList :: [String] -> String
206+ commaList = intercalate ", "
207+
208+-- | Imports a module, preserving the initial state on failure.
209+handleImport
210+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
211+ => ImportedModule
212+ -> m ()
213+handleImport im = do
214+ st <- gets (updateImportedModules (im :))
215+ foreignFiles <- asks psciForeignFiles
216+ let m = createTemporaryModuleForImports st
217+ e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m
218+ case e of
219+ Left errs -> printErrors errs
220+ Right _ -> put st
221+
222+-- | Takes a value and prints its type
223+handleTypeOf
224+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
225+ => P.Expr
226+ -> m ()
227+handleTypeOf val = do
228+ st <- get
229+ foreignFiles <- asks psciForeignFiles
230+ let m = createTemporaryModule False st val
231+ e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m
232+ case e of
233+ Left errs -> printErrors errs
234+ Right (_, env') ->
235+ case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
236+ Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty
237+ Nothing -> liftIO $ putStrLn "Could not find type"
238+
239+-- | Takes a type and prints its kind
240+handleKindOf
241+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
242+ => P.Type
243+ -> m ()
244+handleKindOf typ = do
245+ st <- get
246+ foreignFiles <- asks psciForeignFiles
247+ let m = createTemporaryModuleForKind st typ
248+ mName = P.ModuleName [P.ProperName "$PSCI"]
249+ e <- liftIO . runMake $ rebuild foreignFiles (map snd (psciLoadedExterns st)) m
250+ case e of
251+ Left errs -> printErrors errs
252+ Right (_, env') ->
253+ case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
254+ Just (_, typ') -> do
255+ let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
256+ k = check (P.kindOf typ') chk
257+
258+ check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
259+ check sew = fst . runWriter . runExceptT . runStateT sew
260+ case k of
261+ Left err -> printErrors err
262+ Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind
263+ Nothing -> liftIO $ putStrLn "Could not find kind"
264+
265+-- | Browse a module and displays its signature
266+handleBrowse
267+ :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
268+ => P.ModuleName
269+ -> m ()
270+handleBrowse moduleName = do
271+ st <- get
272+ env <- asks psciEnvironment
273+ if isModInEnv moduleName st
274+ then liftIO . putStrLn $ printModuleSignatures moduleName env
275+ else case lookupUnQualifiedModName moduleName st of
276+ Just unQualifiedName ->
277+ if isModInEnv unQualifiedName st
278+ then liftIO . putStrLn $ printModuleSignatures unQualifiedName env
279+ else failNotInEnv moduleName
280+ Nothing ->
281+ failNotInEnv moduleName
282+ where
283+ isModInEnv modName =
284+ any ((== modName) . P.getModuleName . fst) . psciLoadedExterns
285+ failNotInEnv modName =
286+ liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."
287+ lookupUnQualifiedModName quaModName st =
288+ (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
psci/PSCi/Completion.hs → src/Language/PureScript/Interactive/Completion.hsrenamed+74−75
@@ -1,35 +1,89 @@
1{-# LANGUAGE DataKinds #-}
1{-# LANGUAGE DataKinds #-}
2
2
3−module PSCi.Completion where
3+module Language.PureScript.Interactive.Completion
4+ ( CompletionM
5+ , liftCompletionM
6+ , completion
7+ , completion'
8+ ) where
4
9
5−import Prelude ()
6import Prelude.Compat
10import Prelude.Compat
7
11
8−import Data.Maybe (mapMaybe)
9−import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)
10−import Data.Function (on)
11−
12−import Control.Arrow (second)
12+import Control.Arrow (second)
13+import Control.Monad.IO.Class (MonadIO(..))
14+import Control.Monad.State.Class (MonadState(..))
13−import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
15+import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
14−import Control.Monad.Trans.State.Strict
16+import Data.Function (on)
15−
17+import Data.List (nub, nubBy, isPrefixOf, sortBy, stripPrefix)
16−import System.Console.Haskeline
18+import Data.Maybe (mapMaybe)
17−
18import qualified Language.PureScript as P
19import qualified Language.PureScript as P
20+import qualified Language.PureScript.Interactive.Directive as D
21+import Language.PureScript.Interactive.Types
19import qualified Language.PureScript.Names as N
22import qualified Language.PureScript.Names as N
20−
23+import System.Console.Haskeline
21−import qualified PSCi.Directive as D
22−import PSCi.Types
23
24
24-- Completions may read the state, but not modify it.
25-- Completions may read the state, but not modify it.
25type CompletionM = ReaderT PSCiState IO
26type CompletionM = ReaderT PSCiState IO
26
27
27−-- Lift a `CompletionM` action to a `StateT PSCiState IO` one.
28+-- Lift a `CompletionM` action into a state monad.
28−liftCompletionM :: CompletionM a -> StateT PSCiState IO a
29+liftCompletionM
30+ :: (MonadState PSCiState m, MonadIO m)
31+ => CompletionM a
32+ -> m a
29−liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s)
33+liftCompletionM act = do
34+ st <- get
35+ liftIO $ runReaderT act st
30
36
31-- Haskeline completions
37-- Haskeline completions
32
38
39+-- | Loads module, function, and file completions.
40+completion
41+ :: (MonadState PSCiState m, MonadIO m)
42+ => CompletionFunc m
43+completion = liftCompletionM . completion'
44+
45+completion' :: CompletionFunc CompletionM
46+completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions
47+
48+-- | Callback for Haskeline's `completeWordWithPrev`.
49+-- Expects:
50+-- * Line contents to the left of the word, reversed
51+-- * Word to be completed
52+findCompletions :: String -> String -> CompletionM [Completion]
53+findCompletions prev word = do
54+ let ctx = completionContext (words (reverse prev)) word
55+ completions <- concat <$> traverse getCompletions ctx
56+ return $ sortBy directivesFirst completions
57+ where
58+ getCompletions :: CompletionContext -> CompletionM [Completion]
59+ getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion
60+
61+ getCompletion :: CompletionContext -> CompletionM [Either String Completion]
62+ getCompletion ctx =
63+ case ctx of
64+ CtxFilePath f -> map Right <$> listFiles f
65+ CtxModule -> map Left <$> getModuleNames
66+ CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)
67+ CtxType -> map Left <$> getTypeNames
68+ CtxFixed str -> return [Left str]
69+ CtxDirective d -> return (map Left (completeDirectives d))
70+
71+ completeDirectives :: String -> [String]
72+ completeDirectives = map (':' :) . D.directiveStringsFor
73+
74+ prefixedBy :: String -> String -> Maybe Completion
75+ prefixedBy w cand = if w `isPrefixOf` cand
76+ then Just (simpleCompletion cand)
77+ else Nothing
78+
79+ directivesFirst :: Completion -> Completion -> Ordering
80+ directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
81+ where
82+ go (':' : xs) (':' : ys) = compare xs ys
83+ go (':' : _) _ = LT
84+ go _ (':' : _) = GT
85+ go xs ys = compare xs ys
86+
33data CompletionContext
87data CompletionContext
34 = CtxDirective String
88 = CtxDirective String
35 | CtxFilePath String
89 | CtxFilePath String
@@ -39,15 +93,6 @@ data CompletionContext
39 | CtxFixed String
93 | CtxFixed String
40 deriving (Show, Read)
94 deriving (Show, Read)
41
95
42−-- |
43−-- Loads module, function, and file completions.
44−--
45−completion :: CompletionFunc (StateT PSCiState IO)
46−completion = liftCompletionM . completion'
47−
48−completion' :: CompletionFunc CompletionM
49−completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions
50−
51-- |
96-- |
52-- Decide what kind of completion we need based on input. This function expects
97-- Decide what kind of completion we need based on input. This function expects
53-- a list of complete words (to the left of the cursor) as the first argument,
98-- a list of complete words (to the left of the cursor) as the first argument,
@@ -74,8 +119,6 @@ completeDirective ws w =
74
119
75directiveArg :: String -> Directive -> [CompletionContext]
120directiveArg :: String -> Directive -> [CompletionContext]
76directiveArg _ Browse = [CtxModule]
121directiveArg _ Browse = [CtxModule]
77−directiveArg w Load = [CtxFilePath w]
78−directiveArg w Foreign = [CtxFilePath w]
79directiveArg _ Quit = []
122directiveArg _ Quit = []
80directiveArg _ Reset = []
123directiveArg _ Reset = []
81directiveArg _ Help = []
124directiveArg _ Help = []
@@ -95,44 +138,8 @@ headSatisfies p str =
95 (c:_) -> p c
138 (c:_) -> p c
96 _ -> False
139 _ -> False
97
140
98−-- | Callback for Haskeline's `completeWordWithPrev`.
99−-- Expects:
100−-- * Line contents to the left of the word, reversed
101−-- * Word to be completed
102−findCompletions :: String -> String -> CompletionM [Completion]
103−findCompletions prev word = do
104− let ctx = completionContext (words (reverse prev)) word
105− completions <- concat <$> traverse getCompletions ctx
106− return $ sortBy directivesFirst completions
107− where
108− getCompletions :: CompletionContext -> CompletionM [Completion]
109− getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion
110−
111− prefixedBy :: String -> String -> Maybe Completion
112− prefixedBy w cand = if w `isPrefixOf` cand
113− then Just (simpleCompletion cand)
114− else Nothing
115−
116−getCompletion :: CompletionContext -> CompletionM [Either String Completion]
117−getCompletion ctx =
118− case ctx of
119− CtxFilePath f -> map Right <$> listFiles f
120− CtxModule -> map Left <$> getModuleNames
121− CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)
122− CtxType -> map Left <$> getTypeNames
123− CtxFixed str -> return [Left str]
124− CtxDirective d -> return (map Left (completeDirectives d))
125−
126− where
127− completeDirectives :: String -> [String]
128− completeDirectives = map (':' :) . D.directiveStringsFor
129−
130−
131getLoadedModules :: CompletionM [P.Module]
141getLoadedModules :: CompletionM [P.Module]
132−getLoadedModules = asks (map snd . psciLoadedModules)
142+getLoadedModules = asks (map fst . psciLoadedExterns)
133−
134−getImportedModules :: CompletionM [ImportedModule]
135−getImportedModules = asks psciImportedModules
136
143
137getModuleNames :: CompletionM [String]
144getModuleNames :: CompletionM [String]
138getModuleNames = moduleNames <$> getLoadedModules
145getModuleNames = moduleNames <$> getLoadedModules
@@ -212,12 +219,4 @@ dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
212 go _ = []
219 go _ = []
213
220
214moduleNames :: [P.Module] -> [String]
221moduleNames :: [P.Module] -> [String]
215−moduleNames ms = nub [P.runModuleName moduleName | P.Module _ _ moduleName _ _ <- ms]
222+moduleNames = nub . map (P.runModuleName . P.getModuleName)
216−
217−directivesFirst :: Completion -> Completion -> Ordering
218−directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
219− where
220− go (':' : xs) (':' : ys) = compare xs ys
221− go (':' : _) _ = LT
222− go _ (':' : _) = GT
223− go xs ys = compare xs ys
psci/PSCi/Directive.hs → src/Language/PureScript/Interactive/Directive.hsrenamed+2−8
@@ -1,17 +1,15 @@
1-- |
1-- |
2-- Directives for PSCI.
2-- Directives for PSCI.
3--
3--
4−module PSCi.Directive where
4+module Language.PureScript.Interactive.Directive where
5
5
6−import Prelude ()
7import Prelude.Compat
6import Prelude.Compat
8
7
9−
10import Data.Maybe (fromJust, listToMaybe)
8import Data.Maybe (fromJust, listToMaybe)
11import Data.List (isPrefixOf)
9import Data.List (isPrefixOf)
12import Data.Tuple (swap)
10import Data.Tuple (swap)
13
11
14−import PSCi.Types
12+import Language.PureScript.Interactive.Types
15
13
16-- |
14-- |
17-- List of all avaliable directives.
15-- List of all avaliable directives.
@@ -29,8 +27,6 @@ directiveStrings =
29 , (Quit , ["quit"])
27 , (Quit , ["quit"])
30 , (Reset , ["reset"])
28 , (Reset , ["reset"])
31 , (Browse , ["browse"])
29 , (Browse , ["browse"])
32− , (Load , ["load", "module"])
33− , (Foreign, ["foreign"])
34 , (Type , ["type"])
30 , (Type , ["type"])
35 , (Kind , ["kind"])
31 , (Kind , ["kind"])
36 , (Show , ["show"])
32 , (Show , ["show"])
@@ -97,8 +93,6 @@ help =
97 , (Quit, "", "Quit PSCi")
93 , (Quit, "", "Quit PSCi")
98 , (Reset, "", "Discard all imported modules and declared bindings")
94 , (Reset, "", "Discard all imported modules and declared bindings")
99 , (Browse, "<module>", "See all functions in <module>")
95 , (Browse, "<module>", "See all functions in <module>")
100− , (Load, "<file>", "Load <file> for importing")
101− , (Foreign, "<file>", "Load foreign module <file>")
102 , (Type, "<expr>", "Show the type of <expr>")
96 , (Type, "<expr>", "Show the type of <expr>")
103 , (Kind, "<type>", "Show the kind of <type>")
97 , (Kind, "<type>", "Show the kind of <type>")
104 , (Show, "import", "Show all imported modules")
98 , (Show, "import", "Show all imported modules")
psci/PSCi/IO.hs → src/Language/PureScript/Interactive/IO.hsrenamed+4−17
@@ -1,14 +1,11 @@
1−module PSCi.IO where
1+module Language.PureScript.Interactive.IO where
2
2
3−import Prelude ()
4import Prelude.Compat
3import Prelude.Compat
5
4
6−import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable, doesFileExist)
7−import System.FilePath (takeDirectory, (</>), isPathSeparator)
8−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
9import Control.Monad (msum)
5import Control.Monad (msum)
10−import Control.Monad.IO.Class (MonadIO, liftIO)
6+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
11−import System.Console.Haskeline (outputStrLn, InputT)
7+import System.Directory (createDirectoryIfMissing, getHomeDirectory, findExecutable)
8+import System.FilePath (takeDirectory, (</>), isPathSeparator)
12
9
13mkdirp :: FilePath -> IO ()
10mkdirp :: FilePath -> IO ()
14mkdirp = createDirectoryIfMissing True . takeDirectory
11mkdirp = createDirectoryIfMissing True . takeDirectory
@@ -36,19 +33,9 @@ getHistoryFilename = do
36 mkdirp filename
33 mkdirp filename
37 return filename
34 return filename
38
35
39−
40-- |
36-- |
41-- Expands tilde in path.
37-- Expands tilde in path.
42--
38--
43expandTilde :: FilePath -> IO FilePath
39expandTilde :: FilePath -> IO FilePath
44expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
40expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
45expandTilde p = return p
41expandTilde p = return p
46−
47−
48−whenFileExists :: MonadIO m => FilePath -> (FilePath -> InputT m ()) -> InputT m ()
49−whenFileExists filePath f = do
50− absPath <- liftIO $ expandTilde filePath
51− exists <- liftIO $ doesFileExist absPath
52− if exists
53− then f absPath
54− else outputStrLn $ "Couldn't locate: " ++ filePath
src/Language/PureScript/Interactive/Message.hsnew file+52
@@ -0,0 +1,52 @@
1+module Language.PureScript.Interactive.Message where
2+
3+import Prelude.Compat
4+
5+import Data.List (intercalate)
6+import Data.Version (showVersion)
7+import qualified Paths_purescript as Paths
8+import qualified Language.PureScript.Interactive.Directive as D
9+import Language.PureScript.Interactive.Types
10+
11+-- Messages
12+
13+-- | The help message.
14+helpMessage :: String
15+helpMessage = "The following commands are available:\n\n " ++
16+ intercalate "\n " (map line D.help) ++
17+ "\n\n" ++ extraHelp
18+ where
19+ line :: (Directive, String, String) -> String
20+ line (dir, arg, desc) =
21+ let cmd = ':' : D.stringFor dir
22+ in unwords [ cmd
23+ , replicate (11 - length cmd) ' '
24+ , arg
25+ , replicate (11 - length arg) ' '
26+ , desc
27+ ]
28+
29+ extraHelp =
30+ "Further information is available on the PureScript wiki:\n" ++
31+ " --> https://github.com/purescript/purescript/wiki/psci"
32+
33+-- | The welcome prologue.
34+prologueMessage :: String
35+prologueMessage = unlines
36+ [ "PSCi, version " ++ showVersion Paths.version
37+ , "Type :? for help"
38+ ]
39+
40+supportModuleMessage :: String
41+supportModuleMessage = unlines
42+ [ "PSCi requires the purescript-psci-support package to be installed."
43+ , "You can install it using Bower as follows:"
44+ , ""
45+ , " bower i purescript-psci-support --save"
46+ , ""
47+ , "For help getting started, visit http://wiki.purescript.org/PSCi"
48+ ]
49+
50+-- | The quit message.
51+quitMessage :: String
52+quitMessage = "See ya!"
psci/PSCi/Module.hs → src/Language/PureScript/Interactive/Module.hsrenamed+13−35
@@ -1,45 +1,24 @@
1−module PSCi.Module where
1+module Language.PureScript.Interactive.Module where
2
2
3−import Prelude ()
4−import Prelude.Compat
3+import Prelude.Compat
5
4
5+import Control.Monad
6import qualified Language.PureScript as P
6import qualified Language.PureScript as P
7−import PSCi.Types
7+import Language.PureScript.Interactive.Types
8−import System.FilePath (pathSeparator)
8+import System.FilePath (pathSeparator)
9−import System.IO.UTF8 (readUTF8File)
9+import System.IO.UTF8 (readUTF8File)
10−import Control.Monad
10+
11+-- * Support Module
11
12
12-- | The name of the PSCI support module
13-- | The name of the PSCI support module
13supportModuleName :: P.ModuleName
14supportModuleName :: P.ModuleName
14−supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
15+supportModuleName = P.moduleNameFromString "PSCI.Support"
15
16
16−-- | Support module, contains code to evaluate terms
17+-- | Checks if the Console module is defined
17−supportModule :: P.Module
18+supportModuleIsDefined :: [P.Module] -> Bool
18−supportModule =
19+supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)
19− case P.parseModulesFromFiles id [("", code)] of
20− Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
21− _ -> P.internalError "Support module could not be parsed"
22− where
23− code :: String
24− code = unlines
25− [ "module S where"
26− , ""
27− , "import Prelude"
28− , "import Control.Monad.Eff (Eff)"
29− , "import Control.Monad.Eff.Console (CONSOLE, logShow)"
30− , "import Control.Monad.Eff.Unsafe (unsafeInterleaveEff)"
31− , ""
32− , "class Eval a where"
33− , " eval :: a -> Eff (console :: CONSOLE) Unit"
34− , ""
35− , "instance evalShow :: (Show a) => Eval a where"
36− , " eval = logShow"
37− , ""
38− , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
39− , " eval x = unsafeInterleaveEff x >>= eval"
40− ]
41
20
42−-- Module Management
21+-- * Module Management
43
22
44-- |
23-- |
45-- Loads a file for use with imports.
24-- Loads a file for use with imports.
@@ -59,7 +38,6 @@ loadAllModules files = do
59 return (filename, content)
38 return (filename, content)
60 return $ P.parseModulesFromFiles id filesAndContent
39 return $ P.parseModulesFromFiles id filesAndContent
61
40
62−
63-- |
41-- |
64-- Makes a volatile module to execute the current expression.
42-- Makes a volatile module to execute the current expression.
65--
43--
psci/PSCi/Parser.hs → src/Language/PureScript/Interactive/Parser.hsrenamed+8−14
@@ -1,23 +1,19 @@
1-- |
1-- |
2-- Parser for PSCI.
2-- Parser for PSCI.
3--
3--
4−module PSCi.Parser
4+module Language.PureScript.Interactive.Parser
5 ( parseCommand
5 ( parseCommand
6 ) where
6 ) where
7
7
8−import Prelude ()
9−import Prelude.Compat hiding (lex)
8+import Prelude.Compat hiding (lex)
10−
11−import Data.Char (isSpace)
12−import Data.List (intercalate)
13−
14−import Text.Parsec hiding ((<|>))
15
9
10+import Data.Char (isSpace)
11+import Data.List (intercalate)
12+import Text.Parsec hiding ((<|>))
16import qualified Language.PureScript as P
13import qualified Language.PureScript as P
14+import qualified Language.PureScript.Interactive.Directive as D
15+import Language.PureScript.Interactive.Types
17−import Language.PureScript.Parser.Common (mark, same)
16+import Language.PureScript.Parser.Common (mark, same)
18−
19−import qualified PSCi.Directive as D
20−import PSCi.Types
21
17
22-- |
18-- |
23-- Parses PSCI metacommands or expressions input from the user.
19-- Parses PSCI metacommands or expressions input from the user.
@@ -67,8 +63,6 @@ parseDirective cmd =
67 Quit -> return QuitPSCi
63 Quit -> return QuitPSCi
68 Reset -> return ResetState
64 Reset -> return ResetState
69 Browse -> BrowseModule <$> parseRest P.moduleName arg
65 Browse -> BrowseModule <$> parseRest P.moduleName arg
70− Load -> return $ LoadFile (trim arg)
71− Foreign -> return $ LoadForeign (trim arg)
72 Show -> ShowInfo <$> parseReplQuery' (trim arg)
66 Show -> ShowInfo <$> parseReplQuery' (trim arg)
73 Type -> TypeOf <$> parseRest P.parseValue arg
67 Type -> TypeOf <$> parseRest P.parseValue arg
74 Kind -> KindOf <$> parseRest P.parseType arg
68 Kind -> KindOf <$> parseRest P.parseType arg
psci/PSCi/Printer.hs → src/Language/PureScript/Interactive/Printer.hsrenamed+7−14
@@ -1,25 +1,22 @@
1{-# LANGUAGE RecordWildCards #-}
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DataKinds #-}
3
3
4−module PSCi.Printer where
4+module Language.PureScript.Interactive.Printer where
5
5
6−import Prelude ()
7−import Prelude.Compat
6+import Prelude.Compat
8
7
8+import Data.List (intersperse)
9+import qualified Data.Map as M
10+import Data.Maybe (mapMaybe)
9import qualified Language.PureScript as P
11import qualified Language.PureScript as P
10import qualified Text.PrettyPrint.Boxes as Box
12import qualified Text.PrettyPrint.Boxes as Box
11−import qualified Data.Map as M
12−import System.Console.Haskeline
13−import Data.Maybe (mapMaybe)
14−import Data.List (intersperse)
15−import Control.Monad.IO.Class (MonadIO)
16
13
17-- Printers
14-- Printers
18
15
19-- |
16-- |
20-- Pretty print a module's signatures
17-- Pretty print a module's signatures
21--
18--
22−printModuleSignatures :: MonadIO m => P.ModuleName -> P.Environment -> InputT m ()
19+printModuleSignatures :: P.ModuleName -> P.Environment -> String
23printModuleSignatures moduleName (P.Environment {..}) =
20printModuleSignatures moduleName (P.Environment {..}) =
24 -- get relevant components of a module from environment
21 -- get relevant components of a module from environment
25 let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
22 let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
@@ -28,7 +25,7 @@ printModuleSignatures moduleName (P.Environment {..}) =
28
25
29 in
26 in
30 -- print each component
27 -- print each component
31− (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
28+ (unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
32 [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
29 [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
33 , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
30 , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
34 , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
31 , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
@@ -125,7 +122,3 @@ printModuleSignatures moduleName (P.Environment {..}) =
125 mapFirstRest f g (x:xs) = f x : map g xs
122 mapFirstRest f g (x:xs) = f x : map g xs
126
123
127 trimEnd = reverse . dropWhile (== ' ') . reverse
124 trimEnd = reverse . dropWhile (== ' ') . reverse
128−
129−-- | Pretty-print errors
130−printErrors :: MonadIO m => P.MultipleErrors -> InputT m ()
131−printErrors = outputStrLn . P.prettyPrintMultipleErrors False
psci/PSCi/Types.hs → src/Language/PureScript/Interactive/Types.hsrenamed+28−86
@@ -1,71 +1,37 @@
1-- |
1-- |
2-- Type declarations and associated basic functions for PSCI.
2-- Type declarations and associated basic functions for PSCI.
3--
3--
4−module PSCi.Types where
4+module Language.PureScript.Interactive.Types where
5
5
6−import Prelude ()
7import Prelude.Compat
6import Prelude.Compat
8
7
9−import Control.Arrow (second)
10−import Data.Map (Map)
8+import Data.Map (Map)
11−import qualified Data.Map as Map
12import qualified Language.PureScript as P
9import qualified Language.PureScript as P
13
10
14−data PSCiOptions = PSCiOptions
11+-- | The PSCI configuration.
15− { psciMultiLineMode :: Bool
12+--
16− , psciInputFile :: [FilePath]
13+-- These configuration values do not change during execution.
17− , psciForeignInputFiles :: [FilePath]
14+--
18− , psciInputNodeFlags :: [String]
15+data PSCiConfig = PSCiConfig
19− }
16+ { psciLoadedFiles :: [FilePath]
17+ , psciForeignFiles :: Map P.ModuleName FilePath
18+ , psciNodeFlags :: [String]
19+ , psciEnvironment :: P.Environment
20+ } deriving Show
20
21
21−-- |
22−-- The PSCI state.
22+-- | The PSCI state.
23+--
23-- Holds a list of imported modules, loaded files, and partial let bindings.
24-- Holds a list of imported modules, loaded files, and partial let bindings.
24-- The let bindings are partial,
25-- The let bindings are partial,
25-- because it makes more sense to apply the binding to the final evaluated expression.
26-- because it makes more sense to apply the binding to the final evaluated expression.
26−--
27data PSCiState = PSCiState
27data PSCiState = PSCiState
28 { psciImportedModules :: [ImportedModule]
28 { psciImportedModules :: [ImportedModule]
29− , _psciLoadedModules :: Map FilePath [P.Module]
30− , psciForeignFiles :: Map P.ModuleName FilePath
31 , psciLetBindings :: [P.Declaration]
29 , psciLetBindings :: [P.Declaration]
32− , psciNodeFlags :: [String]
30+ , psciLoadedExterns :: [(P.Module, P.ExternsFile)]
33− }
31+ } deriving Show
34
32
35initialPSCiState :: PSCiState
33initialPSCiState :: PSCiState
36−initialPSCiState =
34+initialPSCiState = PSCiState [] [] []
37− PSCiState [] Map.empty Map.empty [] []
38−
39−mkPSCiState :: [ImportedModule]
40− -> [(FilePath, P.Module)]
41− -> Map P.ModuleName FilePath
42− -> [P.Declaration]
43− -> [String]
44− -> PSCiState
45−mkPSCiState imported loaded foreigns lets nodeFlags =
46− (initialPSCiState
47− |> each imported updateImportedModules
48− |> updateModules loaded)
49− { psciForeignFiles = foreigns
50− , psciLetBindings = lets
51− , psciNodeFlags = nodeFlags
52− }
53− where
54− x |> f = f x
55− each xs f st = foldl (flip f) st xs
56−
57−-- Public psci state accessors
58−
59−-- | Get the imported filenames as a list.
60−psciImportedFilenames :: PSCiState -> [FilePath]
61−psciImportedFilenames = Map.keys . _psciLoadedModules
62−
63−-- | Get the loaded modules as a list.
64−psciLoadedModules :: PSCiState -> [(FilePath, P.Module)]
65−psciLoadedModules = collect . Map.toList . _psciLoadedModules
66− where
67− collect :: [(k, [v])] -> [(k, v)]
68− collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
69
35
70-- | All of the data that is contained by an ImportDeclaration in the AST.
36-- | All of the data that is contained by an ImportDeclaration in the AST.
71-- That is:
37-- That is:
@@ -89,35 +55,21 @@ allImportsOf m (PSCiState{psciImportedModules = is}) =
89 name = P.getModuleName m
55 name = P.getModuleName m
90 isImportOfThis (name', _, _) = name == name'
56 isImportOfThis (name', _, _) = name == name'
91
57
92−-- State helpers
58+-- * State helpers
93
59
94−-- |
95−-- Updates the state to have more imported modules.
60+-- | Updates the imported modules in the state record.
96−--
97−updateImportedModules :: ImportedModule -> PSCiState -> PSCiState
61+updateImportedModules :: ([ImportedModule] -> [ImportedModule]) -> PSCiState -> PSCiState
98−updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
62+updateImportedModules f st = st { psciImportedModules = f (psciImportedModules st) }
99
63
100−-- |
64+-- | Updates the loaded externs files in the state record.
101−-- Updates the state to have more loaded modules (available for import, but
102−-- not necessarily imported).
103−--
104−updateModules :: [(FilePath, P.Module)] -> PSCiState -> PSCiState
65+updateLoadedExterns :: ([(P.Module, P.ExternsFile)] -> [(P.Module, P.ExternsFile)]) -> PSCiState -> PSCiState
105−updateModules modules st =
66+updateLoadedExterns f st = st { psciLoadedExterns = f (psciLoadedExterns st) }
106− st { _psciLoadedModules = Map.union (go modules) (_psciLoadedModules st) }
107− where
108− go = Map.fromListWith (++) . map (second (:[]))
109
67
110−-- |
111−-- Updates the state to have more let bindings.
68+-- | Updates the let bindings in the state record.
112−--
113−updateLets :: [P.Declaration] -> PSCiState -> PSCiState
69+updateLets :: ([P.Declaration] -> [P.Declaration]) -> PSCiState -> PSCiState
114−updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
70+updateLets f st = st { psciLetBindings = f (psciLetBindings st) }
115
71
116−-- |
72+-- * Commands
117−-- Updates the state to have more let bindings.
118−--
119−updateForeignFiles :: Map P.ModuleName FilePath -> PSCiState -> PSCiState
120−updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `Map.union` fs }
121
73
122-- |
74-- |
123-- Valid Meta-commands for PSCI
75-- Valid Meta-commands for PSCI
@@ -140,14 +92,6 @@ data Command
140 --
92 --
141 | BrowseModule P.ModuleName
93 | BrowseModule P.ModuleName
142 -- |
94 -- |
143− -- Load a file for use with importing
144− --
145− | LoadFile FilePath
146− -- |
147− -- Load a foreign module
148− --
149− | LoadForeign FilePath
150− -- |
151 -- Exit PSCI
95 -- Exit PSCI
152 --
96 --
153 | QuitPSCi
97 | QuitPSCi
@@ -198,8 +142,6 @@ data Directive
198 | Quit
142 | Quit
199 | Reset
143 | Reset
200 | Browse
144 | Browse
201− | Load
202− | Foreign
203 | Type
145 | Type
204 | Kind
146 | Kind
205 | Show
147 | Show
src/Language/PureScript/Make.hs+7−3
@@ -14,6 +14,8 @@ module Language.PureScript.Make
14 -- * Implementation of Make API using files on disk
14 -- * Implementation of Make API using files on disk
15 , Make(..)
15 , Make(..)
16 , runMake
16 , runMake
17+ , makeIO
18+ , readTextFile
17 , buildMakeActions
19 , buildMakeActions
18 ) where
20 ) where
19
21
@@ -290,6 +292,11 @@ makeIO f io = do
290 e <- liftIO $ tryIOError io
292 e <- liftIO $ tryIOError io
291 either (throwError . singleError . f) return e
293 either (throwError . singleError . f) return e
292
294
295+-- | Read a text file in the 'Make' monad, capturing any errors using the
296+-- 'MonadError' instance.
297+readTextFile :: FilePath -> Make String
298+readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
299+
293-- Traverse (Either e) instance (base 4.7)
300-- Traverse (Either e) instance (base 4.7)
294traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
301traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
295traverseEither _ (Left x) = pure (Left x)
302traverseEither _ (Left x) = pure (Left x)
@@ -400,9 +407,6 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
400 progress :: ProgressMessage -> Make ()
407 progress :: ProgressMessage -> Make ()
401 progress = liftIO . putStrLn . renderProgressMessage
408 progress = liftIO . putStrLn . renderProgressMessage
402
409
403−readTextFile :: FilePath -> Make String
404−readTextFile path = makeIO (const (ErrorMessage [] $ CannotReadFile path)) $ readUTF8File path
405−
406-- |
410-- |
407-- Check that the declarations in a given PureScript module match with those
411-- Check that the declarations in a given PureScript module match with those
408-- in its corresponding foreign module.
412-- in its corresponding foreign module.
tests/TestPsci.hs+11−21
@@ -6,10 +6,8 @@ module TestPsci where
6import Prelude ()
6import Prelude ()
7import Prelude.Compat
7import Prelude.Compat
8
8
9−import Control.Monad.Trans.State.Strict (runStateT)
9+import Control.Monad.Trans.State.Strict (evalStateT)
10−import Control.Monad (when, forM)
10+import Control.Monad (when)
11−import Control.Monad.Writer.Strict (runWriterT)
12−import Control.Monad.Trans.Except (runExceptT)
13
11
14import Data.List (sort)
12import Data.List (sort)
15
13
@@ -17,16 +15,15 @@ import System.Exit (exitFailure)
17import System.Console.Haskeline
15import System.Console.Haskeline
18import System.FilePath ((</>))
16import System.FilePath ((</>))
19import System.Directory (getCurrentDirectory)
17import System.Directory (getCurrentDirectory)
20−import System.IO.UTF8 (readUTF8File)
21import qualified System.FilePath.Glob as Glob
18import qualified System.FilePath.Glob as Glob
22
19
23import Test.HUnit
20import Test.HUnit
24
21
25import qualified Language.PureScript as P
22import qualified Language.PureScript as P
26
23
27−import PSCi.Module (loadAllModules)
24+import Language.PureScript.Interactive.Module (loadAllModules)
28−import PSCi.Completion
25+import Language.PureScript.Interactive.Completion
29−import PSCi.Types
26+import Language.PureScript.Interactive.Types
30
27
31import TestUtils (supportModules)
28import TestUtils (supportModules)
32
29
@@ -49,11 +46,10 @@ completionTests =
49completionTestData :: [(String, [String])]
46completionTestData :: [(String, [String])]
50completionTestData =
47completionTestData =
51 -- basic directives
48 -- basic directives
52− [ (":h", [":help"])
49+ [ (":h", [":help"])
53 , (":re", [":reset"])
50 , (":re", [":reset"])
54− , (":q", [":quit"])
51+ , (":q", [":quit"])
55− , (":mo", [":module"])
56− , (":b", [":browse"])
52+ , (":b", [":browse"])
57
53
58 -- :browse should complete module names
54 -- :browse should complete module names
59 , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
55 , (":b Control.Monad.E", map (":b Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
@@ -63,10 +59,6 @@ completionTestData =
63 , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
59 , ("import Control.Monad.E", map ("import Control.Monad.Eff" ++) ["", ".Unsafe", ".Class", ".Console"])
64 , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
60 , ("import Control.Monad.Eff.", map ("import Control.Monad.Eff" ++) [".Unsafe", ".Class", ".Console"])
65
61
66− -- :load, :module should complete file paths
67− , (":l tests/support/psci/", [":l tests/support/psci/Sample.purs"])
68− , (":module tests/support/psci/", [":module tests/support/psci/Sample.purs"])
69−
70 -- :quit, :help, :reset should not complete
62 -- :quit, :help, :reset should not complete
71 , (":help ", [])
63 , (":help ", [])
72 , (":quit ", [])
64 , (":quit ", [])
@@ -122,7 +114,7 @@ assertCompletedOk (line, expecteds) = do
122runCM :: CompletionM a -> IO a
114runCM :: CompletionM a -> IO a
123runCM act = do
115runCM act = do
124 psciState <- getPSCiState
116 psciState <- getPSCiState
125− fmap fst (runStateT (liftCompletionM act) psciState)
117+ evalStateT (liftCompletionM act) psciState
126
118
127getPSCiState :: IO PSCiState
119getPSCiState :: IO PSCiState
128getPSCiState = do
120getPSCiState = do
@@ -130,17 +122,15 @@ getPSCiState = do
130 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
122 let supportDir = cwd </> "tests" </> "support" </> "bower_components"
131 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
123 let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir
132 pursFiles <- supportFiles "purs"
124 pursFiles <- supportFiles "purs"
133− jsFiles <- supportFiles "js"
134
125
135 modulesOrFirstError <- loadAllModules pursFiles
126 modulesOrFirstError <- loadAllModules pursFiles
136− foreignFiles <- forM jsFiles (\f -> (f,) <$> readUTF8File f)
137− Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
138 case modulesOrFirstError of
127 case modulesOrFirstError of
139 Left err ->
128 Left err ->
140 print err >> exitFailure
129 print err >> exitFailure
141 Right modules ->
130 Right modules ->
142 let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
131 let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
132+ dummyExterns = P.internalError "TestPsci: dummyExterns should not be used"
143− in return (mkPSCiState imports modules foreigns [] [])
133+ in return (PSCiState imports [] (zip (map snd modules) (repeat dummyExterns)))
144
134
145controlMonadSTasST :: ImportedModule
135controlMonadSTasST :: ImportedModule
146controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
136controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))