git.iko.soy/rowtype-yoga/purescript-native
on 7894cad help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Interactive.hs
289 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.FilePath ((</>))
43-- | Pretty-print errors
44printErrors :: MonadIO m => P.MultipleErrors -> m ()
45printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions
47-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
48-- options and ignores the warning messages.
49runMake :: P.Make a -> IO (Either P.MultipleErrors a)
50runMake mk = fst <$> P.runMake P.defaultOptions mk
52-- | Rebuild a module, using the cached externs data for dependencies.
53rebuild
54 :: [P.ExternsFile]
55 -> P.Module
56 -> P.Make (P.ExternsFile, P.Environment)
57rebuild loadedExterns m = do
58 externs <- P.rebuildModule buildActions loadedExterns m
59 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))
60 where
61 buildActions :: P.MakeActions P.Make
62 buildActions =
63 (P.buildMakeActions modulesDir
64 filePathMap
65 M.empty
66 False) { P.progress = const (return ()) }
68 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
69 filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
71-- | Build the collection of modules from scratch. This is usually done on startup.
72make
73 :: [(FilePath, P.Module)]
74 -> P.Make ([P.ExternsFile], P.Environment)
75make ms = do
76 foreignFiles <- P.inferForeignModules filePathMap
77 externs <- P.make (buildActions foreignFiles) (map snd ms)
78 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
79 where
80 buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
81 buildActions foreignFiles =
82 P.buildMakeActions modulesDir
83 filePathMap
84 foreignFiles
85 False
87 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
88 filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms
90-- | Performs a PSCi command
91handleCommand
92 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
93 => (String -> m ())
94 -> m ()
95 -> Command
96 -> m ()
97handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage
98handleCommand _ r ResetState = handleResetState r
99handleCommand c _ (Expression val) = handleExpression c 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 ()
113 -> m ()
114handleResetState reload = do
115 modify $ updateImportedModules (const [])
116 . updateLets (const [])
117 files <- asks psciLoadedFiles
118 e <- runExceptT $ do
119 modules <- ExceptT . liftIO $ loadAllModules files
120 (externs, _) <- ExceptT . liftIO . runMake . make $ modules
121 return (map snd modules, externs)
122 case e of
123 Left errs -> printErrors errs
124 Right (modules, externs) -> do
125 modify (updateLoadedExterns (const (zip modules externs)))
126 reload
128-- | Takes a value expression and evaluates it with the current state.
129handleExpression
130 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
131 => (String -> m ())
132 -> P.Expr
133 -> m ()
134handleExpression evaluate val = do
135 st <- get
136 let m = createTemporaryModule True st val
137 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
138 case e of
139 Left errs -> printErrors errs
140 Right _ -> do
141 js <- liftIO $ readFile (modulesDir </> "$PSCI" </> "index.js")
142 evaluate js
144-- |
145-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
146-- restore the original environment.
147--
148handleDecls
149 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
150 => [P.Declaration]
151 -> m ()
152handleDecls ds = do
153 st <- gets (updateLets (++ ds))
154 let m = createTemporaryModule False st (P.Literal (P.ObjectLiteral []))
155 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
156 case e of
157 Left err -> printErrors err
158 Right _ -> put st
160-- | Show actual loaded modules in psci.
161handleShowLoadedModules
162 :: (MonadState PSCiState m, MonadIO m)
163 => m ()
164handleShowLoadedModules = do
165 loadedModules <- gets psciLoadedExterns
166 liftIO $ putStrLn (readModules loadedModules)
167 where
168 readModules = unlines . sort . nub . map (P.runModuleName . P.getModuleName . fst)
170-- | Show the imported modules in psci.
171handleShowImportedModules
172 :: (MonadState PSCiState m, MonadIO m)
173 => m ()
174handleShowImportedModules = do
175 PSCiState { psciImportedModules = importedModules } <- get
176 liftIO $ showModules importedModules >>= putStrLn
177 return ()
178 where
179 showModules = return . unlines . sort . map showModule
180 showModule (mn, declType, asQ) =
181 "import " ++ N.runModuleName mn ++ showDeclType declType ++
182 foldMap (\mn' -> " as " ++ N.runModuleName mn') asQ
184 showDeclType P.Implicit = ""
185 showDeclType (P.Explicit refs) = refsList refs
186 showDeclType (P.Hiding refs) = " hiding " ++ refsList refs
187 refsList refs = " (" ++ commaList (mapMaybe showRef refs) ++ ")"
189 showRef :: P.DeclarationRef -> Maybe String
190 showRef (P.TypeRef pn dctors) =
191 Just $ N.runProperName pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
192 showRef (P.TypeOpRef op) =
193 Just $ "type " ++ N.showOp op
194 showRef (P.ValueRef ident) =
195 Just $ N.runIdent ident
196 showRef (P.ValueOpRef op) =
197 Just $ N.showOp op
198 showRef (P.TypeClassRef pn) =
199 Just $ "class " ++ N.runProperName pn
200 showRef (P.TypeInstanceRef ident) =
201 Just $ N.runIdent ident
202 showRef (P.ModuleRef name) =
203 Just $ "module " ++ N.runModuleName name
204 showRef (P.ReExportRef _ _) =
205 Nothing
206 showRef (P.PositionedDeclarationRef _ _ ref) =
207 showRef ref
209 commaList :: [String] -> String
210 commaList = intercalate ", "
212-- | Imports a module, preserving the initial state on failure.
213handleImport
214 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
215 => ImportedModule
216 -> m ()
217handleImport im = do
218 st <- gets (updateImportedModules (im :))
219 let m = createTemporaryModuleForImports st
220 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
221 case e of
222 Left errs -> printErrors errs
223 Right _ -> put st
225-- | Takes a value and prints its type
226handleTypeOf
227 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
228 => P.Expr
229 -> m ()
230handleTypeOf val = do
231 st <- get
232 let m = createTemporaryModule False st val
233 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
234 case e of
235 Left errs -> printErrors errs
236 Right (_, env') ->
237 case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of
238 Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty
239 Nothing -> liftIO $ putStrLn "Could not find type"
241-- | Takes a type and prints its kind
242handleKindOf
243 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
244 => P.Type
245 -> m ()
246handleKindOf typ = do
247 st <- get
248 let m = createTemporaryModuleForKind st typ
249 mName = P.ModuleName [P.ProperName "$PSCI"]
250 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
251 case e of
252 Left errs -> printErrors errs
253 Right (_, env') ->
254 case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
255 Just (_, typ') -> do
256 let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
257 k = check (P.kindOf typ') chk
259 check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
260 check sew = fst . runWriter . runExceptT . runStateT sew
261 case k of
262 Left err -> printErrors err
263 Right (kind, _) -> liftIO . putStrLn . P.prettyPrintKind $ kind
264 Nothing -> liftIO $ putStrLn "Could not find kind"
266-- | Browse a module and displays its signature
267handleBrowse
268 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
269 => P.ModuleName
270 -> m ()
271handleBrowse moduleName = do
272 st <- get
273 env <- asks psciEnvironment
274 if isModInEnv moduleName st
275 then liftIO . putStrLn $ printModuleSignatures moduleName env
276 else case lookupUnQualifiedModName moduleName st of
277 Just unQualifiedName ->
278 if isModInEnv unQualifiedName st
279 then liftIO . putStrLn $ printModuleSignatures unQualifiedName env
280 else failNotInEnv moduleName
281 Nothing ->
282 failNotInEnv moduleName
283 where
284 isModInEnv modName =
285 any ((== modName) . P.getModuleName . fst) . psciLoadedExterns
286 failNotInEnv modName =
287 liftIO $ putStrLn $ "Module '" ++ N.runModuleName modName ++ "' is not valid."
288 lookupUnQualifiedModName quaModName st =
289 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)