{-# 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.Format (parseFormatString)
import Futhark.MonadFreshNames
import Futhark.Util (fancyTerminal, showText)
import Futhark.Util.Options
import Futhark.Util.Pretty (AnsiStyle, Color (..), Doc, align, annotate, bgColorDull, bold, brackets, color, docText, docTextForHandle, hardline, italicized, oneLine, 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
banner :: Doc AnsiStyle
banner =
  [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat ([Doc AnsiStyle] -> Doc AnsiStyle)
-> ([Text] -> [Doc AnsiStyle]) -> [Text] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Doc AnsiStyle) -> [Text] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map ((Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline) (Doc AnsiStyle -> Doc AnsiStyle)
-> (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
decorate (Doc AnsiStyle -> Doc AnsiStyle)
-> (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty) ([Text] -> Doc AnsiStyle) -> [Text] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
    [ Text
"┃╱╱ ┃╲    ┃   ┃╲  ┃╲   ╱" :: T.Text,
      Text
"┃╱  ┃ ╲   ┃╲  ┃╲  ┃╱  ╱ ",
      Text
"┃   ┃  ╲  ┃╱  ┃   ┃╲  ╲ ",
      Text
"┃   ┃   ╲ ┃   ┃   ┃ ╲  ╲"
    ]
  where
    decorate :: Doc AnsiStyle -> Doc AnsiStyle
decorate = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
bgColorDull Color
Red AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White)

-- | Run @futhark repl@.
main :: String -> [String] -> IO ()
main :: [Char] -> [[Char]] -> IO ()
main = ()
-> [FunOptDescr ()]
-> [Char]
-> ([[Char]] -> () -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> [Char]
-> ([[Char]] -> cfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
mainWithOptions () [] [Char]
"options... [program.fut]" [[Char]] -> () -> Maybe (IO ())
forall {p}. [[Char]] -> p -> Maybe (IO ())
run
  where
    run :: [[Char]] -> p -> Maybe (IO ())
run [] p
_ = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl Maybe [Char]
forall a. Maybe a
Nothing
    run [[Char]
prog] p
_ = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl (Maybe [Char] -> IO ()) -> Maybe [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
prog
    run [[Char]]
_ p
_ = Maybe (IO ())
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
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancyTerminal (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
banner
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Version " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version [Char] -> [Char] -> [Char]
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 (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Run" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold Doc AnsiStyle
":help" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
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') <-
          InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
Haskeline.handleInterrupt ((Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StopReason -> Either StopReason Any
forall a b. a -> Either a b
Left StopReason
Interrupt, FutharkiState
s))
            (InputT IO (Either StopReason Any, FutharkiState)
 -> InputT IO (Either StopReason Any, FutharkiState))
-> (InputT IO (Either StopReason Any, FutharkiState)
    -> InputT IO (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Haskeline.withInterrupt
            (InputT IO (Either StopReason Any, FutharkiState)
 -> InputT IO (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall a b. (a -> b) -> a -> b
$ StateT FutharkiState (InputT IO) (Either StopReason Any)
-> FutharkiState
-> InputT IO (Either StopReason Any, FutharkiState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
 -> StateT FutharkiState (InputT IO) (Either StopReason Any))
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall a b. (a -> b) -> a -> b
$ FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM (FutharkiM Any
 -> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any)
-> FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a b. (a -> b) -> a -> b
$ FutharkiM () -> FutharkiM Any
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
            IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
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' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
          Left (Load [Char]
file) -> do
            IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Loading " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
file
            Either (Doc AnsiStyle) FutharkiState
maybe_new_state <-
              IO (Either (Doc AnsiStyle) FutharkiState)
-> InputT IO (Either (Doc AnsiStyle) FutharkiState)
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Doc AnsiStyle) FutharkiState)
 -> InputT IO (Either (Doc AnsiStyle) FutharkiState))
-> IO (Either (Doc AnsiStyle) FutharkiState)
-> InputT IO (Either (Doc AnsiStyle) FutharkiState)
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) (Maybe [Char] -> IO (Either (Doc AnsiStyle) FutharkiState))
-> Maybe [Char] -> IO (Either (Doc AnsiStyle) FutharkiState)
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
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
                IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn Doc AnsiStyle
err
                FutharkiState -> InputT IO ()
toploop FutharkiState
s'
          Right Any
_ -> () -> InputT IO ()
forall a. a -> InputT IO a
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 Bool -> InputT IO Bool
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        if Bool
quit then () -> InputT IO ()
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure () else FutharkiState -> InputT IO ()
toploop FutharkiState
s

  Either (Doc AnsiStyle) FutharkiState
maybe_init_state <- IO (Either (Doc AnsiStyle) FutharkiState)
-> IO (Either (Doc AnsiStyle) FutharkiState)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Doc AnsiStyle) FutharkiState)
 -> IO (Either (Doc AnsiStyle) FutharkiState))
-> IO (Either (Doc AnsiStyle) FutharkiState)
-> IO (Either (Doc AnsiStyle) FutharkiState)
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 <- IO (Either (Doc AnsiStyle) FutharkiState)
-> IO (Either (Doc AnsiStyle) FutharkiState)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (Doc AnsiStyle) FutharkiState)
 -> IO (Either (Doc AnsiStyle) FutharkiState))
-> IO (Either (Doc AnsiStyle) FutharkiState)
-> IO (Either (Doc AnsiStyle) FutharkiState)
forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg Maybe [Char]
forall a. Maybe a
Nothing
      case Either (Doc AnsiStyle) FutharkiState
noprog_init_state of
        Left Doc AnsiStyle
err ->
          [Char] -> IO FutharkiState
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO FutharkiState) -> [Char] -> IO FutharkiState
forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to initialise interpreter state: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (Doc AnsiStyle -> Text
forall a. Doc a -> Text
docText Doc AnsiStyle
err)
        Right FutharkiState
s -> do
          IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
prog_err
          FutharkiState -> IO FutharkiState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s {futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_prog}
    Right FutharkiState
s ->
      FutharkiState -> IO FutharkiState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s
  Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Haskeline.runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings (InputT IO () -> IO ()) -> InputT IO () -> IO ()
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 <- [Char] -> InputT IO (Maybe Char)
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 -> Bool -> InputT IO Bool
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True -- EOF
    Just Char
'y' -> Bool -> InputT IO Bool
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just Char
'n' -> Bool -> InputT IO Bool
forall a. a -> InputT IO a
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 = ((ImportName, FileModule) -> Bool) -> Imports -> Imports
forall a. (a -> Bool) -> [a] -> [a]
filter ((ImportName -> [ImportName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
opens) (ImportName -> Bool)
-> ((ImportName, FileModule) -> ImportName)
-> (ImportName, FileModule)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, FileModule) -> ImportName
forall a b. (a, b) -> a
fst) (Imports -> Imports) -> Imports -> Imports
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports LoadedProg
prog
    i_envs :: [Env]
i_envs = ((ImportName, Env) -> Env) -> [(ImportName, Env)] -> [Env]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName, Env) -> Env
forall a b. (a, b) -> b
snd ([(ImportName, Env)] -> [Env]) -> [(ImportName, Env)] -> [Env]
forall a b. (a -> b) -> a -> b
$ ((ImportName, Env) -> Bool)
-> [(ImportName, Env)] -> [(ImportName, Env)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((ImportName -> [ImportName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
opens) (ImportName -> Bool)
-> ((ImportName, Env) -> ImportName) -> (ImportName, Env) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, Env) -> ImportName
forall a b. (a, b) -> a
fst) ([(ImportName, Env)] -> [(ImportName, Env)])
-> [(ImportName, Env)] -> [(ImportName, Env)]
forall a b. (a -> b) -> a -> b
$ Map ImportName Env -> [(ImportName, Env)]
forall k a. Map k a -> [(k, a)]
M.toList (Map ImportName Env -> [(ImportName, Env)])
-> Map ImportName Env -> [(ImportName, Env)]
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 = ExceptT (Doc AnsiStyle) IO FutharkiState
-> IO (Either (Doc AnsiStyle) FutharkiState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Doc AnsiStyle) IO FutharkiState
 -> IO (Either (Doc AnsiStyle) FutharkiState))
-> ExceptT (Doc AnsiStyle) IO FutharkiState
-> IO (Either (Doc AnsiStyle) FutharkiState)
forall a b. (a -> b) -> a -> b
$ do
  let files :: [[Char]]
files = Maybe [Char] -> [[Char]]
forall a. Maybe a -> [a]
maybeToList Maybe [Char]
maybe_file
  -- Put code through the type checker.
  LoadedProg
prog <-
    (NonEmpty ProgError -> Doc AnsiStyle)
-> Either (NonEmpty ProgError) LoadedProg
-> ExceptT (Doc AnsiStyle) IO LoadedProg
forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors
      (Either (NonEmpty ProgError) LoadedProg
 -> ExceptT (Doc AnsiStyle) IO LoadedProg)
-> ExceptT
     (Doc AnsiStyle) IO (Either (NonEmpty ProgError) LoadedProg)
-> ExceptT (Doc AnsiStyle) IO LoadedProg
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either (NonEmpty ProgError) LoadedProg)
-> ExceptT
     (Doc AnsiStyle) IO (Either (NonEmpty ProgError) LoadedProg)
forall a. IO a -> ExceptT (Doc AnsiStyle) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
reloadProg LoadedProg
prev_prog [[Char]]
files VFS
forall k a. Map k a
M.empty)
  IO () -> ExceptT (Doc AnsiStyle) IO ()
forall a. IO a -> ExceptT (Doc AnsiStyle) IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT (Doc AnsiStyle) IO ())
-> IO () -> ExceptT (Doc AnsiStyle) IO ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Warnings -> Doc AnsiStyle
prettyWarnings (Warnings -> Doc AnsiStyle) -> Warnings -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Warnings
lpWarnings LoadedProg
prog
  -- Then into the interpreter.
  Ctx
ictx <-
    (Ctx -> (ImportName, Prog) -> ExceptT (Doc AnsiStyle) IO Ctx)
-> Ctx -> [(ImportName, Prog)] -> ExceptT (Doc AnsiStyle) IO Ctx
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
      (\Ctx
ctx -> (InterpreterError -> Doc AnsiStyle)
-> Either InterpreterError Ctx -> ExceptT (Doc AnsiStyle) IO Ctx
forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft ([Char] -> Doc AnsiStyle
forall ann. [Char] -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Char] -> Doc AnsiStyle)
-> (InterpreterError -> [Char])
-> InterpreterError
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show) (Either InterpreterError Ctx -> ExceptT (Doc AnsiStyle) IO Ctx)
-> ((ImportName, Prog)
    -> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx))
-> (ImportName, Prog)
-> ExceptT (Doc AnsiStyle) IO Ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< F ExtOp Ctx
-> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak (F ExtOp Ctx
 -> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx))
-> ((ImportName, Prog) -> F ExtOp Ctx)
-> (ImportName, Prog)
-> ExceptT (Doc AnsiStyle) IO (Either InterpreterError Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (ImportName, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx)
      Ctx
I.initialCtx
      ([(ImportName, Prog)] -> ExceptT (Doc AnsiStyle) IO Ctx)
-> [(ImportName, Prog)] -> ExceptT (Doc AnsiStyle) IO Ctx
forall a b. (a -> b) -> a -> b
$ ((ImportName, FileModule) -> (ImportName, Prog))
-> Imports -> [(ImportName, Prog)]
forall a b. (a -> b) -> [a] -> [b]
map ((FileModule -> Prog)
-> (ImportName, FileModule) -> (ImportName, Prog)
forall a b. (a -> b) -> (ImportName, a) -> (ImportName, b)
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) = Imports -> (ImportName, FileModule)
forall a. HasCallStack => [a] -> a
last (Imports -> (ImportName, FileModule))
-> Imports -> (ImportName, FileModule)
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 Map ImportName Env -> ImportName -> Env
forall k a. Ord k => Map k a -> k -> a
M.! ImportName
iname}
            )

  FutharkiState -> ExceptT (Doc AnsiStyle) IO FutharkiState
forall a. a -> ExceptT (Doc AnsiStyle) IO a
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 = Maybe Breaking
forall a. Maybe a
Nothing,
        futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = [Loc]
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) = a -> ExceptT err' IO a
forall a. a -> ExceptT err' IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    badOnLeft err -> err'
p (Left err
err) = err' -> ExceptT err' IO a
forall a. err' -> ExceptT err' IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (err' -> ExceptT err' IO a) -> err' -> ExceptT err' IO a
forall a b. (a -> b) -> a -> b
$ err -> err'
p err
err

getPrompt :: FutharkiM String
getPrompt :: FutharkiM [Char]
getPrompt = do
  Int
i <- (FutharkiState -> Int) -> FutharkiM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Int
futharkiCount
  (Text -> [Char]) -> FutharkiM Text -> FutharkiM [Char]
forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack (FutharkiM Text -> FutharkiM [Char])
-> FutharkiM Text -> FutharkiM [Char]
forall a b. (a -> b) -> a -> b
$ IO Text -> FutharkiM Text
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> FutharkiM Text) -> IO Text -> FutharkiM Text
forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO Text
docTextForHandle Handle
stdout (Doc AnsiStyle -> IO Text) -> Doc AnsiStyle -> IO Text
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
brackets (Int -> Doc AnsiStyle
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Int
i) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
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 -> b) -> FutharkiM a -> FutharkiM b)
-> (forall a b. a -> FutharkiM b -> FutharkiM a)
-> Functor FutharkiM
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
$cfmap :: forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
fmap :: forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
$c<$ :: forall a b. a -> FutharkiM b -> FutharkiM a
<$ :: forall a b. a -> FutharkiM b -> FutharkiM a
Functor,
      Functor FutharkiM
Functor FutharkiM
-> (forall a. a -> FutharkiM a)
-> (forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b)
-> (forall a b c.
    (a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c)
-> (forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b)
-> (forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a)
-> Applicative 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
$cpure :: forall a. a -> FutharkiM a
pure :: forall a. a -> FutharkiM a
$c<*> :: forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
<*> :: forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
liftA2 :: forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
$c*> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
*> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
$c<* :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
<* :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
Applicative,
      Applicative FutharkiM
Applicative FutharkiM
-> (forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b)
-> (forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b)
-> (forall a. a -> FutharkiM a)
-> Monad 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
$c>>= :: forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
>>= :: forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
$c>> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
>> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
$creturn :: forall a. a -> FutharkiM a
return :: forall a. a -> FutharkiM a
Monad,
      MonadState FutharkiState,
      Monad FutharkiM
Monad FutharkiM
-> (forall a. IO a -> FutharkiM a) -> MonadIO FutharkiM
forall a. IO a -> FutharkiM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> FutharkiM a
liftIO :: 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 <- (FutharkiState -> Maybe Breaking) -> FutharkiM (Maybe 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
      | Maybe Breaking -> Bool
forall a. Maybe a -> Bool
isJust Maybe Breaking
breaking -> StopReason -> FutharkiM ()
forall a. StopReason -> FutharkiM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop
      | Bool
otherwise -> () -> FutharkiM ()
forall a. a -> FutharkiM a
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
rest
      case ((Text, (Command, Text)) -> Bool)
-> [(Text, (Command, Text))] -> [(Text, (Command, Text))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
cmdname `T.isPrefixOf`) (Text -> Bool)
-> ((Text, (Command, Text)) -> Text)
-> (Text, (Command, Text))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (Command, Text)) -> Text
forall a b. (a, b) -> a
fst) [(Text, (Command, Text))]
commands of
        [] -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Unknown command '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmdname Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"'"
        [(Text
_, (Command
cmdf, Text
_))] -> Command
cmdf Text
arg
        [(Text, (Command, Text))]
matches ->
          IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> (Text -> IO ()) -> Command
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStrLn Command -> Command
forall a b. (a -> b) -> a -> b
$
            Text
"Ambiguous command; could be one of "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " (((Text, (Command, Text)) -> Text)
-> [(Text, (Command, Text))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, (Command, Text)) -> Text
forall a b. (a, b) -> a
fst [(Text, (Command, Text))]
matches))
    Maybe (Char, Text)
_ -> do
      -- Read a declaration or expression.
      case [Char]
-> Text -> Either SyntaxError (Either UncheckedDec UncheckedExp)
parseDecOrExp [Char]
prompt Text
line of
        Left (SyntaxError Loc
_ Text
err) -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
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) -> do
          Either (Doc AnsiStyle) Value
valOrErr <- UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value)
onExp UncheckedExp
e
          case Either (Doc AnsiStyle) Value
valOrErr of
            Left Doc AnsiStyle
err -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn Doc AnsiStyle
err
            Right Value
val -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Value -> Doc AnsiStyle
forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue Value
val
  (FutharkiState -> FutharkiState) -> FutharkiM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkiState -> FutharkiState) -> FutharkiM ())
-> (FutharkiState -> FutharkiState) -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
  where
    inputLine :: [Char] -> FutharkiM Text
inputLine [Char]
prompt = do
      Maybe [Char]
inp <- ExceptT
  StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
-> FutharkiM (Maybe [Char])
forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM (ExceptT
   StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
 -> FutharkiM (Maybe [Char]))
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
-> FutharkiM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ StateT FutharkiState (InputT IO) (Maybe [Char])
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
forall (m :: * -> *) a. Monad m => m a -> ExceptT StopReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT FutharkiState (InputT IO) (Maybe [Char])
 -> ExceptT
      StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char]))
-> StateT FutharkiState (InputT IO) (Maybe [Char])
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ InputT IO (Maybe [Char])
-> StateT FutharkiState (InputT IO) (Maybe [Char])
forall (m :: * -> *) a. Monad m => m a -> StateT FutharkiState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO (Maybe [Char])
 -> StateT FutharkiState (InputT IO) (Maybe [Char]))
-> InputT IO (Maybe [Char])
-> StateT FutharkiState (InputT IO) (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> InputT IO (Maybe [Char])
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe [Char])
Haskeline.getInputLine [Char]
prompt
      case Maybe [Char]
inp of
        Just [Char]
s -> Text -> FutharkiM Text
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FutharkiM Text) -> Text -> FutharkiM Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
s
        Maybe [Char]
Nothing -> StopReason -> FutharkiM Text
forall a. StopReason -> FutharkiM a
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 <- (FutharkiState -> Imports) -> FutharkiM Imports
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> Imports) -> FutharkiM Imports)
-> (FutharkiState -> Imports) -> FutharkiM Imports
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports (LoadedProg -> Imports)
-> (FutharkiState -> LoadedProg) -> FutharkiState -> Imports
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
  VNameSource
src <- (FutharkiState -> VNameSource) -> FutharkiM VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> VNameSource) -> FutharkiM VNameSource)
-> (FutharkiState -> VNameSource) -> FutharkiM VNameSource
forall a b. (a -> b) -> a -> b
$ LoadedProg -> VNameSource
lpNameSource (LoadedProg -> VNameSource)
-> (FutharkiState -> LoadedProg) -> FutharkiState -> VNameSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
  (Env
tenv, Ctx
ienv) <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
  (Imports, VNameSource, Env, Ctx)
-> FutharkiM (Imports, VNameSource, Env, Ctx)
forall a. a -> FutharkiM a
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 <- (FutharkiState -> Imports) -> FutharkiM Imports
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> Imports) -> FutharkiM Imports)
-> (FutharkiState -> Imports) -> FutharkiM Imports
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports (LoadedProg -> Imports)
-> (FutharkiState -> LoadedProg) -> FutharkiState -> Imports
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
  ImportName
cur_import <- (FutharkiState -> ImportName) -> FutharkiM ImportName
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> ImportName) -> FutharkiM ImportName)
-> (FutharkiState -> ImportName) -> FutharkiM ImportName
forall a b. (a -> b) -> a -> b
$ [Char] -> ImportName
T.mkInitialImport ([Char] -> ImportName)
-> (FutharkiState -> [Char]) -> FutharkiState -> ImportName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"." (Maybe [Char] -> [Char])
-> (FutharkiState -> Maybe [Char]) -> FutharkiState -> [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 = (([Char], Loc) -> [Char]) -> [([Char], Loc)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName -> [Char]
T.includeToFilePath (ImportName -> [Char])
-> (([Char], Loc) -> ImportName) -> ([Char], Loc) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImportName
mkImport ([Char] -> ImportName)
-> (([Char], Loc) -> [Char]) -> ([Char], Loc) -> ImportName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Loc) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], Loc)] -> [[Char]]) -> [([Char], Loc)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UncheckedDec -> [([Char], Loc)]
forall (f :: * -> *) vn. DecBase f vn -> [([Char], Loc)]
decImports UncheckedDec
d

  LoadedProg
cur_prog <- (FutharkiState -> LoadedProg) -> FutharkiM LoadedProg
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> LoadedProg
futharkiProg
  Either (NonEmpty ProgError) LoadedProg
imp_r <- IO (Either (NonEmpty ProgError) LoadedProg)
-> FutharkiM (Either (NonEmpty ProgError) LoadedProg)
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (NonEmpty ProgError) LoadedProg)
 -> FutharkiM (Either (NonEmpty ProgError) LoadedProg))
-> IO (Either (NonEmpty ProgError) LoadedProg)
-> FutharkiM (Either (NonEmpty ProgError) LoadedProg)
forall a b. (a -> b) -> a -> b
$ LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
extendProg LoadedProg
cur_prog [[Char]]
files VFS
forall k a. Map k a
M.empty
  case Either (NonEmpty ProgError) LoadedProg
imp_r of
    Left NonEmpty ProgError
e -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors NonEmpty ProgError
e
    Right LoadedProg
prog -> do
      (Env, Ctx)
env <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
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 ([ImportName] -> (Env, Ctx)) -> [ImportName] -> (Env, Ctx)
forall a b. (a -> b) -> a -> b
$ (([Char], Loc) -> ImportName) -> [([Char], Loc)] -> [ImportName]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> ImportName
T.mkInitialImport ([Char] -> ImportName)
-> (([Char], Loc) -> [Char]) -> ([Char], Loc) -> ImportName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Loc) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], Loc)] -> [ImportName])
-> [([Char], Loc)] -> [ImportName]
forall a b. (a -> b) -> a -> b
$ UncheckedDec -> [([Char], Loc)]
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) -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
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 =
                ((ImportName, FileModule) -> Bool) -> Imports -> Imports
forall a. (a -> Bool) -> [a] -> [a]
filter ((ImportName -> [ImportName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ((ImportName, FileModule) -> ImportName) -> Imports -> [ImportName]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName, FileModule) -> ImportName
forall a b. (a, b) -> a
fst Imports
old_imports) (ImportName -> Bool)
-> ((ImportName, FileModule) -> ImportName)
-> (ImportName, FileModule)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ImportName, FileModule) -> ImportName
forall a b. (a, b) -> a
fst) Imports
imports
          Either InterpreterError Ctx
int_r <- F ExtOp Ctx -> FutharkiM (Either InterpreterError Ctx)
forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter (F ExtOp Ctx -> FutharkiM (Either InterpreterError Ctx))
-> F ExtOp Ctx -> FutharkiM (Either InterpreterError Ctx)
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' <- (Ctx -> (ImportName, FileModule) -> F ExtOp Ctx)
-> Ctx -> Imports -> F ExtOp Ctx
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 -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ InterpreterError -> IO ()
forall a. Show a => a -> IO ()
print InterpreterError
err
            Right Ctx
ienv' -> (FutharkiState -> FutharkiState) -> FutharkiM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkiState -> FutharkiState) -> FutharkiM ())
-> (FutharkiState -> FutharkiState) -> FutharkiM ()
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 (Either (Doc AnsiStyle) I.Value)
onExp :: UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value)
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], ExpBase Info VName))
T.checkExp Imports
imports VNameSource
src Env
tenv UncheckedExp
e of
    (Warnings
_, Left TypeError
err) -> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc AnsiStyle) Value
 -> FutharkiM (Either (Doc AnsiStyle) Value))
-> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Either (Doc AnsiStyle) Value
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) Value)
-> Doc AnsiStyle -> Either (Doc AnsiStyle) Value
forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
    (Warnings
_, Right ([TypeParam]
tparams, ExpBase Info VName
e'))
      | [TypeParam] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
tparams -> do
          Either InterpreterError Value
r <- F ExtOp Value -> FutharkiM (Either InterpreterError Value)
forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter (F ExtOp Value -> FutharkiM (Either InterpreterError Value))
-> F ExtOp Value -> FutharkiM (Either InterpreterError Value)
forall a b. (a -> b) -> a -> b
$ Ctx -> ExpBase Info VName -> F ExtOp Value
I.interpretExp Ctx
ienv ExpBase Info VName
e'
          case Either InterpreterError Value
r of
            Left InterpreterError
err -> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc AnsiStyle) Value
 -> FutharkiM (Either (Doc AnsiStyle) Value))
-> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> Either (Doc AnsiStyle) Value
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) Value)
-> Doc AnsiStyle -> Either (Doc AnsiStyle) Value
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (Text -> Doc AnsiStyle) -> Text -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Text
forall a. Show a => a -> Text
showText InterpreterError
err
            Right Value
v -> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc AnsiStyle) Value
 -> FutharkiM (Either (Doc AnsiStyle) Value))
-> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a b. (a -> b) -> a -> b
$ Value -> Either (Doc AnsiStyle) Value
forall a b. b -> Either a b
Right Value
v
      | Bool
otherwise ->
          Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Doc AnsiStyle) Value
 -> FutharkiM (Either (Doc AnsiStyle) Value))
-> Either (Doc AnsiStyle) Value
-> FutharkiM (Either (Doc AnsiStyle) Value)
forall a b. (a -> b) -> a -> b
$
            Doc AnsiStyle -> Either (Doc AnsiStyle) Value
forall a b. a -> Either a b
Left (Doc AnsiStyle -> Either (Doc AnsiStyle) Value)
-> Doc AnsiStyle -> Either (Doc AnsiStyle) Value
forall a b. (a -> b) -> a -> b
$
              (Doc AnsiStyle
"Inferred type of expression: " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align (StructType -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. StructType -> Doc ann
pretty (ExpBase Info VName -> StructType
typeOf ExpBase Info VName
e')))
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty
                  ( Text
"The following types are ambiguous: "
                      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate
                        Text
", "
                        ((TypeParam -> Text) -> [TypeParam] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Text
nameToText (Name -> Text) -> (TypeParam -> Name) -> TypeParam -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. VName -> Name
forall v. IsName v => v -> Name
toName (VName -> Name) -> (TypeParam -> VName) -> TypeParam -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName) [TypeParam]
tparams)
                  )
                Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline

prettyBreaking :: Breaking -> T.Text
prettyBreaking :: Breaking -> Text
prettyBreaking Breaking
b =
  Int -> [Text] -> Text
prettyStacktrace (Breaking -> Int
breakingAt Breaking
b) ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (StackFrame -> Text) -> [StackFrame] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map StackFrame -> Text
forall a. Located a => a -> Text
locText ([StackFrame] -> [Text]) -> [StackFrame] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty StackFrame -> [StackFrame]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty StackFrame -> [StackFrame])
-> NonEmpty StackFrame -> [StackFrame]
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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s = Bool
False
breakForReason FutharkiState
s StackFrame
top BreakReason
_ =
  Maybe Breaking -> Bool
forall a. Maybe a -> Bool
isNothing (FutharkiState -> Maybe Breaking
futharkiBreaking FutharkiState
s)
    Bool -> Bool -> Bool
&& StackFrame -> Loc
forall a. Located a => a -> Loc
locOf StackFrame
top Loc -> [Loc] -> Bool
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 = F ExtOp a -> forall r. (a -> r) -> (ExtOp r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (Either InterpreterError a -> FutharkiM (Either InterpreterError a)
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError a
 -> FutharkiM (Either InterpreterError a))
-> (a -> Either InterpreterError a)
-> a
-> FutharkiM (Either InterpreterError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either InterpreterError a
forall a b. b -> Either a b
Right) ExtOp (FutharkiM (Either InterpreterError a))
-> FutharkiM (Either InterpreterError a)
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) =
      Either InterpreterError b -> FutharkiM (Either InterpreterError b)
forall a. a -> FutharkiM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b
 -> FutharkiM (Either InterpreterError b))
-> Either InterpreterError b
-> FutharkiM (Either InterpreterError b)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left InterpreterError
err
    intOp (I.ExtOpTrace Text
w Doc ()
v FutharkiM (Either InterpreterError b)
c) = do
      IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
w Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc () -> Doc AnsiStyle
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 <- FutharkiM FutharkiState
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 = NonEmpty StackFrame -> StackFrame
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 (Env -> Env) -> Env -> Env
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?
      Bool -> FutharkiM () -> FutharkiM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkiState -> StackFrame -> BreakReason -> Bool
breakForReason FutharkiState
s StackFrame
top BreakReason
why) (FutharkiM () -> FutharkiM ()) -> FutharkiM () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
why' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" at " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Loc -> Text
forall a. Located a => a -> Text
locText Loc
w
        IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Breaking -> Text
prettyBreaking Breaking
breaking
        IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
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') <-
          ExceptT
  StopReason
  (StateT FutharkiState (InputT IO))
  (Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState)
forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM (ExceptT
   StopReason
   (StateT FutharkiState (InputT IO))
   (Either StopReason Any, FutharkiState)
 -> FutharkiM (Either StopReason Any, FutharkiState))
-> (InputT IO (Either StopReason Any, FutharkiState)
    -> ExceptT
         StopReason
         (StateT FutharkiState (InputT IO))
         (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT
  FutharkiState (InputT IO) (Either StopReason Any, FutharkiState)
-> ExceptT
     StopReason
     (StateT FutharkiState (InputT IO))
     (Either StopReason Any, FutharkiState)
forall (m :: * -> *) a. Monad m => m a -> ExceptT StopReason m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
   FutharkiState (InputT IO) (Either StopReason Any, FutharkiState)
 -> ExceptT
      StopReason
      (StateT FutharkiState (InputT IO))
      (Either StopReason Any, FutharkiState))
-> (InputT IO (Either StopReason Any, FutharkiState)
    -> StateT
         FutharkiState (InputT IO) (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> ExceptT
     StopReason
     (StateT FutharkiState (InputT IO))
     (Either StopReason Any, FutharkiState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT IO (Either StopReason Any, FutharkiState)
-> StateT
     FutharkiState (InputT IO) (Either StopReason Any, FutharkiState)
forall (m :: * -> *) a. Monad m => m a -> StateT FutharkiState m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO (Either StopReason Any, FutharkiState)
 -> FutharkiM (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState)
forall a b. (a -> b) -> a -> b
$
            StateT FutharkiState (InputT IO) (Either StopReason Any)
-> FutharkiState
-> InputT IO (Either StopReason Any, FutharkiState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
              (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
 -> StateT FutharkiState (InputT IO) (Either StopReason Any))
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall a b. (a -> b) -> a -> b
$ FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM (FutharkiM Any
 -> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any)
-> FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a b. (a -> b) -> a -> b
$ FutharkiM () -> FutharkiM Any
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
                  futharkiBreaking :: Maybe Breaking
futharkiBreaking = Breaking -> Maybe Breaking
forall a. a -> Maybe a
Just Breaking
breaking
                }

        case Either StopReason Any
stop of
          Left (Load [Char]
file) -> StopReason -> FutharkiM ()
forall a. StopReason -> FutharkiM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StopReason -> FutharkiM ()) -> StopReason -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load [Char]
file
          Either StopReason Any
_ -> do
            IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Continuing..."
            FutharkiState -> FutharkiM ()
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' [Loc] -> [Loc] -> [Loc]
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 = F ExtOp a -> forall r. (a -> r) -> (ExtOp r -> r) -> r
forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (Either InterpreterError a -> m (Either InterpreterError a)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError a -> m (Either InterpreterError a))
-> (a -> Either InterpreterError a)
-> a
-> m (Either InterpreterError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either InterpreterError a
forall a b. b -> Either a b
Right) ExtOp (m (Either InterpreterError a))
-> m (Either InterpreterError a)
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) = Either InterpreterError b -> f (Either InterpreterError b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> f (Either InterpreterError b))
-> Either InterpreterError b -> f (Either InterpreterError b)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left InterpreterError
err
    intOp (I.ExtOpTrace Text
w Doc ()
v f (Either InterpreterError b)
c) = do
      IO () -> f ()
forall a. IO a -> f a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
w Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
align (Doc () -> Doc AnsiStyle
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 <- (FutharkiState -> Maybe [Char]) -> FutharkiM (Maybe [Char])
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') -> StopReason -> FutharkiM ()
forall a. StopReason -> FutharkiM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StopReason -> FutharkiM ()) -> StopReason -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load [Char]
loaded'
    (Bool
True, Maybe [Char]
Nothing) -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"No file specified and no file previously loaded."
    (Bool
False, Maybe [Char]
_) -> StopReason -> FutharkiM ()
forall a. StopReason -> FutharkiM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StopReason -> FutharkiM ()) -> StopReason -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load ([Char] -> StopReason) -> [Char] -> StopReason
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 -> Doc AnsiStyle) ->
  Command
genTypeCommand :: forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError a
f Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g b -> Doc AnsiStyle
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) -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
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 (Warnings, Either TypeError b) -> Either TypeError b
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError b) -> Either TypeError b)
-> (Warnings, Either TypeError b) -> Either TypeError b
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 -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
        Right b
x -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ b -> Doc AnsiStyle
h b
x

typeCommand :: Command
typeCommand :: Command
typeCommand = ([Char] -> Text -> Either SyntaxError UncheckedExp)
-> (Imports
    -> VNameSource
    -> Env
    -> UncheckedExp
    -> (Warnings, Either TypeError ([TypeParam], ExpBase Info VName)))
-> (([TypeParam], ExpBase Info VName) -> Doc AnsiStyle)
-> Command
forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError UncheckedExp
parseExp Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], ExpBase Info VName))
T.checkExp ((([TypeParam], ExpBase Info VName) -> Doc AnsiStyle) -> Command)
-> (([TypeParam], ExpBase Info VName) -> Doc AnsiStyle) -> Command
forall a b. (a -> b) -> a -> b
$ \([TypeParam]
ps, ExpBase Info VName
e) ->
  Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann
oneLine (StructType -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. StructType -> Doc ann
pretty (ExpBase Info VName -> StructType
typeOf ExpBase Info VName
e))
    Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> if Bool -> Bool
not ([TypeParam] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
ps)
      then
        AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
italicized (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle
"\n\nPolymorphic in"
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Doc ann -> Doc ann -> Doc ann
<+> [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat (Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a. a -> [a] -> [a]
intersperse Doc AnsiStyle
" " ([Doc AnsiStyle] -> [Doc AnsiStyle])
-> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall a b. (a -> b) -> a -> b
$ (TypeParam -> Doc AnsiStyle) -> [TypeParam] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map TypeParam -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. TypeParam -> Doc ann
pretty [TypeParam]
ps)
            Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"."
      else Doc AnsiStyle
forall a. Monoid a => a
mempty

mtypeCommand :: Command
mtypeCommand :: Command
mtypeCommand = ([Char] -> Text -> Either SyntaxError (ModExpBase NoInfo Name))
-> (Imports
    -> VNameSource
    -> Env
    -> ModExpBase NoInfo Name
    -> (Warnings, Either TypeError (MTy, ModExpBase Info VName)))
-> ((MTy, ModExpBase Info VName) -> Doc AnsiStyle)
-> Command
forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> 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 (((MTy, ModExpBase Info VName) -> Doc AnsiStyle) -> Command)
-> ((MTy, ModExpBase Info VName) -> Doc AnsiStyle) -> Command
forall a b. (a -> b) -> a -> b
$ MTy -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. MTy -> Doc ann
pretty (MTy -> Doc AnsiStyle)
-> ((MTy, ModExpBase Info VName) -> MTy)
-> (MTy, ModExpBase Info VName)
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (MTy, ModExpBase Info VName) -> MTy
forall a b. (a, b) -> a
fst

formatCommand :: Command
formatCommand :: Command
formatCommand Text
input = do
  case Text -> Either Text [Either Text Text]
parseFormatString Text
input of
    Left Text
err -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
err
    Right [Either Text Text]
parts -> do
      [Char]
prompt <- FutharkiM [Char]
getPrompt
      case (Either Text Text -> Either SyntaxError (Either Text UncheckedExp))
-> [Either Text Text]
-> Either SyntaxError [Either Text UncheckedExp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Text -> Either SyntaxError UncheckedExp)
-> Either Text Text
-> Either SyntaxError (Either Text UncheckedExp)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Either Text a -> f (Either Text b)
traverse ((Text -> Either SyntaxError UncheckedExp)
 -> Either Text Text
 -> Either SyntaxError (Either Text UncheckedExp))
-> (Text -> Either SyntaxError UncheckedExp)
-> Either Text Text
-> Either SyntaxError (Either Text UncheckedExp)
forall a b. (a -> b) -> a -> b
$ [Char] -> Text -> Either SyntaxError UncheckedExp
parseExp [Char]
prompt) [Either Text Text]
parts of
        Left (SyntaxError Loc
_ Text
err) ->
          IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStr Text
err
        Right [Either Text UncheckedExp]
parts' -> do
          Either (Doc AnsiStyle) [Either Text Value]
parts'' <- (Either Text (Either (Doc AnsiStyle) Value)
 -> Either (Doc AnsiStyle) (Either Text Value))
-> [Either Text (Either (Doc AnsiStyle) Value)]
-> Either (Doc AnsiStyle) [Either Text Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Either Text (Either (Doc AnsiStyle) Value)
-> Either (Doc AnsiStyle) (Either Text Value)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
Either Text (f a) -> f (Either Text a)
sequenceA ([Either Text (Either (Doc AnsiStyle) Value)]
 -> Either (Doc AnsiStyle) [Either Text Value])
-> FutharkiM [Either Text (Either (Doc AnsiStyle) Value)]
-> FutharkiM (Either (Doc AnsiStyle) [Either Text Value])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Either Text UncheckedExp
 -> FutharkiM (Either Text (Either (Doc AnsiStyle) Value)))
-> [Either Text UncheckedExp]
-> FutharkiM [Either Text (Either (Doc AnsiStyle) Value)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value))
-> Either Text UncheckedExp
-> FutharkiM (Either Text (Either (Doc AnsiStyle) Value))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Either Text a -> f (Either Text b)
traverse UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value)
onExp) [Either Text UncheckedExp]
parts'
          case Either (Doc AnsiStyle) [Either Text Value]
parts'' of
            Left Doc AnsiStyle
err -> IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
err
            Right [Either Text Value]
parts''' ->
              IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ())
-> ([Text] -> IO ()) -> [Text] -> FutharkiM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStrLn (Text -> IO ()) -> ([Text] -> Text) -> [Text] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> FutharkiM ()) -> [Text] -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$
                (Either Text Value -> Text) -> [Either Text Value] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text) -> (Value -> Text) -> Either Text Value -> Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> Text
forall a. a -> a
id (Doc Any -> Text
forall a. Doc a -> Text
docText (Doc Any -> Text) -> (Value -> Doc Any) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Doc Any
forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue)) [Either Text Value]
parts'''

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

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

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

helpCommand :: Command
helpCommand :: Command
helpCommand Text
_ = IO () -> FutharkiM ()
forall a. IO a -> FutharkiM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$
  [(Text, (Command, Text))]
-> ((Text, (Command, Text)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, (Command, Text))]
commands (((Text, (Command, Text)) -> IO ()) -> IO ())
-> ((Text, (Command, Text)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Text
cmd, (Command
_, Text
desc)) -> do
    Doc AnsiStyle -> IO ()
putDoc (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Text
cmd Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
    Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Int
1 Int -> Int -> Int
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
_ = StopReason -> FutharkiM ()
forall a. StopReason -> FutharkiM a
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
"format",
      ( Command
formatCommand,
        [text|
Use format strings to print arbitrary futhark expressions. Usage:

  > :format The value of foo: {foo}. The value of 2+2={2+2}
|]
      )
    ),
    ( 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 occurrences 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.
|]
      )
    )
  ]