{-# 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.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
import           Data.Functor.Identity (Identity (..))
import           Data.List (sortBy)
#if __GLASGOW_HASKELL__ < 810
import           Data.Either (rights)
#else
import           Data.Either (partitionEithers, rights)
#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

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

import qualified Pipes
import           Pipes.Safe (SafeT)
import qualified 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
#if    __GLASGOW_HASKELL__ >= 902
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
                                  )
#else
import           GHC.Driver.Types ( Hsc
                                  , HsParsedModule (..)
                                  , ModSummary (..)
                                  , MetaHook
                                  , MetaRequest (..)
                                  , MetaResult
                                  , metaRequestAW
                                  , metaRequestD
                                  , metaRequestE
                                  , metaRequestP
                                  , metaRequestT
                                  )
#endif
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)
#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
                            )
import qualified SrcLoc as GHC (SrcSpan (..), getLoc, srcSpanFile)
#endif
#if   __GLASGOW_HASKELL__ >= 902
import           GHC.Driver.Session (DynFlags)
#elif __GLASGOW_HASKELL__ >= 900
import           GHC.Driver.Session (DynFlags (DynFlags, hooks))
#elif __GLASGOW_HASKELL__ >= 810
import           DynFlags (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
#if   __GLASGOW_HASKELL__ >= 900
import           GHC.Data.FastString (bytesFS)
#elif __GLASGOW_HASKELL__ >= 810
import           FastString          (bytesFS)
#else
import           FastString          (FastString (fs_bs))
#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__ < 810
bytesFS :: FastString -> ByteString
bytesFS = fs_bs
#endif

#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 :: [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction =
#if   __GLASGOW_HASKELL__ >= 904
      -- TODO: add warnings / errors to 'ParsedResult'
       \args summary result@GhcPlugins.ParsedResult { GhcPlugins.parsedResultModule } ->
                     result <$ ghcTagsParserPlugin args summary parsedResultModule,
#else
        [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
ghcTagsParserPlugin,
#endif
#if   __GLASGOW_HASKELL__ >= 902
      driverPlugin :: [String] -> HscEnv -> IO HscEnv
driverPlugin       = [String] -> HscEnv -> IO HscEnv
ghcTagsDriverPlugin,
#elif __GLASGOW_HASKELL__ >= 810
      dynflagsPlugin     = ghcTagsDynflagsPlugin,
#endif
      pluginRecompile :: [String] -> IO PluginRecompile
pluginRecompile    = [String] -> IO 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GhcTagsPluginException] -> ShowS
$cshowList :: [GhcTagsPluginException] -> ShowS
show :: GhcTagsPluginException -> String
$cshow :: GhcTagsPluginException -> String
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 :: [String] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
ghcTagsParserPlugin [String]
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
hpm_module :: HsParsedModule -> Located HsModule
hpm_module :: Located HsModule
hpm_module} =

    HsParsedModule
hsParsedModule 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 :: forall (f :: * -> *). Options f -> Bool
debug :: Bool
debug
                             } ->

           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
            -- wrap 'IOException's
            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 (forall a. a -> Maybe a
Just Module
ms_mod)
                                (forall e. Exception e => e -> String
displayException IOException
ioerr))
                     forall e a. Exception e => e -> IO a
throwIO (IOException -> GhcTagsPluginException
GhcTagsParserPluginIOException IOException
ioerr)) forall a b. (a -> b) -> a -> b
$

                let lockFile :: String
lockFile = case String -> (String, String)
splitFileName String
tagsFile of
                      (String
dir, String
name) -> String
dir String -> ShowS
</> String
"." forall a. [a] -> [a] -> [a]
++ String
name forall a. [a] -> [a] -> [a]
++ String
".lock" in
                -- 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.
                forall x. Bool -> String -> LockMode -> (FD -> IO x) -> IO x
withFileLock Bool
debug String
lockFile LockMode
ExclusiveLock forall a b. (a -> b) -> a -> b
$ \FD
_ -> do
                    Maybe Integer
mbInSize <-
                      if Bool
debug
                        then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Integer
getFileSize String
tagsFile
                                      forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
                        else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
                    Options Identity -> ModSummary -> Located HsModule -> IO ()
updateTags Options Identity
opts ModSummary
moduleSummary Located HsModule
hpm_module
                    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ do
                      let Just Integer
inSize = Maybe Integer
mbInSize
                      Integer
outSize <- String -> IO Integer
getFileSize String
tagsFile
                      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
inSize forall a. Ord a => a -> a -> Bool
> Integer
outSize)
                        forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                        forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                            (MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
SizeWarning
                                        (forall a. a -> Maybe a
Just Module
ms_mod)
                                        (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ forall a. Show a => a -> String
show Integer
inSize
                                                , String
"→"
                                                , forall a. Show a => a -> String
show Integer
outSize
                                                ]))

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

        CompletionInvoked {} -> 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 -> IO ()
updateTags Options { Bool
etags :: forall (f :: * -> *). Options f -> Bool
etags :: Bool
etags, Bool
stream :: forall (f :: * -> *). Options f -> Bool
stream :: Bool
stream, filePath :: forall (f :: * -> *). Options f -> f String
filePath = Identity String
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
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
      Bool
tagsFileExists <- String -> IO Bool
doesFileExist String
tagsFile
      let destFile :: String
destFile = case String -> (String, String)
splitFileName String
tagsFile of
            (String
dir, String
name) -> String
dir String -> ShowS
</> String
"." forall a. [a] -> [a] -> [a]
++ String
name

      Maybe Integer
mbInSize <-
        if Bool
debug
          then
            if Bool
tagsFileExists
              then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Integer
getFileSize String
tagsFile
                        forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(IOException
_ :: IOException) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Integer
0
              else forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just Integer
0)
          else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

      forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
destFile IOMode
WriteMode  forall a b. (a -> b) -> a -> b
$ \Handle
writeHandle ->
        forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withFile String
tagsFile IOMode
ReadWriteMode forall a b. (a -> b) -> a -> b
$ \Handle
readHandle -> do
          ByteString
cwd <- String -> ByteString
BSC.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
          -- absolute directory path of the tags file; we need canonical path
          -- (without ".." and ".") to make 'makeRelative' works.
          ByteString
tagsDir <- String -> ByteString
BSC.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
canonicalizePath (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitFileName String
tagsFile)
          case ModLocation -> Maybe String
ml_hs_file ModLocation
ms_location of
            Maybe String
Nothing         -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just String
sourcePath -> do
              let sourcePathBS :: ByteString
sourcePathBS = 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 :: ByteString
modulePath =
                    case forall l e. GenLocated l e -> l
GHC.getLoc Located HsModule
lmodule of
#if __GLASGOW_HASKELL__ >= 900
                      GHC.RealSrcSpan RealSrcSpan
rss Maybe BufSpan
_ ->
#else
                      GHC.RealSrcSpan rss ->
#endif
                          FastString -> ByteString
bytesFS
                        forall b c a. (b -> c) -> (a -> b) -> a -> c
. RealSrcSpan -> FastString
GHC.srcSpanFile
                        forall a b. (a -> b) -> a -> b
$ RealSrcSpan
rss
                      GHC.UnhelpfulSpan {} ->
                        ByteString -> ByteString -> ByteString -> ByteString
fixFilePath ByteString
cwd ByteString
tagsDir ByteString
sourcePathBS
                  -- text parser
                  producer :: Pipes.Producer ByteString (SafeT IO) ()
                  producer :: Producer ByteString (SafeT IO) ()
producer
                    | Bool
tagsFileExists =
                        forall (f :: * -> *) a. Functor f => f a -> f ()
void (forall (m :: * -> *).
MonadIO m =>
Handle -> Producer' ByteString m ()
Pipes.BS.fromHandle Handle
readHandle)
                        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) ->
                          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
Pipes.liftIO 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 (forall a. a -> Maybe a
Just Module
ms_mod) (forall e. Exception e => e -> String
displayException IOException
e))
                    | Bool
otherwise      = 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 =
                    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 {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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift forall a b. (a -> b) -> a -> b
$ 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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift (forall (m :: * -> *) (tk :: TAG_KIND).
MonadIO m =>
Parser (Maybe (Tag tk))
-> Producer ByteString m () -> Producer (Tag tk) m ()
tagParser (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Either Header CTag)
CTag.parseTagLine) Producer ByteString (SafeT IO) ()
producer)
                        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) ->
                          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
Pipes.liftIO 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 forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ParserException (forall a. a -> Maybe a
Just Module
ms_mod) (forall e. Exception e => e -> String
displayException IOException
e)
                      )
                      -- merge tags
                      (\CTag
tag -> do
                        -- update tags counter
                        forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a. Enum a => a -> a
succ
                        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 (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift forall a b. (a -> b) -> a -> b
$
                            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
modulePath
                              CTag
tag
                          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) ->
                            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Pipes.lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
Pipes.liftIO 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 forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
WriteException (forall a. a -> Maybe a
Just Module
ms_mod) (forall e. Exception e => e -> String
displayException IOException
e)
                      )

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

              -- Write header
              Handle -> ByteString -> IO ()
BSL.hPut Handle
writeHandle (Builder -> ByteString
BB.toLazyByteString (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') <- forall (m :: * -> *) r.
(MonadMask m, MonadIO m) =>
SafeT m r -> m r
Pipes.Safe.runSafeT forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
execStateT (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'
              forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (Handle -> ByteString -> IO ()
BSL.hPut Handle
writeHandle forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BB.toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. CTag -> Builder
CTag.formatTag) [CTag]
tags'

              Handle -> IO ()
hFlush Handle
writeHandle

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


    --
    -- update ctags (non streaming)
    --
    updateCTags :: IO ()
updateCTags = do
      Bool
tagsFileExists <- String -> IO Bool
doesFileExist String
tagsFile

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

            Either IOException (Either String [Either Header CTag])
pres <- forall e a. Exception e => IO a -> IO (Either e a)
try @IOException 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 forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ParserException (forall a. a -> Maybe a
Just Module
ms_mod) (forall e. Exception e => e -> String
displayException IOException
err)

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

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

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

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

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

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


    --
    -- update etags file
    --
    updateETags :: IO ()
updateETags = do
      Bool
tagsFileExists <- String -> IO Bool
doesFileExist String
tagsFile

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

          case ModLocation -> Maybe String
ml_hs_file ModLocation
ms_location of
            Maybe String
Nothing         -> 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 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 forall a b. (a -> b) -> a -> b
$ MessageType -> Maybe Module -> String -> SDoc
messageDoc MessageType
ParserException (forall a. a -> Maybe a
Just Module
ms_mod) (forall e. Exception e => e -> String
displayException IOException
err)

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

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

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

                      combined :: [ETag]
                      combined :: [ETag]
combined = 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]
tags
                                   (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ETag -> ETag -> Ordering
ETag.compareTags [ETag]
tags)

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

                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug forall a b. (a -> b) -> a -> b
$ do
                    Integer
outSize <- String -> IO Integer
getFileSize String
tagsFile
                    let Just Integer
inSize = Maybe Integer
mbInSize
                    DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags MessageType
DebugMessage (forall a. a -> Maybe a
Just Module
ms_mod)
                      (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ String
"parsed: "
                              , forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ETag]
parsedTags)
                              , String
" found: "
                              , forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ETag]
tags)
                              , String
" in-size: "
                              , forall a. Show a => a -> String
show Integer
inSize
                              , String
" out-size: "
                              , 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 =
    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)
_)  | forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
p forall a. Eq a => a -> a -> Bool
== forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
c
                         , TagKind
TkTypeSignature <- forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
p
                         , TagKind
k <- forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
c
                         , TagKind
k forall a. Eq a => a -> a -> Bool
== TagKind
TkTerm
                        Bool -> Bool -> Bool
|| TagKind
k 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)  | forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
c forall a. Eq a => a -> a -> Bool
== forall (tk :: TAG_KIND). Tag tk -> TagName
tagName Tag tk
n
                         , TagKind
TkTypeConstructor <- forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
c
                         , TagKind
k <- forall (tk :: TAG_KIND). Tag tk -> TagKind
tagKind Tag tk
n
                         , TagKind
k forall a. Eq a => a -> a -> Bool
== TagKind
TkDataConstructor
                        Bool -> Bool -> Bool
|| TagKind
k forall a. Eq a => a -> a -> Bool
== TagKind
TkGADTConstructor
                        ->     [Tag tk]
acc

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

      )
      []
      (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]
_  -> forall a. Maybe a
Nothing forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just (forall a. [a] -> [a]
init [Tag tk]
tags)

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


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

#if __GLASGOW_HASKELL__ >= 902
ghcTagsDriverPlugin :: [CommandLineOption] -> HscEnv -> IO HscEnv
ghcTagsDriverPlugin :: [String] -> HscEnv -> IO HscEnv
ghcTagsDriverPlugin [String]
opts env :: HscEnv
env@HscEnv{ Hooks
hsc_hooks :: HscEnv -> Hooks
hsc_hooks :: 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)
    forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
env { hsc_hooks :: Hooks
hsc_hooks = Hooks
hsc_hooks { runMetaHook :: Maybe (MetaHook (IOEnv (Env TcGblEnv TcLclEnv)))
runMetaHook = forall a. a -> Maybe a
Just MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
hook } }
#else
ghcTagsDynflagsPlugin :: [CommandLineOption] -> DynFlags -> IO DynFlags
ghcTagsDynflagsPlugin options dynFlags@DynFlags { hooks } = do
    let hook = ghcTagsMetaHook options dynFlags
    return dynFlags { hooks = hooks { runMetaHook = Just hook } }

#endif

-- | 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 :: Bool
etags :: forall (f :: * -> *). Options f -> Bool
etags
                      , Bool
debug :: Bool
debug :: forall (f :: * -> *). Options f -> Bool
debug
                      } -> do

        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 forall a b. (a -> b) -> a -> b
$ \[LHsDecl GhcPs]
decls ->
          forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
            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 forall a. Maybe a
Nothing
                               (forall e. Exception e => e -> String
displayException IOException
ioerr))
                     forall e a. Exception e => e -> IO a
throwIO (IOException -> GhcTagsPluginException
GhcTagsDynFlagsPluginIOException IOException
ioerr)) forall a b. (a -> b) -> a -> b
$
            forall x. Bool -> String -> LockMode -> (FD -> IO x) -> IO x
withFileLock Bool
debug String
tagsFile LockMode
ExclusiveLock forall a b. (a -> b) -> a -> b
$ \FD
_ -> do
            ByteString
cwd <- String -> ByteString
BSC.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO String
getCurrentDirectory
            ByteString
tagsDir <- String -> ByteString
BSC.pack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO String
canonicalizePath (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ String -> (String, String)
splitFileName String
tagsFile)
            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 forall a. Maybe a
Nothing String
err

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

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

      Failure (ParserFailure String -> (ParserHelp, ExitCode, Int)
f)  ->
        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 forall a b. (a -> b) -> a -> b
$ \[LHsDecl GhcPs]
_ ->
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          DynFlags -> SDoc -> IO ()
putDocLn DynFlags
dynFlags
                   (MessageType -> Maybe Module -> String -> SDoc
messageDoc
                     MessageType
OptionParserFailure
                     forall a. Maybe a
Nothing
                     (forall a. Show a => a -> String
show (case String -> (ParserHelp, ExitCode, Int)
f String
"<ghc-tags-plugin>" of (ParserHelp
h, ExitCode
_, Int
_) -> ParserHelp
h)
                       forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [String]
options))

      CompletionInvoked {} -> 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
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- 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 [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
res forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [LHsDecl GhcPs] -> TcM a
f [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
res
      MetaAW Serialized -> MetaResult
k -> Serialized -> MetaResult
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *).
Functor f =>
MetaHook f -> LHsExpr GhcTc -> f Serialized
metaRequestAW MetaHook (IOEnv (Env TcGblEnv TcLclEnv))
h LHsExpr GhcTc
e
#endif


--
-- File path utils
--

fixFilePath :: RawFilePath
            -- ^ current 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
  forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> ByteString
FilePath.makeRelative ByteString
tagsDir
  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 :: forall (tk :: TAG_KIND).
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 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
Out.text String
"GhcTagsPlugin: "
            SDoc -> SDoc -> SDoc
Out.<> PprColour -> SDoc -> SDoc
Out.coloured PprColour
messageColour (String -> SDoc
Out.text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
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 forall a b. (a -> b) -> a -> b
$ 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 forall a b. (a -> b) -> a -> b
$ PprColour -> SDoc -> SDoc
Out.coloured PprColour
messageColour (String -> SDoc
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
Out.text String
"Please report this bug to: ")
            SDoc -> SDoc -> SDoc
Out.<> String -> SDoc
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 ()
#if   __GLASGOW_HASKELL__ >= 902
putDocLn :: DynFlags -> SDoc -> IO ()
putDocLn DynFlags
_dynFlags SDoc
sdoc =
#else
putDocLn  dynFlags sdoc =
#endif
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$
#if   __GLASGOW_HASKELL__ >= 902
      SDocContext -> SDoc -> String
Out.renderWithContext
        SDocContext
Out.defaultSDocContext { sdocStyle :: PprStyle
Out.sdocStyle = PrintUnqualified -> PprStyle
Out.mkErrStyle PrintUnqualified
Out.neverQualify }
        SDoc
sdoc
#elif __GLASGOW_HASKELL__ >= 900
      Out.renderWithStyle
        (Out.initSDocContext
          dynFlags
          (Out.setStyleColoured False
            $ Out.mkErrStyle Out.neverQualify))
        sdoc
#else
      Out.renderWithStyle
        dynFlags
        sdoc
        (Out.setStyleColoured True $ Out.defaultErrStyle dynFlags)
#endif


printMessageDoc :: DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc :: DynFlags -> MessageType -> Maybe Module -> String -> IO ()
printMessageDoc DynFlags
dynFlags = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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