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