git.iko.soy/rowtype-yoga/purescript-native
on 46f1687 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Interactive.hs
288 lines 12 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 False
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 :: M.Map P.ModuleName FilePath
57 -> [P.ExternsFile]
58 -> P.Module
59 -> P.Make (P.ExternsFile, P.Environment)
60rebuild 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 ()) }
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 :: M.Map P.ModuleName FilePath
76 -> [P.Module]
77 -> P.Make ([P.ExternsFile], P.Environment)
78make 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)
88 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
89 filePathMap = M.fromList $ map (\m -> (P.getModuleName m, Left P.RebuildAlways)) 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 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)))
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 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"
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--
153handleDecls
154 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
155 => [P.Declaration]
156 -> m ()
157handleDecls 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
166-- | Show actual loaded modules in psci.
167handleShowLoadedModules
168 :: (MonadState PSCiState m, MonadIO m)
169 => m ()
170handleShowLoadedModules = do
171 loadedModules <- gets psciLoadedExterns
172 liftIO $ putStrLn (readModules loadedModules)
173 where
174 readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst)
176-- | Show the imported modules in psci.
177handleShowImportedModules
178 :: (MonadState PSCiState m, MonadIO m)
179 => m ()
180handleShowImportedModules = 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
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) ++ ")"
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
205 commaList :: [String] -> String
206 commaList = intercalate ", "
208-- | Imports a module, preserving the initial state on failure.
209handleImport
210 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
211 => ImportedModule
212 -> m ()
213handleImport 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
222-- | Takes a value and prints its type
223handleTypeOf
224 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
225 => P.Expr
226 -> m ()
227handleTypeOf 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"
239-- | Takes a type and prints its kind
240handleKindOf
241 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
242 => P.Type
243 -> m ()
244handleKindOf 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
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"
265-- | Browse a module and displays its signature
266handleBrowse
267 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
268 => P.ModuleName
269 -> m ()
270handleBrowse 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)