{-# 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
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
}
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
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"
(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
$
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
""
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
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
(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)
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
$
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 ()
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
$
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
$
(\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
$
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)
([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
([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)
([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
(Located (HsModule GhcPs) -> [CTag])
-> Located (HsModule GhcPs) -> [CTag]
forall a b. (a -> b) -> a -> b
$ Located (HsModule GhcPs)
lmodule
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))
(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
(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
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')
])
(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')
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
(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
(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
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)
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
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"
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
fixFilePath :: RawFilePath
-> RawFilePath
-> RawFilePath
-> 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.</>)
fixTagFilePath :: RawFilePath
-> RawFilePath
-> 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)))
}
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
#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