{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}

module Test.DocTest.Internal.Extract (Module(..), extract, eraseConfigLocation) where

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

import           Control.DeepSeq (NFData, deepseq)
import           Data.Generics (Data, Typeable, extQ, mkQ, everythingBut)

import qualified GHC

#if __GLASGOW_HASKELL__ < 900
import           GHC hiding (Module, Located, moduleName)
import           DynFlags
import           MonadUtils (liftIO)
#else
import           GHC hiding (Module, Located, moduleName)
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__ < 900
import           BasicTypes (SourceText(SourceText))
import           FastString (unpackFS)
#elif __GLASGOW_HASKELL__ < 902
import           GHC.Data.FastString (unpackFS)
import           GHC.Types.Basic (SourceText(SourceText))
#else
import           GHC.Data.FastString (unpackFS)
import           GHC.Types.SourceText (SourceText(SourceText))
#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

#if __GLASGOW_HASKELL__ >= 901
import           GHC.Unit.Module.Graph
#endif

import           GHC.Generics (Generic)


-- | 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-parallel."
      , String
""
      , String
"Please report it here: https://github.com/martijnbastiaan/doctest-parallel/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 {
  Module a -> String
moduleName    :: String
, Module a -> Maybe a
moduleSetup   :: Maybe a
, Module a -> [a]
moduleContent :: [a]
, Module a -> [Located String]
moduleConfig  :: [Located String]
} 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, a -> Module b -> Module a
(a -> b) -> Module a -> Module b
(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
<$ :: a -> Module b -> Module a
$c<$ :: forall a b. a -> Module b -> Module a
fmap :: (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, (forall x. Module a -> Rep (Module a) x)
-> (forall x. Rep (Module a) x -> Module a) -> Generic (Module a)
forall x. Rep (Module a) x -> Module a
forall x. Module a -> Rep (Module a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Module a) x -> Module a
forall a x. Module a -> Rep (Module a) x
$cto :: forall a x. Rep (Module a) x -> Module a
$cfrom :: forall a x. Module a -> Rep (Module a) x
Generic, Module a -> ()
(Module a -> ()) -> NFData (Module a)
forall a. NFData a => Module a -> ()
forall a. (a -> ()) -> NFData a
rnf :: Module a -> ()
$crnf :: forall a. NFData a => Module a -> ()
NFData)

eraseConfigLocation :: Module a -> Module a
eraseConfigLocation :: Module a -> Module a
eraseConfigLocation m :: Module a
m@Module{[Located String]
moduleConfig :: [Located String]
moduleConfig :: forall a. Module a -> [Located String]
moduleConfig} =
  Module a
m{moduleConfig :: [Located String]
moduleConfig=(Located String -> Located String)
-> [Located String] -> [Located String]
forall a b. (a -> b) -> [a] -> [b]
map Located String -> Located String
forall a. Located a -> Located a
go [Located String]
moduleConfig}
 where
  go :: Located a -> Located a
go (Located Location
_ a
a) = a -> Located a
forall a. a -> Located a
noLocation a
a

#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
  [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 Phase -> Ghc Target
forall (m :: * -> *).
GhcMonad m =>
String -> Maybe Phase -> m Target
guessTarget String
m
#if __GLASGOW_HASKELL__ >= 903
                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
                     $ filterToposortToModules
#endif
                     ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$ 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/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
      [InstalledUnitId]
_ <- DynFlags -> Ghc [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags (DynFlags -> DynFlags
f DynFlags
dflags')
      () -> Ghc ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    withTempOutputDir :: Ghc a -> Ghc a
    withTempOutputDir :: 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_ :: m a -> m b -> m c -> m c
gbracket_ m a
before_ m b
after m c
thing = m a -> (a -> m b) -> (a -> m c) -> m c
forall (m :: * -> *) a b c.
ExceptionMonad m =>
m a -> (a -> m b) -> (a -> m c) -> m c
gbracket m a
before_ (m b -> a -> m b
forall a b. a -> b -> a
const m b
after) (m c -> a -> m c
forall a b. a -> b -> a
const m c
thing)
#else
    gbracket_ before_ after thing = fst <$> generalBracket before_ (\ _ _ -> after) (const 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
      [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: * -> *). GhcMonad m => DynFlags -> m [InstalledUnitId]
setSessionDynFlags (ModSummary -> DynFlags
GHC.ms_hspp_opts ModSummary
modsum)
      HscEnv
hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

# if __GLASGOW_HASKELL__ >= 901
      hsc_env' <- liftIO (initializePlugins hsc_env)
      setSession hsc_env'
      return $ modsum
# else
      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' }
# 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
  [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 = Module :: forall a. String -> Maybe a -> [a] -> [Located String] -> Module a
Module
  { moduleName :: String
moduleName = String
name
  , moduleSetup :: Maybe (Located String)
moduleSetup = [Located String] -> Maybe (Located String)
forall a. [a] -> Maybe a
listToMaybe (((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)
  , moduleContent :: [Located String]
moduleContent = ((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
  , moduleConfig :: [Located String]
moduleConfig = ParsedModule -> [Located String]
moduleAnnsFromModule ParsedModule
m
  }
 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
. Module -> ModuleName
GHC.moduleName (Module -> ModuleName)
-> (ParsedModule -> Module) -> ParsedModule -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModSummary -> Module
ms_mod (ModSummary -> Module)
-> (ParsedModule -> ModSummary) -> ParsedModule -> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ModSummary
pm_mod_summary) ParsedModule
m

-- | Extract all module annotations from given module.
moduleAnnsFromModule :: ParsedModule -> [Located String]
moduleAnnsFromModule :: ParsedModule -> [Located String]
moduleAnnsFromModule ParsedModule
mod =
  [ShowS -> Located String -> Located String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ShowS
stripOptionString Located String
ann | Located String
ann <- [Located String]
anns, Located String -> Bool
isOption Located String
ann]
 where
  optionPrefix :: String
optionPrefix = String
"doctest-parallel:"
  isOption :: Located String -> Bool
isOption (Located Location
_ String
s) = String
optionPrefix String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
  stripOptionString :: ShowS
stripOptionString String
s = ShowS
trim (Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
optionPrefix) String
s)
  anns :: [Located String]
anns = HsModule GhcPs -> [Located String]
forall a. Data a => a -> [Located String]
extractModuleAnns HsModule GhcPs
source
  source :: HsModule GhcPs
source = (ParsedSource -> HsModule GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ParsedSource -> HsModule GhcPs)
-> (ParsedModule -> ParsedSource) -> ParsedModule -> HsModule GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ParsedSource
pm_parsed_source) ParsedModule
mod

-- | Extract all docstrings from given module.
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule ParsedModule
mod =
#if __GLASGOW_HASKELL__ < 904
  ((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
#else
  map (fmap (toLocated . fmap renderHsDocString)) docs
#endif
 where
  source :: HsModule GhcPs
source = (ParsedSource -> HsModule GhcPs
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (ParsedSource -> HsModule GhcPs)
-> (ParsedModule -> ParsedSource) -> ParsedModule -> HsModule GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParsedModule -> ParsedSource
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)]
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.
  header :: [(Maybe String, LHsDocString)]
#if __GLASGOW_HASKELL__ < 904
  header :: [(Maybe String, GenLocated SrcSpan HsDocString)]
header  = [(Maybe String
forall a. Maybe a
Nothing, GenLocated SrcSpan HsDocString
x) | Just GenLocated SrcSpan HsDocString
x <- [HsModule GhcPs -> Maybe (GenLocated SrcSpan HsDocString)
forall pass.
HsModule pass -> Maybe (GenLocated SrcSpan HsDocString)
hsmodHaddockModHeader HsModule GhcPs
source]]
#else
  header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader source]]
#endif

  exports :: [(Maybe String, LHsDocString)]
  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 (SrcSpan -> SrcSpan
locA SrcSpan
loc) HsDocString
doc)
#if __GLASGOW_HASKELL__ < 710
            | L loc (IEDoc doc) <- concat (hsmodExports source)
#elif __GLASGOW_HASKELL__ < 805
            | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)
#elif __GLASGOW_HASKELL__ < 904
            | L SrcSpan
loc (IEDoc XIEDoc GhcPs
_ HsDocString
doc) <- [GenLocated SrcSpan (IE GhcPs)]
-> (Located [GenLocated SrcSpan (IE GhcPs)]
    -> [GenLocated SrcSpan (IE GhcPs)])
-> Maybe (Located [GenLocated SrcSpan (IE GhcPs)])
-> [GenLocated SrcSpan (IE GhcPs)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Located [GenLocated SrcSpan (IE GhcPs)]
-> [GenLocated SrcSpan (IE GhcPs)]
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc (HsModule GhcPs -> Maybe (Located [GenLocated SrcSpan (IE GhcPs)])
forall pass. HsModule pass -> Maybe (Located [LIE pass])
hsmodExports HsModule GhcPs
source)
#else
            | L loc (IEDoc _ (unLoc . fmap hsDocString -> doc)) <- maybe [] unLoc (hsmodExports source)
#endif
            ]

  decls :: [(Maybe String, LHsDocString)]
  decls :: [(Maybe String, GenLocated SrcSpan HsDocString)]
decls   = Either (HsDecl GhcPs) [LHsDecl GhcPs]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings ([LHsDecl GhcPs] -> Either (HsDecl GhcPs) [LHsDecl GhcPs]
forall a b. b -> Either a b
Right (HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls HsModule GhcPs
source))

type Selector b a = a -> ([b], Bool)

type DocSelector a = Selector (Maybe String, LHsDocString) a
type AnnSelector a = Selector (Located String) a

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

#if __GLASGOW_HASKELL__ >= 904
-- | Don't collect any values
noSelect :: ([a], Bool)
noSelect = ([], False)
#endif

-- | Extract module annotations from given value.
extractModuleAnns :: Data a => a -> [Located String]
extractModuleAnns :: a -> [Located String]
extractModuleAnns = ([Located String] -> [Located String] -> [Located String])
-> GenericQ ([Located String], Bool)
-> forall a. Data a => a -> [Located String]
forall r. (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r
everythingBut [Located String] -> [Located String] -> [Located String]
forall a. [a] -> [a] -> [a]
(++) (([], Bool
False) ([Located String], Bool)
-> (LHsDecl GhcPs -> ([Located String], Bool))
-> a
-> ([Located String], Bool)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` LHsDecl GhcPs -> ([Located String], Bool)
fromLHsDecl)
 where
  fromLHsDecl :: AnnSelector (LHsDecl GhcPs)
  fromLHsDecl :: LHsDecl GhcPs -> ([Located String], Bool)
fromLHsDecl (L (SrcSpan -> SrcSpan
locA -> SrcSpan
loc) HsDecl GhcPs
decl) = case HsDecl GhcPs
decl of
#if __GLASGOW_HASKELL__ < 805
    AnnD (HsAnnotation (SourceText _) ModuleAnnProvenance (L _loc expr))
#else
    AnnD XAnnD GhcPs
_ (HsAnnotation XHsAnnotation GhcPs
_ (SourceText String
_) AnnProvenance (IdP GhcPs)
ModuleAnnProvenance (L SrcSpan
_loc HsExpr GhcPs
expr))
#endif
     | Just Located String
s <- SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit SrcSpan
loc HsExpr GhcPs
expr
     -> Located String -> ([Located String], Bool)
forall a. a -> ([a], Bool)
select Located String
s
    HsDecl GhcPs
_ ->
      -- XXX: Shouldn't this be handled by 'everythingBut'?
      (HsDecl GhcPs -> [Located String]
forall a. Data a => a -> [Located String]
extractModuleAnns HsDecl GhcPs
decl, Bool
True)

-- | Extract string literals. Looks through type annotations and parentheses.
extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit SrcSpan
loc = \case
  -- well this is a holy mess innit
#if __GLASGOW_HASKELL__ < 805
  HsPar (L l e) -> extractLit l e
  ExprWithTySig (L l e) _ -> extractLit l e
  HsOverLit OverLit{ol_val=HsIsString _ s} -> Just (toLocated (L loc (unpackFS s)))
  HsLit (HsString _ s) -> Just (toLocated (L loc (unpackFS s)))
  _ -> Nothing
#else
#if __GLASGOW_HASKELL__ < 904
  HsPar XPar GhcPs
_ (L SrcSpan
l HsExpr GhcPs
e) -> SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit (SrcSpan -> SrcSpan
locA SrcSpan
l) HsExpr GhcPs
e
#else
  HsPar _ _ (L l e) _ -> extractLit (locA l) e
#endif
#if __GLASGOW_HASKELL__ < 807
  ExprWithTySig _ (L l e) -> extractLit l e
#else
  ExprWithTySig XExprWithTySig GhcPs
_ (L SrcSpan
l HsExpr GhcPs
e) LHsSigWcType (NoGhcTc GhcPs)
_ -> SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit (SrcSpan -> SrcSpan
locA SrcSpan
l) HsExpr GhcPs
e
#endif
  HsOverLit XOverLitE GhcPs
_ OverLit{ol_val :: forall p. HsOverLit p -> OverLitVal
ol_val=HsIsString SourceText
_ FastString
s} -> Located String -> Maybe (Located String)
forall a. a -> Maybe a
Just (Located String -> Located String
forall a. Located a -> Located a
toLocated (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (FastString -> String
unpackFS FastString
s)))
  HsLit XLitE GhcPs
_ (HsString XHsString GhcPs
_ FastString
s) -> Located String -> Maybe (Located String)
forall a. a -> Maybe a
Just (Located String -> Located String
forall a. Located a -> Located a
toLocated (SrcSpan -> String -> Located String
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (FastString -> String
unpackFS FastString
s)))
  HsExpr GhcPs
_ -> Maybe (Located String)
forall a. Maybe a
Nothing
#endif

-- | Extract all docstrings from given value.
extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs] -> [(Maybe String, LHsDocString)]
extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs]
-> [(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)
-> GenericQ [(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
#if __GLASGOW_HASKELL__ >= 904
      `extQ` fromHsType
#endif
    )
  where
    fromLHsDecl :: DocSelector (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
#else
      DocD XDocD GhcPs
_ DocDecl
x
#endif
           -> (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 -> SrcSpan
locA SrcSpan
loc) DocDecl
x)

      HsDecl GhcPs
_ -> (Either (HsDecl GhcPs) [LHsDecl GhcPs]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings (HsDecl GhcPs -> Either (HsDecl GhcPs) [LHsDecl GhcPs]
forall a b. a -> Either a b
Left HsDecl GhcPs
decl), Bool
True)


    fromLDocDecl :: DocSelector
#if __GLASGOW_HASKELL__ >= 901
                             (LDocDecl GhcPs)
#else
                             LDocDecl
#endif
    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 -> SrcSpan
locA SrcSpan
loc) DocDecl
x)

    fromLHsDocString :: DocSelector 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)

#if __GLASGOW_HASKELL__ >= 904
    fromHsType :: DocSelector (HsType GhcPs)
    fromHsType x = case x of
      HsDocTy _ _ (L loc hsDoc) -> select (Nothing, L loc (hsDocString hsDoc))
      _ -> noSelect
#endif

#if __GLASGOW_HASKELL__ < 904
    fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)
#else
    fromDocDecl :: SrcSpan -> DocDecl GhcPs -> (Maybe String, LHsDocString)
#endif
    fromDocDecl :: SrcSpan
-> DocDecl -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl SrcSpan
loc DocDecl
x = case DocDecl
x of
#if __GLASGOW_HASKELL__ < 904
      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)
#else
      DocCommentNamed name doc -> (Just name, hsDocString <$> doc)
      _                        -> (Nothing, L loc $ hsDocString $ unLoc $ docDeclDoc x)
#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 :: SrcSpan -> SrcSpan
locA = SrcSpan -> SrcSpan
forall a. a -> a
id
#endif