{-# 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, oneLine, pretty, putDoc, putDocLn, unAnnotate, (<+>))
import Futhark.Version
import Language.Futhark
import Language.Futhark.Interpreter qualified as I
import Language.Futhark.Parser
import Language.Futhark.Semantic qualified as T
import Language.Futhark.TypeChecker qualified as T
import NeatInterpolation (text)
import System.Console.Haskeline qualified as Haskeline
import System.Directory
import System.IO (stdout)
import Text.Read (readMaybe)
banner :: Doc AnsiStyle
banner :: Doc AnsiStyle
banner =
forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> Doc AnsiStyle
decorate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) forall a b. (a -> b) -> a -> b
$
[ Text
"┃╱╱ ┃╲ ┃ ┃╲ ┃╲ ╱" :: T.Text,
Text
"┃╱ ┃ ╲ ┃╲ ┃╲ ┃╱ ╱ ",
Text
"┃ ┃ ╲ ┃╱ ┃ ┃╲ ╲ ",
Text
"┃ ┃ ╲ ┃ ┃ ┃ ╲ ╲"
]
where
decorate :: Doc AnsiStyle -> Doc AnsiStyle
decorate = forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
bgColorDull Color
Red forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold forall a. Semigroup a => a -> a -> a
<> Color -> AnsiStyle
color Color
White)
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
Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Inferred type of expression: " forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
align (forall a ann. Pretty a => a -> Doc ann
pretty (Exp -> 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 -> Doc AnsiStyle) ->
Command
genTypeCommand :: forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError a
f Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g b -> Doc AnsiStyle
h Text
e = do
[Char]
prompt <- FutharkiM [Char]
getPrompt
case [Char] -> Text -> Either SyntaxError a
f [Char]
prompt Text
e of
Left (SyntaxError Loc
_ Text
err) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
err
Right a
e' -> do
(Imports
imports, VNameSource
src, Env
tenv, Ctx
_) <- FutharkiM (Imports, VNameSource, Env, Ctx)
getIt
case forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b)
g Imports
imports VNameSource
src Env
tenv a
e' of
Left TypeError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ TypeError -> Doc AnsiStyle
T.prettyTypeErrorNoLoc TypeError
err
Right b
x -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle -> IO ()
putDocLn forall a b. (a -> b) -> a -> b
$ b -> Doc AnsiStyle
h b
x
typeCommand :: Command
typeCommand :: Command
typeCommand = forall a b.
([Char] -> Text -> Either SyntaxError a)
-> (Imports
-> VNameSource -> Env -> a -> (Warnings, Either TypeError b))
-> (b -> Doc AnsiStyle)
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError UncheckedExp
parseExp Imports
-> VNameSource
-> Env
-> UncheckedExp
-> (Warnings, Either TypeError ([TypeParam], Exp))
T.checkExp forall a b. (a -> b) -> a -> b
$ \([TypeParam]
ps, Exp
e) ->
forall ann. Doc ann -> Doc ann
oneLine (forall a ann. Pretty a => a -> Doc ann
pretty Exp
e)
forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((Doc AnsiStyle
" " <>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a ann. Pretty a => a -> Doc ann
pretty) [TypeParam]
ps
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
" : "
forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
oneLine (forall a ann. Pretty a => a -> Doc ann
pretty (Exp -> 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 -> Doc AnsiStyle)
-> Command
genTypeCommand [Char] -> Text -> Either SyntaxError (ModExpBase NoInfo Name)
parseModExp Imports
-> VNameSource
-> Env
-> ModExpBase NoInfo Name
-> (Warnings, Either TypeError (MTy, ModExpBase Info VName))
T.checkModExp forall a b. (a -> b) -> a -> b
$ forall a ann. Pretty a => a -> Doc ann
pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst
unbreakCommand :: Command
unbreakCommand :: Command
unbreakCommand Text
_ = do
Maybe StackFrame
top <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. NonEmpty a -> a
NE.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Breaking -> NonEmpty StackFrame
breakingStack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
case Maybe StackFrame
top of
Maybe StackFrame
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Not currently stopped at a breakpoint."
Just StackFrame
top' -> do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiSkipBreaks :: [Loc]
futharkiSkipBreaks = forall a. Located a => a -> Loc
locOf StackFrame
top' forall a. a -> [a] -> [a]
: FutharkiState -> [Loc]
futharkiSkipBreaks FutharkiState
s}
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Stop
nanbreakCommand :: Command
nanbreakCommand :: Command
nanbreakCommand Text
_ = do
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s -> FutharkiState
s {futharkiBreakOnNaN :: Bool
futharkiBreakOnNaN = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ FutharkiState -> Bool
futharkiBreakOnNaN FutharkiState
s}
Bool
b <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkiState -> Bool
futharkiBreakOnNaN
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
if Bool
b
then [Char]
"Now treating NaNs as breakpoints."
else [Char]
"No longer treating NaNs as breakpoints."
frameCommand :: Command
frameCommand :: Command
frameCommand Text
which = do
Maybe (NonEmpty StackFrame)
maybe_stack <- forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Breaking -> NonEmpty StackFrame
breakingStack forall b c a. (b -> c) -> (a -> b) -> a -> c
. FutharkiState -> Maybe Breaking
futharkiBreaking
case (Maybe (NonEmpty StackFrame)
maybe_stack, forall a. Read a => [Char] -> Maybe a
readMaybe forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
which) of
(Just NonEmpty StackFrame
stack, Just Int
i)
| StackFrame
frame : [StackFrame]
_ <- forall a. Int -> NonEmpty a -> [a]
NE.drop Int
i NonEmpty StackFrame
stack -> do
let breaking :: Breaking
breaking = NonEmpty StackFrame -> Int -> Breaking
Breaking NonEmpty StackFrame
stack Int
i
ctx :: Ctx
ctx = StackFrame -> Ctx
I.stackFrameCtx StackFrame
frame
tenv :: Env
tenv = Env -> Env
I.typeCheckerEnv forall a b. (a -> b) -> a -> b
$ Ctx -> Env
I.ctxEnv Ctx
ctx
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify forall a b. (a -> b) -> a -> b
$ \FutharkiState
s ->
FutharkiState
s
{ futharkiEnv :: (Env, Ctx)
futharkiEnv = (Env
tenv, Ctx
ctx),
futharkiBreaking :: Maybe Breaking
futharkiBreaking = forall a. a -> Maybe a
Just Breaking
breaking
}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Breaking -> Text
prettyBreaking Breaking
breaking
(Just NonEmpty StackFrame
_, Maybe Int
_) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid stack index: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
which
(Maybe (NonEmpty StackFrame)
Nothing, Maybe Int
_) ->
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Not stopped at a breakpoint."
pwdCommand :: Command
pwdCommand :: Command
pwdCommand Text
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [Char]
getCurrentDirectory
cdCommand :: Command
cdCommand :: Command
cdCommand Text
dir
| Text -> Bool
T.null Text
dir = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn [Char]
"Usage: ':cd <dir>'."
| Bool
otherwise =
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
[Char] -> IO ()
setCurrentDirectory (Text -> [Char]
T.unpack Text
dir)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
err :: IOException) -> forall a. Show a => a -> IO ()
print IOException
err
helpCommand :: Command
helpCommand :: Command
helpCommand Text
_ = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Text, (Command, Text))]
commands forall a b. (a -> b) -> a -> b
$ \(Text
cmd, (Command
_, Text
desc)) -> do
Doc AnsiStyle -> IO ()
putDoc forall a b. (a -> b) -> a -> b
$ forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
":" forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty Text
cmd forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline
Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
T.replicate (Int
1 forall a. Num a => a -> a -> a
+ Text -> Int
T.length Text
cmd) Text
"─"
Text -> IO ()
T.putStr Text
desc
Text -> IO ()
T.putStrLn Text
""
Text -> IO ()
T.putStrLn Text
""
quitCommand :: Command
quitCommand :: Command
quitCommand Text
_ = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StopReason
Exit
commands :: [(T.Text, (Command, T.Text))]
commands :: [(Text, (Command, Text))]
commands =
[ ( Text
"load",
( Command
loadCommand,
[text|
Load a Futhark source file. Usage:
> :load foo.fut
If the loading succeeds, any expressions entered subsequently can use the
declarations in the source file.
Only one source file can be loaded at a time. Using the :load command a
second time will replace the previously loaded file. It will also replace
any declarations entered at the REPL.
|]
)
),
( Text
"type",
( Command
typeCommand,
[text|
Show the type of an expression, which must fit on a single line.
|]
)
),
( Text
"mtype",
( Command
mtypeCommand,
[text|
Show the type of a module expression, which must fit on a single line.
|]
)
),
( Text
"unbreak",
( Command
unbreakCommand,
[text|
Skip all future 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.
|]
)
)
]