{-# 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, isPrefixOf)
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.Encoding qualified as T
import Data.Text.IO qualified as T
import Data.Version
import Futhark.Compiler
import Futhark.Error (badOnLeft)
import Futhark.Eval
  ( EvalConfig (..),
    evalConfig,
    evalServerOptions,
    forceValue,
    initialiseInterpreter,
    runFFI,
  )
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.Interpreter.FFI.ServerM qualified as FFI
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 :: FilePath -> [FilePath] -> IO ()
main = EvalConfig
-> [FunOptDescr EvalConfig]
-> FilePath
-> ([FilePath] -> EvalConfig -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> FilePath
-> ([FilePath] -> cfg -> Maybe (IO ()))
-> FilePath
-> [FilePath]
-> IO ()
mainWithOptions EvalConfig
evalConfig [FunOptDescr EvalConfig]
evalServerOptions FilePath
"options... [program.fut]" [FilePath] -> EvalConfig -> Maybe (IO ())
run
  where
    run :: [FilePath] -> EvalConfig -> Maybe (IO ())
run [] EvalConfig
cfg = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ EvalConfig -> Maybe FilePath -> IO ()
repl EvalConfig
cfg Maybe FilePath
forall a. Maybe a
Nothing
    run [FilePath
prog] EvalConfig
cfg = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ EvalConfig -> Maybe FilePath -> IO ()
repl EvalConfig
cfg (Maybe FilePath -> IO ()) -> Maybe FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
prog
    run [FilePath]
_ EvalConfig
_ = Maybe (IO ())
forall a. Maybe a
Nothing

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

replSettings :: Haskeline.Settings IO
replSettings :: Settings IO
replSettings =
  CompletionFunc IO -> Settings IO -> Settings IO
forall (m :: * -> *). CompletionFunc m -> Settings m -> Settings m
Haskeline.setComplete CompletionFunc IO
replComplete Settings IO
forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings

repl :: EvalConfig -> Maybe FilePath -> IO ()
repl :: EvalConfig -> Maybe FilePath -> IO ()
repl EvalConfig
cfg Maybe FilePath
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
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Version " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Version -> FilePath
showVersion Version
version FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"."
    FilePath -> IO ()
putStrLn FilePath
"Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
    FilePath -> IO ()
putStrLn FilePath
""
    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."
    FilePath -> IO ()
putStrLn FilePath
""

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

        case 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 = futharkiCount s' + 1}
          Left (Load FilePath
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
<> FilePath -> Text
T.pack FilePath
file
            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
$ EvalConfig
-> Int
-> LoadedProg
-> Maybe FilePath
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState EvalConfig
cfg (FutharkiState -> Int
futharkiCount FutharkiState
s) (FutharkiState -> LoadedProg
futharkiProg FutharkiState
s) (Maybe FilePath -> IO (Either (Doc AnsiStyle) FutharkiState))
-> Maybe FilePath -> IO (Either (Doc AnsiStyle) FutharkiState)
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
file
            case maybe_new_state of
              Right FutharkiState
new_state -> 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
$ FutharkiState -> IO ()
stopServer FutharkiState
s
                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 ZonkAny 3
_ -> () -> InputT IO ()
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      finish :: FutharkiState -> InputT IO ()
finish = IO () -> InputT IO ()
forall a. IO a -> InputT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ())
-> (FutharkiState -> IO ()) -> FutharkiState -> InputT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> IO ()
stopServer

      -- A server that has already crashed will complain when shut
      -- down, which is no reason to take the REPL with it.
      stopServer :: FutharkiState -> IO ()
stopServer FutharkiState
s = case FutharkiState -> Maybe Server
futharkiServer FutharkiState
s of
        Maybe Server
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just Server
server -> (Text -> IO ()) -> Maybe Text -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> IO ()
T.putStrLn (Maybe Text -> IO ()) -> IO (Maybe Text) -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Server -> IO (Maybe Text)
FFI.stopServer Server
server

  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
$ EvalConfig
-> Int
-> LoadedProg
-> Maybe FilePath
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState EvalConfig
cfg Int
0 LoadedProg
noLoadedProg Maybe FilePath
maybe_prog
  s <- case maybe_init_state of
    Left Doc AnsiStyle
prog_err -> do
      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
$ EvalConfig
-> Int
-> LoadedProg
-> Maybe FilePath
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState EvalConfig
cfg Int
0 LoadedProg
noLoadedProg Maybe FilePath
forall a. Maybe a
Nothing
      case noprog_init_state of
        Left Doc AnsiStyle
err ->
          FilePath -> IO FutharkiState
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO FutharkiState) -> FilePath -> IO FutharkiState
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to initialise interpreter state: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Text -> FilePath
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 ()
putDocLn 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_prog}
    Right FutharkiState
s ->
      FutharkiState -> IO FutharkiState
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s
  Haskeline.runInputT replSettings $ toploop s

  putStrLn "Leaving 'futhark repl'."

-- | 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 FilePath
futharkiLoaded :: Maybe FilePath,
    -- | Possibly a computation server.
    FutharkiState -> Maybe Server
futharkiServer :: Maybe FFI.Server
  }

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 ::
  EvalConfig ->
  Int ->
  LoadedProg ->
  Maybe FilePath ->
  IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState :: EvalConfig
-> Int
-> LoadedProg
-> Maybe FilePath
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState EvalConfig
cfg Int
count LoadedProg
prev_prog Maybe FilePath
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 :: [FilePath]
files = Maybe FilePath -> [FilePath]
forall a. Maybe a -> [a]
maybeToList Maybe FilePath
maybe_file
  -- Put code through the type checker.
  prog <-
    (NonEmpty ProgError -> Doc AnsiStyle)
-> Either (NonEmpty ProgError) LoadedProg
-> ExceptT (Doc AnsiStyle) IO LoadedProg
forall err' (m :: * -> *) err a.
MonadError err' m =>
(err -> err') -> Either err a -> m 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
-> [FilePath] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
reloadProg LoadedProg
prev_prog [FilePath]
files VFS
forall k a. Map k a
M.empty)
  liftIO $ putDoc $ prettyWarnings $ lpWarnings prog

  -- Then into the interpreter.
  (server, tenv, ienv) <-
    ExceptT $ initialiseInterpreter cfg maybe_file Nothing $ lpImports prog

  pure
    FutharkiState
      { futharkiProg = prog,
        futharkiCount = count,
        futharkiEnv = (tenv, ienv),
        futharkiBreaking = Nothing,
        futharkiSkipBreaks = mempty,
        futharkiBreakOnNaN = False,
        futharkiLoaded = maybe_file,
        futharkiServer = server
      }

getPrompt :: FutharkiM String
getPrompt :: FutharkiM FilePath
getPrompt = do
  i <- (FutharkiState -> Int) -> FutharkiM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Int
futharkiCount
  fmap T.unpack $ liftIO $ docTextForHandle stdout $ annotate bold $ brackets (pretty i) <> "> "

-- 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
  prompt <- FutharkiM FilePath
getPrompt
  line <- inputLine prompt
  breaking <- gets futharkiBreaking
  case T.uncons 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 Text -> Text -> Bool
`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 FilePath
-> Text -> Either SyntaxError (Either UncheckedDec UncheckedExp)
parseDecOrExp FilePath
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
          valOrErr <- UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value)
onExp UncheckedExp
e
          case 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
  modify $ \FutharkiState
s -> FutharkiState
s {futharkiCount = futharkiCount s + 1}
  where
    inputLine :: FilePath -> FutharkiM Text
inputLine FilePath
prompt = do
      inp <- ExceptT
  StopReason (StateT FutharkiState (InputT IO)) (Maybe FilePath)
-> FutharkiM (Maybe FilePath)
forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM (ExceptT
   StopReason (StateT FutharkiState (InputT IO)) (Maybe FilePath)
 -> FutharkiM (Maybe FilePath))
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe FilePath)
-> FutharkiM (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ StateT FutharkiState (InputT IO) (Maybe FilePath)
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe FilePath)
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 FilePath)
 -> ExceptT
      StopReason (StateT FutharkiState (InputT IO)) (Maybe FilePath))
-> StateT FutharkiState (InputT IO) (Maybe FilePath)
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ InputT IO (Maybe FilePath)
-> StateT FutharkiState (InputT IO) (Maybe FilePath)
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 FilePath)
 -> StateT FutharkiState (InputT IO) (Maybe FilePath))
-> InputT IO (Maybe FilePath)
-> StateT FutharkiState (InputT IO) (Maybe FilePath)
forall a b. (a -> b) -> a -> b
$ FilePath -> InputT IO (Maybe FilePath)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
FilePath -> InputT m (Maybe FilePath)
Haskeline.getInputLine FilePath
prompt
      case inp of
        Just FilePath
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
$ FilePath -> Text
T.pack FilePath
s
        Maybe FilePath
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 <- (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
  src <- gets $ lpNameSource . futharkiProg
  (tenv, ienv) <- gets futharkiEnv
  pure (imports, src, tenv, ienv)

onDec :: UncheckedDec -> FutharkiM ()
onDec :: UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d = do
  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
  cur_import <- gets $ T.mkInitialImport . fromMaybe "." . futharkiLoaded
  let mkImport = ImportName -> FilePath -> ImportName
T.mkImportFrom ImportName
cur_import
      files = ((FilePath, Loc) -> FilePath) -> [(FilePath, Loc)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName -> FilePath
T.includeToFilePath (ImportName -> FilePath)
-> ((FilePath, Loc) -> ImportName) -> (FilePath, Loc) -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> ImportName
mkImport (FilePath -> ImportName)
-> ((FilePath, Loc) -> FilePath) -> (FilePath, Loc) -> ImportName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, Loc) -> FilePath
forall a b. (a, b) -> a
fst) ([(FilePath, Loc)] -> [FilePath])
-> [(FilePath, Loc)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$ UncheckedDec -> [(FilePath, Loc)]
forall (f :: * -> *) vn. DecBase f vn -> [(FilePath, Loc)]
decImports UncheckedDec
d

  cur_prog <- gets futharkiProg
  imp_r <- liftIO $ extendProg cur_prog files M.empty
  case 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 <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
      let (tenv, ienv) =
            extendEnvs prog env $ map (T.mkInitialImport . fst) $ decImports d
          imports = LoadedProg -> Imports
lpImports LoadedProg
prog
          src = LoadedProg -> VNameSource
lpNameSource LoadedProg
prog
      case T.checkDec imports src tenv cur_import 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
          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)
            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
            I.interpretDec ienv' d'
          case 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 = (tenv', ienv'),
                  futharkiProg = prog {lpNameSource = src'}
                }

onExp :: UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) I.Value)
onExp :: UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value)
onExp UncheckedExp
e = do
  (imports, src, tenv, ienv) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
  case T.checkExp imports src tenv 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
          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 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 -> do
              -- Whatever we do with the value next (printing it, most
              -- likely) requires having it in full.
              server <- (FutharkiState -> Maybe Server) -> FutharkiM (Maybe Server)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe Server
futharkiServer
              either (Left . I.prettyInterpreterError) Right
                <$> liftIO (forceValue server 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
      s <- FutharkiM FutharkiState
forall s (m :: * -> *). MonadState s m => m s
get

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

      -- Are we supposed to respect this breakpoint?
      when (breakForReason s top why) $ do
        liftIO $ T.putStrLn $ why' <> " at " <> locText w
        liftIO $ T.putStrLn $ prettyBreaking breaking
        liftIO $ T.putStrLn "<Enter> to continue."

        -- Note the cleverness to preserve the Haskeline session (for
        -- line history and such).
        (stop, s') <-
          FutharkiM . lift . lift $
            runStateT
              (runExceptT $ runFutharkiM $ forever readEvalPrint)
              s
                { futharkiEnv = (tenv, ctx),
                  futharkiCount = futharkiCount s + 1,
                  futharkiBreaking = Just breaking
                }

        case stop of
          Left (Load FilePath
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
$ FilePath -> StopReason
Load FilePath
file
          Either StopReason (ZonkAny 2)
_ -> 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
$ FilePath -> IO ()
putStrLn FilePath
"Continuing..."
            FutharkiState -> FutharkiM ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put
              FutharkiState
s
                { futharkiCount =
                    futharkiCount s',
                  futharkiSkipBreaks =
                    futharkiSkipBreaks s' <> futharkiSkipBreaks s,
                  futharkiBreakOnNaN =
                    futharkiBreakOnNaN s'
                }

      c
    intOp (I.ExtOpFFI ServerM Value
sm Value -> FutharkiM (Either InterpreterError b)
c) = do
      server <- (FutharkiState -> Maybe Server) -> FutharkiM (Maybe Server)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe Server
futharkiServer
      either (pure . Left) c =<< liftIO (runFFI server sm)
    intOp (I.ExtOpIO IOOp
op Value -> FutharkiM (Either InterpreterError b)
c) = do
      server <- (FutharkiState -> Maybe Server) -> FutharkiM (Maybe Server)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe Server
futharkiServer
      either (pure . Left . I.InterpreterError) c =<< liftIO (I.doIOOp server op)

replComplete :: Haskeline.CompletionFunc IO
replComplete :: CompletionFunc IO
replComplete = CompletionFunc IO
forall {m :: * -> *}.
MonadIO m =>
(FilePath, FilePath) -> m (FilePath, [Completion])
loadComplete
  where
    loadComplete :: (FilePath, FilePath) -> m (FilePath, [Completion])
loadComplete (FilePath
prev, FilePath
aft)
      | FilePath
":load " FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
prev =
          (FilePath, FilePath) -> m (FilePath, [Completion])
forall {m :: * -> *}.
MonadIO m =>
(FilePath, FilePath) -> m (FilePath, [Completion])
Haskeline.completeFilename (FilePath
prev, FilePath
aft)
      | Bool
otherwise =
          (FilePath, FilePath) -> m (FilePath, [Completion])
forall (m :: * -> *). Monad m => CompletionFunc m
Haskeline.noCompletion (FilePath
prev, FilePath
aft)

type Command = T.Text -> FutharkiM ()

loadCommand :: Command
loadCommand :: Command
loadCommand Text
file = do
  loaded <- (FutharkiState -> Maybe FilePath) -> FutharkiM (Maybe FilePath)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe FilePath
futharkiLoaded
  case (T.null file, loaded) of
    (Bool
True, Just FilePath
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
$ FilePath -> StopReason
Load FilePath
loaded'
    (Bool
True, Maybe FilePath
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 FilePath
_) -> 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
$ FilePath -> StopReason
Load (FilePath -> StopReason) -> FilePath -> StopReason
forall a b. (a -> b) -> a -> b
$ Text -> FilePath
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.
(FilePath -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand FilePath -> Text -> Either SyntaxError a
f Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g b -> Doc AnsiStyle
h Text
e = do
  prompt <- FutharkiM FilePath
getPrompt
  case f prompt 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, src, tenv, _) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
      case snd $ g imports src tenv 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 = (FilePath -> 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.
(FilePath -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand FilePath -> 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 = (FilePath -> 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.
(FilePath -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand FilePath -> 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
      prompt <- FutharkiM FilePath
getPrompt
      case mapM (traverse $ parseExp prompt) 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
          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 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 ()
putDocLn 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 (ZonkAny 1) -> Text
forall a. Doc a -> Text
docText (Doc (ZonkAny 1) -> Text)
-> (Value -> Doc (ZonkAny 1)) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Doc (ZonkAny 1)
forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue)) [Either Text Value]
parts'''

stringCommand :: Command
stringCommand :: Command
stringCommand Text
input = do
  prompt <- FutharkiM FilePath
getPrompt
  case parseExp prompt input 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 UncheckedExp
e -> do
      e' <- UncheckedExp -> FutharkiM (Either (Doc AnsiStyle) Value)
onExp UncheckedExp
e
      liftIO $ case e' of
        Left Doc AnsiStyle
err -> Doc AnsiStyle -> IO ()
putDocLn Doc AnsiStyle
err
        Right Value
v
          | Just ByteString
bytes <- Value -> Maybe ByteString
forall (m :: * -> *). Value m -> Maybe ByteString
I.asByteString Value
v ->
              Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
bytes
          | Bool
otherwise ->
              Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                Text
"Cannot print this value as string:\n"
                  Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Doc (ZonkAny 0) -> Text
forall a. Doc a -> Text
docText (Value -> Doc (ZonkAny 0)
forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue Value
v)

unbreakCommand :: Command
unbreakCommand :: Command
unbreakCommand Text
_ = do
  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 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
$ FilePath -> IO ()
putStrLn FilePath
"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 = locOf top' : futharkiSkipBreaks 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 = not $ futharkiBreakOnNaN s}
  b <- (FutharkiState -> Bool) -> FutharkiM Bool
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Bool
futharkiBreakOnNaN
  liftIO $
    putStrLn $
      if b
        then "Now treating NaNs as breakpoints."
        else "No longer treating NaNs as breakpoints."

frameCommand :: Command
frameCommand :: Command
frameCommand Text
which = do
  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_stack, readMaybe $ T.unpack 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 = (tenv, ctx),
                futharkiBreaking = Just 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
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Invalid stack index: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Text -> FilePath
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
$ FilePath -> IO ()
putStrLn FilePath
"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
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> IO FilePath -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO FilePath
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
$ FilePath -> IO ()
putStrLn FilePath
"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
$
        FilePath -> IO ()
setCurrentDirectory (Text -> FilePath
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
"string",
      ( Command
stringCommand,
        [text|
Evaluate the given expression, which must have type []u8,
and print the result as a string. It is assumes that the
byte array contains valid UTF-8.
           |]
      )
    ),
    ( 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.
|]
      )
    )
  ]