{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-}
module Test.DocTest.Internal.Extract (Module(..), extract) where

import           Prelude hiding (mod, concat)
import           Control.Monad
import           Control.Exception
import           Data.List (partition)
import           Data.Maybe

import           Control.DeepSeq (deepseq, NFData(rnf))
import           Data.Generics

#if __GLASGOW_HASKELL__ < 900
import           GHC hiding (Module, Located)
import           DynFlags
import           MonadUtils (liftIO)
#else
import           GHC hiding (Module, Located)
import           GHC.Driver.Session
import           GHC.Utils.Monad (liftIO)
#endif

#if __GLASGOW_HASKELL__ < 900
import           Digraph (flattenSCCs)
import           Exception (ExceptionMonad)
#else
import           GHC.Data.Graph.Directed (flattenSCCs)
import           GHC.Utils.Exception (ExceptionMonad)
import           Control.Monad.Catch (generalBracket)
#endif

import           System.Directory
import           System.FilePath

#if __GLASGOW_HASKELL__ < 805
import           FastString (unpackFS)
#endif

import           System.Posix.Internals (c_getpid)

import           Test.DocTest.Internal.GhcUtil (withGhc)
import           Test.DocTest.Internal.Location hiding (unLoc)
import           Test.DocTest.Internal.Util (convertDosLineEndings)

#if __GLASGOW_HASKELL__ >= 806
#if __GLASGOW_HASKELL__ < 900
import           DynamicLoading (initializePlugins)
#else
import           GHC.Runtime.Loader (initializePlugins)
#endif
#endif

-- | A wrapper around `SomeException`, to allow for a custom `Show` instance.
newtype ExtractError = ExtractError SomeException
  deriving Typeable

instance Show ExtractError where
  show :: ExtractError -> String
show (ExtractError SomeException
e) =
    [String] -> String
unlines [
        String
"Ouch! Hit an error thunk in GHC's AST while extracting documentation."
      , String
""
      , String
"    " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg
      , String
""
      , String
"This is most likely a bug in doctest."
      , String
""
      , String
"Please report it here: https://github.com/sol/doctest/issues/new"
      ]
    where
      msg :: String
msg = case SomeException -> Maybe GhcException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just (Panic String
s) -> String
"GHC panic: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
        Maybe GhcException
_              -> SomeException -> String
forall a. Show a => a -> String
show SomeException
e

instance Exception ExtractError

-- | Documentation for a module grouped together with the modules name.
data Module a = Module {
  forall a. Module a -> String
moduleName    :: String
, forall a. Module a -> Maybe a
moduleSetup   :: Maybe a
, forall a. Module a -> [a]
moduleContent :: [a]
} deriving (Module a -> Module a -> Bool
(Module a -> Module a -> Bool)
-> (Module a -> Module a -> Bool) -> Eq (Module a)
forall a. Eq a => Module a -> Module a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Module a -> Module a -> Bool
$c/= :: forall a. Eq a => Module a -> Module a -> Bool
== :: Module a -> Module a -> Bool
$c== :: forall a. Eq a => Module a -> Module a -> Bool
Eq, (forall a b. (a -> b) -> Module a -> Module b)
-> (forall a b. a -> Module b -> Module a) -> Functor Module
forall a b. a -> Module b -> Module a
forall a b. (a -> b) -> Module a -> Module b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Module b -> Module a
$c<$ :: forall a b. a -> Module b -> Module a
fmap :: forall a b. (a -> b) -> Module a -> Module b
$cfmap :: forall a b. (a -> b) -> Module a -> Module b
Functor, Int -> Module a -> ShowS
[Module a] -> ShowS
Module a -> String
(Int -> Module a -> ShowS)
-> (Module a -> String) -> ([Module a] -> ShowS) -> Show (Module a)
forall a. Show a => Int -> Module a -> ShowS
forall a. Show a => [Module a] -> ShowS
forall a. Show a => Module a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Module a] -> ShowS
$cshowList :: forall a. Show a => [Module a] -> ShowS
show :: Module a -> String
$cshow :: forall a. Show a => Module a -> String
showsPrec :: Int -> Module a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Module a -> ShowS
Show)

instance NFData a => NFData (Module a) where
  rnf :: Module a -> ()
rnf (Module String
name Maybe a
setup [a]
content) = String
name String -> Maybe a -> Maybe a
forall a b. NFData a => a -> b -> b
`deepseq` Maybe a
setup Maybe a -> [a] -> [a]
forall a b. NFData a => a -> b -> b
`deepseq` [a]
content [a] -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` ()

#if __GLASGOW_HASKELL__ < 803
type GhcPs = RdrName

needsTemplateHaskellOrQQ :: ModuleGraph -> Bool
needsTemplateHaskellOrQQ = needsTemplateHaskell

mapMG :: (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG = map
#endif

#if __GLASGOW_HASKELL__ < 805
addQuoteInclude :: [String] -> [String] -> [String]
addQuoteInclude includes new = new ++ includes
#endif

-- | Parse a list of modules.
parse :: [String] -> IO [ParsedModule]
parse :: [String] -> IO [ParsedModule]
parse [String]
args = [String] -> ([String] -> Ghc [ParsedModule]) -> IO [ParsedModule]
forall a. [String] -> ([String] -> Ghc a) -> IO a
withGhc [String]
args (([String] -> Ghc [ParsedModule]) -> IO [ParsedModule])
-> ([String] -> Ghc [ParsedModule]) -> IO [ParsedModule]
forall a b. (a -> b) -> a -> b
$ \[String]
modules -> Ghc [ParsedModule] -> Ghc [ParsedModule]
forall a. Ghc a -> Ghc a
withTempOutputDir (Ghc [ParsedModule] -> Ghc [ParsedModule])
-> Ghc [ParsedModule] -> Ghc [ParsedModule]
forall a b. (a -> b) -> a -> b
$ do

  (String -> Ghc Target) -> [String] -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
`guessTarget` Maybe Phase
forall a. Maybe a
Nothing) [String]
modules Ghc [Target] -> ([Target] -> Ghc ()) -> Ghc ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets
  ModuleGraph
mods <- [ModuleName] -> Bool -> Ghc ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False

  ModuleGraph
mods' <- if ModuleGraph -> Bool
needsTemplateHaskellOrQQ ModuleGraph
mods then ModuleGraph -> Ghc ModuleGraph
enableCompilation ModuleGraph
mods else ModuleGraph -> Ghc ModuleGraph
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraph
mods

  let sortedMods :: [ModSummary]
sortedMods = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs (Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
topSortModuleGraph Bool
False ModuleGraph
mods' Maybe ModuleName
forall a. Maybe a
Nothing)
  [ParsedModule] -> [ParsedModule]
forall a. [a] -> [a]
reverse ([ParsedModule] -> [ParsedModule])
-> Ghc [ParsedModule] -> Ghc [ParsedModule]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ModSummary -> Ghc ParsedModule)
-> [ModSummary] -> Ghc [ParsedModule]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ModSummary -> Ghc ModSummary
forall {m :: * -> *}. GhcMonad m => ModSummary -> m ModSummary
loadModPlugins (ModSummary -> Ghc ModSummary)
-> (ModSummary -> Ghc ParsedModule)
-> ModSummary
-> Ghc ParsedModule
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> ModSummary -> Ghc ParsedModule
forall (m :: * -> *). GhcMonad m => ModSummary -> m ParsedModule
parseModule) [ModSummary]
sortedMods
  where
    -- copied from Haddock/Interface.hs
    enableCompilation :: ModuleGraph -> Ghc ModuleGraph
    enableCompilation :: ModuleGraph -> Ghc ModuleGraph
enableCompilation ModuleGraph
modGraph = do
#if __GLASGOW_HASKELL__ < 809
      let enableComp d = let platform = targetPlatform d
                         in d { hscTarget = defaultObjectTarget platform }
#else
      let enableComp :: DynFlags -> DynFlags
enableComp DynFlags
d = DynFlags
d { hscTarget :: HscTarget
hscTarget = DynFlags -> HscTarget
defaultObjectTarget DynFlags
d }
#endif
      (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags DynFlags -> DynFlags
enableComp
      -- We need to update the DynFlags of the ModSummaries as well.
      let upd :: ModSummary -> ModSummary
upd ModSummary
m = ModSummary
m { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags -> DynFlags
enableComp (ModSummary -> DynFlags
ms_hspp_opts ModSummary
m) }
      let modGraph' :: ModuleGraph
modGraph' = (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
mapMG ModSummary -> ModSummary
upd ModuleGraph
modGraph
      ModuleGraph -> Ghc ModuleGraph
forall (m :: * -> *) a. Monad m => a -> m a
return ModuleGraph
modGraph'

    -- copied from Haddock/GhcUtils.hs
    modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
    modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags DynFlags -> DynFlags
f = do
      DynFlags
dflags <- Ghc DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getSessionDynFlags
      let dflags' :: DynFlags
dflags' = case String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"GHC Dynamic" (DynFlags -> [(String, String)]
compilerInfo DynFlags
dflags) of
            Just String
"YES" -> DynFlags -> GeneralFlag -> DynFlags
gopt_set DynFlags
dflags GeneralFlag
Opt_BuildDynamicToo
            Maybe String
_          -> DynFlags
dflags
      ()
_ <- DynFlags -> Ghc ()
forall (m :: * -> *). GhcMonad m => DynFlags -> m ()
setSessionDynFlags (DynFlags -> DynFlags
f DynFlags
dflags')
      () -> Ghc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    withTempOutputDir :: Ghc a -> Ghc a
    withTempOutputDir :: forall a. Ghc a -> Ghc a
withTempOutputDir Ghc a
action = do
      String
tmp <- IO String -> Ghc String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getTemporaryDirectory
      CPid
x   <- IO CPid -> Ghc CPid
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CPid
c_getpid
      let dir :: String
dir = String
tmp String -> ShowS
</> String
".doctest-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ CPid -> String
forall a. Show a => a -> String
show CPid
x
      (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags (String -> DynFlags -> DynFlags
setOutputDir String
dir)
      Ghc () -> Ghc () -> Ghc a -> Ghc a
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> m b -> m c -> m c
gbracket_
        (IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
createDirectory String
dir)
        (IO () -> Ghc ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
dir)
        Ghc a
action

    -- | A variant of 'gbracket' where the return value from the first computation
    -- is not required.
    gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
#if __GLASGOW_HASKELL__ < 900
    gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
#else
    gbracket_ :: forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> m b -> m c -> m c
gbracket_ m a
before_ m b
after m c
thing = (c, b) -> c
forall a b. (a, b) -> a
fst ((c, b) -> c) -> m (c, b) -> m c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m a -> (a -> ExitCase c -> m b) -> (a -> m c) -> m (c, b)
forall (m :: * -> *) a b c.
MonadMask m =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
generalBracket m a
before_ (\ a
_ ExitCase c
_ -> m b
after) (m c -> a -> m c
forall a b. a -> b -> a
const m c
thing)
#endif

    setOutputDir :: String -> DynFlags -> DynFlags
setOutputDir String
f DynFlags
d = DynFlags
d {
        objectDir :: Maybe String
objectDir  = String -> Maybe String
forall a. a -> Maybe a
Just String
f
      , hiDir :: Maybe String
hiDir      = String -> Maybe String
forall a. a -> Maybe a
Just String
f
      , stubDir :: Maybe String
stubDir    = String -> Maybe String
forall a. a -> Maybe a
Just String
f
      , includePaths :: IncludeSpecs
includePaths = IncludeSpecs -> [String] -> IncludeSpecs
addQuoteInclude (DynFlags -> IncludeSpecs
includePaths DynFlags
d) [String
f]
      }

#if __GLASGOW_HASKELL__ >= 806
    -- Since GHC 8.6, plugins are initialized on a per module basis
    loadModPlugins :: ModSummary -> m ModSummary
loadModPlugins ModSummary
modsum = do
      HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
      DynFlags
dynflags' <- IO DynFlags -> m DynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> DynFlags -> IO DynFlags
initializePlugins HscEnv
hsc_env (ModSummary -> DynFlags
GHC.ms_hspp_opts ModSummary
modsum))
      ModSummary -> m ModSummary
forall (m :: * -> *) a. Monad m => a -> m a
return (ModSummary -> m ModSummary) -> ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ ModSummary
modsum { ms_hspp_opts :: DynFlags
ms_hspp_opts = DynFlags
dynflags' }
#else
    loadModPlugins = return
#endif

-- | Extract all docstrings from given list of files/modules.
--
-- This includes the docstrings of all local modules that are imported from
-- those modules (possibly indirect).
extract :: [String] -> IO [Module (Located String)]
extract :: [String] -> IO [Module (Located String)]
extract [String]
args = do
  [ParsedModule]
mods <- [String] -> IO [ParsedModule]
parse [String]
args
  let docs :: [Module (Located String)]
docs = (ParsedModule -> Module (Located String))
-> [ParsedModule] -> [Module (Located String)]
forall a b. (a -> b) -> [a] -> [b]
map ((Located String -> Located String)
-> Module (Located String) -> Module (Located String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> Located String -> Located String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
convertDosLineEndings) (Module (Located String) -> Module (Located String))
-> (ParsedModule -> Module (Located String))
-> ParsedModule
-> Module (Located String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> Module (Located String)
extractFromModule) [ParsedModule]
mods

  ([Module (Located String)]
docs [Module (Located String)]
-> IO [Module (Located String)] -> IO [Module (Located String)]
forall a b. NFData a => a -> b -> b
`deepseq` [Module (Located String)] -> IO [Module (Located String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [Module (Located String)]
docs) IO [Module (Located String)]
-> [Handler [Module (Located String)]]
-> IO [Module (Located String)]
forall a. IO a -> [Handler a] -> IO a
`catches` [
      -- Re-throw AsyncException, otherwise execution will not terminate on
      -- SIGINT (ctrl-c).  All AsyncExceptions are re-thrown (not just
      -- UserInterrupt) because all of them indicate severe conditions and
      -- should not occur during normal operation.
      (AsyncException -> IO [Module (Located String)])
-> Handler [Module (Located String)]
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (\AsyncException
e -> AsyncException -> IO [Module (Located String)]
forall a e. Exception e => e -> a
throw (AsyncException
e :: AsyncException))
    , (SomeException -> IO [Module (Located String)])
-> Handler [Module (Located String)]
forall a e. Exception e => (e -> IO a) -> Handler a
Handler (ExtractError -> IO [Module (Located String)]
forall e a. Exception e => e -> IO a
throwIO (ExtractError -> IO [Module (Located String)])
-> (SomeException -> ExtractError)
-> SomeException
-> IO [Module (Located String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> ExtractError
ExtractError)
    ]

-- | Extract all docstrings from given module and attach the modules name.
extractFromModule :: ParsedModule -> Module (Located String)
extractFromModule :: ParsedModule -> Module (Located String)
extractFromModule ParsedModule
m = String
-> Maybe (Located String)
-> [Located String]
-> Module (Located String)
forall a. String -> Maybe a -> [a] -> Module a
Module String
name ([Located String] -> Maybe (Located String)
forall a. [a] -> Maybe a
listToMaybe ([Located String] -> Maybe (Located String))
-> [Located String] -> Maybe (Located String)
forall a b. (a -> b) -> a -> b
$ ((Maybe String, Located String) -> Located String)
-> [(Maybe String, Located String)] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String, Located String) -> Located String
forall a b. (a, b) -> b
snd [(Maybe String, Located String)]
setup) (((Maybe String, Located String) -> Located String)
-> [(Maybe String, Located String)] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe String, Located String) -> Located String
forall a b. (a, b) -> b
snd [(Maybe String, Located String)]
docs)
  where
    isSetup :: (Maybe String, b) -> Bool
isSetup = (Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"setup") (Maybe String -> Bool)
-> ((Maybe String, b) -> Maybe String) -> (Maybe String, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe String, b) -> Maybe String
forall a b. (a, b) -> a
fst
    ([(Maybe String, Located String)]
setup, [(Maybe String, Located String)]
docs) = ((Maybe String, Located String) -> Bool)
-> [(Maybe String, Located String)]
-> ([(Maybe String, Located String)],
    [(Maybe String, Located String)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Maybe String, Located String) -> Bool
forall {b}. (Maybe String, b) -> Bool
isSetup (ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule ParsedModule
m)
    name :: String
name = (ModuleName -> String
moduleNameString (ModuleName -> String)
-> (ParsedModule -> ModuleName) -> ParsedModule -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenModule Unit -> ModuleName
forall unit. GenModule unit -> ModuleName
GHC.moduleName (GenModule Unit -> ModuleName)
-> (ParsedModule -> GenModule Unit) -> ParsedModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> GenModule Unit
ms_mod (ModSummary -> GenModule Unit)
-> (ParsedModule -> ModSummary) -> ParsedModule -> GenModule Unit
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary) ParsedModule
m

-- | Extract all docstrings from given module.
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule ParsedModule
mod = ((Maybe String, GenLocated SrcSpan HsDocString)
 -> (Maybe String, Located String))
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, Located String)]
forall a b. (a -> b) -> [a] -> [b]
map ((GenLocated SrcSpan HsDocString -> Located String)
-> (Maybe String, GenLocated SrcSpan HsDocString)
-> (Maybe String, Located String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Located String -> Located String
forall a. Located a -> Located a
toLocated (Located String -> Located String)
-> (GenLocated SrcSpan HsDocString -> Located String)
-> GenLocated SrcSpan HsDocString
-> Located String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDocString -> String)
-> GenLocated SrcSpan HsDocString -> Located String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsDocString -> String
unpackHDS)) [(Maybe String, GenLocated SrcSpan HsDocString)]
docs
  where
    source :: HsModule
source   = (GenLocated SrcSpan HsModule -> HsModule
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan HsModule -> HsModule)
-> (ParsedModule -> GenLocated SrcSpan HsModule)
-> ParsedModule
-> HsModule
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> GenLocated SrcSpan HsModule
pm_parsed_source) ParsedModule
mod

    -- we use dlist-style concatenation here
    docs :: [(Maybe String, GenLocated SrcSpan HsDocString)]
docs     = [(Maybe String, GenLocated SrcSpan HsDocString)]
forall {a}. [(Maybe a, GenLocated SrcSpan HsDocString)]
header [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a. [a] -> [a] -> [a]
++ [(Maybe String, GenLocated SrcSpan HsDocString)]
forall {a}. [(Maybe a, GenLocated SrcSpan HsDocString)]
exports [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a. [a] -> [a] -> [a]
++ [(Maybe String, GenLocated SrcSpan HsDocString)]
decls

    -- We process header, exports and declarations separately instead of
    -- traversing the whole source in a generic way, to ensure that we get
    -- everything in source order.
    header :: [(Maybe a, GenLocated SrcSpan HsDocString)]
header  = [(Maybe a
forall a. Maybe a
Nothing, GenLocated SrcSpan HsDocString
x) | Just GenLocated SrcSpan HsDocString
x <- [HsModule -> Maybe (GenLocated SrcSpan HsDocString)
hsmodHaddockModHeader HsModule
source]]
#if __GLASGOW_HASKELL__ < 805
    exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)]
#else
    exports :: [(Maybe a, GenLocated SrcSpan HsDocString)]
exports = [(Maybe a
forall a. Maybe a
Nothing, SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsDocString
doc) | L SrcSpan
loc (IEDoc XIEDoc GhcPs
_ HsDocString
doc) <- [GenLocated SrcSpan (IE GhcPs)]
-> (GenLocated SrcSpan [GenLocated SrcSpan (IE GhcPs)]
    -> [GenLocated SrcSpan (IE GhcPs)])
-> Maybe (GenLocated SrcSpan [GenLocated SrcSpan (IE GhcPs)])
-> [GenLocated SrcSpan (IE GhcPs)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] GenLocated SrcSpan [GenLocated SrcSpan (IE GhcPs)]
-> [GenLocated SrcSpan (IE GhcPs)]
forall l e. GenLocated l e -> e
unLoc (HsModule
-> Maybe (GenLocated SrcSpan [GenLocated SrcSpan (IE GhcPs)])
hsmodExports HsModule
source)]
#endif
    decls :: [(Maybe String, GenLocated SrcSpan HsDocString)]
decls   = [LHsDecl GhcPs] -> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a.
Data a =>
a -> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings (HsModule -> [LHsDecl GhcPs]
hsmodDecls HsModule
source)

type Selector a = a -> ([(Maybe String, LHsDocString)], Bool)

-- | Collect given value and descend into subtree.
select :: a -> ([a], Bool)
select :: forall a. a -> ([a], Bool)
select a
x = ([a
x], Bool
False)

-- | Extract all docstrings from given value.
extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)]
extractDocStrings :: forall a.
Data a =>
a -> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings = ([(Maybe String, GenLocated SrcSpan HsDocString)]
 -> [(Maybe String, GenLocated SrcSpan HsDocString)]
 -> [(Maybe String, GenLocated SrcSpan HsDocString)])
-> GenericQ
     ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
-> forall a.
   Data a =>
   a -> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a. [a] -> [a] -> [a]
(++) (([], Bool
False) ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
-> (LHsDecl GhcPs
    -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> a
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` LHsDecl GhcPs
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLHsDecl
  (a -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> (LDocDecl
    -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> a
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` LDocDecl
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLDocDecl
  (a -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> (GenLocated SrcSpan HsDocString
    -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> a
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a b q.
(Typeable a, Typeable b) =>
(a -> q) -> (b -> q) -> a -> q
`extQ` GenLocated SrcSpan HsDocString
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLHsDocString
  )
  where
    fromLHsDecl :: Selector (LHsDecl GhcPs)
    fromLHsDecl :: LHsDecl GhcPs
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLHsDecl (L SrcSpan
loc HsDecl GhcPs
decl) = case HsDecl GhcPs
decl of

      -- Top-level documentation has to be treated separately, because it has
      -- no location information attached.  The location information is
      -- attached to HsDecl instead.
#if __GLASGOW_HASKELL__ < 805
      DocD x -> select (fromDocDecl loc x)
#else
      DocD XDocD GhcPs
_ DocDecl
x -> (Maybe String, GenLocated SrcSpan HsDocString)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. a -> ([a], Bool)
select (SrcSpan
-> DocDecl -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl SrcSpan
loc DocDecl
x)
#endif

      HsDecl GhcPs
_ -> (HsDecl GhcPs -> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a.
Data a =>
a -> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings HsDecl GhcPs
decl, Bool
True)

    fromLDocDecl :: Selector LDocDecl
    fromLDocDecl :: LDocDecl
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLDocDecl (L SrcSpan
loc DocDecl
x) = (Maybe String, GenLocated SrcSpan HsDocString)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. a -> ([a], Bool)
select (SrcSpan
-> DocDecl -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl SrcSpan
loc DocDecl
x)

    fromLHsDocString :: Selector LHsDocString
    fromLHsDocString :: GenLocated SrcSpan HsDocString
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLHsDocString GenLocated SrcSpan HsDocString
x = (Maybe String, GenLocated SrcSpan HsDocString)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. a -> ([a], Bool)
select (Maybe String
forall a. Maybe a
Nothing, GenLocated SrcSpan HsDocString
x)

    fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)
    fromDocDecl :: SrcSpan
-> DocDecl -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl SrcSpan
loc DocDecl
x = case DocDecl
x of
      DocCommentNamed String
name HsDocString
doc -> (String -> Maybe String
forall a. a -> Maybe a
Just String
name, SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc HsDocString
doc)
      DocDecl
_                        -> (Maybe String
forall a. Maybe a
Nothing, SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDocString -> GenLocated SrcSpan HsDocString)
-> HsDocString -> GenLocated SrcSpan HsDocString
forall a b. (a -> b) -> a -> b
$ DocDecl -> HsDocString
docDeclDoc DocDecl
x)

#if __GLASGOW_HASKELL__ < 805
-- | Convert a docstring to a plain string.
unpackHDS :: HsDocString -> String
unpackHDS (HsDocString s) = unpackFS s
#endif