{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts, OverloadedStrings #-}
module Futhark.Pipeline
       ( Pipeline
       , PipelineConfig (..)
       , Action (..)

       , FutharkM
       , runFutharkM
       , Verbosity(..)

       , internalErrorS

       , module Futhark.Error

       , onePass
       , passes
       , runPasses
       )
       where

import Control.Category
import Control.Monad
import Control.Monad.Writer.Strict hiding (pass)
import Control.Monad.Except
import Control.Monad.State
import Control.Monad.Reader
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Clock
import System.IO
import Text.Printf

import Prelude hiding (id, (.))

import qualified Futhark.Analysis.Alias as Alias
import Futhark.Error
import Futhark.Representation.AST (Prog, PrettyLore)
import Futhark.TypeCheck
import Futhark.Pass
import Futhark.Util.Log
import Futhark.Util.Pretty (Pretty, prettyText)
import Futhark.MonadFreshNames

-- | If Verbose, print log messages to standard error.  If
-- VeryVerbose, also print logs from individual passes.
data Verbosity = NotVerbose | Verbose | VeryVerbose deriving (Verbosity -> Verbosity -> Bool
(Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool) -> Eq Verbosity
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Verbosity -> Verbosity -> Bool
$c/= :: Verbosity -> Verbosity -> Bool
== :: Verbosity -> Verbosity -> Bool
$c== :: Verbosity -> Verbosity -> Bool
Eq, Eq Verbosity
Eq Verbosity
-> (Verbosity -> Verbosity -> Ordering)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Bool)
-> (Verbosity -> Verbosity -> Verbosity)
-> (Verbosity -> Verbosity -> Verbosity)
-> Ord Verbosity
Verbosity -> Verbosity -> Bool
Verbosity -> Verbosity -> Ordering
Verbosity -> Verbosity -> Verbosity
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Verbosity -> Verbosity -> Verbosity
$cmin :: Verbosity -> Verbosity -> Verbosity
max :: Verbosity -> Verbosity -> Verbosity
$cmax :: Verbosity -> Verbosity -> Verbosity
>= :: Verbosity -> Verbosity -> Bool
$c>= :: Verbosity -> Verbosity -> Bool
> :: Verbosity -> Verbosity -> Bool
$c> :: Verbosity -> Verbosity -> Bool
<= :: Verbosity -> Verbosity -> Bool
$c<= :: Verbosity -> Verbosity -> Bool
< :: Verbosity -> Verbosity -> Bool
$c< :: Verbosity -> Verbosity -> Bool
compare :: Verbosity -> Verbosity -> Ordering
$ccompare :: Verbosity -> Verbosity -> Ordering
$cp1Ord :: Eq Verbosity
Ord)

newtype FutharkEnv = FutharkEnv { FutharkEnv -> Verbosity
futharkVerbose :: Verbosity }

data FutharkState = FutharkState { FutharkState -> UTCTime
futharkPrevLog :: UTCTime
                                 , FutharkState -> VNameSource
futharkNameSource :: VNameSource }

newtype FutharkM a = FutharkM (ExceptT CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a)
                     deriving (Functor FutharkM
a -> FutharkM a
Functor FutharkM
-> (forall a. a -> FutharkM a)
-> (forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b)
-> (forall a b c.
    (a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c)
-> (forall a b. FutharkM a -> FutharkM b -> FutharkM b)
-> (forall a b. FutharkM a -> FutharkM b -> FutharkM a)
-> Applicative FutharkM
FutharkM a -> FutharkM b -> FutharkM b
FutharkM a -> FutharkM b -> FutharkM a
FutharkM (a -> b) -> FutharkM a -> FutharkM b
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
forall a. a -> FutharkM a
forall a b. FutharkM a -> FutharkM b -> FutharkM a
forall a b. FutharkM a -> FutharkM b -> FutharkM b
forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM 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
<* :: FutharkM a -> FutharkM b -> FutharkM a
$c<* :: forall a b. FutharkM a -> FutharkM b -> FutharkM a
*> :: FutharkM a -> FutharkM b -> FutharkM b
$c*> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
liftA2 :: (a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FutharkM a -> FutharkM b -> FutharkM c
<*> :: FutharkM (a -> b) -> FutharkM a -> FutharkM b
$c<*> :: forall a b. FutharkM (a -> b) -> FutharkM a -> FutharkM b
pure :: a -> FutharkM a
$cpure :: forall a. a -> FutharkM a
$cp1Applicative :: Functor FutharkM
Applicative, a -> FutharkM b -> FutharkM a
(a -> b) -> FutharkM a -> FutharkM b
(forall a b. (a -> b) -> FutharkM a -> FutharkM b)
-> (forall a b. a -> FutharkM b -> FutharkM a) -> Functor FutharkM
forall a b. a -> FutharkM b -> FutharkM a
forall a b. (a -> b) -> FutharkM a -> FutharkM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FutharkM b -> FutharkM a
$c<$ :: forall a b. a -> FutharkM b -> FutharkM a
fmap :: (a -> b) -> FutharkM a -> FutharkM b
$cfmap :: forall a b. (a -> b) -> FutharkM a -> FutharkM b
Functor, Applicative FutharkM
a -> FutharkM a
Applicative FutharkM
-> (forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b)
-> (forall a b. FutharkM a -> FutharkM b -> FutharkM b)
-> (forall a. a -> FutharkM a)
-> Monad FutharkM
FutharkM a -> (a -> FutharkM b) -> FutharkM b
FutharkM a -> FutharkM b -> FutharkM b
forall a. a -> FutharkM a
forall a b. FutharkM a -> FutharkM b -> FutharkM b
forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM 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 :: a -> FutharkM a
$creturn :: forall a. a -> FutharkM a
>> :: FutharkM a -> FutharkM b -> FutharkM b
$c>> :: forall a b. FutharkM a -> FutharkM b -> FutharkM b
>>= :: FutharkM a -> (a -> FutharkM b) -> FutharkM b
$c>>= :: forall a b. FutharkM a -> (a -> FutharkM b) -> FutharkM b
$cp1Monad :: Applicative FutharkM
Monad,
                               MonadError CompilerError,
                               MonadState FutharkState,
                               MonadReader FutharkEnv,
                               Monad FutharkM
Monad FutharkM
-> (forall a. IO a -> FutharkM a) -> MonadIO FutharkM
IO a -> FutharkM a
forall a. IO a -> FutharkM a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> FutharkM a
$cliftIO :: forall a. IO a -> FutharkM a
$cp1MonadIO :: Monad FutharkM
MonadIO)

instance MonadFreshNames FutharkM where
  getNameSource :: FutharkM VNameSource
getNameSource = (FutharkState -> VNameSource) -> FutharkM VNameSource
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkState -> VNameSource
futharkNameSource
  putNameSource :: VNameSource -> FutharkM ()
putNameSource VNameSource
src = (FutharkState -> FutharkState) -> FutharkM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkState -> FutharkState) -> FutharkM ())
-> (FutharkState -> FutharkState) -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ \FutharkState
s -> FutharkState
s { futharkNameSource :: VNameSource
futharkNameSource = VNameSource
src }

instance MonadLogger FutharkM where
  addLog :: Log -> FutharkM ()
addLog = (Text -> FutharkM ()) -> [Text] -> FutharkM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Text -> FutharkM ()
forall (m :: * -> *).
(MonadReader FutharkEnv m, MonadState FutharkState m, MonadIO m) =>
Text -> m ()
perLine ([Text] -> FutharkM ()) -> (Log -> [Text]) -> Log -> FutharkM ()
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [Text]
T.lines (Text -> [Text]) -> (Log -> Text) -> Log -> [Text]
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Log -> Text
toText
    where perLine :: Text -> m ()
perLine Text
msg = do
            Bool
verb <- (FutharkEnv -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FutharkEnv -> Bool) -> m Bool) -> (FutharkEnv -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ (Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>=Verbosity
Verbose) (Verbosity -> Bool)
-> (FutharkEnv -> Verbosity) -> FutharkEnv -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. FutharkEnv -> Verbosity
futharkVerbose
            UTCTime
prev <- (FutharkState -> UTCTime) -> m UTCTime
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets FutharkState -> UTCTime
futharkPrevLog
            UTCTime
now <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
            let delta :: Double
                delta :: Double
delta = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
prev)
                prefix :: String
prefix = String -> Double -> String
forall r. PrintfType r => String -> r
printf String
"[  +%.6f] " Double
delta
            (FutharkState -> FutharkState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((FutharkState -> FutharkState) -> m ())
-> (FutharkState -> FutharkState) -> m ()
forall a b. (a -> b) -> a -> b
$ \FutharkState
s -> FutharkState
s { futharkPrevLog :: UTCTime
futharkPrevLog = UTCTime
now }
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg

runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM :: FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM (FutharkM ExceptT
  CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
m) Verbosity
verbose = do
  FutharkState
s <- UTCTime -> VNameSource -> FutharkState
FutharkState (UTCTime -> VNameSource -> FutharkState)
-> IO UTCTime -> IO (VNameSource -> FutharkState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime IO (VNameSource -> FutharkState)
-> IO VNameSource -> IO FutharkState
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VNameSource -> IO VNameSource
forall (f :: * -> *) a. Applicative f => a -> f a
pure VNameSource
blankNameSource
  ReaderT FutharkEnv IO (Either CompilerError a)
-> FutharkEnv -> IO (Either CompilerError a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (StateT
  FutharkState (ReaderT FutharkEnv IO) (Either CompilerError a)
-> FutharkState -> ReaderT FutharkEnv IO (Either CompilerError a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ExceptT
  CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
-> StateT
     FutharkState (ReaderT FutharkEnv IO) (Either CompilerError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT
  CompilerError (StateT FutharkState (ReaderT FutharkEnv IO)) a
m) FutharkState
s) FutharkEnv
newEnv
  where newEnv :: FutharkEnv
newEnv = Verbosity -> FutharkEnv
FutharkEnv Verbosity
verbose

internalErrorS :: Pretty t => String -> t -> FutharkM a
internalErrorS :: String -> t -> FutharkM a
internalErrorS String
s t
p = CompilerError -> FutharkM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompilerError -> FutharkM a) -> CompilerError -> FutharkM a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ErrorClass -> CompilerError
InternalError (String -> Text
T.pack String
s) (t -> Text
forall a. Pretty a => a -> Text
prettyText t
p) ErrorClass
CompilerBug

data Action lore =
  Action { Action lore -> String
actionName :: String
         , Action lore -> String
actionDescription :: String
         , Action lore -> Prog lore -> FutharkM ()
actionProcedure :: Prog lore -> FutharkM ()
         }

data PipelineConfig =
  PipelineConfig { PipelineConfig -> Bool
pipelineVerbose :: Bool
                 , PipelineConfig -> Bool
pipelineValidate :: Bool
                 }

newtype Pipeline fromlore tolore =
  Pipeline { Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
unPipeline :: PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore) }

instance Category Pipeline where
  id :: Pipeline a a
id = (PipelineConfig -> Prog a -> FutharkM (Prog a)) -> Pipeline a a
forall fromlore tolore.
(PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore))
-> Pipeline fromlore tolore
Pipeline ((PipelineConfig -> Prog a -> FutharkM (Prog a)) -> Pipeline a a)
-> (PipelineConfig -> Prog a -> FutharkM (Prog a)) -> Pipeline a a
forall a b. (a -> b) -> a -> b
$ (Prog a -> FutharkM (Prog a))
-> PipelineConfig -> Prog a -> FutharkM (Prog a)
forall a b. a -> b -> a
const Prog a -> FutharkM (Prog a)
forall (m :: * -> *) a. Monad m => a -> m a
return
  Pipeline b c
p2 . :: Pipeline b c -> Pipeline a b -> Pipeline a c
. Pipeline a b
p1 = (PipelineConfig -> Prog a -> FutharkM (Prog c)) -> Pipeline a c
forall fromlore tolore.
(PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore))
-> Pipeline fromlore tolore
Pipeline PipelineConfig -> Prog a -> FutharkM (Prog c)
perform
    where perform :: PipelineConfig -> Prog a -> FutharkM (Prog c)
perform PipelineConfig
cfg Prog a
prog =
            Pipeline b c -> PipelineConfig -> Prog b -> FutharkM (Prog c)
forall fromlore tolore.
Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
runPasses Pipeline b c
p2 PipelineConfig
cfg (Prog b -> FutharkM (Prog c))
-> FutharkM (Prog b) -> FutharkM (Prog c)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Pipeline a b -> PipelineConfig -> Prog a -> FutharkM (Prog b)
forall fromlore tolore.
Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
runPasses Pipeline a b
p1 PipelineConfig
cfg Prog a
prog

runPasses :: Pipeline fromlore tolore
          -> PipelineConfig
          -> Prog fromlore
          -> FutharkM (Prog tolore)
runPasses :: Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
runPasses = Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
forall fromlore tolore.
Pipeline fromlore tolore
-> PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
unPipeline

onePass :: Checkable tolore =>
           Pass fromlore tolore -> Pipeline fromlore tolore
onePass :: Pass fromlore tolore -> Pipeline fromlore tolore
onePass Pass fromlore tolore
pass = (PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore))
-> Pipeline fromlore tolore
forall fromlore tolore.
(PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore))
-> Pipeline fromlore tolore
Pipeline PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
perform
  where perform :: PipelineConfig -> Prog fromlore -> FutharkM (Prog tolore)
perform PipelineConfig
cfg Prog fromlore
prog = do
          Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
cfg) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ Text -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (Text -> FutharkM ()) -> Text -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
            Text
"Running pass " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Pass fromlore tolore -> String
forall fromlore tolore. Pass fromlore tolore -> String
passName Pass fromlore tolore
pass)
          Prog tolore
prog' <- Pass fromlore tolore -> Prog fromlore -> FutharkM (Prog tolore)
forall fromlore tolore.
Pass fromlore tolore -> Prog fromlore -> FutharkM (Prog tolore)
runPass Pass fromlore tolore
pass Prog fromlore
prog
          let prog'' :: Prog (Aliases tolore)
prog'' = Prog tolore -> Prog (Aliases tolore)
forall lore.
(Attributes lore, CanBeAliased (Op lore)) =>
Prog lore -> Prog (Aliases lore)
Alias.aliasAnalysis Prog tolore
prog'
          Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineValidate PipelineConfig
cfg) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
            case Prog (Aliases tolore) -> Either (TypeError tolore) ()
forall lore.
Checkable lore =>
Prog (Aliases lore) -> Either (TypeError lore) ()
checkProg Prog (Aliases tolore)
prog'' of
              Left TypeError tolore
err -> Pass fromlore tolore
-> Prog (Aliases tolore) -> String -> FutharkM ()
forall lore fromlore tolore a.
PrettyLore lore =>
Pass fromlore tolore -> Prog lore -> String -> FutharkM a
validationError Pass fromlore tolore
pass Prog (Aliases tolore)
prog'' (String -> FutharkM ()) -> String -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ TypeError tolore -> String
forall a. Show a => a -> String
show TypeError tolore
err
              Right () -> () -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Prog tolore -> FutharkM (Prog tolore)
forall (m :: * -> *) a. Monad m => a -> m a
return Prog tolore
prog'

passes :: Checkable lore =>
          [Pass lore lore] -> Pipeline lore lore
passes :: [Pass lore lore] -> Pipeline lore lore
passes = (Pipeline lore lore -> Pipeline lore lore -> Pipeline lore lore)
-> Pipeline lore lore -> [Pipeline lore lore] -> Pipeline lore lore
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Pipeline lore lore -> Pipeline lore lore -> Pipeline lore lore
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
(>>>) Pipeline lore lore
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
id ([Pipeline lore lore] -> Pipeline lore lore)
-> ([Pass lore lore] -> [Pipeline lore lore])
-> [Pass lore lore]
-> Pipeline lore lore
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Pass lore lore -> Pipeline lore lore)
-> [Pass lore lore] -> [Pipeline lore lore]
forall a b. (a -> b) -> [a] -> [b]
map Pass lore lore -> Pipeline lore lore
forall tolore fromlore.
Checkable tolore =>
Pass fromlore tolore -> Pipeline fromlore tolore
onePass

validationError :: PrettyLore lore =>
                   Pass fromlore tolore -> Prog lore -> String -> FutharkM a
validationError :: Pass fromlore tolore -> Prog lore -> String -> FutharkM a
validationError Pass fromlore tolore
pass Prog lore
prog String
err =
  CompilerError -> FutharkM a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (CompilerError -> FutharkM a) -> CompilerError -> FutharkM a
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ErrorClass -> CompilerError
InternalError Text
msg (Prog lore -> Text
forall a. Pretty a => a -> Text
prettyText Prog lore
prog) ErrorClass
CompilerBug
  where msg :: Text
msg = Text
"Type error after pass '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Pass fromlore tolore -> String
forall fromlore tolore. Pass fromlore tolore -> String
passName Pass fromlore tolore
pass) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"':\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack String
err

runPass :: Pass fromlore tolore
        -> Prog fromlore
        -> FutharkM (Prog tolore)
runPass :: Pass fromlore tolore -> Prog fromlore -> FutharkM (Prog tolore)
runPass Pass fromlore tolore
pass Prog fromlore
prog = do
  (Prog tolore
prog', Log
logged) <- PassM (Prog tolore) -> FutharkM (Prog tolore, Log)
forall (m :: * -> *) a. MonadFreshNames m => PassM a -> m (a, Log)
runPassM (Pass fromlore tolore -> Prog fromlore -> PassM (Prog tolore)
forall fromlore tolore.
Pass fromlore tolore -> Prog fromlore -> PassM (Prog tolore)
passFunction Pass fromlore tolore
pass Prog fromlore
prog)
  Bool
verb <- (FutharkEnv -> Bool) -> FutharkM Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ((FutharkEnv -> Bool) -> FutharkM Bool)
-> (FutharkEnv -> Bool) -> FutharkM Bool
forall a b. (a -> b) -> a -> b
$ (Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
>=Verbosity
VeryVerbose) (Verbosity -> Bool)
-> (FutharkEnv -> Verbosity) -> FutharkEnv -> Bool
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. FutharkEnv -> Verbosity
futharkVerbose
  Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
verb (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ Log -> FutharkM ()
forall (m :: * -> *). MonadLogger m => Log -> m ()
addLog Log
logged
  Prog tolore -> FutharkM (Prog tolore)
forall (m :: * -> *) a. Monad m => a -> m a
return Prog tolore
prog'