{-# LANGUAGE CPP #-}
module Extract (Module(..), extract) where

import           Imports hiding (mod, concat)
import           Control.Exception
import           Data.List (partition, isSuffixOf)

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           GhcUtil (withGhc)
import           Location hiding (unLoc)

import           Util (convertDosLineEndings)
import           PackageDBs (getPackageDBArgs)

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

#if __GLASGOW_HASKELL__ >= 901
import           GHC.Unit.Module.Graph
#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
$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
/= :: Module a -> Module a -> Bool
Eq, 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
$cshowsPrec :: forall a. Show a => Int -> Module a -> ShowS
showsPrec :: Int -> Module a -> ShowS
$cshow :: forall a. Show a => Module a -> String
show :: Module a -> String
$cshowList :: forall a. Show a => [Module a] -> ShowS
showList :: [Module a] -> ShowS
Show, (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
$cfmap :: forall a b. (a -> b) -> Module a -> Module b
fmap :: forall a b. (a -> b) -> Module a -> Module b
$c<$ :: forall a b. a -> Module b -> Module a
<$ :: forall a b. a -> Module b -> Module a
Functor)

instance NFData a => NFData (Module a) where
  rnf :: Module a -> ()
rnf (Module String
name Maybe a
setup [a]
content) = String
name String -> () -> ()
forall a b. NFData a => a -> b -> b
`deepseq` Maybe a
setup Maybe 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
#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

  -- ignore additional object files
  let modules :: [String]
modules = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isSuffixOf String
".o") [String]
modules_

  [Target] -> Ghc ()
forall (m :: * -> *). GhcMonad m => [Target] -> m ()
setTargets ([Target] -> Ghc ()) -> Ghc [Target] -> Ghc ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> (String -> Ghc Target) -> Ghc [Target]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
modules (\ String
m -> String -> Maybe UnitId -> Maybe Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe UnitId -> Maybe Phase -> m Target
guessTarget String
m
#if __GLASGOW_HASKELL__ >= 903
                Maybe UnitId
forall a. Maybe a
Nothing
#endif
                Maybe Phase
forall a. Maybe a
Nothing)
  ModuleGraph
mods <- [ModuleName] -> Bool -> Ghc ModuleGraph
forall (m :: * -> *).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
depanal [] Bool
False

  let sortedMods :: [ModSummary]
sortedMods = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
flattenSCCs
#if __GLASGOW_HASKELL__ >= 901
                     ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ [SCC ModuleGraphNode] -> [SCC ModSummary]
filterToposortToModules
#endif
                     ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$ Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
topSortModuleGraph Bool
False ModuleGraph
mods Maybe HomeUnitModule
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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/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
      -- GHCi 7.7 now uses dynamic linking.
      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 :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (DynFlags -> DynFlags
f DynFlags
dflags')
      () -> Ghc ()
forall a. a -> Ghc a
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 a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO String
getTemporaryDirectory
      CPid
x   <- IO CPid -> Ghc CPid
forall a. IO a -> Ghc a
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 a. IO a -> Ghc a
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 a. IO a -> Ghc a
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 a b c.
HasCallStack =>
m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c)
forall (m :: * -> *) a b c.
(MonadMask m, HasCallStack) =>
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  = Just f
      , hiDir      = Just f
      , stubDir    = Just f
      , includePaths = addQuoteInclude (includePaths d) [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
      ()
_ <- DynFlags -> m ()
forall (m :: * -> *).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
setSessionDynFlags (ModSummary -> DynFlags
GHC.ms_hspp_opts ModSummary
modsum)
      HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

# if __GLASGOW_HASKELL__ >= 902
      HscEnv
hsc_env' <- IO HscEnv -> m HscEnv
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> IO HscEnv
initializePlugins HscEnv
hsc_env)
      HscEnv -> m ()
forall (m :: * -> *). GhcMonad m => HscEnv -> m ()
setSession HscEnv
hsc_env'
      ModSummary -> m ModSummary
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ModSummary
modsum
# else
      dynflags' <- liftIO (initializePlugins hsc_env (GHC.ms_hspp_opts modsum))
      return $ modsum { ms_hspp_opts = dynflags' }
# endif
#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
  [String]
packageDBArgs <- IO [String]
getPackageDBArgs
  let
    args' :: [String]
args' = [String]
args [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
#if __GLASGOW_HASKELL__ >= 810
      -- `ghci` ignores unused packages in certain situation.  This ensures
      -- that we don't fail in situations where `ghci` would not.
      String
"-Wno-unused-packages" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
#endif
      [String]
packageDBArgs

  [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 a b. (a -> b) -> Module a -> Module b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS -> Located String -> Located String
forall a b. (a -> b) -> Located a -> Located b
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 a. a -> IO a
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

#if __GLASGOW_HASKELL__ >= 904
unpackHDS :: HsDocString -> String
unpackHDS :: HsDocString -> String
unpackHDS = HsDocString -> String
renderHsDocString
#endif

-- | 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 a b. (a -> b) -> (Maybe String, a) -> (Maybe String, b)
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 a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
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 GhcPs
source   = (GenLocated SrcSpan (HsModule GhcPs) -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (HsModule GhcPs) -> HsModule GhcPs)
-> (ParsedModule -> GenLocated SrcSpan (HsModule GhcPs))
-> ParsedModule
-> HsModule GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> GenLocated SrcSpan (HsModule GhcPs)
pm_parsed_source) ParsedModule
mod

    -- we use dlist-style concatenation here
    docs :: [(Maybe String, LHsDocString)]
    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)]
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.
#if __GLASGOW_HASKELL__ >= 906
    header :: [(Maybe a, GenLocated SrcSpan HsDocString)]
header  = [(Maybe a
forall a. Maybe a
Nothing, WithHsDocIdentifiers HsDocString GhcPs -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers HsDocString GhcPs -> HsDocString)
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> GenLocated SrcSpan HsDocString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
x) | Just GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
x <- [XModulePs
-> Maybe
     (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs))
hsmodHaddockModHeader (HsModule GhcPs -> XCModule GhcPs
forall p. HsModule p -> XCModule p
hsmodExt HsModule GhcPs
source)]]
#elif __GLASGOW_HASKELL__ >= 904
    header  = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader (source)]]
#else
    header  = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]
#endif
    exports :: [(Maybe String, LHsDocString)]
#if __GLASGOW_HASKELL__ >= 904
    exports :: [(Maybe String, GenLocated SrcSpan HsDocString)]
exports = [ (Maybe String
forall a. Maybe a
Nothing, SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) (WithHsDocIdentifiers HsDocString GhcPs -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> WithHsDocIdentifiers HsDocString GhcPs
forall l e. GenLocated l e -> e
unLoc GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
doc)))
#else
    exports = [ (Nothing, L (locA loc) doc)
#endif
#if __GLASGOW_HASKELL__ < 805
              | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)
#else
              | L SrcSpanAnnA
loc (IEDoc XIEDoc GhcPs
_ GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
doc) <- [GenLocated SrcSpanAnnA (IE GhcPs)]
-> (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
    -> [GenLocated SrcSpanAnnA (IE GhcPs)])
-> Maybe
     (GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)])
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] GenLocated SrcSpanAnnL [GenLocated SrcSpanAnnA (IE GhcPs)]
-> [GenLocated SrcSpanAnnA (IE GhcPs)]
forall l e. GenLocated l e -> e
unLoc (HsModule GhcPs -> Maybe (XRec GhcPs [LIE GhcPs])
forall p. HsModule p -> Maybe (XRec p [LIE p])
hsmodExports HsModule GhcPs
source)
#endif
              ]
    decls :: [(Maybe String, LHsDocString)]
    decls :: [(Maybe String, GenLocated SrcSpan HsDocString)]
decls   = [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a.
Data a =>
a -> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
hsmodDecls HsModule GhcPs
source)

-- | 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 a
d =
#if __GLASGOW_HASKELL__ >= 904
  let
    docStrs :: [GenLocated SrcSpan HsDocString]
docStrs = (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
 -> GenLocated SrcSpan HsDocString)
-> a -> [GenLocated SrcSpan HsDocString]
forall {a} {b} {a}. (Data a, Typeable b) => (b -> a) -> a -> [a]
extractAll GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> GenLocated SrcSpan HsDocString
extractDocDocString a
d
    docStrNames :: [(SrcSpan, String)]
docStrNames = [Maybe (SrcSpan, String)] -> [(SrcSpan, String)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (SrcSpan, String)] -> [(SrcSpan, String)])
-> [Maybe (SrcSpan, String)] -> [(SrcSpan, String)]
forall a b. (a -> b) -> a -> b
$ (DocDecl GhcPs -> Maybe (SrcSpan, String))
-> a -> [Maybe (SrcSpan, String)]
forall {a} {b} {a}. (Data a, Typeable b) => (b -> a) -> a -> [a]
extractAll DocDecl GhcPs -> Maybe (SrcSpan, String)
extractDocName a
d
  in
    ((GenLocated SrcSpan HsDocString
  -> (Maybe String, GenLocated SrcSpan HsDocString))
 -> [GenLocated SrcSpan HsDocString]
 -> [(Maybe String, GenLocated SrcSpan HsDocString)])
-> [GenLocated SrcSpan HsDocString]
-> (GenLocated SrcSpan HsDocString
    -> (Maybe String, GenLocated SrcSpan HsDocString))
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (GenLocated SrcSpan HsDocString
 -> (Maybe String, GenLocated SrcSpan HsDocString))
-> [GenLocated SrcSpan HsDocString]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [GenLocated SrcSpan HsDocString]
docStrs ((GenLocated SrcSpan HsDocString
  -> (Maybe String, GenLocated SrcSpan HsDocString))
 -> [(Maybe String, GenLocated SrcSpan HsDocString)])
-> (GenLocated SrcSpan HsDocString
    -> (Maybe String, GenLocated SrcSpan HsDocString))
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
forall a b. (a -> b) -> a -> b
$ \GenLocated SrcSpan HsDocString
docStr -> (SrcSpan -> [(SrcSpan, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (GenLocated SrcSpan HsDocString -> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan HsDocString
docStr) [(SrcSpan, String)]
docStrNames, GenLocated SrcSpan HsDocString
docStr)
  where
    extractAll :: (b -> a) -> a -> [a]
extractAll b -> a
z = ([a] -> [a] -> [a]) -> GenericQ [a] -> GenericQ [a]
forall r. (r -> r -> r) -> GenericQ r -> GenericQ r
everything [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([a] -> (b -> [a]) -> a -> [a]
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
mkQ [] ((a -> [a] -> [a]
forall a. a -> [a] -> [a]
:[]) (a -> [a]) -> (b -> a) -> b -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
z))

    extractDocDocString :: LHsDoc GhcPs -> LHsDocString
    extractDocDocString :: GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> GenLocated SrcSpan HsDocString
extractDocDocString = (WithHsDocIdentifiers HsDocString GhcPs -> HsDocString)
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> GenLocated SrcSpan HsDocString
forall a b.
(a -> b) -> GenLocated SrcSpan a -> GenLocated SrcSpan b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap WithHsDocIdentifiers HsDocString GhcPs -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString

    extractDocName :: DocDecl GhcPs -> Maybe (SrcSpan, String)
    extractDocName :: DocDecl GhcPs -> Maybe (SrcSpan, String)
extractDocName DocDecl GhcPs
docDecl = case DocDecl GhcPs
docDecl of
      DocCommentNamed String
name GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
y ->
        (SrcSpan, String) -> Maybe (SrcSpan, String)
forall a. a -> Maybe a
Just (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> SrcSpan
forall l e. GenLocated l e -> l
getLoc GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
y, String
name)
      DocDecl GhcPs
_ ->
        Maybe (SrcSpan, String)
forall a. Maybe a
Nothing
#else
  everythingBut (++) (([], False) `mkQ` fromLHsDecl
  `extQ` fromLDocDecl
  `extQ` fromLHsDocString
  ) d
  where
    fromLHsDecl :: Selector (LHsDecl GhcPs)
    fromLHsDecl (L loc decl) = case 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
#else
      DocD _ x
#endif
               -> select (fromDocDecl (locA loc) x)

      _ -> (extractDocStrings decl, True)

    fromLDocDecl :: Selector
#if __GLASGOW_HASKELL__ >= 901
                             (LDocDecl GhcPs)
#else
                             LDocDecl
#endif
    fromLDocDecl (L loc x) = select (fromDocDecl (locA loc) x)

    fromLHsDocString :: Selector LHsDocString
    fromLHsDocString x = select (Nothing, x)

    fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)
    fromDocDecl loc x = case x of
      DocCommentNamed name doc -> (Just name, L loc doc)
      _                        -> (Nothing, L loc $ docDeclDoc x)

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

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

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

#if __GLASGOW_HASKELL__ < 901
locA :: SrcSpan -> SrcSpan
locA = id
#endif