Skip to content
Browse files

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.
  • Loading branch information...
1 parent 5108cd5 commit d64d322078ddf4feaffe89fa250c2d4ade63bb33 @Philonous Philonous committed Dec 19, 2013
Showing with 114 additions and 3 deletions.
  1. +42 −2 Setup.hs
  2. +11 −1 pontarius-xmpp.cabal
  3. +25 −0 source/Network/Xmpp/Types.hs
  4. +36 −0 tests/Doctest.hs
View
44 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
View
12 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
View
25 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_
View
36 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

0 comments on commit d64d322

Please sign in to comment.
Something went wrong with that request. Please try again.