1{-# LANGUAGE DoAndIfThenElse #-}
2
3module Language.PureScript.Interactive
4  ( handleCommand
5  , module Interactive
6
7  -- TODO: remove these exports
8  , make
9  , runMake
10  ) where
11
12import           Prelude ()
13import           Prelude.Compat
14import           Protolude (ordNub)
15
16import           Data.List (sort, find, foldl')
17import           Data.Maybe (fromMaybe, mapMaybe)
18import qualified Data.Map as M
19import qualified Data.Set as S
20import           Data.Text (Text)
21import qualified Data.Text as T
22
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, evalStateT)
28import           Control.Monad.Writer.Strict (Writer(), runWriter)
29
30import qualified Language.PureScript as P
31import qualified Language.PureScript.CST as CST
32import qualified Language.PureScript.Names as N
33import qualified Language.PureScript.Constants.Prim as C
34
35import           Language.PureScript.Interactive.Completion   as Interactive
36import           Language.PureScript.Interactive.IO           as Interactive
37import           Language.PureScript.Interactive.Message      as Interactive
38import           Language.PureScript.Interactive.Module       as Interactive
39import           Language.PureScript.Interactive.Parser       as Interactive
40import           Language.PureScript.Interactive.Printer      as Interactive
41import           Language.PureScript.Interactive.Types        as Interactive
42
43import           System.Directory (getCurrentDirectory)
44import           System.FilePath ((</>))
45import           System.FilePath.Glob (glob)
46
47-- | Pretty-print errors
48printErrors :: MonadIO m => P.MultipleErrors -> m ()
49printErrors errs = liftIO $ do
50  pwd <- getCurrentDirectory
51  putStrLn $ P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd} errs
52
53-- | This is different than the runMake in 'Language.PureScript.Make' in that it specifies the
54-- options and ignores the warning messages.
55runMake :: P.Make a -> IO (Either P.MultipleErrors a)
56runMake mk = fst <$> P.runMake P.defaultOptions mk
57
58-- | Rebuild a module, using the cached externs data for dependencies.
59rebuild
60  :: [P.ExternsFile]
61  -> P.Module
62  -> P.Make (P.ExternsFile, P.Environment)
63rebuild loadedExterns m = do
64    externs <- P.rebuildModule buildActions loadedExterns m
65    return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment (loadedExterns ++ [externs]))
66  where
67    buildActions :: P.MakeActions P.Make
68    buildActions =
69      (P.buildMakeActions modulesDir
70                          filePathMap
71                          M.empty
72                          False) { P.progress = const (return ()) }
73
74    filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
75    filePathMap = M.singleton (P.getModuleName m) (Left P.RebuildAlways)
76
77-- | Build the collection of modules from scratch. This is usually done on startup.
78make
79  :: [(FilePath, CST.PartialResult P.Module)]
80  -> P.Make ([P.ExternsFile], P.Environment)
81make ms = do
82    foreignFiles <- P.inferForeignModules filePathMap
83    externs <- P.make (buildActions foreignFiles) (map snd ms)
84    return (externs, foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs)
85  where
86    buildActions :: M.Map P.ModuleName FilePath -> P.MakeActions P.Make
87    buildActions foreignFiles =
88      P.buildMakeActions modulesDir
89                         filePathMap
90                         foreignFiles
91                         False
92
93    filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
94    filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName $ CST.resPartial m, Right fp)) ms
95
96-- | Performs a PSCi command
97handleCommand
98  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
99  => (String -> m ()) -- ^ evaluate JS
100  -> m () -- ^ reload
101  -> (String -> m ()) -- ^ print into console
102  -> Command
103  -> m ()
104handleCommand _ _ p ShowHelp                  = p helpMessage
105handleCommand _ r _ ReloadState               = handleReloadState r
106handleCommand _ r _ ClearState                = handleClearState r
107handleCommand e _ _ (Expression val)          = handleExpression e val
108handleCommand _ _ _ (Import im)               = handleImport im
109handleCommand _ _ _ (Decls l)                 = handleDecls l
110handleCommand _ _ p (TypeOf val)              = handleTypeOf p val
111handleCommand _ _ p (KindOf typ)              = handleKindOf p typ
112handleCommand _ _ p (BrowseModule moduleName) = handleBrowse p moduleName
113handleCommand _ _ p (ShowInfo QueryLoaded)    = handleShowLoadedModules p
114handleCommand _ _ p (ShowInfo QueryImport)    = handleShowImportedModules p
115handleCommand _ _ p (ShowInfo QueryPrint)     = handleShowPrint p
116handleCommand _ _ p (CompleteStr prefix)      = handleComplete p prefix
117handleCommand _ _ p (SetInteractivePrint ip)  = handleSetInteractivePrint p ip
118handleCommand _ _ _ _                         = P.internalError "handleCommand: unexpected command"
119
120-- | Reload the application state
121handleReloadState
122  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
123  => m ()
124  -> m ()
125handleReloadState reload = do
126  modify $ updateLets (const [])
127  globs <- asks psciFileGlobs
128  files <- liftIO $ concat <$> traverse glob globs
129  e <- runExceptT $ do
130    modules <- ExceptT . liftIO $ loadAllModules files
131    (externs, _) <- ExceptT . liftIO . runMake . make $ fmap CST.pureResult <$> modules
132    return (map snd modules, externs)
133  case e of
134    Left errs -> printErrors errs
135    Right (modules, externs) -> do
136      modify (updateLoadedExterns (const (zip modules externs)))
137      reload
138
139-- | Clear the application state
140handleClearState
141  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
142  => m ()
143  -> m ()
144handleClearState reload = do
145  modify $ updateImportedModules (const [])
146  handleReloadState reload
147
148-- | Takes a value expression and evaluates it with the current state.
149handleExpression
150  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
151  => (String -> m ())
152  -> P.Expr
153  -> m ()
154handleExpression evaluate val = do
155  st <- get
156  let m = createTemporaryModule True st val
157  e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
158  case e of
159    Left errs -> printErrors errs
160    Right _ -> do
161      js <- liftIO $ readFile (modulesDir </> "$PSCI" </> "index.js")
162      evaluate js
163
164-- |
165-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
166-- restore the original environment.
167--
168handleDecls
169  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
170  => [P.Declaration]
171  -> m ()
172handleDecls ds = do
173  st <- gets (updateLets (++ ds))
174  let m = createTemporaryModule False st (P.Literal P.nullSourceSpan (P.ObjectLiteral []))
175  e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
176  case e of
177    Left err -> printErrors err
178    Right _ -> put st
179
180-- | Show actual loaded modules in psci.
181handleShowLoadedModules
182  :: (MonadState PSCiState m, MonadIO m)
183  => (String -> m ())
184  -> m ()
185handleShowLoadedModules print' = do
186    loadedModules <- gets psciLoadedExterns
187    print' $ readModules loadedModules
188  where
189    readModules = unlines . sort . ordNub . map (T.unpack . P.runModuleName . P.getModuleName . fst)
190
191-- | Show the imported modules in psci.
192handleShowImportedModules
193  :: (MonadState PSCiState m, MonadIO m)
194  => (String -> m ())
195  -> m ()
196handleShowImportedModules print' = do
197  importedModules <- psciImportedModules <$> get
198  print' $ showModules importedModules
199  where
200  showModules = unlines . sort . map (T.unpack . showModule)
201  showModule (mn, declType, asQ) =
202    "import " <> N.runModuleName mn <> showDeclType declType <>
203    foldMap (\mn' -> " as " <> N.runModuleName mn') asQ
204
205  showDeclType P.Implicit = ""
206  showDeclType (P.Explicit refs) = refsList refs
207  showDeclType (P.Hiding refs) = " hiding " <> refsList refs
208  refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")"
209
210  showRef :: P.DeclarationRef -> Maybe Text
211  showRef (P.TypeRef _ pn dctors) =
212    Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")"
213  showRef (P.TypeOpRef _ op) =
214    Just $ "type " <> N.showOp op
215  showRef (P.ValueRef _ ident) =
216    Just $ N.runIdent ident
217  showRef (P.ValueOpRef _ op) =
218    Just $ N.showOp op
219  showRef (P.TypeClassRef _ pn) =
220    Just $ "class " <> N.runProperName pn
221  showRef (P.TypeInstanceRef _ ident P.UserNamed) =
222    Just $ N.runIdent ident
223  showRef (P.TypeInstanceRef _ _ P.CompilerNamed) =
224    Nothing
225  showRef (P.ModuleRef _ name) =
226    Just $ "module " <> N.runModuleName name
227  showRef (P.ReExportRef _ _ _) =
228    Nothing
229
230  commaList :: [Text] -> Text
231  commaList = T.intercalate ", "
232
233handleShowPrint
234  :: (MonadState PSCiState m, MonadIO m)
235  => (String -> m ())
236  -> m ()
237handleShowPrint print' = do
238  current <- psciInteractivePrint <$> get
239  if current == initialInteractivePrint
240    then
241      print' $
242        "The interactive print function is currently set to the default (`" ++ showPrint current ++ "`)"
243    else
244      print' $
245        "The interactive print function is currently set to `" ++ showPrint current ++ "`\n" ++
246        "The default can be restored with `:print " ++ showPrint initialInteractivePrint ++ "`"
247
248  where
249  showPrint (mn, ident) = T.unpack (N.runModuleName mn <> "." <> N.runIdent ident)
250
251-- | Imports a module, preserving the initial state on failure.
252handleImport
253  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
254  => ImportedModule
255  -> m ()
256handleImport im = do
257   st <- gets (updateImportedModules (im :))
258   let m = createTemporaryModuleForImports st
259   e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
260   case e of
261     Left errs -> printErrors errs
262     Right _  -> put st
263
264-- | Takes a value and prints its type
265handleTypeOf
266  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
267  => (String -> m ())
268  -> P.Expr
269  -> m ()
270handleTypeOf print' val = do
271  st <- get
272  let m = createTemporaryModule False st val
273  e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
274  case e of
275    Left errs -> printErrors errs
276    Right (_, env') ->
277      case M.lookup (P.mkQualified (P.Ident "it") (P.ModuleName "$PSCI")) (P.names env') of
278        Just (ty, _, _) -> print' . P.prettyPrintType maxBound $ ty
279        Nothing -> print' "Could not find type"
280
281-- | Takes a type and prints its kind
282handleKindOf
283  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
284  => (String -> m ())
285  -> P.SourceType
286  -> m ()
287handleKindOf print' typ = do
288  st <- get
289  let m = createTemporaryModuleForKind st typ
290      mName = P.ModuleName "$PSCI"
291  e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
292  case e of
293    Left errs -> printErrors errs
294    Right (_, env') ->
295      case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
296        Just (_, typ') -> do
297          let chk = (P.emptyCheckState env') { P.checkCurrentModule = Just mName }
298              k   = check (snd <$> P.kindOf typ') chk
299
300              check :: StateT P.CheckState (ExceptT P.MultipleErrors (Writer P.MultipleErrors)) a -> P.CheckState -> Either P.MultipleErrors (a, P.CheckState)
301              check sew = fst . runWriter . runExceptT . runStateT sew
302          case k of
303            Left err        -> printErrors err
304            Right (kind, _) -> print' . P.prettyPrintType 1024 $ kind
305        Nothing -> print' "Could not find kind"
306
307-- | Browse a module and displays its signature
308handleBrowse
309  :: (MonadReader PSCiConfig m, MonadState PSCiState m, MonadIO m)
310  => (String -> m ())
311  -> P.ModuleName
312  -> m ()
313handleBrowse print' moduleName = do
314  st <- get
315  let env = psciEnvironment st
316  case findMod moduleName (psciLoadedExterns st) (psciImportedModules st) of
317    Just qualName -> print' $ printModuleSignatures qualName env
318    Nothing       -> failNotInEnv moduleName
319  where
320    findMod needle externs imports =
321      let qualMod = fromMaybe needle (lookupUnQualifiedModName needle imports)
322          modules = S.fromList (C.primModules <> (P.getModuleName . fst <$> externs))
323      in if qualMod `S.member` modules
324           then Just qualMod
325           else Nothing
326
327    failNotInEnv modName = print' $ T.unpack $ "Module '" <> N.runModuleName modName <> "' is not valid."
328    lookupUnQualifiedModName needle imports =
329        (\(modName,_,_) -> modName) <$> find (\(_,_,mayQuaName) -> mayQuaName == Just needle) imports
330
331-- | Return output as would be returned by tab completion, for tools integration etc.
332handleComplete
333  :: (MonadState PSCiState m, MonadIO m)
334  => (String -> m ())
335  -> String
336  -> m ()
337handleComplete print' prefix = do
338  st <- get
339  let act = liftCompletionM (completion' (reverse prefix, ""))
340  results <- evalStateT act st
341  print' $ unlines (formatCompletions results)
342
343-- | Attempt to set the interactive print function. Note that the state will
344-- only be updated if the interactive print function exists and appears to
345-- work; we test it by attempting to evaluate '0'.
346handleSetInteractivePrint
347  :: (MonadState PSCiState m, MonadIO m)
348  => (String -> m ())
349  -> (P.ModuleName, P.Ident)
350  -> m ()
351handleSetInteractivePrint print' new = do
352  current <- gets psciInteractivePrint
353  modify (setInteractivePrint new)
354  st <- get
355  let expr = P.Literal internalSpan (P.NumericLiteral (Left 0))
356  let m = createTemporaryModule True st expr
357  e <- liftIO . runMake $ rebuild (map snd (psciLoadedExterns st)) m
358  case e of
359    Left errs -> do
360      modify (setInteractivePrint current)
361      print' "Unable to set the repl's printing function:"
362      printErrors errs
363    Right _ ->
364      pure ()
365