{-# LANGUAGE Strict #-}

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

import Control.Monad
import Control.Monad.Except (MonadError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.List.NonEmpty qualified as NE
import Data.Loc (Loc (..), posCoff, posFile)
import Data.Text.IO qualified as T
import Futhark.Analysis.Alias qualified as Alias
import Futhark.Compiler.Config
import Futhark.Compiler.Program
import Futhark.IR
import Futhark.IR.SOACS qualified as I
import Futhark.IR.TypeCheck qualified as I
import Futhark.Internalise
import Futhark.MonadFreshNames
import Futhark.Pipeline
import Futhark.Util.Log
import Futhark.Util.Pretty
import Language.Futhark qualified 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 AnsiStyle
s -> do
      Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr Doc AnsiStyle
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 :: forall rep.
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 a. IO a -> IO a
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  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 a. ToLog a => a -> 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 a. ToLog a => a -> 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 :: forall torep.
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 a. ToLog a => a -> 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 a. ToLog a => a -> 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
        { 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 AnsiStyle -> FutharkM ()
forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> Doc AnsiStyle -> 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 AnsiStyle
forall a ann. Pretty a => a -> Doc ann
forall ann. Prog (Aliases SOACS) -> Doc ann
pretty Prog (Aliases SOACS)
prog')
    Right () -> () -> FutharkM ()
forall a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    prog' :: Prog (Aliases SOACS)
prog' = Prog SOACS -> Prog (Aliases SOACS)
forall rep. AliasableRep rep => Prog rep -> Prog (Aliases rep)
Alias.aliasAnalysis Prog SOACS
prog

-- | Prettyprint program errors as suitable for showing on a text console.
prettyProgErrors :: NE.NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors :: NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors = [Doc AnsiStyle] -> Doc AnsiStyle
forall a. [Doc a] -> Doc a
stack ([Doc AnsiStyle] -> Doc AnsiStyle)
-> (NonEmpty ProgError -> [Doc AnsiStyle])
-> NonEmpty ProgError
-> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc AnsiStyle -> [Doc AnsiStyle] -> [Doc AnsiStyle]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc AnsiStyle
forall ann. Doc ann
line ([Doc AnsiStyle] -> [Doc AnsiStyle])
-> (NonEmpty ProgError -> [Doc AnsiStyle])
-> NonEmpty ProgError
-> [Doc AnsiStyle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgError -> Doc AnsiStyle) -> [ProgError] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map ProgError -> Doc AnsiStyle
onError ([ProgError] -> [Doc AnsiStyle])
-> (NonEmpty ProgError -> [ProgError])
-> NonEmpty ProgError
-> [Doc AnsiStyle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProgError -> (FilePath, Int)) -> [ProgError] -> [ProgError]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Loc -> (FilePath, Int)
rep (Loc -> (FilePath, Int))
-> (ProgError -> Loc) -> ProgError -> (FilePath, Int)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProgError -> Loc
forall a. Located a => a -> Loc
locOf) ([ProgError] -> [ProgError])
-> (NonEmpty ProgError -> [ProgError])
-> NonEmpty ProgError
-> [ProgError]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgError -> [ProgError]
forall a. NonEmpty a -> [a]
NE.toList
  where
    rep :: Loc -> (FilePath, Int)
rep Loc
NoLoc = (FilePath
"", Int
0)
    rep (Loc Pos
p Pos
_) = (Pos -> FilePath
posFile Pos
p, Pos -> Int
posCoff Pos
p)
    onError :: ProgError -> Doc AnsiStyle
onError (ProgError Loc
NoLoc Doc ()
msg) =
      Doc () -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
    onError (ProgError Loc
loc Doc ()
msg) =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (Doc AnsiStyle
"Error at " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SrcLoc -> Text
forall a. Located a => a -> Text
locText (Loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Loc
loc))) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Doc a -> Doc a -> Doc a
</> Doc () -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
    onError (ProgWarning Loc
NoLoc Doc ()
msg) =
      Doc () -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
    onError (ProgWarning Loc
loc Doc ()
msg) =
      AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Warning at " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Text -> Doc AnsiStyle
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty (SrcLoc -> Text
forall a. Located a => a -> Text
locText (Loc -> SrcLoc
forall a. Located a => a -> SrcLoc
srclocOf Loc
loc)) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Doc a -> Doc a -> Doc a
</> Doc () -> Doc AnsiStyle
forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg

-- | Throw an exception formatted with 'pprProgErrors' if there's
-- an error.
throwOnProgError ::
  (MonadError CompilerError m) =>
  Either (NE.NonEmpty ProgError) a ->
  m a
throwOnProgError :: forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError =
  (NonEmpty ProgError -> m a)
-> (a -> m a) -> Either (NonEmpty ProgError) a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Doc AnsiStyle -> m a
forall (m :: * -> *) a.
MonadError CompilerError m =>
Doc AnsiStyle -> m a
externalError (Doc AnsiStyle -> m a)
-> (NonEmpty ProgError -> Doc AnsiStyle)
-> NonEmpty ProgError
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors) a -> m a
forall a. 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 :: forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[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 a. a -> [a]
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 :: forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [Name]
extra_eps =
  Either (NonEmpty ProgError) (Warnings, Imports, VNameSource)
-> m (Warnings, Imports, VNameSource)
forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError (Either (NonEmpty ProgError) (Warnings, Imports, VNameSource)
 -> m (Warnings, Imports, VNameSource))
-> ([FilePath]
    -> m (Either
            (NonEmpty ProgError) (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 ProgError) (Warnings, Imports, VNameSource))
-> m (Either (NonEmpty ProgError) (Warnings, Imports, VNameSource))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (NonEmpty ProgError) (Warnings, Imports, VNameSource))
 -> m (Either
         (NonEmpty ProgError) (Warnings, Imports, VNameSource)))
-> ([FilePath]
    -> IO
         (Either (NonEmpty ProgError) (Warnings, Imports, VNameSource)))
-> [FilePath]
-> m (Either (NonEmpty ProgError) (Warnings, Imports, VNameSource))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name]
-> [FilePath]
-> IO
     (Either (NonEmpty ProgError) (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 :: forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
FilePath -> m [(FilePath, UncheckedProg)]
readUntypedProgram =
  ([(ImportName, UncheckedProg)] -> [(FilePath, UncheckedProg)])
-> m [(ImportName, UncheckedProg)] -> m [(FilePath, UncheckedProg)]
forall a b. (a -> b) -> m a -> m b
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 a b c. (a -> b) -> (a, c) -> (b, c)
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 ProgError) [(ImportName, UncheckedProg)]
    -> m [(ImportName, UncheckedProg)])
-> Either (NonEmpty ProgError) [(ImportName, UncheckedProg)]
-> m [(FilePath, UncheckedProg)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (NonEmpty ProgError) [(ImportName, UncheckedProg)]
-> m [(ImportName, UncheckedProg)]
forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError
    (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)]
 -> m [(FilePath, UncheckedProg)])
-> (FilePath
    -> m (Either (NonEmpty ProgError) [(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 ProgError) [(ImportName, UncheckedProg)])
-> m (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
 -> m (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)]))
-> (FilePath
    -> IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)]))
-> FilePath
-> m (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
readUntypedLibrary ([FilePath]
 -> IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)]))
-> (FilePath -> [FilePath])
-> FilePath
-> IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure

orDie :: (MonadIO m) => FutharkM a -> m a
orDie :: forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie FutharkM a
m = IO a -> m a
forall a. 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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
res'

-- | Not verbose, and terminates process on error.
readProgramOrDie :: (MonadIO m) => FilePath -> m (Warnings, Imports, VNameSource)
readProgramOrDie :: forall (m :: * -> *).
MonadIO m =>
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 :: forall (m :: * -> *).
MonadIO m =>
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 :: forall a. 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 a. IO a -> FutharkM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> FutharkM ()) -> IO () -> FutharkM ()
forall a b. (a -> b) -> a -> b
$ Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Warnings -> Doc AnsiStyle
prettyWarnings 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 a. a -> FutharkM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a