git.iko.soy/rowtype-yoga/purescript-native
on 1e60728 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 (nub, sort, find, foldl')
20import Data.Maybe (mapMaybe)
21import qualified Data.Map as M
22import Data.Monoid ((<>))
23import Data.Text (Text)
24import qualified Data.Text as T
26import Control.Monad.IO.Class (MonadIO, liftIO)
27import Control.Monad.State.Class
28import Control.Monad.Reader.Class
29import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
30import Control.Monad.Trans.State.Strict (StateT, runStateT)
31import Control.Monad.Writer.Strict (Writer(), runWriter)
33import qualified Language.PureScript as P
34import qualified Language.PureScript.Names as N
36import Language.PureScript.Interactive.Completion as Interactive
37import Language.PureScript.Interactive.IO as Interactive
38import Language.PureScript.Interactive.Message as Interactive
39import Language.PureScript.Interactive.Module as Interactive
40import Language.PureScript.Interactive.Parser as Interactive
41import Language.PureScript.Interactive.Printer as Interactive
42import Language.PureScript.Interactive.Types as Interactive
44import System.FilePath ((</>))
46-- | Pretty-print errors
47printErrors :: MonadIO m => P.MultipleErrors -> m ()
48printErrors = liftIO . putStrLn . P.prettyPrintMultipleErrors P.defaultPPEOptions
50-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
51-- options and ignores the warning messages.
52runMake :: P.Make a -> IO (Either P.MultipleErrors a)
53runMake mk = fst <$> P.runMake P.defaultOptions mk
55-- | Rebuild a module, using the cached externs data for dependencies.
56rebuild
57 :: [P.ExternsFile]
58 -> P.Module
59 -> P.Make (P.ExternsFile, P.Environment)
60rebuild 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 =
66 (P.buildMakeActions modulesDir
67 filePathMap
68 M.empty
69 False) { P.progress = const (return ()) }
71 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
72 filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
74-- | Build the collection of modules from scratch. This is usually done on startup.
75make
76 :: [(FilePath, P.Module)]
77 -> P.Make ([P.ExternsFile], P.Environment)
78make ms = do
79 foreignFiles <- P.inferForeignModules filePathMap
80 externs <- P.make (buildActions foreignFiles) (map snd ms)
81 return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
82 where
83 buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
84 buildActions foreignFiles =
85 P.buildMakeActions modulesDir
86 filePathMap
87 foreignFiles
88 False
90 filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
91 filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms
93-- | Performs a PSCi command
94handleCommand
95 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
96 => (String -> m ())
97 -> m ()
98 -> Command
99 -> m ()
100handleCommand _ _ ShowHelp = liftIO $ putStrLn helpMessage
101handleCommand _ r ResetState = handleResetState r
102handleCommand c _ (Expression val) = handleExpression c val
103handleCommand _ _ (Import im) = handleImport im
104handleCommand _ _ (Decls l) = handleDecls l
105handleCommand _ _ (TypeOf val) = handleTypeOf val
106handleCommand _ _ (KindOf typ) = handleKindOf typ
107handleCommand _ _ (BrowseModule moduleName) = handleBrowse moduleName
108handleCommand _ _ (ShowInfo QueryLoaded) = handleShowLoadedModules
109handleCommand _ _ (ShowInfo QueryImport) = handleShowImportedModules
110handleCommand _ _ _ = P.internalError "handleCommand: unexpected command"
112-- | Reset the application state
113handleResetState
114 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
115 => m ()
116 -> m ()
117handleResetState reload = do
118 modify $ updateImportedModules (const [])
119 . updateLets (const [])
120 files <- asks psciLoadedFiles
121 e <- runExceptT $ do
122 modules <- ExceptT . liftIO $ loadAllModules files
123 (externs, _) <- ExceptT . liftIO . runMake . make $ modules
124 return (map snd modules, externs)
125 case e of
126 Left errs -> printErrors errs
127 Right (modules, externs) -> do
128 modify (updateLoadedExterns (const (zip modules externs)))
129 reload
131-- | Takes a value expression and evaluates it with the current state.
132handleExpression
133 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
134 => (String -> m ())
135 -> P.Expr
136 -> m ()
137handleExpression evaluate val = do
138 st <- get
139 let m = createTemporaryModule True st val
140 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
141 case e of
142 Left errs -> printErrors errs
143 Right _ -> do
144 js <- liftIO $ readFile (modulesDir </> "$PSCI" </> "index.js")
145 evaluate 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 (T.unpack . 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 (T.unpack . 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 Text
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 :: [Text] -> Text
213 commaList = T.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.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (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 . T.unpack . 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 $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
291 lookupUnQualifiedModName quaModName st =
292 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)