{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | @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 (intercalate, intersperse)
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Version
import Futhark.Compiler
import Futhark.MonadFreshNames
import Futhark.Pipeline
import Futhark.Util (toPOSIX)
import Futhark.Util.Options
import Futhark.Version
import Language.Futhark
import qualified Language.Futhark.Interpreter as I
import Language.Futhark.Parser hiding (EOF)
import qualified Language.Futhark.Semantic as T
import qualified Language.Futhark.TypeChecker as T
import NeatInterpolation (text)
import qualified System.Console.Haskeline as Haskeline
import System.Directory
import System.FilePath
import Text.Read (readMaybe)

banner :: String
banner :: [Char]
banner =
  [[Char]] -> [Char]
unlines
    [ [Char]
"|// |\\    |   |\\  |\\   /",
      [Char]
"|/  | \\   |\\  |\\  |/  /",
      [Char]
"|   |  \\  |/  |   |\\  \\",
      [Char]
"|   |   \\ |   |   | \\  \\"
    ]

-- | Run @futhark repl@.
main :: String -> [String] -> IO ()
main :: [Char] -> [[Char]] -> IO ()
main = InterpreterConfig
-> [FunOptDescr InterpreterConfig]
-> [Char]
-> ([[Char]] -> InterpreterConfig -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> [Char]
-> ([[Char]] -> cfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
mainWithOptions InterpreterConfig
interpreterConfig [FunOptDescr InterpreterConfig]
options [Char]
"options... [program.fut]" [[Char]] -> InterpreterConfig -> 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

repl :: Maybe FilePath -> IO ()
repl :: Maybe [Char] -> IO ()
repl Maybe [Char]
maybe_prog = do
  [Char] -> IO ()
putStr [Char]
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]
""
  [Char] -> IO ()
putStrLn [Char]
"Run :help for a list of commands."
  [Char] -> IO ()
putStrLn [Char]
""

  let toploop :: FutharkiState -> InputT IO ()
toploop FutharkiState
s = do
        (Either StopReason Any
stop, FutharkiState
s') <- StateT FutharkiState (InputT IO) (Either StopReason Any)
-> FutharkiState
-> InputT IO (Either StopReason Any, FutharkiState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
 -> StateT FutharkiState (InputT IO) (Either StopReason Any))
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall a b. (a -> b) -> a -> b
$ FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM (FutharkiM Any
 -> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any)
-> FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a b. (a -> b) -> a -> b
$ FutharkiM () -> FutharkiM Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint) FutharkiState
s
        case Either StopReason Any
stop of
          Left StopReason
Stop -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
          Left StopReason
EOF -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
          Left StopReason
Exit -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
          Left (Load [Char]
file) -> do
            IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Loading " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
file
            Either [Char] FutharkiState
maybe_new_state <-
              IO (Either [Char] FutharkiState)
-> InputT IO (Either [Char] FutharkiState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] FutharkiState)
 -> InputT IO (Either [Char] FutharkiState))
-> IO (Either [Char] FutharkiState)
-> InputT IO (Either [Char] FutharkiState)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState (FutharkiState -> Int
futharkiCount FutharkiState
s) (Maybe [Char] -> IO (Either [Char] FutharkiState))
-> Maybe [Char] -> IO (Either [Char] FutharkiState)
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
file
            case Either [Char] FutharkiState
maybe_new_state of
              Right FutharkiState
new_state -> FutharkiState -> InputT IO ()
toploop FutharkiState
new_state
              Left [Char]
err -> do
                IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
err
                FutharkiState -> InputT IO ()
toploop FutharkiState
s'
          Right Any
_ -> () -> InputT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      finish :: FutharkiState -> InputT IO ()
finish FutharkiState
s = do
        Bool
quit <- InputT IO Bool
confirmQuit
        if Bool
quit then () -> InputT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else FutharkiState -> InputT IO ()
toploop FutharkiState
s

  Either [Char] FutharkiState
maybe_init_state <- IO (Either [Char] FutharkiState)
-> IO (Either [Char] FutharkiState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] FutharkiState)
 -> IO (Either [Char] FutharkiState))
-> IO (Either [Char] FutharkiState)
-> IO (Either [Char] FutharkiState)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState Int
0 Maybe [Char]
maybe_prog
  FutharkiState
s <- case Either [Char] FutharkiState
maybe_init_state of
    Left [Char]
prog_err -> do
      Either [Char] FutharkiState
noprog_init_state <- IO (Either [Char] FutharkiState)
-> IO (Either [Char] FutharkiState)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] FutharkiState)
 -> IO (Either [Char] FutharkiState))
-> IO (Either [Char] FutharkiState)
-> IO (Either [Char] FutharkiState)
forall a b. (a -> b) -> a -> b
$ Int -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState Int
0 Maybe [Char]
forall a. Maybe a
Nothing
      case Either [Char] FutharkiState
noprog_init_state of
        Left [Char]
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. [a] -> [a] -> [a]
++ [Char]
err
        Right FutharkiState
s -> do
          IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
prog_err
          FutharkiState -> IO FutharkiState
forall (m :: * -> *) a. Monad m => a -> m a
return FutharkiState
s {futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_prog}
    Right FutharkiState
s ->
      FutharkiState -> IO FutharkiState
forall (m :: * -> *) a. Monad m => a -> m a
return FutharkiState
s
  Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Haskeline.runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings (InputT IO () -> IO ()) -> InputT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FutharkiState -> InputT IO ()
toploop FutharkiState
s

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

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

newtype InterpreterConfig = InterpreterConfig {InterpreterConfig -> Name
interpreterEntryPoint :: Name}

interpreterConfig :: InterpreterConfig
interpreterConfig :: InterpreterConfig
interpreterConfig = Name -> InterpreterConfig
InterpreterConfig Name
defaultEntryPoint

options :: [FunOptDescr InterpreterConfig]
options :: [FunOptDescr InterpreterConfig]
options =
  [ [Char]
-> [[Char]]
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> [Char]
-> FunOptDescr InterpreterConfig
forall a. [Char] -> [[Char]] -> ArgDescr a -> [Char] -> OptDescr a
Option
      [Char]
"e"
      [[Char]
"entry-point"]
      ( ([Char] -> Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> [Char]
-> ArgDescr
     (Either (IO ()) (InterpreterConfig -> InterpreterConfig))
forall a. ([Char] -> a) -> [Char] -> ArgDescr a
ReqArg
          ( \[Char]
entry -> (InterpreterConfig -> InterpreterConfig)
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
forall a b. b -> Either a b
Right ((InterpreterConfig -> InterpreterConfig)
 -> Either (IO ()) (InterpreterConfig -> InterpreterConfig))
-> (InterpreterConfig -> InterpreterConfig)
-> Either (IO ()) (InterpreterConfig -> InterpreterConfig)
forall a b. (a -> b) -> a -> b
$ \InterpreterConfig
config ->
              InterpreterConfig
config {interpreterEntryPoint :: Name
interpreterEntryPoint = [Char] -> Name
nameFromString [Char]
entry}
          )
          [Char]
"NAME"
      )
      [Char]
"The entry point to execute."
  ]

-- | 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 -> Imports
futharkiImports :: Imports,
    FutharkiState -> VNameSource
futharkiNameSource :: VNameSource,
    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
  }

newFutharkiState :: Int -> Maybe FilePath -> IO (Either String FutharkiState)
newFutharkiState :: Int -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState Int
count Maybe [Char]
maybe_file = ExceptT [Char] IO FutharkiState -> IO (Either [Char] FutharkiState)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT [Char] IO FutharkiState
 -> IO (Either [Char] FutharkiState))
-> ExceptT [Char] IO FutharkiState
-> IO (Either [Char] FutharkiState)
forall a b. (a -> b) -> a -> b
$ do
  (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv) <- case Maybe [Char]
maybe_file of
    Maybe [Char]
Nothing -> do
      -- Load the builtins through the type checker.
      (Warnings
_, Imports
imports, VNameSource
src) <- (CompilerError -> [Char])
-> Either CompilerError (Warnings, Imports, VNameSource)
-> ExceptT [Char] IO (Warnings, Imports, VNameSource)
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft CompilerError -> [Char]
forall a. Show a => a -> [Char]
show (Either CompilerError (Warnings, Imports, VNameSource)
 -> ExceptT [Char] IO (Warnings, Imports, VNameSource))
-> ExceptT
     [Char] IO (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT [Char] IO (Warnings, Imports, VNameSource)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT
  CompilerError (ExceptT [Char] IO) (Warnings, Imports, VNameSource)
-> ExceptT
     [Char] IO (Either CompilerError (Warnings, Imports, VNameSource))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ([Name]
-> [[Char]]
-> ExceptT
     CompilerError (ExceptT [Char] IO) (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [[Char]] -> m (Warnings, Imports, VNameSource)
readLibrary [] [])
      -- Then into the interpreter.
      Ctx
ienv <-
        (Ctx -> ([Char], Prog) -> ExceptT [Char] IO Ctx)
-> Ctx -> [([Char], Prog)] -> ExceptT [Char] IO Ctx
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
          (\Ctx
ctx -> (InterpreterError -> [Char])
-> Either InterpreterError Ctx -> ExceptT [Char] IO Ctx
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (Either InterpreterError Ctx -> ExceptT [Char] IO Ctx)
-> (([Char], Prog)
    -> ExceptT [Char] IO (Either InterpreterError Ctx))
-> ([Char], Prog)
-> ExceptT [Char] IO Ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx))
-> (([Char], Prog) -> F ExtOp Ctx)
-> ([Char], Prog)
-> ExceptT [Char] IO (Either InterpreterError Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ([Char], Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx)
          Ctx
I.initialCtx
          ([([Char], Prog)] -> ExceptT [Char] IO Ctx)
-> [([Char], Prog)] -> ExceptT [Char] IO Ctx
forall a b. (a -> b) -> a -> b
$ (([Char], FileModule) -> ([Char], Prog))
-> Imports -> [([Char], Prog)]
forall a b. (a -> b) -> [a] -> [b]
map ((FileModule -> Prog) -> ([Char], FileModule) -> ([Char], Prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Prog
fileProg) Imports
imports

      -- Then make the prelude available in the type checker.
      (Env
tenv, Dec
d, VNameSource
src') <-
        (TypeError -> [Char])
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT [Char] IO (Env, Dec, VNameSource)
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft TypeError -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Either TypeError (Env, Dec, VNameSource)
 -> ExceptT [Char] IO (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT [Char] IO (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
          (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError (Env, Dec, VNameSource))
 -> Either TypeError (Env, Dec, VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
            Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec
              Imports
imports
              VNameSource
src
              Env
T.initialEnv
              ([Char] -> ImportName
T.mkInitialImport [Char]
".")
              (UncheckedDec
 -> (Warnings, Either TypeError (Env, Dec, VNameSource)))
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall a b. (a -> b) -> a -> b
$ [Char] -> UncheckedDec
mkOpen [Char]
"/prelude/prelude"
      -- Then in the interpreter.
      Ctx
ienv' <- (InterpreterError -> [Char])
-> Either InterpreterError Ctx -> ExceptT [Char] IO Ctx
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (Either InterpreterError Ctx -> ExceptT [Char] IO Ctx)
-> ExceptT [Char] IO (Either InterpreterError Ctx)
-> ExceptT [Char] IO Ctx
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv Dec
d)
      (Imports, VNameSource, Env, Ctx)
-> ExceptT [Char] IO (Imports, VNameSource, Env, Ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imports
imports, VNameSource
src', Env
tenv, Ctx
ienv')
    Just [Char]
file -> do
      (Warnings
ws, Imports
imports, VNameSource
src) <-
        (CompilerError -> [Char])
-> Either CompilerError (Warnings, Imports, VNameSource)
-> ExceptT [Char] IO (Warnings, Imports, VNameSource)
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft CompilerError -> [Char]
forall a. Show a => a -> [Char]
show
          (Either CompilerError (Warnings, Imports, VNameSource)
 -> ExceptT [Char] IO (Warnings, Imports, VNameSource))
-> ExceptT
     [Char] IO (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT [Char] IO (Warnings, Imports, VNameSource)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either CompilerError (Warnings, Imports, VNameSource))
-> ExceptT
     [Char] IO (Either CompilerError (Warnings, Imports, VNameSource))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            ( ExceptT CompilerError IO (Warnings, Imports, VNameSource)
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ([Name]
-> [Char]
-> ExceptT CompilerError IO (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [Char] -> m (Warnings, Imports, VNameSource)
readProgram [] [Char]
file)
                IO (Either CompilerError (Warnings, Imports, VNameSource))
-> (IOException
    -> IO (Either CompilerError (Warnings, Imports, VNameSource)))
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
err :: IOException) ->
                  Either CompilerError (Warnings, Imports, VNameSource)
-> IO (Either CompilerError (Warnings, Imports, VNameSource))
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> Either CompilerError (Warnings, Imports, VNameSource)
forall (m :: * -> *) a. MonadError CompilerError m => [Char] -> m a
externalErrorS (IOException -> [Char]
forall a. Show a => a -> [Char]
show IOException
err))
            )
      IO () -> ExceptT [Char] IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT [Char] IO ()) -> IO () -> ExceptT [Char] IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ Warnings -> [Char]
forall a. Pretty a => a -> [Char]
pretty Warnings
ws

      let imp :: ImportName
imp = [Char] -> ImportName
T.mkInitialImport [Char]
"."
      Ctx
ienv1 <-
        (Ctx -> ([Char], Prog) -> ExceptT [Char] IO Ctx)
-> Ctx -> [([Char], Prog)] -> ExceptT [Char] IO Ctx
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\Ctx
ctx -> (InterpreterError -> [Char])
-> Either InterpreterError Ctx -> ExceptT [Char] IO Ctx
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (Either InterpreterError Ctx -> ExceptT [Char] IO Ctx)
-> (([Char], Prog)
    -> ExceptT [Char] IO (Either InterpreterError Ctx))
-> ([Char], Prog)
-> ExceptT [Char] IO Ctx
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx))
-> (([Char], Prog) -> F ExtOp Ctx)
-> ([Char], Prog)
-> ExceptT [Char] IO (Either InterpreterError Ctx)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> ([Char], Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx) Ctx
I.initialCtx ([([Char], Prog)] -> ExceptT [Char] IO Ctx)
-> [([Char], Prog)] -> ExceptT [Char] IO Ctx
forall a b. (a -> b) -> a -> b
$
          (([Char], FileModule) -> ([Char], Prog))
-> Imports -> [([Char], Prog)]
forall a b. (a -> b) -> [a] -> [b]
map ((FileModule -> Prog) -> ([Char], FileModule) -> ([Char], Prog)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Prog
fileProg) Imports
imports
      (Env
tenv1, Dec
d1, VNameSource
src') <-
        (TypeError -> [Char])
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT [Char] IO (Env, Dec, VNameSource)
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft TypeError -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Either TypeError (Env, Dec, VNameSource)
 -> ExceptT [Char] IO (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT [Char] IO (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
          (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError (Env, Dec, VNameSource))
 -> Either TypeError (Env, Dec, VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
            Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src Env
T.initialEnv ImportName
imp (UncheckedDec
 -> (Warnings, Either TypeError (Env, Dec, VNameSource)))
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall a b. (a -> b) -> a -> b
$
              [Char] -> UncheckedDec
mkOpen [Char]
"/prelude/prelude"
      (Env
tenv2, Dec
d2, VNameSource
src'') <-
        (TypeError -> [Char])
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT [Char] IO (Env, Dec, VNameSource)
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft TypeError -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Either TypeError (Env, Dec, VNameSource)
 -> ExceptT [Char] IO (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
-> ExceptT [Char] IO (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
          (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError (Env, Dec, VNameSource))
 -> Either TypeError (Env, Dec, VNameSource))
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
-> Either TypeError (Env, Dec, VNameSource)
forall a b. (a -> b) -> a -> b
$
            Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src' Env
tenv1 ImportName
imp (UncheckedDec
 -> (Warnings, Either TypeError (Env, Dec, VNameSource)))
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
forall a b. (a -> b) -> a -> b
$
              [Char] -> UncheckedDec
mkOpen ([Char] -> UncheckedDec) -> [Char] -> UncheckedDec
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
toPOSIX ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
dropExtension [Char]
file
      Ctx
ienv2 <- (InterpreterError -> [Char])
-> Either InterpreterError Ctx -> ExceptT [Char] IO Ctx
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (Either InterpreterError Ctx -> ExceptT [Char] IO Ctx)
-> ExceptT [Char] IO (Either InterpreterError Ctx)
-> ExceptT [Char] IO Ctx
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv1 Dec
d1)
      Ctx
ienv3 <- (InterpreterError -> [Char])
-> Either InterpreterError Ctx -> ExceptT [Char] IO Ctx
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft InterpreterError -> [Char]
forall a. Show a => a -> [Char]
show (Either InterpreterError Ctx -> ExceptT [Char] IO Ctx)
-> ExceptT [Char] IO (Either InterpreterError Ctx)
-> ExceptT [Char] IO Ctx
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< F ExtOp Ctx -> ExceptT [Char] IO (Either InterpreterError Ctx)
forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreter' (Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv2 Dec
d2)
      (Imports, VNameSource, Env, Ctx)
-> ExceptT [Char] IO (Imports, VNameSource, Env, Ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imports
imports, VNameSource
src'', Env
tenv2, Ctx
ienv3)

  FutharkiState -> ExceptT [Char] IO FutharkiState
forall (m :: * -> *) a. Monad m => a -> m a
return
    FutharkiState :: Imports
-> VNameSource
-> Int
-> (Env, Ctx)
-> Maybe Breaking
-> [Loc]
-> Bool
-> Maybe [Char]
-> FutharkiState
FutharkiState
      { futharkiImports :: Imports
futharkiImports = Imports
imports,
        futharkiNameSource :: VNameSource
futharkiNameSource = VNameSource
src,
        futharkiCount :: Int
futharkiCount = Int
count,
        futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ienv),
        futharkiBreaking :: Maybe Breaking
futharkiBreaking = Maybe Breaking
forall a. Maybe a
Nothing,
        futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = [Loc]
forall a. Monoid a => a
mempty,
        futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool
False,
        futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_file
      }
  where
    badOnLeft :: (err -> String) -> Either err a -> ExceptT String IO a
    badOnLeft :: forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft err -> [Char]
_ (Right a
x) = a -> ExceptT [Char] IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
    badOnLeft err -> [Char]
p (Left err
err) = [Char] -> ExceptT [Char] IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ([Char] -> ExceptT [Char] IO a) -> [Char] -> ExceptT [Char] IO a
forall a b. (a -> b) -> a -> b
$ err -> [Char]
p err
err

getPrompt :: FutharkiM String
getPrompt :: FutharkiM [Char]
getPrompt = do
  Int
i <- (FutharkiState -> Int) -> FutharkiM Int
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Int
futharkiCount
  [Char] -> FutharkiM [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> FutharkiM [Char]) -> [Char] -> FutharkiM [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"[" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"]> "

mkOpen :: FilePath -> UncheckedDec
mkOpen :: [Char] -> UncheckedDec
mkOpen [Char]
f = ModExpBase NoInfo Name -> SrcLoc -> UncheckedDec
forall (f :: * -> *) vn. ModExpBase f vn -> SrcLoc -> DecBase f vn
OpenDec ([Char] -> NoInfo [Char] -> SrcLoc -> ModExpBase NoInfo Name
forall (f :: * -> *) vn.
[Char] -> f [Char] -> SrcLoc -> ModExpBase f vn
ModImport [Char]
f NoInfo [Char]
forall a. NoInfo a
NoInfo SrcLoc
forall a. Monoid a => a
mempty) SrcLoc
forall a. Monoid a => a
mempty

-- 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
<$ :: 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
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
<* :: 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
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
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
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
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 <- (FutharkiState -> Maybe Breaking) -> FutharkiM (Maybe Breaking)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe Breaking
futharkiBreaking
  case Text -> Maybe (Char, Text)
T.uncons Text
line of
    Maybe (Char, Text)
Nothing
      | Maybe Breaking -> Bool
forall a. Maybe a -> Bool
isJust Maybe Breaking
breaking -> StopReason -> FutharkiM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop
      | Bool
otherwise -> () -> FutharkiM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    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 (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 (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
"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.
      Either ParseError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e <- FutharkiM Text
-> [Char]
-> Text
-> FutharkiM (Either ParseError (Either UncheckedDec UncheckedExp))
forall (m :: * -> *).
Monad m =>
m Text
-> [Char]
-> Text
-> m (Either ParseError (Either UncheckedDec UncheckedExp))
parseDecOrExpIncrM ([Char] -> FutharkiM Text
inputLine [Char]
"  ") [Char]
prompt Text
line

      case Either ParseError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e of
        Left ParseError
err -> IO () -> FutharkiM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ ParseError -> IO ()
forall a. Show a => a -> IO ()
print ParseError
err
        Right (Left UncheckedDec
d) -> UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d
        Right (Right UncheckedExp
e) -> UncheckedExp -> FutharkiM ()
onExp UncheckedExp
e
  (FutharkiState -> FutharkiState) -> FutharkiM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkiState -> FutharkiState) -> FutharkiM ())
-> (FutharkiState -> FutharkiState) -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
  where
    inputLine :: [Char] -> FutharkiM Text
inputLine [Char]
prompt = do
      Maybe [Char]
inp <- ExceptT
  StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
-> FutharkiM (Maybe [Char])
forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM (ExceptT
   StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
 -> FutharkiM (Maybe [Char]))
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
-> FutharkiM (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ StateT FutharkiState (InputT IO) (Maybe [Char])
-> ExceptT
     StopReason (StateT FutharkiState (InputT IO)) (Maybe [Char])
forall (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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO (Maybe [Char])
 -> StateT FutharkiState (InputT IO) (Maybe [Char]))
-> InputT IO (Maybe [Char])
-> StateT FutharkiState (InputT IO) (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ [Char] -> InputT IO (Maybe [Char])
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe [Char])
Haskeline.getInputLine [Char]
prompt
      case Maybe [Char]
inp of
        Just [Char]
s -> Text -> FutharkiM Text
forall (m :: * -> *) a. Monad m => a -> m a
return (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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
EOF

getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx)
getIt :: FutharkiM (Imports, VNameSource, Env, Ctx)
getIt = do
  Imports
imports <- (FutharkiState -> Imports) -> FutharkiM Imports
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Imports
futharkiImports
  VNameSource
src <- (FutharkiState -> VNameSource) -> FutharkiM VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> VNameSource
futharkiNameSource
  (Env
tenv, Ctx
ienv) <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
  (Imports, VNameSource, Env, Ctx)
-> FutharkiM (Imports, VNameSource, Env, Ctx)
forall (m :: * -> *) a. Monad m => a -> m a
return (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv)

onDec :: UncheckedDec -> FutharkiM ()
onDec :: UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d = do
  (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
  ImportName
cur_import <- (FutharkiState -> ImportName) -> FutharkiM ImportName
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> ImportName) -> FutharkiM ImportName)
-> (FutharkiState -> ImportName) -> FutharkiM ImportName
forall a b. (a -> b) -> a -> b
$ [Char] -> ImportName
T.mkInitialImport ([Char] -> ImportName)
-> (FutharkiState -> [Char]) -> FutharkiState -> ImportName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"." (Maybe [Char] -> [Char])
-> (FutharkiState -> Maybe [Char]) -> FutharkiState -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe [Char]
futharkiLoaded

  -- Most of the complexity here concerns the dealing with the fact
  -- that 'import "foo"' is a declaration.  We have to involve a lot
  -- of machinery to load this external code before executing the
  -- declaration itself.
  let basis :: Basis
basis = Imports -> VNameSource -> [[Char]] -> Basis
Basis Imports
imports VNameSource
src [[Char]
"/prelude/prelude"]
      mkImport :: ([Char], SrcLoc) -> ImportName
mkImport = ([Char] -> SrcLoc -> ImportName) -> ([Char], SrcLoc) -> ImportName
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (([Char] -> SrcLoc -> ImportName)
 -> ([Char], SrcLoc) -> ImportName)
-> ([Char] -> SrcLoc -> ImportName)
-> ([Char], SrcLoc)
-> ImportName
forall a b. (a -> b) -> a -> b
$ ImportName -> [Char] -> SrcLoc -> ImportName
T.mkImportFrom ImportName
cur_import
  Either CompilerError (Warnings, Imports, VNameSource)
imp_r <- ExceptT CompilerError FutharkiM (Warnings, Imports, VNameSource)
-> FutharkiM
     (Either CompilerError (Warnings, Imports, VNameSource))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT CompilerError FutharkiM (Warnings, Imports, VNameSource)
 -> FutharkiM
      (Either CompilerError (Warnings, Imports, VNameSource)))
-> ExceptT CompilerError FutharkiM (Warnings, Imports, VNameSource)
-> FutharkiM
     (Either CompilerError (Warnings, Imports, VNameSource))
forall a b. (a -> b) -> a -> b
$ Basis
-> [ImportName]
-> ExceptT CompilerError FutharkiM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
Basis -> [ImportName] -> m (Warnings, Imports, VNameSource)
readImports Basis
basis ((([Char], SrcLoc) -> ImportName)
-> [([Char], SrcLoc)] -> [ImportName]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], SrcLoc) -> ImportName
mkImport ([([Char], SrcLoc)] -> [ImportName])
-> [([Char], SrcLoc)] -> [ImportName]
forall a b. (a -> b) -> a -> b
$ UncheckedDec -> [([Char], SrcLoc)]
forall (f :: * -> *) vn. DecBase f vn -> [([Char], SrcLoc)]
decImports UncheckedDec
d)

  case Either CompilerError (Warnings, Imports, VNameSource)
imp_r of
    Left CompilerError
e -> IO () -> FutharkiM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ CompilerError -> IO ()
forall a. Show a => a -> IO ()
print CompilerError
e
    Right (Warnings
_, Imports
imports', VNameSource
src') ->
      case Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports' VNameSource
src' Env
tenv ImportName
cur_import UncheckedDec
d of
        (Warnings
_, Left TypeError
e) -> IO () -> FutharkiM ()
forall (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
$ TypeError -> [Char]
forall a. Pretty a => a -> [Char]
pretty TypeError
e
        (Warnings
_, Right (Env
tenv', Dec
d', VNameSource
src'')) -> do
          let new_imports :: Imports
new_imports = (([Char], FileModule) -> Bool) -> Imports -> Imports
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (([Char], FileModule) -> [Char]) -> Imports -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], FileModule) -> [Char]
forall a b. (a, b) -> a
fst Imports
imports) ([Char] -> Bool)
-> (([Char], FileModule) -> [Char]) -> ([Char], FileModule) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], FileModule) -> [Char]
forall a b. (a, b) -> a
fst) Imports
imports'
          Either InterpreterError Ctx
int_r <- F ExtOp Ctx -> FutharkiM (Either InterpreterError Ctx)
forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter (F ExtOp Ctx -> FutharkiM (Either InterpreterError Ctx))
-> F ExtOp Ctx -> FutharkiM (Either InterpreterError Ctx)
forall a b. (a -> b) -> a -> b
$ do
            let onImport :: Ctx -> ([Char], FileModule) -> F ExtOp Ctx
onImport Ctx
ienv' ([Char]
s, FileModule
imp) =
                  Ctx -> ([Char], Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ienv' ([Char]
s, FileModule -> Prog
T.fileProg FileModule
imp)
            Ctx
ienv' <- (Ctx -> ([Char], 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 -> ([Char], FileModule) -> F ExtOp Ctx
onImport Ctx
ienv Imports
new_imports
            Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv' Dec
d'
          case Either InterpreterError Ctx
int_r of
            Left InterpreterError
err -> IO () -> FutharkiM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ InterpreterError -> IO ()
forall a. Show a => a -> IO ()
print InterpreterError
err
            Right Ctx
ienv' -> (FutharkiState -> FutharkiState) -> FutharkiM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkiState -> FutharkiState) -> FutharkiM ())
-> (FutharkiState -> FutharkiState) -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
              FutharkiState
s
                { futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv', Ctx
ienv'),
                  futharkiImports :: Imports
futharkiImports = Imports
imports',
                  futharkiNameSource :: VNameSource
futharkiNameSource = 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) -> IO () -> FutharkiM ()
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
$ TypeError -> [Char]
forall a. Pretty a => a -> [Char]
pretty TypeError
err
    (Warnings
_, Right ([TypeParam]
tparams, Exp
e'))
      | [TypeParam] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
tparams -> do
        Either InterpreterError Value
r <- F ExtOp Value -> FutharkiM (Either InterpreterError Value)
forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter (F ExtOp Value -> FutharkiM (Either InterpreterError Value))
-> F ExtOp Value -> FutharkiM (Either InterpreterError Value)
forall a b. (a -> b) -> a -> b
$ Ctx -> Exp -> F ExtOp Value
I.interpretExp Ctx
ienv Exp
e'
        case Either InterpreterError Value
r of
          Left InterpreterError
err -> IO () -> FutharkiM ()
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 Value
v -> IO () -> FutharkiM ()
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
$ Value -> [Char]
forall a. Pretty a => a -> [Char]
pretty Value
v
      | Bool
otherwise -> IO () -> FutharkiM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Inferred type of expression: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ PatternType -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Exp -> PatternType
typeOf Exp
e')
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Char]
"The following types are ambiguous: "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " ((TypeParam -> [Char]) -> [TypeParam] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (VName -> [Char]
forall v. IsName v => v -> [Char]
prettyName (VName -> [Char]) -> (TypeParam -> VName) -> TypeParam -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeParam -> VName
forall vn. TypeParamBase vn -> vn
typeParamName) [TypeParam]
tparams)

prettyBreaking :: Breaking -> String
prettyBreaking :: Breaking -> [Char]
prettyBreaking Breaking
b =
  Int -> [[Char]] -> [Char]
prettyStacktrace (Breaking -> Int
breakingAt Breaking
b) ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ (StackFrame -> [Char]) -> [StackFrame] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map StackFrame -> [Char]
forall a. Located a => a -> [Char]
locStr ([StackFrame] -> [[Char]]) -> [StackFrame] -> [[Char]]
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 (m :: * -> *) a. Monad m => a -> m a
return (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 (m :: * -> *) a. Monad m => a -> m a
return (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 Loc
w [Char]
v FutharkiM (Either InterpreterError b)
c) = do
      IO () -> FutharkiM ()
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]
"Trace at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SrcLoc -> [Char]
forall a. Located a => a -> [Char]
locStr (Loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Loc
w) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v
      FutharkiM (Either InterpreterError b)
c
    intOp (I.ExtOpBreak BreakReason
why NonEmpty StackFrame
callstack FutharkiM (Either InterpreterError b)
c) = do
      FutharkiState
s <- FutharkiM FutharkiState
forall s (m :: * -> *). MonadState s m => m s
get

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

      -- Are we supposed to respect this breakpoint?
      Bool -> FutharkiM () -> FutharkiM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkiState -> StackFrame -> BreakReason -> Bool
breakForReason FutharkiState
s StackFrame
top BreakReason
why) (FutharkiM () -> FutharkiM ()) -> FutharkiM () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ do
        IO () -> FutharkiM ()
forall (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]
why' [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ StackFrame -> [Char]
forall a. Located a => a -> [Char]
locStr StackFrame
top
        IO () -> FutharkiM ()
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
$ Breaking -> [Char]
prettyBreaking Breaking
breaking
        IO () -> FutharkiM ()
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]
"<Enter> to continue."

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

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

      FutharkiM (Either InterpreterError b)
c

runInterpreter' :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a)
runInterpreter' :: forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (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 -> m (Either InterpreterError a)
forall (m :: * -> *) a. Monad m => a -> m a
return (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 {m :: * -> *} {b}.
MonadIO m =>
ExtOp (m (Either InterpreterError b))
-> m (Either InterpreterError b)
intOp
  where
    intOp :: ExtOp (m (Either InterpreterError b))
-> m (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) = Either InterpreterError b -> m (Either InterpreterError b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either InterpreterError b -> m (Either InterpreterError b))
-> Either InterpreterError b -> m (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 Loc
w [Char]
v m (Either InterpreterError b)
c) = do
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Trace at " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Loc -> [Char]
forall a. Located a => a -> [Char]
locStr Loc
w [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v
      m (Either InterpreterError b)
c
    intOp (I.ExtOpBreak BreakReason
_ NonEmpty StackFrame
_ m (Either InterpreterError b)
c) = m (Either InterpreterError b)
c

type Command = T.Text -> FutharkiM ()

loadCommand :: Command
loadCommand :: Command
loadCommand Text
file = do
  Maybe [Char]
loaded <- (FutharkiState -> Maybe [Char]) -> FutharkiM (Maybe [Char])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe [Char]
futharkiLoaded
  case (Text -> Bool
T.null Text
file, Maybe [Char]
loaded) of
    (Bool
True, Just [Char]
loaded') -> StopReason -> FutharkiM ()
forall 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 (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 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 ::
  Show err =>
  (String -> T.Text -> Either err a) ->
  (Imports -> VNameSource -> T.Env -> a -> (Warnings, Either T.TypeError b)) ->
  (b -> String) ->
  Command
genTypeCommand :: forall err a b.
Show err =>
([Char] -> Text -> Either err a)
-> (Imports
    -> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either err a
f Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g b -> [Char]
h Text
e = do
  [Char]
prompt <- FutharkiM [Char]
getPrompt
  case [Char] -> Text -> Either err a
f [Char]
prompt Text
e of
    Left err
err -> IO () -> FutharkiM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkiM ()) -> IO () -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ err -> IO ()
forall a. Show a => a -> IO ()
print err
err
    Right a
e' -> do
      Imports
imports <- (FutharkiState -> Imports) -> FutharkiM Imports
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Imports
futharkiImports
      VNameSource
src <- (FutharkiState -> VNameSource) -> FutharkiM VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> VNameSource
futharkiNameSource
      (Env
tenv, Ctx
_) <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
      case (Warnings, Either TypeError b) -> Either TypeError b
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError b) -> Either TypeError b)
-> (Warnings, Either TypeError b) -> Either TypeError b
forall a b. (a -> b) -> a -> b
$ Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g Imports
imports VNameSource
src Env
tenv a
e' of
        Left TypeError
err -> IO () -> FutharkiM ()
forall (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
$ TypeError -> [Char]
forall a. Pretty a => a -> [Char]
pretty TypeError
err
        Right b
x -> IO () -> FutharkiM ()
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
$ b -> [Char]
h b
x

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

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

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

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

frameCommand :: Command
frameCommand :: Command
frameCommand Text
which = do
  Maybe (NonEmpty StackFrame)
maybe_stack <- (FutharkiState -> Maybe (NonEmpty StackFrame))
-> FutharkiM (Maybe (NonEmpty StackFrame))
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> Maybe (NonEmpty StackFrame))
 -> FutharkiM (Maybe (NonEmpty StackFrame)))
-> (FutharkiState -> Maybe (NonEmpty StackFrame))
-> FutharkiM (Maybe (NonEmpty StackFrame))
forall a b. (a -> b) -> a -> b
$ (Breaking -> NonEmpty StackFrame)
-> Maybe Breaking -> Maybe (NonEmpty StackFrame)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Breaking -> NonEmpty StackFrame
breakingStack (Maybe Breaking -> Maybe (NonEmpty StackFrame))
-> (FutharkiState -> Maybe Breaking)
-> FutharkiState
-> Maybe (NonEmpty StackFrame)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
  case (Maybe (NonEmpty StackFrame)
maybe_stack, [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe ([Char] -> Maybe Int) -> [Char] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
which) of
    (Just NonEmpty StackFrame
stack, Just Int
i)
      | StackFrame
frame : [StackFrame]
_ <- Int -> NonEmpty StackFrame -> [StackFrame]
forall a. Int -> NonEmpty a -> [a]
NE.drop Int
i NonEmpty StackFrame
stack -> do
        let breaking :: Breaking
breaking = NonEmpty StackFrame -> Int -> Breaking
Breaking NonEmpty StackFrame
stack Int
i
            ctx :: Ctx
ctx = StackFrame -> Ctx
I.stackFrameCtx StackFrame
frame
            tenv :: Env
tenv = Env -> Env
I.typeCheckerEnv (Env -> Env) -> Env -> Env
forall a b. (a -> b) -> a -> b
$ Ctx -> Env
I.ctxEnv Ctx
ctx
        (FutharkiState -> FutharkiState) -> FutharkiM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkiState -> FutharkiState) -> FutharkiM ())
-> (FutharkiState -> FutharkiState) -> FutharkiM ()
forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
          FutharkiState
s
            { futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
              futharkiBreaking :: Maybe Breaking
futharkiBreaking = Breaking -> Maybe Breaking
forall a. a -> Maybe a
Just Breaking
breaking
            }
        IO () -> FutharkiM ()
forall (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
$ Breaking -> [Char]
prettyBreaking Breaking
breaking
    (Just NonEmpty StackFrame
_, Maybe Int
_) ->
      IO () -> FutharkiM ()
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 (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 (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 (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 (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 (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
    Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd
    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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Exit

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

  > :load foo.fut

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

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

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