{-# LANGUAGE QuasiQuotes #-}

-- | @futhark repl@
module Futhark.CLI.REPL (main) where

import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Free.Church
import Control.Monad.State
import Data.Char
import Data.List (intersperse)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Version
import Futhark.Compiler
import Futhark.MonadFreshNames
import Futhark.Util (fancyTerminal)
import Futhark.Util.Options
import Futhark.Util.Pretty (AnsiStyle, Color (..), Doc, align, annotate, bgColorDull, bold, brackets, color, docText, docTextForHandle, hardline, pretty, putDoc, putDocLn, unAnnotate, (<+>))
import Futhark.Version
import Language.Futhark
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Parser
import Language.Futhark.Semantic qualified as T
import Language.Futhark.TypeChecker qualified as T
import NeatInterpolation (text)
import System.Console.Haskeline qualified as Haskeline
import System.Directory
import System.IO (stdout)
import Text.Read (readMaybe)

banner :: Doc AnsiStyle
 =
  forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
decorate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall a b. (a -> b) -> a -> b
$
    [ Text
"┃╱╱ ┃╲    ┃   ┃╲  ┃╲   ╱" :: T.Text,
      Text
"┃╱  ┃ ╲   ┃╲  ┃╲  ┃╱  ╱ ",
      Text
"┃   ┃  ╲  ┃╱  ┃   ┃╲  ╲ ",
      Text
"┃   ┃   ╲ ┃   ┃   ┃ ╲  ╲"
    ]
  where
    decorate :: Doc AnsiStyle -> Doc AnsiStyle
decorate = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
bgColorDull Color
Red forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White)

-- | Run @futhark repl@.
main :: String -> [String] -> IO ()
main :: [Char] -> [[Char]] -> IO ()
main = forall cfg.
cfg
-> [FunOptDescr cfg]
-> [Char]
-> ([[Char]] -> cfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
mainWithOptions () [] [Char]
"options... [program.fut]" forall {p}. [[Char]] -> p -> Maybe (IO ())
run
  where
    run :: [[Char]] -> p -> Maybe (IO ())
run [] p
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl forall a. Maybe a
Nothing
    run [[Char]
prog] p
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
prog
    run [[Char]]
_ p
_ = forall a. Maybe a
Nothing

data StopReason = EOF | Stop | Exit | Load FilePath | Interrupt

repl :: Maybe FilePath -> IO ()
repl :: Maybe [Char] -> IO ()
repl Maybe [Char]
maybe_prog = do
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancyTerminal forall a b. (a -> b) -> a -> b
$ do
    Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
banner
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Version " forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version forall a. [a] -> [a] -> [a]
++ [Char]
"."
    [Char] -> IO ()
putStrLn [Char]
"Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
    [Char] -> IO ()
putStrLn [Char]
""
    Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Run" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold Doc AnsiStyle
":help" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"for a list of commands."
    [Char] -> IO ()
putStrLn [Char]
""

  let toploop :: FutharkiState -> InputT IO ()
toploop FutharkiState
s = do
        (Either StopReason Any
stop, FutharkiState
s') <-
          forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
Haskeline.handleInterrupt (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left StopReason
Interrupt, FutharkiState
s))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Haskeline.withInterrupt
            forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint) FutharkiState
s

        case Either StopReason Any
stop of
          Left StopReason
Stop -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
          Left StopReason
EOF -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
          Left StopReason
Exit -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
          Left StopReason
Interrupt -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Interrupted"
            FutharkiState -> InputT IO ()
toploop FutharkiState
s' {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s' forall a. Num a => a -> a -> a
+ Int
1}
          Left (Load [Char]
file) -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Loading " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
file
            Either (Doc AnsiStyle) FutharkiState
maybe_new_state <-
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState (FutharkiState -> Int
futharkiCount FutharkiState
s) (FutharkiState -> LoadedProg
futharkiProg FutharkiState
s) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
file
            case Either (Doc AnsiStyle) FutharkiState
maybe_new_state of
              Right FutharkiState
new_state -> FutharkiState -> InputT IO ()
toploop FutharkiState
new_state
              Left Doc AnsiStyle
err -> do
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn Doc AnsiStyle
err
                FutharkiState -> InputT IO ()
toploop FutharkiState
s'
          Right Any
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      finish :: FutharkiState -> InputT IO ()
finish FutharkiState
s = do
        Bool
quit <- if Bool
fancyTerminal then InputT IO Bool
confirmQuit else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        if Bool
quit then forall (f :: * -> *) a. Applicative f => a -> f a
pure () else FutharkiState -> InputT IO ()
toploop FutharkiState
s

  Either (Doc AnsiStyle) FutharkiState
maybe_init_state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg Maybe [Char]
maybe_prog
  FutharkiState
s <- case Either (Doc AnsiStyle) FutharkiState
maybe_init_state of
    Left Doc AnsiStyle
prog_err -> do
      Either (Doc AnsiStyle) FutharkiState
noprog_init_state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg forall a. Maybe a
Nothing
      case Either (Doc AnsiStyle) FutharkiState
noprog_init_state of
        Left Doc AnsiStyle
err ->
          forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to initialise interpreter state: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (forall a. Doc a -> Text
docText Doc AnsiStyle
err)
        Right FutharkiState
s -> do
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
prog_err
          forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s {futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_prog}
    Right FutharkiState
s ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s
  forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Haskeline.runInputT forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings forall a b. (a -> b) -> a -> b
$ FutharkiState -> InputT IO ()
toploop FutharkiState
s

  [Char] -> IO ()
putStrLn [Char]
"Leaving 'futhark repl'."

confirmQuit :: Haskeline.InputT IO Bool
confirmQuit :: InputT IO Bool
confirmQuit = do
  Maybe Char
c <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe Char)
Haskeline.getInputChar [Char]
"Quit REPL? (y/n) "
  case Maybe Char
c of
    Maybe Char
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- EOF
    Just Char
'y' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just Char
'n' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Maybe Char
_ -> InputT IO Bool
confirmQuit

-- | Representation of breaking at a breakpoint, to allow for
-- navigating through the stack frames and such.
data Breaking = Breaking
  { Breaking -> NonEmpty StackFrame
breakingStack :: NE.NonEmpty I.StackFrame,
    -- | Index of the current breakpoint (with
    -- 0 being the outermost).
    Breaking -> Int
breakingAt :: Int
  }

data FutharkiState = FutharkiState
  { FutharkiState -> LoadedProg
futharkiProg :: LoadedProg,
    FutharkiState -> Int
futharkiCount :: Int,
    FutharkiState -> (Env, Ctx)
futharkiEnv :: (T.Env, I.Ctx),
    -- | Are we currently stopped at a breakpoint?
    FutharkiState -> Maybe Breaking
futharkiBreaking :: Maybe Breaking,
    -- | Skip breakpoints at these locations.
    FutharkiState -> [Loc]
futharkiSkipBreaks :: [Loc],
    FutharkiState -> Bool
futharkiBreakOnNaN :: Bool,
    -- | The currently loaded file.
    FutharkiState -> Maybe [Char]
futharkiLoaded :: Maybe FilePath
  }

extendEnvs :: LoadedProg -> (T.Env, I.Ctx) -> [ImportName] -> (T.Env, I.Ctx)
extendEnvs :: LoadedProg -> (Env, Ctx) -> [ImportName] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env
tenv, Ctx
ictx) [ImportName]
opens = (Env
tenv', Ctx
ictx')
  where
    tenv' :: Env
tenv' = Imports -> Env -> Env
T.envWithImports Imports
t_imports Env
tenv
    ictx' :: Ctx
ictx' = [Env] -> Ctx -> Ctx
I.ctxWithImports [Env]
i_envs Ctx
ictx
    t_imports :: Imports
t_imports = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
opens) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports LoadedProg
prog
    i_envs :: [Env]
i_envs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
opens) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ Ctx -> Map ImportName Env
I.ctxImports Ctx
ictx

newFutharkiState :: Int -> LoadedProg -> Maybe FilePath -> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState :: Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
count LoadedProg
prev_prog Maybe [Char]
maybe_file = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
  let files :: [[Char]]
files = forall a. Maybe a -> [a]
maybeToList Maybe [Char]
maybe_file
  -- Put code through the type checker.
  LoadedProg
prog <-
    forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors
      forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
reloadProg LoadedProg
prev_prog [[Char]]
files forall k a. Map k a
M.empty)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ Warnings -> Doc AnsiStyle
prettyWarnings forall a b. (a -> b) -> a -> b
$ LoadedProg -> Warnings
lpWarnings LoadedProg
prog
  -- Then into the interpreter.
  Ctx
ictx <-
    forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (\Ctx
ctx -> forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (ImportName, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx)
      Ctx
I.initialCtx
      forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Prog
fileProg) (LoadedProg -> Imports
lpImports LoadedProg
prog)

  let (Env
tenv, Ctx
ienv) =
        let (ImportName
iname, FileModule
fm) = forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports LoadedProg
prog
         in ( FileModule -> Env
fileScope FileModule
fm,
              Ctx
ictx {ctxEnv :: Env
I.ctxEnv = Ctx -> Map ImportName Env
I.ctxImports Ctx
ictx forall k a. Ord k => Map k a -> k -> a
M.! ImportName
iname}
            )

  forall (f :: * -> *) a. Applicative f => a -> f a
pure
    FutharkiState
      { futharkiProg :: LoadedProg
futharkiProg = LoadedProg
prog,
        futharkiCount :: Int
futharkiCount = Int
count,
        futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ienv),
        futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. Maybe a
Nothing,
        futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = forall a. Monoid a => a
mempty,
        futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool
False,
        futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_file
      }
  where
    badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a
    badOnLeft :: forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft err -> err'
_ (Right a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    badOnLeft err -> err'
p (Left err
err) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ err -> err'
p err
err

getPrompt :: FutharkiM String
getPrompt :: FutharkiM [Char]
getPrompt = do
  Int
i <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Int
futharkiCount
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO Text
docTextForHandle Handle
stdout forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
brackets (forall a ann. Pretty a => a -> Doc ann
pretty Int
i) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"> "

-- The ExceptT part is more of a continuation, really.
newtype FutharkiM a = FutharkiM {forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM :: ExceptT StopReason (StateT FutharkiState (Haskeline.InputT IO)) a}
  deriving
    ( forall a b. a -> FutharkiM b -> FutharkiM a
forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FutharkiM b -> FutharkiM a
$c<$ :: forall a b. a -> FutharkiM b -> FutharkiM a
fmap :: forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
$cfmap :: forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
Functor,
      Functor FutharkiM
forall a. a -> FutharkiM a
forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
$c<* :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
*> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
$c*> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
liftA2 :: forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
<*> :: forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
$c<*> :: forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
pure :: forall a. a -> FutharkiM a
$cpure :: forall a. a -> FutharkiM a
Applicative,
      Applicative FutharkiM
forall a. a -> FutharkiM a
forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> FutharkiM a
$creturn :: forall a. a -> FutharkiM a
>> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
$c>> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
>>= :: forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
$c>>= :: forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
Monad,
      MonadState FutharkiState,
      Monad FutharkiM
forall a. IO a -> FutharkiM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> FutharkiM a
$cliftIO :: forall a. IO a -> FutharkiM a
MonadIO,
      MonadError StopReason
    )

readEvalPrint :: FutharkiM ()
readEvalPrint :: FutharkiM ()
readEvalPrint = do
  [Char]
prompt <- FutharkiM [Char]
getPrompt
  Text
line <- [Char] -> FutharkiM Text
inputLine [Char]
prompt
  Maybe Breaking
breaking <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe Breaking
futharkiBreaking
  case Text -> Maybe (Char, Text)
T.uncons Text
line of
    Maybe (Char, Text)
Nothing
      | forall a. Maybe a -> Bool
isJust Maybe Breaking
breaking -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop
      | Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Just (Char
':', Text
command) -> do
      let (Text
cmdname, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
command
          arg :: Text
arg = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
rest
      case forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
cmdname `T.isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, (Command, Text))]
commands of
        [] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Unknown command '" forall a. Semigroup a => a -> a -> a
<> Text
cmdname forall a. Semigroup a => a -> a -> a
<> Text
"'"
        [(Text
_, (Command
cmdf, Text
_))] -> Command
cmdf Text
arg
        [(Text, (Command, Text))]
matches ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$
            Text
"Ambiguous command; could be one of "
              forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, (Command, Text))]
matches))
    Maybe (Char, Text)
_ -> do
      -- Read a declaration or expression.
      Either SyntaxError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e <- forall (m :: * -> *).
Monad m =>
m Text
-> [Char]
-> Text
-> m (Either SyntaxError (Either UncheckedDec UncheckedExp))
parseDecOrExpIncrM ([Char] -> FutharkiM Text
inputLine [Char]
"  ") [Char]
prompt Text
line

      case Either SyntaxError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e of
        Left (SyntaxError Loc
_ Text
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
err
        Right (Left UncheckedDec
d) -> UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d
        Right (Right UncheckedExp
e) -> UncheckedExp -> FutharkiM ()
onExp UncheckedExp
e
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s forall a. Num a => a -> a -> a
+ Int
1}
  where
    inputLine :: [Char] -> FutharkiM Text
inputLine [Char]
prompt = do
      Maybe [Char]
inp <- forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe [Char])
Haskeline.getInputLine [Char]
prompt
      case Maybe [Char]
inp of
        Just [Char]
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
s
        Maybe [Char]
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
EOF

getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx)
getIt :: FutharkiM (Imports, VNameSource, Env, Ctx)
getIt = do
  Imports
imports <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
  VNameSource
src <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ LoadedProg -> VNameSource
lpNameSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
  (Env
tenv, Ctx
ienv) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv)

onDec :: UncheckedDec -> FutharkiM ()
onDec :: UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d = do
  Imports
old_imports <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
  ImportName
cur_import <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ [Char] -> ImportName
T.mkInitialImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [Char]
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe [Char]
futharkiLoaded
  let mkImport :: [Char] -> ImportName
mkImport = ImportName -> [Char] -> ImportName
T.mkImportFrom ImportName
cur_import
      files :: [[Char]]
files = forall a b. (a -> b) -> [a] -> [b]
map (ImportName -> [Char]
T.includeToFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImportName
mkImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. DecBase f vn -> [([Char], Loc)]
decImports UncheckedDec
d

  LoadedProg
cur_prog <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> LoadedProg
futharkiProg
  Either (NonEmpty ProgError) LoadedProg
imp_r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
extendProg LoadedProg
cur_prog [[Char]]
files forall k a. Map k a
M.empty
  case Either (NonEmpty ProgError) LoadedProg
imp_r of
    Left NonEmpty ProgError
e -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors NonEmpty ProgError
e
    Right LoadedProg
prog -> do
      (Env, Ctx)
env <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
      let (Env
tenv, Ctx
ienv) =
            LoadedProg -> (Env, Ctx) -> [ImportName] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env, Ctx)
env forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> ImportName
T.mkInitialImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. DecBase f vn -> [([Char], Loc)]
decImports UncheckedDec
d
          imports :: Imports
imports = LoadedProg -> Imports
lpImports LoadedProg
prog
          src :: VNameSource
src = LoadedProg -> VNameSource
lpNameSource LoadedProg
prog
      case Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src Env
tenv ImportName
cur_import UncheckedDec
d of
        (Warnings
_, Left TypeError
e) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
e
        (Warnings
_, Right (Env
tenv', Dec
d', VNameSource
src')) -> do
          let new_imports :: Imports
new_imports =
                forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst Imports
old_imports) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Imports
imports
          Either InterpreterError Ctx
int_r <- forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter forall a b. (a -> b) -> a -> b
$ do
            let onImport :: Ctx -> (ImportName, FileModule) -> F ExtOp Ctx
onImport Ctx
ienv' (ImportName
s, FileModule
imp) =
                  Ctx -> (ImportName, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ienv' (ImportName
s, FileModule -> Prog
T.fileProg FileModule
imp)
            Ctx
ienv' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Ctx -> (ImportName, FileModule) -> F ExtOp Ctx
onImport Ctx
ienv Imports
new_imports
            Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv' Dec
d'
          case Either InterpreterError Ctx
int_r of
            Left InterpreterError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print InterpreterError
err
            Right Ctx
ienv' -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
              FutharkiState
s
                { futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv', Ctx
ienv'),
                  futharkiProg :: LoadedProg
futharkiProg = LoadedProg
prog {lpNameSource :: VNameSource
lpNameSource = VNameSource
src'}
                }

onExp :: UncheckedExp -> FutharkiM ()
onExp :: UncheckedExp -> FutharkiM ()
onExp UncheckedExp
e = do
  (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
  case Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp Imports
imports VNameSource
src Env
tenv UncheckedExp
e of
    (Warnings
_, Left TypeError
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
    (Warnings
_, Right ([TypeParam]
tparams, Exp
e'))
      | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
tparams -> do
          Either InterpreterError Value
r <- forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter forall a b. (a -> b) -> a -> b
$ Ctx -> Exp -> F ExtOp Value
I.interpretExp Ctx
ienv Exp
e'
          case Either InterpreterError Value
r of
            Left InterpreterError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print InterpreterError
err
            Right Value
v -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue Value
v forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
      | Bool
otherwise -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Inferred type of expression: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (Exp -> PatType
typeOf Exp
e')
          Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$
            Text
"The following types are ambiguous: "
              forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Text
nameToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsName v => v -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vn. TypeParamBase vn -> vn
typeParamName) [TypeParam]
tparams)

prettyBreaking :: Breaking -> T.Text
prettyBreaking :: Breaking -> Text
prettyBreaking Breaking
b =
  Int -> [Text] -> Text
prettyStacktrace (Breaking -> Int
breakingAt Breaking
b) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a => a -> Text
locText forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ Breaking -> NonEmpty StackFrame
breakingStack Breaking
b

-- Are we currently willing to break for this reason?  Among othe
-- things, we do not want recursive breakpoints.  It could work fine
-- technically, but is probably too confusing to be useful.
breakForReason :: FutharkiState -> I.StackFrame -> I.BreakReason -> Bool
breakForReason :: FutharkiState -> StackFrame -> BreakReason -> Bool
breakForReason FutharkiState
s StackFrame
_ BreakReason
I.BreakNaN
  | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s = Bool
False
breakForReason FutharkiState
s StackFrame
top BreakReason
_ =
  forall a. Maybe a -> Bool
isNothing (FutharkiState -> Maybe Breaking
futharkiBreaking FutharkiState
s)
    Bool -> Bool -> Bool
&& forall a. Located a => a -> Loc
locOf StackFrame
top forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s

runInterpreter :: F I.ExtOp a -> FutharkiM (Either I.InterpreterError a)
runInterpreter :: forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter F ExtOp a
m = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) forall {b}.
ExtOp (FutharkiM (Either InterpreterError b))
-> FutharkiM (Either InterpreterError b)
intOp
  where
    intOp :: ExtOp (FutharkiM (Either InterpreterError b))
-> FutharkiM (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) =
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left InterpreterError
err
    intOp (I.ExtOpTrace Text
w Doc ()
v FutharkiM (Either InterpreterError b)
c) = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
w forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
v
      FutharkiM (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
w BreakReason
why NonEmpty StackFrame
callstack FutharkiM (Either InterpreterError b)
c) = do
      FutharkiState
s <- forall s (m :: * -> *). MonadState s m => m s
get

      let why' :: Text
why' = case BreakReason
why of
            BreakReason
I.BreakPoint -> Text
"Breakpoint"
            BreakReason
I.BreakNaN -> Text
"NaN produced"
          top :: StackFrame
top = forall a. NonEmpty a -> a
NE.head NonEmpty StackFrame
callstack
          ctx :: Ctx
ctx = StackFrame -> Ctx
I.stackFrameCtx StackFrame
top
          tenv :: Env
tenv = Env -> Env
I.typeCheckerEnv forall a b. (a -> b) -> a -> b
$ Ctx -> Env
I.ctxEnv Ctx
ctx
          breaking :: Breaking
breaking = NonEmpty StackFrame -> Int -> Breaking
Breaking NonEmpty StackFrame
callstack Int
0

      -- Are we supposed to respect this breakpoint?
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkiState -> StackFrame -> BreakReason -> Bool
breakForReason FutharkiState
s StackFrame
top BreakReason
why) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
why' forall a. Semigroup a => a -> a -> a
<> Text
" at " forall a. Semigroup a => a -> a -> a
<> forall a. Located a => a -> Text
locText Loc
w
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Breaking -> Text
prettyBreaking Breaking
breaking
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"<Enter> to continue."

        -- Note the cleverness to preserve the Haskeline session (for
        -- line history and such).
        (Either StopReason Any
stop, FutharkiState
s') <-
          forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
            forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
              (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint)
              FutharkiState
s
                { futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
                  futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s forall a. Num a => a -> a -> a
+ Int
1,
                  futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. a -> Maybe a
Just Breaking
breaking
                }

        case Either StopReason Any
stop of
          Left (Load [Char]
file) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load [Char]
file
          Either StopReason Any
_ -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Continuing..."
            forall s (m :: * -> *). MonadState s m => s -> m ()
put
              FutharkiState
s
                { futharkiCount :: Int
futharkiCount =
                    FutharkiState -> Int
futharkiCount FutharkiState
s',
                  futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks =
                    FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s' forall a. Semigroup a => a -> a -> a
<> FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s,
                  futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN =
                    FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s'
                }

      FutharkiM (Either InterpreterError b)
c

runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a)
runInterpreterNoBreak :: forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak F ExtOp a
m = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) forall {f :: * -> *} {b}.
MonadIO f =>
ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp
  where
    intOp :: ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left InterpreterError
err
    intOp (I.ExtOpTrace Text
w Doc ()
v f (Either InterpreterError b)
c) = do
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
w forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
v)
      f (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
_ BreakReason
_ NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c

type Command = T.Text -> FutharkiM ()

loadCommand :: Command
loadCommand :: Command
loadCommand Text
file = do
  Maybe [Char]
loaded <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe [Char]
futharkiLoaded
  case (Text -> Bool
T.null Text
file, Maybe [Char]
loaded) of
    (Bool
True, Just [Char]
loaded') -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load [Char]
loaded'
    (Bool
True, Maybe [Char]
Nothing) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"No file specified and no file previously loaded."
    (Bool
False, Maybe [Char]
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
file

genTypeCommand ::
  (String -> T.Text -> Either SyntaxError a) ->
  (Imports -> VNameSource -> T.Env -> a -> (Warnings, Either T.TypeError b)) ->
  (b -> String) ->
  Command
genTypeCommand :: forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError a
f Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g b -> [Char]
h Text
e = do
  [Char]
prompt <- FutharkiM [Char]
getPrompt
  case [Char] -> Text -> Either SyntaxError a
f [Char]
prompt Text
e of
    Left (SyntaxError Loc
_ Text
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
err
    Right a
e' -> do
      (Imports
imports, VNameSource
src, Env
tenv, Ctx
_) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
      case forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g Imports
imports VNameSource
src Env
tenv a
e' of
        Left TypeError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
        Right b
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ b -> [Char]
h b
x

typeCommand :: Command
typeCommand :: Command
typeCommand = forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError UncheckedExp
parseExp Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp forall a b. (a -> b) -> a -> b
$ \([TypeParam]
ps, Exp
e) ->
  forall a. Pretty a => a -> [Char]
prettyString Exp
e
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char]
" " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
prettyString) [TypeParam]
ps
    forall a. Semigroup a => a -> a -> a
<> [Char]
" : "
    forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettyString (Exp -> PatType
typeOf Exp
e)

mtypeCommand :: Command
mtypeCommand :: Command
mtypeCommand = forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError (ModExpBase NoInfo Name)
parseModExp Imports
-> VNameSource
-> Env
-> ModExpBase NoInfo Name
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
T.checkModExp forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> [Char]
prettyString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst

unbreakCommand :: Command
unbreakCommand :: Command
unbreakCommand Text
_ = do
  Maybe StackFrame
top <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Breaking -> NonEmpty StackFrame
breakingStack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
  case Maybe StackFrame
top of
    Maybe StackFrame
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Not currently stopped at a breakpoint."
    Just StackFrame
top' -> do
      forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = forall a. Located a => a -> Loc
locOf StackFrame
top' forall a. a -> [a] -> [a]
: FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s}
      forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop

nanbreakCommand :: Command
nanbreakCommand :: Command
nanbreakCommand Text
_ = do
  forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s}
  Bool
b <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Bool
futharkiBreakOnNaN
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
    [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
      if Bool
b
        then [Char]
"Now treating NaNs as breakpoints."
        else [Char]
"No longer treating NaNs as breakpoints."

frameCommand :: Command
frameCommand :: Command
frameCommand Text
which = do
  Maybe (NonEmpty StackFrame)
maybe_stack <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Breaking -> NonEmpty StackFrame
breakingStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
  case (Maybe (NonEmpty StackFrame)
maybe_stack, forall a. Read a => [Char] -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
which) of
    (Just NonEmpty StackFrame
stack, Just Int
i)
      | StackFrame
frame : [StackFrame]
_ <- forall a. Int -> NonEmpty a -> [a]
NE.drop Int
i NonEmpty StackFrame
stack -> do
          let breaking :: Breaking
breaking = NonEmpty StackFrame -> Int -> Breaking
Breaking NonEmpty StackFrame
stack Int
i
              ctx :: Ctx
ctx = StackFrame -> Ctx
I.stackFrameCtx StackFrame
frame
              tenv :: Env
tenv = Env -> Env
I.typeCheckerEnv forall a b. (a -> b) -> a -> b
$ Ctx -> Env
I.ctxEnv Ctx
ctx
          forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
            FutharkiState
s
              { futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
                futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. a -> Maybe a
Just Breaking
breaking
              }
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Breaking -> Text
prettyBreaking Breaking
breaking
    (Just NonEmpty StackFrame
_, Maybe Int
_) ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid stack index: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
which
    (Maybe (NonEmpty StackFrame)
Nothing, Maybe Int
_) ->
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Not stopped at a breakpoint."

pwdCommand :: Command
pwdCommand :: Command
pwdCommand Text
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Char]
getCurrentDirectory

cdCommand :: Command
cdCommand :: Command
cdCommand Text
dir
  | Text -> Bool
T.null Text
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Usage: ':cd <dir>'."
  | Bool
otherwise =
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
        [Char] -> IO ()
setCurrentDirectory (Text -> [Char]
T.unpack Text
dir)
          forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
err :: IOException) -> forall a. Show a => a -> IO ()
print IOException
err

helpCommand :: Command
helpCommand :: Command
helpCommand Text
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, (Command, Text))]
commands forall a b. (a -> b) -> a -> b
$ \(Text
cmd, (Command
_, Text
desc)) -> do
    Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
":" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
cmd forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Int
1 forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
cmd) Text
"─"
    Text -> IO ()
T.putStr Text
desc
    Text -> IO ()
T.putStrLn Text
""
    Text -> IO ()
T.putStrLn Text
""

quitCommand :: Command
quitCommand :: Command
quitCommand Text
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Exit

commands :: [(T.Text, (Command, T.Text))]
commands :: [(Text, (Command, Text))]
commands =
  [ ( Text
"load",
      ( Command
loadCommand,
        [text|
Load a Futhark source file.  Usage:

  > :load foo.fut

If the loading succeeds, any expressions entered subsequently can use the
declarations in the source file.

Only one source file can be loaded at a time.  Using the :load command a
second time will replace the previously loaded file.  It will also replace
any declarations entered at the REPL.

|]
      )
    ),
    ( Text
"type",
      ( Command
typeCommand,
        [text|
Show the type of an expression, which must fit on a single line.
|]
      )
    ),
    ( Text
"mtype",
      ( Command
mtypeCommand,
        [text|
Show the type of a module expression, which must fit on a single line.
|]
      )
    ),
    ( Text
"unbreak",
      ( Command
unbreakCommand,
        [text|
Skip all future occurences of the current breakpoint.
|]
      )
    ),
    ( Text
"nanbreak",
      ( Command
nanbreakCommand,
        [text|
Toggle treating operators that produce new NaNs as breakpoints.  We consider a NaN
to be "new" if none of the arguments to the operator in question is a NaN.
|]
      )
    ),
    ( Text
"frame",
      ( Command
frameCommand,
        [text|
While at a break point, jump to another stack frame, whose variables can then
be inspected.  Resuming from the breakpoint will jump back to the innermost
stack frame.
|]
      )
    ),
    ( Text
"pwd",
      ( Command
pwdCommand,
        [text|
Print the current working directory.
|]
      )
    ),
    ( Text
"cd",
      ( Command
cdCommand,
        [text|
Change the current working directory.
|]
      )
    ),
    ( Text
"help",
      ( Command
helpCommand,
        [text|
Print a list of commands and a description of their behaviour.
|]
      )
    ),
    ( Text
"quit",
      ( Command
quitCommand,
        [text|
Exit REPL.
|]
      )
    )
  ]