{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Strict #-}

-- | High-level API for invoking the Futhark compiler.
module Futhark.Compiler
  ( runPipelineOnProgram,
    runCompilerOnProgram,
    dumpError,
    handleWarnings,
    pprProgramErrors,
    module Futhark.Compiler.Program,
    module Futhark.Compiler.Config,
    readProgramFile,
    readProgramFiles,
    readProgramOrDie,
    readUntypedProgram,
    readUntypedProgramOrDie,
  )
where

import Control.Monad
import Control.Monad.Except
import Data.Bifunctor (first)
import qualified Data.List.NonEmpty as NE
import Data.Loc (Loc (NoLoc))
import qualified Data.Text.IO as T
import qualified Futhark.Analysis.Alias as Alias
import Futhark.Compiler.Config
import Futhark.Compiler.Program
import Futhark.IR
import qualified Futhark.IR.SOACS as I
import qualified Futhark.IR.TypeCheck as I
import Futhark.Internalise
import Futhark.MonadFreshNames
import Futhark.Pipeline
import Futhark.Util.Console (inRed)
import Futhark.Util.Log
import Futhark.Util.Pretty (Doc, line, ppr, prettyText, punctuate, stack, text, (</>))
import qualified Language.Futhark as E
import Language.Futhark.Semantic (includeToString)
import Language.Futhark.Warnings
import System.Exit (ExitCode (..), exitWith)
import System.IO

-- | Print a compiler error to stdout.  The 'FutharkConfig' controls
-- to which degree auxiliary information (e.g. the failing program) is
-- also printed.
dumpError :: FutharkConfig -> CompilerError -> IO ()
dumpError :: FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err =
  case CompilerError
err of
    ExternalError Doc
s -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Doc -> Text
forall a. Pretty a => a -> Text
prettyText Doc
s
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
""
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"If you find this error message confusing, uninformative, or wrong, please open an issue:"
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"  https://github.com/diku-dk/futhark/issues"
    InternalError Text
s Text
info ErrorClass
CompilerBug -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Internal compiler error.  Please report this:"
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"  https://github.com/diku-dk/futhark/issues"
      Text -> Text -> IO ()
report Text
s Text
info
    InternalError Text
s Text
info ErrorClass
CompilerLimitation -> do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Known compiler limitation encountered.  Sorry."
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
"Revise your program or try a different Futhark compiler."
      Text -> Text -> IO ()
report Text
s Text
info
  where
    report :: Text -> Text -> IO ()
report Text
s Text
info = do
      Handle -> Text -> IO ()
T.hPutStrLn Handle
stderr Text
s
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        (Text -> IO ())
-> (FilePath -> Text -> IO ()) -> Maybe FilePath -> Text -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Handle -> Text -> IO ()
T.hPutStr Handle
stderr)
          FilePath -> Text -> IO ()
T.writeFile
          ((Verbosity, Maybe FilePath) -> Maybe FilePath
forall a b. (a, b) -> b
snd (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config))
          (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
info Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n"

-- | Read a program from the given 'FilePath', run the given
-- 'Pipeline', and finish up with the given 'Action'.
runCompilerOnProgram ::
  FutharkConfig ->
  Pipeline I.SOACS rep ->
  Action rep ->
  FilePath ->
  IO ()
runCompilerOnProgram :: FutharkConfig
-> Pipeline SOACS rep -> Action rep -> FilePath -> IO ()
runCompilerOnProgram FutharkConfig
config Pipeline SOACS rep
pipeline Action rep
action FilePath
file = do
  Either CompilerError ()
res <- FutharkM () -> Verbosity -> IO (Either CompilerError ())
forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM ()
compile (Verbosity -> IO (Either CompilerError ()))
-> Verbosity -> IO (Either CompilerError ())
forall a b. (a -> b) -> a -> b
$ (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst ((Verbosity, Maybe FilePath) -> Verbosity)
-> (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config
  case Either CompilerError ()
res of
    Left CompilerError
err -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
      FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err
      ExitCode -> IO ()
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO ()) -> ExitCode -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
    Right () ->
      () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    compile :: FutharkM ()
compile = do
      Prog rep
prog <- FutharkConfig
-> Pipeline SOACS rep -> FilePath -> FutharkM (Prog rep)
forall torep.
FutharkConfig
-> Pipeline SOACS torep -> FilePath -> FutharkM (Prog torep)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS rep
pipeline FilePath
file
      Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) (Verbosity -> Bool)
-> ((Verbosity, Maybe FilePath) -> Verbosity)
-> (Verbosity, Maybe FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst ((Verbosity, Maybe FilePath) -> Bool)
-> (Verbosity, Maybe FilePath) -> Bool
forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath -> FutharkM ()) -> FilePath -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Running action " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Action rep -> FilePath
forall rep. Action rep -> FilePath
actionName Action rep
action
      Action rep -> Prog rep -> FutharkM ()
forall rep. Action rep -> Prog rep -> FutharkM ()
actionProcedure Action rep
action Prog rep
prog
      Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) (Verbosity -> Bool)
-> ((Verbosity, Maybe FilePath) -> Verbosity)
-> (Verbosity, Maybe FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst ((Verbosity, Maybe FilePath) -> Bool)
-> (Verbosity, Maybe FilePath) -> Bool
forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
        FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Done." :: String)

-- | Read a program from the given 'FilePath', run the given
-- 'Pipeline', and return it.
runPipelineOnProgram ::
  FutharkConfig ->
  Pipeline I.SOACS torep ->
  FilePath ->
  FutharkM (Prog torep)
runPipelineOnProgram :: FutharkConfig
-> Pipeline SOACS torep -> FilePath -> FutharkM (Prog torep)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS torep
pipeline FilePath
file = do
  Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Reading and type-checking source program" :: String)
  (Imports
prog_imports, VNameSource
namesrc) <-
    FutharkConfig
-> FutharkM (Warnings, (Imports, VNameSource))
-> FutharkM (Imports, VNameSource)
forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
config (FutharkM (Warnings, (Imports, VNameSource))
 -> FutharkM (Imports, VNameSource))
-> FutharkM (Warnings, (Imports, VNameSource))
-> FutharkM (Imports, VNameSource)
forall a b. (a -> b) -> a -> b
$
      (\(Warnings
a, Imports
b, VNameSource
c) -> (Warnings
a, (Imports
b, VNameSource
c)))
        ((Warnings, Imports, VNameSource)
 -> (Warnings, (Imports, VNameSource)))
-> FutharkM (Warnings, Imports, VNameSource)
-> FutharkM (Warnings, (Imports, VNameSource))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Name] -> FilePath -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile (FutharkConfig -> [Name]
futharkEntryPoints FutharkConfig
config) FilePath
file

  VNameSource -> FutharkM ()
forall (m :: * -> *). MonadFreshNames m => VNameSource -> m ()
putNameSource VNameSource
namesrc
  Prog SOACS
int_prog <- FutharkConfig -> Imports -> FutharkM (Prog SOACS)
forall (m :: * -> *).
(MonadFreshNames m, MonadLogger m) =>
FutharkConfig -> Imports -> m (Prog SOACS)
internaliseProg FutharkConfig
config Imports
prog_imports
  Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> FutharkM ()
forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Type-checking internalised program" :: String)
  Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
int_prog
  Pipeline SOACS torep
-> PipelineConfig -> Prog SOACS -> FutharkM (Prog torep)
forall fromrep torep.
Pipeline fromrep torep
-> PipelineConfig -> Prog fromrep -> FutharkM (Prog torep)
runPipeline Pipeline SOACS torep
pipeline PipelineConfig
pipeline_config Prog SOACS
int_prog
  where
    pipeline_config :: PipelineConfig
pipeline_config =
      PipelineConfig :: Bool -> Bool -> PipelineConfig
PipelineConfig
        { pipelineVerbose :: Bool
pipelineVerbose = (Verbosity, Maybe FilePath) -> Verbosity
forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) Verbosity -> Verbosity -> Bool
forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose,
          pipelineValidate :: Bool
pipelineValidate = FutharkConfig -> Bool
futharkTypeCheck FutharkConfig
config
        }

typeCheckInternalProgram :: I.Prog I.SOACS -> FutharkM ()
typeCheckInternalProgram :: Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
prog =
  case Prog (Aliases SOACS) -> Either (TypeError SOACS) ()
forall rep.
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
I.checkProg Prog (Aliases SOACS)
prog' of
    Left TypeError SOACS
err -> FilePath -> Doc -> FutharkM ()
forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> Doc -> m a
internalErrorS (FilePath
"After internalisation:\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TypeError SOACS -> FilePath
forall a. Show a => a -> FilePath
show TypeError SOACS
err) (Prog (Aliases SOACS) -> Doc
forall a. Pretty a => a -> Doc
ppr Prog (Aliases SOACS)
prog')
    Right () -> () -> FutharkM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    prog' :: Prog (Aliases SOACS)
prog' = Prog SOACS -> Prog (Aliases SOACS)
forall rep.
(ASTRep rep, CanBeAliased (Op rep)) =>
Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog SOACS
prog

-- | Prettyprint program errors as suitable for showing on a text console.
pprProgramErrors :: NE.NonEmpty ProgramError -> Doc
pprProgramErrors :: NonEmpty ProgramError -> Doc
pprProgramErrors = [Doc] -> Doc
stack ([Doc] -> Doc)
-> (NonEmpty ProgramError -> [Doc]) -> NonEmpty ProgramError -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
line ([Doc] -> [Doc])
-> (NonEmpty ProgramError -> [Doc])
-> NonEmpty ProgramError
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgramError -> Doc) -> [ProgramError] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ProgramError -> Doc
onError ([ProgramError] -> [Doc])
-> (NonEmpty ProgramError -> [ProgramError])
-> NonEmpty ProgramError
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgramError -> [ProgramError]
forall a. NonEmpty a -> [a]
NE.toList
  where
    onError :: ProgramError -> Doc
onError (ProgramError Loc
NoLoc Doc
msg) =
      Doc
msg
    onError (ProgramError Loc
loc Doc
msg) =
      FilePath -> Doc
text (FilePath -> FilePath
inRed (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Error at " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> SrcLoc -> FilePath
forall a. Located a => a -> FilePath
locStr (Loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Loc
loc) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
":") Doc -> Doc -> Doc
</> Doc
msg

-- | Throw an exception formatted with 'pprProgramErrors' if there's
-- an error.
throwOnProgramError ::
  MonadError CompilerError m =>
  Either (NE.NonEmpty ProgramError) a ->
  m a
throwOnProgramError :: Either (NonEmpty ProgramError) a -> m a
throwOnProgramError =
  (NonEmpty ProgramError -> m a)
-> (a -> m a) -> Either (NonEmpty ProgramError) a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Doc -> m a
forall (m :: * -> *) a. MonadError CompilerError m => Doc -> m a
externalError (Doc -> m a)
-> (NonEmpty ProgramError -> Doc) -> NonEmpty ProgramError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgramError -> Doc
pprProgramErrors) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Read and type-check a Futhark program, comprising a single file,
-- including all imports.
readProgramFile ::
  (MonadError CompilerError m, MonadIO m) =>
  [I.Name] ->
  FilePath ->
  m (Warnings, Imports, VNameSource)
readProgramFile :: [Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile [Name]
extra_eps =
  [Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [Name]
extra_eps ([FilePath] -> m (Warnings, Imports, VNameSource))
-> (FilePath -> [FilePath])
-> FilePath
-> m (Warnings, Imports, VNameSource)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | Read and type-check a Futhark library, comprising multiple files,
-- including all imports.
readProgramFiles ::
  (MonadError CompilerError m, MonadIO m) =>
  [I.Name] ->
  [FilePath] ->
  m (Warnings, Imports, VNameSource)
readProgramFiles :: [Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [Name]
extra_eps =
  Either (NonEmpty ProgramError) (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource)
forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgramError) a -> m a
throwOnProgramError (Either (NonEmpty ProgramError) (Warnings, Imports, VNameSource)
 -> m (Warnings, Imports, VNameSource))
-> ([FilePath]
    -> m (Either
            (NonEmpty ProgramError) (Warnings, Imports, VNameSource)))
-> [FilePath]
-> m (Warnings, Imports, VNameSource)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO
  (Either (NonEmpty ProgramError) (Warnings, Imports, VNameSource))
-> m (Either
        (NonEmpty ProgramError) (Warnings, Imports, VNameSource))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either (NonEmpty ProgramError) (Warnings, Imports, VNameSource))
 -> m (Either
         (NonEmpty ProgramError) (Warnings, Imports, VNameSource)))
-> ([FilePath]
    -> IO
         (Either (NonEmpty ProgramError) (Warnings, Imports, VNameSource)))
-> [FilePath]
-> m (Either
        (NonEmpty ProgramError) (Warnings, Imports, VNameSource))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name]
-> [FilePath]
-> IO
     (Either (NonEmpty ProgramError) (Warnings, Imports, VNameSource))
readLibrary [Name]
extra_eps

-- | Read and parse (but do not type-check) a Futhark program,
-- including all imports.
readUntypedProgram ::
  (MonadError CompilerError m, MonadIO m) =>
  FilePath ->
  m [(String, E.UncheckedProg)]
readUntypedProgram :: FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgram =
  ([(ImportName, UncheckedProg)] -> [(FilePath, UncheckedProg)])
-> m [(ImportName, UncheckedProg)] -> m [(FilePath, UncheckedProg)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((ImportName, UncheckedProg) -> (FilePath, UncheckedProg))
-> [(ImportName, UncheckedProg)] -> [(FilePath, UncheckedProg)]
forall a b. (a -> b) -> [a] -> [b]
map ((ImportName -> FilePath)
-> (ImportName, UncheckedProg) -> (FilePath, UncheckedProg)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ImportName -> FilePath
includeToString)) (m [(ImportName, UncheckedProg)] -> m [(FilePath, UncheckedProg)])
-> (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)]
    -> m [(ImportName, UncheckedProg)])
-> Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)]
-> m [(FilePath, UncheckedProg)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)]
-> m [(ImportName, UncheckedProg)]
forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgramError) a -> m a
throwOnProgramError
    (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)]
 -> m [(FilePath, UncheckedProg)])
-> (FilePath
    -> m (Either
            (NonEmpty ProgramError) [(ImportName, UncheckedProg)]))
-> FilePath
-> m [(FilePath, UncheckedProg)]
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< IO (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)])
-> m (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)])
 -> m (Either
         (NonEmpty ProgramError) [(ImportName, UncheckedProg)]))
-> (FilePath
    -> IO
         (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)]))
-> FilePath
-> m (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> IO
     (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)])
readUntypedLibrary ([FilePath]
 -> IO
      (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)]))
-> (FilePath -> [FilePath])
-> FilePath
-> IO
     (Either (NonEmpty ProgramError) [(ImportName, UncheckedProg)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

orDie :: MonadIO m => FutharkM a -> m a
orDie :: FutharkM a -> m a
orDie FutharkM a
m = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ do
  Either CompilerError a
res <- FutharkM a -> Verbosity -> IO (Either CompilerError a)
forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM a
m Verbosity
NotVerbose
  case Either CompilerError a
res of
    Left CompilerError
err -> do
      FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
newFutharkConfig CompilerError
err
      ExitCode -> IO a
forall a. ExitCode -> IO a
exitWith (ExitCode -> IO a) -> ExitCode -> IO a
forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
    Right a
res' -> a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
res'

-- | Not verbose, and terminates process on error.
readProgramOrDie :: MonadIO m => FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie :: FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie FilePath
file = FutharkM (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource)
forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie (FutharkM (Warnings, Imports, VNameSource)
 -> m (Warnings, Imports, VNameSource))
-> FutharkM (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource)
forall a b. (a -> b) -> a -> b
$ [Name] -> FilePath -> FutharkM (Warnings, Imports, VNameSource)
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile [Name]
forall a. Monoid a => a
mempty FilePath
file

-- | Not verbose, and terminates process on error.
readUntypedProgramOrDie :: MonadIO m => FilePath -> m [(String, E.UncheckedProg)]
readUntypedProgramOrDie :: FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgramOrDie FilePath
file = FutharkM [(FilePath, UncheckedProg)]
-> m [(FilePath, UncheckedProg)]
forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie (FutharkM [(FilePath, UncheckedProg)]
 -> m [(FilePath, UncheckedProg)])
-> FutharkM [(FilePath, UncheckedProg)]
-> m [(FilePath, UncheckedProg)]
forall a b. (a -> b) -> a -> b
$ FilePath -> FutharkM [(FilePath, UncheckedProg)]
forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgram FilePath
file

-- | Run an operation that produces warnings, and handle them
-- appropriately, yielding the non-warning return value.  "Proper
-- handling" means e.g. to print them to the screen, as directed by
-- the compiler configuration.
handleWarnings :: FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings :: FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
config FutharkM (Warnings, a)
m = do
  (Warnings
ws, a
a) <- FutharkM (Warnings, a)
m

  Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWarn FutharkConfig
config Bool -> Bool -> Bool
&& Warnings -> Bool
anyWarnings Warnings
ws) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> FutharkM ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Warnings -> FilePath
forall a. Pretty a => a -> FilePath
pretty Warnings
ws
    Bool -> FutharkM () -> FutharkM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWerror FutharkConfig
config) (FutharkM () -> FutharkM ()) -> FutharkM () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$
      FilePath -> FutharkM ()
forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> m a
externalErrorS FilePath
"Treating above warnings as errors due to --Werror."

  a -> FutharkM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a