{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExistentialQuantification #-}
module HIE.Bios.Ghc.Check (
    checkSyntax
  , check
  ) where

import GHC (DynFlags(..), GhcMonad)
import qualified GHC as G

#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Driver.Session as G
#else
import qualified DynFlags as G
#endif

import Control.Exception
import Control.Monad.IO.Class
import Colog.Core (LogAction (..), WithSeverity (..), Severity (..), (<&), cmap)
import Data.Text.Prettyprint.Doc

import HIE.Bios.Ghc.Api
import HIE.Bios.Ghc.Logger
import HIE.Bios.Types hiding (Log (..))
import qualified HIE.Bios.Types as T
import qualified HIE.Bios.Ghc.Load as Load
import HIE.Bios.Environment

import System.IO.Unsafe (unsafePerformIO)
import qualified HIE.Bios.Ghc.Gap as Gap

data Log =
  LoadLog Load.Log
  | LogAny T.Log
  | forall a . Show a => LogCradle (Cradle a)

instance Pretty Log where
  pretty :: Log -> Doc ann
pretty (LoadLog Log
l) = Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Log
l
  pretty (LogAny Log
l) = Log -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Log
l
  pretty (LogCradle Cradle a
c) = Doc ann
"Cradle:" Doc ann -> Doc ann -> Doc ann
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Cradle a -> Doc ann
forall a ann. Show a => a -> Doc ann
viaShow Cradle a
c

----------------------------------------------------------------

-- | Checking syntax of a target file using GHC.
--   Warnings and errors are returned.
checkSyntax :: Show a
            => LogAction IO (WithSeverity Log)
            -> Cradle a
            -> [FilePath]  -- ^ The target files.
            -> IO String
checkSyntax :: LogAction IO (WithSeverity Log)
-> Cradle a -> [FilePath] -> IO FilePath
checkSyntax LogAction IO (WithSeverity Log)
_       Cradle a
_     []    = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
""
checkSyntax LogAction IO (WithSeverity Log)
logger Cradle a
cradle [FilePath]
files = do
    CradleLoadResult FilePath
libDirRes <- Cradle a -> IO (CradleLoadResult FilePath)
forall a. Cradle a -> IO (CradleLoadResult FilePath)
getRuntimeGhcLibDir Cradle a
cradle
    CradleLoadResult FilePath
-> (FilePath -> IO FilePath) -> IO FilePath
forall (m :: * -> *) a t.
(MonadIO m, IsString a) =>
CradleLoadResult t -> (t -> m a) -> m a
handleRes CradleLoadResult FilePath
libDirRes ((FilePath -> IO FilePath) -> IO FilePath)
-> (FilePath -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \FilePath
libDir ->
      Maybe FilePath -> GhcT IO FilePath -> IO FilePath
forall (m :: * -> *) a.
ExceptionMonad m =>
Maybe FilePath -> GhcT m a -> m a
G.runGhcT (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libDir) (GhcT IO FilePath -> IO FilePath)
-> GhcT IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ do
        IO () -> GhcT IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> GhcT IO ()) -> IO () -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log)
logger LogAction IO (WithSeverity Log) -> WithSeverity Log -> IO ()
forall (m :: * -> *) msg. LogAction m msg -> msg -> m ()
<& Cradle a -> Log
forall a. Show a => Cradle a -> Log
LogCradle Cradle a
cradle Log -> Severity -> WithSeverity Log
forall msg. msg -> Severity -> WithSeverity msg
`WithSeverity` Severity
Info
        CradleLoadResult (GhcT IO SuccessFlag, ComponentOptions)
res <- LogAction IO (WithSeverity Log)
-> FilePath
-> Cradle a
-> GhcT
     IO (CradleLoadResult (GhcT IO SuccessFlag, ComponentOptions))
forall (m :: * -> *) a.
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> FilePath
-> Cradle a
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
initializeFlagsWithCradle ((WithSeverity Log -> WithSeverity Log)
-> LogAction IO (WithSeverity Log)
-> LogAction IO (WithSeverity Log)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap ((Log -> Log) -> WithSeverity Log -> WithSeverity Log
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Log -> Log
LogAny) LogAction IO (WithSeverity Log)
logger) ([FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
files) Cradle a
cradle
        CradleLoadResult (GhcT IO SuccessFlag, ComponentOptions)
-> ((GhcT IO SuccessFlag, ComponentOptions) -> GhcT IO FilePath)
-> GhcT IO FilePath
forall (m :: * -> *) a t.
(MonadIO m, IsString a) =>
CradleLoadResult t -> (t -> m a) -> m a
handleRes CradleLoadResult (GhcT IO SuccessFlag, ComponentOptions)
res (((GhcT IO SuccessFlag, ComponentOptions) -> GhcT IO FilePath)
 -> GhcT IO FilePath)
-> ((GhcT IO SuccessFlag, ComponentOptions) -> GhcT IO FilePath)
-> GhcT IO FilePath
forall a b. (a -> b) -> a -> b
$ \(GhcT IO SuccessFlag
ini, ComponentOptions
_) -> do
          SuccessFlag
_sf <- GhcT IO SuccessFlag
ini
          (FilePath -> FilePath)
-> (FilePath -> FilePath) -> Either FilePath FilePath -> FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either FilePath -> FilePath
forall a. a -> a
id FilePath -> FilePath
forall a. a -> a
id (Either FilePath FilePath -> FilePath)
-> GhcT IO (Either FilePath FilePath) -> GhcT IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LogAction IO (WithSeverity Log)
-> [FilePath] -> GhcT IO (Either FilePath FilePath)
forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log)
-> [FilePath] -> m (Either FilePath FilePath)
check LogAction IO (WithSeverity Log)
logger [FilePath]
files
  where
    handleRes :: CradleLoadResult t -> (t -> m a) -> m a
handleRes (CradleSuccess t
x) t -> m a
f = t -> m a
f t
x
    handleRes (CradleFail CradleError
ce) t -> m a
_f = 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
$ CradleError -> IO a
forall e a. Exception e => e -> IO a
throwIO CradleError
ce
    handleRes CradleLoadResult t
CradleNone t -> m a
_f = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
"None cradle"

----------------------------------------------------------------

-- | Checking syntax of a target file using GHC.
--   Warnings and errors are returned.
check :: (GhcMonad m)
      => LogAction IO (WithSeverity Log)
      -> [FilePath]  -- ^ The target files.
      -> m (Either String String)
check :: LogAction IO (WithSeverity Log)
-> [FilePath] -> m (Either FilePath FilePath)
check LogAction IO (WithSeverity Log)
logger [FilePath]
fileNames = do
  FilePath
libDir <- DynFlags -> FilePath
G.topDir (DynFlags -> FilePath) -> m DynFlags -> m FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
G.getDynFlags
  (DynFlags -> DynFlags) -> m () -> m (Either FilePath FilePath)
forall (m :: * -> *).
GhcMonad m =>
(DynFlags -> DynFlags) -> m () -> m (Either FilePath FilePath)
withLogger (FilePath -> DynFlags -> DynFlags
setAllWarningFlags FilePath
libDir) (m () -> m (Either FilePath FilePath))
-> m () -> m (Either FilePath FilePath)
forall a b. (a -> b) -> a -> b
$ LogAction IO (WithSeverity Log) -> [(FilePath, FilePath)] -> m ()
forall (m :: * -> *).
GhcMonad m =>
LogAction IO (WithSeverity Log) -> [(FilePath, FilePath)] -> m ()
Load.setTargetFiles ((WithSeverity Log -> WithSeverity Log)
-> LogAction IO (WithSeverity Log)
-> LogAction IO (WithSeverity Log)
forall a b (m :: * -> *).
(a -> b) -> LogAction m b -> LogAction m a
cmap ((Log -> Log) -> WithSeverity Log -> WithSeverity Log
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Log -> Log
LoadLog) LogAction IO (WithSeverity Log)
logger) ((FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> (FilePath, FilePath)
forall a. a -> (a, a)
dup [FilePath]
fileNames)

dup :: a -> (a, a)
dup :: a -> (a, a)
dup a
x = (a
x, a
x)

----------------------------------------------------------------

-- | Set 'DynFlags' equivalent to "-Wall".
setAllWarningFlags :: FilePath -> DynFlags -> DynFlags
setAllWarningFlags :: FilePath -> DynFlags -> DynFlags
setAllWarningFlags FilePath
libDir DynFlags
df = DynFlags
df { warningFlags :: EnumSet WarningFlag
warningFlags = FilePath -> EnumSet WarningFlag
allWarningFlags FilePath
libDir }

{-# NOINLINE allWarningFlags #-}
allWarningFlags :: FilePath -> Gap.WarnFlags
allWarningFlags :: FilePath -> EnumSet WarningFlag
allWarningFlags FilePath
libDir = IO (EnumSet WarningFlag) -> EnumSet WarningFlag
forall a. IO a -> a
unsafePerformIO (IO (EnumSet WarningFlag) -> EnumSet WarningFlag)
-> IO (EnumSet WarningFlag) -> EnumSet WarningFlag
forall a b. (a -> b) -> a -> b
$
    Maybe FilePath
-> GhcT IO (EnumSet WarningFlag) -> IO (EnumSet WarningFlag)
forall (m :: * -> *) a.
ExceptionMonad m =>
Maybe FilePath -> GhcT m a -> m a
G.runGhcT (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libDir) (GhcT IO (EnumSet WarningFlag) -> IO (EnumSet WarningFlag))
-> GhcT IO (EnumSet WarningFlag) -> IO (EnumSet WarningFlag)
forall a b. (a -> b) -> a -> b
$ do
        DynFlags
df <- GhcT IO DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
G.getSessionDynFlags
        (DynFlags
df', [Target]
_) <- [FilePath] -> DynFlags -> GhcT IO (DynFlags, [Target])
forall (m :: * -> *).
GhcMonad m =>
[FilePath] -> DynFlags -> m (DynFlags, [Target])
addCmdOpts [FilePath
"-Wall"] DynFlags
df
        EnumSet WarningFlag -> GhcT IO (EnumSet WarningFlag)
forall (m :: * -> *) a. Monad m => a -> m a
return (EnumSet WarningFlag -> GhcT IO (EnumSet WarningFlag))
-> EnumSet WarningFlag -> GhcT IO (EnumSet WarningFlag)
forall a b. (a -> b) -> a -> b
$ DynFlags -> EnumSet WarningFlag
G.warningFlags DynFlags
df'