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

module Test.DocTest.Internal.Extract
  ( Module(..)
  , isEmptyModule
  , extract
  , extractIO
  , eraseConfigLocation
  ) where
import           Prelude hiding (mod, concat)
import           Control.DeepSeq (NFData, deepseq)
import           Control.Exception (AsyncException, throw, throwIO, fromException)
import           Control.Monad
import           Control.Monad.Catch (catches, SomeException, Exception, Handler (Handler))
import           Data.Generics (Data, extQ, mkQ, everythingBut)
import           Data.List (partition, isPrefixOf)
import           Data.List.Extra (trim, splitOn)
import           Data.Maybe
import           GHC.Generics (Generic)

#if __GLASGOW_HASKELL__ < 912
import           Data.Generics (Typeable)
#endif

import           GHC hiding (Module, Located, moduleName, parsedSource)
import           GHC.Driver.Session
import           GHC.Utils.Monad (liftIO)

import           System.Directory
import           System.FilePath

#if __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           Test.DocTest.Internal.GhcUtil (withGhc)
import           Test.DocTest.Internal.Location hiding (unLoc)
import           Test.DocTest.Internal.Util (convertDosLineEndings)

#if MIN_VERSION_ghc_exactprint(1,3,0)
import           Language.Haskell.GHC.ExactPrint.Parsers (parseModuleEpAnnsWithCppInternal, defaultCppOptions)
#else
import           Language.Haskell.GHC.ExactPrint.Parsers (parseModuleApiAnnsWithCppInternal, defaultCppOptions)
#endif

#if __GLASGOW_HASKELL__ < 902
import           GHC.Driver.Types (throwErrors)
import           GHC.Parser.Header (getOptionsFromFile)
#elif __GLASGOW_HASKELL__ < 904
import           GHC.Types.SourceError (throwErrors)
import           GHC.Parser.Header (getOptionsFromFile)
#else
import           GHC.Types.SourceError (throwErrors)
import           GHC.Parser.Header (getOptionsFromFile)
import           GHC.Driver.Config.Parser (initParserOpts)
#endif

#if __GLASGOW_HASKELL__ < 904
initParserOpts :: DynFlags -> DynFlags
initParserOpts = id
#endif


-- | A wrapper around `SomeException`, to allow for a custom `Show` instance.
newtype ExtractError = ExtractError SomeException
#if __GLASGOW_HASKELL__ < 912
  deriving Typeable
#endif

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 ModuleNotFoundError = ModuleNotFoundError String [FilePath]
  deriving (
#if __GLASGOW_HASKELL__ < 912
    Typeable,
#endif
    Show ModuleNotFoundError
Typeable ModuleNotFoundError
(Typeable ModuleNotFoundError, Show ModuleNotFoundError) =>
(ModuleNotFoundError -> SomeException)
-> (SomeException -> Maybe ModuleNotFoundError)
-> (ModuleNotFoundError -> String)
-> Exception ModuleNotFoundError
SomeException -> Maybe ModuleNotFoundError
ModuleNotFoundError -> String
ModuleNotFoundError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e) -> (e -> String) -> Exception e
$ctoException :: ModuleNotFoundError -> SomeException
toException :: ModuleNotFoundError -> SomeException
$cfromException :: SomeException -> Maybe ModuleNotFoundError
fromException :: SomeException -> Maybe ModuleNotFoundError
$cdisplayException :: ModuleNotFoundError -> String
displayException :: ModuleNotFoundError -> String
Exception
  )

instance Show ModuleNotFoundError where
  show :: ModuleNotFoundError -> String
show (ModuleNotFoundError String
modName [String]
incdirs) =
    [String] -> String
unlines [
        String
"Module not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
modName
      , String
""
      , String
"Tried the following include directories:"
      , String
""
      , [String] -> String
unlines [String]
incdirs
      ]

-- | Documentation for a module grouped together with the modules name.
data Module a = Module {
  forall a. Module a -> String
moduleName    :: String
, forall a. Module a -> Maybe a
moduleSetup   :: Maybe a
, forall a. Module a -> [a]
moduleContent :: [a]
, 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)

isEmptyModule :: Module a -> Bool
isEmptyModule :: forall a. Module a -> Bool
isEmptyModule (Module String
_ Maybe a
setup [a]
tests [Located String]
_) = [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
tests Bool -> Bool -> Bool
&& Maybe a -> Bool
forall a. Maybe a -> Bool
isNothing Maybe a
setup

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

moduleParts :: String -> [String]
moduleParts :: String -> [String]
moduleParts = Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn Char
'.'

findModulePath :: [FilePath] -> String -> IO FilePath
findModulePath :: [String] -> String -> IO String
findModulePath [String]
importPaths String
modName = do
  let
    modPath :: String
modPath = (String -> ShowS) -> [String] -> String
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 String -> ShowS
(</>) (String -> [String]
moduleParts String
modName) String -> ShowS
<.> String
"hs"

  [String]
found <- ([Maybe String] -> [String]) -> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe String] -> [String]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe String] -> IO [String])
-> IO [Maybe String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [String] -> (String -> IO (Maybe String)) -> IO [Maybe String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
importPaths ((String -> IO (Maybe String)) -> IO [Maybe String])
-> (String -> IO (Maybe String)) -> IO [Maybe String]
forall a b. (a -> b) -> a -> b
$ \String
importPath -> do
    let fullPath :: String
fullPath = String
importPath String -> ShowS
</> String
modPath
    Bool
exists <- String -> IO Bool
doesFileExist String
fullPath
    Maybe String -> IO (Maybe String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ if Bool
exists then String -> Maybe String
forall a. a -> Maybe a
Just String
fullPath else Maybe String
forall a. Maybe a
Nothing

  case [String]
found of
    [] -> ModuleNotFoundError -> IO String
forall e a. Exception e => e -> IO a
throwIO (String -> [String] -> ModuleNotFoundError
ModuleNotFoundError String
modName [String]
importPaths)
    (String
p:[String]
_) -> String -> IO String
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String
p

-- | Parse a list of modules. Can throw an `ModuleNotFoundError` if a module's
-- source file cannot be found. Can throw a `SourceError` if an error occurs
-- while parsing.
parse :: String -> Ghc ParsedSource
parse :: String -> Ghc ParsedSource
parse String
modName = do
  -- Find all specified modules on disk
  [String]
importPaths0 <- DynFlags -> [String]
importPaths (DynFlags -> [String]) -> Ghc DynFlags -> Ghc [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  String
path <- IO String -> Ghc String
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> Ghc String) -> IO String -> Ghc String
forall a b. (a -> b) -> a -> b
$ [String] -> String -> IO String
findModulePath [String]
importPaths0 String
modName

  -- LANGUAGE pragmas can influence how a file is parsed. For example, CPP
  -- means we need to preprocess the file before parsing it. We use GHC's
  -- `getOptionsFromFile` to parse these pragmas and then feed them as options
  -- to the "real" parser.
  DynFlags
dynFlags0 <- Ghc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
#if __GLASGOW_HASKELL__ < 904
  flagsFromFile <-
#else
  (Messages PsMessage
_, [Located String]
flagsFromFile) <-
#endif
    IO (Messages PsMessage, [Located String])
-> Ghc (Messages PsMessage, [Located String])
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages PsMessage, [Located String])
 -> Ghc (Messages PsMessage, [Located String]))
-> IO (Messages PsMessage, [Located String])
-> Ghc (Messages PsMessage, [Located String])
forall a b. (a -> b) -> a -> b
$ ParserOpts -> String -> IO (Messages PsMessage, [Located String])
getOptionsFromFile (DynFlags -> ParserOpts
initParserOpts DynFlags
dynFlags0) String
path
  (DynFlags
dynFlags1, [Located String]
_, [Warn]
_) <- DynFlags
-> [Located String] -> Ghc (DynFlags, [Located String], [Warn])
forall (m :: * -> *).
MonadIO m =>
DynFlags
-> [Located String] -> m (DynFlags, [Located String], [Warn])
parseDynamicFilePragma DynFlags
dynFlags0 [Located String]
flagsFromFile

#if MIN_VERSION_ghc_exactprint(1,3,0)
  Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
result <- CppOptions
-> DynFlags
-> String
-> Ghc
     (Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource))
forall (m :: * -> *).
GhcMonad m =>
CppOptions
-> DynFlags
-> String
-> m (Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource))
parseModuleEpAnnsWithCppInternal CppOptions
defaultCppOptions DynFlags
dynFlags1 String
path
#else
  result <- parseModuleApiAnnsWithCppInternal defaultCppOptions dynFlags1 path
#endif

  case Either ErrorMessages ([LEpaComment], DynFlags, ParsedSource)
result of
    Left ErrorMessages
errs -> ErrorMessages -> Ghc ParsedSource
forall (io :: * -> *) a. MonadIO io => ErrorMessages -> io a
throwErrors ErrorMessages
errs
#if MIN_VERSION_ghc_exactprint(1,3,0)
    Right ([LEpaComment]
_cppComments, DynFlags
_dynFlags, ParsedSource
parsedSource) -> ParsedSource -> Ghc ParsedSource
forall a. a -> Ghc a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ParsedSource
parsedSource
#else
    Right (_apiAnns, _cppComments, _dynFlags, parsedSource) -> pure parsedSource
#endif

-- | Like `extract`, but runs in the `IO` monad given GHC parse arguments.
extractIO :: [String] -> String -> IO (Module (Located String))
extractIO :: [String] -> String -> IO (Module (Located String))
extractIO [String]
parseArgs String
modName = [String]
-> Ghc (Module (Located String)) -> IO (Module (Located String))
forall a. [String] -> Ghc a -> IO a
withGhc [String]
parseArgs (Ghc (Module (Located String)) -> IO (Module (Located String)))
-> Ghc (Module (Located String)) -> IO (Module (Located String))
forall a b. (a -> b) -> a -> b
$ String -> Ghc (Module (Located String))
extract String
modName

-- | 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).
--
-- Can throw `ExtractError` if an error occurs while extracting the docstrings,
-- or a `SourceError` if an error occurs while parsing the module. Can throw a
-- `ModuleNotFoundError` if a module's source file cannot be found.
extract :: String -> Ghc (Module (Located String))
extract :: String -> Ghc (Module (Located String))
extract String
modName = do
  ParsedSource
mod <- String -> Ghc ParsedSource
parse String
modName
  let
    docs0 :: Module (Located String)
docs0 = String -> ParsedSource -> Module (Located String)
extractFromModule String
modName ParsedSource
mod
    docs1 :: Module (Located String)
docs1 = 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 (Located String -> Located String)
-> Module (Located String) -> Module (Located String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module (Located String)
docs0

  (Module (Located String)
docs1 Module (Located String)
-> Ghc (Module (Located String)) -> Ghc (Module (Located String))
forall a b. NFData a => a -> b -> b
`deepseq` Module (Located String) -> Ghc (Module (Located String))
forall a. a -> Ghc a
forall (m :: * -> *) a. Monad m => a -> m a
return Module (Located String)
docs1) Ghc (Module (Located String))
-> [Handler Ghc (Module (Located String))]
-> Ghc (Module (Located String))
forall (f :: * -> *) (m :: * -> *) a.
(HasCallStack, Foldable f, MonadCatch m) =>
m a -> f (Handler m a) -> m 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 -> Ghc (Module (Located String)))
-> Handler Ghc (Module (Located String))
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (\AsyncException
e -> AsyncException -> Ghc (Module (Located String))
forall a e. Exception e => e -> a
throw (AsyncException
e :: AsyncException))
    , (SomeException -> Ghc (Module (Located String)))
-> Handler Ghc (Module (Located String))
forall (m :: * -> *) a e. Exception e => (e -> m a) -> Handler m a
Handler (IO (Module (Located String)) -> Ghc (Module (Located String))
forall a. IO a -> Ghc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Module (Located String)) -> Ghc (Module (Located String)))
-> (SomeException -> IO (Module (Located String)))
-> SomeException
-> Ghc (Module (Located String))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: String -> ParsedSource -> Module (Located String)
extractFromModule :: String -> ParsedSource -> Module (Located String)
extractFromModule String
modName ParsedSource
m = Module
  { moduleName :: String
moduleName = String
modName
  , 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 = ParsedSource -> [Located String]
moduleAnnsFromModule ParsedSource
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 (ParsedSource -> [(Maybe String, Located String)]
docStringsFromModule ParsedSource
m)

-- | Extract all module annotations from given module.
moduleAnnsFromModule :: ParsedSource -> [Located String]
moduleAnnsFromModule :: ParsedSource -> [Located String]
moduleAnnsFromModule ParsedSource
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 = ParsedSource -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc ParsedSource
mod

-- | Extract all docstrings from given module.
docStringsFromModule :: ParsedSource -> [(Maybe String, Located String)]
docStringsFromModule :: ParsedSource -> [(Maybe String, Located String)]
docStringsFromModule ParsedSource
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 = ParsedSource -> HsModule GhcPs
forall l e. GenLocated l e -> e
unLoc ParsedSource
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  = [(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__ < 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

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

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

-- | Extract module annotations from given value.
extractModuleAnns :: Data a => a -> [Located String]
extractModuleAnns :: forall a. Data a => 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)
-> (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__ < 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
_ ->
      -- 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__ < 904
  HsPar _ (L l e) -> extractLit (locA l) e
#elif __GLASGOW_HASKELL__ < 909
  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
#else
  HsPar _ (L l e) -> extractLit (locA l) e
#endif
  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
  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

-- | 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)
-> (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

      -- Top-level documentation has to be treated separately, because it has
      -- no location information attached.  The location information is
      -- attached to HsDecl instead.
      DocD XDocD GhcPs
_ 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)

      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__ < 901
locA :: SrcSpan -> SrcSpan
locA = id
#endif