b5cf74d · typeable/bloodhound

git.iko.soy/typeable/bloodhound

trying to get doctests working

commitb5cf74df90ccb7137f17bae76bb11f7c146108a2 authorChris Allen <cma@bitemyapp.com> dateWed 10 Dec 2014, 14:17 (12 years ago) parentb26300e

7 files changed+223−23

compare with master

unifiedsplit

README.md+1−1 Setup.hs+51−2 bloodhound.cabal+23 src/Database/Bloodhound/Client.hs+37−5 src/Database/Bloodhound/Types.hs+33−11 tests/doctests.hsc+74 tests/tests.hs+4−4

README.md+1−1

@@ -60,7 +60,7 @@ import Data.Time.Calendar (Day(..))

6060import Data.Time.Clock (secondsToDiffTime, UTCTime(..))

6161import Data.Text (Text)

6262import GHC.Generics (Generic)

63−import Network.HTTP.Conduit

63+import Network.HTTP.Client

6464import qualified Network.HTTP.Types.Status as NHTS

6565

6666-- no trailing slashes in servers, library handles building the path.

Setup.hs+51−2

@@ -1,2 +1,51 @@

1−import Distribution.Simple

2−main = defaultMain

1+{-# OPTIONS_GHC -Wall #-}

2+module Main (main) where

4+import Data.List ( nub )

5+import Data.Version ( showVersion )

6+import Distribution.Package ( PackageName(PackageName), Package, PackageId, InstalledPackageId, packageVersion, packageName )

7+import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )

8+import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )

9+import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose, copyFiles )

10+import Distribution.Simple.BuildPaths ( autogenModulesDir )

11+import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), Flag(..), fromFlag, HaddockFlags(haddockDistPref))

12+import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )

13+import Distribution.Text ( display )

14+import Distribution.Verbosity ( Verbosity, normal )

15+import System.FilePath ( (</>) )

16+

17+main :: IO ()

18+main = defaultMainWithHooks simpleUserHooks

19+ { buildHook = \pkg lbi hooks flags -> do

20+ generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi

21+ buildHook simpleUserHooks pkg lbi hooks flags

22+ , postHaddock = \args flags pkg lbi -> do

23+ copyFiles normal (haddockOutputDir flags pkg) [("images","Hierarchy.png")]

24+ postHaddock simpleUserHooks args flags pkg lbi

25+ }

26+

27+haddockOutputDir :: Package p => HaddockFlags -> p -> FilePath

28+haddockOutputDir flags pkg = destDir where

29+ baseDir = case haddockDistPref flags of

30+ NoFlag -> "."

31+ Flag x -> x

32+ destDir = baseDir </> "doc" </> "html" </> display (packageName pkg)

33+

34+generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO ()

35+generateBuildModule verbosity pkg lbi = do

36+ let dir = autogenModulesDir lbi

37+ createDirectoryIfMissingVerbose verbosity True dir

38+ withLibLBI pkg lbi $ \_ libcfg -> do

39+ withTestLBI pkg lbi $ \suite suitecfg -> do

40+ rewriteFile (dir </> "Build_" ++ testName suite ++ ".hs") $ unlines

41+ [ "module Build_" ++ testName suite ++ " where"

42+ , "deps :: [String]"

43+ , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg))

44+ ]

45+ where

46+ formatdeps = map (formatone . snd)

47+ formatone p = case packageName p of

48+ PackageName n -> n ++ "-" ++ showVersion (packageVersion p)

49+

50+testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]

51+testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys

bloodhound.cabal+23

@@ -57,3 +57,26 @@ test-suite tests

5757 vector,

5858 unordered-containers >= 0.2.5.0 && <0.3

5959 default-language: Haskell2010

60+

61+test-suite doctests

62+ default-language: Haskell2010

63+ default-extensions: OverloadedStrings

64+ type: exitcode-stdio-1.0

65+ main-is: doctests.hs

66+ hs-source-dirs: tests

67+ build-depends: base,

68+ doctest,

69+ doctest-prop,

70+ directory,

71+ filepath

72+

73+-- test-suite doctests

74+-- type: exitcode-stdio-1.0

75+-- ghc-options: -threaded

76+-- main-is: doctest-driver.hs

77+-- hs-source-dirs: tests

78+-- build-depends: base >4 && <5

79+-- , doctest

80+-- , doctest-discover

81+-- , doctest-prop

82+-- default-language: Haskell2010

src/Database/Bloodhound/Client.hs+37−5

@@ -1,3 +1,22 @@

1+{-# LANGUAGE OverloadedStrings #-}

3+-------------------------------------------------------------------------------

4+-- |

5+-- Module : Database.Bloodhound.Types

7+-- License : BSD-style (see the file LICENSE)

8+-- Maintainer : Chris Allen <cma@bitemyapp.com

9+-- Stability : provisional

10+-- Portability : DeriveGeneric, RecordWildCards

11+--

12+-- Data types for describing actions and data structures performed to interact

13+-- with Elasticsearch. The two main buckets your queries against Elasticsearch

14+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like

15+-- traditional database constraints and often have preferable performance

16+-- properties. 'Query's support human-written textual queries, such as fuzzy

17+-- queries.

18+-------------------------------------------------------------------------------

19+

120module Database.Bloodhound.Client

221 ( createIndex

322 , deleteIndex

@@ -41,15 +60,22 @@ import Prelude hiding (filter, head)

4160

4261import Database.Bloodhound.Types

4362

44−-- find way to avoid destructuring Servers and Indexes?

45−-- make get, post, put, delete helpers.

46−-- make dispatch take URL last for better variance and

47−-- utilization of partial application

63+-- $setup

64+-- >>> :set -XOverloadedStrings

65+-- >>> import Database.Bloodhound

66+-- >>> import Test.DocTest.Prop (assert)

67+-- >>> error "blah"

68+-- no trailing slashes in servers, library handles building the path.

69+-- >>> let testServer = (Server "http://localhost:9200")

70+-- >>> let testIndex = IndexName "twitter"

71+-- >>> let testMapping = MappingName "tweet"

72+-- defaultIndexSettings is exported by Database.Bloodhound as well

73+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)

4874

4975mkShardCount :: Int -> Maybe ShardCount

5076mkShardCount n

5177 | n < 1 = Nothing

52− | n > 1000 = Nothing -- seriously, what the fuck?

78+ | n > 1000 = Nothing

5379 | otherwise = Just (ShardCount n)

5480

5581mkReplicaCount :: Int -> Maybe ReplicaCount

@@ -96,6 +122,12 @@ getStatus (Server server) = do

96122 response <- withManager defaultManagerSettings $ httpLbs request

97123 return $ decode (responseBody response)

98124

125+-- | createIndex will create an index given a 'Server',

126+-- 'IndexSettings', and an 'IndexName'

127+

128+-- >>> response <- createIndex testServer defaultIndexSettings testIndex

129+-- >>> assert $ respIsTwoHunna response

130+-- >>> assert False

99131createIndex :: Server -> IndexSettings -> IndexName -> IO Reply

100132createIndex (Server server) indexSettings (IndexName indexName) =

101133 put url body

src/Database/Bloodhound/Types.hs+33−11

@@ -1,13 +1,25 @@

11{-# LANGUAGE DeriveGeneric #-}

2+{-# LANGUAGE OverloadedStrings #-}

23{-# LANGUAGE RecordWildCards #-}

4−{-| Data types for describing actions and data structures performed to interact

5− with Elasticsearch. The two main buckets your queries against Elasticsearch

6− will fall into are 'Query's and 'Filter's. 'Filter's are more like

7− traditional database constraints and often have preferable performance

8− properties. 'Query's support human-written textual queries, such as fuzzy

9− queries.

10−-}

5+-------------------------------------------------------------------------------

6+-- |

7+-- Module : Database.Bloodhound.Types

9+-- License : BSD-style (see the file LICENSE)

10+-- Maintainer : Chris Allen <cma@bitemyapp.com

11+-- Stability : provisional

12+-- Portability : DeriveGeneric, RecordWildCards

13+--

14+-- Data types for describing actions and data structures performed to interact

15+-- with Elasticsearch. The two main buckets your queries against Elasticsearch

16+-- will fall into are 'Query's and 'Filter's. 'Filter's are more like

17+-- traditional database constraints and often have preferable performance

18+-- properties. 'Query's support human-written textual queries, such as fuzzy

19+-- queries.

20+-------------------------------------------------------------------------------

21+

22+

1123

1224module Database.Bloodhound.Types

1325 ( defaultCache

@@ -197,6 +209,16 @@ import qualified Network.HTTP.Types.Method as NHTM

197209

198210import Database.Bloodhound.Types.Class

199211

212+-- $setup

213+-- >>> :set -XOverloadedStrings

214+-- >>> import Database.Bloodhound

215+-- no trailing slashes in servers, library handles building the path.

216+-- >>> let testServer = (Server "http://localhost:9200")

217+-- >>> let testIndex = IndexName "twitter"

218+-- >>> let testMapping = MappingName "tweet"

219+

220+-- defaultIndexSettings is exported by Database.Bloodhound as well

221+-- >>> let defaultIndexSettings = IndexSettings (ShardCount 3) (ReplicaCount 2)

200222

201223{-| 'Version' is embedded in 'Status' -}

202224data Version = Version { number :: Text

@@ -1007,7 +1029,7 @@ data DistanceRange =

10071029 DistanceRange { distanceFrom :: Distance

10081030 , distanceTo :: Distance } deriving (Eq, Show)

10091031

1010−data (FromJSON a) => SearchResult a =

1032+data SearchResult a =

10111033 SearchResult { took :: Int

10121034 , timedOut :: Bool

10131035 , shards :: ShardResult

@@ -1016,12 +1038,12 @@ data (FromJSON a) => SearchResult a =

10161038

10171039type Score = Double

10181040

1019−data (FromJSON a) => SearchHits a =

1041+data SearchHits a =

10201042 SearchHits { hitsTotal :: Int

10211043 , maxScore :: Score

10221044 , hits :: [Hit a] } deriving (Eq, Show)

10231045

1024−data (FromJSON a) => Hit a =

1046+data Hit a =

10251047 Hit { hitIndex :: IndexName

10261048 , hitType :: MappingName

10271049 , hitDocId :: DocId

@@ -1186,7 +1208,7 @@ class BucketAggregation a where

11861208 aggs :: a -> Maybe AggregationResults

11871209

11881210

1189−data (FromJSON a, BucketAggregation a) => Bucket a = Bucket { buckets :: [a]} deriving (Show)

1211+data Bucket a = Bucket { buckets :: [a]} deriving (Show)

11901212

11911213data TermsResult = TermsResult { termKey :: Text

11921214 , termsDocCount :: Int

tests/doctests.hscnew file+74

@@ -0,0 +1,74 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE ForeignFunctionInterface #-}

3+-----------------------------------------------------------------------------

4+-- |

5+-- Module : Main (doctests)

7+-- License : BSD-style (see the file LICENSE)

8+-- Maintainer : Chris Allen <cma@bitemyapp.com>

9+-- Stability : provisional

10+-- Portability : portable

11+--

12+-- This module provides doctests for a project based on the actual versions

13+-- of the packages it was built with. It requires a corresponding Setup.lhs

14+-- to be added to the project

15+-----------------------------------------------------------------------------

16+

17+module Main where

18+

19+import Build_doctests (deps)

20+import Control.Applicative

21+import Control.Monad

22+import Data.List

23+import System.Directory

24+import System.FilePath

25+import Test.DocTest

26+

27+##if defined(mingw32_HOST_OS)

28+##if defined(i386_HOST_ARCH)

29+##define USE_CP

30+import Control.Applicative

31+import Control.Exception

32+import Foreign.C.Types

33+foreign import stdcall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool

34+foreign import stdcall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt

35+##elif defined(x86_64_HOST_ARCH)

36+##define USE_CP

37+import Control.Applicative

38+import Control.Exception

39+import Foreign.C.Types

40+foreign import ccall "windows.h SetConsoleCP" c_SetConsoleCP :: CUInt -> IO Bool

41+foreign import ccall "windows.h GetConsoleCP" c_GetConsoleCP :: IO CUInt

42+##endif

43+##endif

44+

45+-- | Run in a modified codepage where we can print UTF-8 values on Windows.

46+withUnicode :: IO a -> IO a

47+##ifdef USE_CP

48+withUnicode m = do

49+ cp <- c_GetConsoleCP

50+ (c_SetConsoleCP 65001 >> m) `finally` c_SetConsoleCP cp

51+##else

52+withUnicode m = m

53+##endif

54+

55+main :: IO ()

56+main = withUnicode $ getSources >>= \sources -> doctest $

57+ "-isrc"

58+ : "-idist/build/autogen"

59+ : "-optP-include"

60+ : "-optPdist/build/autogen/cabal_macros.h"

61+ : "-hide-all-packages"

62+ : map ("-package="++) deps ++ sources

63+

64+getSources :: IO [FilePath]

65+getSources = filter (isSuffixOf ".hs") <$> go "src"

66+ where

67+ go dir = do

68+ (dirs, files) <- getFilesAndDirectories dir

69+ (files ++) . concat <$> mapM go dirs

70+

71+getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])

72+getFilesAndDirectories dir = do

73+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir

74+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c

tests/tests.hs+4−4

@@ -499,9 +499,9 @@ main = hspec $ do

499499 _ <- insertData

500500 _ <- insertOther

501501 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")

502− let highlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]

502+ let testHighlight = Highlights Nothing [FieldHighlight (FieldName "message") Nothing]

503503

504− let search = mkHighlightSearch (Just query) highlight

504+ let search = mkHighlightSearch (Just query) testHighlight

505505 myHighlight <- searchTweetHighlight search

506506 myHighlight `shouldBe` Right (Just (M.fromList [("message",["Use <em>haskell</em>!"])]))

507507

@@ -509,9 +509,9 @@ main = hspec $ do

509509 _ <- insertData

510510 _ <- insertOther

511511 let query = QueryMatchQuery $ mkMatchQuery (FieldName "_all") (QueryString "haskell")

512− let highlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]

512+ let testHighlight = Highlights Nothing [FieldHighlight (FieldName "user") Nothing]

513513

514− let search = mkHighlightSearch (Just query) highlight

514+ let search = mkHighlightSearch (Just query) testHighlight

515515 myHighlight <- searchTweetHighlight search

516516 myHighlight `shouldBe` Right Nothing

517517