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