-----------------------------------------------------------------------------

-----------------------------------------------------------------------------

-- |
-- Module      :  Disco.Interactive.CmdLine
-- Copyright   :  disco team and contributors
-- Maintainer  :  byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Definition of the command-line REPL interface for Disco.
module Disco.Interactive.CmdLine (
  -- * Command-line options record
  DiscoOpts (..),

  -- * optparse-applicative command line parsers
  discoOpts,
  discoInfo,

  -- * main
  discoMain,
) where

import Data.Version (showVersion)
import Paths_disco (version)

import Control.Lens hiding (use)
import Control.Monad (unless, when)
import qualified Control.Monad.Catch as CMC
import Control.Monad.IO.Class (MonadIO (..))
import Data.Foldable (forM_)
import Data.List (isPrefixOf)
import Data.Maybe (isJust)
import System.Exit (
  exitFailure,
  exitSuccess,
 )

import qualified Options.Applicative as O
import System.Console.Haskeline as H

import Disco.AST.Surface (emptyModule)
import Disco.Error
import Disco.Eval
import Disco.Interactive.Commands
import Disco.Messages
import Disco.Module (
  Resolver (FromStdlib),
  miExts,
 )
import Disco.Names (ModuleName (REPLModule))
import Disco.Pretty

import Disco.Effects.State
import Polysemy
import Polysemy.ConstraintAbsorber.MonadCatch
import Polysemy.Error

------------------------------------------------------------
-- Command-line options parser
------------------------------------------------------------

-- | Command-line options for disco.
data DiscoOpts = DiscoOpts
  { DiscoOpts -> Bool
onlyVersion :: Bool
  -- ^ Should we just print the version?
  , DiscoOpts -> Maybe String
evaluate :: Maybe String
  -- ^ A single expression to evaluate
  , DiscoOpts -> Maybe String
cmdFile :: Maybe String
  -- ^ Execute the commands in a given file
  , DiscoOpts -> Maybe String
checkFile :: Maybe String
  -- ^ Check a file and then exit
  , DiscoOpts -> Bool
debugFlag :: Bool
  }

discoOpts :: O.Parser DiscoOpts
discoOpts :: Parser DiscoOpts
discoOpts =
  Bool
-> Maybe String
-> Maybe String
-> Maybe String
-> Bool
-> DiscoOpts
DiscoOpts
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
O.switch
      ( forall a. Monoid a => [a] -> a
mconcat
          [ forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"version"
          , forall (f :: * -> *) a. HasName f => Char -> Mod f a
O.short Char
'v'
          , forall (f :: * -> *) a. String -> Mod f a
O.help String
"show current version"
          ]
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
O.optional
      ( forall s. IsString s => Mod OptionFields s -> Parser s
O.strOption
          ( forall a. Monoid a => [a] -> a
mconcat
              [ forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"evaluate"
              , forall (f :: * -> *) a. HasName f => Char -> Mod f a
O.short Char
'e'
              , forall (f :: * -> *) a. String -> Mod f a
O.help String
"evaluate an expression"
              , forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
O.metavar String
"TERM"
              ]
          )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
O.optional
      ( forall s. IsString s => Mod OptionFields s -> Parser s
O.strOption
          ( forall a. Monoid a => [a] -> a
mconcat
              [ forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"file"
              , forall (f :: * -> *) a. HasName f => Char -> Mod f a
O.short Char
'f'
              , forall (f :: * -> *) a. String -> Mod f a
O.help String
"execute the commands in a file"
              , forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
O.metavar String
"FILE"
              ]
          )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
O.optional
      ( forall s. IsString s => Mod OptionFields s -> Parser s
O.strOption
          ( forall a. Monoid a => [a] -> a
mconcat
              [ forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"check"
              , forall (f :: * -> *) a. String -> Mod f a
O.help String
"check a file without starting the interactive REPL"
              , forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
O.metavar String
"FILE"
              ]
          )
      )
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
O.switch
      ( forall a. Monoid a => [a] -> a
mconcat
          [ forall (f :: * -> *) a. HasName f => String -> Mod f a
O.long String
"debug"
          , forall (f :: * -> *) a. String -> Mod f a
O.help String
"print debugging information"
          , forall (f :: * -> *) a. HasName f => Char -> Mod f a
O.short Char
'd'
          ]
      )

discoVersion :: String
discoVersion :: String
discoVersion = Version -> String
showVersion Version
version

discoInfo :: O.ParserInfo DiscoOpts
discoInfo :: ParserInfo DiscoOpts
discoInfo =
  forall a. Parser a -> InfoMod a -> ParserInfo a
O.info (forall a. Parser (a -> a)
O.helper forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser DiscoOpts
discoOpts) forall a b. (a -> b) -> a -> b
$
    forall a. Monoid a => [a] -> a
mconcat
      [ forall a. InfoMod a
O.fullDesc
      , forall a. String -> InfoMod a
O.progDesc String
"Command-line interface for Disco, a programming language for discrete mathematics."
      , forall a. String -> InfoMod a
O.header forall a b. (a -> b) -> a -> b
$ String
"disco " forall a. [a] -> [a] -> [a]
++ String
discoVersion
      ]

optsToCfg :: DiscoOpts -> DiscoConfig
optsToCfg :: DiscoOpts -> DiscoConfig
optsToCfg DiscoOpts
opts = DiscoConfig
initDiscoConfig forall a b. a -> (a -> b) -> b
& Iso' DiscoConfig Bool
debugMode forall s t a b. ASetter s t a b -> b -> s -> t
.~ DiscoOpts -> Bool
debugFlag DiscoOpts
opts

------------------------------------------------------------
-- Command-line interface
------------------------------------------------------------

banner :: String
banner :: String
banner = String
"Welcome to Disco, version " forall a. [a] -> [a] -> [a]
++ String
discoVersion forall a. [a] -> [a] -> [a]
++ String
"!\n\nA language for programming discrete mathematics.\n\n"

discoMain :: IO ()
discoMain :: IO ()
discoMain = do
  DiscoOpts
opts <- forall a. ParserInfo a -> IO a
O.execParser ParserInfo DiscoOpts
discoInfo

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DiscoOpts -> Bool
onlyVersion DiscoOpts
opts) forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
putStrLn String
discoVersion
    forall a. IO a
exitSuccess

  let batch :: Bool
batch = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a. Maybe a -> Bool
isJust [DiscoOpts -> Maybe String
evaluate DiscoOpts
opts, DiscoOpts -> Maybe String
cmdFile DiscoOpts
opts, DiscoOpts -> Maybe String
checkFile DiscoOpts
opts]
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
batch forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStr String
banner
  DiscoConfig
-> (forall (r :: EffectRow). Members DiscoEffects r => Sem r ())
-> IO ()
runDisco (DiscoOpts -> DiscoConfig
optsToCfg DiscoOpts
opts) forall a b. (a -> b) -> a -> b
$ do
    -- Load an empty module just to force standard libraries to be loaded first
    ModuleInfo
_ <- forall ann (r :: EffectRow).
Members
  '[State TopInfo, Output (Message ann), Random, State Mem,
    Error DiscoError, Embed IO]
  r =>
Bool -> Resolver -> ModuleName -> Module -> Sem r ModuleInfo
loadParsedDiscoModule Bool
True Resolver
FromStdlib ModuleName
REPLModule Module
emptyModule

    case DiscoOpts -> Maybe String
checkFile DiscoOpts
opts of
      Just String
file -> do
        Bool
res <- forall (r :: EffectRow).
Members
  (Error DiscoError
     : State TopInfo : Output (Message ()) : Embed IO : EvalEffects)
  r =>
String -> Sem r Bool
handleLoad String
file
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ if Bool
res then forall a. IO a
exitSuccess else forall a. IO a
exitFailure
      Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case DiscoOpts -> Maybe String
cmdFile DiscoOpts
opts of
      Just String
file -> do
        Maybe String
mcmds <- forall ann (r :: EffectRow).
Members '[Output (Message ann), Embed IO] r =>
String -> Sem r (Maybe String)
loadFile String
file
        case Maybe String
mcmds of
          Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just String
cmds -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (r :: EffectRow).
Members DiscoEffects r =>
String -> Sem r ()
handleCMD (String -> [String]
lines String
cmds)
      Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (DiscoOpts -> Maybe String
evaluate DiscoOpts
opts) forall (r :: EffectRow).
Members DiscoEffects r =>
String -> Sem r ()
handleCMD
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
batch forall a b. (a -> b) -> a -> b
$ do
      forall (r :: EffectRow). Members DiscoEffects r => Sem r ()
loop
 where
  -- These types used to involve InputT Disco, but we now use Final
  -- (InputT IO) in the list of effects.  see
  -- https://github.com/polysemy-research/polysemy/issues/395 for
  -- inspiration.

  ctrlC :: MonadIO m => m a -> SomeException -> m a
  ctrlC :: forall (m :: * -> *) a. MonadIO m => m a -> SomeException -> m a
ctrlC m a
act SomeException
e = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print SomeException
e
    m a
act

  withCtrlC :: (MonadIO m, CMC.MonadCatch m) => m a -> m a -> m a
  withCtrlC :: forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m a -> m a
withCtrlC m a
resume m a
act = forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
CMC.catch m a
act (forall (m :: * -> *) a. MonadIO m => m a -> SomeException -> m a
ctrlC m a
resume)

  loop :: Members DiscoEffects r => Sem r ()
  loop :: forall (r :: EffectRow). Members DiscoEffects r => Sem r ()
loop = do
    Maybe String
minput <- forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m a -> m a
withCtrlC (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just String
"") (forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
"Disco> ")
    case Maybe String
minput of
      Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just String
input
        | String
":q" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
input Bool -> Bool -> Bool
&& String
input forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
":quit" -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"Goodbye!"
            forall (m :: * -> *) a. Monad m => a -> m a
return ()
        | String
":{" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
input -> do
            forall (r :: EffectRow).
Members DiscoEffects r =>
[String] -> Sem r ()
multiLineLoop []
            forall (r :: EffectRow). Members DiscoEffects r => Sem r ()
loop
        | Bool
otherwise -> do
            forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError @_ @DiscoError (String -> DiscoError
Panic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$
              forall (r :: EffectRow) a.
Member (Error SomeException) r =>
(MonadCatch (Sem r) => Sem r a) -> Sem r a
absorbMonadCatch forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m a -> m a
withCtrlC (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$
                  forall (r :: EffectRow).
Members DiscoEffects r =>
String -> Sem r ()
handleCMD String
input
            forall (r :: EffectRow). Members DiscoEffects r => Sem r ()
loop

  multiLineLoop :: Members DiscoEffects r => [String] -> Sem r ()
  multiLineLoop :: forall (r :: EffectRow).
Members DiscoEffects r =>
[String] -> Sem r ()
multiLineLoop [String]
ls = do
    Maybe String
minput <- forall (m :: * -> *) (r :: EffectRow) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
embedFinal forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m a -> m a
withCtrlC (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) (forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
String -> InputT m (Maybe String)
getInputLine String
"Disco| ")
    case Maybe String
minput of
      Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just String
input
        | String
":}" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
input -> do
            forall e1 e2 (r :: EffectRow) a.
Member (Error e2) r =>
(e1 -> e2) -> Sem (Error e1 : r) a -> Sem r a
mapError @_ @DiscoError (String -> DiscoError
Panic forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. (a -> b) -> a -> b
$
              forall (r :: EffectRow) a.
Member (Error SomeException) r =>
(MonadCatch (Sem r) => Sem r a) -> Sem r a
absorbMonadCatch forall a b. (a -> b) -> a -> b
$
                forall (m :: * -> *) a.
(MonadIO m, MonadCatch m) =>
m a -> m a -> m a
withCtrlC (forall (m :: * -> *) a. Monad m => a -> m a
return ()) forall a b. (a -> b) -> a -> b
$
                  forall (r :: EffectRow).
Members DiscoEffects r =>
String -> Sem r ()
handleCMD ([String] -> String
unlines (forall a. [a] -> [a]
reverse [String]
ls))
        | Bool
otherwise -> do
            forall (r :: EffectRow).
Members DiscoEffects r =>
[String] -> Sem r ()
multiLineLoop (String
input forall a. a -> [a] -> [a]
: [String]
ls)

-- | Parse and run the command corresponding to some REPL input.
handleCMD :: Members DiscoEffects r => String -> Sem r ()
handleCMD :: forall (r :: EffectRow).
Members DiscoEffects r =>
String -> Sem r ()
handleCMD String
"" = forall (m :: * -> *) a. Monad m => a -> m a
return ()
handleCMD String
s = do
  ExtSet
exts <- forall s (r :: EffectRow) a.
Member (State s) r =>
Getter s a -> Sem r a
use @TopInfo (Lens' TopInfo ModuleInfo
replModInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' ModuleInfo ExtSet
miExts)
  case REPLCommands -> ExtSet -> String -> Either String SomeREPLExpr
parseLine REPLCommands
discoCommands ExtSet
exts String
s of
    Left String
m -> forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
info (forall (m :: * -> *) ann. Applicative m => String -> m (Doc ann)
text String
m)
    Right SomeREPLExpr
l -> forall e (r :: EffectRow) a.
Member (Error e) r =>
Sem r a -> (e -> Sem r a) -> Sem r a
catch @DiscoError (forall (r :: EffectRow).
Members DiscoEffects r =>
REPLCommands -> SomeREPLExpr -> Sem r ()
dispatch REPLCommands
discoCommands SomeREPLExpr
l) (forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
info forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty')

-- The above has to be catch, not outputErrors, because
-- the latter won't resume afterwards.