git.iko.soy/rowtype-yoga/purescript-native
on d2dfad0 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Interactive.hs
283 lines 11 kB history raw
1{-# LANGUAGE DoAndIfThenElse #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE MultiParamTypeClasses #-}
5{-# LANGUAGE RecordWildCards #-}
6{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE DataKinds #-}
9module Language.PureScript.Interactive
10 ( handleCommand
11 , module Interactive
13 -- TODO: remove these exports
14 , make
15 , runMake
16 ) where
18import Prelude ()
19import Prelude.Compat
21import Data.List (intercalate, nub, sort, find, foldl')
22import qualified Data.Map as M
24import Control.Monad.IO.Class (MonadIO, liftIO)
25import Control.Monad.State.Class
26import Control.Monad.Reader.Class
27import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
28import Control.Monad.Trans.State.Strict (StateT, runStateT)
29import Control.Monad.Writer.Strict (Writer(), runWriter)
31import qualified Language.PureScript as P
32import qualified Language.PureScript.Names as N
34import Language.PureScript.Interactive.Completion as Interactive
35import Language.PureScript.Interactive.IO as Interactive
36import Language.PureScript.Interactive.Message as Interactive
37import Language.PureScript.Interactive.Module as Interactive
38import Language.PureScript.Interactive.Parser as Interactive
39import Language.PureScript.Interactive.Printer as Interactive
40import Language.PureScript.Interactive.Types as Interactive
42import System.Exit
43import System.Process (readProcessWithExitCode)
45-- | Pretty-print errors
46printErrors :: MonadIO m => P.MultipleErrors -> m ()
47printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions
49-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
50-- options and ignores the warning messages.
51runMake :: P.Make a -> IO (Either P.MultipleErrors a)
52runMake mk = fst <$> P.runMake P.defaultOptions mk
54-- | Rebuild a module, using the cached externs data for dependencies.
55rebuild
56 :: [P.ExternsFile]
57 -> P.Module
58 -> P.Make (P.ExternsFile, P.Environment)
59rebuild loadedExterns m = do
60 externs <- P.rebuildModule buildActions loadedExterns m
61 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))
62 where
63 buildActions :: P.MakeActions P.Make
64 buildActions =
65 (P.buildMakeActions modulesDir
66 filePathMap
67 M.empty
68 False) { P.progress = const (return ()) }
70 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
71 filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
73-- | Build the collection of modules from scratch. This is usually done on startup.
74make
75 :: [(FilePath, P.Module)]
76 -> P.Make ([P.ExternsFile], P.Environment)
77make ms = do
78 foreignFiles <- P.inferForeignModules filePathMap
79 externs <- P.make (buildActions foreignFiles) (map snd ms)
80 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
81 where
82 buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
83 buildActions foreignFiles =
84 P.buildMakeActions modulesDir
85 filePathMap
86 foreignFiles
87 False
89 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
90 filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms
92-- | Performs a PSCi command
93handleCommand
94 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
95 => Command
96 -> m ()
97handleCommand ShowHelp = liftIO $ putStrLn helpMessage
98handleCommand ResetState = handleResetState
99handleCommand (Expression val) = handleExpression val
100handleCommand (Import im) = handleImport im
101handleCommand (Decls l) = handleDecls l
102handleCommand (TypeOf val) = handleTypeOf val
103handleCommand (KindOf typ) = handleKindOf typ
104handleCommand (BrowseModule moduleName) = handleBrowse moduleName
105handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
106handleCommand (ShowInfo QueryImport) = handleShowImportedModules
107handleCommand QuitPSCi = P.internalError "`handleCommand QuitPSCi` was called. This is a bug."
109-- | Reset the application state
110handleResetState
111 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
112 => m ()
113handleResetState = do
114 modify $ updateImportedModules (const [])
115 . updateLets (const [])
116 files <- asks psciLoadedFiles
117 e <- runExceptT $ do
118 modules <- ExceptT . liftIO $ loadAllModules files
119 (externs, _) <- ExceptT . liftIO . runMake . make $ 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)))
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.
128handleExpression
129 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
130 => P.Expr
131 -> m ()
132handleExpression val = do
133 st <- get
134 let m = createTemporaryModule True st val
135 nodeArgs <- asks ((++ [indexFile]) . psciNodeFlags)
136 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
137 case e of
138 Left errs -> printErrors errs
139 Right _ -> do
140 liftIO $ writeFile indexFile "require('$PSCI')['$main']();"
141 process <- liftIO findNodeProcess
142 result <- liftIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
143 case result of
144 Just (ExitSuccess, out, _) -> liftIO $ putStrLn out
145 Just (ExitFailure _, _, err) -> liftIO $ putStrLn err
146 Nothing -> liftIO $ putStrLn "Couldn't find node.js"
148-- |
149-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
150-- restore the original environment.
151--
152handleDecls
153 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
154 => [P.Declaration]
155 -> m ()
156handleDecls ds = do
157 st <- gets (updateLets (++ ds))
158 let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral []))
159 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
160 case e of
161 Left err -> printErrors err
162 Right _ -> put st
164-- | Show actual loaded modules in psci.
165handleShowLoadedModules
166 :: (MonadState PSCiState m, MonadIO m)
167 => m ()
168handleShowLoadedModules = do
169 loadedModules <- gets psciLoadedExterns
170 liftIO $ putStrLn (readModules loadedModules)
171 where
172 readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst)
174-- | Show the imported modules in psci.
175handleShowImportedModules
176 :: (MonadState PSCiState m, MonadIO m)
177 => m ()
178handleShowImportedModules = do
179 PSCiState { psciImportedModules = importedModules } <- get
180 liftIO $ showModules importedModules >>= putStrLn
181 return ()
182 where
183 showModules = return . unlines . sort . map showModule
184 showModule (mn, declType, asQ) =
185 "import " ++ N.runModuleName mn ++ showDeclType declType ++
186 foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ
188 showDeclType P.Implicit = ""
189 showDeclType (P.Explicit refs) = refsList refs
190 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
191 refsList refs = " (" ++ commaList (map showRef refs) ++ ")"
193 showRef :: P.DeclarationRef -> String
194 showRef (P.TypeRef pn dctors) = N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
195 showRef (P.TypeOpRef op) = "type " ++ N.showOp op
196 showRef (P.ValueRef ident) = N.runIdent ident
197 showRef (P.ValueOpRef op) = N.showOp op
198 showRef (P.TypeClassRef pn) = "class " ++ N.runProperName pn
199 showRef (P.TypeInstanceRef ident) = N.runIdent ident
200 showRef (P.ModuleRef name) = "module " ++ N.runModuleName name
201 showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
203 commaList :: [String] -> String
204 commaList = intercalate ", "
206-- | Imports a module, preserving the initial state on failure.
207handleImport
208 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
209 => ImportedModule
210 -> m ()
211handleImport im = do
212 st <- gets (updateImportedModules (im :))
213 let m = createTemporaryModuleForImports st
214 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
215 case e of
216 Left errs -> printErrors errs
217 Right _ -> put st
219-- | Takes a value and prints its type
220handleTypeOf
221 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
222 => P.Expr
223 -> m ()
224handleTypeOf val = do
225 st <- get
226 let m = createTemporaryModule False st val
227 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
228 case e of
229 Left errs -> printErrors errs
230 Right (_, env') ->
231 case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
232 Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty
233 Nothing -> liftIO $ putStrLn "Could not find type"
235-- | Takes a type and prints its kind
236handleKindOf
237 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
238 => P.Type
239 -> m ()
240handleKindOf typ = do
241 st <- get
242 let m = createTemporaryModuleForKind st typ
243 mName = P.ModuleName [P.ProperName "$PSCI"]
244 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
245 case e of
246 Left errs -> printErrors errs
247 Right (_, env') ->
248 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
249 Just (_, typ') -> do
250 let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
251 k = check (P.kindOf typ') chk
253 check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
254 check sew = fst . runWriter . runExceptT . runStateT sew
255 case k of
256 Left err -> printErrors err
257 Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind
258 Nothing -> liftIO $ putStrLn "Could not find kind"
260-- | Browse a module and displays its signature
261handleBrowse
262 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
263 => P.ModuleName
264 -> m ()
265handleBrowse moduleName = do
266 st <- get
267 env <- asks psciEnvironment
268 if isModInEnv moduleName st
269 then liftIO . putStrLn $ printModuleSignatures moduleName env
270 else case lookupUnQualifiedModName moduleName st of
271 Just unQualifiedName ->
272 if isModInEnv unQualifiedName st
273 then liftIO . putStrLn $ printModuleSignatures unQualifiedName env
274 else failNotInEnv moduleName
275 Nothing ->
276 failNotInEnv moduleName
277 where
278 isModInEnv modName =
279 any ((== modName) . P.getModuleName . fst) . psciLoadedExterns
280 failNotInEnv modName =
281 liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."
282 lookupUnQualifiedModName quaModName st =
283 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)