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

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

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

import           Control.Exception
import           Control.Monad.State.Strict
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 qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
#if __GLASGOW_HASKELL__ < 808
import           Data.Functor (void, (<$))
#endif
import           Data.Functor.Identity (Identity (..))
import           Data.List (sortBy)
#if __GLASGOW_HASKELL__ >= 810
import           Data.Either (partitionEithers)
#endif
import           Data.Foldable (traverse_)
import           Data.Maybe (mapMaybe)
import           System.Directory
import           System.FilePath
import           System.FilePath.ByteString (RawFilePath)
import qualified System.FilePath.ByteString as FilePath
import           System.IO

#if !defined(mingw32_HOST_OS)
import           Foreign.C.Types (CInt (..))
import           Foreign.C.Error (throwErrnoIfMinus1_)
import           GHC.IO.FD (FD (..))
import           GHC.IO.Handle.FD (handleToFd)
#endif

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

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

#if __GLASGOW_HASKELL__ >= 900
import           GHC.Driver.Plugins
#else
import           GhcPlugins
#endif
                            ( CommandLineOption
                            , Plugin (..)
                            )
#if __GLASGOW_HASKELL__ >= 900
import qualified GHC.Driver.Plugins as GhcPlugins
import           GHC.Driver.Types ( Hsc
                                  , HsParsedModule (..)
                                  , ModSummary (..)
                                  , 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)
#else
import qualified GhcPlugins
import           GhcPlugins ( Hsc
                            , HsParsedModule (..)
                            , Located
                            , Module
                            , ModLocation (..)
                            , ModSummary (..)
#if __GLASGOW_HASKELL__ >= 810
                            , MetaHook
                            , MetaRequest (..)
                            , MetaResult
                            , metaRequestAW
                            , metaRequestD
                            , metaRequestE
                            , metaRequestP
                            , metaRequestT
#endif
                            )
#endif
#if   __GLASGOW_HASKELL__ >= 900
import           GHC.Driver.Session (DynFlags (hooks))
#elif __GLASGOW_HASKELL__ >= 810
import           DynFlags (DynFlags (hooks))
#else
import           DynFlags (DynFlags)
#endif

#if   __GLASGOW_HASKELL__ >= 900
import           GHC.Hs (GhcPs, GhcTc, HsModule (..), LHsDecl, LHsExpr)
#elif __GLASGOW_HASKELL__ >= 810
import           GHC.Hs (GhcPs, GhcTc, HsModule (..), LHsDecl, LHsExpr)
import           TcSplice
import           TcRnMonad
import           Hooks
#else
import           HsExtension (GhcPs)
import           HsSyn (HsModule (..))
#endif
#if __GLASGOW_HASKELL__ >= 900
import           GHC.Utils.Outputable (($+$), ($$))
import qualified GHC.Utils.Outputable as Out
import qualified GHC.Utils.Ppr.Colour as PprColour
#else
import           Outputable (($+$), ($$))
import qualified Outputable as Out
import qualified PprColour
#endif

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__ >= 900
type GhcPsModule = HsModule
#else
type GhcPsModule = HsModule GhcPs
#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 :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
ghcTagsParserPlugin,
#if __GLASGOW_HASKELL__ >= 810
      dynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags
dynflagsPlugin     = [CommandLineOption] -> DynFlags -> IO DynFlags
ghcTagsDynflagsPlugin,
#endif
      pluginRecompile :: [CommandLineOption] -> IO PluginRecompile
pluginRecompile    = [CommandLineOption] -> IO PluginRecompile
GhcPlugins.purePlugin
   }


-- | IOExcption 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 -> CommandLineOption
(Int -> GhcTagsPluginException -> ShowS)
-> (GhcTagsPluginException -> CommandLineOption)
-> ([GhcTagsPluginException] -> ShowS)
-> Show GhcTagsPluginException
forall a.
(Int -> a -> ShowS)
-> (a -> CommandLineOption) -> ([a] -> ShowS) -> Show a
showList :: [GhcTagsPluginException] -> ShowS
$cshowList :: [GhcTagsPluginException] -> ShowS
show :: GhcTagsPluginException -> CommandLineOption
$cshow :: GhcTagsPluginException -> CommandLineOption
showsPrec :: Int -> GhcTagsPluginException -> ShowS
$cshowsPrec :: Int -> 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 :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
ghcTagsParserPlugin [CommandLineOption]
options
                    moduleSummary :: ModSummary
moduleSummary@ModSummary {Module
ms_mod :: ModSummary -> Module
ms_mod :: Module
ms_mod, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dynFlags}
                    hsParsedModule :: HsParsedModule
hsParsedModule@HsParsedModule {Located (HsModule GhcPs)
hpm_module :: HsParsedModule -> Located (HsModule GhcPs)
hpm_module :: Located (HsModule GhcPs)
hpm_module} =

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

           IO () -> Hsc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ do
            let sourceFile :: CommandLineOption
sourceFile = case CommandLineOption -> (CommandLineOption, CommandLineOption)
splitFileName CommandLineOption
tagsFile of
                  (CommandLineOption
dir, CommandLineOption
name) -> CommandLineOption
dir CommandLineOption -> ShowS
</> CommandLineOption
"." CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ CommandLineOption
name
                lockFile :: CommandLineOption
lockFile = CommandLineOption
sourceFile CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ CommandLineOption
".lock"

            -- 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 -> CommandLineOption -> SDoc
messageDoc MessageType
UnhandledException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                                (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
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
$
             (IO () -> IO () -> IO ()) -> IO () -> IO () -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
finally (IO (Either IOException ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Either IOException ()) -> IO ())
-> IO (Either IOException ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ forall a.
Exception IOException =>
IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> IO ()
removeFile CommandLineOption
sourceFile) (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.
                CommandLineOption -> LockMode -> (FD -> IO ()) -> IO ()
forall x. CommandLineOption -> LockMode -> (FD -> IO x) -> IO x
withFileLock CommandLineOption
lockFile 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
<$> CommandLineOption -> IO Integer
getFileSize CommandLineOption
tagsFile
                                      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 (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
                        else Maybe Integer -> IO (Maybe Integer)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Integer
forall a. Maybe a
Nothing
                    Options Identity
-> ModSummary
-> Located (HsModule GhcPs)
-> CommandLineOption
-> IO ()
updateTags Options Identity
opts ModSummary
moduleSummary Located (HsModule GhcPs)
hpm_module CommandLineOption
sourceFile
                    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 <- CommandLineOption -> IO Integer
getFileSize CommandLineOption
tagsFile
                      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
$ IOException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (CommandLineOption -> IOException
userError (CommandLineOption -> IOException)
-> CommandLineOption -> IOException
forall a b. (a -> b) -> a -> b
$ [CommandLineOption] -> CommandLineOption
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
                                    [ CommandLineOption
"tags file '"
                                    , CommandLineOption
tagsFile
                                    , CommandLineOption
"' size shrinked: "
                                    , Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
inSize
                                    , CommandLineOption
"→"
                                    , Integer -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Integer
outSize
                                    ])

        Failure (ParserFailure CommandLineOption -> (ParserHelp, ExitCode, Int)
f)  ->
          IO () -> Hsc ()
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 -> CommandLineOption -> SDoc
messageDoc
                       MessageType
OptionParserFailure
                       (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                       (ParserHelp -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (case CommandLineOption -> (ParserHelp, ExitCode, Int)
f CommandLineOption
"<ghc-tags-plugin>" of (ParserHelp
h, ExitCode
_, Int
_) -> ParserHelp
h)
                         CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" " CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ [CommandLineOption] -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show [CommandLineOption]
options))

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


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


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


-- | Extract tags from a module and update tags file
--
updateTags :: Options Identity
           -> ModSummary
           -> Located GhcPsModule
           -> FilePath
           -> IO ()
updateTags :: Options Identity
-> ModSummary
-> Located (HsModule GhcPs)
-> CommandLineOption
-> IO ()
updateTags Options { Bool
etags :: forall (f :: * -> *). Options f -> Bool
etags :: Bool
etags, filePath :: forall (f :: * -> *). Options f -> f CommandLineOption
filePath = Identity CommandLineOption
tagsFile, Bool
debug :: Bool
debug :: forall (f :: * -> *). Options f -> Bool
debug }
           ModSummary {Module
ms_mod :: Module
ms_mod :: ModSummary -> Module
ms_mod, ModLocation
ms_location :: ModSummary -> ModLocation
ms_location :: ModLocation
ms_location, ms_hspp_opts :: ModSummary -> DynFlags
ms_hspp_opts = DynFlags
dynFlags}
           Located (HsModule GhcPs)
lmodule CommandLineOption
sourceFile = do
  Bool
tagsFileExists <- CommandLineOption -> IO Bool
doesFileExist CommandLineOption
tagsFile
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tagsFileExists
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> CommandLineOption -> IO ()
renameFile CommandLineOption
tagsFile CommandLineOption
sourceFile
  CommandLineOption -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. CommandLineOption -> IOMode -> (Handle -> IO r) -> IO r
withFile CommandLineOption
tagsFile IOMode
WriteMode  ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
writeHandle ->
    CommandLineOption -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. CommandLineOption -> IOMode -> (Handle -> IO r) -> IO r
withFile CommandLineOption
sourceFile IOMode
ReadWriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
readHandle -> do
      ByteString
cwd <- CommandLineOption -> ByteString
BSC.pack (CommandLineOption -> ByteString)
-> IO CommandLineOption -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CommandLineOption
getCurrentDirectory
      -- absolute directory path of the tags file; we need canonical path
      -- (without ".." and ".") to make 'makeRelative' works.
      ByteString
tagsDir <- CommandLineOption -> ByteString
BSC.pack (CommandLineOption -> ByteString)
-> IO CommandLineOption -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandLineOption -> IO CommandLineOption
canonicalizePath ((CommandLineOption, CommandLineOption) -> CommandLineOption
forall a b. (a, b) -> a
fst ((CommandLineOption, CommandLineOption) -> CommandLineOption)
-> (CommandLineOption, CommandLineOption) -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> (CommandLineOption, CommandLineOption)
splitFileName CommandLineOption
tagsFile)

      case (Bool
etags, ModLocation -> Maybe CommandLineOption
ml_hs_file ModLocation
ms_location) of

        --
        -- ctags
        --
        (Bool
False, Maybe CommandLineOption
Nothing)          -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Bool
False, Just CommandLineOption
sourcePath) -> do

          let sourcePathBS :: ByteString
sourcePathBS = Text -> ByteString
Text.encodeUtf8 (CommandLineOption -> Text
Text.pack CommandLineOption
sourcePath)
              -- 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 (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 (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 -> CommandLineOption -> SDoc
messageDoc MessageType
ReadException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
displayException IOException
e))
                | Bool
otherwise      = () -> Producer ByteString (SafeT IO) ()
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
Pipes.hoist forall a.
StateT [CTag] (SafeT IO) a
-> StateT Int (StateT [CTag] (SafeT IO)) 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
Pipes.hoist forall a. SafeT IO a -> StateT [CTag] (SafeT IO) 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 (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 (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 -> CommandLineOption -> SDoc
messageDoc MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
displayException IOException
e)
                  )
                  ((CTag -> Effect (StateT Int (StateT [CTag] (SafeT IO))) ())
 -> Effect (StateT Int (StateT [CTag] (SafeT IO))) ())
-> (CTag -> Effect (StateT Int (StateT [CTag] (SafeT IO))) ())
-> Effect (StateT Int (StateT [CTag] (SafeT IO))) ()
forall a b. (a -> b) -> a -> b
$
                  -- merge tags
                  (\CTag
tag -> do
                    (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
Pipes.hoist forall a.
StateT [CTag] (SafeT IO) a
-> StateT Int (StateT [CTag] (SafeT IO)) 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)
-> ByteString
-> CTag
-> Proxy X () () X (StateT [CTag] (SafeT IO)) ()
forall (m :: * -> *) (tk :: TAG_KIND).
MonadIO m =>
Handle
-> (Tag tk -> Tag tk -> Ordering)
-> (Tag tk -> Builder)
-> ByteString
-> Tag tk
-> Effect (StateT [Tag tk] m) ()
runCombineTagsPipe Handle
writeHandle
                          CTag -> CTag -> Ordering
CTag.compareTags
                          CTag -> Builder
CTag.formatTag
                          (ByteString -> ByteString -> ByteString -> ByteString
fixFilePath ByteString
cwd ByteString
tagsDir ByteString
sourcePathBS)
                          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 (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 (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 -> CommandLineOption -> SDoc
messageDoc MessageType
WriteException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
displayException IOException
e)
                  )

          let tags :: [CTag]
              tags :: [CTag]
tags = (CTag -> CTag) -> [CTag] -> [CTag]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> CTag -> CTag
forall (tk :: TAG_KIND).
ByteString -> ByteString -> Tag tk -> Tag tk
fixTagFilePath ByteString
cwd ByteString
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 (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
          -- hDataSync is necessary, otherwise next read will not get all the
          -- data, and the tags file will get truncated. Issue #37.
          Handle -> IO ()
hDataSync 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
$ DynFlags
-> MessageType -> Maybe Module -> CommandLineOption -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
DebugMessage (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                ([CommandLineOption] -> CommandLineOption
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ CommandLineOption
"parsed: "
                        , Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show Int
parsedTags
                        , CommandLineOption
" found: "
                        , Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show ([CTag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTag]
tags)
                        , CommandLineOption
" left: "
                        , Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show ([CTag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CTag]
tags')
                        ])

        --
        -- etags
        --
        (Bool
True, Maybe CommandLineOption
Nothing)         -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        (Bool
True, Just CommandLineOption
sourcePath) ->
          IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (Handle -> IO ByteString
BS.hGetContents Handle
readHandle)
            IO (Either IOException ByteString)
-> (Either IOException ByteString -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Left IOException
err ->
                DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> CommandLineOption -> SDoc
messageDoc MessageType
ReadException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
displayException IOException
err)

              Right ByteString
txt -> do
                Either IOException (Either CommandLineOption [ETag])
pres <- forall a.
Exception IOException =>
IO a -> IO (Either IOException a)
forall e a. Exception e => IO a -> IO (Either e a)
try @IOException (IO (Either CommandLineOption [ETag])
 -> IO (Either IOException (Either CommandLineOption [ETag])))
-> IO (Either CommandLineOption [ETag])
-> IO (Either IOException (Either CommandLineOption [ETag]))
forall a b. (a -> b) -> a -> b
$ ByteString -> IO (Either CommandLineOption [ETag])
ETag.parseTagsFile ByteString
txt
                case Either IOException (Either CommandLineOption [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 -> CommandLineOption -> SDoc
messageDoc MessageType
ParserException (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod) (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
displayException IOException
err)

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

                  Right (Right [ETag]
tags) -> do
                    let sourcePathBS :: ByteString
sourcePathBS = Text -> ByteString
Text.encodeUtf8 (CommandLineOption -> Text
Text.pack CommandLineOption
sourcePath)

                        newTags  :: [ETag]
                        newTags :: [ETag]
newTags =
                            [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 (ByteString -> ByteString -> ETag -> ETag
forall (tk :: TAG_KIND).
ByteString -> ByteString -> Tag tk -> Tag tk
fixTagFilePath ByteString
cwd ByteString
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

                        tags' :: [ETag]
                        tags' :: [ETag]
tags' = (ETag -> ETag -> Ordering)
-> ByteString -> [ETag] -> [ETag] -> [ETag]
forall (tk :: TAG_KIND).
(Tag tk -> Tag tk -> Ordering)
-> ByteString -> [Tag tk] -> [Tag tk] -> [Tag tk]
combineTags
                                  ETag -> ETag -> Ordering
ETag.compareTags
                                  (ByteString -> ByteString -> ByteString -> ByteString
fixFilePath ByteString
cwd ByteString
tagsDir ByteString
sourcePathBS)
                                  [ETag]
newTags
                                  ((ETag -> ETag -> Ordering) -> [ETag] -> [ETag]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ETag -> ETag -> Ordering
ETag.compareTags [ETag]
tags)

                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug
                      (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ DynFlags
-> MessageType -> Maybe Module -> CommandLineOption -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
DebugMessage (Module -> Maybe Module
forall a. a -> Maybe a
Just Module
ms_mod)
                          ([CommandLineOption] -> CommandLineOption
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ CommandLineOption
"parsed: "
                                  , Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show ([ETag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ETag]
tags)
                                  , CommandLineOption
" found: "
                                  , Int -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show ([ETag] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ETag]
newTags)
                                  ])

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


-- | Filter adjacent tags.
--
filterAdjacentTags :: [Tag tk] -> [Tag tk]
filterAdjacentTags :: [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 (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 tk
TkTypeSignature <- Tag tk -> TagKind tk
forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind Tag tk
p
                         , TagKind tk
k <- Tag tk -> TagKind tk
forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind Tag tk
c
                         , TagKind tk
k TagKind tk -> TagKind tk -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind tk
TagKind 'CTAG
TkTerm
                        Bool -> Bool -> Bool
|| TagKind tk
k TagKind tk -> TagKind tk -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind tk
TagKind 'CTAG
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 tk
TkTypeConstructor <- Tag tk -> TagKind tk
forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind Tag tk
c
                         , TagKind tk
k <- Tag tk -> TagKind tk
forall (tk :: TAG_KIND). Tag tk -> TagKind tk
tagKind Tag tk
n
                         , TagKind tk
k TagKind tk -> TagKind tk -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind tk
TagKind 'CTAG
TkDataConstructor
                        Bool -> Bool -> Bool
|| TagKind tk
k TagKind tk -> TagKind tk -> Bool
forall a. Eq a => a -> a -> Bool
== TagKind tk
TagKind 'CTAG
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. [a] -> [a]
init [Tag tk]
tags)

    -- next
    tags'' :: [Maybe (Tag tk)]
tags'' = case [Tag tk]
tags of
      [] -> []
      [Tag tk]
_  -> (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. [a] -> [a]
tail [Tag tk]
tags) [Maybe (Tag tk)] -> [Maybe (Tag tk)] -> [Maybe (Tag tk)]
forall a. [a] -> [a] -> [a]
++ [Maybe (Tag tk)
forall a. Maybe a
Nothing]


#if __GLASGOW_HASKELL__ >= 810
--
-- Tags for Template-Haskell splices
--

-- | DynFlags plugin which extract tags from TH splices.
--
ghcTagsDynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags
ghcTagsDynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags
ghcTagsDynflagsPlugin [CommandLineOption]
options DynFlags
dynFlags =
    DynFlags -> IO DynFlags
forall (f :: * -> *) a. Applicative f => a -> f a
pure DynFlags
dynFlags
      { hooks :: Hooks
hooks =
          (DynFlags -> Hooks
hooks DynFlags
dynFlags)
            { runMetaHook :: Maybe (MetaHook TcM)
runMetaHook = MetaHook TcM -> Maybe (MetaHook TcM)
forall a. a -> Maybe a
Just MetaHook TcM
ghcTagsMetaHook }
      }
  where
    ghcTagsMetaHook :: MetaHook TcM
    ghcTagsMetaHook :: MetaHook TcM
ghcTagsMetaHook MetaRequest
request LHsExpr GhcTc
expr =
      case [CommandLineOption] -> ParserResult (Options Identity)
runOptionParser [CommandLineOption]
options of
        Success Options { filePath :: forall (f :: * -> *). Options f -> f CommandLineOption
filePath = Identity CommandLineOption
tagsFile
                        , Bool
etags :: Bool
etags :: forall (f :: * -> *). Options f -> Bool
etags
                        } -> do
          let sourceFile :: CommandLineOption
sourceFile = case CommandLineOption -> (CommandLineOption, CommandLineOption)
splitFileName CommandLineOption
tagsFile of
                (CommandLineOption
dir, CommandLineOption
name) -> CommandLineOption
dir CommandLineOption -> ShowS
</> CommandLineOption
"." CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ CommandLineOption
name
              lockFile :: CommandLineOption
lockFile = CommandLineOption
sourceFile CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ CommandLineOption
".lock"

          MetaHook TcM
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM ())
-> TcM MetaResult
forall a.
MetaHook TcM
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM a)
-> TcM MetaResult
withMetaD MetaHook TcM
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 (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 -> CommandLineOption -> SDoc
messageDoc MessageType
UnhandledException Maybe Module
forall a. Maybe a
Nothing
                                 (IOException -> CommandLineOption
forall e. Exception e => e -> CommandLineOption
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
$
              CommandLineOption -> LockMode -> (FD -> IO ()) -> IO ()
forall x. CommandLineOption -> LockMode -> (FD -> IO x) -> IO x
withFileLock CommandLineOption
lockFile LockMode
ExclusiveLock ((FD -> IO ()) -> IO ()) -> (FD -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FD
_ -> do
              ByteString
cwd <- CommandLineOption -> ByteString
BSC.pack (CommandLineOption -> ByteString)
-> IO CommandLineOption -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO CommandLineOption
getCurrentDirectory
              ByteString
tagsDir <- CommandLineOption -> ByteString
BSC.pack (CommandLineOption -> ByteString)
-> IO CommandLineOption -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandLineOption -> IO CommandLineOption
canonicalizePath ((CommandLineOption, CommandLineOption) -> CommandLineOption
forall a b. (a, b) -> a
fst ((CommandLineOption, CommandLineOption) -> CommandLineOption)
-> (CommandLineOption, CommandLineOption) -> CommandLineOption
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> (CommandLineOption, CommandLineOption)
splitFileName CommandLineOption
tagsFile)
              ByteString
tagsContent <- CommandLineOption -> IO ByteString
BSC.readFile CommandLineOption
tagsFile
              if Bool
etags
                then do
                  Either CommandLineOption [ETag]
pr <- ByteString -> IO (Either CommandLineOption [ETag])
ETag.parseTagsFile ByteString
tagsContent
                  case Either CommandLineOption [ETag]
pr of
                    Left CommandLineOption
err ->
                      DynFlags
-> MessageType -> Maybe Module -> CommandLineOption -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
ParserException Maybe Module
forall a. Maybe a
Nothing CommandLineOption
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString -> ETag -> ETag
forall (tk :: TAG_KIND).
ByteString -> ByteString -> Tag tk -> Tag tk
fixTagFilePath  ByteString
cwd ByteString
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
                      CommandLineOption -> ByteString -> IO ()
BSL.writeFile CommandLineOption
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 CommandLineOption ([Header], [CTag])
pr <- ([Either Header CTag] -> ([Header], [CTag]))
-> Either CommandLineOption [Either Header CTag]
-> Either CommandLineOption ([Header], [CTag])
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 CommandLineOption [Either Header CTag]
 -> Either CommandLineOption ([Header], [CTag]))
-> IO (Either CommandLineOption [Either Header CTag])
-> IO (Either CommandLineOption ([Header], [CTag]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> IO (Either CommandLineOption [Either Header CTag])
CTag.parseTagsFile ByteString
tagsContent
                  case Either CommandLineOption ([Header], [CTag])
pr of
                    Left CommandLineOption
err ->
                      DynFlags
-> MessageType -> Maybe Module -> CommandLineOption -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
ParserException Maybe Module
forall a. Maybe a
Nothing CommandLineOption
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> ByteString -> CTag -> CTag
forall (tk :: TAG_KIND).
ByteString -> ByteString -> Tag tk -> Tag tk
fixTagFilePath  ByteString
cwd ByteString
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
                                  )
                      CommandLineOption -> ByteString -> IO ()
BSL.writeFile CommandLineOption
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 CommandLineOption -> (ParserHelp, ExitCode, Int)
f)  ->
          MetaHook TcM
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM ())
-> TcM MetaResult
forall a.
MetaHook TcM
-> MetaRequest
-> LHsExpr GhcTc
-> ([LHsDecl GhcPs] -> TcM a)
-> TcM MetaResult
withMetaD MetaHook TcM
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 (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 -> CommandLineOption -> SDoc
messageDoc
                       MessageType
OptionParserFailure
                       Maybe Module
forall a. Maybe a
Nothing
                       (ParserHelp -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show (case CommandLineOption -> (ParserHelp, ExitCode, Int)
f CommandLineOption
"<ghc-tags-plugin>" of (ParserHelp
h, ExitCode
_, Int
_) -> ParserHelp
h)
                         CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ CommandLineOption
" " CommandLineOption -> ShowS
forall a. [a] -> [a] -> [a]
++ [CommandLineOption] -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show [CommandLineOption]
options))

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

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


--
-- File path utils
--

fixFilePath :: RawFilePath
            -- ^ curent directory
            -> RawFilePath
            -- ^ tags file directory
            -> RawFilePath
            -- ^ tag's file path
            -> RawFilePath
fixFilePath :: ByteString -> ByteString -> ByteString -> ByteString
fixFilePath ByteString
cwd ByteString
tagsDir =
    ByteString -> ByteString
FilePath.normalise
  (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
FilePath.makeRelative ByteString
tagsDir
  (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString
cwd ByteString -> ByteString -> ByteString
FilePath.</>)


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

--
-- Error Formattng
--

data MessageSeverity
      = Debug
      | Warning
      | Error

messageDoc :: MessageType -> Maybe Module -> String -> Out.SDoc
messageDoc :: MessageType -> Maybe Module -> CommandLineOption -> SDoc
messageDoc MessageType
errorType Maybe Module
mb_mod CommandLineOption
errorMessage =
    SDoc
Out.blankLine
      SDoc -> SDoc -> SDoc
$+$
        PprColour -> SDoc -> SDoc
Out.coloured PprColour
PprColour.colBold
          ((CommandLineOption -> SDoc
Out.text CommandLineOption
"GhcTagsPlugin: ")
            SDoc -> SDoc -> SDoc
Out.<> (PprColour -> SDoc -> SDoc
Out.coloured PprColour
messageColour (CommandLineOption -> SDoc
Out.text (CommandLineOption -> SDoc) -> CommandLineOption -> SDoc
forall a b. (a -> b) -> a -> b
$ MessageType -> CommandLineOption
forall a. Show a => a -> CommandLineOption
show MessageType
errorType)))
      SDoc -> SDoc -> SDoc
$$
        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
Out.empty
      SDoc -> SDoc -> SDoc
$$
        (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 (CommandLineOption -> SDoc
Out.text CommandLineOption
errorMessage))
      SDoc -> SDoc -> SDoc
$+$
        SDoc
Out.blankLine
      SDoc -> SDoc -> SDoc
$+$ case MessageSeverity
severity of
        MessageSeverity
Error ->
          PprColour -> SDoc -> SDoc
Out.coloured PprColour
PprColour.colBold (CommandLineOption -> SDoc
Out.text CommandLineOption
"Please report this bug to: ")
            SDoc -> SDoc -> SDoc
Out.<> CommandLineOption -> SDoc
Out.text CommandLineOption
"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
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 =
    CommandLineOption -> IO ()
putStrLn (CommandLineOption -> IO ()) -> CommandLineOption -> IO ()
forall a b. (a -> b) -> a -> b
$
#if __GLASGOW_HASKELL__ >= 900
      Out.renderWithStyle
        (Out.initSDocContext
          dynFlags
          (Out.setStyleColoured False
            $ Out.mkErrStyle Out.neverQualify))
        sdoc
#else
      DynFlags -> SDoc -> PprStyle -> CommandLineOption
Out.renderWithStyle
        DynFlags
dynFlags
        SDoc
sdoc
        (Bool -> PprStyle -> PprStyle
Out.setStyleColoured Bool
True (PprStyle -> PprStyle) -> PprStyle -> PprStyle
forall a b. (a -> b) -> a -> b
$ DynFlags -> PprStyle
Out.defaultErrStyle DynFlags
dynFlags)
#endif


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

--
-- Syscalls
--

#if !defined(mingw32_HOST_OS)
hDataSync ::  Handle -> IO ()
hDataSync :: Handle -> IO ()
hDataSync Handle
h = do
    FD { CInt
fdFD :: FD -> CInt
fdFD :: CInt
fdFD } <- Handle -> IO FD
handleToFd Handle
h
    CommandLineOption -> IO CInt -> IO ()
forall a. (Eq a, Num a) => CommandLineOption -> IO a -> IO ()
throwErrnoIfMinus1_ CommandLineOption
"ghc-tags-plugin" (CInt -> IO CInt
c_fdatasync CInt
fdFD)

foreign import ccall safe "fdatasync"
    c_fdatasync :: CInt -> IO CInt
#else
hDataSync :: Handle -> IO ()
hDataSync _ = pure ()
#endif