trying to get doctests working

README.md

@@ -60,7 +60,7 @@ import Data.Time.Calendar (Day(..))
 import Data.Time.Clock (secondsToDiffTime, UTCTime(..))
 import Data.Text (Text)
 import GHC.Generics (Generic)
-import Network.HTTP.Conduit
+import Network.HTTP.Client
 import qualified Network.HTTP.Types.Status as NHTS
 
 -- no trailing slashes in servers, library handles building the path.

Setup.hs

@@ -1,2 +1,51 @@
-import Distribution.Simple
-main = defaultMain
+{-# 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
+  , postHaddock = \args flags pkg lbi -> do
+     copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]
+     postHaddock simpleUserHooks args flags pkg lbi
+  }
+
+haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath
+haddockOutputDir flags pkg = destDir where
+  baseDir = case haddockDistPref flags of
+    NoFlag -> "."
+    Flag x -> x
+  destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)
+
+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

bloodhound.cabal

@@ -57,3 +57,26 @@ test-suite tests
                        vector,
                        unordered-containers >= 0.2.5.0 && <0.3
   default-language:    Haskell2010
+
+test-suite doctests
+  default-language: Haskell2010
+  default-extensions: OverloadedStrings
+  type:             exitcode-stdio-1.0
+  main-is:          doctests.hs
+  hs-source-dirs:   tests
+  build-depends:    base,
+                    doctest,
+                    doctest-prop,
+                    directory,
+                    filepath
+
+-- test-suite doctests
+--   type:               exitcode-stdio-1.0
+--   ghc-options:        -threaded
+--   main-is:            doctest-driver.hs
+--   hs-source-dirs:     tests
+--   build-depends:      base >4 && <5
+--                     , doctest
+--                     , doctest-discover
+--                     , doctest-prop
+--   default-language:   Haskell2010

src/Database/Bloodhound/Client.hs

@@ -1,3 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-------------------------------------------------------------------------------
+-- |
+-- Module : Database.Bloodhound.Types
+-- Copyright : (C) 2014 Chris Allen
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Chris Allen <cma@bitemyapp.com
+-- Stability : provisional
+-- Portability : DeriveGeneric, RecordWildCards
+--
+-- Data types for describing actions and data structures performed to interact
+-- with Elasticsearch. The two main buckets your queries against Elasticsearch
+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like
+-- traditional database constraints and often have preferable performance
+-- properties. 'Query's support human-written textual queries, such as fuzzy
+-- queries.
+-------------------------------------------------------------------------------
+
 module Database.Bloodhound.Client
        ( createIndex
        , deleteIndex
@@ -41,15 +60,22 @@ import           Prelude                    hiding (filter, head)
 
 import           Database.Bloodhound.Types
 
--- find way to avoid destructuring Servers and Indexes?
--- make get, post, put, delete helpers.
--- make dispatch take URL last for better variance and
--- utilization of partial application
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Database.Bloodhound
+-- >>> import Test.DocTest.Prop (assert)
+-- >>> error "blah"
+-- no trailing slashes in servers, library handles building the path.
+-- >>> let testServer = (Server "http://localhost:9200")
+-- >>> let testIndex = IndexName "twitter"
+-- >>> let testMapping = MappingName "tweet"
+-- defaultIndexSettings is exported by Database.Bloodhound as well
+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
 
 mkShardCount :: Int -> Maybe ShardCount
 mkShardCount n
   | n < 1 = Nothing
-  | n > 1000 = Nothing -- seriously, what the fuck?
+  | n > 1000 = Nothing
   | otherwise = Just (ShardCount n)
 
 mkReplicaCount :: Int -> Maybe ReplicaCount
@@ -96,6 +122,12 @@ getStatus (Server server) = do
   response <- withManager defaultManagerSettings $ httpLbs request
   return $ decode (responseBody response)
 
+-- | createIndex will create an index given a 'Server',
+-- 'IndexSettings', and an 'IndexName'
+
+-- >>> response <- createIndex testServer defaultIndexSettings testIndex
+-- >>> assert $ respIsTwoHunna response
+-- >>> assert False
 createIndex :: Server -> IndexSettings -> IndexName -> IO Reply
 createIndex (Server server) indexSettings (IndexName indexName) =
   put url body

src/Database/Bloodhound/Types.hs

@@ -1,13 +1,25 @@
 {-# LANGUAGE DeriveGeneric   #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 
-{-| Data types for describing actions and data structures performed to interact
-    with Elasticsearch. The two main buckets your queries against Elasticsearch
-    will fall into are 'Query's and 'Filter's. 'Filter's are more like
-    traditional database constraints and often have preferable performance
-    properties. 'Query's support human-written textual queries, such as fuzzy
-    queries.
--}
+-------------------------------------------------------------------------------
+-- |
+-- Module : Database.Bloodhound.Types
+-- Copyright : (C) 2014 Chris Allen
+-- License : BSD-style (see the file LICENSE)
+-- Maintainer : Chris Allen <cma@bitemyapp.com
+-- Stability : provisional
+-- Portability : DeriveGeneric, RecordWildCards
+--
+-- Data types for describing actions and data structures performed to interact
+-- with Elasticsearch. The two main buckets your queries against Elasticsearch
+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like
+-- traditional database constraints and often have preferable performance
+-- properties. 'Query's support human-written textual queries, such as fuzzy
+-- queries.
+-------------------------------------------------------------------------------
+
+
 
 module Database.Bloodhound.Types
        ( defaultCache
@@ -197,6 +209,16 @@ import qualified Network.HTTP.Types.Method       as NHTM
 
 import           Database.Bloodhound.Types.Class
 
+-- $setup
+-- >>> :set -XOverloadedStrings
+-- >>> import Database.Bloodhound
+-- no trailing slashes in servers, library handles building the path.
+-- >>> let testServer = (Server "http://localhost:9200")
+-- >>> let testIndex = IndexName "twitter"
+-- >>> let testMapping = MappingName "tweet"
+
+-- defaultIndexSettings is exported by Database.Bloodhound as well
+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)
 
 {-| 'Version' is embedded in 'Status' -}
 data Version = Version { number          :: Text
@@ -1007,7 +1029,7 @@ data DistanceRange =
   DistanceRange { distanceFrom :: Distance
                 , distanceTo   :: Distance } deriving (Eq, Show)
 
-data (FromJSON a) => SearchResult a =
+data SearchResult a =
   SearchResult { took         :: Int
                , timedOut     :: Bool
                , shards       :: ShardResult
@@ -1016,12 +1038,12 @@ data (FromJSON a) => SearchResult a =
 
 type Score = Double
 
-data (FromJSON a) => SearchHits a =
+data SearchHits a =
   SearchHits { hitsTotal :: Int
              , maxScore  :: Score
              , hits      :: [Hit a] } deriving (Eq, Show)
 
-data (FromJSON a) => Hit a =
+data Hit a =
   Hit { hitIndex     :: IndexName
       , hitType      :: MappingName
       , hitDocId     :: DocId
@@ -1186,7 +1208,7 @@ class BucketAggregation a where
   aggs :: a -> Maybe AggregationResults
 
 
-data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)
+data Bucket a = Bucket { buckets :: [a]} deriving (Show)
 
 data TermsResult = TermsResult { termKey       :: Text
                                , termsDocCount :: Int

tests/doctests.hsc

@@ -0,0 +1,74 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Main (doctests)
+-- Copyright   :  (C) 2014 Chris Allen
+-- License     :  BSD-style (see the file LICENSE)
+-- Maintainer  :  Chris Allen <cma@bitemyapp.com>
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- This module provides doctests for a project based on the actual versions
+-- of the packages it was built with. It requires a corresponding Setup.lhs
+-- to be added to the project
+-----------------------------------------------------------------------------
+
+module Main where
+
+import Build_doctests (deps)
+import Control.Applicative
+import Control.Monad
+import Data.List
+import System.Directory
+import System.FilePath
+import Test.DocTest
+
+##if defined(mingw32_HOST_OS)
+##if defined(i386_HOST_ARCH)
+##define USE_CP
+import Control.Applicative
+import Control.Exception
+import Foreign.C.Types
+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
+##elif defined(x86_64_HOST_ARCH)
+##define USE_CP
+import Control.Applicative
+import Control.Exception
+import Foreign.C.Types
+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool
+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt
+##endif
+##endif
+
+-- | Run in a modified codepage where we can print UTF-8 values on Windows.
+withUnicode :: IO a -> IO a
+##ifdef USE_CP
+withUnicode m = do
+  cp <- c_GetConsoleCP
+  (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp
+##else
+withUnicode m = m
+##endif
+
+main :: IO ()
+main = withUnicode $ getSources >>= \sources -> doctest $
+    "-isrc"
+  : "-idist/build/autogen"
+  : "-optP-include"
+  : "-optPdist/build/autogen/cabal_macros.h"
+  : "-hide-all-packages"
+  : map ("-package="++) deps ++ sources
+
+getSources :: IO [FilePath]
+getSources = filter (isSuffixOf ".hs") <$> go "src"
+  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

tests/tests.hs

@@ -499,9 +499,9 @@ main = hspec $ do
       _ <- insertData
       _ <- insertOther
       let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
-      let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
+      let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]
 
-      let search = mkHighlightSearch (Just query) highlight
+      let search = mkHighlightSearch (Just query) testHighlight
       myHighlight <- searchTweetHighlight search
       myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))
 
@@ -509,9 +509,9 @@ main = hspec $ do
       _ <- insertData
       _ <- insertOther
       let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")
-      let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
+      let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]
 
-      let search = mkHighlightSearch (Just query) highlight
+      let search = mkHighlightSearch (Just query) testHighlight
       myHighlight <- searchTweetHighlight search
       myHighlight `shouldBe` Right Nothing