{-# LANGUAGE QuasiQuotes #-}
module Futhark.CLI.REPL (main) where
import Control.Exception
import Control.Monad
import Control.Monad.Except
import Control.Monad.Free.Church
import Control.Monad.State
import Data.Char
import Data.List (intersperse)
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Version
import Futhark.Compiler
import Futhark.MonadFreshNames
import Futhark.Util (fancyTerminal)
import Futhark.Util.Options
import Futhark.Util.Pretty (AnsiStyle, Color (..), Doc, align, annotate, bgColorDull, bold, brackets, color, docText, docTextForHandle, hardline, pretty, putDoc, putDocLn, unAnnotate, (<+>))
import Futhark.Version
import Language.Futhark
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Parser
import Language.Futhark.Semantic qualified as T
import Language.Futhark.TypeChecker qualified as T
import NeatInterpolation (text)
import System.Console.Haskeline qualified as Haskeline
import System.Directory
import System.IO (stdout)
import Text.Read (readMaybe)
banner :: Doc AnsiStyle
banner :: Doc AnsiStyle
banner =
forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
decorate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall a b. (a -> b) -> a -> b
$
[ Text
"┃╱╱ ┃╲ ┃ ┃╲ ┃╲ ╱" :: T.Text,
Text
"┃╱ ┃ ╲ ┃╲ ┃╲ ┃╱ ╱ ",
Text
"┃ ┃ ╲ ┃╱ ┃ ┃╲ ╲ ",
Text
"┃ ┃ ╲ ┃ ┃ ┃ ╲ ╲"
]
where
decorate :: Doc AnsiStyle -> Doc AnsiStyle
decorate = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
bgColorDull Color
Red forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White)
main :: String -> [String] -> IO ()
main :: [Char] -> [[Char]] -> IO ()
main = forall cfg.
cfg
-> [FunOptDescr cfg]
-> [Char]
-> ([[Char]] -> cfg -> Maybe (IO ()))
-> [Char]
-> [[Char]]
-> IO ()
mainWithOptions () [] [Char]
"options... [program.fut]" forall {p}. [[Char]] -> p -> Maybe (IO ())
run
where
run :: [[Char]] -> p -> Maybe (IO ())
run [] p
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl forall a. Maybe a
Nothing
run [[Char]
prog] p
_ = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Maybe [Char] -> IO ()
repl forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
prog
run [[Char]]
_ p
_ = forall a. Maybe a
Nothing
data StopReason = EOF | Stop | Exit | Load FilePath | Interrupt
repl :: Maybe FilePath -> IO ()
repl :: Maybe [Char] -> IO ()
repl Maybe [Char]
maybe_prog = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
fancyTerminal forall a b. (a -> b) -> a -> b
$ do
Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
banner
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Version " forall a. [a] -> [a] -> [a]
++ Version -> [Char]
showVersion Version
version forall a. [a] -> [a] -> [a]
++ [Char]
"."
[Char] -> IO ()
putStrLn [Char]
"Copyright (C) DIKU, University of Copenhagen, released under the ISC license."
[Char] -> IO ()
putStrLn [Char]
""
Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Run" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold Doc AnsiStyle
":help" forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc AnsiStyle
"for a list of commands."
[Char] -> IO ()
putStrLn [Char]
""
let toploop :: FutharkiState -> InputT IO ()
toploop FutharkiState
s = do
(Either StopReason Any
stop, FutharkiState
s') <-
forall (m :: * -> *) a. MonadMask m => m a -> m a -> m a
Haskeline.handleInterrupt (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left StopReason
Interrupt, FutharkiState
s))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
InputT m a -> InputT m a
Haskeline.withInterrupt
forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint) FutharkiState
s
case Either StopReason Any
stop of
Left StopReason
Stop -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
Left StopReason
EOF -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
Left StopReason
Exit -> FutharkiState -> InputT IO ()
finish FutharkiState
s'
Left StopReason
Interrupt -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"Interrupted"
FutharkiState -> InputT IO ()
toploop FutharkiState
s' {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s' forall a. Num a => a -> a -> a
+ Int
1}
Left (Load [Char]
file) -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Loading " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
file
Either (Doc AnsiStyle) FutharkiState
maybe_new_state <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState (FutharkiState -> Int
futharkiCount FutharkiState
s) (FutharkiState -> LoadedProg
futharkiProg FutharkiState
s) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just [Char]
file
case Either (Doc AnsiStyle) FutharkiState
maybe_new_state of
Right FutharkiState
new_state -> FutharkiState -> InputT IO ()
toploop FutharkiState
new_state
Left Doc AnsiStyle
err -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn Doc AnsiStyle
err
FutharkiState -> InputT IO ()
toploop FutharkiState
s'
Right Any
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
finish :: FutharkiState -> InputT IO ()
finish FutharkiState
s = do
Bool
quit <- if Bool
fancyTerminal then InputT IO Bool
confirmQuit else forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
if Bool
quit then forall (f :: * -> *) a. Applicative f => a -> f a
pure () else FutharkiState -> InputT IO ()
toploop FutharkiState
s
Either (Doc AnsiStyle) FutharkiState
maybe_init_state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg Maybe [Char]
maybe_prog
FutharkiState
s <- case Either (Doc AnsiStyle) FutharkiState
maybe_init_state of
Left Doc AnsiStyle
prog_err -> do
Either (Doc AnsiStyle) FutharkiState
noprog_init_state <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
0 LoadedProg
noLoadedProg forall a. Maybe a
Nothing
case Either (Doc AnsiStyle) FutharkiState
noprog_init_state of
Left Doc AnsiStyle
err ->
forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Failed to initialise interpreter state: " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack (forall a. Doc a -> Text
docText Doc AnsiStyle
err)
Right FutharkiState
s -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc Doc AnsiStyle
prog_err
forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s {futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_prog}
Right FutharkiState
s ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure FutharkiState
s
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
Settings m -> InputT m a -> m a
Haskeline.runInputT forall (m :: * -> *). MonadIO m => Settings m
Haskeline.defaultSettings forall a b. (a -> b) -> a -> b
$ FutharkiState -> InputT IO ()
toploop FutharkiState
s
[Char] -> IO ()
putStrLn [Char]
"Leaving 'futhark repl'."
confirmQuit :: Haskeline.InputT IO Bool
confirmQuit :: InputT IO Bool
confirmQuit = do
Maybe Char
c <- forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe Char)
Haskeline.getInputChar [Char]
"Quit REPL? (y/n) "
case Maybe Char
c of
Maybe Char
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just Char
'y' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
Just Char
'n' -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
Maybe Char
_ -> InputT IO Bool
confirmQuit
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) -> [ImportName] -> (T.Env, I.Ctx)
extendEnvs :: LoadedProg -> (Env, Ctx) -> [ImportName] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env
tenv, Ctx
ictx) [ImportName]
opens = (Env
tenv', Ctx
ictx')
where
tenv' :: Env
tenv' = Imports -> Env -> Env
T.envWithImports Imports
t_imports Env
tenv
ictx' :: Ctx
ictx' = [Env] -> Ctx -> Ctx
I.ctxWithImports [Env]
i_envs Ctx
ictx
t_imports :: Imports
t_imports = forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
opens) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports LoadedProg
prog
i_envs :: [Env]
i_envs = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ImportName]
opens) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ Ctx -> Map ImportName Env
I.ctxImports Ctx
ictx
newFutharkiState :: Int -> LoadedProg -> Maybe FilePath -> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState :: Int
-> LoadedProg
-> Maybe [Char]
-> IO (Either (Doc AnsiStyle) FutharkiState)
newFutharkiState Int
count LoadedProg
prev_prog Maybe [Char]
maybe_file = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ do
let files :: [[Char]]
files = forall a. Maybe a -> [a]
maybeToList Maybe [Char]
maybe_file
LoadedProg
prog <-
forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
reloadProg LoadedProg
prev_prog [[Char]]
files forall k a. Map k a
M.empty)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ Warnings -> Doc AnsiStyle
prettyWarnings forall a b. (a -> b) -> a -> b
$ LoadedProg -> Warnings
lpWarnings LoadedProg
prog
Ctx
ictx <-
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
(\Ctx
ctx -> forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft (forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> (ImportName, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ctx)
Ctx
I.initialCtx
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FileModule -> Prog
fileProg) (LoadedProg -> Imports
lpImports LoadedProg
prog)
let (Env
tenv, Ctx
ienv) =
let (ImportName
iname, FileModule
fm) = forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports LoadedProg
prog
in ( FileModule -> Env
fileScope FileModule
fm,
Ctx
ictx {ctxEnv :: Env
I.ctxEnv = Ctx -> Map ImportName Env
I.ctxImports Ctx
ictx forall k a. Ord k => Map k a -> k -> a
M.! ImportName
iname}
)
forall (f :: * -> *) a. Applicative f => a -> f a
pure
FutharkiState
{ futharkiProg :: LoadedProg
futharkiProg = LoadedProg
prog,
futharkiCount :: Int
futharkiCount = Int
count,
futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ienv),
futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. Maybe a
Nothing,
futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = forall a. Monoid a => a
mempty,
futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool
False,
futharkiLoaded :: Maybe [Char]
futharkiLoaded = Maybe [Char]
maybe_file
}
where
badOnLeft :: (err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft :: forall err err' a.
(err -> err') -> Either err a -> ExceptT err' IO a
badOnLeft err -> err'
_ (Right a
x) = forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
badOnLeft err -> err'
p (Left err
err) = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ err -> err'
p err
err
getPrompt :: FutharkiM String
getPrompt :: FutharkiM [Char]
getPrompt = do
Int
i <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Int
futharkiCount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> [Char]
T.unpack forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO Text
docTextForHandle Handle
stdout forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold forall a b. (a -> b) -> a -> b
$ forall ann. Doc ann -> Doc ann
brackets (forall a ann. Pretty a => a -> Doc ann
pretty Int
i) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
"> "
newtype FutharkiM a = FutharkiM {forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM :: ExceptT StopReason (StateT FutharkiState (Haskeline.InputT IO)) a}
deriving
( forall a b. a -> FutharkiM b -> FutharkiM a
forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FutharkiM b -> FutharkiM a
$c<$ :: forall a b. a -> FutharkiM b -> FutharkiM a
fmap :: forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
$cfmap :: forall a b. (a -> b) -> FutharkiM a -> FutharkiM b
Functor,
Functor FutharkiM
forall a. a -> FutharkiM a
forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
$c<* :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM a
*> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
$c*> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
liftA2 :: forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkiM a -> FutharkiM b -> FutharkiM c
<*> :: forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
$c<*> :: forall a b. FutharkiM (a -> b) -> FutharkiM a -> FutharkiM b
pure :: forall a. a -> FutharkiM a
$cpure :: forall a. a -> FutharkiM a
Applicative,
Applicative FutharkiM
forall a. a -> FutharkiM a
forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> FutharkiM a
$creturn :: forall a. a -> FutharkiM a
>> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
$c>> :: forall a b. FutharkiM a -> FutharkiM b -> FutharkiM b
>>= :: forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
$c>>= :: forall a b. FutharkiM a -> (a -> FutharkiM b) -> FutharkiM b
Monad,
MonadState FutharkiState,
Monad FutharkiM
forall a. IO a -> FutharkiM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> FutharkiM a
$cliftIO :: forall a. IO a -> FutharkiM a
MonadIO,
MonadError StopReason
)
readEvalPrint :: FutharkiM ()
readEvalPrint :: FutharkiM ()
readEvalPrint = do
[Char]
prompt <- FutharkiM [Char]
getPrompt
Text
line <- [Char] -> FutharkiM Text
inputLine [Char]
prompt
Maybe Breaking
breaking <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe Breaking
futharkiBreaking
case Text -> Maybe (Char, Text)
T.uncons Text
line of
Maybe (Char, Text)
Nothing
| forall a. Maybe a -> Bool
isJust Maybe Breaking
breaking -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop
| Bool
otherwise -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just (Char
':', Text
command) -> do
let (Text
cmdname, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isSpace Text
command
arg :: Text
arg = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Text
T.dropWhile Char -> Bool
isSpace Text
rest
case forall a. (a -> Bool) -> [a] -> [a]
filter ((Text
cmdname `T.isPrefixOf`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Text, (Command, Text))]
commands of
[] -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Unknown command '" forall a. Semigroup a => a -> a -> a
<> Text
cmdname forall a. Semigroup a => a -> a -> a
<> Text
"'"
[(Text
_, (Command
cmdf, Text
_))] -> Command
cmdf Text
arg
[(Text, (Command, Text))]
matches ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$
Text
"Ambiguous command; could be one of "
forall a. Semigroup a => a -> a -> a
<> forall a. Monoid a => [a] -> a
mconcat (forall a. a -> [a] -> [a]
intersperse Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Text, (Command, Text))]
matches))
Maybe (Char, Text)
_ -> do
Either SyntaxError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e <- forall (m :: * -> *).
Monad m =>
m Text
-> [Char]
-> Text
-> m (Either SyntaxError (Either UncheckedDec UncheckedExp))
parseDecOrExpIncrM ([Char] -> FutharkiM Text
inputLine [Char]
" ") [Char]
prompt Text
line
case Either SyntaxError (Either UncheckedDec UncheckedExp)
maybe_dec_or_e of
Left (SyntaxError Loc
_ Text
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
err
Right (Left UncheckedDec
d) -> UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d
Right (Right UncheckedExp
e) -> UncheckedExp -> FutharkiM ()
onExp UncheckedExp
e
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s forall a. Num a => a -> a -> a
+ Int
1}
where
inputLine :: [Char] -> FutharkiM Text
inputLine [Char]
prompt = do
Maybe [Char]
inp <- forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
[Char] -> InputT m (Maybe [Char])
Haskeline.getInputLine [Char]
prompt
case Maybe [Char]
inp of
Just [Char]
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
s
Maybe [Char]
Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
EOF
getIt :: FutharkiM (Imports, VNameSource, T.Env, I.Ctx)
getIt :: FutharkiM (Imports, VNameSource, Env, Ctx)
getIt = do
Imports
imports <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
VNameSource
src <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ LoadedProg -> VNameSource
lpNameSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
(Env
tenv, Ctx
ienv) <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv)
onDec :: UncheckedDec -> FutharkiM ()
onDec :: UncheckedDec -> FutharkiM ()
onDec UncheckedDec
d = do
Imports
old_imports <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ LoadedProg -> Imports
lpImports forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> LoadedProg
futharkiProg
ImportName
cur_import <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ [Char] -> ImportName
T.mkInitialImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe [Char]
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe [Char]
futharkiLoaded
let mkImport :: [Char] -> ImportName
mkImport = ImportName -> [Char] -> ImportName
T.mkImportFrom ImportName
cur_import
files :: [[Char]]
files = forall a b. (a -> b) -> [a] -> [b]
map (ImportName -> [Char]
T.includeToFilePath forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ImportName
mkImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. DecBase f vn -> [([Char], Loc)]
decImports UncheckedDec
d
LoadedProg
cur_prog <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> LoadedProg
futharkiProg
Either (NonEmpty ProgError) LoadedProg
imp_r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ LoadedProg
-> [[Char]] -> VFS -> IO (Either (NonEmpty ProgError) LoadedProg)
extendProg LoadedProg
cur_prog [[Char]]
files forall k a. Map k a
M.empty
case Either (NonEmpty ProgError) LoadedProg
imp_r of
Left NonEmpty ProgError
e -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors NonEmpty ProgError
e
Right LoadedProg
prog -> do
(Env, Ctx)
env <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> (Env, Ctx)
futharkiEnv
let (Env
tenv, Ctx
ienv) =
LoadedProg -> (Env, Ctx) -> [ImportName] -> (Env, Ctx)
extendEnvs LoadedProg
prog (Env, Ctx)
env forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> ImportName
T.mkInitialImport forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) vn. DecBase f vn -> [([Char], Loc)]
decImports UncheckedDec
d
imports :: Imports
imports = LoadedProg -> Imports
lpImports LoadedProg
prog
src :: VNameSource
src = LoadedProg -> VNameSource
lpNameSource LoadedProg
prog
case Imports
-> VNameSource
-> Env
-> ImportName
-> UncheckedDec
-> (Warnings, Either TypeError (Env, Dec, VNameSource))
T.checkDec Imports
imports VNameSource
src Env
tenv ImportName
cur_import UncheckedDec
d of
(Warnings
_, Left TypeError
e) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
e
(Warnings
_, Right (Env
tenv', Dec
d', VNameSource
src')) -> do
let new_imports :: Imports
new_imports =
forall a. (a -> Bool) -> [a] -> [a]
filter ((forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst Imports
old_imports) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) Imports
imports
Either InterpreterError Ctx
int_r <- forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter forall a b. (a -> b) -> a -> b
$ do
let onImport :: Ctx -> (ImportName, FileModule) -> F ExtOp Ctx
onImport Ctx
ienv' (ImportName
s, FileModule
imp) =
Ctx -> (ImportName, Prog) -> F ExtOp Ctx
I.interpretImport Ctx
ienv' (ImportName
s, FileModule -> Prog
T.fileProg FileModule
imp)
Ctx
ienv' <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Ctx -> (ImportName, FileModule) -> F ExtOp Ctx
onImport Ctx
ienv Imports
new_imports
Ctx -> Dec -> F ExtOp Ctx
I.interpretDec Ctx
ienv' Dec
d'
case Either InterpreterError Ctx
int_r of
Left InterpreterError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print InterpreterError
err
Right Ctx
ienv' -> forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
FutharkiState
s
{ futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv', Ctx
ienv'),
futharkiProg :: LoadedProg
futharkiProg = LoadedProg
prog {lpNameSource :: VNameSource
lpNameSource = VNameSource
src'}
}
onExp :: UncheckedExp -> FutharkiM ()
onExp :: UncheckedExp -> FutharkiM ()
onExp UncheckedExp
e = do
(Imports
imports, VNameSource
src, Env
tenv, Ctx
ienv) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
case Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp Imports
imports VNameSource
src Env
tenv UncheckedExp
e of
(Warnings
_, Left TypeError
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
(Warnings
_, Right ([TypeParam]
tparams, Exp
e'))
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TypeParam]
tparams -> do
Either InterpreterError Value
r <- forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter forall a b. (a -> b) -> a -> b
$ Ctx -> Exp -> F ExtOp Value
I.interpretExp Ctx
ienv Exp
e'
case Either InterpreterError Value
r of
Left InterpreterError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> IO ()
print InterpreterError
err
Right Value
v -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Value m -> Doc a
I.prettyValue Value
v forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
| Bool
otherwise -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
"Inferred type of expression: " forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> Text
prettyText (Exp -> PatType
typeOf Exp
e')
Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$
Text
"The following types are ambiguous: "
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map (Name -> Text
nameToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. IsName v => v -> Name
toName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall vn. TypeParamBase vn -> vn
typeParamName) [TypeParam]
tparams)
prettyBreaking :: Breaking -> T.Text
prettyBreaking :: Breaking -> Text
prettyBreaking Breaking
b =
Int -> [Text] -> Text
prettyStacktrace (Breaking -> Int
breakingAt Breaking
b) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Located a => a -> Text
locText forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList forall a b. (a -> b) -> a -> b
$ Breaking -> NonEmpty StackFrame
breakingStack Breaking
b
breakForReason :: FutharkiState -> I.StackFrame -> I.BreakReason -> Bool
breakForReason :: FutharkiState -> StackFrame -> BreakReason -> Bool
breakForReason FutharkiState
s StackFrame
_ BreakReason
I.BreakNaN
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s = Bool
False
breakForReason FutharkiState
s StackFrame
top BreakReason
_ =
forall a. Maybe a -> Bool
isNothing (FutharkiState -> Maybe Breaking
futharkiBreaking FutharkiState
s)
Bool -> Bool -> Bool
&& forall a. Located a => a -> Loc
locOf StackFrame
top forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s
runInterpreter :: F I.ExtOp a -> FutharkiM (Either I.InterpreterError a)
runInterpreter :: forall a. F ExtOp a -> FutharkiM (Either InterpreterError a)
runInterpreter F ExtOp a
m = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) forall {b}.
ExtOp (FutharkiM (Either InterpreterError b))
-> FutharkiM (Either InterpreterError b)
intOp
where
intOp :: ExtOp (FutharkiM (Either InterpreterError b))
-> FutharkiM (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) =
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left InterpreterError
err
intOp (I.ExtOpTrace Text
w Doc ()
v FutharkiM (Either InterpreterError b)
c) = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
w forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
v
FutharkiM (Either InterpreterError b)
c
intOp (I.ExtOpBreak Loc
w BreakReason
why NonEmpty StackFrame
callstack FutharkiM (Either InterpreterError b)
c) = do
FutharkiState
s <- forall s (m :: * -> *). MonadState s m => m s
get
let why' :: Text
why' = case BreakReason
why of
BreakReason
I.BreakPoint -> Text
"Breakpoint"
BreakReason
I.BreakNaN -> Text
"NaN produced"
top :: StackFrame
top = forall a. NonEmpty a -> a
NE.head NonEmpty StackFrame
callstack
ctx :: Ctx
ctx = StackFrame -> Ctx
I.stackFrameCtx StackFrame
top
tenv :: Env
tenv = Env -> Env
I.typeCheckerEnv forall a b. (a -> b) -> a -> b
$ Ctx -> Env
I.ctxEnv Ctx
ctx
breaking :: Breaking
breaking = NonEmpty StackFrame -> Int -> Breaking
Breaking NonEmpty StackFrame
callstack Int
0
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkiState -> StackFrame -> BreakReason -> Bool
breakForReason FutharkiState
s StackFrame
top BreakReason
why) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Text
why' forall a. Semigroup a => a -> a -> a
<> Text
" at " forall a. Semigroup a => a -> a -> a
<> forall a. Located a => a -> Text
locText Loc
w
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Breaking -> Text
prettyBreaking Breaking
breaking
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"<Enter> to continue."
(Either StopReason Any
stop, FutharkiState
s') <-
forall a.
ExceptT StopReason (StateT FutharkiState (InputT IO)) a
-> FutharkiM a
FutharkiM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT
(forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall a.
FutharkiM a
-> ExceptT StopReason (StateT FutharkiState (InputT IO)) a
runFutharkiM forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Applicative f => f a -> f b
forever FutharkiM ()
readEvalPrint)
FutharkiState
s
{ futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
futharkiCount :: Int
futharkiCount = FutharkiState -> Int
futharkiCount FutharkiState
s forall a. Num a => a -> a -> a
+ Int
1,
futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. a -> Maybe a
Just Breaking
breaking
}
case Either StopReason Any
stop of
Left (Load [Char]
file) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load [Char]
file
Either StopReason Any
_ -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Continuing..."
forall s (m :: * -> *). MonadState s m => s -> m ()
put
FutharkiState
s
{ futharkiCount :: Int
futharkiCount =
FutharkiState -> Int
futharkiCount FutharkiState
s',
futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks =
FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s' forall a. Semigroup a => a -> a -> a
<> FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s,
futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN =
FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s'
}
FutharkiM (Either InterpreterError b)
c
runInterpreterNoBreak :: MonadIO m => F I.ExtOp a -> m (Either I.InterpreterError a)
runInterpreterNoBreak :: forall (m :: * -> *) a.
MonadIO m =>
F ExtOp a -> m (Either InterpreterError a)
runInterpreterNoBreak F ExtOp a
m = forall (f :: * -> *) a.
F f a -> forall r. (a -> r) -> (f r -> r) -> r
runF F ExtOp a
m (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right) forall {f :: * -> *} {b}.
MonadIO f =>
ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp
where
intOp :: ExtOp (f (Either InterpreterError b))
-> f (Either InterpreterError b)
intOp (I.ExtOpError InterpreterError
err) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left InterpreterError
err
intOp (I.ExtOpTrace Text
w Doc ()
v f (Either InterpreterError b)
c) = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty Text
w forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann -> Doc ann
align (forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
v)
f (Either InterpreterError b)
c
intOp (I.ExtOpBreak Loc
_ BreakReason
_ NonEmpty StackFrame
_ f (Either InterpreterError b)
c) = f (Either InterpreterError b)
c
type Command = T.Text -> FutharkiM ()
loadCommand :: Command
loadCommand :: Command
loadCommand Text
file = do
Maybe [Char]
loaded <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Maybe [Char]
futharkiLoaded
case (Text -> Bool
T.null Text
file, Maybe [Char]
loaded) of
(Bool
True, Just [Char]
loaded') -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load [Char]
loaded'
(Bool
True, Maybe [Char]
Nothing) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
"No file specified and no file previously loaded."
(Bool
False, Maybe [Char]
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ [Char] -> StopReason
Load forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
file
genTypeCommand ::
(String -> T.Text -> Either SyntaxError a) ->
(Imports -> VNameSource -> T.Env -> a -> (Warnings, Either T.TypeError b)) ->
(b -> 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
_ Text
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
err
Right a
e' -> do
(Imports
imports, VNameSource
src, Env
tenv, Ctx
_) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
case forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g Imports
imports VNameSource
src Env
tenv a
e' of
Left TypeError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
Right b
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ b -> [Char]
h b
x
typeCommand :: Command
typeCommand :: Command
typeCommand = forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [Char])
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError UncheckedExp
parseExp Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp forall a b. (a -> b) -> a -> b
$ \([TypeParam]
ps, Exp
e) ->
forall a. Pretty a => a -> [Char]
prettyString Exp
e
forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (([Char]
" " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
prettyString) [TypeParam]
ps
forall a. Semigroup a => a -> a -> a
<> [Char]
" : "
forall a. Semigroup a => a -> a -> a
<> forall a. Pretty a => a -> [Char]
prettyString (Exp -> PatType
typeOf Exp
e)
mtypeCommand :: Command
mtypeCommand :: Command
mtypeCommand = forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> [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 forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> [Char]
prettyString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
unbreakCommand :: Command
unbreakCommand :: Command
unbreakCommand Text
_ = do
Maybe StackFrame
top <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Breaking -> NonEmpty StackFrame
breakingStack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
case Maybe StackFrame
top of
Maybe StackFrame
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Not currently stopped at a breakpoint."
Just StackFrame
top' -> do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = forall a. Located a => a -> Loc
locOf StackFrame
top' forall a. a -> [a] -> [a]
: FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s}
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop
nanbreakCommand :: Command
nanbreakCommand :: Command
nanbreakCommand Text
_ = do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s}
Bool
b <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Bool
futharkiBreakOnNaN
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
if Bool
b
then [Char]
"Now treating NaNs as breakpoints."
else [Char]
"No longer treating NaNs as breakpoints."
frameCommand :: Command
frameCommand :: Command
frameCommand Text
which = do
Maybe (NonEmpty StackFrame)
maybe_stack <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Breaking -> NonEmpty StackFrame
breakingStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
case (Maybe (NonEmpty StackFrame)
maybe_stack, forall a. Read a => [Char] -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
which) of
(Just NonEmpty StackFrame
stack, Just Int
i)
| StackFrame
frame : [StackFrame]
_ <- forall a. Int -> NonEmpty a -> [a]
NE.drop Int
i NonEmpty StackFrame
stack -> do
let breaking :: Breaking
breaking = NonEmpty StackFrame -> Int -> Breaking
Breaking NonEmpty StackFrame
stack Int
i
ctx :: Ctx
ctx = StackFrame -> Ctx
I.stackFrameCtx StackFrame
frame
tenv :: Env
tenv = Env -> Env
I.typeCheckerEnv forall a b. (a -> b) -> a -> b
$ Ctx -> Env
I.ctxEnv Ctx
ctx
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
FutharkiState
s
{ futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. a -> Maybe a
Just Breaking
breaking
}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Breaking -> Text
prettyBreaking Breaking
breaking
(Just NonEmpty StackFrame
_, Maybe Int
_) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid stack index: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
which
(Maybe (NonEmpty StackFrame)
Nothing, Maybe Int
_) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Not stopped at a breakpoint."
pwdCommand :: Command
pwdCommand :: Command
pwdCommand Text
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Char]
getCurrentDirectory
cdCommand :: Command
cdCommand :: Command
cdCommand Text
dir
| Text -> Bool
T.null Text
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Usage: ':cd <dir>'."
| Bool
otherwise =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
setCurrentDirectory (Text -> [Char]
T.unpack Text
dir)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
err :: IOException) -> forall a. Show a => a -> IO ()
print IOException
err
helpCommand :: Command
helpCommand :: Command
helpCommand Text
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, (Command, Text))]
commands forall a b. (a -> b) -> a -> b
$ \(Text
cmd, (Command
_, Text
desc)) -> do
Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
":" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
cmd forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Int
1 forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
cmd) Text
"─"
Text -> IO ()
T.putStr Text
desc
Text -> IO ()
T.putStrLn Text
""
Text -> IO ()
T.putStrLn Text
""
quitCommand :: Command
quitCommand :: Command
quitCommand Text
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Exit
commands :: [(T.Text, (Command, T.Text))]
commands :: [(Text, (Command, Text))]
commands =
[ ( Text
"load",
( Command
loadCommand,
[text|
Load a Futhark source file. Usage:
> :load foo.fut
If the loading succeeds, any expressions entered subsequently can use the
declarations in the source file.
Only one source file can be loaded at a time. Using the :load command a
second time will replace the previously loaded file. It will also replace
any declarations entered at the REPL.
|]
)
),
( Text
"type",
( Command
typeCommand,
[text|
Show the type of an expression, which must fit on a single line.
|]
)
),
( Text
"mtype",
( Command
mtypeCommand,
[text|
Show the type of a module expression, which must fit on a single line.
|]
)
),
( Text
"unbreak",
( Command
unbreakCommand,
[text|
Skip all future 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.
|]
)
)
]