From d64d322078ddf4feaffe89fa250c2d4ade63bb33 Mon Sep 17 00:00:00 2001 From: Philipp Balzarek Date: Thu, 19 Dec 2013 23:31:52 +0100 Subject: [PATCH] add doctests doctests need some build magic in order for ghci to use the right modules. The support code is taken and adapted from the lens package. --- Setup.hs | 44 ++++++++++++++++++++++++++++++++++-- pontarius-xmpp.cabal | 12 +++++++++- source/Network/Xmpp/Types.hs | 25 ++++++++++++++++++++ tests/Doctest.hs | 36 +++++++++++++++++++++++++++++ 4 files changed, 114 insertions(+), 3 deletions(-) create mode 100644 tests/Doctest.hs diff --git a/Setup.hs b/Setup.hs index 9a994af..9312e98 100644 --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,42 @@ -import Distribution.Simple -main = defaultMain +-- pilfered from lens package +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +import Data.List ( nub ) +import Data.Version ( showVersion ) +import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName ) +import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) +import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) +import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles ) +import Distribution.Simple.BuildPaths ( autogenModulesDir ) +import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref)) +import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) +import Distribution.Text ( display ) +import Distribution.Verbosity ( Verbosity, normal ) +import System.FilePath ( () ) + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { buildHook = \pkg lbi hooks flags -> do + generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi + buildHook simpleUserHooks pkg lbi hooks flags + } + +generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () +generateBuildModule verbosity pkg lbi = do + let dir = autogenModulesDir lbi + createDirectoryIfMissingVerbose verbosity True dir + withLibLBI pkg lbi $ \_ libcfg -> do + withTestLBI pkg lbi $ \suite suitecfg -> do + rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines + [ "module Build_" ++ testName suite ++ " where" + , "deps :: [String]" + , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) + ] + where + formatdeps = map (formatone . snd) + formatone p = case packageName p of + PackageName n -> n ++ "-" ++ showVersion (packageVersion p) + +testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] +testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys diff --git a/pontarius-xmpp.cabal b/pontarius-xmpp.cabal index bb466ab..7847e76 100644 --- a/pontarius-xmpp.cabal +++ b/pontarius-xmpp.cabal @@ -1,7 +1,7 @@ Name: pontarius-xmpp Version: 0.3.0.2 Cabal-Version: >= 1.9.2 -Build-Type: Simple +Build-Type: Custom License: BSD3 License-File: LICENSE.md Copyright: Dmitry Astapov, Pierre Kovalev, Mahdi Abdinejadi, Jon Kristensen, @@ -154,6 +154,16 @@ Test-Suite tests , Tests.Arbitrary.Xmpp ghc-options: -Wall -O2 -fno-warn-orphans +Test-Suite doctest + Type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Doctest.hs + GHC-Options: -Wall -threaded + Build-Depends: base + , doctest + , directory + , filepath + benchmark benchmarks type: exitcode-stdio-1.0 build-depends: base diff --git a/source/Network/Xmpp/Types.hs b/source/Network/Xmpp/Types.hs index 8ca4545..f23dc0a 100644 --- a/source/Network/Xmpp/Types.hs +++ b/source/Network/Xmpp/Types.hs @@ -930,27 +930,52 @@ jidFromTexts l d r = do validPartLength p = Text.length p > 0 && Text.length p < 1024 -- | Returns 'True' if the JID is /bare/, and 'False' otherwise. +-- +-- >>> isBare [jidQ|foo@bar|] +-- True +-- +-- >>> isBare [jidQ|foo@bar/quux|] +-- False isBare :: Jid -> Bool isBare j | resourcepart j == Nothing = True | otherwise = False -- | Returns 'True' if the JID is /full/, and 'False' otherwise. +-- isFull = not . isBare +-- +-- >>> isBare [jidQ|foo@bar|] +-- True +-- +-- >>> isBare [jidQ|foo@bar/quux|] +-- False isFull :: Jid -> Bool isFull = not . isBare -- | Returns the @Jid@ without the resourcepart (if any). +-- +-- >>> toBare [jidQ|foo@bar/quux|] == [jidQ|foo@bar|] +-- True toBare :: Jid -> Jid toBare j = j{resourcepart_ = Nothing} -- | Returns the localpart of the @Jid@ (if any). +-- +-- >>> localpart [jidQ|foo@bar/quux|] +-- Just "foo" localpart :: Jid -> Maybe Text localpart = fmap text . localpart_ -- | Returns the domainpart of the @Jid@. +-- +-- >>> domainpart [jidQ|foo@bar/quux|] +-- "bar" domainpart :: Jid -> Text domainpart = text . domainpart_ -- | Returns the resourcepart of the @Jid@ (if any). +-- +-- >>> resourcepart [jidQ|foo@bar/quux|] +-- Just "quux" resourcepart :: Jid -> Maybe Text resourcepart = fmap text . resourcepart_ diff --git a/tests/Doctest.hs b/tests/Doctest.hs new file mode 100644 index 0000000..9f4e09a --- /dev/null +++ b/tests/Doctest.hs @@ -0,0 +1,36 @@ +-- pilfered from lens package + +module Main(main) where + +import Build_doctest (deps) + +import Control.Applicative +import Control.Monad +import Data.List +import System.Directory +import System.FilePath +import Test.DocTest + +main :: IO () +main = doctest $ + "-isource" + : "-idist/build/autogen" + : "-hide-all-packages" + : "-XQuasiQuotes" + : "-DWITH_TEMPLATE_HASKELL" + : map ("-package="++) deps ++ sources + +sources :: [String] +sources = ["source/Network/Xmpp/Types.hs"] + +-- getSources :: IO [FilePath] +-- getSources = filter (isSuffixOf ".hs") <$> go "source" +-- where +-- go dir = do +-- (dirs, files) <- getFilesAndDirectories dir +-- (files ++) . concat <$> mapM go dirs + +-- getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) +-- getFilesAndDirectories dir = do +-- c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir +-- (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c