@@ -7,16 +7,14 @@
77-- |
88-- PureScript Compiler Interactive.
99--
10−module PSCi where
10+module PSCi (runPSCi) where
1111
1212import Prelude ()
1313import Prelude.Compat
1414
1515import Data.Foldable (traverse_)
16−import Data.Maybe (mapMaybe)
17−import Data.List (intersperse, intercalate, nub, sort, find)
16+import Data.List (intercalate, nub, sort, find)
1817import Data.Tuple (swap)
19−import Data.Version (showVersion)
2018import qualified Data.Map as M
2119
2220import Control.Arrow (first)
@@ -24,102 +22,87 @@ import Control.Monad
2422import Control.Monad.Error.Class (MonadError(..))
2523import Control.Monad.Trans.Class
2624import Control.Monad.Trans.Except (ExceptT(), runExceptT)
27−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
2825import Control.Monad.Trans.State.Strict
2926import Control.Monad.IO.Class (liftIO)
3027import Control.Monad.Writer.Strict (Writer(), runWriter)
3128
32−import Options.Applicative as Opts
33−
3429import System.Console.Haskeline
35−import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
30+import System.Directory (doesFileExist, getHomeDirectory, getCurrentDirectory)
3631import System.Exit
37−import System.FilePath (pathSeparator, (</>), isPathSeparator)
32+import System.FilePath ((</>))
3833import System.FilePath.Glob (glob)
3934import System.Process (readProcessWithExitCode)
4035import System.IO.Error (tryIOError)
41−import qualified Text.PrettyPrint.Boxes as Box
4236
4337import qualified Language.PureScript as P
4438import qualified Language.PureScript.Names as N
45−import qualified Paths_purescript as Paths
4639
47−import qualified PSCi.Directive as D
4840import PSCi.Completion (completion)
49−import PSCi.IO (mkdirp)
5041import PSCi.Parser (parseCommand)
42+import PSCi.Option
5143import PSCi.Types
52−
53−-- | The name of the PSCI support module
54−supportModuleName :: P.ModuleName
55−supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
56−
57−-- | Support module, contains code to evaluate terms
58−supportModule :: P.Module
59−supportModule =
60− case P.parseModulesFromFiles id [("", code)] of
61− Right [(_, P.Module ss cs _ ds exps)] -> P.Module ss cs supportModuleName ds exps
62− _ -> P.internalError "Support module could not be parsed"
63− where
64− code :: String
65− code = unlines
66− [ "module S where"
67− , ""
68− , "import Prelude"
69− , "import Control.Monad.Eff"
70− , "import Control.Monad.Eff.Console"
71− , "import Control.Monad.Eff.Unsafe"
72− , ""
73− , "class Eval a where"
74− , " eval :: a -> Eff (console :: CONSOLE) Unit"
75− , ""
76− , "instance evalShow :: (Show a) => Eval a where"
77− , " eval = print"
78− , ""
79− , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
80− , " eval x = unsafeInterleaveEff x >>= eval"
81− ]
82−
83−-- File helpers
84−
85−onFirstFileMatching :: Monad m => (b -> m (Maybe a)) -> [b] -> m (Maybe a)
86−onFirstFileMatching f pathVariants = runMaybeT . msum $ map (MaybeT . f) pathVariants
44+import PSCi.Message
45+import PSCi.IO
46+import PSCi.Printer
47+import PSCi.Module
8748
8849-- |
89−-- Locates the node executable.
90−-- Checks for either @nodejs@ or @node@.
50+-- PSCI monad
9151--
92−findNodeProcess :: IO (Maybe String)
93−findNodeProcess = onFirstFileMatching findExecutable names
94− where names = ["nodejs", "node"]
52+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
9553
96−-- |
97−-- Grabs the filename where the history is stored.
98−--
99−getHistoryFilename :: IO FilePath
100−getHistoryFilename = do
101− home <- getHomeDirectory
102− let filename = home </> ".purescript" </> "psci_history"
103− mkdirp filename
104− return filename
54+psciIO :: IO a -> PSCI a
55+psciIO io = PSCI . lift $ lift io
10556
10657-- |
107−-- Loads a file for use with imports.
58+-- The runner
10859--
109−loadModule :: FilePath -> IO (Either String [P.Module])
110−loadModule filename = do
111− content <- readFile filename
112− return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
60+runPSCi :: IO ()
61+runPSCi = getOpt >>= loop
11362
11463-- |
115−-- Load all modules.
64+-- The PSCI main loop.
11665--
117−loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
118−loadAllModules files = do
119− filesAndContent <- forM files $ \filename -> do
120− content <- readFile filename
121− return (filename, content)
122− return $ P.parseModulesFromFiles id filesAndContent
66+loop :: PSCiOptions -> IO ()
67+loop PSCiOptions{..} = do
68+ config <- loadUserConfig
69+ inputFiles <- concat <$> traverse glob psciInputFile
70+ foreignFiles <- concat <$> traverse glob psciForeignInputFiles
71+ modulesOrFirstError <- loadAllModules inputFiles
72+ case modulesOrFirstError of
73+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
74+ Right modules -> do
75+ historyFilename <- getHistoryFilename
76+ let settings = defaultSettings { historyFile = Just historyFilename }
77+ foreignsOrError <- runMake $ do
78+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
79+ P.parseForeignModulesFromFiles foreignFilesContent
80+ case foreignsOrError of
81+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
82+ Right foreigns ->
83+ flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
84+ outputStrLn prologueMessage
85+ traverse_ (traverse_ (runPSCI . handleCommand)) config
86+ modules' <- lift $ gets psciLoadedModules
87+ unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
88+ [ "PSCi requires the purescript-console module to be installed."
89+ , "For help getting started, visit http://wiki.purescript.org/PSCi"
90+ ]
91+ go
92+ where
93+ go :: InputT (StateT PSCiState IO) ()
94+ go = do
95+ c <- getCommand (not psciMultiLineMode)
96+ case c of
97+ Left err -> outputStrLn err >> go
98+ Right Nothing -> go
99+ Right (Just QuitPSCi) -> outputStrLn quitMessage
100+ Right (Just c') -> do
101+ handleInterrupt (outputStrLn "Interrupted.")
102+ (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
103+ go
104+
105+-- Compile the module
123106
124107-- |
125108-- Load all modules, updating the application state
@@ -129,116 +112,9 @@ loadAllImportedModules = do
129112 files <- PSCI . lift $ fmap psciImportedFilenames get
130113 modulesOrFirstError <- psciIO $ loadAllModules files
131114 case modulesOrFirstError of
132− Left errs -> printErrors errs
115+ Left errs -> PSCI $ printErrors errs
133116 Right modules -> PSCI . lift . modify $ updateModules modules
134117
135−-- |
136−-- Expands tilde in path.
137−--
138−expandTilde :: FilePath -> IO FilePath
139−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
140−expandTilde p = return p
141−
142−-- Messages
143−
144−-- |
145−-- The help message.
146−--
147−helpMessage :: String
148−helpMessage = "The following commands are available:\n\n " ++
149− intercalate "\n " (map line D.help) ++
150− "\n\n" ++ extraHelp
151− where
152− line :: (Directive, String, String) -> String
153− line (dir, arg, desc) =
154− let cmd = ':' : D.stringFor dir
155− in unwords [ cmd
156− , replicate (11 - length cmd) ' '
157− , arg
158− , replicate (11 - length arg) ' '
159− , desc
160− ]
161−
162− extraHelp =
163− "Further information is available on the PureScript wiki:\n" ++
164− " --> https://github.com/purescript/purescript/wiki/psci"
165−
166−
167−-- |
168−-- The welcome prologue.
169−--
170−prologueMessage :: String
171−prologueMessage = intercalate "\n"
172− [ " ____ ____ _ _ "
173− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
174− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
175− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
176− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
177− , " |_| "
178− , ""
179− , ":? shows help"
180− ]
181−
182−-- |
183−-- The quit message.
184−--
185−quitMessage :: String
186−quitMessage = "See ya!"
187−
188−-- |
189−-- PSCI monad
190−--
191−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
192−
193−psciIO :: IO a -> PSCI a
194−psciIO io = PSCI . lift $ lift io
195−
196−-- |
197−-- Makes a volatile module to execute the current expression.
198−--
199−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
200−createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
201− let
202− moduleName = P.ModuleName [P.ProperName "$PSCI"]
203− trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
204− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
205− itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
206− mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] $ Right mainValue
207− decls = if exec then [itDecl, mainDecl] else [itDecl]
208− in
209− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
210−
211−
212−-- |
213−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
214−--
215−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
216−createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ =
217− let
218− moduleName = P.ModuleName [P.ProperName "$PSCI"]
219− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
220− in
221− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing
222−
223−-- |
224−-- Makes a volatile module to execute the current imports.
225−--
226−createTemporaryModuleForImports :: PSCiState -> P.Module
227−createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
228− let
229− moduleName = P.ModuleName [P.ProperName "$PSCI"]
230− in
231− P.Module (P.internalModuleSourceSpan "<internal>") [] moduleName (importDecl `map` imports) Nothing
232−
233−importDecl :: ImportedModule -> P.Declaration
234−importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ False
235−
236−indexFile :: FilePath
237−indexFile = ".psci_modules" ++ pathSeparator : "index.js"
238−
239−modulesDir :: FilePath
240−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
241−
242118-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
243119-- options and ignores the warning messages.
244120runMake :: P.Make a -> IO (Either P.MultipleErrors a)
@@ -258,6 +134,58 @@ make st@PSCiState{..} ms = P.make actions' (map snd loadedModules ++ ms)
258134 loadedModules = psciLoadedModules st
259135 allModules = map (first Right) loadedModules ++ map (Left P.RebuildAlways,) ms
260136
137+
138+-- Commands
139+
140+-- |
141+-- Parses the input and returns either a Metacommand, or an error as a string.
142+--
143+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
144+getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
145+ firstLine <- withInterrupt $ getInputLine "> "
146+ case firstLine of
147+ Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
148+ Just "" -> return (Right Nothing)
149+ Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
150+ Just s -> fmap Just . parseCommand <$> go [s]
151+ where
152+ go :: [String] -> InputT (StateT PSCiState IO) String
153+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
154+
155+-- |
156+-- Performs an action for each meta-command given, and also for expressions.
157+--
158+handleCommand :: Command -> PSCI ()
159+handleCommand (Expression val) = handleExpression val
160+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
161+handleCommand (Import im) = handleImport im
162+handleCommand (Decls l) = handleDecls l
163+handleCommand (LoadFile filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
164+ m <- lift . lift $ loadModule absPath
165+ case m of
166+ Left err -> outputStrLn err
167+ Right mods -> lift $ modify (updateModules (map (absPath,) mods))
168+handleCommand (LoadForeign filePath) = PSCI $ whenFileExists filePath $ \absPath -> do
169+ foreignsOrError <- lift . lift . runMake $ do
170+ foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
171+ P.parseForeignModulesFromFiles [(absPath, foreignFile)]
172+ case foreignsOrError of
173+ Left err -> outputStrLn $ P.prettyPrintMultipleErrors False err
174+ Right foreigns -> lift $ modify (updateForeignFiles foreigns)
175+handleCommand ResetState = do
176+ PSCI . lift . modify $ \st ->
177+ st { psciImportedModules = []
178+ , psciLetBindings = []
179+ }
180+ loadAllImportedModules
181+handleCommand (TypeOf val) = handleTypeOf val
182+handleCommand (KindOf typ) = handleKindOf typ
183+handleCommand (BrowseModule moduleName) = handleBrowse moduleName
184+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
185+handleCommand (ShowInfo QueryImport) = handleShowImportedModules
186+handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
187+
188+
261189-- |
262190-- Takes a value expression and evaluates it with the current state.
263191--
@@ -268,7 +196,7 @@ handleExpression val = do
268196 let nodeArgs = psciNodeFlags st ++ [indexFile]
269197 e <- psciIO . runMake $ make st [supportModule, m]
270198 case e of
271− Left errs -> printErrors errs
199+ Left errs -> PSCI $ printErrors errs
272200 Right _ -> do
273201 psciIO $ writeFile indexFile "require('$PSCI')['$main']();"
274202 process <- psciIO findNodeProcess
@@ -289,7 +217,7 @@ handleDecls ds = do
289217 let m = createTemporaryModule False st' (P.ObjectLiteral [])
290218 e <- psciIO . runMake $ make st' [m]
291219 case e of
292− Left err -> printErrors err
220+ Left err -> PSCI $ printErrors err
293221 Right _ -> PSCI $ lift (put st')
294222
295223-- |
@@ -344,7 +272,7 @@ handleImport im = do
344272 let m = createTemporaryModuleForImports st
345273 e <- psciIO . runMake $ make st [m]
346274 case e of
347− Left errs -> printErrors errs
275+ Left errs -> PSCI $ printErrors errs
348276 Right _ -> do
349277 PSCI $ lift $ put st
350278 return ()
@@ -358,124 +286,12 @@ handleTypeOf val = do
358286 let m = createTemporaryModule False st val
359287 e <- psciIO . runMake $ make st [m]
360288 case e of
361− Left errs -> printErrors errs
289+ Left errs -> PSCI $ printErrors errs
362290 Right env' ->
363291 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
364292 Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
365293 Nothing -> PSCI $ outputStrLn "Could not find type"
366294
367−-- |
368−-- Pretty print a module's signatures
369−--
370−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
371−printModuleSignatures moduleName (P.Environment {..}) =
372− PSCI $
373− -- get relevant components of a module from environment
374− let moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) names
375− moduleTypeClasses = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) typeClasses
376− moduleTypes = (filter (\(P.Qualified maybeName _) -> maybeName == Just moduleName) . M.keys) types
377−
378− in
379− -- print each component
380− (outputStr . unlines . map trimEnd . lines . Box.render . Box.vsep 1 Box.left)
381− [ printModule's (mapMaybe (showTypeClass . findTypeClass typeClasses)) moduleTypeClasses -- typeClasses
382− , printModule's (mapMaybe (showType typeClasses dataConstructors typeSynonyms . findType types)) moduleTypes -- types
383− , printModule's (map (showNameType . findNameType names)) moduleNamesIdent -- functions
384− ]
385−
386− where printModule's showF = Box.vsep 1 Box.left . showF
387−
388− findNameType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
389− findNameType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
390−
391− showNameType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> Box.Box
392− showNameType (mIdent, Just (mType, _, _)) = Box.text (P.showIdent mIdent ++ " :: ") Box.<> P.typeAsBox mType
393− showNameType _ = P.internalError "The impossible happened in printModuleSignatures."
394−
395− findTypeClass
396− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
397− -> P.Qualified (P.ProperName 'P.ClassName)
398− -> (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
399− findTypeClass envTypeClasses name = (name, M.lookup name envTypeClasses)
400−
401− showTypeClass
402− :: (P.Qualified (P.ProperName 'P.ClassName), Maybe ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint]))
403− -> Maybe Box.Box
404− showTypeClass (_, Nothing) = Nothing
405− showTypeClass (P.Qualified _ name, Just (vars, body, constrs)) =
406− let constraints =
407− if null constrs
408− then Box.text ""
409− else Box.text "("
410− Box.<> Box.hcat Box.left (intersperse (Box.text ", ") $ map (\(P.Qualified _ pn, lt) -> Box.text (P.runProperName pn) Box.<+> Box.hcat Box.left (map P.typeAtomAsBox lt)) constrs)
411− Box.<> Box.text ") <= "
412− className =
413− Box.text (P.runProperName name)
414− Box.<> Box.text (concatMap ((' ':) . fst) vars)
415− classBody =
416− Box.vcat Box.top (map (\(i, t) -> Box.text (P.showIdent i ++ " ::") Box.<+> P.typeAsBox t) body)
417−
418− in
419− Just $
420− (Box.text "class "
421− Box.<> constraints
422− Box.<> className
423− Box.<+> if null body then Box.text "" else Box.text "where")
424− Box.// Box.moveRight 2 classBody
425−
426−
427− findType
428− :: M.Map (P.Qualified (P.ProperName 'P.TypeName)) (P.Kind, P.TypeKind)
429− -> P.Qualified (P.ProperName 'P.TypeName)
430− -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
431− findType envTypes name = (name, M.lookup name envTypes)
432−
433− showType
434− :: M.Map (P.Qualified (P.ProperName 'P.ClassName)) ([(String, Maybe P.Kind)], [(P.Ident, P.Type)], [P.Constraint])
435− -> M.Map (P.Qualified (P.ProperName 'P.ConstructorName)) (P.DataDeclType, P.ProperName 'P.TypeName, P.Type, [P.Ident])
436− -> M.Map (P.Qualified (P.ProperName 'P.TypeName)) ([(String, Maybe P.Kind)], P.Type)
437− -> (P.Qualified (P.ProperName 'P.TypeName), Maybe (P.Kind, P.TypeKind))
438− -> Maybe Box.Box
439− showType typeClassesEnv dataConstructorsEnv typeSynonymsEnv (n@(P.Qualified modul name), typ) =
440− case (typ, M.lookup n typeSynonymsEnv) of
441− (Just (_, P.TypeSynonym), Just (typevars, dtType)) ->
442− if M.member (fmap P.coerceProperName n) typeClassesEnv
443− then
444− Nothing
445− else
446− Just $
447− Box.text ("type " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars)
448− Box.// Box.moveRight 2 (Box.text "=" Box.<+> P.typeAsBox dtType)
449−
450− (Just (_, P.DataType typevars pt), _) ->
451− let prefix =
452− case pt of
453− [(dtProperName,_)] ->
454− case M.lookup (P.Qualified modul dtProperName) dataConstructorsEnv of
455− Just (dataDeclType, _, _, _) -> P.showDataDeclType dataDeclType
456− _ -> "data"
457− _ -> "data"
458−
459− in
460− Just $ Box.text (prefix ++ " " ++ P.runProperName name ++ concatMap ((' ':) . fst) typevars) Box.// printCons pt
461−
462− _ ->
463− Nothing
464−
465− where printCons pt =
466− Box.moveRight 2 $
467− Box.vcat Box.left $
468− mapFirstRest (Box.text "=" Box.<+>) (Box.text "|" Box.<+>) $
469− map (\(cons,idents) -> (Box.text (P.runProperName cons) Box.<> Box.hcat Box.left (map prettyPrintType idents))) pt
470−
471− prettyPrintType t = Box.text " " Box.<> P.typeAtomAsBox t
472−
473− mapFirstRest _ _ [] = []
474− mapFirstRest f g (x:xs) = f x : map g xs
475−
476− trimEnd = reverse . dropWhile (== ' ') . reverse
477−
478−
479295-- |
480296-- Browse a module and displays its signature (if module exists).
481297--
@@ -484,14 +300,14 @@ handleBrowse moduleName = do
484300 st <- PSCI $ lift get
485301 env <- psciIO . runMake $ make st []
486302 case env of
487− Left errs -> printErrors errs
303+ Left errs -> PSCI $ printErrors errs
488304 Right env' ->
489305 if isModInEnv moduleName st
490− then printModuleSignatures moduleName env'
306+ then PSCI $ printModuleSignatures moduleName env'
491307 else case lookupUnQualifiedModName moduleName st of
492308 Just unQualifiedName ->
493309 if isModInEnv unQualifiedName st
494− then printModuleSignatures unQualifiedName env'
310+ then PSCI $ printModuleSignatures unQualifiedName env'
495311 else failNotInEnv moduleName
496312 Nothing ->
497313 failNotInEnv moduleName
@@ -503,10 +319,6 @@ handleBrowse moduleName = do
503319 lookupUnQualifiedModName quaModName st =
504320 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)
505321
506−-- | Pretty-print errors
507−printErrors :: P.MultipleErrors -> PSCI ()
508−printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
509−
510322-- |
511323-- Takes a value and prints its kind
512324--
@@ -517,7 +329,7 @@ handleKindOf typ = do
517329 mName = P.ModuleName [P.ProperName "$PSCI"]
518330 e <- psciIO . runMake $ make st [m]
519331 case e of
520− Left errs -> printErrors errs
332+ Left errs -> PSCI $ printErrors errs
521333 Right env' ->
522334 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
523335 Just (_, typ') -> do
@@ -531,63 +343,7 @@ handleKindOf typ = do
531343 Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
532344 Nothing -> PSCI $ outputStrLn "Could not find kind"
533345
534−-- Commands
535−
536−-- |
537−-- Parses the input and returns either a Metacommand, or an error as a string.
538−--
539−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
540−getCommand singleLineMode = handleInterrupt (return (Right Nothing)) $ do
541− firstLine <- withInterrupt $ getInputLine "> "
542− case firstLine of
543− Nothing -> return (Right (Just QuitPSCi)) -- Ctrl-D when input is empty
544− Just "" -> return (Right Nothing)
545− Just s | singleLineMode || head s == ':' -> return .fmap Just $ parseCommand s
546− Just s -> fmap Just . parseCommand <$> go [s]
547− where
548− go :: [String] -> InputT (StateT PSCiState IO) String
549− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
550−
551−-- |
552−-- Performs an action for each meta-command given, and also for expressions.
553−--
554−handleCommand :: Command -> PSCI ()
555−handleCommand (Expression val) = handleExpression val
556−handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
557−handleCommand (Import im) = handleImport im
558−handleCommand (Decls l) = handleDecls l
559−handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
560− m <- psciIO $ loadModule absPath
561− case m of
562− Left err -> PSCI $ outputStrLn err
563− Right mods -> PSCI . lift $ modify (updateModules (map (absPath,) mods))
564−handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
565− foreignsOrError <- psciIO . runMake $ do
566− foreignFile <- makeIO (const (P.ErrorMessage [] $ P.CannotReadFile absPath)) (readFile absPath)
567− P.parseForeignModulesFromFiles [(absPath, foreignFile)]
568− case foreignsOrError of
569− Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
570− Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)
571−handleCommand ResetState = do
572− PSCI . lift . modify $ \st ->
573− st { psciImportedModules = []
574− , psciLetBindings = []
575− }
576− loadAllImportedModules
577−handleCommand (TypeOf val) = handleTypeOf val
578−handleCommand (KindOf typ) = handleKindOf typ
579−handleCommand (BrowseModule moduleName) = handleBrowse moduleName
580−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
581−handleCommand (ShowInfo QueryImport) = handleShowImportedModules
582−handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
583−
584−whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()
585−whenFileExists filePath f = do
586− absPath <- psciIO $ expandTilde filePath
587− exists <- psciIO $ doesFileExist absPath
588− if exists
589− then f absPath
590− else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
346+-- Misc
591347
592348-- |
593349-- Attempts to read initial commands from '.psci' in the present working
@@ -610,92 +366,6 @@ loadUserConfig = onFirstFileMatching readCommands pathGetters
610366 else
611367 return Nothing
612368
613−
614369-- | Checks if the Console module is defined
615370consoleIsDefined :: [P.Module] -> Bool
616371consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)
617−
618−-- |
619−-- The PSCI main loop.
620−--
621−loop :: PSCiOptions -> IO ()
622−loop PSCiOptions{..} = do
623− config <- loadUserConfig
624− inputFiles <- concat <$> traverse glob psciInputFile
625− foreignFiles <- concat <$> traverse glob psciForeignInputFiles
626− modulesOrFirstError <- loadAllModules inputFiles
627− case modulesOrFirstError of
628− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
629− Right modules -> do
630− historyFilename <- getHistoryFilename
631− let settings = defaultSettings { historyFile = Just historyFilename }
632− foreignsOrError <- runMake $ do
633− foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.ErrorMessage [] $ P.CannotReadFile inFile)) (readFile inFile))
634− P.parseForeignModulesFromFiles foreignFilesContent
635− case foreignsOrError of
636− Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
637− Right foreigns ->
638− flip evalStateT (mkPSCiState [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
639− outputStrLn prologueMessage
640− traverse_ (traverse_ (runPSCI . handleCommand)) config
641− modules' <- lift $ gets psciLoadedModules
642− unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
643− [ "PSCi requires the purescript-console module to be installed."
644− , "For help getting started, visit http://wiki.purescript.org/PSCi"
645− ]
646− go
647− where
648− go :: InputT (StateT PSCiState IO) ()
649− go = do
650− c <- getCommand (not psciMultiLineMode)
651− case c of
652− Left err -> outputStrLn err >> go
653− Right Nothing -> go
654− Right (Just QuitPSCi) -> outputStrLn quitMessage
655− Right (Just c') -> do
656− handleInterrupt (outputStrLn "Interrupted.")
657− (withInterrupt (runPSCI (loadAllImportedModules >> handleCommand c')))
658− go
659−
660−multiLineMode :: Parser Bool
661−multiLineMode = switch $
662− long "multi-line-mode"
663− <> short 'm'
664− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
665−
666−inputFile :: Parser FilePath
667−inputFile = strArgument $
668− metavar "FILE"
669− <> Opts.help "Optional .purs files to load on start"
670−
671−inputForeignFile :: Parser FilePath
672−inputForeignFile = strOption $
673− short 'f'
674− <> long "ffi"
675− <> help "The input .js file(s) providing foreign import implementations"
676−
677−nodeFlagsFlag :: Parser [String]
678−nodeFlagsFlag = option parser $
679− long "node-opts"
680− <> metavar "NODE_OPTS"
681− <> value []
682− <> Opts.help "Flags to pass to node, separated by spaces"
683− where
684− parser = words <$> str
685−
686−psciOptions :: Parser PSCiOptions
687−psciOptions = PSCiOptions <$> multiLineMode
688− <*> many inputFile
689− <*> many inputForeignFile
690− <*> nodeFlagsFlag
691−
692−runPSCi :: IO ()
693−runPSCi = execParser opts >>= loop
694− where
695− opts = info (version <*> helper <*> psciOptions) infoModList
696− infoModList = fullDesc <> headerInfo <> footerInfo
697− headerInfo = header "psci - Interactive mode for PureScript"
698− footerInfo = footer $ "psci " ++ showVersion Paths.version
699−
700− version :: Parser (a -> a)
701− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden