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