{-# 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.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

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

        case stop of
          Left StopReason
Stop -> FutharkiState -> InputT IO ()
forall {f :: * -> *} {p}. Applicative f => p -> f ()
finish FutharkiState
s'
          Left StopReason
EOF -> FutharkiState -> InputT IO ()
forall {f :: * -> *} {p}. Applicative f => p -> f ()
finish FutharkiState
s'
          Left StopReason
Exit -> FutharkiState -> InputT IO ()
forall {f :: * -> *} {p}. Applicative f => p -> f ()
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 [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
            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 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 ZonkAny 2
_ -> () -> InputT IO ()
forall a. a -> InputT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      finish :: p -> f ()
finish p
_s = () -> f ()
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  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
  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
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg Maybe [Char]
forall a. Maybe a
Nothing
      case 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 ()
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 [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.
  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)
  liftIO $ putDoc $ prettyWarnings $ lpWarnings prog
  -- Then into the interpreter.
  ictx <-
    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)
      I.initialCtx
      $ map (fmap fileProg) (lpImports prog)

  let (tenv, ienv) =
        let (iname, fm) = last $ lpImports prog
         in ( fileScope fm,
              ictx {I.ctxEnv = I.ctxImports ictx M.! iname}
            )

  pure
    FutharkiState
      { futharkiProg = prog,
        futharkiCount = count,
        futharkiEnv = (tenv, ienv),
        futharkiBreaking = Nothing,
        futharkiSkipBreaks = mempty,
        futharkiBreakOnNaN = False,
        futharkiLoaded = 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
  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 [Char]
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 [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
          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 :: [Char] -> FutharkiM Text
inputLine [Char]
prompt = do
      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 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 <- (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 -> [Char] -> ImportName
T.mkImportFrom ImportName
cur_import
      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

  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 -> 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
      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 [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 (ZonkAny 1)
_ -> 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 =
                    futharkiCount s',
                  futharkiSkipBreaks =
                    futharkiSkipBreaks s' <> futharkiSkipBreaks s,
                  futharkiBreakOnNaN =
                    futharkiBreakOnNaN s'
                }

      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
I.BreakNaN NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c
    intOp (I.ExtOpBreak Loc
w BreakReason
_ NonEmpty StackFrame
_ 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
$
        Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
          Loc -> Text
forall a. Located a => a -> Text
locText Loc
w Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"ignoring breakpoint when computating constant."
      f (Either InterpreterError b)
c

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

type Command = T.Text -> FutharkiM ()

loadCommand :: Command
loadCommand :: Command
loadCommand Text
file = do
  loaded <- (FutharkiState -> Maybe [Char]) -> FutharkiM (Maybe [Char])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe [Char]
futharkiLoaded
  case (T.null file, 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
  prompt <- FutharkiM [Char]
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 = ([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
      prompt <- FutharkiM [Char]
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 ()
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 (ZonkAny 0) -> Text
forall a. Doc a -> Text
docText (Doc (ZonkAny 0) -> Text)
-> (Value -> Doc (ZonkAny 0)) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Doc (ZonkAny 0)
forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue)) [Either Text Value]
parts'''

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
$ [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 = 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
$ [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.
|]
      )
    )
  ]