@@ -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)