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

@@ -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

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

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_
 

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