servant 0.10 → 0.11
raw patch · 15 files changed
+272/−245 lines, 15 filesdep +taggeddep ~basedep ~http-mediadep ~http-typessetup-changed
Dependencies added: tagged
Dependency ranges changed: base, http-media, http-types
Files
- CHANGELOG.md +31/−1
- Setup.lhs +14/−148
- servant.cabal +13/−5
- src/Servant/API.hs +3/−0
- src/Servant/API/ContentTypes.hs +13/−0
- src/Servant/API/Empty.hs +12/−0
- src/Servant/API/Internal/Test/ComprehensiveAPI.hs +2/−1
- src/Servant/API/RemoteHost.hs +1/−1
- src/Servant/API/ResponseHeaders.hs +2/−2
- src/Servant/Utils/Enter.hs +44/−11
- src/Servant/Utils/Links.hs +69/−15
- test/Servant/Utils/EnterSpec.hs +32/−0
- test/Servant/Utils/LinksSpec.hs +11/−2
- test/doctests.hs +25/−0
- test/doctests.hsc +0/−59
CHANGELOG.md view
@@ -1,5 +1,35 @@+0.11+----++### Breaking changes++- `Enter` refactored+ ([#734](https://github.com/haskell-servant/servant/issues/734)+ , [#736](https://github.com/haskell-servant/servant/pull/736))++### Other changes++- Add a type representing an empty API+ ([#753](https://github.com/haskell-servant/servant/pull/753))+- Add `linkURI'` and `Link` accessors+ ([#745](https://github.com/haskell-servant/servant/pull/745)+ , [#717](https://github.com/haskell-servant/servant/pull/717)+ , [#715](https://github.com/haskell-servant/servant/issues/715))+- Prepare for GHC-8.2+ ([#722](https://github.com/haskell-servant/servant/pull/722))+- Add `HasLink AuthProtect` instance+ ([#720](https://github.com/haskell-servant/servant/pull/720))+- `AllCTRender [] ()` `TypeError` (use `NoContent`)+ ([#671](https://github.com/haskell-servant/servant/pull/671))+- Documentation improvements and typo fixes+ ([#702](https://github.com/haskell-servant/servant/pull/702)+ , [#709](https://github.com/haskell-servant/servant/pull/709)+ , [#716](https://github.com/haskell-servant/servant/pull/716)+ , [#725](https://github.com/haskell-servant/servant/pull/725)+ , [#727](https://github.com/haskell-servant/servant/pull/727))+ 0.10-------+---- ### Breaking changes
Setup.lhs view
@@ -1,165 +1,31 @@ \begin{code} {-# LANGUAGE CPP #-}-#ifndef MIN_VERSION_Cabal-#define MIN_VERSION_Cabal(x,y,z) 0-#endif-#ifndef MIN_VERSION_directory-#define MIN_VERSION_directory(x,y,z) 0-#endif-#if MIN_VERSION_Cabal(1,24,0)-#define InstalledPackageId UnitId-#endif+{-# OPTIONS_GHC -Wall #-} module Main (main) where -import Control.Monad ( when )-import Data.List ( nub )-import Distribution.Package ( InstalledPackageId )-import Distribution.Package ( PackageId, Package (..), packageVersion )-import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) , Library (..), BuildInfo (..))-import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose )-import Distribution.Simple.BuildPaths ( autogenModulesDir )-import Distribution.Simple.Setup ( BuildFlags(buildDistPref, buildVerbosity), fromFlag)-import Distribution.Simple.LocalBuildInfo ( withPackageDB, withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps), compiler )-import Distribution.Simple.Compiler ( showCompilerId , PackageDB (..))-import Distribution.Text ( display , simpleParse )-import System.FilePath ( (</>) )--#if MIN_VERSION_Cabal(1,25,0)-import Distribution.Simple.BuildPaths ( autogenComponentModulesDir )+#ifndef MIN_VERSION_cabal_doctest+#define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif -#if MIN_VERSION_directory(1,2,2)-import System.Directory (makeAbsolute)-#else-import System.Directory (getCurrentDirectory)-import System.FilePath (isAbsolute)--makeAbsolute :: FilePath -> IO FilePath-makeAbsolute p | isAbsolute p = return p- | otherwise = do- cwd <- getCurrentDirectory- return $ cwd </> p-#endif+#if MIN_VERSION_cabal_doctest(1,0,0) +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO ()-main = defaultMainWithHooks simpleUserHooks- { buildHook = \pkg lbi hooks flags -> do- generateBuildModule flags pkg lbi- buildHook simpleUserHooks pkg lbi hooks flags- }--generateBuildModule :: BuildFlags -> PackageDescription -> LocalBuildInfo -> IO ()-generateBuildModule flags pkg lbi = do- let verbosity = fromFlag (buildVerbosity flags)- let distPref = fromFlag (buildDistPref flags)-- -- Package DBs- let dbStack = withPackageDB lbi ++ [ SpecificPackageDB $ distPref </> "package.conf.inplace" ]- let dbFlags = "-hide-all-packages" : packageDbArgs dbStack-- withLibLBI pkg lbi $ \lib libcfg -> do- let libBI = libBuildInfo lib-- -- modules- let modules = exposedModules lib ++ otherModules libBI- -- it seems that doctest is happy to take in module names, not actual files!- let module_sources = modules+main = defaultMainWithDoctests "doctests" - -- We need the directory with library's cabal_macros.h!-#if MIN_VERSION_Cabal(1,25,0)- let libAutogenDir = autogenComponentModulesDir lbi libcfg #else- let libAutogenDir = autogenModulesDir lbi-#endif - -- Lib sources and includes- iArgs <- mapM (fmap ("-i"++) . makeAbsolute) $ "test" : libAutogenDir : hsSourceDirs libBI- includeArgs <- mapM (fmap ("-I"++) . makeAbsolute) $ includeDirs libBI-- -- CPP includes, i.e. include cabal_macros.h- let cppFlags = map ("-optP"++) $- [ "-include", libAutogenDir ++ "/cabal_macros.h" ]- ++ cppOptions libBI-- -- Actually we need to check whether testName suite == "doctests"- -- pending https://github.com/haskell/cabal/pull/4229 getting into GHC HEAD tree- withTestLBI pkg lbi $ \suite suitecfg -> when (testName suite == "doctests") $ do-- -- get and create autogen dir-#if MIN_VERSION_Cabal(1,25,0)- let testAutogenDir = autogenComponentModulesDir lbi suitecfg-#else- let testAutogenDir = autogenModulesDir lbi+#ifdef MIN_VERSION_Cabal+#warning You are configuring this package without cabal-doctest installed. \+ The doctests test-suite will not work as a result. \+ To fix this, install cabal-doctest before configuring. #endif- createDirectoryIfMissingVerbose verbosity True testAutogenDir - -- write autogen'd file- rewriteFile (testAutogenDir </> "Build_doctests.hs") $ unlines- [ "module Build_doctests where"- , ""- -- -package-id etc. flags- , "pkgs :: [String]"- , "pkgs = " ++ (show $ formatDeps $ testDeps libcfg suitecfg)- , ""- , "flags :: [String]"- , "flags = " ++ show (iArgs ++ includeArgs ++ dbFlags ++ cppFlags)- , ""- , "module_sources :: [String]"- , "module_sources = " ++ show ("Servant.Utils.LinksSpec" : map display module_sources)- ]- where- -- we do this check in Setup, as then doctests don't need to depend on Cabal- isOldCompiler = maybe False id $ do- a <- simpleParse $ showCompilerId $ compiler lbi- b <- simpleParse "7.5"- return $ packageVersion (a :: PackageId) < b-- formatDeps = map formatOne- formatOne (installedPkgId, pkgId)- -- The problem is how different cabal executables handle package databases- -- when doctests depend on the library- | packageId pkg == pkgId = "-package=" ++ display pkgId- | otherwise = "-package-id=" ++ display installedPkgId-- -- From Distribution.Simple.Program.GHC- packageDbArgs :: [PackageDB] -> [String]- packageDbArgs | isOldCompiler = packageDbArgsConf- | otherwise = packageDbArgsDb-- -- GHC <7.6 uses '-package-conf' instead of '-package-db'.- packageDbArgsConf :: [PackageDB] -> [String]- packageDbArgsConf dbstack = case dbstack of- (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs- (GlobalPackageDB:dbs) -> ("-no-user-package-conf")- : concatMap specific dbs- _ -> ierror- where- specific (SpecificPackageDB db) = [ "-package-conf=" ++ db ]- specific _ = ierror- ierror = error $ "internal error: unexpected package db stack: "- ++ show dbstack+import Distribution.Simple - -- GHC >= 7.6 uses the '-package-db' flag. See- -- https://ghc.haskell.org/trac/ghc/ticket/5977.- packageDbArgsDb :: [PackageDB] -> [String]- -- special cases to make arguments prettier in common scenarios- packageDbArgsDb dbstack = case dbstack of- (GlobalPackageDB:UserPackageDB:dbs)- | all isSpecific dbs -> concatMap single dbs- (GlobalPackageDB:dbs)- | all isSpecific dbs -> "-no-user-package-db"- : concatMap single dbs- dbs -> "-clear-package-db"- : concatMap single dbs- where- single (SpecificPackageDB db) = [ "-package-db=" ++ db ]- single GlobalPackageDB = [ "-global-package-db" ]- single UserPackageDB = [ "-user-package-db" ]- isSpecific (SpecificPackageDB _) = True- isSpecific _ = False+main :: IO ()+main = defaultMain -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)]-testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys+#endif \end{code}
servant.cabal view
@@ -1,5 +1,5 @@ name: servant-version: 0.10+version: 0.11 synopsis: A family of combinators for defining webservices APIs description: A family of combinators for defining webservices APIs and serving them@@ -27,7 +27,9 @@ custom-setup setup-depends:- Cabal >=1.14, base, filepath, directory+ base >= 4 && <5,+ Cabal,+ cabal-doctest >= 1.0.2 && <1.1 library exposed-modules:@@ -36,6 +38,7 @@ Servant.API.BasicAuth Servant.API.Capture Servant.API.ContentTypes+ Servant.API.Empty Servant.API.Experimental.Auth Servant.API.Header Servant.API.HttpVersion@@ -56,7 +59,7 @@ build-depends: base >= 4.7 && < 4.10 , base-compat >= 0.9 && < 0.10- , aeson >= 0.7 && < 1.2+ , aeson >= 0.7 && < 1.3 , attoparsec >= 0.12 && < 0.14 , bytestring >= 0.10 && < 0.11 , case-insensitive >= 1.2 && < 1.3@@ -65,7 +68,8 @@ , http-types >= 0.8 && < 0.10 , natural-transformation >= 0.4 && < 0.5 , mtl >= 2.0 && < 2.3- , mmorph >= 1 && < 1.1+ , mmorph >= 1 && < 1.2+ , tagged >= 0.7.3 && < 0.9 , text >= 1 && < 1.3 , string-conversions >= 0.3 && < 0.5 , network-uri >= 2.6 && < 2.7@@ -112,6 +116,7 @@ Servant.API.ContentTypesSpec Servant.API.ResponseHeadersSpec Servant.Utils.LinksSpec+ Servant.Utils.EnterSpec build-depends: base == 4.* , base-compat@@ -144,5 +149,8 @@ buildable: True default-language: Haskell2010 ghc-options: -Wall -threaded- build-tools: hsc2hs+ if impl(ghc >= 8.2)+ x-doctest-options: -fdiagnostics-color=never include-dirs: include+ x-doctest-source-dirs: test+ x-doctest-modules: Servant.Utils.LinksSpec
src/Servant/API.hs view
@@ -5,6 +5,8 @@ -- | Type-level combinator for expressing subrouting: @':>'@ module Servant.API.Alternative, -- | Type-level combinator for alternative endpoints: @':<|>'@+ module Servant.API.Empty,+ -- | Type-level combinator for an empty API: @'EmptyAPI'@ -- * Accessing information from the request module Servant.API.Capture,@@ -66,6 +68,7 @@ MimeRender (..), NoContent (NoContent), MimeUnrender (..), OctetStream, PlainText)+import Servant.API.Empty (EmptyAPI (..)) import Servant.API.Experimental.Auth (AuthProtect) import Servant.API.Header (Header (..)) import Servant.API.HttpVersion (HttpVersion (..))
src/Servant/API/ContentTypes.hs view
@@ -98,6 +98,10 @@ import Prelude () import Prelude.Compat +#if MIN_VERSION_base(4,9,0)+import qualified GHC.TypeLits as TL+#endif+ -- * Provided content types data JSON deriving Typeable data PlainText deriving Typeable@@ -182,6 +186,12 @@ amrs = allMimeRender pctyps val lkup = fmap (\(a,b) -> (a, (fromStrict $ M.renderHeader a, b))) amrs +#if MIN_VERSION_base(4,9,0)+instance TL.TypeError ('TL.Text "No instance for (), use NoContent instead.")+ => AllCTRender '[] () where+ handleAcceptH _ _ _ = error "unreachable"+#endif+ -------------------------------------------------------------------------- -- * Unrender @@ -409,6 +419,9 @@ -- $setup+-- >>> :set -XFlexibleInstances+-- >>> :set -XMultiParamTypeClasses+-- >>> :set -XOverloadedStrings -- >>> import Servant.API -- >>> import Data.Aeson -- >>> import Data.Text
+ src/Servant/API/Empty.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_HADDOCK not-home #-}+module Servant.API.Empty(EmptyAPI(..)) where++import Data.Typeable (Typeable)+import Prelude ()+import Prelude.Compat++-- | An empty API: one which serves nothing. Morally speaking, this should be+-- the unit of ':<|>'. Implementors of interpretations of API types should+-- treat 'EmptyAPI' as close to the unit as possible.+data EmptyAPI = EmptyAPI deriving (Typeable, Eq, Show, Bounded, Enum)
src/Servant/API/Internal/Test/ComprehensiveAPI.hs view
@@ -37,7 +37,8 @@ Verb 'POST 204 '[JSON] NoContent :<|> Verb 'POST 204 '[JSON] Int :<|> WithNamedContext "foo" '[] GET :<|>- CaptureAll "foo" Int :> GET+ CaptureAll "foo" Int :> GET :<|>+ EmptyAPI comprehensiveAPIWithoutRaw :: Proxy ComprehensiveAPIWithoutRaw comprehensiveAPIWithoutRaw = Proxy
src/Servant/API/RemoteHost.hs view
@@ -12,7 +12,7 @@ -- $remotehost ----- | Use 'RemoteHost' whenever your request handlers need the host or IP address+-- Use 'RemoteHost' whenever your request handlers need the host or IP address -- from which the client issued the HTTP request. The corresponding handlers -- receive arguments of type @SockAddr@ (from @Network.Socket@). --
src/Servant/API/ResponseHeaders.hs view
@@ -45,7 +45,7 @@ import Prelude.Compat -- | Response Header objects. You should never need to construct one directly.--- Instead, use 'addOptionalHeader.+-- Instead, use 'addOptionalHeader'. data Headers ls a = Headers { getResponse :: a -- ^ The underlying value of a 'Headers' , getHeadersHList :: HList ls@@ -125,7 +125,7 @@ -- | @addHeader@ adds a header to a response. Note that it changes the type of -- the value in the following ways: ----- 1. A simple value is wrapped in "Headers [<hdr>]":+-- 1. A simple value is wrapped in "Headers '[hdr]": -- -- >>> let example1 = addHeader 5 "hi" :: Headers '[Header "someheader" Int] String; -- >>> getHeaders example1
src/Servant/Utils/Enter.hs view
@@ -22,26 +22,59 @@ import qualified Control.Monad.State.Strict as SState import qualified Control.Monad.Writer.Lazy as LWriter import qualified Control.Monad.Writer.Strict as SWriter+import Data.Tagged (Tagged, retag) import Prelude () import Prelude.Compat- import Servant.API -class Enter typ arg ret | typ arg -> ret, typ ret -> arg where- enter :: arg -> typ -> ret+-- | Helper type family to state the 'Enter' symmetry.+type family Entered m n api where+ Entered m n (a -> api) = a -> Entered m n api+ Entered m n (m a) = n a+ Entered m n (api1 :<|> api2) = Entered m n api1 :<|> Entered m n api2+ Entered m n (Tagged m a) = Tagged n a --- ** Servant combinators-instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2- , arg1 ~ arg2- ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where+class+ ( Entered m n typ ~ ret+ , Entered n m ret ~ typ+ ) => Enter typ m n ret | typ m n -> ret, ret m n -> typ, ret typ m -> n, ret typ n -> m+ where+ -- | Map the leafs of an API type.+ enter :: (m :~> n) -> typ -> ret++-- ** Servant combinators++instance+ ( Enter typ1 m1 n1 ret1, Enter typ2 m2 n2 ret2+ , m1 ~ m2, n1 ~ n2+ , Entered m1 n1 (typ1 :<|> typ2) ~ (ret1 :<|> ret2)+ , Entered n1 m1 (ret1 :<|> ret2) ~ (typ1 :<|> typ2)+ ) => Enter (typ1 :<|> typ2) m1 n1 (ret1 :<|> ret2)+ where enter e (a :<|> b) = enter e a :<|> enter e b -instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where+instance+ ( Enter typ m n ret+ , Entered m n (a -> typ) ~ (a -> ret)+ , Entered n m (a -> ret) ~ (a -> typ)+ ) => Enter (a -> typ) m n (a -> ret)+ where enter arg f a = enter arg (f a) --- ** Useful instances+-- ** Leaf instances -instance Enter (m a) (m :~> n) (n a) where+instance+ ( Entered m n (Tagged m a) ~ Tagged n a+ , Entered n m (Tagged n a) ~ Tagged m a+ ) => Enter (Tagged m a) m n (Tagged n a)+ where+ enter _ = retag++instance+ ( Entered m n (m a) ~ n a+ , Entered n m (n a) ~ m a+ ) => Enter (m a) m n (n a)+ where enter (NT f) = f -- | Like `lift`.@@ -65,7 +98,7 @@ liftIO $ logger w return a --- | Like `logWriterTSNat`, but for strict @WriterT@.+-- | Like `logWriterTSNat`, but for lazy @WriterT@. logWriterTLNat :: MonadIO m => (w -> IO ()) -> (LWriter.WriterT w m :~> m) logWriterTLNat logger = NT $ \x -> do (a, w) <- LWriter.runWriterT x
src/Servant/Utils/Links.hs view
@@ -87,8 +87,14 @@ , URI(..) -- * Adding custom types , HasLink(..)- , linkURI , Link+ , linkURI+ , linkURI'+ , LinkArrayElementStyle (..)+ -- ** Link accessors+ , Param (..)+ , linkSegments+ , linkQueryParams ) where import Data.List@@ -112,26 +118,30 @@ import Servant.API.Sub ( type (:>) ) import Servant.API.Raw ( Raw ) import Servant.API.TypeLevel+import Servant.API.Experimental.Auth ( AuthProtect ) -- | A safe link datatype. -- The only way of constructing a 'Link' is using 'safeLink', which means any -- 'Link' is guaranteed to be part of the mentioned API. data Link = Link- { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]- , _queryParams :: [Param Query]+ { _segments :: [String] -- ^ Segments of "foo/bar" would be ["foo", "bar"]+ , _queryParams :: [Param] } deriving Show +linkSegments :: Link -> [String]+linkSegments = _segments++linkQueryParams :: Link -> [Param]+linkQueryParams = _queryParams+ instance ToHttpApiData Link where toHeader = TE.encodeUtf8 . toUrlPiece toUrlPiece l = let uri = linkURI l in Text.pack $ uriPath uri ++ uriQuery uri --- Phantom types for Param-data Query---- | Query param-data Param a+-- | Query parameter.+data Param = SingleParam String Text.Text | ArrayElemParam String Text.Text | FlagParam String@@ -140,27 +150,63 @@ addSegment :: String -> Link -> Link addSegment seg l = l { _segments = _segments l <> [seg] } -addQueryParam :: Param Query -> Link -> Link+addQueryParam :: Param -> Link -> Link addQueryParam qp l = l { _queryParams = _queryParams l <> [qp] } +-- | Transform 'Link' into 'URI'.+--+-- >>> type API = "something" :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)+-- something+--+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x[]=1&x[]=2&x[]=3+--+-- >>> type API = "foo/bar" :> Get '[JSON] Int+-- >>> linkURI $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API)+-- foo%2Fbar+-- linkURI :: Link -> URI-linkURI (Link segments q_params) =+linkURI = linkURI' LinkArrayElementBracket++-- | How to encode array query elements.+data LinkArrayElementStyle+ = LinkArrayElementBracket -- ^ @foo[]=1&foo[]=2@+ | LinkArrayElementPlain -- ^ @foo=1&foo=2@+ deriving (Eq, Ord, Show, Enum, Bounded)++-- | Configurable 'linkURI'.+--+-- >>> type API = "sum" :> QueryParams "x" Int :> Get '[JSON] Int+-- >>> linkURI' LinkArrayElementBracket $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x[]=1&x[]=2&x[]=3+--+-- >>> linkURI' LinkArrayElementPlain $ safeLink (Proxy :: Proxy API) (Proxy :: Proxy API) [1, 2, 3]+-- sum?x=1&x=2&x=3+--+linkURI' :: LinkArrayElementStyle -> Link -> URI+linkURI' addBrackets (Link segments q_params) = URI mempty -- No scheme (relative) Nothing -- Or authority (relative)- (intercalate "/" segments)+ (intercalate "/" $ map escape segments) (makeQueries q_params) mempty where- makeQueries :: [Param Query] -> String+ makeQueries :: [Param] -> String makeQueries [] = "" makeQueries xs = "?" <> intercalate "&" (fmap makeQuery xs) - makeQuery :: Param Query -> String- makeQuery (ArrayElemParam k v) = escape k <> "[]=" <> escape (Text.unpack v)+ makeQuery :: Param -> String+ makeQuery (ArrayElemParam k v) = escape k <> style <> escape (Text.unpack v) makeQuery (SingleParam k v) = escape k <> "=" <> escape (Text.unpack v) makeQuery (FlagParam k) = escape k + style = case addBrackets of+ LinkArrayElementBracket -> "[]="+ LinkArrayElementPlain -> "="+ escape :: String -> String escape = escapeURIString isUnreserved @@ -254,8 +300,16 @@ -- Verb (terminal) instances instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) = Link- toLink _ = id + toLink _ = id instance HasLink Raw where type MkLink Raw = Link toLink _ = id++-- AuthProtext instances+instance HasLink sub => HasLink (AuthProtect tag :> sub) where+ type MkLink (AuthProtect tag :> sub) = MkLink sub+ toLink _ = toLink (Proxy :: Proxy sub)++-- $setup+-- >>> import Servant.API
+ test/Servant/Utils/EnterSpec.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+module Servant.Utils.EnterSpec where++import Test.Hspec (Spec)++import Servant.API+import Servant.Utils.Enter++-------------------------------------------------------------------------------+-- https://github.com/haskell-servant/servant/issues/734+-------------------------------------------------------------------------------++-- This didn't fail if executed in GHCi; cannot have as a doctest.++data App a++f :: App :~> App+f = NT id++server :: App Int :<|> (String -> App Bool)+server = undefined++server' :: App Int :<|> (String -> App Bool)+server' = enter f server++-------------------------------------------------------------------------------+-- Spec+-------------------------------------------------------------------------------++spec :: Spec+spec = return ()
test/Servant/Utils/LinksSpec.hs view
@@ -25,6 +25,7 @@ :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] NoContent :<|> "delete" :> Header "ponies" String :> Delete '[JSON] NoContent :<|> "raw" :> Raw+ :<|> NoEndpoint apiLink :: (IsElem endpoint TestApi, HasLink endpoint)@@ -71,9 +72,11 @@ -- Before https://github.com/CRogers/should-not-typecheck/issues/5 is fixed, -- we'll just use doctest --+-- with TypeError comparing for errors is difficult.+-- -- >>> apiLink (Proxy :: Proxy WrongPath) -- ...--- ...Could not deduce...+-- ......:...:... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongReturnType)@@ -83,7 +86,7 @@ -- -- >>> apiLink (Proxy :: Proxy WrongContentType) -- ...--- ...Could not deduce...+-- ......:...:... -- ... -- -- >>> apiLink (Proxy :: Proxy WrongMethod)@@ -96,6 +99,11 @@ -- ...Could not deduce... -- ... --+-- >>> apiLink (Proxy :: Proxy NoEndpoint)+-- ...+-- ...No instance for...+-- ...+-- -- sanity check -- >>> toUrlPiece $ apiLink (Proxy :: Proxy AllGood) -- "get"@@ -105,3 +113,4 @@ type WrongMethod = "get" :> Post '[JSON] NoContent type NotALink = "hello" :> ReqBody '[JSON] 'True :> Get '[JSON] Bool type AllGood = "get" :> Get '[JSON] NoContent+type NoEndpoint = "empty" :> EmptyAPI
+ test/doctests.hs view
@@ -0,0 +1,25 @@+-----------------------------------------------------------------------------+-- |+-- Module : Main (doctests)+-- Copyright : (C) 2012-14 Edward Kmett+-- License : BSD-style (see the file LICENSE)+-- Maintainer : Edward Kmett <ekmett@gmail.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 (flags, pkgs, module_sources)+import Data.Foldable (traverse_)+import Test.DocTest++main :: IO ()+main = do+ traverse_ putStrLn args+ doctest args+ where+ args = flags ++ pkgs ++ module_sources
− test/doctests.hsc
@@ -1,59 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE ForeignFunctionInterface #-}--------------------------------------------------------------------------------- |--- Module : Main (doctests)--- Copyright : (C) 2012-14 Edward Kmett--- License : BSD-style (see the file LICENSE)--- Maintainer : Edward Kmett <ekmett@gmail.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 (flags, pkgs, module_sources)-import Data.Foldable (traverse_)-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 $ do- traverse_ putStrLn args- doctest args- where- args = - "-XOverloadedStrings" :- "-XFlexibleInstances" :- "-XMultiParamTypeClasses" :- flags ++ pkgs ++ module_sources