diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Api.hs b/example/Api.hs new file mode 100644 --- /dev/null +++ b/example/Api.hs @@ -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 diff --git a/example/Client.hs b/example/Client.hs new file mode 100644 --- /dev/null +++ b/example/Client.hs @@ -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 "" + diff --git a/example/Docs.hs b/example/Docs.hs new file mode 100644 --- /dev/null +++ b/example/Docs.hs @@ -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) diff --git a/example/Server.hs b/example/Server.hs new file mode 100644 --- /dev/null +++ b/example/Server.hs @@ -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 diff --git a/servant-checked-exceptions.cabal b/servant-checked-exceptions.cabal new file mode 100644 --- /dev/null +++ b/servant-checked-exceptions.cabal @@ -0,0 +1,147 @@ +name: servant-checked-exceptions +version: 0.1.0.0 +synopsis: Checked exceptions for Servant APIs. +description: Please see . +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 diff --git a/src/Servant/Checked/Exceptions.hs b/src/Servant/Checked/Exceptions.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal.hs b/src/Servant/Checked/Exceptions/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal/Envelope.hs b/src/Servant/Checked/Exceptions/Internal/Envelope.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Envelope.hs @@ -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 diff --git a/src/Servant/Checked/Exceptions/Internal/Product.hs b/src/Servant/Checked/Exceptions/Internal/Product.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Product.hs @@ -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 + diff --git a/src/Servant/Checked/Exceptions/Internal/Servant.hs b/src/Servant/Checked/Exceptions/Internal/Servant.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Servant.hs @@ -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 () diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/API.hs b/src/Servant/Checked/Exceptions/Internal/Servant/API.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Servant/API.hs @@ -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 :: [*]) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Client.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Client.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Servant/Client.hs @@ -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)) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Servant/Docs.hs @@ -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) diff --git a/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Servant/Server.hs @@ -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)) diff --git a/src/Servant/Checked/Exceptions/Internal/Union.hs b/src/Servant/Checked/Exceptions/Internal/Union.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Union.hs @@ -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 + 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 + 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 diff --git a/src/Servant/Checked/Exceptions/Internal/Util.hs b/src/Servant/Checked/Exceptions/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Servant/Checked/Exceptions/Internal/Util.hs @@ -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)) + diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -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" + ]