diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,11 @@ # Changelog +## 1.13 + +* Change the type of `Reason_` from `Reason ()` to `Reason Void` +* Remove the no longer needed `ToResponseCode ()` instance +* Removed `Error` instances for `DataError`, `Reason e`, and `SomeReason`. + ## 1.12 * Add `method` field to `Resource`, allowing you to use different diff --git a/rest-types.cabal b/rest-types.cabal --- a/rest-types.cabal +++ b/rest-types.cabal @@ -1,5 +1,5 @@ name: rest-types -version: 1.12 +version: 1.13 description: Silk Rest Framework Types synopsis: Silk Rest Framework Types maintainer: code@silk.co @@ -28,9 +28,11 @@ Rest.Types.Method Rest.Types.Range Rest.Types.ShowUrl + Rest.Types.Void build-depends: base == 4.* , aeson >= 0.7 && < 0.9 + , case-insensitive >= 1.2 && < 1.3 , generic-aeson >= 0.1 && < 0.3 , hxt >= 9.2 && < 9.4 , json-schema >= 0.6 && < 0.8 @@ -39,4 +41,6 @@ , regular-xmlpickler == 0.2.* , rest-stringmap == 0.2.* , text >= 0.11 && < 1.3 + , transformers >= 0.3 && < 0.5 + , transformers-compat >= 0.3 && < 0.5 , uuid >= 1.2 && < 1.4 diff --git a/src/Rest/Types/Container/Resource.hs b/src/Rest/Types/Container/Resource.hs --- a/src/Rest/Types/Container/Resource.hs +++ b/src/Rest/Types/Container/Resource.hs @@ -16,6 +16,7 @@ ) where import Data.Aeson hiding (Value) +import Data.CaseInsensitive (CI) import Data.JSON.Schema (JSONSchema (..), gSchema) import Data.Typeable import GHC.Generics @@ -28,6 +29,7 @@ import qualified Data.JSON.Schema.Combinators as Json type KeyValues = StringHashMap String Value +type CaseInsensitiveKeyValues = StringHashMap (CI String) Value newtype Value = Value { unValue :: String } deriving (Show, Typeable) @@ -43,7 +45,7 @@ data Resource = Resource { uri :: String , method :: Method - , headers :: KeyValues + , headers :: CaseInsensitiveKeyValues , parameters :: KeyValues , input :: String } deriving (Generic, Show, Typeable) diff --git a/src/Rest/Types/Error.hs b/src/Rest/Types/Error.hs --- a/src/Rest/Types/Error.hs +++ b/src/Rest/Types/Error.hs @@ -12,18 +12,17 @@ , TypeFamilies #-} module Rest.Types.Error - ( DataError(..) - , DomainReason(..) - , Status(..) + ( DataError (..) + , DomainReason (..) + , Status (..) , fromEither , toEither , Reason_ - , Reason(..) - , SomeReason(..) - , ToResponseCode(..) + , Reason (..) + , SomeReason (..) + , ToResponseCode (..) ) where -import Control.Monad.Error import Data.Aeson hiding (Success) import Data.Foldable (Foldable) import Data.JSON.Schema (JSONSchema (..), gSchema) @@ -38,6 +37,8 @@ import Text.XML.HXT.Arrow.Pickle.Xml import qualified Data.JSON.Schema as JSONSchema +import Rest.Types.Void + -- Error utilities. data DataError @@ -64,7 +65,7 @@ data Status a b = Failure a | Success b deriving (Eq, Show, Generic, Typeable, Functor, Foldable, Traversable) -$(deriveAll ''Status "PFStatus") +deriveAll ''Status "PFStatus" type instance PF (Status a b) = PFStatus a b instance (XmlPickler a, XmlPickler b) => XmlPickler (Status a b) where @@ -83,7 +84,7 @@ toEither (Success x) = Right x toEither (Failure y) = Left y -type Reason_ = Reason () +type Reason_ = Reason Void data Reason a -- Thrown in the router. @@ -109,12 +110,8 @@ | CustomReason (DomainReason a) deriving (Eq, Generic, Show, Typeable, Functor, Foldable, Traversable) -instance Error DataError - -instance Error (Reason e) - -$(deriveAll ''DataError "PFDataError") -$(deriveAll ''Reason "PFReason") +deriveAll ''DataError "PFDataError" +deriveAll ''Reason "PFReason" type instance PF DataError = PFDataError type instance PF (Reason e) = PFReason e @@ -133,8 +130,6 @@ data SomeReason where SomeReason :: (XmlPickler e, JSONSchema e, ToJSON e) => Reason e -> SomeReason -instance Error SomeReason - deriving instance Typeable SomeReason instance XmlPickler SomeReason where @@ -153,10 +148,8 @@ class ToResponseCode a where toResponseCode :: a -> Int --- This instance shouldn't be here, and instead the None dictionary in --- Rest.Dictionary.Types should have type Dicts f Void. -instance ToResponseCode () where - toResponseCode () = 500 +instance ToResponseCode Void where + toResponseCode = magic instance ToResponseCode a => ToResponseCode (Reason a) where toResponseCode e = diff --git a/src/Rest/Types/Info.hs b/src/Rest/Types/Info.hs --- a/src/Rest/Types/Info.hs +++ b/src/Rest/Types/Info.hs @@ -3,7 +3,7 @@ , TypeSynonymInstances #-} -- | Module facilitating informative inspection of datatypes. -module Rest.Types.Info where +module Rest.Types.Info (Info (..)) where import Data.Text (Text) import Data.Typeable diff --git a/src/Rest/Types/Void.hs b/src/Rest/Types/Void.hs new file mode 100644 --- /dev/null +++ b/src/Rest/Types/Void.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE + DeriveDataTypeable + , EmptyDataDecls + , RankNTypes + , TypeFamilies + #-} +module Rest.Types.Void (Void (..)) where + +import Data.Aeson (FromJSON (..), ToJSON (..)) +import Data.JSON.Schema (JSONSchema (..), Schema(Choice)) +import Data.Typeable (Typeable) +import GHC.Generics +import Text.XML.HXT.Arrow.Pickle (XmlPickler (..), PU (..)) +import Text.XML.HXT.Arrow.Pickle.Schema (Schema(Alt)) +import Text.XML.HXT.Arrow.Pickle.Xml (Unpickler (UP)) + +-- * The @Void@ type. + +-- | The 'Void' type is used as the identifier for resources that +-- can't be routed to. It contains no values apart from bottom. + +newtype Void = Void { magic :: forall a. a } deriving (Typeable) + +-- This instance is needed for generated API clients. + +instance FromJSON Void where + parseJSON = fail "Cannot parse Void in FromJSON." + +instance ToJSON Void where + toJSON = magic + +instance JSONSchema Void where + schema _ = Choice [] + +instance XmlPickler Void where + xpickle = PU magic (UP (\st -> (Left ("Cannot unpickle Void.", st), st))) (Alt []) + +instance Show Void where + show = magic + +-- | Generic. Can't derive it, sadly. + +instance Generic Void where + type Rep Void = D1 D1Void V1 + from = magic + to (M1 x) = x `seq` Void (error "Impossible: constructing a Void in Generic instance.") + +data D1Void + +instance Datatype D1Void where + datatypeName _ = "Void" + moduleName _ = "Rest.Types.Void"