module HIE.Bios.Ghc.Check (
    checkSyntax
  , check
  ) where

import GHC (DynFlags(..), GhcMonad)
import 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

import qualified DynFlags as G
import qualified GHC as G

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

-- | 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
"No 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'