packages feed

servant-checked-exceptions (empty) → 0.1.0.0

raw patch · 20 files changed

+2023/−0 lines, 20 filesdep +Globdep +aesondep +basesetup-changed

Dependencies added: Glob, aeson, base, bytestring, deepseq, doctest, http-api-data, http-client, http-media, lens, natural-transformation, optparse-applicative, servant, servant-checked-exceptions, servant-client, servant-docs, servant-server, text, wai, warp

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Dennis Gosnell (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Author name here nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,14 @@++Servant.+==================++[![Build Status](https://secure.travis-ci.org/cdepillabout/servant-checked-exceptions.svg)](http://travis-ci.org/cdepillabout/servant-checked-exceptions)+[![Hackage](https://img.shields.io/hackage/v/servant-checked-exceptions.svg)](https://hackage.haskell.org/package/servant-checked-exceptions)+[![Stackage LTS](http://stackage.org/package/servant-checked-exceptions/badge/lts)](http://stackage.org/lts/package/servant-checked-exceptions)+[![Stackage Nightly](http://stackage.org/package/servant-checked-exceptions/badge/nightly)](http://stackage.org/nightly/package/servant-checked-exceptions)+![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg)++`servant-checked-exceptions` ++For documentation and usage examples, see the+[documentation](https://hackage.haskell.org/package/servant-checked-exceptions) on Hackage.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/Api.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Api where++import Data.Aeson+       (FromJSON(parseJSON), ToJSON(toJSON), Value, withText)+import Data.Aeson.Types (Parser)+-- import Data.Proxy (Proxy(Proxy))+import Data.String (IsString)+import Data.Text (unpack)+import Servant.API (Capture, JSON, Post, (:>), (:<|>))+-- import Servant.Client (Client, ClientM, client)+-- import Servant.Docs+--        (ToParam(toParam), ToSample(toSamples), docs, markdown)+-- import Servant.Docs.Internal+--        (DocQueryParam(DocQueryParam), ParamKind(Normal))+import Text.Read (readMaybe)+import Web.HttpApiData (FromHttpApiData, ToHttpApiData)++import Servant.Checked.Exceptions (Throws)++---------+-- API --+---------++type Api = ApiStrictSearch :<|> ApiLaxSearch++type ApiStrictSearch =+  "strict-search" :>+  Capture "query" SearchQuery :>+  Throws BadSearchTermErr :>+  Throws IncorrectCapitalization :>+  Post '[JSON] SearchResponse++type ApiLaxSearch =+  "lax-search" :>+  Capture "query" SearchQuery :>+  Throws BadSearchTermErr :>+  Post '[JSON] SearchResponse++------------------------------+-- Parameters and Responses --+------------------------------++newtype SearchQuery = SearchQuery+  { unSearchQuery :: String+  } deriving ( Eq+             , FromHttpApiData+             , FromJSON+             , IsString+             , Ord+             , Read+             , Show+             , ToHttpApiData+             , ToJSON+             )++newtype SearchResponse = SearchResponse+  { unSearchResponse :: String+  } deriving ( Eq+             , FromHttpApiData+             , FromJSON+             , IsString+             , Ord+             , Read+             , Show+             , ToHttpApiData+             , ToJSON+             )++------------+-- Errors --+------------++data BadSearchTermErr = BadSearchTermErr deriving (Eq, Read, Show)++instance ToJSON BadSearchTermErr where+  toJSON :: BadSearchTermErr -> Value+  toJSON = toJSON . show++instance FromJSON BadSearchTermErr where+  parseJSON :: Value -> Parser BadSearchTermErr+  parseJSON = withText "BadSearchTermErr" $+    maybe (fail "could not parse as BadSearchTermErr") pure . readMaybe . unpack++data IncorrectCapitalization = IncorrectCapitalization deriving (Eq, Read, Show)++instance ToJSON IncorrectCapitalization where+  toJSON :: IncorrectCapitalization -> Value+  toJSON = toJSON . show++instance FromJSON IncorrectCapitalization where+  parseJSON :: Value -> Parser IncorrectCapitalization+  parseJSON = withText "IncorrectCapitalization" $+    maybe (fail "could not parse as IncorrectCapitalization") pure . readMaybe . unpack++----------+-- Port --+----------++port :: Int+port = 8201
+ example/Client.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Data.Monoid ((<>))+import Data.Proxy (Proxy(Proxy))+import Network.HTTP.Client (defaultManagerSettings, newManager)+import Options.Applicative+       (Parser, (<**>), argument, execParser, fullDesc, help, helper, info, long,+        metavar, progDesc, short, str, switch)+import Servant.API ((:<|>)((:<|>)))+import Servant.Client+       (BaseUrl(BaseUrl), ClientEnv(ClientEnv), ClientM, Scheme(Http),+        client, runClientM)++import Servant.Checked.Exceptions (Envelope, catchesEnvelope)++import Api+       (Api, BadSearchTermErr(BadSearchTermErr),+        IncorrectCapitalization(IncorrectCapitalization),+        SearchQuery(SearchQuery), SearchResponse(SearchResponse), port)++strictSearch+  :: SearchQuery+  -> ClientM (Envelope '[BadSearchTermErr, IncorrectCapitalization] SearchResponse)+laxSearch+  :: SearchQuery+  -> ClientM (Envelope '[BadSearchTermErr] SearchResponse)+strictSearch :<|> laxSearch = client (Proxy :: Proxy Api)++data Options = Options { query :: String, useStrict :: Bool }++queryParser :: Parser String+queryParser = argument str (metavar "QUERY")++useStrictParser :: Parser Bool+useStrictParser =+  switch $+    long "strict" <> short 's' <> help "Whether to be use the strict api"++commandParser :: Parser Options+commandParser = Options <$> queryParser <*> useStrictParser++runStrict :: ClientEnv -> String -> IO ()+runStrict clientEnv query = do+  eitherRes <- runClientM (strictSearch $ SearchQuery query) clientEnv+  case eitherRes of+    Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr+    Right env ->+      putStrLn $+        catchesEnvelope+          ( \BadSearchTermErr -> "the search term was not \"Hello\""+          , \IncorrectCapitalization -> "the search term was not capitalized correctly"+          )+          (\(SearchResponse searchResponse) -> "Success: " <> searchResponse)+          env++runLax :: ClientEnv -> String -> IO ()+runLax clientEnv query = do+  eitherRes <- runClientM (laxSearch $ SearchQuery query) clientEnv+  case eitherRes of+    Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr+    Right env ->+      putStrLn $+        catchesEnvelope+          (\BadSearchTermErr -> "the search term was not \"Hello\"")+          (\(SearchResponse searchResponse) -> "Success: " <> searchResponse)+          env++run :: ClientEnv -> Options -> IO ()+run clientEnv Options{query, useStrict = True} = runStrict clientEnv query+run clientEnv Options{query, useStrict = False} = runLax clientEnv query++main :: IO ()+main = do+  manager <- newManager defaultManagerSettings+  let clientEnv = ClientEnv manager baseUrl+  options <- execParser opts+  run clientEnv options+  where+    opts = info (commandParser <**> helper) $+      fullDesc <>+      progDesc "Send the QUERY to the example server and print the response."++baseUrl :: BaseUrl+baseUrl = BaseUrl Http "localhost" port ""+
+ example/Docs.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Main where++import Data.Proxy (Proxy(Proxy))+import Data.Text (Text)+import Servant.API (Capture)+import Servant.Docs+       (DocCapture(DocCapture), ToCapture(toCapture), ToSample(toSamples),+        docs, markdown)++import Servant.Checked.Exceptions ()++import Api+       (Api, BadSearchTermErr(BadSearchTermErr),+        IncorrectCapitalization(IncorrectCapitalization), SearchQuery,+        SearchResponse)++instance ToSample SearchResponse where+  toSamples :: Proxy SearchResponse -> [(Text, SearchResponse)]+  toSamples Proxy = [("This is a successful response.", "good")]++instance ToCapture (Capture "query" SearchQuery) where+  toCapture :: Proxy (Capture "query" SearchQuery) -> DocCapture+  toCapture Proxy =+    DocCapture "query" "a search string like \"hello\" or \"bye\""++instance ToSample BadSearchTermErr where+  toSamples :: Proxy BadSearchTermErr -> [(Text, BadSearchTermErr)]+  toSamples Proxy =+    [("a completely incorrect search term was used", BadSearchTermErr)]++instance ToSample IncorrectCapitalization where+  toSamples :: Proxy IncorrectCapitalization -> [(Text, IncorrectCapitalization)]+  toSamples Proxy =+    [ ( "the search term \"Hello\" has not been capitalized correctly"+      , IncorrectCapitalization)+    ]++main :: IO ()+main = putStrLn . markdown $ docs (Proxy :: Proxy Api)
+ example/Server.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Main where++import Data.Char (toLower)+import Data.Proxy (Proxy(Proxy))+import Network.Wai (Application)+import Network.Wai.Handler.Warp (run)+import Servant (Handler, (:<|>)((:<|>)), ServerT, serve)++import Servant.Checked.Exceptions+       (Envelope, pureErrEnvelope, pureSuccEnvelope)++import Api+       (Api, BadSearchTermErr(BadSearchTermErr),+        IncorrectCapitalization(IncorrectCapitalization),+        SearchQuery(SearchQuery), SearchResponse, port)++serverRoot :: ServerT Api Handler+serverRoot = postStrictSearch :<|> postLaxSearch++postStrictSearch+  :: SearchQuery+  -> Handler (Envelope '[BadSearchTermErr, IncorrectCapitalization] SearchResponse)+postStrictSearch (SearchQuery "Hello") = pureSuccEnvelope "good"+postStrictSearch (SearchQuery query)+  | fmap toLower query == "hello" = pureErrEnvelope IncorrectCapitalization+  | otherwise = pureErrEnvelope BadSearchTermErr++postLaxSearch+  :: SearchQuery+  -> Handler (Envelope '[BadSearchTermErr] SearchResponse)+postLaxSearch (SearchQuery query)+  | fmap toLower query == "hello" = pureSuccEnvelope "good"+  | otherwise = pureErrEnvelope BadSearchTermErr++app :: Application+app = serve (Proxy :: Proxy Api) serverRoot++main :: IO ()+main = run port app
+ servant-checked-exceptions.cabal view
@@ -0,0 +1,147 @@+name:                servant-checked-exceptions+version:             0.1.0.0+synopsis:            Checked exceptions for Servant APIs.+description:         Please see <https://github.com/cdepillabout/servant-checked-exceptions#readme README.md>.+homepage:            https://github.com/cdepillabout/servant-checked-exceptions+license:             BSD3+license-file:        LICENSE+author:              Dennis Gosnell+maintainer:          cdep.illabout@gmail.com+copyright:           2017 Dennis Gosnell+category:            Text+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++flag buildexample+  description: Build a small example program+  default: False++library+  hs-source-dirs:      src+  exposed-modules:     Servant.Checked.Exceptions+                     , Servant.Checked.Exceptions.Internal+                     , Servant.Checked.Exceptions.Internal.Envelope+                     , Servant.Checked.Exceptions.Internal.Product+                     , Servant.Checked.Exceptions.Internal.Servant+                     , Servant.Checked.Exceptions.Internal.Servant.API+                     , Servant.Checked.Exceptions.Internal.Servant.Client+                     , Servant.Checked.Exceptions.Internal.Servant.Docs+                     , Servant.Checked.Exceptions.Internal.Servant.Server+                     , Servant.Checked.Exceptions.Internal.Union+                     , Servant.Checked.Exceptions.Internal.Util+  build-depends:       base >= 4.8 && < 5+                     , aeson+                     , bytestring+                     , deepseq+                     , http-media+                     , lens+                     , servant >= 0.9+                     , servant-client >= 0.9+                     , servant-docs >= 0.9+                     , servant-server >= 0.9+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction+  other-extensions:    QuasiQuotes+                     , TemplateHaskell++executable servant-checked-exceptions-example-client+  main-is:             Client.hs+  other-modules:       Api+  hs-source-dirs:      example+  build-depends:       base+                     , aeson+                     , http-api-data+                     , http-client+                     , optparse-applicative+                     , servant+                     , servant-checked-exceptions+                     , servant-client+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++  if flag(buildexample)+    buildable:         True+  else+    buildable:         False++executable servant-checked-exceptions-example-docs+  main-is:             Docs.hs+  other-modules:       Api+  hs-source-dirs:      example+  build-depends:       base+                     , aeson+                     , http-api-data+                     , servant+                     , servant-checked-exceptions+                     , servant-docs+                     , text+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++  if flag(buildexample)+    buildable:         True+  else+    buildable:         False++executable servant-checked-exceptions-example-server+  main-is:             Server.hs+  other-modules:       Api+  hs-source-dirs:      example+  build-depends:       base+                     , aeson+                     , http-api-data+                     , natural-transformation+                     , servant+                     , servant-checked-exceptions+                     , servant-server+                     , text+                     , wai+                     , warp+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++  if flag(buildexample)+    buildable:         True+  else+    buildable:         False++test-suite servant-checked-exceptions-doctest+  type:                exitcode-stdio-1.0+  main-is:             DocTest.hs+  hs-source-dirs:      test+  build-depends:       base+                     , doctest+                     , Glob+  default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N++-- test-suite servant-checked-exceptions-test+--   type:                exitcode-stdio-1.0+--   main-is:             Spec.hs+--   other-modules:       Spec.ApiSpec+--                      , Spec.HelperFuncSpec+--                      , Spec.ServerSpec+--                      , Spec.TastyHelpers+--                      , Spec.TestDirLocation+--   hs-source-dirs:      test+--   build-depends:       base+--                      , bytestring+--                      , directory+--                      , filepath+--                      , hspec-wai+--                      , tasty+--                      , tasty-hspec+--                      , tasty-hunit+--                      , servant+--                      , servant-checked-exceptions+--                      , servant-server+--                      , wai+--   default-language:    Haskell2010+--   ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction++source-repository head+  type:     git+  location: git@github.com:cdepillabout/servant-checked-exceptions.git
+ src/Servant/Checked/Exceptions.hs view
@@ -0,0 +1,71 @@+module Servant.Checked.Exceptions+  (+  -- * 'Throws' API parameter+    Throws+  -- * 'Envelope' response wrapper+  , Envelope(..)+  -- ** 'Envelope' helper functions+  -- *** 'Envelope' constructors+  , toSuccEnvelope+  , toErrEnvelope+  , pureSuccEnvelope+  , pureErrEnvelope+  -- *** 'Envelope' destructors+  , envelope+  , fromEnvelope+  , fromEnvelopeOr+  , fromEnvelopeM+  , fromEnvelopeOrM+  , errEnvelopeMatch+  , catchesEnvelope+  -- *** 'Envelope' optics+  , _SuccEnvelope+  , _ErrEnvelope+  , _ErrEnvelopeErr+  -- *** 'Envelope' and 'Either'+  , envelopeToEither+  , eitherToEnvelope+  , isoEnvelopeEither+  -- *** 'OpenUnion' (used in 'ErrEnvelope')+  , OpenUnion+  -- **** 'OpenUnion' Helpers+  , openUnion+  , fromOpenUnion+  , fromOpenUnionOr+  , openUnionPrism+  , openUnionLift+  , openUnionMatch+  , catchesOpenUnion+  -- **** 'Union' (used by 'OpenUnion')+  -- | 'OpenUnion' is a type synonym around 'Union'. Most users will be able to+  -- work directly with 'OpenUnion' and ignore this 'Union' type.+  , Union(..)+  -- ***** Union helpers+  , union+  , absurdUnion+  , umap+  , catchesUnion+  -- ***** Union optics+  , _This+  , _That+  -- ***** Typeclasses used with Union+  , Nat(Z, S)+  , RIndex+  , UElem(..)+  , IsMember+  -- **** 'OpenProduct' (used by 'OpenUnion')+  -- | This 'Product' type is used to easily create a case-analysis for+  -- 'Union's.  You can see it being used in 'catchesOpenUnion' and+  -- 'catchesEnvelope'.  The 'ToProduct' type class makes it easy to convert a+  -- tuple to a 'Product'.  This makes it so the end user only has to worry+  -- about working with tuples, and can mostly ignore this 'Product' type.+  , OpenProduct+  , Product(..)+  , ToOpenProduct+  , tupleToOpenProduct+  , ToProduct+  , tupleToProduct+  , ReturnX+  ) where++import Servant.Checked.Exceptions.Internal
+ src/Servant/Checked/Exceptions/Internal.hs view
@@ -0,0 +1,14 @@++module Servant.Checked.Exceptions.Internal+  ( module Servant.Checked.Exceptions.Internal.Envelope+  , module Servant.Checked.Exceptions.Internal.Product+  , module Servant.Checked.Exceptions.Internal.Servant+  , module Servant.Checked.Exceptions.Internal.Union+  , module Servant.Checked.Exceptions.Internal.Util+  ) where++import Servant.Checked.Exceptions.Internal.Envelope+import Servant.Checked.Exceptions.Internal.Product+import Servant.Checked.Exceptions.Internal.Servant+import Servant.Checked.Exceptions.Internal.Union+import Servant.Checked.Exceptions.Internal.Util
+ src/Servant/Checked/Exceptions/Internal/Envelope.hs view
@@ -0,0 +1,380 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Envelope++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines the 'Envelope' type as a wrapper around a success value, or+a set of possible errors.  The errors are an 'OpenUnion', which is an+extensible sumtype.++Other than the 'Envelope' type, the most important thing in this module is the+'ToJSON' instance for 'Envelope'.+-}++module Servant.Checked.Exceptions.Internal.Envelope+  (+  -- * Envelope+    Envelope(..)+  -- * Helper functions+  -- ** Envelope Constructors+  , toSuccEnvelope+  , toErrEnvelope+  , pureSuccEnvelope+  , pureErrEnvelope+  -- ** Envelope Destructors+  , envelope+  , fromEnvelope+  , fromEnvelopeOr+  , fromEnvelopeM+  , fromEnvelopeOrM+  , errEnvelopeMatch+  , catchesEnvelope+  -- ** Optics+  , _SuccEnvelope+  , _ErrEnvelope+  , _ErrEnvelopeErr+  -- ** Either+  , envelopeToEither+  , eitherToEnvelope+  , isoEnvelopeEither+  -- * Setup code for doctests+  -- $setup+  ) where++import Control.Applicative ((<|>))+import Control.Lens (Iso, Prism, Prism', iso, preview, prism)+import Control.Monad.Fix (MonadFix(mfix))+import Data.Aeson+       (FromJSON(parseJSON), ToJSON(toJSON), Value, (.=), (.:), object,+        withObject)+import Data.Aeson.Types (Parser)+import Data.Data (Data)+import Data.Semigroup (Semigroup((<>), stimes), stimesIdempotent)+import Data.Typeable (Typeable)+import GHC.Generics (Generic)++import Servant.Checked.Exceptions.Internal.Product (ToOpenProduct)+import Servant.Checked.Exceptions.Internal.Union+       (IsMember, OpenUnion, catchesOpenUnion, openUnionLift,+        openUnionPrism)+import Servant.Checked.Exceptions.Internal.Util (ReturnX)+++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators+-- >>> import Control.Lens (preview, review)+-- >>> import Data.Aeson (encode)+-- >>> import Data.ByteString.Lazy.Char8 (hPutStrLn)+-- >>> import Data.Text (Text)+-- >>> import System.IO (stdout)+-- >>> import Text.Read (readMaybe)+-- >>> let putByteStrLn = hPutStrLn stdout+++-- | This 'Envelope' type is a used as a wrapper around either an 'OpenUnion'+-- with an error or a successful value.  It is similar to an @'Either' e a@,+-- but where the @e@ is specialized to @'OpenUnion' es@.  The most important+-- difference from 'Either' is the the 'FromJSON' and 'ToJSON' instances.+--+-- Given an @'Envelope' \'['String', 'Double'] ()@, we know that the envelope+-- could be a 'SuccEnvelope' and contain @()@.  Or it could be a 'ErrEnvelope'+-- that contains /either/ a 'String' /or/ a 'Double'.  It might be simpler to+-- think of it as a type like @'Either' 'String' ('Either' 'Double' ())@.+--+-- An 'Envelope' can be created with the 'toErrEnvelope' and 'toSuccEnvelope'+-- functions.  The 'Prism's '_SuccEnvelope', '_ErrEnvelope', and+-- '_ErrEnvelopeErr' can be used to get values out of an 'Envelope'.+data Envelope es a = ErrEnvelope (OpenUnion es) | SuccEnvelope a+  deriving (Foldable, Functor, Generic, Traversable)++-- | Create an 'ErrEnvelope' from a member of the 'OpenUnion'.+--+-- For instance, here is how to create an 'ErrEnvelope' that contains a+-- 'Double':+--+-- >>> let double = 3.5 :: Double+-- >>> toErrEnvelope double :: Envelope '[String, Double, Int] ()+-- ErrEnvelope (Identity 3.5)+toErrEnvelope :: IsMember e es => e -> Envelope es a+toErrEnvelope = ErrEnvelope . openUnionLift++-- | This is a function to create a 'SuccEnvelope'.+--+-- >>> toSuccEnvelope "hello" :: Envelope '[Double] String+-- SuccEnvelope "hello"+toSuccEnvelope :: a -> Envelope es a+toSuccEnvelope = SuccEnvelope++-- | 'pureErrEnvelope' is 'toErrEnvelope' lifted up to an 'Applicative'.+pureErrEnvelope :: (Applicative m, IsMember e es) => e -> m (Envelope es a)+pureErrEnvelope = pure . toErrEnvelope++-- | 'pureSuccEnvelope' is 'toSuccEnvelope' lifted up to an 'Applicative'.+pureSuccEnvelope :: Applicative m => a -> m (Envelope es a)+pureSuccEnvelope = pure . toSuccEnvelope++-- | Case analysis for 'Envelope's.+--+--  Here is an example of matching on a 'SuccEnvelope':+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[Double, Int] String+-- >>> envelope (const "not a String") id env+-- "hello"+--+-- Here is an example of matching on a 'ErrEnvelope':+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double, Int] String+-- >>> envelope (const "not a String") id env'+-- "not a String"+envelope :: (OpenUnion es -> c) -> (a -> c) -> Envelope es a -> c+envelope f _ (ErrEnvelope es) = f es+envelope _ f (SuccEnvelope a) = f a++-- | Just like 'Data.Either.fromEither' but for 'Envelope'.+--+--  Here is an example of successfully matching:+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[Double, Int] String+-- >>> fromEnvelope (const "not a String") env+-- "hello"+--+-- Here is an example of unsuccessfully matching:+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double, Int] String+-- >>> fromEnvelope (const "not a String") env'+-- "not a String"+fromEnvelope :: (OpenUnion es -> a) -> Envelope es a -> a+fromEnvelope f = envelope f id++-- | Lifted version of 'fromEnvelope'.+fromEnvelopeM+  :: Applicative m+  => (OpenUnion es -> m a) -> Envelope es a -> m a+fromEnvelopeM f = envelope f pure++-- | Flipped version of 'fromEnvelope'.+fromEnvelopeOr :: Envelope es a -> (OpenUnion es -> a) -> a+fromEnvelopeOr = flip fromEnvelope++-- | Flipped version of 'fromEnvelopeM'.+fromEnvelopeOrM+  :: Applicative m+  => Envelope es a -> (OpenUnion es -> m a) -> m a+fromEnvelopeOrM = flip fromEnvelopeM++-- | Convert an 'Envelope' to an 'Either'.+envelopeToEither :: Envelope es a -> Either (OpenUnion es) a+envelopeToEither (ErrEnvelope es) = Left es+envelopeToEither (SuccEnvelope a) = Right a++-- | Convert an 'Either' to an 'Envelope'.+eitherToEnvelope :: Either (OpenUnion es) a -> Envelope es a+eitherToEnvelope (Left es) = ErrEnvelope es+eitherToEnvelope (Right a) = SuccEnvelope a++-- | Lens-compatible 'Iso' from 'Envelope' to 'Either'.+isoEnvelopeEither :: Iso (Envelope es a) (Envelope fs b) (Either (OpenUnion es) a) (Either (OpenUnion fs) b)+isoEnvelopeEither = iso envelopeToEither eitherToEnvelope++-- | Lens-compatible 'Prism' to pull out an @a@ from a 'SuccEnvelope'.+--+-- Use '_SuccEnvelope' to construct an 'Envelope':+--+-- >>> review _SuccEnvelope "hello" :: Envelope '[Double] String+-- SuccEnvelope "hello"+--+-- Use '_SuccEnvelope' to try to destruct an 'Envelope' into an @a@:+--+-- >>> let env = toSuccEnvelope "hello" :: Envelope '[Double] String+-- >>> preview _SuccEnvelope env :: Maybe String+-- Just "hello"+--+-- Use '_SuccEnvelope' to try to destruct a 'Envelope into an @a@+-- (unsuccessfully):+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double] String+-- >>> preview _SuccEnvelope env' :: Maybe String+-- Nothing+_SuccEnvelope :: Prism (Envelope es a) (Envelope es b) a b+_SuccEnvelope = prism SuccEnvelope $ envelope (Left . ErrEnvelope) Right++-- | Lens-compatible 'Prism' to pull out an @'OpenUnion' es@ from a+-- 'ErrEnvelope'.+--+-- Use '_ErrEnvelope' to construct an 'Envelope':+--+-- >>> let string = "hello" :: String+-- >>> review _ErrEnvelope (openUnionLift string) :: Envelope '[String] Double+-- ErrEnvelope (Identity "hello")+--+-- Use '_ErrEnvelope' to try to destruct an 'Envelope' into an+-- @'OpenUnion' es@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double] ()+-- >>> preview _ErrEnvelope env :: Maybe (OpenUnion '[Double])+-- Just (Identity 3.5)+--+-- Use '_ErrEnvelope' to try to destruct a 'Envelope into an+-- @'OpenUnion' es@ (unsuccessfully):+--+-- >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()+-- >>> preview _ErrEnvelope env' :: Maybe (OpenUnion '[Double])+-- Nothing+--+-- Most users will not use '_ErrEnvelope', but instead '_ErrEnvelopeErr'.+_ErrEnvelope :: Prism (Envelope es a) (Envelope es' a) (OpenUnion es) (OpenUnion es')+_ErrEnvelope = prism ErrEnvelope $ envelope Right (Left . SuccEnvelope)++-- | Lens-compatible 'Prism' to pull out a specific @e@ from an 'ErrEnvelope'.+--+-- Use '_ErrEnvelopeErr' to construct an 'Envelope':+--+-- >>> let string = "hello" :: String+-- >>> review _ErrEnvelopeErr string :: Envelope '[String] Double+-- ErrEnvelope (Identity "hello")+--+-- Use '_ErrEnvelopeErr' to try to destruct an 'Envelope' into an @e@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double] ()+-- >>> preview _ErrEnvelopeErr env :: Maybe Double+-- Just 3.5+--+-- Use '_ErrEnvelopeErr' to try to destruct a 'Envelope into an+-- @e@ (unsuccessfully):+--+-- >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()+-- >>> preview _ErrEnvelopeErr env' :: Maybe Double+-- Nothing+-- >>> let env'' = toErrEnvelope 'c' :: Envelope '[Double, Char] ()+-- >>> preview _ErrEnvelopeErr env'' :: Maybe Double+-- Nothing+--+-- Most users will use '_ErrEnvelopeErr' instead of '_ErrEnvelope'.+_ErrEnvelopeErr :: forall e es a. IsMember e es => Prism' (Envelope es a) e+_ErrEnvelopeErr = _ErrEnvelope . openUnionPrism++-- | Pull out a specific @e@ from an 'ErrEnvelope'.+--+-- Successfully pull out an @e@:+--+-- >>> let double = 3.5 :: Double+-- >>> let env = toErrEnvelope double :: Envelope '[Double] ()+-- >>> errEnvelopeMatch env :: Maybe Double+-- Just 3.5+--+-- Unsuccessfully pull out an @e@:+--+-- >>> let env' = toSuccEnvelope () :: Envelope '[Double] ()+-- >>> errEnvelopeMatch env' :: Maybe Double+-- Nothing+-- >>> let env'' = toErrEnvelope 'c' :: Envelope '[Double, Char] ()+-- >>> errEnvelopeMatch env'' :: Maybe Double+-- Nothing+errEnvelopeMatch+  :: forall e es a.+     IsMember e es+  => Envelope es a -> Maybe e+errEnvelopeMatch = preview _ErrEnvelopeErr++catchesEnvelope+  :: forall tuple es a x.+     ToOpenProduct tuple (ReturnX x es)+  => tuple -> (a -> x) -> Envelope es a -> x+catchesEnvelope _ a2x (SuccEnvelope a) = a2x a+catchesEnvelope tuple _ (ErrEnvelope u) = catchesOpenUnion tuple u++-- data EnvelopeHandler es x = forall e. IsMember e es => EnvelopeHandler (e -> x)++-- | This 'ToJSON' instance encodes an 'Envelope' as an object with one of two+-- keys depending on whether it is a 'SuccEnvelope' or an 'ErrEnvelope'.+--+-- Here is an example of a 'SuccEnvelope':+--+-- >>> let string = "hello" :: String+-- >>> let env = toSuccEnvelope string :: Envelope '[Double] String+-- >>> putByteStrLn $ encode env+-- {"data":"hello"}+--+-- Here is an example of a 'ErrEnvelope':+--+-- >>> let double = 3.5 :: Double+-- >>> let env' = toErrEnvelope double :: Envelope '[Double] String+-- >>> putByteStrLn $ encode env'+-- {"err":3.5}+instance (ToJSON (OpenUnion es), ToJSON a) => ToJSON (Envelope es a) where+  toJSON :: Envelope es a -> Value+  toJSON (ErrEnvelope es) = object ["err" .= es]+  toJSON (SuccEnvelope a) = object ["data" .= a]++-- | This is only a valid instance when the 'FromJSON' instances for the @es@+-- don't overlap.+--+-- For an explanation, see the documentation on the 'FromJSON' instance for+-- 'Union'.+instance (FromJSON (OpenUnion es), FromJSON a) => FromJSON (Envelope es a) where+  parseJSON :: Value -> Parser (Envelope es a)+  parseJSON = withObject "Envelope" $ \obj ->+    SuccEnvelope <$> obj .: "data" <|>+    ErrEnvelope <$> obj .: "err"++deriving instance (Data (OpenUnion es), Data a, Typeable es) => Data (Envelope es a)+deriving instance (Eq (OpenUnion es), Eq a) => Eq (Envelope es a)+deriving instance (Ord (OpenUnion es), Ord a) => Ord (Envelope es a)+deriving instance (Read (OpenUnion es), Read a) => Read (Envelope es a)+deriving instance (Show (OpenUnion es), Show a) => Show (Envelope es a)+deriving instance (Typeable (OpenUnion es), Typeable a) => Typeable (Envelope es a)++instance Applicative (Envelope es) where+  pure :: a -> Envelope es a+  pure = SuccEnvelope++  (<*>) :: Envelope es (a -> b) -> Envelope es a -> Envelope es b+  ErrEnvelope es <*> _ = ErrEnvelope es+  SuccEnvelope f <*> r = fmap f r++instance Monad (Envelope es) where+  (>>=) :: Envelope es a -> (a -> Envelope es b) -> Envelope es b+  ErrEnvelope es >>= _ = ErrEnvelope es+  SuccEnvelope a >>= k = k a++instance MonadFix (Envelope es) where+  mfix :: (a -> Envelope es a) -> Envelope es a+  mfix f =+    let a = f (unSucc a)+    in a+    where+      unSucc :: Envelope es a -> a+      unSucc (SuccEnvelope x) = x+      unSucc (ErrEnvelope _) = errorWithoutStackTrace "mfix Envelope: ErrEnvelope"++instance Semigroup (Envelope es a) where+  (<>) :: Envelope es a -> Envelope es a -> Envelope es a+  ErrEnvelope _ <> b = b+  a      <> _ = a++  stimes :: Integral b => b -> Envelope es a -> Envelope es a+  stimes = stimesIdempotent
+ src/Servant/Checked/Exceptions/Internal/Product.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Product++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines an open product type.  This is used in the case-analysis+handler for the open sum type.+-}++module Servant.Checked.Exceptions.Internal.Product+  where++import Data.Functor.Identity (Identity(Identity))++-- $setup+-- >>> -- :set -XDataKinds++-------------+-- Product --+-------------++-- | An extensible product type.  This is similar to+-- 'Servant.Checked.Exceptions.Internal.Union.Union', except a product type+-- instead of a sum type.+data Product (f :: u -> *) (as :: [u]) where+  Nil :: Product f '[]+  Cons :: !(f a) -> Product f as -> Product f (a ': as)++-- | This type class provides a way to turn a tuple into a 'Product'.+class ToProduct (tuple :: *) (f :: u -> *) (as :: [u]) | f as -> tuple where+  toProduct :: tuple -> Product f as++instance forall (f :: u -> *) (a :: u). ToProduct (f a) f '[a] where+  toProduct :: f a -> Product f '[a]+  toProduct fa = Cons fa Nil++instance forall (f :: u -> *) (a :: u) (b :: u). ToProduct (f a, f b) f '[a, b] where+  toProduct :: (f a, f b) -> Product f '[a, b]+  toProduct (fa, fb) = Cons fa $ Cons fb Nil++instance forall (f :: u -> *) (a :: u) (b :: u) (c :: u). ToProduct (f a, f b, f c) f '[a, b, c] where+  toProduct :: (f a, f b, f c) -> Product f '[a, b, c]+  toProduct (fa, fb, fc) = Cons fa $ Cons fb $ Cons fc Nil++instance forall (f :: u -> *) (a :: u) (b :: u) (c :: u) (d :: u). ToProduct (f a, f b, f c, f d) f '[a, b, c, d] where+  toProduct :: (f a, f b, f c, f d) -> Product f '[a, b, c, d]+  toProduct (fa, fb, fc, fd) = Cons fa $ Cons fb $ Cons fc $ Cons fd Nil++-- | Turn a tuple into a 'Product'.+--+-- >>> tupleToProduct (Identity 1, Identity 2.0) :: Product Identity '[Int, Double]+-- Cons (Identity 1) (Cons (Identity 2.0) Nil)+tupleToProduct :: ToProduct t f as => t -> Product f as+tupleToProduct = toProduct++-----------------+-- OpenProduct --+-----------------++-- | @'Product' 'Identity'@ is used as a standard open product type.+type OpenProduct = Product Identity++-- | 'ToOpenProduct' gives us a way to convert a tuple to an 'OpenProduct'.+-- See 'tupleToOpenProduct'.+class ToOpenProduct (tuple :: *) (as :: [*]) | as -> tuple where+  toOpenProduct :: tuple -> OpenProduct as++instance forall (a :: *). ToOpenProduct a '[a] where+  toOpenProduct :: a -> OpenProduct '[a]+  toOpenProduct a = Cons (Identity a) Nil++instance+    forall (a :: *) (b :: *). ToOpenProduct (a, b) '[a, b] where+  toOpenProduct :: (a, b) -> OpenProduct '[a, b]+  toOpenProduct (a, b) = Cons (Identity a) $ Cons (Identity b) Nil++instance+    forall (a :: *) (b :: *) (c :: *). ToOpenProduct (a, b, c) '[a, b, c] where+  toOpenProduct :: (a, b, c) -> OpenProduct '[a, b, c]+  toOpenProduct (a, b, c) =+    Cons (Identity a) $ Cons (Identity b) $ Cons (Identity c) Nil++instance+    forall (a :: *) (b :: *) (c :: *) (d :: *).+    ToOpenProduct (a, b, c, d) '[a, b, c, d] where+  toOpenProduct :: (a, b, c, d) -> OpenProduct '[a, b, c, d]+  toOpenProduct (a, b, c, d) =+    Cons (Identity a)+      . Cons (Identity b)+      . Cons (Identity c)+      $ Cons (Identity d) Nil++-- | Turn a tuple into an 'OpenProduct'.+--+-- For example, turn a triple into an 'OpenProduct':+--+-- >>> tupleToOpenProduct (1, 2.0, "hello") :: OpenProduct '[Int, Double, String]+-- Cons (Identity 1) (Cons (Identity 2.0) (Cons (Identity "hello") Nil))+--+-- Turn a single value into an 'OpenProduct':+--+-- >>> tupleToOpenProduct 'c' :: OpenProduct '[Char]+-- Cons (Identity 'c') Nil+tupleToOpenProduct :: ToOpenProduct t as => t -> OpenProduct as+tupleToOpenProduct = toOpenProduct++---------------+-- Instances --+---------------++instance Show (Product f '[]) where+  show :: Product f '[] -> String+  show Nil = "Nil"++instance (Show (f a), Show (Product f as)) => Show (Product f (a ': as)) where+  showsPrec :: Int -> (Product f (a ': as)) -> String -> String+  showsPrec n (Cons fa prod) = showParen (n > 10) $+    showString "Cons " . showsPrec 11 fa . showString " " . showsPrec 11 prod+
+ src/Servant/Checked/Exceptions/Internal/Servant.hs view
@@ -0,0 +1,9 @@++module Servant.Checked.Exceptions.Internal.Servant+  ( module Servant.Checked.Exceptions.Internal.Servant.API+  ) where++import Servant.Checked.Exceptions.Internal.Servant.API+import Servant.Checked.Exceptions.Internal.Servant.Client ()+import Servant.Checked.Exceptions.Internal.Servant.Docs ()+import Servant.Checked.Exceptions.Internal.Servant.Server ()
+ src/Servant/Checked/Exceptions/Internal/Servant/API.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}++module Servant.Checked.Exceptions.Internal.Servant.API where++-- | 'Throws' is used in Servant API definitions and signifies that an API will+-- throw the given error.+--+-- Here is an example of how to create an API that potentially returns a+-- 'String' as an error, or an 'Int' on success:+--+-- >>> import Servant.API (Get, JSON, (:>))+-- >>> type API = Throws String :> Get '[JSON] Int+data Throws (e :: *)++-- | This is used internally and should not be used by end-users.+data Throwing (e :: [*])
+ src/Servant/Checked/Exceptions/Internal/Servant/Client.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Checked.Exceptions.Internal.Servant.Client where++import Data.Proxy (Proxy(Proxy))+import Servant.API (Verb, (:>))+import Servant.Client (HasClient(clientWithRoute, Client))+import Servant.Common.Req (Req)++import Servant.Checked.Exceptions.Internal.Envelope (Envelope)+import Servant.Checked.Exceptions.Internal.Servant.API+       (Throws, Throwing)+import Servant.Checked.Exceptions.Internal.Util (Snoc)++-- TODO: Make sure to also account for when headers are being used.++-- | Change a 'Throws' into 'Throwing'.+instance (HasClient (Throwing '[e] :> api)) => HasClient (Throws e :> api) where+  type Client (Throws e :> api) = Client (Throwing '[e] :> api)++  clientWithRoute+    :: Proxy (Throws e :> api)+    -> Req+    -> Client (Throwing '[e] :> api)+  clientWithRoute Proxy = clientWithRoute (Proxy :: Proxy (Throwing '[e] :> api))++-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'+-- but returning an @'Envelope' es@.+instance (HasClient (Verb method status ctypes (Envelope es a))) =>+    HasClient (Throwing es :> Verb method status ctypes a) where++  type Client (Throwing es :> Verb method status ctypes a) =+    Client (Verb method status ctypes (Envelope es a))++  clientWithRoute+    :: Proxy (Throwing es :> Verb method status ctypes a)+    -> Req+    -> Client (Verb method status ctypes (Envelope es a))+  clientWithRoute Proxy =+    clientWithRoute (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))++-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the+-- @e@ onto the @es@.+instance (HasClient (Throwing (Snoc es e) :> api)) =>+    HasClient (Throwing es :> Throws e :> api) where++  type Client (Throwing es :> Throws e :> api) =+    Client (Throwing (Snoc es e) :> api)++  clientWithRoute+    :: Proxy (Throwing es :> Throws e :> api)+    -> Req+    -> Client (Throwing (Snoc es e) :> api)+  clientWithRoute Proxy =+    clientWithRoute (Proxy :: Proxy (Throwing (Snoc es e) :> api))
+ src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Checked.Exceptions.Internal.Servant.Docs where++import Control.Lens ((&), (<>~))+import Data.Proxy (Proxy(Proxy))+import Data.ByteString.Lazy (ByteString)+import Data.Monoid ((<>))+import Data.Text (Text)+import Network.HTTP.Media (MediaType)+import Servant.API (Verb, (:>))+import Servant.API.ContentTypes (AllMimeRender(allMimeRender))+import Servant.Docs+       (Action, API, DocOptions, Endpoint, HasDocs(docsFor),+        ToSample(toSamples))+import Servant.Docs.Internal (apiEndpoints, respBody, response)++import Servant.Checked.Exceptions.Internal.Envelope+       (Envelope, toErrEnvelope, toSuccEnvelope)+import Servant.Checked.Exceptions.Internal.Servant.API+       (Throws, Throwing)+import Servant.Checked.Exceptions.Internal.Util (Snoc)++-- TODO: Make sure to also account for when headers are being used.++-- | Change a 'Throws' into 'Throwing'.+instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where+  docsFor+    :: Proxy (Throws e :> api)+    -> (Endpoint, Action)+    -> DocOptions+    -> API+  docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[e] :> api))++instance+       ( CreateRespBodiesFor es ctypes+       , HasDocs (Verb method status ctypes (Envelope es a))+       )+    => HasDocs (Throwing es :> Verb method status ctypes a) where+  docsFor+    :: Proxy (Throwing es :> Verb method status ctypes a)+    -> (Endpoint, Action)+    -> DocOptions+    -> API+  docsFor Proxy (endpoint, action) docOpts =+    let api =+          docsFor+            (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))+            (endpoint, action)+            docOpts+    in api & apiEndpoints . traverse . response . respBody <>~+        createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes)++-- | Create samples for a given @list@ of types, under given @ctypes@.+--+-- Additional instances of this class should not need to be created.+class CreateRespBodiesFor list ctypes where+  createRespBodiesFor+    :: Proxy list+    -> Proxy ctypes+    -> [(Text, MediaType, ByteString)]++instance CreateRespBodiesFor '[] ctypes where+  createRespBodiesFor+    :: Proxy '[]+    -> Proxy ctypes+    -> [(Text, MediaType, ByteString)]+  createRespBodiesFor Proxy Proxy = []++instance+       ( AllMimeRender ctypes (Envelope '[e] ())+       , CreateRespBodiesFor es ctypes+       , ToSample e+       )+    => CreateRespBodiesFor (e ': es) ctypes where+  createRespBodiesFor+    :: Proxy (e ': es)+    -> Proxy ctypes+    -> [(Text, MediaType, ByteString)]+  createRespBodiesFor Proxy ctypes =+    createRespBodyFor (Proxy :: Proxy e) ctypes <>+    createRespBodiesFor (Proxy :: Proxy es) ctypes++-- | Create a sample for a given @e@ under given @ctypes@.+createRespBodyFor+  :: forall e ctypes.+     (AllMimeRender ctypes (Envelope '[e] ()), ToSample e)+  => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)]+createRespBodyFor Proxy ctypes = concatMap enc samples+    where+      samples :: [(Text, Envelope '[e] ())]+      samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e)++      enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)]+      enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s++-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the+-- @e@ onto the @es@.+instance (HasDocs (Throwing (Snoc es e) :> api)) =>+    HasDocs (Throwing es :> Throws e :> api) where+  docsFor+    :: Proxy (Throwing es :> Throws e :> api)+    -> (Endpoint, Action)+    -> DocOptions+    -> API+  docsFor Proxy =+    docsFor (Proxy :: Proxy (Throwing (Snoc es e) :> api))++-- | We can generate a sample of an @'Envelope' es a@ as long as there is a way+-- to generate a sample of the @a@.+--+-- This doesn't need to worry about generating a sample of @es@, because that is+-- taken care of in the 'HasDocs' instance for @'Throwing' es@.+instance ToSample a => ToSample (Envelope es a) where+  toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)]+  toSamples Proxy = fmap toSuccEnvelope <$> toSamples (Proxy :: Proxy a)
+ src/Servant/Checked/Exceptions/Internal/Servant/Server.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Servant.Checked.Exceptions.Internal.Servant.Server where++import Data.Proxy (Proxy(Proxy))+import Servant.Server.Internal.Router (Router)+import Servant.Server.Internal.RoutingApplication (Delayed)+import Servant+       (Context, Handler, HasServer(..), ServerT, Verb, (:>))++import Servant.Checked.Exceptions.Internal.Envelope (Envelope)+import Servant.Checked.Exceptions.Internal.Servant.API+       (Throws, Throwing)+import Servant.Checked.Exceptions.Internal.Util (Snoc)++-- TODO: Make sure to also account for when headers are being used.++-- | Change a 'Throws' into 'Throwing'.+instance (HasServer (Throwing '[e] :> api) context) =>+    HasServer (Throws e :> api) context where++  type ServerT (Throws e :> api) m =+    ServerT (Throwing '[e] :> api) m++  route+    :: Proxy (Throws e :> api)+    -> Context context+    -> Delayed env (ServerT (Throwing '[e] :> api) Handler)+    -> Router env+  route _ = route (Proxy :: Proxy (Throwing '[e] :> api))++-- | When @'Throwing' es@ comes before a 'Verb', change it into the same 'Verb'+-- but returning an @'Envelope' es@.+instance (HasServer (Verb method status ctypes (Envelope es a)) context) =>+    HasServer (Throwing es :> Verb method status ctypes a) context where++  type ServerT (Throwing es :> Verb method status ctypes a) m =+    ServerT (Verb method status ctypes (Envelope es a)) m++  route+    :: Proxy (Throwing es :> Verb method status ctypes a)+    -> Context context+    -> Delayed env (ServerT (Verb method status ctypes (Envelope es a)) Handler)+    -> Router env+  route _ = route (Proxy :: Proxy (Verb method status ctypes (Envelope es a)))++-- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the+-- @e@ onto the @es@.+instance (HasServer (Throwing (Snoc es e) :> api) context) =>+    HasServer (Throwing es :> Throws e :> api) context where++  type ServerT (Throwing es :> Throws e :> api) m =+    ServerT (Throwing (Snoc es e) :> api) m++  route+    :: Proxy (Throwing es :> Throws e :> api)+    -> Context context+    -> Delayed env (ServerT (Throwing (Snoc es e) :> api) Handler)+    -> Router env+  route _ = route (Proxy :: Proxy (Throwing (Snoc es e) :> api))
+ src/Servant/Checked/Exceptions/Internal/Union.hs view
@@ -0,0 +1,511 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE EmptyCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Union++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++This module defines extensible sum-types.  This is similar to how+<https://hackage.haskell.org/package/vinyl vinyl> defines extensible records.++This is used extensively in the definition of the 'Envelope' type in+"Servant.Checked.Exceptions.Internal.Envelope".++A large portion of the code from this module was taken from the+<https://hackage.haskell.org/package/union union> package.+-}++module Servant.Checked.Exceptions.Internal.Union+  (+  -- * Union+    Union(..)+  , union+  , catchesUnion+  , absurdUnion+  , umap+  -- ** Optics+  , _This+  , _That+  -- ** Typeclasses+  , Nat(Z, S)+  , RIndex+  , UElem(..)+  , IsMember+  -- * OpenUnion+  , OpenUnion+  , openUnion+  , fromOpenUnion+  , fromOpenUnionOr+  , openUnionPrism+  , openUnionLift+  , openUnionMatch+  , catchesOpenUnion+  -- * Setup code for doctests+  -- $setup+  ) where++-- Imports for Union stuff+import Control.Applicative ((<|>))+import Control.Lens (Prism, Prism', iso, preview, prism, prism', review)+import Control.DeepSeq (NFData(rnf))+import Data.Aeson+       (FromJSON(parseJSON), ToJSON(toJSON), Value)+import Data.Aeson.Types (Parser)+import Data.Functor.Identity (Identity(Identity, runIdentity))+import Data.Typeable (Typeable)+import Text.Read (Read(readPrec), ReadPrec, (<++))++import Servant.Checked.Exceptions.Internal.Product+       (Product(Cons, Nil), ToOpenProduct, ToProduct, tupleToOpenProduct,+        tupleToProduct)+import Servant.Checked.Exceptions.Internal.Util (ReturnX)++-- $setup+-- >>> :set -XDataKinds+-- >>> :set -XTypeOperators+-- >>> import Data.Text (Text)+-- >>> import Text.Read (readMaybe)++----------------------------------------------------+-- Type-level helpers (from Data.Vinyl.TypeLevel) --+----------------------------------------------------++-- | A partial relation that gives the index of a value in a list.+--+-- Find the first item:+--+-- >>> import Data.Type.Equality ((:~:)(Refl))+-- >>> Refl :: RIndex String '[String, Int] :~: 'Z+-- Refl+--+-- Find the third item:+--+-- >>> Refl :: RIndex Char '[String, Int, Char] :~: 'S ('S 'Z)+-- Refl+type family RIndex (r :: k) (rs :: [k]) :: Nat where+  RIndex r (r ': rs) = 'Z+  RIndex r (s ': rs) = 'S (RIndex r rs)++-- | A mere approximation of the natural numbers. And their image as lifted by+-- @-XDataKinds@ corresponds to the actual natural numbers.+data Nat = Z | S !Nat++-----------------------------+-- Union (from Data.Union) --+-----------------------------++-- | A 'Union' is parameterized by a universe @u@, an interpretation @f@+-- and a list of labels @as@. The labels of the union are given by+-- inhabitants of the kind @u@; the type of values at any label @a ::+-- u@ is given by its interpretation @f a :: *@.+data Union (f :: u -> *) (as :: [u]) where+  This :: !(f a) -> Union f (a ': as)+  That :: !(Union f as) -> Union f (a ': as)+  deriving (Typeable)++-- | Case analysis for 'Union'.+--+--  Here is an example of matching on a 'This':+--+-- >>> let u = This (Identity "hello") :: Union Identity '[String, Int]+-- >>> let runIdent = runIdentity :: Identity String -> String+-- >>> union (const "not a String") runIdent u+-- "hello"+--+-- Here is an example of matching on a 'That':+--+-- >>> let v = That (This (Identity 3.3)) :: Union Identity '[String, Double, Int]+-- >>> union (const "not a String") runIdent v+-- "not a String"+union :: (Union f as -> c) -> (f a -> c) -> Union f (a ': as) -> c+union _ onThis (This a) = onThis a+union onThat _ (That u) = onThat u++-- | Since a union with an empty list of labels is uninhabited, we+-- can recover any type from it.+absurdUnion :: Union f '[] -> a+absurdUnion u = case u of {}++-- | Map over the interpretation @f@ in the 'Union'.+--+-- Here is an example of changing a @'Union' 'Identity' \'['String', 'Int']@ to+-- @'Union' 'Maybe' \'['String', 'Int']@:+--+-- >>> let u = This (Identity "hello") :: Union Identity '[String, Int]+-- >>> umap (Just . runIdentity) u :: Union Maybe '[String, Int]+-- Just "hello"+umap :: (forall a . f a -> g a) -> Union f as -> Union g as+umap f (This a) = This $ f a+umap f (That u) = That $ umap f u++catchesUnionProduct+  :: forall x f as.+     Applicative f+  => Product f (ReturnX x as) -> Union f as -> f x+catchesUnionProduct (Cons f _) (This a) = f <*> a+catchesUnionProduct (Cons _ p) (That u) = catchesUnionProduct p u+catchesUnionProduct Nil _ = undefined++-- | An alternate case anaylsis for a 'Union'.  This method uses a tuple+-- containing handlers for each potential value of the 'Union'.  This is+-- somewhat similar to the 'Control.Exception.catches' function.+--+-- Here is an example of handling a 'Union' with two possible values.  Notice+-- that a normal tuple is used:+--+-- >>> let u = This $ Identity 3 :: Union Identity '[Int, String]+-- >>> let intHandler = (Identity $ \int -> show int) :: Identity (Int -> String)+-- >>> let strHandler = (Identity $ \str -> str) :: Identity (String -> String)+-- >>> catchesUnion (intHandler, strHandler) u :: Identity String+-- Identity "3"+--+-- Given a 'Union' like @'Union' 'Identity' \'['Int', 'String']@, the type of+-- 'catchesUnion' becomes the following:+--+-- @+--   'catchesUnion'+--     :: ('Identity' ('Int' -> 'String'), 'Identity' ('String' -> 'String'))+--     -> 'Union' 'Identity' \'['Int', 'String']+--     -> 'Identity' 'String'+-- @+--+-- Checkout 'catchesOpenUnion' for more examples.+catchesUnion+  :: (Applicative f, ToProduct tuple f (ReturnX x as))+  => tuple -> Union f as -> f x+catchesUnion tuple u = catchesUnionProduct (tupleToProduct tuple) u++-- | Lens-compatible 'Prism' for 'This'.+--+-- Use '_This' to construct a 'Union':+--+-- >>> review _This (Just "hello") :: Union Maybe '[String]+-- Just "hello"+--+-- Use '_This' to try to destruct a 'Union' into a @f a@:+--+-- >>> let u = This (Identity "hello") :: Union Identity '[String, Int]+-- >>> preview _This u :: Maybe (Identity String)+-- Just (Identity "hello")+--+-- Use '_This' to try to destruct a 'Union' into a @f a@ (unsuccessfully):+--+-- >>> let v = That (This (Identity 3.3)) :: Union Identity '[String, Double, Int]+-- >>> preview _This v :: Maybe (Identity String)+-- Nothing+_This :: Prism (Union f (a ': as)) (Union f (b ': as)) (f a) (f b)+_This = prism This (union (Left . That) Right)+{-# INLINE _This #-}++-- | Lens-compatible 'Prism' for 'That'.+--+-- Use '_That' to construct a 'Union':+--+-- >>> let u = This (Just "hello") :: Union Maybe '[String]+-- >>> review _That u :: Union Maybe '[Double, String]+-- Just "hello"+--+-- Use '_That' to try to peel off a 'That' from a 'Union':+--+-- >>> let v = That (This (Identity "hello")) :: Union Identity '[Int, String]+-- >>> preview _That v :: Maybe (Union Identity '[String])+-- Just (Identity "hello")+--+-- Use '_That' to try to peel off a 'That' from a 'Union' (unsuccessfully):+--+-- >>> let w = This (Identity 3.5) :: Union Identity '[Double, String]+-- >>> preview _That w :: Maybe (Union Identity '[String])+-- Nothing+_That :: Prism (Union f (a ': as)) (Union f (a ': bs)) (Union f as) (Union f bs)+_That = prism That (union Right (Left . This))+{-# INLINE _That #-}++------------------+-- type classes --+------------------++-- | @'UElem' a as i@ provides a way to potentially get an @f a@ out of a+-- @'Union' f as@ ('unionMatch').  It also provides a way to create a+-- @'Union' f as@ from an @f a@ ('unionLift').+--+-- This is safe because of the 'RIndex' contraint. This 'RIndex' constraint+-- tells us that there /actually is/ an @a@ in @as@ at index @i@.+--+-- As an end-user, you should never need to implement an additional instance of+-- this typeclass.+class i ~ RIndex a as => UElem (a :: u) (as :: [u]) (i :: Nat) where+  {-# MINIMAL unionPrism | unionLift, unionMatch #-}++  -- | This is implemented as @'prism'' 'unionLift' 'unionMatch'@.+  unionPrism :: Prism' (Union f as) (f a)+  unionPrism = prism' unionLift unionMatch++  -- | This is implemented as @'review' 'unionPrism'@.+  unionLift :: f a -> Union f as+  unionLift = review unionPrism++  -- | This is implemented as @'preview' 'unionPrism'@.+  unionMatch :: Union f as -> Maybe (f a)+  unionMatch = preview unionPrism++instance UElem a (a ': as) 'Z where+  unionPrism :: Prism' (Union f (a ': as)) (f a)+  unionPrism = _This+  {-# INLINE unionPrism #-}++instance+    ( RIndex a (b ': as) ~ ('S i)+    , UElem a as i+    )+    => UElem a (b ': as) ('S i) where+  unionPrism :: Prism' (Union f (b ': as)) (f a)+  unionPrism = _That . unionPrism+  {-# INLINE unionPrism #-}++-- | This is a helpful 'Constraint' synonym to assert that @a@ is a member of+-- @as@.+type IsMember (a :: u) (as :: [u]) = UElem a as (RIndex a as)++---------------+-- OpenUnion --+---------------++-- | We can use @'Union' 'Identity'@ as a standard open sum type.+type OpenUnion = Union Identity++-- | Case analysis for 'OpenUnion'.+--+--  Here is an example of successfully matching:+--+-- >>> let string = "hello" :: String+-- >>> let o = openUnionLift string :: OpenUnion '[String, Int]+-- >>> openUnion (const "not a String") id o+-- "hello"+--+-- Here is an example of unsuccessfully matching:+--+-- >>> let double = 3.3 :: Double+-- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int]+-- >>> openUnion (const "not a String") id p+-- "not a String"+openUnion+  :: (OpenUnion as -> c) -> (a -> c) -> OpenUnion (a ': as) -> c+openUnion onThat onThis = union onThat (onThis . runIdentity)++-- | This is similar to 'fromMaybe' for an 'OpenUnion'.+--+--  Here is an example of successfully matching:+--+-- >>> let string = "hello" :: String+-- >>> let o = openUnionLift string :: OpenUnion '[String, Int]+-- >>> fromOpenUnion (const "not a String") o+-- "hello"+--+-- Here is an example of unsuccessfully matching:+--+-- >>> let double = 3.3 :: Double+-- >>> let p = openUnionLift double :: OpenUnion '[String, Double, Int]+-- >>> fromOpenUnion (const "not a String") p+-- "not a String"+fromOpenUnion+  :: (OpenUnion as -> a) -> OpenUnion (a ': as) -> a+fromOpenUnion onThat = openUnion onThat id++-- | Flipped version of 'fromOpenUnion'.+fromOpenUnionOr+  :: OpenUnion (a ': as) -> (OpenUnion as -> a) -> a+fromOpenUnionOr = flip fromOpenUnion++-- | Just like 'unionPrism' but for 'OpenUnion'.+openUnionPrism+  :: forall a as.+     IsMember a as+  => Prism' (OpenUnion as) a+openUnionPrism = unionPrism . iso runIdentity Identity+{-# INLINE openUnionPrism #-}++-- | Just like 'unionLift' but for 'OpenUnion'.+--+-- Creating an 'OpenUnion':+--+-- >>> let string = "hello" :: String+-- >>> openUnionLift string :: OpenUnion '[Double, String, Int]+-- Identity "hello"+openUnionLift+  :: forall a as.+     IsMember a as+  => a -> OpenUnion as+openUnionLift = review openUnionPrism++-- | Just like 'unionMatch' but for 'OpenUnion'.+--+-- Successful matching:+--+-- >>> let string = "hello" :: String+-- >>> let o = openUnionLift string :: OpenUnion '[Double, String, Int]+-- >>> openUnionMatch o :: Maybe String+-- Just "hello"+--+-- Failure matching:+--+-- >>> let double = 3.3 :: Double+-- >>> let p = openUnionLift double :: OpenUnion '[Double, String]+-- >>> openUnionMatch p :: Maybe String+-- Nothing+openUnionMatch+  :: forall a as.+     IsMember a as+  => OpenUnion as -> Maybe a+openUnionMatch = preview openUnionPrism++catchesOpenUnion+  :: ToOpenProduct tuple (ReturnX x as)+  => tuple -> OpenUnion as -> x+catchesOpenUnion tuple u =+  runIdentity $+    catchesUnionProduct (tupleToOpenProduct tuple) u++---------------+-- Instances --+---------------++instance NFData (Union f '[]) where+  rnf = absurdUnion++instance (NFData (f a), NFData (Union f as)) => NFData (Union f (a ': as)) where+  rnf = union rnf rnf++instance Show (Union f '[]) where+  showsPrec _ = absurdUnion++instance (Show (f a), Show (Union f as)) => Show (Union f (a ': as)) where+  showsPrec n = union (showsPrec n) (showsPrec n)++-- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'.+instance Read (Union f '[]) where+  readsPrec :: Int -> ReadS (Union f '[])+  readsPrec _ _ = []++-- | This is only a valid instance when the 'Read' instances for the types+-- don't overlap.+--+-- For instance, imagine we are working with a 'Union' of a 'String' and a 'Double'.+-- @3.5@ can only be read as a 'Double', not as a 'String'.+-- Oppositely, @\"hello\"@ can only be read as a 'String', not as a 'Double'.+--+-- >>> let o = readMaybe "Identity 3.5" :: Maybe (Union Identity '[Double, String])+-- >>> o+-- Just (Identity 3.5)+-- >>> o >>= openUnionMatch :: Maybe Double+-- Just 3.5+-- >>> o >>= openUnionMatch :: Maybe String+-- Nothing+--+-- >>> let p = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Double, String])+-- >>> p+-- Just (Identity "hello")+-- >>> p >>= openUnionMatch :: Maybe Double+-- Nothing+-- >>> p >>= openUnionMatch :: Maybe String+-- Just "hello"+--+-- However, imagine are we working with a 'Union' of a 'String' and 'Text'.+-- @\"hello\"@ can be 'read' as both a 'String' and 'Text'.  However, in the+-- following example, it can only be read as a 'String':+--+-- >>> let q = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[String, Text])+-- >>> q+-- Just (Identity "hello")+-- >>> q >>= openUnionMatch :: Maybe String+-- Just "hello"+-- >>> q >>= openUnionMatch :: Maybe Text+-- Nothing+--+-- If the order of the types is flipped around, we are are able to read @\"hello\"@+-- as a 'Text' but not as a 'String'.+--+-- >>> let r = readMaybe "Identity \"hello\"" :: Maybe (Union Identity '[Text, String])+-- >>> r+-- Just (Identity "hello")+-- >>> r >>= openUnionMatch :: Maybe String+-- Nothing+-- >>> r >>= openUnionMatch :: Maybe Text+-- Just "hello"+instance (Read (f a), Read (Union f as)) => Read (Union f (a ': as)) where+  readPrec :: ReadPrec (Union f (a ': as))+  readPrec = fmap This readPrec <++ fmap That readPrec++instance Eq (Union f '[]) where+  (==) = absurdUnion++instance (Eq (f a), Eq (Union f as)) => Eq (Union f (a ': as)) where+    This a1 == This a2 = a1 == a2+    That u1 == That u2 = u1 == u2+    _       == _       = False++instance Ord (Union f '[]) where+  compare = absurdUnion++instance (Ord (f a), Ord (Union f as)) => Ord (Union f (a ': as))+  where+    compare (This a1) (This a2) = compare a1 a2+    compare (That u1) (That u2) = compare u1 u2+    compare (This _)  (That _)  = LT+    compare (That _)  (This _)  = GT++instance ToJSON (Union f '[]) where+  toJSON :: Union f '[] -> Value+  toJSON = absurdUnion++instance (ToJSON (f a), ToJSON (Union f as)) => ToJSON (Union f (a ': as)) where+  toJSON :: Union f (a ': as) -> Value+  toJSON = union toJSON toJSON++-- | This will always fail, since @'Union' f \'[]@ is effectively 'Void'.+instance FromJSON (Union f '[]) where+  parseJSON :: Value -> Parser (Union f '[])+  parseJSON _ = fail "Value of Union f '[] can never be created"++-- | This is only a valid instance when the 'FromJSON' instances for the types+-- don't overlap.+--+-- This is similar to the 'Read' instance.+instance (FromJSON (f a), FromJSON (Union f as)) => FromJSON (Union f (a ': as)) where+  parseJSON :: Value -> Parser (Union f (a ': as))+  parseJSON val = fmap This (parseJSON val) <|> fmap That (parseJSON val)++-- instance f ~ Identity => Exception (Union f '[])++-- instance+--     ( f ~ Identity+--     , Exception a+--     , Typeable as+--     , Exception (Union f as)+--     ) => Exception (Union f (a ': as))+--   where+--     toException = union toException (toException . runIdentity)+--     fromException sE = matchR <|> matchL+--       where+--         matchR = This . Identity <$> fromException sE+--         matchL = That <$> fromException sE
+ src/Servant/Checked/Exceptions/Internal/Util.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++{- |+Module      :  Servant.Checked.Exceptions.Internal.Util++Copyright   :  Dennis Gosnell 2017+License     :  BSD3++Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)+Stability   :  experimental+Portability :  unknown++Additional helpers.+-}++module Servant.Checked.Exceptions.Internal.Util where++-- | A type-level @snoc@.+--+-- Append to an empty list:+--+-- >>> Refl :: Snoc '[] Double :~: '[Double]+-- Refl+--+-- Append to a non-empty list:+--+-- >>> Refl :: Snoc '[Char] String :~: '[Char, String]+-- Refl+type family Snoc (as :: [k]) (b :: k) where+  Snoc '[] b = '[b]+  Snoc (a ': as) b = (a ': Snoc as b)++-- | Change a list of types into a list of functions that take the given type+-- and return @x@.+--+-- >>> Refl :: ReturnX Double '[String, Int] :~: '[String -> Double, Int -> Double]+-- Refl+--+-- Don't do anything with an empty list:+--+-- >>> Refl :: ReturnX Double '[] :~: '[]+-- Refl+type family ReturnX x as where+  ReturnX x (a ': as) = ((a -> x) ': ReturnX x as)+  ReturnX x '[] = '[]++-- $setup+-- >>> import Data.Type.Equality ((:~:)(Refl))+
+ test/DocTest.hs view
@@ -0,0 +1,40 @@++module Main (main) where++import Prelude++import Data.Monoid ((<>))+import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doDocTest++doDocTest :: [String] -> IO ()+doDocTest options = doctest $ options <> ghcExtensions++ghcExtensions :: [String]+ghcExtensions =+    [+    --   "-XConstraintKinds"+    -- , "-XDataKinds"+      "-XDeriveDataTypeable"+    , "-XDeriveGeneric"+    -- , "-XEmptyDataDecls"+    , "-XFlexibleContexts"+    -- , "-XFlexibleInstances"+    -- , "-XGADTs"+    -- , "-XGeneralizedNewtypeDeriving"+    -- , "-XInstanceSigs"+    -- , "-XMultiParamTypeClasses"+    -- , "-XNoImplicitPrelude"+    , "-XOverloadedStrings"+    -- , "-XPolyKinds"+    -- , "-XRankNTypes"+    -- , "-XRecordWildCards"+    , "-XScopedTypeVariables"+    -- , "-XStandaloneDeriving"+    -- , "-XTupleSections"+    -- , "-XTypeFamilies"+    -- , "-XTypeOperators"+    ]