diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,5 +1,5 @@ name: doctest -version: 0.11.2 +version: 0.11.3 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python @@ -37,7 +37,7 @@ , GhcUtil , Interpreter , Location - , Help + , Options , PackageDBs , Parse , Paths_doctest diff --git a/src/Help.hs b/src/Help.hs deleted file mode 100644 --- a/src/Help.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Help ( - usage -, printVersion -) where - -import Paths_doctest (version) -import Data.Version (showVersion) -import Config as GHC -import Interpreter (ghc) - -usage :: String -usage = unlines [ - "Usage:" - , " doctest [ GHC OPTION | MODULE ]..." - , " doctest --help" - , " doctest --version" - , "" - , "Options:" - , " --help display this help and exit" - , " --version output version information and exit" - ] - -printVersion :: IO () -printVersion = do - putStrLn ("doctest version " ++ showVersion version) - putStrLn ("using version " ++ GHC.cProjectVersion ++ " of the GHC API") - putStrLn ("using " ++ ghc) diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE CPP #-} +module Options ( + Result(..) +, Run(..) +, parseOptions +#ifdef TEST +, usage +, info +, versionInfo +#endif +) where + +import Prelude () +import Prelude.Compat + +import Data.List.Compat +import Data.Maybe + +import qualified Paths_doctest +import Data.Version (showVersion) +import Config as GHC +import Interpreter (ghc) + +usage :: String +usage = unlines [ + "Usage:" + , " doctest [ --no-magic | GHC OPTION | MODULE ]..." + , " doctest --help" + , " doctest --version" + , " doctest --info" + , "" + , "Options:" + , " --help display this help and exit" + , " --version output version information and exit" + , " --info output machine-readable version information and exit" + ] + +version :: String +version = showVersion Paths_doctest.version + +ghcVersion :: String +ghcVersion = GHC.cProjectVersion + +versionInfo :: String +versionInfo = unlines [ + "doctest version " ++ version + , "using version " ++ ghcVersion ++ " of the GHC API" + , "using " ++ ghc + ] + +info :: String +info = "[ " ++ (intercalate "\n, " . map show $ [ + ("version", version) + , ("ghc_version", ghcVersion) + , ("ghc", ghc) + ]) ++ "\n]\n" + +data Result = Output String | Result Run + deriving (Eq, Show) + +type Warning = String + +data Run = Run { + runWarnings :: [Warning] +, runOptions :: [String] +, runMagicMode :: Bool +} deriving (Eq, Show) + +parseOptions :: [String] -> Result +parseOptions args + | "--help" `elem` args = Output usage + | "--info" `elem` args = Output info + | "--version" `elem` args = Output versionInfo + | otherwise = case stripOptGhc <$> stripNoMagic args of + (magicMode, (warning, xs)) -> Result (Run (maybeToList warning) xs magicMode) + +stripNoMagic :: [String] -> (Bool, [String]) +stripNoMagic args = (noMagic `notElem` args, filter (/= noMagic) args) + where + noMagic = "--no-magic" + +stripOptGhc :: [String] -> (Maybe Warning, [String]) +stripOptGhc = go + where + go args = case args of + [] -> (Nothing, []) + "--optghc" : opt : rest -> (Just warning, opt : snd (go rest)) + opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (Just warning, x : xs)) (stripPrefix "--optghc=" opt) (go rest) + + warning = "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -53,8 +53,10 @@ -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's -getDocTests args = do - filter (not . isEmpty) . map parseModule <$> extract args +getDocTests args = parseModules <$> extract args + +parseModules :: [Module (Located String)] -> [Module [Located DocTest]] +parseModules = filter (not . isEmpty) . map parseModule where isEmpty (Module _ setup tests) = null tests && isNothing setup diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -4,7 +4,6 @@ #ifdef TEST , doctest_ , Summary -, stripOptGhc , expandDirs #endif ) where @@ -12,7 +11,6 @@ import Prelude () import Prelude.Compat -import Data.List.Compat import Control.Monad (when, unless) import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import System.Environment (getEnvironment) @@ -26,7 +24,7 @@ import PackageDBs import Parse -import Help +import Options import Runner import qualified Interpreter @@ -43,33 +41,33 @@ -- If a directory is given, it is traversed to find all .hs and .lhs files -- inside of it, ignoring hidden entries. doctest :: [String] -> IO () -doctest args0 - | "--help" `elem` args0 = putStr usage - | "--version" `elem` args0 = printVersion - | otherwise = do - args <- concat <$> mapM expandDirs args0 - i <- Interpreter.interpreterSupported - unless i $ do - hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" - exitSuccess +doctest args0 = case parseOptions args0 of + Output s -> putStr s + Result (Run warnings args_ magicMode) -> do + mapM_ (hPutStrLn stderr) warnings + hFlush stderr - let (f, args_) = stripOptGhc args - when f $ do - hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." - hFlush stderr + i <- Interpreter.interpreterSupported + unless i $ do + hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" + exitSuccess - packageDBArgs <- getPackageDBArgs - let addPackageConf = (packageDBArgs ++) - addDistArgs <- getAddDistArgs + args <- case magicMode of + False -> return args_ + True -> do + expandedArgs <- concat <$> mapM expandDirs args_ + packageDBArgs <- getPackageDBArgs + addDistArgs <- getAddDistArgs + return (addDistArgs $ packageDBArgs ++ expandedArgs) - r <- doctest_ (addDistArgs $ addPackageConf args_) `E.catch` \e -> do - case fromException e of - Just (UsageError err) -> do - hPutStrLn stderr ("doctest: " ++ err) - hPutStrLn stderr "Try `doctest --help' for more information." - exitFailure - _ -> E.throwIO e - when (not $ isSuccess r) exitFailure + r <- doctest_ args `E.catch` \e -> do + case fromException e of + Just (UsageError err) -> do + hPutStrLn stderr ("doctest: " ++ err) + hPutStrLn stderr "Try `doctest --help' for more information." + exitFailure + _ -> E.throwIO e + when (not $ isSuccess r) exitFailure -- | Expand a reference to a directory to all .hs and .lhs files within it. expandDirs :: String -> IO [String] @@ -124,20 +122,6 @@ isSuccess :: Summary -> Bool isSuccess s = sErrors s == 0 && sFailures s == 0 - --- | --- Strip --optghc from GHC options. This is for backward compatibility with --- previous versions of doctest. --- --- A boolean is returned with the stripped arguments. It is True if striping --- occurred. -stripOptGhc :: [String] -> (Bool, [String]) -stripOptGhc = go - where - go args = case args of - [] -> (False, []) - "--optghc" : opt : rest -> (True, opt : snd (go rest)) - opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x :xs)) (stripPrefix "--optghc=" opt) (go rest) doctest_ :: [String] -> IO Summary doctest_ args = do