{-# 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
newtype = 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
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 :: [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
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
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'
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
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
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 :: [String] -> IO [Module (Located String)]
[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` [
(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)
]
extractFromModule :: ParsedModule -> Module (Located String)
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
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
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
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)
select :: a -> ([a], Bool)
select :: forall a. a -> ([a], Bool)
select a
x = ([a
x], Bool
False)
extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)]
= ([(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
#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
unpackHDS :: HsDocString -> String
unpackHDS (HsDocString s) = unpackFS s
#endif