{-# 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))
#elif __GLASGOW_HASKELL__ < 906
import GHC.Types.SourceText (SourceText(SourceText))
import GHC.Data.FastString (unpackFS)
#else
import GHC.Data.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
#if __GLASGOW_HASKELL__ >= 901
import GHC.Unit.Module.Graph
#endif
import GHC.Generics (Generic)
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-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
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]
, forall 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
$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, (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, 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 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
$cfrom :: forall a x. Module a -> Rep (Module a) x
from :: forall x. Module a -> Rep (Module a) x
$cto :: forall a x. Rep (Module a) x -> Module a
to :: forall x. Rep (Module a) x -> Module a
Generic, Module a -> ()
(Module a -> ()) -> NFData (Module a)
forall a. NFData a => Module a -> ()
forall a. (a -> ()) -> NFData a
$crnf :: forall a. NFData a => Module a -> ()
rnf :: Module a -> ()
NFData)
eraseConfigLocation :: Module a -> Module a
eraseConfigLocation :: forall a. Module a -> Module a
eraseConfigLocation m :: Module a
m@Module{[Located String]
moduleConfig :: forall a. Module a -> [Located String]
moduleConfig :: [Located String]
moduleConfig} =
Module a
m{moduleConfig=map go 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 :: [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 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
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 :: * -> *).
(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
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
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__ >= 901
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 -> m ModSummary) -> ModSummary -> m ModSummary
forall a b. (a -> b) -> a -> b
$ 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 :: [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 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` [
(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 = 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
. 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
moduleAnnsFromModule :: ParsedModule -> [Located String]
moduleAnnsFromModule :: ParsedModule -> [Located String]
moduleAnnsFromModule ParsedModule
mod =
[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
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 a. [a] -> 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 = (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
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule ParsedModule
mod =
#if __GLASGOW_HASKELL__ < 904
map (fmap (toLocated . fmap unpackHDS)) docs
#else
((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
renderHsDocString)) [(Maybe String, GenLocated SrcSpan HsDocString)]
docs
#endif
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
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
header :: [(Maybe String, LHsDocString)]
#if __GLASGOW_HASKELL__ < 904
header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]
#elif __GLASGOW_HASKELL__ < 906
header = [(Nothing, hsDocString <$> x) | Just x <- [hsmodHaddockModHeader source]]
#else
header :: [(Maybe String, GenLocated SrcSpan HsDocString)]
header = [(Maybe String
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)]]
#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 (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
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 loc (IEDoc _ doc) <- maybe [] unLoc (hsmodExports source)
#else
| L SrcSpanAnnA
loc (IEDoc XIEDoc GhcPs
_ (GenLocated SrcSpan HsDocString -> HsDocString
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan HsDocString -> HsDocString)
-> (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> GenLocated SrcSpan HsDocString)
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> HsDocString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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 -> HsDocString
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 = Either (HsDecl GhcPs) [LHsDecl GhcPs]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings ([GenLocated SrcSpanAnnA (HsDecl GhcPs)]
-> Either (HsDecl GhcPs) [GenLocated SrcSpanAnnA (HsDecl GhcPs)]
forall a b. b -> Either a b
Right (HsModule GhcPs -> [LHsDecl GhcPs]
forall p. HsModule p -> [LHsDecl p]
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
select :: a -> ([a], Bool)
select :: forall a. a -> ([a], Bool)
select a
x = ([a
x], Bool
False)
#if __GLASGOW_HASKELL__ >= 904
noSelect :: ([a], Bool)
noSelect :: forall a. ([a], Bool)
noSelect = ([], Bool
False)
#endif
extractModuleAnns :: Data a => a -> [Located String]
= ([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)
-> (GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> ([Located String], Bool))
-> a
-> ([Located String], Bool)
forall a b r. (Typeable a, Typeable b) => r -> (b -> r) -> a -> r
`mkQ` AnnSelector (LHsDecl GhcPs)
GenLocated SrcSpanAnnA (HsDecl GhcPs) -> ([Located String], Bool)
fromLHsDecl)
where
fromLHsDecl :: AnnSelector (LHsDecl GhcPs)
fromLHsDecl :: AnnSelector (LHsDecl GhcPs)
fromLHsDecl (L (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA -> SrcSpan
loc) HsDecl GhcPs
decl) = case HsDecl GhcPs
decl of
#if __GLASGOW_HASKELL__ < 805
AnnD (HsAnnotation (SourceText _) ModuleAnnProvenance (L _loc expr))
#elif __GLASGOW_HASKELL__ < 906
AnnD _ (HsAnnotation _ (SourceText _) ModuleAnnProvenance (L _loc expr))
#else
AnnD XAnnD GhcPs
_ (HsAnnotation XHsAnnotation GhcPs
_ AnnProvenance GhcPs
ModuleAnnProvenance (L SrcSpanAnnA
_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
_ ->
(HsDecl GhcPs -> [Located String]
forall a. Data a => a -> [Located String]
extractModuleAnns HsDecl GhcPs
decl, Bool
True)
extractLit :: SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
SrcSpan
loc = \case
#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 _ (L l e) -> extractLit (locA l) e
#else
HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ (L SrcSpanAnnA
l HsExpr GhcPs
e) LHsToken ")" GhcPs
_ -> SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
l) HsExpr GhcPs
e
#endif
#if __GLASGOW_HASKELL__ < 807
ExprWithTySig _ (L l e) -> extractLit l e
#else
ExprWithTySig XExprWithTySig GhcPs
_ (L SrcSpanAnnA
l HsExpr GhcPs
e) LHsSigWcType (NoGhcTc GhcPs)
_ -> SrcSpan -> HsExpr GhcPs -> Maybe (Located String)
extractLit (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
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
extractDocStrings :: Either (HsDecl GhcPs) [LHsDecl GhcPs] -> [(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)
-> 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)
-> (GenLocated SrcSpanAnnA (HsDecl 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` DocSelector (LHsDecl GhcPs)
GenLocated SrcSpanAnnA (HsDecl GhcPs)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLHsDecl
(a -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> (GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> a
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` DocSelector (LDocDecl GhcPs)
GenLocated SrcSpanAnnA (DocDecl GhcPs)
-> ([(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 r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` GenLocated SrcSpan HsDocString
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromLHsDocString
#if __GLASGOW_HASKELL__ >= 904
(a -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> (HsType GhcPs
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool))
-> a
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a b r.
(Typeable a, Typeable b) =>
(a -> r) -> (b -> r) -> a -> r
`extQ` HsType GhcPs
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromHsType
#endif
)
where
fromLHsDecl :: DocSelector (LHsDecl GhcPs)
fromLHsDecl :: DocSelector (LHsDecl GhcPs)
fromLHsDecl (L SrcSpanAnnA
loc HsDecl GhcPs
decl) = case HsDecl GhcPs
decl of
#if __GLASGOW_HASKELL__ < 805
DocD x
#else
DocD XDocD GhcPs
_ DocDecl GhcPs
x
#endif
-> (Maybe String, GenLocated SrcSpan HsDocString)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. a -> ([a], Bool)
select (SrcSpan
-> DocDecl GhcPs -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) DocDecl GhcPs
x)
HsDecl GhcPs
_ -> (Either (HsDecl GhcPs) [LHsDecl GhcPs]
-> [(Maybe String, GenLocated SrcSpan HsDocString)]
extractDocStrings (HsDecl GhcPs
-> Either (HsDecl GhcPs) [GenLocated SrcSpanAnnA (HsDecl 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 :: DocSelector (LDocDecl GhcPs)
fromLDocDecl (L SrcSpanAnnA
loc DocDecl GhcPs
x) = (Maybe String, GenLocated SrcSpan HsDocString)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. a -> ([a], Bool)
select (SrcSpan
-> DocDecl GhcPs -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) DocDecl GhcPs
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 :: HsType GhcPs
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
fromHsType HsType GhcPs
x = case HsType GhcPs
x of
HsDocTy XDocTy GhcPs
_ LHsType GhcPs
_ (L SrcSpan
loc WithHsDocIdentifiers HsDocString GhcPs
hsDoc) -> (Maybe String, GenLocated SrcSpan HsDocString)
-> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. a -> ([a], Bool)
select (Maybe String
forall a. Maybe a
Nothing, SrcSpan -> HsDocString -> GenLocated SrcSpan HsDocString
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (WithHsDocIdentifiers HsDocString GhcPs -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString WithHsDocIdentifiers HsDocString GhcPs
hsDoc))
HsType GhcPs
_ -> ([(Maybe String, GenLocated SrcSpan HsDocString)], Bool)
forall a. ([a], Bool)
noSelect
#endif
#if __GLASGOW_HASKELL__ < 904
fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)
#else
fromDocDecl :: SrcSpan -> DocDecl GhcPs -> (Maybe String, LHsDocString)
#endif
fromDocDecl :: SrcSpan
-> DocDecl GhcPs -> (Maybe String, GenLocated SrcSpan HsDocString)
fromDocDecl SrcSpan
loc DocDecl GhcPs
x = case DocDecl GhcPs
x of
#if __GLASGOW_HASKELL__ < 904
DocCommentNamed name doc -> (Just name, L loc doc)
_ -> (Nothing, L loc $ docDeclDoc x)
#else
DocCommentNamed String
name GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
doc -> (String -> Maybe String
forall a. a -> Maybe a
Just String
name, 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)
doc)
DocDecl GhcPs
_ -> (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
$ WithHsDocIdentifiers HsDocString GhcPs -> HsDocString
forall a pass. WithHsDocIdentifiers a pass -> a
hsDocString (WithHsDocIdentifiers HsDocString GhcPs -> HsDocString)
-> WithHsDocIdentifiers HsDocString GhcPs -> HsDocString
forall a b. (a -> b) -> a -> b
$ GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> WithHsDocIdentifiers HsDocString GhcPs
forall l e. GenLocated l e -> e
unLoc (GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> WithHsDocIdentifiers HsDocString GhcPs)
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
-> WithHsDocIdentifiers HsDocString GhcPs
forall a b. (a -> b) -> a -> b
$ DocDecl GhcPs
-> GenLocated SrcSpan (WithHsDocIdentifiers HsDocString GhcPs)
forall pass. DocDecl pass -> LHsDoc pass
docDeclDoc DocDecl GhcPs
x)
#endif
#if __GLASGOW_HASKELL__ < 805
unpackHDS :: HsDocString -> String
unpackHDS (HsDocString s) = unpackFS s
#endif
#if __GLASGOW_HASKELL__ < 901
locA :: SrcSpan -> SrcSpan
locA = id
#endif