{-# LANGUAGE CPP #-}
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 HIE.Bios.Environment
import HIE.Bios.Ghc.Api
import HIE.Bios.Ghc.Logger
import qualified HIE.Bios.Internal.Log as Log
import HIE.Bios.Types
import HIE.Bios.Ghc.Load
import Control.Monad.IO.Class

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


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

-- | Checking syntax of a target file using GHC.
--   Warnings and errors are returned.
checkSyntax :: Show a
            => Cradle a
            -> [FilePath]  -- ^ The target files.
            -> IO String
checkSyntax :: Cradle a -> [FilePath] -> IO FilePath
checkSyntax Cradle a
_      []    = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
""
checkSyntax 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 :: * -> *) t.
MonadIO m =>
CradleLoadResult t -> (t -> m FilePath) -> m FilePath
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
        FilePath -> GhcT IO ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
Log.debugm (FilePath -> GhcT IO ()) -> FilePath -> GhcT IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Cradle: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Cradle a -> FilePath
forall a. Show a => a -> FilePath
show Cradle a
cradle
        CradleLoadResult (GhcT IO SuccessFlag, ComponentOptions)
res <- FilePath
-> Cradle a
-> GhcT
     IO (CradleLoadResult (GhcT IO SuccessFlag, ComponentOptions))
forall (m :: * -> *) a.
GhcMonad m =>
FilePath
-> Cradle a
-> m (CradleLoadResult (m SuccessFlag, ComponentOptions))
initializeFlagsWithCradle ([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 :: * -> *) t.
MonadIO m =>
CradleLoadResult t -> (t -> m FilePath) -> m FilePath
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
<$> [FilePath] -> GhcT IO (Either FilePath FilePath)
forall (m :: * -> *).
GhcMonad m =>
[FilePath] -> m (Either FilePath FilePath)
check [FilePath]
files
  where
    handleRes :: CradleLoadResult t -> (t -> m FilePath) -> m FilePath
handleRes (CradleSuccess t
x) t -> m FilePath
f = t -> m FilePath
f t
x
    handleRes (CradleFail CradleError
ce) t -> m FilePath
_f = IO FilePath -> m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> m FilePath) -> IO FilePath -> m FilePath
forall a b. (a -> b) -> a -> b
$ CradleError -> IO FilePath
forall e a. Exception e => e -> IO a
throwIO CradleError
ce
    handleRes CradleLoadResult t
CradleNone t -> m FilePath
_f = FilePath -> m FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"None cradle"

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

-- | Checking syntax of a target file using GHC.
--   Warnings and errors are returned.
check :: (GhcMonad m)
      => [FilePath]  -- ^ The target files.
      -> m (Either String String)
check :: [FilePath] -> m (Either FilePath FilePath)
check [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
$ [(FilePath, FilePath)] -> m ()
forall (m :: * -> *). GhcMonad m => [(FilePath, FilePath)] -> m ()
setTargetFiles ((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'