module Extract (Module(..), extract) where
import Prelude hiding (mod, concat)
import Control.Monad
import Control.Applicative
import Control.Exception
import Data.List (partition, isSuffixOf)
import Data.Maybe
import Data.Foldable (concat)
import Control.DeepSeq (deepseq, NFData(rnf))
import Data.Generics
import GHC hiding (flags, Module, Located)
import MonadUtils (liftIO, MonadIO)
import Exception (ExceptionMonad)
import System.Directory
import System.FilePath
import NameSet (NameSet)
import Coercion (Coercion)
import FastString (unpackFS)
import Digraph (flattenSCCs)
import System.Posix.Internals (c_getpid)
import GhcUtil (withGhc)
import Location hiding (unLoc)
import Util (convertDosLineEndings)
newtype ExtractError = ExtractError SomeException
deriving Typeable
instance Show ExtractError where
show (ExtractError e) =
unlines [
"Ouch! Hit an error thunk in GHC's AST while extracting documentation."
, ""
, " " ++ msg
, ""
, "This is most likely a bug in doctest."
, ""
, "Please report it here: https://github.com/sol/doctest-haskell/issues/new"
]
where
msg = case fromException e of
Just (Panic s) -> "GHC panic: " ++ s
_ -> show e
instance Exception ExtractError
data Module a = Module {
moduleName :: String
, moduleSetup :: Maybe a
, moduleContent :: [a]
} deriving (Eq, Functor)
instance NFData a => NFData (Module a) where
rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` ()
parse :: [String] -> IO [TypecheckedModule]
parse args = withGhc args $ \modules_ -> withTempOutputDir $ do
let modules = filter (not . isSuffixOf ".o") modules_
mapM (`guessTarget` Nothing) modules >>= setTargets
mods <- depanal [] False
mods' <- if needsTemplateHaskell mods then enableCompilation mods else return mods
let sortedMods = flattenSCCs (topSortModuleGraph False mods' Nothing)
reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods
where
enableCompilation :: ModuleGraph -> Ghc ModuleGraph
enableCompilation modGraph = do
let enableComp d = d { hscTarget = defaultObjectTarget }
modifySessionDynFlags enableComp
let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }
let modGraph' = map upd modGraph
return modGraph'
modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()
modifySessionDynFlags f = do
dflags <- getSessionDynFlags
_ <- setSessionDynFlags (f dflags)
return ()
withTempOutputDir :: Ghc a -> Ghc a
withTempOutputDir action = do
tmp <- liftIO getTemporaryDirectory
x <- liftIO c_getpid
let dir = tmp </> ".doctest-" ++ show x
modifySessionDynFlags (setOutputDir dir)
gbracket_
(liftIO $ createDirectory dir)
(liftIO $ removeDirectoryRecursive dir)
action
gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c
gbracket_ before_ after thing = gbracket before_ (const after) (const thing)
setOutputDir f d = d {
objectDir = Just f
, hiDir = Just f
, stubDir = Just f
, includePaths = f : includePaths d
}
extract :: [String] -> IO [Module (Located String)]
extract args = do
mods <- parse args
let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods
(docs `deepseq` return docs) `catches` [
Handler (\e -> throw (e :: AsyncException))
, Handler (throwIO . ExtractError)
]
extractFromModule :: ParsedModule -> Module (Located String)
extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs)
where
isSetup = (== Just "setup") . fst
(setup, docs) = partition isSetup (docStringsFromModule m)
name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m
docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)]
docStringsFromModule mod = map (fmap (toLocated . fmap unpackDocString)) docs
where
source = (unLoc . pm_parsed_source) mod
docs = header ++ exports ++ decls
header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]]
exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- concat (hsmodExports source)]
decls = extractDocStrings (hsmodDecls source)
type Selector a = a -> ([(Maybe String, LHsDocString)], Bool)
ignore :: Selector a
ignore = const ([], True)
select :: a -> ([a], Bool)
select x = ([x], False)
extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)]
extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl
`extQ` fromLDocDecl
`extQ` fromLHsDocString
`extQ` (ignore :: Selector NameSet)
`extQ` (ignore :: Selector PostTcKind)
`extQ` (ignore :: Selector (HsExpr RdrName))
`extQ` (ignore :: Selector Coercion)
#if __GLASGOW_HASKELL__ >= 706
`extQ` (ignore :: Selector (HsWithBndrs [LHsType RdrName]))
`extQ` (ignore :: Selector (HsWithBndrs [LHsType Name]))
`extQ` (ignore :: Selector (HsWithBndrs (LHsType RdrName)))
`extQ` (ignore :: Selector (HsWithBndrs (LHsType Name)))
#endif
)
where
fromLHsDecl :: Selector (LHsDecl RdrName)
fromLHsDecl (L loc decl) = case decl of
DocD x -> select (fromDocDecl loc x)
_ -> (extractDocStrings decl, True)
fromLDocDecl :: Selector LDocDecl
fromLDocDecl (L loc x) = select (fromDocDecl loc x)
fromLHsDocString :: Selector LHsDocString
fromLHsDocString x = select (Nothing, x)
fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString)
fromDocDecl loc x = case x of
DocCommentNamed name doc -> (Just name, L loc doc)
_ -> (Nothing, L loc $ docDeclDoc x)
unpackDocString :: HsDocString -> String
unpackDocString (HsDocString s) = unpackFS s