git.iko.soy/rowtype-yoga/purescript-native
on 99a2db3 help sign in
rowtype-yoga/purescript-native/src/Language/PureScript/Interactive.hs
288 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.ReExportRef _ _) =
204 Nothing
205 showRef (P.PositionedDeclarationRef _ _ ref) =
206 showRef ref
208 commaList :: [Text] -> Text
209 commaList = T.intercalate ", "
211-- | Imports a module, preserving the initial state on failure.
212handleImport
213 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
214 => ImportedModule
215 -> m ()
216handleImport im = do
217 st <- gets (updateImportedModules (im :))
218 let m = createTemporaryModuleForImports st
219 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
220 case e of
221 Left errs -> printErrors errs
222 Right _ -> put st
224-- | Takes a value and prints its type
225handleTypeOf
226 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
227 => P.Expr
228 -> m ()
229handleTypeOf val = do
230 st <- get
231 let m = createTemporaryModule False st val
232 e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
233 case e of
234 Left errs -> printErrors errs
235 Right (_, env') ->
236 case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName [P.ProperName "$PSCI"])) (P.names env') of
237 Just (ty, _, _) -> liftIO . putStrLn . P.prettyPrintType $ ty
238 Nothing -> liftIO $ putStrLn "Could not find type"
240-- | Takes a type and prints its kind
241handleKindOf
242 :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
243 => P.Type
244 -> m ()
245handleKindOf typ = do
246 st <- get
247 let m = createTemporaryModuleForKind st typ
248 mName = P.ModuleName [P.ProperName "$PSCI"]
249 e <- liftIO . runMake $ rebuild (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 . T.unpack . 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 $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
287 lookupUnQualifiedModName quaModName st =
288 (\(modName,_,_) -> modName) <$> find ( \(_, _, mayQuaName) -> mayQuaName == Just quaModName) (psciImportedModules st)