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
#if __GLASGOW_HASKELL__ < 707
import GHC hiding (flags, Module, Located)
import MonadUtils (liftIO, MonadIO)
#else
import GHC hiding (Module, Located)
import DynFlags
import MonadUtils (liftIO)
#endif
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)
import Sandbox (getSandboxArguments)
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
#if __GLASGOW_HASKELL__ < 707
let enableComp d = d { hscTarget = defaultObjectTarget }
#else
let enableComp d = let platform = targetPlatform d
in d { hscTarget = defaultObjectTarget platform }
#endif
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
#if __GLASGOW_HASKELL__ < 707
_ <- setSessionDynFlags (f dflags)
#else
let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of
Just "YES" -> gopt_set dflags Opt_BuildDynamicToo
_ -> dflags
_ <- setSessionDynFlags (f dflags')
#endif
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
sandboxArgs <- getSandboxArguments
let args' = args ++ sandboxArgs
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