Skip to content

Commit

Permalink
Merge pull request #28 from phadej/ordhashmap
Browse files Browse the repository at this point in the history
Update to use OrdHashMap
  • Loading branch information
phadej committed May 31, 2016
2 parents 7c7b02f + 16d428e commit 8fc9196
Show file tree
Hide file tree
Showing 9 changed files with 116 additions and 126 deletions.
2 changes: 0 additions & 2 deletions Setup.hs

This file was deleted.

48 changes: 48 additions & 0 deletions Setup.lhs
Original file line number Diff line number Diff line change
@@ -0,0 +1,48 @@
#!/usr/bin/runhaskell
\begin{code}
{-# OPTIONS_GHC -Wall #-}
module Main (main) where

import Data.List ( nub )
import Data.Version ( showVersion )
import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName )
import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) )
import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )
import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )
import Distribution.Simple.BuildPaths ( autogenModulesDir )
import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag )
import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) )
import Distribution.Verbosity ( Verbosity )
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"
, ""
, "autogen_dir :: String"
, "autogen_dir = " ++ show dir
, ""
, "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

\end{code}
34 changes: 20 additions & 14 deletions servant-swagger.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -10,7 +10,7 @@ author: David Johnson, Nickolay Kudasov
maintainer: nickolay.kudasov@gmail.com
copyright: (c) 2015-2016, Servant contributors
category: Web
build-type: Simple
build-type: Custom
cabal-version: >=1.10
extra-source-files:
README.md
Expand Down Expand Up @@ -44,22 +44,28 @@ library
Servant.Swagger.Internal.TypeLevel.Every
Servant.Swagger.Internal.TypeLevel.TMap
hs-source-dirs: src
build-depends: aeson
, base >=4.7 && <4.10
, bytestring
, http-media
, lens
, servant >= 0.4.4.5 && <0.8
, swagger2 >= 2.0.1 && <3
, text
, unordered-containers
build-depends: aeson >=0.11.2.0 && <0.12
, base >=4.7.0.0 && <4.10
, bytestring >=0.10.4.0 && <0.11
, http-media >=0.6.3 && <0.7
, insert-ordered-containers >=0.1.0.0 && <0.2
, lens >=4.7.0.1 && <4.15
, servant >=0.5 && <0.8
, swagger2 >=2.1 && <2.2
, text >=1.2.0.6 && <1.3
, unordered-containers >=0.2.5.1 && <0.3

, hspec
, QuickCheck
default-language: Haskell2010

test-suite doctest
build-depends: base, doctest >=0.11.0, Glob
test-suite doctests
ghc-options: -Wall
build-depends:
base,
directory >= 1.0,
doctest >= 0.11 && <0.12,
filepath
default-language: Haskell2010
hs-source-dirs: test
main-is: DocTest.hs
Expand All @@ -70,15 +76,15 @@ test-suite spec
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: Spec.hs
build-depends: base == 4.*
build-depends: base
, aeson
, aeson-qq >=0.8.1
, hspec
, QuickCheck
, lens
, servant
, servant-swagger
, swagger2 >= 2 && <3
, swagger2
, text
, time
other-modules:
Expand Down
13 changes: 7 additions & 6 deletions src/Servant/Swagger.hs
Original file line number Diff line number Diff line change
Expand Up @@ -55,6 +55,7 @@ import Servant.Swagger.Test
-- >>> import Servant.API
-- >>> import Test.Hspec
-- >>> import Test.QuickCheck
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL8
-- >>> :set -XDataKinds
-- >>> :set -XDeriveDataTypeable
-- >>> :set -XDeriveGeneric
Expand Down Expand Up @@ -96,8 +97,8 @@ import Servant.Swagger.Test
-- $generate
-- In order to generate @'Swagger'@ specification for a servant API, just use @'toSwagger'@:
--
-- >>> encode $ toSwagger (Proxy :: Proxy UserAPI)
-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}"
-- >>> BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI)
-- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}}
--
-- By default @'toSwagger'@ will generate specification for all API routes, parameters, headers, responses and data schemas.
--
Expand All @@ -111,14 +112,14 @@ import Servant.Swagger.Test
-- We can add this information using field lenses from @"Data.Swagger"@:
--
-- >>> :{
-- encode $ toSwagger (Proxy :: Proxy UserAPI)
-- BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI)
-- & info.title .~ "User API"
-- & info.version .~ "1.0"
-- & info.description ?~ "This is an API for the Users service"
-- & info.license ?~ "MIT"
-- & host ?~ "example.com"
-- :}
-- "{\"swagger\":\"2.0\",\"host\":\"example.com\",\"info\":{\"version\":\"1.0\",\"title\":\"User API\",\"license\":{\"name\":\"MIT\"},\"description\":\"This is an API for the Users service\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"]}}}}"
-- {"swagger":"2.0","info":{"version":"1.0","title":"User API","license":{"name":"MIT"},"description":"This is an API for the Users service"},"host":"example.com","paths":{"/":{"get":{"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}}}
--
-- It is also useful to annotate or modify certain endpoints.
-- @'subOperations'@ provides a convenient way to zoom into a part of an API.
Expand All @@ -132,11 +133,11 @@ import Servant.Swagger.Test
-- >>> let getOps = subOperations (Proxy :: Proxy (GetUsers :<|> GetUser)) (Proxy :: Proxy UserAPI)
-- >>> let postOps = subOperations (Proxy :: Proxy PostUser) (Proxy :: Proxy UserAPI)
-- >>> :{
-- encode $ toSwagger (Proxy :: Proxy UserAPI)
-- BSL8.putStrLn $ encode $ toSwagger (Proxy :: Proxy UserAPI)
-- & applyTagsFor getOps ["get" & description ?~ "GET operations"]
-- & applyTagsFor postOps ["post" & description ?~ "POST operations"]
-- :}
-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"required\":[\"name\",\"age\"],\"type\":\"object\",\"properties\":{\"age\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"},\"name\":{\"type\":\"string\"}}},\"UserId\":{\"type\":\"integer\"}},\"paths\":{\"/{user_id}\":{\"get\":{\"responses\":{\"404\":{\"description\":\"`user_id` not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"in\":\"path\",\"name\":\"user_id\",\"type\":\"integer\"}],\"tags\":[\"get\"]}},\"/\":{\"post\":{\"consumes\":[\"application/json\"],\"responses\":{\"400\":{\"description\":\"Invalid `body`\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/UserId\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"parameters\":[{\"required\":true,\"schema\":{\"$ref\":\"#/definitions/User\"},\"in\":\"body\",\"name\":\"body\"}],\"tags\":[\"post\"]},\"get\":{\"responses\":{\"200\":{\"schema\":{\"items\":{\"$ref\":\"#/definitions/User\"},\"type\":\"array\"},\"description\":\"\"}},\"produces\":[\"application/json\"],\"tags\":[\"get\"]}}},\"tags\":[{\"name\":\"get\",\"description\":\"GET operations\"},{\"name\":\"post\",\"description\":\"POST operations\"}]}"
-- {"swagger":"2.0","info":{"version":"","title":""},"paths":{"/":{"get":{"tags":["get"],"produces":["application/json"],"responses":{"200":{"schema":{"items":{"$ref":"#/definitions/User"},"type":"array"},"description":""}}},"post":{"tags":["post"],"consumes":["application/json"],"produces":["application/json"],"parameters":[{"required":true,"schema":{"$ref":"#/definitions/User"},"in":"body","name":"body"}],"responses":{"400":{"description":"Invalid `body`"},"200":{"schema":{"$ref":"#/definitions/UserId"},"description":""}}}},"/{user_id}":{"get":{"tags":["get"],"produces":["application/json"],"parameters":[{"required":true,"in":"path","name":"user_id","type":"integer"}],"responses":{"404":{"description":"`user_id` not found"},"200":{"schema":{"$ref":"#/definitions/User"},"description":""}}}}},"definitions":{"User":{"required":["name","age"],"properties":{"name":{"type":"string"},"age":{"maximum":9223372036854775807,"minimum":-9223372036854775808,"type":"integer"}},"type":"object"},"UserId":{"type":"integer"}},"tags":[{"name":"get","description":"GET operations"},{"name":"post","description":"POST operations"}]}
--
-- This applies @\"get\"@ tag to the @GET@ endpoints and @\"post\"@ tag to the @POST@ endpoint of the User API.

Expand Down
6 changes: 4 additions & 2 deletions src/Servant/Swagger/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,8 @@ import Data.Proxy
import qualified Data.Swagger as Swagger
import Data.Swagger hiding (Header)
import Data.Swagger.Declare
import Data.HashMap.Strict.InsOrd (InsOrdHashMap)
import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.TypeLits
Expand Down Expand Up @@ -314,13 +316,13 @@ instance (KnownSymbol sym, ToParamSchema a) => ToResponseHeader (Header sym a) w
hschema = toParamSchema (Proxy :: Proxy a)

class AllToResponseHeader hs where
toAllResponseHeaders :: Proxy hs -> HashMap HeaderName Swagger.Header
toAllResponseHeaders :: Proxy hs -> InsOrdHashMap HeaderName Swagger.Header

instance AllToResponseHeader '[] where
toAllResponseHeaders _ = mempty

instance (ToResponseHeader h, AllToResponseHeader hs) => AllToResponseHeader (h ': hs) where
toAllResponseHeaders _ = HashMap.insert hname header hdrs
toAllResponseHeaders _ = InsOrdHashMap.insert hname header hdrs
where
(hname, header) = toResponseHeader (Proxy :: Proxy h)
hdrs = toAllResponseHeaders (Proxy :: Proxy hs)
Expand Down
95 changes: 7 additions & 88 deletions stack-ghc-7.8.yaml
Original file line number Diff line number Diff line change
@@ -1,132 +1,51 @@
resolver: ghc-7.8.4
resolver: lts-2.22
packages:
- '.'
- example/
extra-deps:
- adjunctions-4.3
- aeson-0.11.2.0
- aeson-pretty-0.7.2
- aeson-qq-0.8.1
- ansi-terminal-0.6.2.3
- ansi-wl-pprint-0.6.7.3
- appar-0.1.4
- async-2.1.0
- attoparsec-0.13.0.2
- auto-update-0.1.4
- base-compat-0.9.1
- base-orphans-0.5.4
- base64-bytestring-1.0.0.1
- bifunctors-5.3
- blaze-builder-0.4.0.2
- blaze-html-0.8.1.1
- blaze-markup-0.7.0.3
- byteorder-1.0.4
- bytestring-builder-0.10.6.0.0
- bytestring-conversion-0.3.1
- case-insensitive-1.2.0.6
- cmdargs-0.10.14
- comonad-5
- contravariant-1.4
- cookie-0.4.2
- bifunctors-5.2
- cpphs-1.20.1
- cryptonite-0.15
- data-default-class-0.0.1
- distributive-0.5.0.2
- dlist-0.7.1.2
- cryptonite-0.6
- doctest-0.11.0
- double-conversion-2.0.1.0
- easy-file-0.2.1
- exceptions-0.8.2.1
- fail-4.9.0.0
- fast-logger-2.4.6
- file-embed-0.0.10
- free-4.12.4
- ghc-paths-0.1.0.9
- Glob-0.7.5
- hashable-1.2.4.0
- haskell-src-exts-1.17.1
- haskell-src-meta-0.6.0.14
- generics-sop-0.2.1.0
- hex-0.1.2
- hspec-2.2.3
- hspec-core-2.2.3
- hspec-discover-2.2.3
- hspec-expectations-0.7.2
- http-api-data-0.2.2
- http-date-0.0.6.1
- http-media-0.6.3
- http-types-0.9
- http2-1.6.0
- HUnit-1.3.1.1
- iproute-1.7.0
- insert-ordered-containers-0.1.0.1
- kan-extensions-5.0.1
- lens-4.14
- lifted-base-0.2.3.6
- memory-0.12
- mime-types-0.1.0.7
- mmorph-1.0.6
- monad-control-1.0.1.0
- mtl-2.1.3.1
- nats-1
- network-2.6.2.1
- network-uri-2.6.1.0
- optparse-applicative-0.12.1.0
- parallel-3.2.1.0
- parsec-3.1.11
- polyparse-1.12
- prelude-extras-0.4.0.3
- primitive-0.6.1.0
- profunctors-5.2
- psqueues-0.2.2.1
- QuickCheck-2.8.2
- quickcheck-instances-0.3.12
- quickcheck-io-0.1.2
- random-1.1
- reflection-2.1.2
- resourcet-1.1.7.4
- safe-0.3.9
- scientific-0.3.4.6
- semigroupoids-5.0.1
- semigroups-0.18.1
- servant-0.7.1
- servant-server-0.7.1
- setenv-0.1.1.3
- simple-sendfile-0.2.21
- split-0.2.3.1
- StateVar-1.1.0.4
- stm-2.4.4.1
- streaming-commons-0.1.15.5
- string-conversions-0.4
- stringsearch-0.3.6.6
- swagger2-2.0.2
- syb-0.6
- system-filepath-0.4.13.4
- swagger2-2.1
- tagged-0.8.4
- text-1.2.2.1
- tf-random-0.5
- th-expand-syns-0.4.0.0
- th-lift-0.7.6
- th-lift-instances-0.1.7
- th-orphans-0.13.1
- th-reify-many-0.1.6
- time-locale-compat-0.1.1.1
- transformers-base-0.4.4
- transformers-compat-0.5.1.3
- unix-compat-0.4.1.4
- unix-time-0.3.6
- unordered-containers-0.2.7.0
- utf8-string-1.0.1.1
- vault-0.3.0.6
- vector-0.11.0.0
- void-0.7.1
- wai-3.2.1
- wai-3.2.1.1
- wai-app-static-3.1.5
- wai-extra-3.0.15.1
- wai-logger-2.2.7
- warp-3.2.6
- word8-0.1.2
- zlib-0.6.1.1
flags:
QuickCheck:
base4point8: false
aeson:
old-locale: true
4 changes: 2 additions & 2 deletions stack-ghc-8.0.yaml
Original file line number Diff line number Diff line change
Expand Up @@ -2,5 +2,5 @@ resolver: nightly-2016-05-29
packages:
- '.'
- example/
extra-deps: []
flags: {}
extra-deps:
- swagger2-2.1
10 changes: 2 additions & 8 deletions stack.yaml
Original file line number Diff line number Diff line change
@@ -1,12 +1,6 @@
resolver: nightly-2016-02-05
resolver: lts-6.0
packages:
- '.'
- example/
extra-deps:
- aeson-0.11.2.0
- doctest-0.11.0
- servant-0.5
- servant-server-0.5
- servant-swagger-1.0.3
- swagger2-2.0.1
flags: {}
- swagger2-2.1
30 changes: 26 additions & 4 deletions test/DocTest.hs
Original file line number Diff line number Diff line change
@@ -1,8 +1,30 @@
module Main (main) where
module Main where

import System.FilePath.Glob (glob)
import Test.DocTest (doctest)
import Build_doctests (autogen_dir, deps)
import Control.Applicative
import Control.Monad
import Data.List
import System.Directory
import System.FilePath
import Test.DocTest

main :: IO ()
main = glob "src/**/*.hs" >>= doctest
main = getSources >>= \sources -> doctest $
"-isrc"
: ("-i" ++ autogen_dir)
: "-optP-include"
: ("-optP" ++ autogen_dir ++ "/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

0 comments on commit 8fc9196

Please sign in to comment.