{-# LANGUAGE CPP                 #-}
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE RankNTypes          #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module Plugin.GhcTags ( plugin, Options (..) ) where

import           Control.Exception
import           Control.Monad (when)
#if __GLASGOW_HASKELL__ >= 906
import           Control.Monad.State.Strict
#else
import           Control.Monad.State.Strict hiding (when, void)
#endif
import           Data.ByteString (ByteString)
import qualified Data.ByteString         as BS
import qualified Data.ByteString.Char8   as BSC
import qualified Data.ByteString.Lazy    as BSL
import qualified Data.ByteString.Builder as BB
import           Data.Functor (void)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import           Data.Functor.Identity (Identity (..))
import           Data.List (sortBy)
import           Data.Either (partitionEithers, rights)
import           Data.Foldable (traverse_)
import           Data.Maybe (mapMaybe)
#if MIN_VERSION_filepath(1,4,100)
import qualified System.OsPath as OsPath
import           System.Directory.OsPath
#else
import           System.Directory
#endif
import qualified System.FilePath as FilePath
import           System.IO

import           Options.Applicative.Types (ParserFailure (..))

import qualified Pipes
import           Pipes.Safe (SafeT)
import qualified Pipes.Safe
import qualified Pipes.ByteString as Pipes.BS

import           GHC.Driver.Plugins
                            ( CommandLineOption
                            , Plugin (..)
                            )
import qualified GHC.Driver.Plugins as GhcPlugins
import           GHC.Driver.Env   ( Hsc
                                  , HscEnv (..)
                                  )
import           GHC.Hs           (HsParsedModule (..))
import           GHC.Unit.Module.ModSummary
                                  (ModSummary (..))
import           GHC.Types.Meta   ( MetaHook
                                  , MetaRequest (..)
                                  , MetaResult
                                  , metaRequestAW
                                  , metaRequestD
                                  , metaRequestE
                                  , metaRequestP
                                  , metaRequestT
                                  )
import           GHC.Driver.Hooks (Hooks (..))
import           GHC.Unit.Types   (Module)
import           GHC.Unit.Module.Location   (ModLocation (..))
import           GHC.Tc.Types (TcM)
import           GHC.Tc.Gen.Splice (defaultRunMeta)
import           GHC.Types.SrcLoc (Located)
import qualified GHC.Types.SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile)
import           GHC.Driver.Session (DynFlags)

import           GHC.Hs (GhcPs, GhcTc, HsModule (..), LHsDecl, LHsExpr)
import           GHC.Utils.Outputable (($+$), ($$))
import qualified GHC.Utils.Outputable as Out
import qualified GHC.Utils.Ppr.Colour as PprColour
import           GHC.Data.FastString (bytesFS)

import           GhcTags.Ghc
import           GhcTags.Tag
import           GhcTags.Stream
import qualified GhcTags.CTag as CTag
import qualified GhcTags.ETag as ETag

import           Plugin.GhcTags.Options
import           Plugin.GhcTags.FileLock
import qualified Plugin.GhcTags.CTag as CTag


#if   __GLASGOW_HASKELL__ >= 906
type GhcPsModule = HsModule GhcPs
#else
type GhcPsModule = HsModule
#endif


-- | The GhcTags plugin.  It will run for every compiled module and have access
-- to parsed syntax tree.  It will inspect it and:
--
-- * update a global mutable state variable, which stores a tag map.
--   It is shared across modules compiled in the same `ghc` run.
-- * update 'tags' file.
--
-- The global mutable variable save us from parsing the tags file for every
-- compiled module.
--
-- __The syntax tree is left unchanged.__
--
-- The tags file will contain location information about:
--
--  * /top level terms/
--  * /data types/
--  * /record fields/
--  * /type synonyms/
--  * /type classes/
--  * /type class members/
--  * /type class instances/
--  * /type families/                           /(standalone and associated)/
--  * /type family instances/                   /(standalone and associated)/
--  * /data type families/                      /(standalone and associated)/
--  * /data type families instances/            /(standalone and associated)/
--  * /data type family instances constructors/ /(standalone and associated)/
--
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
GhcPlugins.defaultPlugin {
      parsedResultAction =
      -- TODO: add warnings / errors to 'ParsedResult'
       \[String]
args ModSummary
summary result :: ParsedResult
result@GhcPlugins.ParsedResult { HsParsedModule
parsedResultModule :: HsParsedModule
parsedResultModule :: ParsedResult -> HsParsedModule
GhcPlugins.parsedResultModule } ->
                     ParsedResult
result ParsedResult -> Hsc HsParsedModule -> Hsc ParsedResult
forall a b. a -> Hsc b -> Hsc a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
ghcTagsParserPlugin [String]
args ModSummary
summary HsParsedModule
parsedResultModule,
      driverPlugin       = ghcTagsDriverPlugin,
      pluginRecompile    = GhcPlugins.purePlugin
   }


-- | IOException wrapper; it is useful for the user to know that it's the plugin
-- not `ghc` that thrown the error.
--
data GhcTagsPluginException
    = GhcTagsParserPluginIOException IOException
    | GhcTagsDynFlagsPluginIOException IOException
    deriving Int -> GhcTagsPluginException -> ShowS
[GhcTagsPluginException] -> ShowS
GhcTagsPluginException -> String
(Int -> GhcTagsPluginException -> ShowS)
-> (GhcTagsPluginException -> String)
-> ([GhcTagsPluginException] -> ShowS)
-> Show GhcTagsPluginException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GhcTagsPluginException -> ShowS
showsPrec :: Int -> GhcTagsPluginException -> ShowS
$cshow :: GhcTagsPluginException -> String
show :: GhcTagsPluginException -> String
$cshowList :: [GhcTagsPluginException] -> ShowS
showList :: [GhcTagsPluginException] -> ShowS
Show

instance Exception GhcTagsPluginException


-- | The plugin does not change the 'HsParedModule', it only runs side effects.
--
ghcTagsParserPlugin :: [CommandLineOption]
                    -> ModSummary
                    -> HsParsedModule
                    -> Hsc HsParsedModule
ghcTagsParserPlugin :: [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
ghcTagsParserPlugin [String]
options
                    moduleSummary :: ModSummary
moduleSummary@ModSummary {Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dynFlags}
                    hsParsedModule :: HsParsedModule
hsParsedModule@HsParsedModule {Located (HsModule GhcPs)
hpm_module :: Located (HsModule GhcPs)
hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module} =

    HsParsedModule
hsParsedModule HsParsedModule -> Hsc () -> Hsc HsParsedModule
forall a b. a -> Hsc b -> Hsc a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$
      case [String] -> ParserResult (Options Identity)
runOptionParser [String]
options of
        Success opts :: Options Identity
opts@Options { filePath :: forall (f :: * -> *). Options f -> f String
filePath = Identity String
tagsFile
                             , Bool
debug :: Bool
debug :: forall (f :: * -> *). Options f -> Bool
debug
                             } ->

           IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_filepath(1,4,100)
            RawFilePath
tagsPath <- String -> IO RawFilePath
forall (m :: * -> *). MonadThrow m => String -> m RawFilePath
OsPath.encodeUtf String
tagsFile
#endif
            -- wrap 'IOException's
            (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\IOException
ioerr -> do
                     DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                              (MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
UnhandledException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                                (IOException -> String
forall e. Exception e => e -> String
displayException IOException
ioerr))
                     GhcTagsPluginException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOException -> GhcTagsPluginException
GhcTagsParserPluginIOException IOException
ioerr)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$

                -- Take advisory exclusive lock (a BSD lock using `flock`) on the tags
                -- file.  This is needed when `cabal` compiles in parallel.
                -- We take the lock on the copy, otherwise the lock would be removed when
                -- we move the file.
                Bool -> String -> LockMode -> (FD -> IO ()) -> IO ()
forall x. Bool -> String -> LockMode -> (FD -> IO x) -> IO x
withFileLock Bool
debug (ShowS
lockFilePath String
tagsFile) LockMode
ExclusiveLock ((FD -> IO ()) -> IO ()) -> (FD -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FD
_ -> do
                    Maybe Integer
mbInSize <-
                      if Bool
debug
                        then Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> IO Integer -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO Integer
getFileSize
#if MIN_VERSION_filepath(1,4,100)
                                      RawFilePath
tagsPath
#else
                                      tagsFile
#endif
                                      IO Integer -> (IOException -> IO Integer) -> IO Integer
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
                        else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
                    Options Identity -> ModSummary -> Located (HsModule GhcPs) -> IO ()
updateTags Options Identity
opts ModSummary
moduleSummary Located (HsModule GhcPs)
hpm_module
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                      let Just Integer
inSize = Maybe Integer
mbInSize
                      Integer
outSize <- RawFilePath -> IO Integer
getFileSize
#if MIN_VERSION_filepath(1,4,100)
                                   RawFilePath
tagsPath
#else
                                   tagsFile
#endif
                      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
inSize Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
outSize)
                        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                            (MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
SizeWarning
                                        (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                                        ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ Integer -> String
forall a. Show a => a -> String
show Integer
inSize
                                                , String
"→"
                                                , Integer -> String
forall a. Show a => a -> String
show Integer
outSize
                                                ]))

        Failure (ParserFailure String -> (ParserHelp, ExitCode, Int)
f)  ->
          IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$
            DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                     (MessageType -> Maybe Module -> String -> SDoc
messageDoc
                       MessageType
OptionParserFailure
                       (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                       (ParserHelp -> String
forall a. Show a => a -> String
show (case String -> (ParserHelp, ExitCode, Int)
f String
"<ghc-tags-plugin>" of (ParserHelp
h, ExitCode
_, Int
_) -> ParserHelp
h)
                         String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
options))

        CompletionInvoked {} -> String -> Hsc ()
forall a. HasCallStack => String -> a
error String
"ghc-tags-plugin: impossible happend"


data MessageType =
      ReadException
    | ParserException
    | WriteException
    | UnhandledException
    | OptionParserFailure
    | DebugMessage
    | SizeWarning


instance Show MessageType where
    show :: MessageType -> String
show MessageType
ReadException       = String
"read error"
    show MessageType
ParserException     = String
"tags parser error"
    show MessageType
WriteException      = String
"write error"
    show MessageType
UnhandledException  = String
"unhandled error"
    show MessageType
OptionParserFailure = String
"plugin options parser error"
    show MessageType
SizeWarning         = String
"tags file shrinked"
    show MessageType
DebugMessage        = String
""



-- | Extract tags from a module and update tags file
--
updateTags :: Options Identity
           -> ModSummary
           -> Located GhcPsModule
           -> IO ()
updateTags :: Options Identity -> ModSummary -> Located (HsModule GhcPs) -> IO ()
updateTags Options { Bool
etags :: Bool
etags :: forall (f :: * -> *). Options f -> Bool
etags, Bool
stream :: Bool
stream :: forall (f :: * -> *). Options f -> Bool
stream, filePath :: forall (f :: * -> *). Options f -> f String
filePath = Identity String
tagsFile, Bool
debug :: forall (f :: * -> *). Options f -> Bool
debug :: Bool
debug }
           ModSummary {Module
ms_mod :: ModSummary -> Module
ms_mod :: Module
ms_mod, ModLocation
ms_location :: ModLocation
ms_location :: ModSummary -> ModLocation
ms_location, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dynFlags}
           Located (HsModule GhcPs)
lmodule = do
    case (Bool
etags, Bool
stream) of
      (Bool
False, Bool
True)  -> IO ()
updateCTags_stream
      (Bool
False, Bool
False) -> IO ()
updateCTags
      (Bool
True,  Bool
_)     -> IO ()
updateETags
  where
    updateCTags_stream, updateCTags, updateETags :: IO ()

    --
    -- update ctags (streaming)
    --
    -- Stream ctags from from the tags file and intersperse tags parsed from
    -- the current module.  The results are written to a destination file which
    -- is then renamed to tags file.
    updateCTags_stream :: IO ()
updateCTags_stream = do
#if MIN_VERSION_filepath(1,4,100)
      RawFilePath
tagsPath <- String -> IO RawFilePath
forall (m :: * -> *). MonadThrow m => String -> m RawFilePath
OsPath.encodeUtf String
tagsFile
#endif
      Bool
tagsFileExists <- RawFilePath -> IO Bool
doesFileExist
#if MIN_VERSION_filepath(1,4,100)
                          RawFilePath
tagsPath
#else
                          tagsFile
#endif
      let destFile :: String
destFile = case String -> (String, String)
FilePath.splitFileName String
tagsFile of
            (String
dir, String
name) -> String
dir String -> ShowS
FilePath.</> String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name

      Maybe Integer
mbInSize <-
        if Bool
debug
          then
            if Bool
tagsFileExists
              then Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> IO Integer -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO Integer
getFileSize
#if MIN_VERSION_filepath(1,4,100)
                              RawFilePath
tagsPath
#else
                              tagsFile
#endif
                        IO Integer -> (IOException -> IO Integer) -> IO Integer
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
              else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0)
          else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing

      String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
destFile IOMode
WriteMode  ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
writeHandle ->
        String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tagsFile IOMode
ReadWriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
readHandle -> do
#if MIN_VERSION_filepath(1,4,100)
          RawFilePath
cwd <- IO RawFilePath
getCurrentDirectory
#else
          cwd <- rawFilePathFromBS . BSC.pack <$> getCurrentDirectory
#endif
          -- absolute directory path of the tags file; we need canonical path
          -- (without ".." and ".") to make 'makeRelative' works.
#if MIN_VERSION_filepath(1,4,100)
          RawFilePath
tagsDir <- RawFilePath -> IO RawFilePath
canonicalizePath ((RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a, b) -> a
fst ((RawFilePath, RawFilePath) -> RawFilePath)
-> (RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RawFilePath -> (RawFilePath, RawFilePath)
OsPath.splitFileName RawFilePath
tagsPath)
#else
          tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile)
#endif
          case ModLocation -> Maybe String
ml_hs_file ModLocation
ms_location of
            Maybe String
Nothing         -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just String
sourcePath -> do
              let sourcePathBS :: RawFilePath
sourcePathBS = ByteString -> RawFilePath
rawFilePathFromBS (ByteString -> RawFilePath) -> ByteString -> RawFilePath
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 (String -> Text
Text.pack String
sourcePath)
                  -- path of the compiled module; it is relative to the cabal file,
                  -- not the project.
                  modulePath :: RawFilePath
modulePath =
                    case Located (HsModule GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
GHC.getLoc Located (HsModule GhcPs)
lmodule of
                      GHC.RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_ ->
                          ByteString -> RawFilePath
rawFilePathFromBS
                        (ByteString -> RawFilePath)
-> (RealSrcSpan -> ByteString) -> RealSrcSpan -> RawFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
bytesFS
                        (FastString -> ByteString)
-> (RealSrcSpan -> FastString) -> RealSrcSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
GHC.srcSpanFile
                        (RealSrcSpan -> RawFilePath) -> RealSrcSpan -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
rss
                      GHC.UnhelpfulSpan {} ->
                        RawFilePath -> RawFilePath -> RawFilePath -> RawFilePath
fixFilePath RawFilePath
cwd RawFilePath
tagsDir RawFilePath
sourcePathBS
                  -- text parser
                  producer :: Pipes.Producer ByteString (SafeT IO) ()
                  producer :: Producer ByteString (SafeT IO) ()
producer
                    | Bool
tagsFileExists =
                        Producer ByteString (SafeT IO) ()
-> Producer ByteString (SafeT IO) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Handle -> Producer' ByteString (SafeT IO) ()
forall (m :: * -> *).
MonadIO m =>
Handle -> Producer' ByteString m ()
Pipes.BS.fromHandle Handle
readHandle)
                        Producer ByteString (SafeT IO) ()
-> (IOException -> Producer ByteString (SafeT IO) ())
-> Producer ByteString (SafeT IO) ()
forall (m :: * -> *) e a' a b' b r.
(MonadSafe m, Exception e) =>
Proxy a' a b' b m r
-> (e -> Proxy a' a b' b m r) -> Proxy a' a b' b m r
`Pipes.Safe.catchP` \(IOException
e :: IOException) ->
                          SafeT IO () -> Producer ByteString (SafeT IO) ()
forall (m :: * -> *) a.
Monad m =>
m a -> Proxy X () () ByteString m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (SafeT IO () -> Producer ByteString (SafeT IO) ())
-> SafeT IO () -> Producer ByteString (SafeT IO) ()
forall a b. (a -> b) -> a -> b
$ IO () -> SafeT IO ()
forall a. IO a -> SafeT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Pipes.liftIO (IO () -> SafeT IO ()) -> IO () -> SafeT IO ()
forall a b. (a -> b) -> a -> b
$
                            -- don't re-throw; this would kill `ghc`, error
                            -- loudly and continue.
                            DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags (MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ReadException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e))
                    | Bool
otherwise      = () -> Producer ByteString (SafeT IO) ()
forall a. a -> Proxy X () () ByteString (SafeT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

                  -- tags pipe
                  pipe :: Pipes.Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
                  pipe :: Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
pipe =
                    Proxy X () () CTag (StateT Int (StateT [CTag] (SafeT IO))) ()
-> (CTag -> Effect (StateT Int (StateT [CTag] (SafeT IO))) ())
-> Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
forall (m :: * -> *) x' x b' b a' c' c.
Functor m =>
Proxy x' x b' b m a'
-> (b -> Proxy x' x c' c m b') -> Proxy x' x c' c m a'
Pipes.for
                      ((forall a.
 StateT [CTag] (SafeT IO) a
 -> StateT Int (StateT [CTag] (SafeT IO)) a)
-> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
-> Proxy X () () CTag (StateT Int (StateT [CTag] (SafeT IO))) ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> Proxy X () () CTag m b -> Proxy X () () CTag n b
Pipes.hoist StateT [CTag] (SafeT IO) a
-> StateT Int (StateT [CTag] (SafeT IO)) a
forall a.
StateT [CTag] (SafeT IO) a
-> StateT Int (StateT [CTag] (SafeT IO)) a
forall (m :: * -> *) a. Monad m => m a -> StateT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
 -> Proxy X () () CTag (StateT Int (StateT [CTag] (SafeT IO))) ())
-> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
-> Proxy X () () CTag (StateT Int (StateT [CTag] (SafeT IO))) ()
forall a b. (a -> b) -> a -> b
$ (forall a. SafeT IO a -> StateT [CTag] (SafeT IO) a)
-> Proxy X () () CTag (SafeT IO) ()
-> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> Proxy X () () CTag m b -> Proxy X () () CTag n b
Pipes.hoist SafeT IO a -> StateT [CTag] (SafeT IO) a
forall a. SafeT IO a -> StateT [CTag] (SafeT IO) a
forall (m :: * -> *) a. Monad m => m a -> StateT [CTag] m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (Parser (Maybe CTag)
-> Producer ByteString (SafeT IO) ()
-> Proxy X () () CTag (SafeT IO) ()
forall (m :: * -> *) (tk :: TAG_KIND).
MonadIO m =>
Parser (Maybe (Tag tk))
-> Producer ByteString m () -> Producer (Tag tk) m ()
tagParser ((Header -> Maybe CTag)
-> (CTag -> Maybe CTag) -> Either Header CTag -> Maybe CTag
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe CTag -> Header -> Maybe CTag
forall a b. a -> b -> a
const Maybe CTag
forall a. Maybe a
Nothing) CTag -> Maybe CTag
forall a. a -> Maybe a
Just (Either Header CTag -> Maybe CTag)
-> Parser ByteString (Either Header CTag) -> Parser (Maybe CTag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString (Either Header CTag)
CTag.parseTagLine) Producer ByteString (SafeT IO) ()
producer)
                        Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
-> (IOException
    -> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ())
-> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) e a' a b' b r.
(MonadSafe m, Exception e) =>
Proxy a' a b' b m r
-> (e -> Proxy a' a b' b m r) -> Proxy a' a b' b m r
`Pipes.Safe.catchP` \(IOException
e :: IOException) ->
                          StateT [CTag] (SafeT IO) ()
-> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) a. Monad m => m a -> Proxy X () () CTag m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (StateT [CTag] (SafeT IO) ()
 -> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ())
-> StateT [CTag] (SafeT IO) ()
-> Proxy X () () CTag (StateT [CTag] (SafeT IO)) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT [CTag] (SafeT IO) ()
forall a. IO a -> StateT [CTag] (SafeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Pipes.liftIO (IO () -> StateT [CTag] (SafeT IO) ())
-> IO () -> StateT [CTag] (SafeT IO) ()
forall a b. (a -> b) -> a -> b
$
                            -- don't re-throw; this would kill `ghc`, error
                            -- loudly and continue.
                            DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e)
                      )
                      -- merge tags
                      (\CTag
tag -> do
                        -- update tags counter
                        (Int -> Int) -> Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' Int -> Int
forall a. Enum a => a -> a
succ
                        (forall a.
 StateT [CTag] (SafeT IO) a
 -> StateT Int (StateT [CTag] (SafeT IO)) a)
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
-> Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
forall {k} (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a)
-> Proxy X () () X m b -> Proxy X () () X n b
Pipes.hoist StateT [CTag] (SafeT IO) a
-> StateT Int (StateT [CTag] (SafeT IO)) a
forall a.
StateT [CTag] (SafeT IO) a
-> StateT Int (StateT [CTag] (SafeT IO)) a
forall (m :: * -> *) a. Monad m => m a -> StateT Int m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (Proxy X () () X (StateT [CTag] (SafeT IO)) ()
 -> Effect (StateT Int (StateT [CTag] (SafeT IO))) ())
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
-> Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
forall a b. (a -> b) -> a -> b
$
                            Handle
-> (CTag -> CTag -> Ordering)
-> (CTag -> Builder)
-> RawFilePath
-> CTag
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) (tk :: TAG_KIND).
MonadIO m =>
Handle
-> (Tag tk -> Tag tk -> Ordering)
-> (Tag tk -> Builder)
-> RawFilePath
-> Tag tk
-> Effect (StateT [Tag tk] m) ()
runCombineTagsPipe Handle
writeHandle
                              CTag -> CTag -> Ordering
CTag.compareTags
                              CTag -> Builder
CTag.formatTag
                              RawFilePath
modulePath
                              CTag
tag
                          Proxy X () () X (StateT [CTag] (SafeT IO)) ()
-> (IOException -> Proxy X () () X (StateT [CTag] (SafeT IO)) ())
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) e a' a b' b r.
(MonadSafe m, Exception e) =>
Proxy a' a b' b m r
-> (e -> Proxy a' a b' b m r) -> Proxy a' a b' b m r
`Pipes.Safe.catchP` \(IOException
e :: IOException) ->
                            StateT [CTag] (SafeT IO) ()
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) a. Monad m => m a -> Proxy X () () X m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (StateT [CTag] (SafeT IO) ()
 -> Proxy X () () X (StateT [CTag] (SafeT IO)) ())
-> StateT [CTag] (SafeT IO) ()
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
forall a b. (a -> b) -> a -> b
$ IO () -> StateT [CTag] (SafeT IO) ()
forall a. IO a -> StateT [CTag] (SafeT IO) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Pipes.liftIO (IO () -> StateT [CTag] (SafeT IO) ())
-> IO () -> StateT [CTag] (SafeT IO) ()
forall a b. (a -> b) -> a -> b
$
                              -- don't re-throw; this would kill `ghc`, error
                              -- loudly and continue.
                              DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
WriteException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
e)
                      )

              let tags :: [CTag]
                  tags :: [CTag]
tags = (CTag -> CTag) -> [CTag] -> [CTag]
forall a b. (a -> b) -> [a] -> [b]
map (RawFilePath -> RawFilePath -> CTag -> CTag
forall (tk :: TAG_KIND).
RawFilePath -> RawFilePath -> Tag tk -> Tag tk
fixTagFilePath RawFilePath
cwd RawFilePath
tagsDir)
                                              -- fix file names
                       ([CTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CTag] -> [CTag]
forall (tk :: TAG_KIND). [Tag tk] -> [Tag tk]
filterAdjacentTags
                       ([CTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CTag -> CTag -> Ordering) -> [CTag] -> [CTag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy CTag -> CTag -> Ordering
forall (tk :: TAG_KIND).
Ord (TagAddress tk) =>
Tag tk -> Tag tk -> Ordering
compareTags   -- sort
                       ([CTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcTag -> Maybe CTag) -> [GhcTag] -> [CTag]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SingTagKind 'CTAG -> DynFlags -> GhcTag -> Maybe CTag
forall (tk :: TAG_KIND).
SingTagKind tk -> DynFlags -> GhcTag -> Maybe (Tag tk)
ghcTagToTag SingTagKind 'CTAG
SingCTag DynFlags
dynFlags)
                                              -- translate 'GhcTag' to 'Tag'
                       ([GhcTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [GhcTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsModule GhcPs) -> [GhcTag]
getGhcTags           -- generate 'GhcTag's
                       (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs) -> [CTag]
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs)
lmodule

              -- Write header
              Handle -> ByteString -> IO ()
BSL.hPut Handle
writeHandle (Builder -> ByteString
BB.toLazyByteString ((Header -> Builder) -> [Header] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Header -> Builder
CTag.formatHeader [Header]
CTag.headers))
              -- update tags file / run 'pipe'
              (Int
parsedTags, [CTag]
tags') <- SafeT IO (Int, [CTag]) -> IO (Int, [CTag])
forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
SafeT m r -> m r
Pipes.Safe.runSafeT (SafeT IO (Int, [CTag]) -> IO (Int, [CTag]))
-> SafeT IO (Int, [CTag]) -> IO (Int, [CTag])
forall a b. (a -> b) -> a -> b
$ StateT [CTag] (SafeT IO) Int -> [CTag] -> SafeT IO (Int, [CTag])
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (StateT Int (StateT [CTag] (SafeT IO)) ()
-> Int -> StateT [CTag] (SafeT IO) Int
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
-> StateT Int (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) r. Monad m => Effect m r -> m r
Pipes.runEffect Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
pipe) Int
0) [CTag]
tags
              -- write the remaining tags'
              (CTag -> IO ()) -> [CTag] -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Handle -> ByteString -> IO ()
BSL.hPut Handle
writeHandle (ByteString -> IO ()) -> (CTag -> ByteString) -> CTag -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> (CTag -> Builder) -> CTag -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> Builder
CTag.formatTag) [CTag]
tags'

              Handle -> IO ()
hFlush Handle
writeHandle

              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Integer
outSize <- RawFilePath -> IO Integer
getFileSize
#if MIN_VERSION_filepath(1,4,100)
                          RawFilePath
tagsPath
#else
                          tagsFile
#endif
                let Just Integer
inSize = Maybe Integer
mbInSize
                DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
DebugMessage (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                  ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"path: "
                          , RawFilePath -> String
forall a. Show a => a -> String
show RawFilePath
modulePath
                          , String
" parsed: "
                          , Int -> String
forall a. Show a => a -> String
show Int
parsedTags
                          , String
" found: "
                          , Int -> String
forall a. Show a => a -> String
show ([CTag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTag]
tags Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [CTag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTag]
tags')
                          , String
" in-size: "
                          , Integer -> String
forall a. Show a => a -> String
show Integer
inSize
                          , String
" out-size: "
                          , Integer -> String
forall a. Show a => a -> String
show Integer
outSize
                          ])
      
#if MIN_VERSION_filepath(1,4,100)
      RawFilePath
destPath <- String -> IO RawFilePath
forall (m :: * -> *). MonadThrow m => String -> m RawFilePath
OsPath.encodeUtf String
destFile
      Bool
destFileExists <- RawFilePath -> IO Bool
doesFileExist RawFilePath
destPath
#else
      destFileExists <- doesFileExist destFile
#endif
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
destFileExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_filepath(1,4,100)
        RawFilePath -> RawFilePath -> IO ()
renameFile RawFilePath
destPath RawFilePath
tagsPath
#else
        renameFile destFile tagsFile
#endif


    --
    -- update ctags (non streaming)
    --
    updateCTags :: IO ()
updateCTags = do
#if MIN_VERSION_filepath(1,4,100)
      RawFilePath
tagsPath <- String -> IO RawFilePath
forall (m :: * -> *). MonadThrow m => String -> m RawFilePath
OsPath.encodeUtf String
tagsFile
      Bool
tagsFileExists <- RawFilePath -> IO Bool
doesFileExist RawFilePath
tagsPath
#else
      tagsFileExists <- doesFileExist tagsFile
#endif

      Maybe Integer
mbInSize <-
        if Bool
debug
          then
            if Bool
tagsFileExists
              then
#if MIN_VERSION_filepath(1,4,100)
                   Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> IO Integer -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO Integer
getFileSize RawFilePath
tagsPath
                        IO Integer -> (IOException -> IO Integer) -> IO Integer
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
#else
                   Just <$> getFileSize tagsFile
                        `catch` \(_ :: IOException) -> pure 0
#endif
              else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0)
          else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
      !ByteString
tagsContent <- if Bool
tagsFileExists
                        then String -> IO ByteString
BS.readFile String
tagsFile
                        else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
forall a. Monoid a => a
mempty
      String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tagsFile IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
writeHandle -> do
#if MIN_VERSION_filepath(1,4,100)
        RawFilePath
cwd <- IO RawFilePath
getCurrentDirectory
#else
        cwd <- rawFilePathFromBS . BSC.pack <$> getCurrentDirectory
#endif
        -- absolute directory path of the tags file; we need canonical path
        -- (without ".." and ".") to make 'makeRelative' works.
#if MIN_VERSION_filepath(1,4,100)
        RawFilePath
tagsDir <- RawFilePath -> IO RawFilePath
canonicalizePath ((RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a, b) -> a
fst ((RawFilePath, RawFilePath) -> RawFilePath)
-> (RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RawFilePath -> (RawFilePath, RawFilePath)
OsPath.splitFileName RawFilePath
tagsPath)
#else
        tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile)
#endif
        case ModLocation -> Maybe String
ml_hs_file ModLocation
ms_location of
          Maybe String
Nothing         -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          Just String
sourcePath -> do
            let sourcePathBS :: RawFilePath
sourcePathBS = ByteString -> RawFilePath
rawFilePathFromBS (ByteString -> RawFilePath) -> ByteString -> RawFilePath
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 (String -> Text
Text.pack String
sourcePath)
                -- path of the compiled module; it is relative to the cabal file,
                -- not the project.
                modulePath :: RawFilePath
modulePath =
                  case Located (HsModule GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
GHC.getLoc Located (HsModule GhcPs)
lmodule of
                    GHC.RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_ ->
                        ByteString -> RawFilePath
rawFilePathFromBS
                      (ByteString -> RawFilePath)
-> (RealSrcSpan -> ByteString) -> RealSrcSpan -> RawFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
bytesFS
                      (FastString -> ByteString)
-> (RealSrcSpan -> FastString) -> RealSrcSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
GHC.srcSpanFile
                      (RealSrcSpan -> RawFilePath) -> RealSrcSpan -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
rss
                    GHC.UnhelpfulSpan {} ->
                      RawFilePath -> RawFilePath -> RawFilePath -> RawFilePath
fixFilePath RawFilePath
cwd RawFilePath
tagsDir RawFilePath
sourcePathBS

            Either IOException (Either String [Either Header CTag])
pres <- forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO (Either String [Either Header CTag])
 -> IO (Either IOException (Either String [Either Header CTag])))
-> IO (Either String [Either Header CTag])
-> IO (Either IOException (Either String [Either Header CTag]))
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either String [Either Header CTag])
CTag.parseTagsFile ByteString
tagsContent
            case Either IOException (Either String [Either Header CTag])
pres of
              Left IOException
err   ->
                DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
err)

              Right (Left String
err) ->
                DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) String
err

              Right (Right [Either Header CTag]
parsed) -> do
                let parsedTags :: [CTag]
parsedTags = [Either Header CTag] -> [CTag]
forall a b. [Either a b] -> [b]
rights [Either Header CTag]
parsed 

                    tags :: [CTag]
                    tags :: [CTag]
tags = (CTag -> CTag) -> [CTag] -> [CTag]
forall a b. (a -> b) -> [a] -> [b]
map (RawFilePath -> RawFilePath -> CTag -> CTag
forall (tk :: TAG_KIND).
RawFilePath -> RawFilePath -> Tag tk -> Tag tk
fixTagFilePath RawFilePath
cwd RawFilePath
tagsDir)
                                                -- fix file names
                         ([CTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CTag] -> [CTag]
forall (tk :: TAG_KIND). [Tag tk] -> [Tag tk]
filterAdjacentTags
                         ([CTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CTag -> CTag -> Ordering) -> [CTag] -> [CTag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy CTag -> CTag -> Ordering
forall (tk :: TAG_KIND).
Ord (TagAddress tk) =>
Tag tk -> Tag tk -> Ordering
compareTags   -- sort
                         ([CTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcTag -> Maybe CTag) -> [GhcTag] -> [CTag]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SingTagKind 'CTAG -> DynFlags -> GhcTag -> Maybe CTag
forall (tk :: TAG_KIND).
SingTagKind tk -> DynFlags -> GhcTag -> Maybe (Tag tk)
ghcTagToTag SingTagKind 'CTAG
SingCTag DynFlags
dynFlags)
                                                -- translate 'GhcTag' to 'Tag'
                         ([GhcTag] -> [CTag])
-> (Located (HsModule GhcPs) -> [GhcTag])
-> Located (HsModule GhcPs)
-> [CTag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsModule GhcPs) -> [GhcTag]
getGhcTags           -- generate 'GhcTag's
                         (Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs) -> [CTag]
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs)
lmodule

                    combined :: [CTag]
                    combined :: [CTag]
combined = (CTag -> CTag -> Ordering)
-> RawFilePath -> [CTag] -> [CTag] -> [CTag]
forall (tk :: TAG_KIND).
(Tag tk -> Tag tk -> Ordering)
-> RawFilePath -> [Tag tk] -> [Tag tk] -> [Tag tk]
combineTags CTag -> CTag -> Ordering
CTag.compareTags RawFilePath
modulePath [CTag]
tags [CTag]
parsedTags

                Handle -> Builder -> IO ()
BB.hPutBuilder Handle
writeHandle
                          (    (Header -> Builder) -> [Header] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Header -> Builder
CTag.formatHeader [Header]
CTag.headers
                            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (CTag -> Builder) -> [CTag] -> Builder
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap CTag -> Builder
CTag.formatTag [CTag]
combined
                          ) 

                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_filepath(1,4,100)
                  Integer
outSize <- RawFilePath -> IO Integer
getFileSize RawFilePath
tagsPath
#else
                  outSize <- getFileSize tagsFile
#endif
                  let Just Integer
inSize = Maybe Integer
mbInSize
                  DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
DebugMessage (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                    ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"parsed: "
                            , Int -> String
forall a. Show a => a -> String
show ([CTag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTag]
parsedTags)
                            , String
" found: "
                            , Int -> String
forall a. Show a => a -> String
show ([CTag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTag]
tags)
                            , String
" in-size: "
                            , Integer -> String
forall a. Show a => a -> String
show Integer
inSize
                            , String
" out-size: "
                            , Integer -> String
forall a. Show a => a -> String
show Integer
outSize
                            ])


    --
    -- update etags file
    --
    updateETags :: IO ()
updateETags = do
#if MIN_VERSION_filepath(1,4,100)
      RawFilePath
tagsPath <- String -> IO RawFilePath
forall (m :: * -> *). MonadThrow m => String -> m RawFilePath
OsPath.encodeUtf String
tagsFile
      Bool
tagsFileExists <- RawFilePath -> IO Bool
doesFileExist RawFilePath
tagsPath
#else
      tagsFileExists <- doesFileExist tagsFile
#endif

      Maybe Integer
mbInSize <-
        if Bool
debug
          then
            if Bool
tagsFileExists
              then
#if MIN_VERSION_filepath(1,4,100)
                   Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> IO Integer -> IO (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawFilePath -> IO Integer
getFileSize RawFilePath
tagsPath
                        IO Integer -> (IOException -> IO Integer) -> IO Integer
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> Integer -> IO Integer
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
#else
                   Just <$> getFileSize tagsFile
                        `catch` \(_ :: IOException) -> pure 0
#endif
              else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
0)
          else Maybe Integer -> IO (Maybe Integer)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
      !ByteString
tagsContent <- if Bool
tagsFileExists
                        then String -> IO ByteString
BS.readFile String
tagsFile
                        else ByteString -> IO ByteString
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
forall a. Monoid a => a
mempty
      String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tagsFile IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
writeHandle -> do
#if MIN_VERSION_filepath(1,4,100)
          RawFilePath
cwd <- IO RawFilePath
getCurrentDirectory
#else
          cwd <- rawFilePathFromBS . BSC.pack <$> getCurrentDirectory
#endif
          -- absolute directory path of the tags file; we need canonical path
          -- (without ".." and ".") to make 'makeRelative' works.
#if MIN_VERSION_filepath(1,4,100)
          RawFilePath
tagsDir <- RawFilePath -> IO RawFilePath
canonicalizePath ((RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a, b) -> a
fst ((RawFilePath, RawFilePath) -> RawFilePath)
-> (RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RawFilePath -> (RawFilePath, RawFilePath)
OsPath.splitFileName RawFilePath
tagsPath)
#else
          tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile)
#endif

          case ModLocation -> Maybe String
ml_hs_file ModLocation
ms_location of
            Maybe String
Nothing         -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just String
sourcePath -> do
              Either IOException (Either String [ETag])
pres <- forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO (Either String [ETag])
 -> IO (Either IOException (Either String [ETag])))
-> IO (Either String [ETag])
-> IO (Either IOException (Either String [ETag]))
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either String [ETag])
ETag.parseTagsFile ByteString
tagsContent
              case Either IOException (Either String [ETag])
pres of
                Left IOException
err   ->
                  DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> String
forall e. Exception e => e -> String
displayException IOException
err)

                Right (Left String
err) ->
                  DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) String
err

                Right (Right [ETag]
parsedTags) -> do
                  let sourcePathBS :: RawFilePath
sourcePathBS = ByteString -> RawFilePath
rawFilePathFromBS
                                   (ByteString -> RawFilePath) -> ByteString -> RawFilePath
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 (String -> Text
Text.pack String
sourcePath)
                      modulePath :: RawFilePath
modulePath =
                        case Located (HsModule GhcPs) -> SrcSpan
forall l e. GenLocated l e -> l
GHC.getLoc Located (HsModule GhcPs)
lmodule of
                          GHC.RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_ ->
                              ByteString -> RawFilePath
rawFilePathFromBS
                            (ByteString -> RawFilePath)
-> (RealSrcSpan -> ByteString) -> RealSrcSpan -> RawFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
bytesFS
                            (FastString -> ByteString)
-> (RealSrcSpan -> FastString) -> RealSrcSpan -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
GHC.srcSpanFile
                            (RealSrcSpan -> RawFilePath) -> RealSrcSpan -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan
rss
                          GHC.UnhelpfulSpan {} ->
                            RawFilePath -> RawFilePath -> RawFilePath -> RawFilePath
fixFilePath RawFilePath
cwd RawFilePath
tagsDir RawFilePath
sourcePathBS

                      tags :: [ETag]
                      tags :: [ETag]
tags = [ETag] -> [ETag]
forall (tk :: TAG_KIND). [Tag tk] -> [Tag tk]
filterAdjacentTags
                           ([ETag] -> [ETag])
-> (Located (HsModule GhcPs) -> [ETag])
-> Located (HsModule GhcPs)
-> [ETag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ETag -> ETag -> Ordering) -> [ETag] -> [ETag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ETag -> ETag -> Ordering
ETag.compareTags
                           ([ETag] -> [ETag])
-> (Located (HsModule GhcPs) -> [ETag])
-> Located (HsModule GhcPs)
-> [ETag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ETag -> ETag) -> [ETag] -> [ETag]
forall a b. (a -> b) -> [a] -> [b]
map (RawFilePath -> RawFilePath -> ETag -> ETag
forall (tk :: TAG_KIND).
RawFilePath -> RawFilePath -> Tag tk -> Tag tk
fixTagFilePath RawFilePath
cwd RawFilePath
tagsDir)
                           ([ETag] -> [ETag])
-> (Located (HsModule GhcPs) -> [ETag])
-> Located (HsModule GhcPs)
-> [ETag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GhcTag -> Maybe ETag) -> [GhcTag] -> [ETag]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (SingTagKind 'ETAG -> DynFlags -> GhcTag -> Maybe ETag
forall (tk :: TAG_KIND).
SingTagKind tk -> DynFlags -> GhcTag -> Maybe (Tag tk)
ghcTagToTag SingTagKind 'ETAG
SingETag DynFlags
dynFlags)
                           ([GhcTag] -> [ETag])
-> (Located (HsModule GhcPs) -> [GhcTag])
-> Located (HsModule GhcPs)
-> [ETag]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsModule GhcPs) -> [GhcTag]
getGhcTags
                           (Located (HsModule GhcPs) -> [ETag])
-> Located (HsModule GhcPs) -> [ETag]
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs)
lmodule

                      combined :: [ETag]
                      combined :: [ETag]
combined = (ETag -> ETag -> Ordering)
-> RawFilePath -> [ETag] -> [ETag] -> [ETag]
forall (tk :: TAG_KIND).
(Tag tk -> Tag tk -> Ordering)
-> RawFilePath -> [Tag tk] -> [Tag tk] -> [Tag tk]
combineTags ETag -> ETag -> Ordering
ETag.compareTags RawFilePath
modulePath [ETag]
tags [ETag]
parsedTags

                  Handle -> Builder -> IO ()
BB.hPutBuilder Handle
writeHandle ([ETag] -> Builder
ETag.formatETagsFile [ETag]
combined)

                  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#if MIN_VERSION_filepath(1,4,100)
                    Integer
outSize <- RawFilePath -> IO Integer
getFileSize RawFilePath
tagsPath
#else
                    outSize <- getFileSize tagsFile
#endif
                    let Just Integer
inSize = Maybe Integer
mbInSize
                    DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
DebugMessage (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                      ([String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"parsed: "
                              , Int -> String
forall a. Show a => a -> String
show ([ETag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ETag]
parsedTags)
                              , String
" found: "
                              , Int -> String
forall a. Show a => a -> String
show ([ETag] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ETag]
tags)
                              , String
" in-size: "
                              , Integer -> String
forall a. Show a => a -> String
show Integer
inSize
                              , String
" out-size: "
                              , Integer -> String
forall a. Show a => a -> String
show Integer
outSize
                              ])


-- | Filter adjacent tags.
--
filterAdjacentTags :: [Tag tk] -> [Tag tk]
filterAdjacentTags :: forall (tk :: TAG_KIND). [Tag tk] -> [Tag tk]
filterAdjacentTags [Tag tk]
tags =
    ((Maybe (Tag tk), Tag tk, Maybe (Tag tk)) -> [Tag tk] -> [Tag tk])
-> [Tag tk]
-> [(Maybe (Tag tk), Tag tk, Maybe (Tag tk))]
-> [Tag tk]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
      (\(Maybe (Tag tk)
mprev, Tag tk
c, Maybe (Tag tk)
mnext) [Tag tk]
acc ->
          case (Maybe (Tag tk)
mprev, Maybe (Tag tk)
mnext) of
            -- filter out terms preceded by a type signature
            (Just Tag tk
p, Maybe (Tag tk)
_)  | Tag tk -> TagName
forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
p TagName -> TagName -> Bool
forall a. Eq a => a -> a -> Bool
== Tag tk -> TagName
forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
c
                         , TagKind
TkTypeSignature <- Tag tk -> TagKind
forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
p
                         , TagKind
k <- Tag tk -> TagKind
forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
c
                         , TagKind
k TagKind -> TagKind -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind
TkTerm
                        Bool -> Bool -> Bool
|| TagKind
k TagKind -> TagKind -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind
TkFunction
                        ->     [Tag tk]
acc

            -- filter out type constructors followed by a data constructor
            (Maybe (Tag tk)
_, Just Tag tk
n)  | Tag tk -> TagName
forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
c TagName -> TagName -> Bool
forall a. Eq a => a -> a -> Bool
== Tag tk -> TagName
forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
n
                         , TagKind
TkTypeConstructor <- Tag tk -> TagKind
forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
c
                         , TagKind
k <- Tag tk -> TagKind
forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
n
                         , TagKind
k TagKind -> TagKind -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind
TkDataConstructor
                        Bool -> Bool -> Bool
|| TagKind
k TagKind -> TagKind -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind
TkGADTConstructor
                        ->     [Tag tk]
acc

            (Maybe (Tag tk), Maybe (Tag tk))
_           -> Tag tk
c Tag tk -> [Tag tk] -> [Tag tk]
forall a. a -> [a] -> [a]
: [Tag tk]
acc

      )
      []
      ([Maybe (Tag tk)]
-> [Tag tk]
-> [Maybe (Tag tk)]
-> [(Maybe (Tag tk), Tag tk, Maybe (Tag tk))]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Maybe (Tag tk)]
tags' [Tag tk]
tags [Maybe (Tag tk)]
tags'')
  where
    -- previous
    tags' :: [Maybe (Tag tk)]
tags' = case [Tag tk]
tags of
      [] -> []
      [Tag tk]
_  -> Maybe (Tag tk)
forall a. Maybe a
Nothing Maybe (Tag tk) -> [Maybe (Tag tk)] -> [Maybe (Tag tk)]
forall a. a -> [a] -> [a]
: (Tag tk -> Maybe (Tag tk)) -> [Tag tk] -> [Maybe (Tag tk)]
forall a b. (a -> b) -> [a] -> [b]
map Tag tk -> Maybe (Tag tk)
forall a. a -> Maybe a
Just ([Tag tk] -> [Tag tk]
forall a. HasCallStack => [a] -> [a]
init [Tag tk]
tags)

    -- next
    tags'' :: [Maybe (Tag tk)]
tags'' = case [Tag tk]
tags of
      []   -> []
      Tag tk
_:[Tag tk]
ts -> (Tag tk -> Maybe (Tag tk)) -> [Tag tk] -> [Maybe (Tag tk)]
forall a b. (a -> b) -> [a] -> [b]
map Tag tk -> Maybe (Tag tk)
forall a. a -> Maybe a
Just [Tag tk]
ts [Maybe (Tag tk)] -> [Maybe (Tag tk)] -> [Maybe (Tag tk)]
forall a. [a] -> [a] -> [a]
++ [Maybe (Tag tk)
forall a. Maybe a
Nothing]


--
-- Tags for Template-Haskell splices
--

ghcTagsDriverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv
ghcTagsDriverPlugin :: [String] -> HscEnv -> IO HscEnv
ghcTagsDriverPlugin [String]
opts env :: HscEnv
env@HscEnv{ Hooks
hsc_hooks :: Hooks
hsc_hooks :: HscEnv -> Hooks
hsc_hooks } = do
    let hook :: MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
hook = [String] -> DynFlags -> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
ghcTagsMetaHook [String]
opts (HscEnv -> DynFlags
hsc_dflags HscEnv
env)
    HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
env { hsc_hooks = hsc_hooks { runMetaHook = Just hook } }


-- | DynFlags plugin which extract tags from TH splices.
--
ghcTagsMetaHook :: [CommandLineOption] -> DynFlags -> MetaHook TcM
ghcTagsMetaHook :: [String] -> DynFlags -> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
ghcTagsMetaHook [String]
options DynFlags
dynFlags MetaRequest
request LHsExpr GhcTc
expr =
    case [String] -> ParserResult (Options Identity)
runOptionParser [String]
options of
      Success Options { filePath :: forall (f :: * -> *). Options f -> f String
filePath = Identity String
tagsFile
                      , Bool
etags :: forall (f :: * -> *). Options f -> Bool
etags :: Bool
etags
                      , Bool
debug :: forall (f :: * -> *). Options f -> Bool
debug :: Bool
debug
                      } -> do

        MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM ())
-> TcM MetaResult
forall a.
MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM a)
-> TcM MetaResult
withMetaD MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
defaultRunMeta MetaRequest
request LHsExpr GhcTc
expr (([LHsDecl GhcPs] -> TcM ()) -> TcM MetaResult)
-> ([LHsDecl GhcPs] -> TcM ()) -> TcM MetaResult
forall a b. (a -> b) -> a -> b
$ \[LHsDecl GhcPs]
decls ->
          IO () -> TcM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcM ()) -> IO () -> TcM ()
forall a b. (a -> b) -> a -> b
$
            (IOException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\IOException
ioerr -> do
                     DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                             (MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
UnhandledException Maybe Module
forall a. Maybe a
Nothing
                               (IOException -> String
forall e. Exception e => e -> String
displayException IOException
ioerr))
                     GhcTagsPluginException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (IOException -> GhcTagsPluginException
GhcTagsDynFlagsPluginIOException IOException
ioerr)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            Bool -> String -> LockMode -> (FD -> IO ()) -> IO ()
forall x. Bool -> String -> LockMode -> (FD -> IO x) -> IO x
withFileLock Bool
debug (ShowS
lockFilePath String
tagsFile) LockMode
ExclusiveLock ((FD -> IO ()) -> IO ()) -> (FD -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FD
_ -> do
#if MIN_VERSION_filepath(1,4,100)
            RawFilePath
cwd <- IO RawFilePath
getCurrentDirectory
#else
            cwd <- rawFilePathFromBS . BSC.pack <$> getCurrentDirectory
#endif
#if MIN_VERSION_filepath(1,4,100)
            RawFilePath
tagsPath <- String -> IO RawFilePath
forall (m :: * -> *). MonadThrow m => String -> m RawFilePath
OsPath.encodeUtf String
tagsFile
            RawFilePath
tagsDir <- RawFilePath -> IO RawFilePath
canonicalizePath ((RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a, b) -> a
fst ((RawFilePath, RawFilePath) -> RawFilePath)
-> (RawFilePath, RawFilePath) -> RawFilePath
forall a b. (a -> b) -> a -> b
$ RawFilePath -> (RawFilePath, RawFilePath)
OsPath.splitFileName RawFilePath
tagsPath)
#else
            tagsDir <- rawFilePathFromBS . BSC.pack <$> canonicalizePath (fst $ FilePath.splitFileName tagsFile)
#endif
            ByteString
tagsContent <- String -> IO ByteString
BSC.readFile String
tagsFile
            if Bool
etags
              then do
                Either String [ETag]
pr <- ByteString -> IO (Either String [ETag])
ETag.parseTagsFile ByteString
tagsContent
                case Either String [ETag]
pr of
                  Left String
err ->
                    DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
ParserException Maybe Module
forall a. Maybe a
Nothing String
err

                  Right [ETag]
tags -> do
                    let tags' :: [ETag]
                        tags' :: [ETag]
tags' = (ETag -> ETag -> Ordering) -> [ETag] -> [ETag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ETag -> ETag -> Ordering
ETag.compareTags ([ETag] -> [ETag]) -> [ETag] -> [ETag]
forall a b. (a -> b) -> a -> b
$
                                  [ETag]
tags
                                  [ETag] -> [ETag] -> [ETag]
forall a. [a] -> [a] -> [a]
++
                                  ((ETag -> ETag) -> Maybe ETag -> Maybe ETag
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RawFilePath -> RawFilePath -> ETag -> ETag
forall (tk :: TAG_KIND).
RawFilePath -> RawFilePath -> Tag tk -> Tag tk
fixTagFilePath RawFilePath
cwd RawFilePath
tagsDir)
                                  (Maybe ETag -> Maybe ETag)
-> (GhcTag -> Maybe ETag) -> GhcTag -> Maybe ETag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingTagKind 'ETAG -> DynFlags -> GhcTag -> Maybe ETag
forall (tk :: TAG_KIND).
SingTagKind tk -> DynFlags -> GhcTag -> Maybe (Tag tk)
ghcTagToTag SingTagKind 'ETAG
SingETag DynFlags
dynFlags)
                                    (GhcTag -> Maybe ETag) -> [GhcTag] -> [ETag]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe`
                                     Maybe [IE GhcPs] -> [LHsDecl GhcPs] -> [GhcTag]
hsDeclsToGhcTags Maybe [IE GhcPs]
forall a. Maybe a
Nothing [LHsDecl GhcPs]
decls
                    String -> ByteString -> IO ()
BSL.writeFile String
tagsFile (Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [ETag] -> Builder
ETag.formatTagsFile [ETag]
tags')
              else do
                Either String ([Header], [CTag])
pr <- ([Either Header CTag] -> ([Header], [CTag]))
-> Either String [Either Header CTag]
-> Either String ([Header], [CTag])
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either Header CTag] -> ([Header], [CTag])
forall a b. [Either a b] -> ([a], [b])
partitionEithers (Either String [Either Header CTag]
 -> Either String ([Header], [CTag]))
-> IO (Either String [Either Header CTag])
-> IO (Either String ([Header], [CTag]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Either String [Either Header CTag])
CTag.parseTagsFile ByteString
tagsContent
                case Either String ([Header], [CTag])
pr of
                  Left String
err ->
                    DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
ParserException Maybe Module
forall a. Maybe a
Nothing String
err

                  Right ([Header]
headers, [CTag]
tags) -> do
                    let tags' :: [Either CTag.Header CTag]
                        tags' :: [Either Header CTag]
tags' = Header -> Either Header CTag
forall a b. a -> Either a b
Left (Header -> Either Header CTag) -> [Header] -> [Either Header CTag]
forall a b. (a -> b) -> [a] -> [b]
`map` [Header]
headers
                             [Either Header CTag]
-> [Either Header CTag] -> [Either Header CTag]
forall a. [a] -> [a] -> [a]
++ CTag -> Either Header CTag
forall a b. b -> Either a b
Right (CTag -> Either Header CTag) -> [CTag] -> [Either Header CTag]
forall a b. (a -> b) -> [a] -> [b]
`map`
                                (CTag -> CTag -> Ordering) -> [CTag] -> [CTag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy CTag -> CTag -> Ordering
CTag.compareTags
                                ( [CTag]
tags
                                  [CTag] -> [CTag] -> [CTag]
forall a. [a] -> [a] -> [a]
++
                                  ((CTag -> CTag) -> Maybe CTag -> Maybe CTag
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RawFilePath -> RawFilePath -> CTag -> CTag
forall (tk :: TAG_KIND).
RawFilePath -> RawFilePath -> Tag tk -> Tag tk
fixTagFilePath RawFilePath
cwd RawFilePath
tagsDir)
                                    (Maybe CTag -> Maybe CTag)
-> (GhcTag -> Maybe CTag) -> GhcTag -> Maybe CTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingTagKind 'CTAG -> DynFlags -> GhcTag -> Maybe CTag
forall (tk :: TAG_KIND).
SingTagKind tk -> DynFlags -> GhcTag -> Maybe (Tag tk)
ghcTagToTag SingTagKind 'CTAG
SingCTag DynFlags
dynFlags)
                                    (GhcTag -> Maybe CTag) -> [GhcTag] -> [CTag]
forall a b. (a -> Maybe b) -> [a] -> [b]
`mapMaybe`
                                    Maybe [IE GhcPs] -> [LHsDecl GhcPs] -> [GhcTag]
hsDeclsToGhcTags Maybe [IE GhcPs]
forall a. Maybe a
Nothing [LHsDecl GhcPs]
decls
                                )
                    String -> ByteString -> IO ()
BSL.writeFile String
tagsFile (Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ [Either Header CTag] -> Builder
CTag.formatTagsFile [Either Header CTag]
tags')

      Failure (ParserFailure String -> (ParserHelp, ExitCode, Int)
f)  ->
        MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM ())
-> TcM MetaResult
forall a.
MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM a)
-> TcM MetaResult
withMetaD MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
defaultRunMeta MetaRequest
request LHsExpr GhcTc
expr (([LHsDecl GhcPs] -> TcM ()) -> TcM MetaResult)
-> ([LHsDecl GhcPs] -> TcM ()) -> TcM MetaResult
forall a b. (a -> b) -> a -> b
$ \[LHsDecl GhcPs]
_ ->
        IO () -> TcM ()
forall a. IO a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> TcM ()) -> IO () -> TcM ()
forall a b. (a -> b) -> a -> b
$
          DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                   (MessageType -> Maybe Module -> String -> SDoc
messageDoc
                     MessageType
OptionParserFailure
                     Maybe Module
forall a. Maybe a
Nothing
                     (ParserHelp -> String
forall a. Show a => a -> String
show (case String -> (ParserHelp, ExitCode, Int)
f String
"<ghc-tags-plugin>" of (ParserHelp
h, ExitCode
_, Int
_) -> ParserHelp
h)
                       String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
options))

      CompletionInvoked {} -> String -> TcM MetaResult
forall a. HasCallStack => String -> a
error String
"ghc-tags-plugin: impossible happend"

  where
    -- run the hook and call call the callback with new declarations
    withMetaD :: MetaHook TcM -> MetaRequest -> LHsExpr GhcTc
                    -> ([LHsDecl GhcPs] -> TcM a)
                    -> TcM MetaResult
    withMetaD :: forall a.
MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM a)
-> TcM MetaResult
withMetaD MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h MetaRequest
req LHsExpr GhcTc
e [LHsDecl GhcPs] -> TcM a
f = case MetaRequest
req of
      MetaE  LHsExpr GhcPs -> MetaResult
k -> LHsExpr GhcPs -> MetaResult
GenLocated SrcSpanAnnA (HsExpr GhcPs) -> MetaResult
k (GenLocated SrcSpanAnnA (HsExpr GhcPs) -> MetaResult)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> TcM MetaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsExpr GhcPs)
forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsExpr GhcPs)
metaRequestE MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h LHsExpr GhcTc
e
      MetaP  LPat GhcPs -> MetaResult
k -> LPat GhcPs -> MetaResult
GenLocated SrcSpanAnnA (Pat GhcPs) -> MetaResult
k (GenLocated SrcSpanAnnA (Pat GhcPs) -> MetaResult)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (Pat GhcPs))
-> TcM MetaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LPat GhcPs)
forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LPat GhcPs)
metaRequestP MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h LHsExpr GhcTc
e
      MetaT  LHsType GhcPs -> MetaResult
k -> LHsType GhcPs -> MetaResult
GenLocated SrcSpanAnnA (HsType GhcPs) -> MetaResult
k (GenLocated SrcSpanAnnA (HsType GhcPs) -> MetaResult)
-> IOEnv
     (Env TcGblEnv TcLclEnv) (GenLocated SrcSpanAnnA (HsType GhcPs))
-> TcM MetaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) (LHsType GhcPs)
forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f (LHsType GhcPs)
metaRequestT MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h LHsExpr GhcTc
e
      MetaD  [LHsDecl GhcPs] -> MetaResult
k -> do
        [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
res <- MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) [LHsDecl GhcPs]
forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f [LHsDecl GhcPs]
metaRequestD MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h LHsExpr GhcTc
e
        [LHsDecl GhcPs] -> MetaResult
k [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
res MetaResult -> TcM a -> TcM MetaResult
forall a b.
a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [LHsDecl GhcPs] -> TcM a
f [LHsDecl GhcPs]
[GenLocated SrcSpanAnnA (HsDecl GhcPs)]
res
      MetaAW Serialized -> MetaResult
k -> Serialized -> MetaResult
k (Serialized -> MetaResult)
-> IOEnv (Env TcGblEnv TcLclEnv) Serialized -> TcM MetaResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
-> LHsExpr GhcTc -> IOEnv (Env TcGblEnv TcLclEnv) Serialized
forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h LHsExpr GhcTc
e


--
-- File path utils
--

fixFilePath :: RawFilePath
            -- ^ current directory
            -> RawFilePath
            -- ^ tags file directory
            -> RawFilePath
            -- ^ tag's file path
            -> RawFilePath
fixFilePath :: RawFilePath -> RawFilePath -> RawFilePath -> RawFilePath
fixFilePath RawFilePath
cwd RawFilePath
tagsDir =
    RawFilePath -> RawFilePath
normaliseRawFilePath
  (RawFilePath -> RawFilePath)
-> (RawFilePath -> RawFilePath) -> RawFilePath -> RawFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RawFilePath -> RawFilePath -> RawFilePath
makeRelativeRawFilePath RawFilePath
tagsDir
  (RawFilePath -> RawFilePath)
-> (RawFilePath -> RawFilePath) -> RawFilePath -> RawFilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RawFilePath
cwd RawFilePath -> RawFilePath -> RawFilePath
</>)


-- we are missing `Text` based `FilePath` library!
fixTagFilePath :: RawFilePath
               -- ^ current directory
               -> RawFilePath
               -- ^ tags file directory
               -> Tag tk -> Tag tk
fixTagFilePath :: forall (tk :: TAG_KIND).
RawFilePath -> RawFilePath -> Tag tk -> Tag tk
fixTagFilePath RawFilePath
cwd RawFilePath
tagsDir tag :: Tag tk
tag@Tag { tagFilePath :: forall (tk :: TAG_KIND). Tag tk -> TagFilePath
tagFilePath = TagFilePath Text
fp } =
  Tag tk
tag { tagFilePath =
          TagFilePath
            ( Text.decodeUtf8 . rawFilePathToBS
            $ fixFilePath cwd tagsDir
                          (rawFilePathFromBS $ Text.encodeUtf8 fp))
      }

lockFilePath :: FilePath -> FilePath
lockFilePath :: ShowS
lockFilePath String
tagsFile =
    case String -> (String, String)
FilePath.splitFileName String
tagsFile of
      (String
dir, String
name) -> String
dir String -> ShowS
FilePath.</> String
"." String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".lock"

--
-- Error Formatting
--

data MessageSeverity
      = Debug
      | Warning
      | Error

messageDoc :: MessageType -> Maybe Module -> String -> Out.SDoc
messageDoc :: MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
errorType Maybe Module
mb_mod String
errorMessage =
    SDoc
Out.blankLine
      SDoc -> SDoc -> SDoc
$+$
        PprColour -> SDoc -> SDoc
Out.coloured PprColour
PprColour.colBold
          (String -> SDoc
forall doc. IsLine doc => String -> doc
Out.text String
"GhcTagsPlugin: "
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
Out.<> PprColour -> SDoc -> SDoc
Out.coloured PprColour
messageColour (String -> SDoc
forall doc. IsLine doc => String -> doc
Out.text (String -> SDoc) -> String -> SDoc
forall a b. (a -> b) -> a -> b
$ MessageType -> String
forall a. Show a => a -> String
show MessageType
errorType))
      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
        case Maybe Module
mb_mod of
          Just Module
mod_ ->
            PprColour -> SDoc -> SDoc
Out.coloured PprColour
PprColour.colBold (Int -> SDoc -> SDoc
Out.nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> SDoc
forall a. Outputable a => a -> SDoc
Out.ppr Module
mod_)
          Maybe Module
Nothing -> SDoc
forall doc. IsOutput doc => doc
Out.empty
      SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
        (Int -> SDoc -> SDoc
Out.nest Int
8 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ PprColour -> SDoc -> SDoc
Out.coloured PprColour
messageColour (String -> SDoc
forall doc. IsLine doc => String -> doc
Out.text String
errorMessage))
      SDoc -> SDoc -> SDoc
$+$
        SDoc
Out.blankLine
      SDoc -> SDoc -> SDoc
$+$ case MessageSeverity
severity of
        MessageSeverity
Error ->
          PprColour -> SDoc -> SDoc
Out.coloured PprColour
PprColour.colBold (String -> SDoc
forall doc. IsLine doc => String -> doc
Out.text String
"Please report this bug to: ")
            SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
Out.<> String -> SDoc
forall doc. IsLine doc => String -> doc
Out.text String
"https://github.com/coot/ghc-tags-plugin/issues"
          SDoc -> SDoc -> SDoc
$+$ SDoc
Out.blankLine
        MessageSeverity
Warning -> SDoc
Out.blankLine
        MessageSeverity
Debug -> SDoc
Out.blankLine
  where
    severity :: MessageSeverity
severity = case MessageType
errorType of
      MessageType
ReadException       -> MessageSeverity
Error
      MessageType
ParserException     -> MessageSeverity
Error
      MessageType
WriteException      -> MessageSeverity
Error
      MessageType
UnhandledException  -> MessageSeverity
Error
      MessageType
OptionParserFailure -> MessageSeverity
Warning
      MessageType
SizeWarning         -> MessageSeverity
Warning
      MessageType
DebugMessage        -> MessageSeverity
Debug

    messageColour :: PprColour
messageColour = case MessageSeverity
severity of
      MessageSeverity
Error   -> PprColour
PprColour.colRedFg
      MessageSeverity
Warning -> PprColour
PprColour.colBlueFg
      MessageSeverity
Debug   -> PprColour
PprColour.colCyanFg


putDocLn :: DynFlags -> Out.SDoc -> IO ()
putDocLn :: DynFlags -> SDoc -> IO ()
putDocLn DynFlags
_dynFlags SDoc
sdoc =
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
      SDocContext -> SDoc -> String
Out.renderWithContext
        SDocContext
Out.defaultSDocContext { Out.sdocStyle = Out.mkErrStyle Out.neverQualify }
        SDoc
sdoc


printMessageDoc :: DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc :: DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags = (((Maybe Module -> String -> SDoc)
 -> Maybe Module -> String -> IO ())
-> (MessageType -> Maybe Module -> String -> SDoc)
-> MessageType
-> Maybe Module
-> String
-> IO ()
forall a b. (a -> b) -> (MessageType -> a) -> MessageType -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Maybe Module -> String -> SDoc)
  -> Maybe Module -> String -> IO ())
 -> (MessageType -> Maybe Module -> String -> SDoc)
 -> MessageType
 -> Maybe Module
 -> String
 -> IO ())
-> ((SDoc -> IO ())
    -> (Maybe Module -> String -> SDoc)
    -> Maybe Module
    -> String
    -> IO ())
-> (SDoc -> IO ())
-> (MessageType -> Maybe Module -> String -> SDoc)
-> MessageType
-> Maybe Module
-> String
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> SDoc) -> String -> IO ())
-> (Maybe Module -> String -> SDoc)
-> Maybe Module
-> String
-> IO ()
forall a b. (a -> b) -> (Maybe Module -> a) -> Maybe Module -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((String -> SDoc) -> String -> IO ())
 -> (Maybe Module -> String -> SDoc)
 -> Maybe Module
 -> String
 -> IO ())
-> ((SDoc -> IO ()) -> (String -> SDoc) -> String -> IO ())
-> (SDoc -> IO ())
-> (Maybe Module -> String -> SDoc)
-> Maybe Module
-> String
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SDoc -> IO ()) -> (String -> SDoc) -> String -> IO ()
forall a b. (a -> b) -> (String -> a) -> String -> b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags) MessageType -> Maybe Module -> String -> SDoc
messageDoc