{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
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 qualified Data.Map as M
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.Util (fancyTerminal)
import Futhark.Util.Options
import Futhark.Version
import Language.Futhark
import qualified Language.Futhark.Interpreter as I
import Language.Futhark.Parser
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]
"| | \\ | | | \\ \\"
]
main :: String -> [String] -> IO ()
main :: [Char] -> [[Char]] -> IO ()
main = ()
-> [FunOptDescr ()]
-> [Char]
-> ([[Char]] -> () -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
forall cfg.
cfg
-> [FunOptDescr cfg]
-> [Char]
-> ([[Char]] -> cfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
mainWithOptions () [] [Char]
"options... [program.fut]" [[Char]] -> () -> Maybe (IO ())
forall {p}. [[Char]] -> p -> Maybe (IO ())
run
where
run :: [[Char]] -> p -> Maybe (IO ())
run [] p
_ = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl Maybe [Char]
forall a. Maybe a
Nothing
run [[Char]
prog] p
_ = IO () -> Maybe (IO ())
forall a. a -> Maybe a
Just (IO () -> Maybe (IO ())) -> IO () -> Maybe (IO ())
forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl (Maybe [Char] -> IO ()) -> Maybe [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
prog
run [[Char]]
_ p
_ = Maybe (IO ())
forall a. Maybe a
Nothing
data StopReason = EOF | Stop | Exit | Load FilePath | Interrupt
repl :: Maybe FilePath -> IO ()
repl :: Maybe [Char] -> IO ()
repl Maybe [Char]
maybe_prog = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancyTerminal (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
[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') <-
InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
Haskeline.handleInterrupt ((Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StopReason -> Either StopReason Any
forall a b. a -> Either a b
Left StopReason
Interrupt, FutharkiState
s))
(InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState))
-> (InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Haskeline.withInterrupt
(InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> InputT IO (Either StopReason Any, FutharkiState)
forall a b. (a -> b) -> a -> b
$ StateT FutharkiState (InputT IO) (Either StopReason Any)
-> FutharkiState
-> InputT IO (Either StopReason Any, FutharkiState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any))
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall a b. (a -> b) -> a -> b
$ FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM (FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any)
-> FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a b. (a -> b) -> a -> b
$ FutharkiM () -> FutharkiM Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint) FutharkiState
s
case Either StopReason Any
stop of
Left StopReason
Stop -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
Left StopReason
EOF -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
Left StopReason
Exit -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
Left StopReason
Interrupt -> do
IO () -> InputT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> InputT IO ()) -> IO () -> InputT IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Interrupted"
FutharkiState -> InputT IO ()
toploop FutharkiState
s' {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1}
Left (Load [Char]
file) -> do
IO () -> InputT IO ()
forall (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
-> LoadedProg -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState (FutharkiState -> Int
futharkiCount FutharkiState
s) (FutharkiState -> LoadedProg
futharkiProg 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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
finish :: FutharkiState -> InputT IO ()
finish FutharkiState
s = do
Bool
quit <- if Bool
fancyTerminal then InputT IO Bool
confirmQuit else Bool -> InputT IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
if Bool
quit then () -> InputT IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure () 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
-> LoadedProg -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg 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
-> LoadedProg -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg 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 (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s {futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_prog}
Right FutharkiState
s ->
FutharkiState -> IO FutharkiState
forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s
Settings IO -> InputT IO () -> IO ()
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Haskeline.runInputT Settings IO
forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings (InputT IO () -> IO ()) -> InputT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FutharkiState -> InputT IO ()
toploop FutharkiState
s
[Char] -> IO ()
putStrLn [Char]
"Leaving 'futhark repl'."
confirmQuit :: Haskeline.InputT IO Bool
confirmQuit :: InputT IO Bool
confirmQuit = do
Maybe Char
c <- [Char] -> InputT IO (Maybe Char)
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe Char)
Haskeline.getInputChar [Char]
"Quit REPL? (y/n) "
case Maybe Char
c of
Maybe Char
Nothing -> Bool -> InputT IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just Char
'y' -> Bool -> InputT IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just Char
'n' -> Bool -> InputT IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Maybe Char
_ -> InputT IO Bool
confirmQuit
data Breaking = Breaking
{ Breaking -> NonEmpty StackFrame
breakingStack :: NE.NonEmpty I.StackFrame,
Breaking -> Int
breakingAt :: Int
}
data FutharkiState = FutharkiState
{ FutharkiState -> LoadedProg
futharkiProg :: LoadedProg,
FutharkiState -> Int
futharkiCount :: Int,
FutharkiState -> (Env, Ctx)
futharkiEnv :: (T.Env, I.Ctx),
FutharkiState -> Maybe Breaking
futharkiBreaking :: Maybe Breaking,
FutharkiState -> [Loc]
futharkiSkipBreaks :: [Loc],
FutharkiState -> Bool
futharkiBreakOnNaN :: Bool,
FutharkiState -> Maybe [Char]
futharkiLoaded :: Maybe FilePath
}
extendEnvs :: LoadedProg -> (T.Env, I.Ctx) -> [String] -> (T.Env, I.Ctx)
extendEnvs :: LoadedProg -> (Env, Ctx) -> [[Char]] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env
tenv, Ctx
ictx) [[Char]]
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 = (([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
`elem` [[Char]]
opens) ([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) -> Imports -> Imports
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports LoadedProg
prog
i_envs :: [Env]
i_envs = (([Char], Env) -> Env) -> [([Char], Env)] -> [Env]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], Env) -> Env
forall a b. (a, b) -> b
snd ([([Char], Env)] -> [Env]) -> [([Char], Env)] -> [Env]
forall a b. (a -> b) -> a -> b
$ (([Char], Env) -> Bool) -> [([Char], Env)] -> [([Char], Env)]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [[Char]] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]]
opens) ([Char] -> Bool)
-> (([Char], Env) -> [Char]) -> ([Char], Env) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], Env) -> [Char]
forall a b. (a, b) -> a
fst) ([([Char], Env)] -> [([Char], Env)])
-> [([Char], Env)] -> [([Char], Env)]
forall a b. (a -> b) -> a -> b
$ Map [Char] Env -> [([Char], Env)]
forall k a. Map k a -> [(k, a)]
M.toList (Map [Char] Env -> [([Char], Env)])
-> Map [Char] Env -> [([Char], Env)]
forall a b. (a -> b) -> a -> b
$ Ctx -> Map [Char] Env
I.ctxImports Ctx
ictx
newFutharkiState :: Int -> LoadedProg -> Maybe FilePath -> IO (Either String FutharkiState)
newFutharkiState :: Int
-> LoadedProg -> Maybe [Char] -> IO (Either [Char] FutharkiState)
newFutharkiState Int
count LoadedProg
prev_prog 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
(LoadedProg
prog, Env
tenv, Ctx
ienv) <- case Maybe [Char]
maybe_file of
Maybe [Char]
Nothing -> do
LoadedProg
prog <-
(NonEmpty ProgError -> [Char])
-> Either (NonEmpty ProgError) LoadedProg
-> ExceptT [Char] IO LoadedProg
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft NonEmpty ProgError -> [Char]
prettyProgErrors (Either (NonEmpty ProgError) LoadedProg
-> ExceptT [Char] IO LoadedProg)
-> ExceptT [Char] IO (Either (NonEmpty ProgError) LoadedProg)
-> ExceptT [Char] IO LoadedProg
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either (NonEmpty ProgError) LoadedProg)
-> ExceptT [Char] IO (Either (NonEmpty ProgError) LoadedProg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
reloadProg LoadedProg
prev_prog [] VFS
forall k a. Map k a
M.empty)
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) (LoadedProg -> Imports
lpImports LoadedProg
prog)
let (Env
tenv, Ctx
ienv') =
LoadedProg -> (Env, Ctx) -> [[Char]] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env
T.initialEnv, Ctx
ienv) [[Char]
"/prelude/prelude"]
(LoadedProg, Env, Ctx) -> ExceptT [Char] IO (LoadedProg, Env, Ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadedProg
prog, Env
tenv, Ctx
ienv')
Just [Char]
file -> do
LoadedProg
prog <- (NonEmpty ProgError -> [Char])
-> Either (NonEmpty ProgError) LoadedProg
-> ExceptT [Char] IO LoadedProg
forall err a.
(err -> [Char]) -> Either err a -> ExceptT [Char] IO a
badOnLeft NonEmpty ProgError -> [Char]
prettyProgErrors (Either (NonEmpty ProgError) LoadedProg
-> ExceptT [Char] IO LoadedProg)
-> ExceptT [Char] IO (Either (NonEmpty ProgError) LoadedProg)
-> ExceptT [Char] IO LoadedProg
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either (NonEmpty ProgError) LoadedProg)
-> ExceptT [Char] IO (Either (NonEmpty ProgError) LoadedProg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
reloadProg LoadedProg
prev_prog [[Char]
file] VFS
forall k a. Map k a
M.empty)
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 -> [Char]) -> Warnings -> [Char]
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Warnings
lpWarnings LoadedProg
prog
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) (LoadedProg -> Imports
lpImports LoadedProg
prog)
let (Env
tenv, Ctx
ienv') =
LoadedProg -> (Env, Ctx) -> [[Char]] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env
T.initialEnv, Ctx
ienv) [[Char]
"/prelude/prelude", [Char] -> [Char]
dropExtension [Char]
file]
(LoadedProg, Env, Ctx) -> ExceptT [Char] IO (LoadedProg, Env, Ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LoadedProg
prog, Env
tenv, Ctx
ienv')
FutharkiState -> ExceptT [Char] IO FutharkiState
forall (f :: * -> *) a. Applicative f => a -> f a
pure
FutharkiState :: LoadedProg
-> Int
-> (Env, Ctx)
-> Maybe Breaking
-> [Loc]
-> Bool
-> Maybe [Char]
-> FutharkiState
FutharkiState
{ futharkiProg :: LoadedProg
futharkiProg = LoadedProg
prog,
futharkiCount :: Int
futharkiCount = Int
count,
futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ienv),
futharkiBreaking :: Maybe Breaking
futharkiBreaking = Maybe Breaking
forall a. Maybe a
Nothing,
futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = [Loc]
forall a. Monoid a => a
mempty,
futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool
False,
futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_file
}
where
badOnLeft :: (err -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure 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
prettyProgErrors :: NonEmpty ProgError -> [Char]
prettyProgErrors = Doc -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Doc -> [Char])
-> (NonEmpty ProgError -> Doc) -> NonEmpty ProgError -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgError -> Doc
pprProgErrors
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 (f :: * -> *) a. Applicative f => a -> f a
pure ([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]
"]> "
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 (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (Char
':', Text
command) -> do
let (Text
cmdname, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
command
arg :: Text
arg = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
rest
case ((Text, (Command, Text)) -> Bool)
-> [(Text, (Command, Text))] -> [(Text, (Command, Text))]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
cmdname Text -> Text -> Bool
`T.isPrefixOf`) (Text -> Bool)
-> ((Text, (Command, Text)) -> Text)
-> (Text, (Command, Text))
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (Command, Text)) -> Text
forall a b. (a, b) -> a
fst) [(Text, (Command, Text))]
commands of
[] -> IO () -> FutharkiM ()
forall (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 ()) -> (Text -> IO ()) -> Command
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStrLn Command -> Command
forall a b. (a -> b) -> a -> b
$
Text
"Ambiguous command; could be one of "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat (Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
intersperse Text
", " (((Text, (Command, Text)) -> Text)
-> [(Text, (Command, Text))] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, (Command, Text)) -> Text
forall a b. (a, b) -> a
fst [(Text, (Command, Text))]
matches))
Maybe (Char, Text)
_ -> do
Either SyntaxError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e <- FutharkiM Text
-> [Char]
-> Text
-> FutharkiM
(Either SyntaxError (Either UncheckedDec UncheckedExp))
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
_ [Char]
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]
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> FutharkiM Text) -> Text -> FutharkiM Text
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
s
Maybe [Char]
Nothing -> StopReason -> FutharkiM Text
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
EOF
getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx)
getIt :: FutharkiM (Imports, VNameSource, Env, Ctx)
getIt = do
Imports
imports <- (FutharkiState -> Imports) -> FutharkiM Imports
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> Imports) -> FutharkiM Imports)
-> (FutharkiState -> Imports) -> FutharkiM Imports
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports (LoadedProg -> Imports)
-> (FutharkiState -> LoadedProg) -> FutharkiState -> Imports
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
VNameSource
src <- (FutharkiState -> VNameSource) -> FutharkiM VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> VNameSource) -> FutharkiM VNameSource)
-> (FutharkiState -> VNameSource) -> FutharkiM VNameSource
forall a b. (a -> b) -> a -> b
$ LoadedProg -> VNameSource
lpNameSource (LoadedProg -> VNameSource)
-> (FutharkiState -> LoadedProg) -> FutharkiState -> VNameSource
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
(Env
tenv, Ctx
ienv) <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
(Imports, VNameSource, Env, Ctx)
-> FutharkiM (Imports, VNameSource, Env, Ctx)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv)
onDec :: UncheckedDec -> FutharkiM ()
onDec :: UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d = do
Imports
old_imports <- (FutharkiState -> Imports) -> FutharkiM Imports
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> Imports) -> FutharkiM Imports)
-> (FutharkiState -> Imports) -> FutharkiM Imports
forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports (LoadedProg -> Imports)
-> (FutharkiState -> LoadedProg) -> FutharkiState -> Imports
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
ImportName
cur_import <- (FutharkiState -> ImportName) -> FutharkiM ImportName
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((FutharkiState -> ImportName) -> FutharkiM ImportName)
-> (FutharkiState -> ImportName) -> FutharkiM ImportName
forall a b. (a -> b) -> a -> b
$ [Char] -> ImportName
T.mkInitialImport ([Char] -> ImportName)
-> (FutharkiState -> [Char]) -> FutharkiState -> ImportName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe [Char] -> [Char]
forall a. a -> Maybe a -> a
fromMaybe [Char]
"." (Maybe [Char] -> [Char])
-> (FutharkiState -> Maybe [Char]) -> FutharkiState -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe [Char]
futharkiLoaded
let mkImport :: ([Char], 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
files :: [[Char]]
files = (([Char], SrcLoc) -> [Char]) -> [([Char], SrcLoc)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map (ImportName -> [Char]
T.includeToFilePath (ImportName -> [Char])
-> (([Char], SrcLoc) -> ImportName) -> ([Char], SrcLoc) -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], SrcLoc) -> ImportName
mkImport) ([([Char], SrcLoc)] -> [[Char]]) -> [([Char], SrcLoc)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UncheckedDec -> [([Char], SrcLoc)]
forall (f :: * -> *) vn. DecBase f vn -> [([Char], SrcLoc)]
decImports UncheckedDec
d
LoadedProg
cur_prog <- (FutharkiState -> LoadedProg) -> FutharkiM LoadedProg
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> LoadedProg
futharkiProg
Either (NonEmpty ProgError) LoadedProg
imp_r <- IO (Either (NonEmpty ProgError) LoadedProg)
-> FutharkiM (Either (NonEmpty ProgError) LoadedProg)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (NonEmpty ProgError) LoadedProg)
-> FutharkiM (Either (NonEmpty ProgError) LoadedProg))
-> IO (Either (NonEmpty ProgError) LoadedProg)
-> FutharkiM (Either (NonEmpty ProgError) LoadedProg)
forall a b. (a -> b) -> a -> b
$ LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
extendProg LoadedProg
cur_prog [[Char]]
files VFS
forall k a. Map k a
M.empty
case Either (NonEmpty ProgError) LoadedProg
imp_r of
Left NonEmpty ProgError
e -> IO () -> FutharkiM ()
forall (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
$ Doc -> Text
forall a. Pretty a => a -> Text
prettyText (Doc -> Text) -> Doc -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty ProgError -> Doc
pprProgErrors NonEmpty ProgError
e
Right LoadedProg
prog -> do
(Env, Ctx)
env <- (FutharkiState -> (Env, Ctx)) -> FutharkiM (Env, Ctx)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
let (Env
tenv, Ctx
ienv) = LoadedProg -> (Env, Ctx) -> [[Char]] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env, Ctx)
env ((([Char], SrcLoc) -> [Char]) -> [([Char], SrcLoc)] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map ([Char], SrcLoc) -> [Char]
forall a b. (a, b) -> a
fst ([([Char], SrcLoc)] -> [[Char]]) -> [([Char], SrcLoc)] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ UncheckedDec -> [([Char], SrcLoc)]
forall (f :: * -> *) vn. DecBase f vn -> [([Char], SrcLoc)]
decImports UncheckedDec
d)
imports :: Imports
imports = LoadedProg -> Imports
lpImports LoadedProg
prog
src :: VNameSource
src = LoadedProg -> VNameSource
lpNameSource LoadedProg
prog
case Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src Env
tenv ImportName
cur_import UncheckedDec
d of
(Warnings
_, Left TypeError
e) -> IO () -> FutharkiM ()
forall (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
old_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'),
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) -> 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]
++ PatType -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Exp -> PatType
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
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 (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError a
-> FutharkiM (Either InterpreterError a))
-> (a -> Either InterpreterError a)
-> a
-> FutharkiM (Either InterpreterError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either InterpreterError a
forall a b. b -> Either a b
Right) ExtOp (FutharkiM (Either InterpreterError a))
-> FutharkiM (Either InterpreterError a)
forall {b}.
ExtOp (FutharkiM (Either InterpreterError b))
-> FutharkiM (Either InterpreterError b)
intOp
where
intOp :: ExtOp (FutharkiM (Either InterpreterError b))
-> FutharkiM (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) =
Either InterpreterError b -> FutharkiM (Either InterpreterError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b
-> FutharkiM (Either InterpreterError b))
-> Either InterpreterError b
-> FutharkiM (Either InterpreterError b)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left InterpreterError
err
intOp (I.ExtOpTrace [Char]
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]
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 Loc
w BreakReason
why NonEmpty StackFrame
callstack FutharkiM (Either InterpreterError b)
c) = do
FutharkiState
s <- FutharkiM FutharkiState
forall s (m :: * -> *). MonadState s m => m s
get
let why' :: [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
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]
++ Loc -> [Char]
forall a. Located a => a -> [Char]
locStr Loc
w
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."
(Either StopReason Any
stop, FutharkiState
s') <-
ExceptT
StopReason
(StateT FutharkiState (InputT IO))
(Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState)
forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM (ExceptT
StopReason
(StateT FutharkiState (InputT IO))
(Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState))
-> (InputT IO (Either StopReason Any, FutharkiState)
-> ExceptT
StopReason
(StateT FutharkiState (InputT IO))
(Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT
FutharkiState (InputT IO) (Either StopReason Any, FutharkiState)
-> ExceptT
StopReason
(StateT FutharkiState (InputT IO))
(Either StopReason Any, FutharkiState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT
FutharkiState (InputT IO) (Either StopReason Any, FutharkiState)
-> ExceptT
StopReason
(StateT FutharkiState (InputT IO))
(Either StopReason Any, FutharkiState))
-> (InputT IO (Either StopReason Any, FutharkiState)
-> StateT
FutharkiState (InputT IO) (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> ExceptT
StopReason
(StateT FutharkiState (InputT IO))
(Either StopReason Any, FutharkiState)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputT IO (Either StopReason Any, FutharkiState)
-> StateT
FutharkiState (InputT IO) (Either StopReason Any, FutharkiState)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (InputT IO (Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState))
-> InputT IO (Either StopReason Any, FutharkiState)
-> FutharkiM (Either StopReason Any, FutharkiState)
forall a b. (a -> b) -> a -> b
$
StateT FutharkiState (InputT IO) (Either StopReason Any)
-> FutharkiState
-> InputT IO (Either StopReason Any, FutharkiState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
(ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any))
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
-> StateT FutharkiState (InputT IO) (Either StopReason Any)
forall a b. (a -> b) -> a -> b
$ FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM (FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any)
-> FutharkiM Any
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) Any
forall a b. (a -> b) -> a -> b
$ FutharkiM () -> FutharkiM Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint)
FutharkiState
s
{ futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1,
futharkiBreaking :: Maybe Breaking
futharkiBreaking = Breaking -> Maybe Breaking
forall a. a -> Maybe a
Just Breaking
breaking
}
case Either StopReason Any
stop of
Left (Load [Char]
file) -> StopReason -> FutharkiM ()
forall 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 (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError a -> m (Either InterpreterError a))
-> (a -> Either InterpreterError a)
-> a
-> m (Either InterpreterError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either InterpreterError a
forall a b. b -> Either a b
Right) ExtOp (m (Either InterpreterError a))
-> m (Either InterpreterError a)
forall {f :: * -> *} {b}.
MonadIO f =>
ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp
where
intOp :: ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) = Either InterpreterError b -> f (Either InterpreterError b)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either InterpreterError b -> f (Either InterpreterError b))
-> Either InterpreterError b -> f (Either InterpreterError b)
forall a b. (a -> b) -> a -> b
$ InterpreterError -> Either InterpreterError b
forall a b. a -> Either a b
Left InterpreterError
err
intOp (I.ExtOpTrace [Char]
w [Char]
v f (Either InterpreterError b)
c) = do
IO () -> f ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> f ()) -> IO () -> f ()
forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
w [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
v
f (Either InterpreterError b)
c
intOp (I.ExtOpBreak Loc
_ BreakReason
_ NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c
type Command = T.Text -> FutharkiM ()
loadCommand :: Command
loadCommand :: Command
loadCommand Text
file = do
Maybe [Char]
loaded <- (FutharkiState -> Maybe [Char]) -> FutharkiM (Maybe [Char])
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe [Char]
futharkiLoaded
case (Text -> Bool
T.null Text
file, Maybe [Char]
loaded) of
(Bool
True, Just [Char]
loaded') -> StopReason -> FutharkiM ()
forall 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 ::
(String -> T.Text -> Either SyntaxError a) ->
(Imports -> VNameSource -> T.Env -> a -> (Warnings, Either T.TypeError b)) ->
(b -> String) ->
Command
genTypeCommand :: forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError 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 SyntaxError a
f [Char]
prompt Text
e of
Left (SyntaxError Loc
_ [Char]
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]
err
Right a
e' -> do
(Imports
imports, VNameSource
src, Env
tenv, Ctx
_) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
case (Warnings, Either TypeError b) -> Either TypeError b
forall a b. (a, b) -> b
snd ((Warnings, Either TypeError b) -> Either TypeError b)
-> (Warnings, Either TypeError b) -> Either TypeError b
forall a b. (a -> b) -> a -> b
$ Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g Imports
imports VNameSource
src Env
tenv a
e' of
Left TypeError
err -> IO () -> FutharkiM ()
forall (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 SyntaxError UncheckedExp)
-> (Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp)))
-> (([TypeParam], Exp) -> [Char])
-> Command
forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError 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
<> PatType -> [Char]
forall a. Pretty a => a -> [Char]
pretty (Exp -> PatType
typeOf Exp
e)
mtypeCommand :: Command
mtypeCommand :: Command
mtypeCommand = ([Char] -> Text -> Either SyntaxError (ModExpBase NoInfo Name))
-> (Imports
-> VNameSource
-> Env
-> ModExpBase NoInfo Name
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName)))
-> ((MTy, ModExpBase Info VName) -> [Char])
-> Command
forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError (ModExpBase NoInfo Name)
parseModExp Imports
-> VNameSource
-> Env
-> ModExpBase NoInfo Name
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
T.checkModExp (((MTy, ModExpBase Info VName) -> [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.
|]
)
)
]