{-# 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
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 {k} (rep :: k).
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 {k} (torep :: k).
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 {k} (rep :: k). Action rep -> FilePath
actionName Action rep
action
      forall {k} (rep :: k). 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 {k} (torep :: k).
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 {k1} {k2} (fromrep :: k1) (torep :: k2).
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 {k} (rep :: k).
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 {k} (rep :: k).
(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.
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