{-# 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
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose)
        forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          (Handle -> Text -> IO ()
T.hPutStr Handle
stderr)
          FilePath -> Text -> IO ()
T.writeFile
          (forall a b. (a, b) -> b
snd (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config))
        forall a b. (a -> b) -> a -> b
$ Text
info 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 <- forall a. FutharkM a -> Verbosity -> IO (Either CompilerError a)
runFutharkM FutharkM ()
compile forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config
  case Either CompilerError ()
res of
    Left CompilerError
err -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
      FutharkConfig -> CompilerError -> IO ()
dumpError FutharkConfig
config CompilerError
err
      forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
    Right () ->
      forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    compile :: FutharkM ()
compile = do
      Prog rep
prog <- forall torep.
FutharkConfig
-> Pipeline SOACS torep -> FilePath -> FutharkM (Prog torep)
runPipelineOnProgram FutharkConfig
config Pipeline SOACS rep
pipeline FilePath
file
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg forall a b. (a -> b) -> a -> b
$
          FilePath
"Running action " forall a. [a] -> [a] -> [a]
++ forall rep. Action rep -> FilePath
actionName Action rep
action
      forall rep. Action rep -> Prog rep -> FutharkM ()
actionProcedure Action rep
action Prog rep
prog
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((forall a. Ord a => a -> a -> Bool
> Verbosity
NotVerbose) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) forall a b. (a -> b) -> a -> b
$
        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
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Reading and type-checking source program" :: String)
  (Imports
prog_imports, VNameSource
namesrc) <-
    forall a. FutharkConfig -> FutharkM (Warnings, a) -> FutharkM a
handleWarnings FutharkConfig
config forall a b. (a -> b) -> a -> b
$
      (\(Warnings
a, Imports
b, VNameSource
c) -> (Warnings
a, (Imports
b, VNameSource
c)))
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile (FutharkConfig -> [Name]
futharkEntryPoints FutharkConfig
config) FilePath
file

  forall (m :: * -> *). MonadFreshNames m => VNameSource -> m ()
putNameSource VNameSource
namesrc
  Prog SOACS
int_prog <- forall (m :: * -> *).
(MonadFreshNames m, MonadLogger m) =>
FutharkConfig -> Imports -> m (Prog SOACS)
internaliseProg FutharkConfig
config Imports
prog_imports
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (PipelineConfig -> Bool
pipelineVerbose PipelineConfig
pipeline_config) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. (MonadLogger m, ToLog a) => a -> m ()
logMsg (FilePath
"Type-checking internalised program" :: String)
  Prog SOACS -> FutharkM ()
typeCheckInternalProgram Prog SOACS
int_prog
  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 = forall a b. (a, b) -> a
fst (FutharkConfig -> (Verbosity, Maybe FilePath)
futharkVerbose FutharkConfig
config) 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 forall rep.
Checkable rep =>
Prog (Aliases rep) -> Either (TypeError rep) ()
I.checkProg Prog (Aliases SOACS)
prog' of
    Left TypeError SOACS
err -> forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> Doc AnsiStyle -> m a
internalErrorS (FilePath
"After internalisation:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show TypeError SOACS
err) (forall a ann. Pretty a => a -> Doc ann
pretty Prog (Aliases SOACS)
prog')
    Right () -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    prog' :: Prog (Aliases SOACS)
prog' = 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 = forall a. [Doc a] -> Doc a
stack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate forall ann. Doc ann
line forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ProgError -> Doc AnsiStyle
onError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Loc -> (FilePath, Int)
rep forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Located a => a -> Loc
locOf) forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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) =
      forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
    onError (ProgError Loc
loc Doc ()
msg) =
      forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red) (Doc AnsiStyle
"Error at " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> Text
locText (forall a. Located a => a -> SrcLoc
srclocOf Loc
loc))) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall a. Doc a -> Doc a -> Doc a
</> forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
    onError (ProgWarning Loc
NoLoc Doc ()
msg) =
      forall ann xxx. Doc ann -> Doc xxx
unAnnotate Doc ()
msg
    onError (ProgWarning Loc
loc Doc ()
msg) =
      forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) forall a b. (a -> b) -> a -> b
$ Doc AnsiStyle
"Warning at " forall a. Semigroup a => a -> a -> a
<> forall a ann. Pretty a => a -> Doc ann
pretty (forall a. Located a => a -> Text
locText (forall a. Located a => a -> SrcLoc
srclocOf Loc
loc)) forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
":" forall a. Doc a -> Doc a -> Doc a
</> 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 =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a.
MonadError CompilerError m =>
Doc AnsiStyle -> m a
externalError forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ProgError -> Doc AnsiStyle
prettyProgErrors) 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 =
  forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> [FilePath] -> m (Warnings, Imports, VNameSource)
readProgramFiles [Name]
extra_eps forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 =
  forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 =
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ImportName -> FilePath
includeToString)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadError CompilerError m =>
Either (NonEmpty ProgError) a -> m a
throwOnProgError
    forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FilePath]
-> IO (Either (NonEmpty ProgError) [(ImportName, UncheckedProg)])
readUntypedLibrary forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Either CompilerError a
res <- 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
      forall a. ExitCode -> IO a
exitWith forall a b. (a -> b) -> a -> b
$ Int -> ExitCode
ExitFailure Int
2
    Right a
res' -> 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 = forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError CompilerError m, MonadIO m) =>
[Name] -> FilePath -> m (Warnings, Imports, VNameSource)
readProgramFile 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 = forall (m :: * -> *) a. MonadIO m => FutharkM a -> m a
orDie forall a b. (a -> b) -> a -> b
$ 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

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWarn FutharkConfig
config Bool -> Bool -> Bool
&& Warnings -> Bool
anyWarnings Warnings
ws) 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
$ Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr forall a b. (a -> b) -> a -> b
$ Warnings -> Doc AnsiStyle
prettyWarnings Warnings
ws
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (FutharkConfig -> Bool
futharkWerror FutharkConfig
config) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
MonadError CompilerError m =>
FilePath -> m a
externalErrorS FilePath
"Treating above warnings as errors due to --Werror."

  forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a