doctest 0.9.8 → 0.9.9
raw patch · 3 files changed
+75/−45 lines, 3 files
Files
- doctest.cabal +1/−1
- src/Parse.hs +29/−3
- src/Sandbox.hs +45/−41
doctest.cabal view
@@ -1,5 +1,5 @@ name: doctest-version: 0.9.8+version: 0.9.9 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python
src/Parse.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE PatternGuards #-} module Parse ( Module (..) , DocTest (..)@@ -19,6 +20,7 @@ import Extract import Location + data DocTest = Example Expression ExpectedResult | Property Expression deriving (Eq, Show) @@ -77,9 +79,15 @@ isEndOfInteraction :: Located String -> Bool isEndOfInteraction x = isPrompt x || isBlankLine x + go :: [Located String] -> [Located Interaction] go xs = case dropWhile (not . isPrompt) xs of- prompt:rest ->+ prompt:rest + | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))),+ (ys,zs) <- break isBlankLine rest ->+ toInteraction prompt ys : go zs+ + | otherwise -> let (ys,zs) = break isEndOfInteraction rest in@@ -87,29 +95,47 @@ [] -> [] -- | Create an `Interaction`, strip superfluous whitespace as appropriate.+--+-- also merge lines between :{ and :}, preserving whitespace inside+-- the block (since this is useful for avoiding {;}). toInteraction :: Located String -> [Located String] -> Located Interaction toInteraction (Located loc x) xs = Located loc $ (- (strip $ drop 3 e) -- we do not care about leading and trailing+ (strip cleanedE) -- we do not care about leading and trailing -- whitespace in expressions, so drop them , result_ ) where -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, e) = span isSpace x+ (ePrompt, eRest) = splitAt 3 e -- 2. drop, if possible, the exact same sequence of whitespace -- characters from each result line -- -- 3. interpret lines that only contain the string "<BLANKLINE>" as an -- empty line- result_ = map (substituteBlankLine . tryStripPrefix prefix . unLoc) xs+ getResult pfx xs' = map (substituteBlankLine . tryStripPrefix pfx . unLoc) xs' where tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys substituteBlankLine "<BLANKLINE>" = "" substituteBlankLine line = line + + cleanBody line = fromMaybe (unLoc line)+ (stripPrefix ePrompt (dropWhile isSpace (unLoc line)))++ (cleanedE, result_)+ | (body , endLine : rest) <- break+ ( (==) [":}"] . take 1 . words . cleanBody)+ xs+ = (unlines (eRest : map cleanBody body +++ [dropWhile isSpace (cleanBody endLine)]),+ getResult (takeWhile isSpace (unLoc endLine)) rest)+ | otherwise = (eRest, getResult prefix xs)+ -- | Remove leading and trailing whitespace. strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse+
src/Sandbox.hs view
@@ -1,18 +1,17 @@-module Sandbox (getSandboxArguments) where+{-# LANGUAGE BangPatterns #-} +module Sandbox (getSandboxArguments, getPackageDbDir) where+ import Control.Applicative ((<$>))+import Control.Exception as E (catch, SomeException, throwIO) import Data.Char (isSpace) import Data.List (isPrefixOf, tails)-import System.Directory (getCurrentDirectory, doesFileExist, doesDirectoryExist)+import System.Directory (getCurrentDirectory, doesFileExist) import System.FilePath ((</>), takeDirectory, takeFileName)-import Control.Exception (handle, SomeException) configFile :: String configFile = "cabal.sandbox.config" -sandboxDir :: String-sandboxDir = ".cabal-sandbox"- pkgDbKey :: String pkgDbKey = "package-db:" @@ -20,53 +19,58 @@ pkgDbKeyLen = length pkgDbKey getSandboxArguments :: IO [String]-getSandboxArguments = do- mdir <- getCurrentDirectory >>= getSandboxDir- case mdir of- Nothing -> return []- Just (sdir,sconf) -> sandboxArguments sdir sconf+getSandboxArguments = (sandboxArguments <$> getPkgDb) `E.catch` handler+ where+ getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir+ handler :: SomeException -> IO [String]+ handler _ = return [] -getSandboxDir :: FilePath -> IO (Maybe (FilePath,FilePath))-getSandboxDir dir = do- exist <- doesSandboxExist dir+-- | Find a sandbox config file by tracing ancestor directories.+-- Exception is thrown if not found+getSandboxConfigFile :: FilePath -> IO FilePath+getSandboxConfigFile dir = do+ let cfile = dir </> configFile+ exist <- doesFileExist cfile if exist then- return $ Just (dir </> sandboxDir, dir </> configFile)+ return cfile else do let dir' = takeDirectory dir if dir == dir' then- return Nothing+ throwIO $ userError "sandbox config file not found" else- getSandboxDir dir'--doesSandboxExist :: FilePath -> IO Bool-doesSandboxExist dir = do- fileExist <- doesFileExist $ dir </> configFile- dirExist <- doesDirectoryExist $ dir </> sandboxDir- return (fileExist && dirExist)--sandboxArguments :: FilePath -> FilePath -> IO [String]-sandboxArguments sdir sconf = handle handler $ do- pkgDb <- getPackageDbDir sconf- let ver = extractGhcVer pkgDb- let (pkgDbOpt,noUserPkgDbOpt)- | ver < 706 = ("-package-conf","-no-user-package-conf")- | otherwise = ("-package-db", "-no-user-package-db")- pkgDbPath = sdir </> pkgDb- libPath = sdir </> "lib"- impOpt = "-i" ++ libPath- return [noUserPkgDbOpt, pkgDbOpt, pkgDbPath, impOpt]- where- handler :: SomeException -> IO [String]- handler _ = return []+ getSandboxConfigFile dir' +-- | Extract a package db directory from the sandbox config file.+-- Exception is thrown if the sandbox config file is broken. getPackageDbDir :: FilePath -> IO FilePath getPackageDbDir sconf = do- ls <- lines <$> readFile sconf- let [target] = filter ("package-db:" `isPrefixOf`) ls- return $ extractValue target+ -- Be strict to ensure that an error can be caught.+ !path <- extractValue . parse <$> readFile sconf+ return path where+ parse = head . filter ("package-db:" `isPrefixOf`) . lines extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen +-- | Adding necessary GHC options to the package db.+-- Exception is thrown if the string argument is incorrect.+--+-- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"+-- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"]+-- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"+-- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"]+sandboxArguments :: FilePath -> [String]+sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb]+ where+ ver = extractGhcVer pkgDb+ (pkgDbOpt,noUserPkgDbOpt)+ | ver < 706 = ("-package-conf","-no-user-package-conf")+ | otherwise = ("-package-db", "-no-user-package-db")++-- | Extracting GHC version from the path of package db.+-- Exception is thrown if the string argument is incorrect.+--+-- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"+-- 706 extractGhcVer :: String -> Int extractGhcVer dir = ver where