{-# LANGUAGE QuasiQuotes #-}

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

import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Free.Church
import Control.Monad.State
import Data.Char
import Data.List (intersperse)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Version
import Futhark.Compiler
import Futhark.MonadFreshNames
import Futhark.Util (fancyTerminal)
import Futhark.Util.Options
import Futhark.Util.Pretty (AnsiStyle, Color (..), Doc, align, annotate, bgColorDull, bold, brackets, color, docText, docTextForHandle, hardline, 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 =
  forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
decorate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall a b. (a -> b) -> a -> b
$
    [ Text
"┃╱╱ ┃╲    ┃   ┃╲  ┃╲   ╱" :: T.Text,
      Text
"┃╱  ┃ ╲   ┃╲  ┃╲  ┃╱  ╱ ",
      Text
"┃   ┃  ╲  ┃╱  ┃   ┃╲  ╲ ",
      Text
"┃   ┃   ╲ ┃   ┃   ┃ ╲  ╲"
    ]
  where
    decorate :: Doc AnsiStyle -> Doc AnsiStyle
decorate = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
bgColorDull Color
Red forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White)

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

      FutharkiM (Either InterpreterError b)
c

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

type Command = T.Text -> FutharkiM ()

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

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

typeCommand :: Command
typeCommand :: Command
typeCommand = forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError UncheckedExp
parseExp Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp forall a b. (a -> b) -> a -> b
$ \([TypeParam]
ps, Exp
e) ->
  forall ann. Doc ann -> Doc ann
oneLine (forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Doc AnsiStyle
" " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [TypeParam]
ps
    forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" : "
    forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
oneLine (forall a ann. Pretty a => a -> Doc ann
pretty (Exp -> StructType
typeOf Exp
e))

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

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

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

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

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

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

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

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

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

  > :load foo.fut

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

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

|]
      )
    ),
    ( Text
"type",
      ( Command
typeCommand,
        [text|
Show the type of an expression, which must fit on a single line.
|]
      )
    ),
    ( Text
"mtype",
      ( Command
mtypeCommand,
        [text|
Show the type of a module expression, which must fit on a single line.
|]
      )
    ),
    ( Text
"unbreak",
      ( Command
unbreakCommand,
        [text|
Skip all future 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.
|]
      )
    )
  ]