diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/servant-cassava.cabal b/servant-cassava.cabal --- a/servant-cassava.cabal +++ b/servant-cassava.cabal @@ -1,10 +1,7 @@ --- Initial servant-cassava.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - name: servant-cassava -version: 0.8 +version: 0.9 synopsis: Servant CSV content-type for cassava --- description: +description: Servant CSV content-type for cassava. homepage: http://haskell-servant.readthedocs.org/ license: BSD3 license-file: LICENSE @@ -13,7 +10,6 @@ copyright: 2015-2016 Servant Contributors category: Web build-type: Simple -extra-source-files: include/*.h cabal-version: >=1.10 bug-reports: http://github.com/haskell-servant/servant-cassava/issues @@ -23,14 +19,13 @@ library exposed-modules: Servant.CSV.Cassava - -- other-modules: - -- other-extensions: build-depends: base >=4.6 && <5 + , base-compat >=0.9.1 && <0.10 + , bytestring , cassava >0.4 && <0.5 - , servant >=0.7 && <0.9 + , servant >=0.7 && <0.12 , http-media , vector hs-source-dirs: src default-language: Haskell2010 - include-dirs: include ghc-options: -Wall diff --git a/src/Servant/CSV/Cassava.hs b/src/Servant/CSV/Cassava.hs --- a/src/Servant/CSV/Cassava.hs +++ b/src/Servant/CSV/Cassava.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,34 +11,56 @@ -- | A @CSV@ empty datatype with `MimeRender` and `MimeUnrender` instances for -- @cassava@'s encoding and decoding classes. -- --- >>> type Eg = Get '[(CSV', MyEncodeOptions)] [(Int, String)] +-- >>> type Eg = Get '[CSV' 'HasHeader MyEncodeOptions] [(Int, String)] -- -- Default encoding and decoding options are also provided, along with the -- @CSV@ type synonym that uses them. -- -- >>> type EgDefault = Get '[CSV] [(Int, String)] -module Servant.CSV.Cassava where +-- +module Servant.CSV.Cassava ( module Servant.CSV.Cassava + , HasHeader(..) + ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) -#endif +import Prelude () +import Prelude.Compat + import Data.Csv -import Data.Proxy (Proxy (..)) -import Data.Typeable (Typeable) -import Data.Vector (Vector, toList) -import GHC.Generics (Generic) -import qualified Network.HTTP.Media as M -import Servant.API (Accept (..), MimeRender (..), - MimeUnrender (..)) +import Data.ByteString.Lazy (ByteString) +import Data.Proxy (Proxy (..)) +import Data.Typeable (Typeable) +import Data.Vector (Vector, toList) +import GHC.Generics (Generic) +import qualified Network.HTTP.Media as M +import Servant.API (Accept (..), MimeRender (..), + MimeUnrender (..)) -data CSV' deriving (Typeable, Generic) +data CSV' (hasHeader :: HasHeader) opt deriving (Typeable) +type CSV = CSV' 'HasHeader DefaultOpts -type CSV = (CSV', DefaultOpts) +-- | 'HasHeader singleton. +data SHasHeader (hasHeader :: HasHeader) where + SHasHeader :: SHasHeader 'HasHeader + SNoHeader :: SHasHeader 'NoHeader +-- | Class to provide 'SHasHeader' implicitly. +class SHasHeaderI (hasHeader :: HasHeader) where shasheader :: SHasHeader hasHeader +instance SHasHeaderI 'HasHeader where shasheader = SHasHeader +instance SHasHeaderI 'NoHeader where shasheader = SNoHeader + +shasheaderToBool :: SHasHeader hasHeader -> Bool +shasheaderToBool SHasHeader = True +shasheaderToBool SNoHeader = False + +lowerSHasHeader :: SHasHeader hasHeader -> HasHeader +lowerSHasHeader SHasHeader = HasHeader +lowerSHasHeader SNoHeader = NoHeader + +-- | Default options, instances providing 'defaultDecodeOptions' and 'defaultEncodeOptions'. data DefaultOpts deriving (Typeable, Generic) -- | @text/csv;charset=utf-8@ -instance Accept (CSV', a) where +instance Accept (CSV' hasHeader opt) where contentType _ = "text" M.// "csv" M./: ("charset", "utf-8") -- * Encoding @@ -45,35 +69,62 @@ -- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining -- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, [a]) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr vals - where p = Proxy :: Proxy opt +instance ( ToNamedRecord a, EncodeOpts opt, SHasHeaderI hasHeader + ) => MimeRender (CSV' hasHeader opt) (Header, [a]) where + mimeRender _ (hdr, vals) = encodeByNameWith opts hdr vals + where + opts = encodeOpts' (Proxy :: Proxy opt) (Proxy :: Proxy hasHeader) --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) [a] where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) - where p = Proxy :: Proxy opt +-- | A class to determine how to encode a list of elements +-- +-- * 'HasHeader' encode with 'encodeDefaultOrderedByNameWith' +-- +-- * 'NoHeader' encode with 'encodeWith' +-- +-- Currently, it's not possible to encode without headers using 'encodeDefaultOrderedByNameWith'. +-- +class EncodeList (hasHeader :: HasHeader) a where + encodeList :: Proxy hasHeader -> EncodeOptions -> [a] -> ByteString +-- | 'encodeDefaultOrderedByNameWith' +instance (DefaultOrdered a, ToNamedRecord a) => EncodeList 'HasHeader a where + encodeList _ opts vals = encodeDefaultOrderedByNameWith opts { encIncludeHeader = True } vals + +-- | 'encodeWith' +instance (ToRecord a) => EncodeList 'NoHeader a where + encodeList _ opts vals = encodeWith opts { encIncludeHeader = False } vals + +instance ( EncodeOpts opt, EncodeList hasHeader a + ) => MimeRender (CSV' hasHeader opt) [a] where + mimeRender _ = encodeList (Proxy :: Proxy hasHeader) opts + where + opts = encodeOpts (Proxy :: Proxy opt) + -- | Encode with 'encodeByNameWith'. The 'Header' param is used for determining -- the order of headers and fields. -instance ( ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Header, Vector a) where - mimeRender _ (hdr, vals) = encodeByNameWith (encodeOpts p) hdr (toList vals) - where p = Proxy :: Proxy opt +instance ( ToNamedRecord a, EncodeOpts opt, SHasHeaderI hasHeader + ) => MimeRender (CSV' hasHeader opt) (Header, Vector a) where + mimeRender _ (hdr, vals) = encodeByNameWith opts hdr (toList vals) + where + opts = encodeOpts' (Proxy :: Proxy opt) (Proxy :: Proxy hasHeader) --- | Encode with 'encodeDefaultOrderedByNameWith' -instance ( DefaultOrdered a, ToNamedRecord a, EncodeOpts opt - ) => MimeRender (CSV', opt) (Vector a) where - mimeRender _ = encodeDefaultOrderedByNameWith (encodeOpts p) . toList - where p = Proxy :: Proxy opt +instance ( EncodeOpts opt, EncodeList hasHeader a + ) => MimeRender (CSV' hasHeader opt) (Vector a) where + mimeRender _ = encodeList (Proxy :: Proxy hasHeader) opts . toList + where + opts = encodeOpts (Proxy :: Proxy opt) -- ** Encode Options -class EncodeOpts a where - encodeOpts :: Proxy a -> EncodeOptions +class EncodeOpts opt where + encodeOpts :: Proxy opt -> EncodeOptions +encodeOpts' + :: forall opt hasHeader. (EncodeOpts opt, SHasHeaderI hasHeader) + => Proxy opt -> Proxy hasHeader -> EncodeOptions +encodeOpts' p _ = (encodeOpts p) + { encIncludeHeader = shasheaderToBool (shasheader :: SHasHeader hasHeader) + } instance EncodeOpts DefaultOpts where encodeOpts _ = defaultEncodeOptions @@ -82,28 +133,33 @@ -- ** Instances --- | Decode with 'decodeByNameWith' +-- | Decode with 'decodeByNameWith'. instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, [a]) where + ) => MimeUnrender (CSV' 'HasHeader opt) (Header, [a]) where mimeUnrender _ bs = fmap toList <$> decodeByNameWith (decodeOpts p) bs where p = Proxy :: Proxy opt --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) [a] where - mimeUnrender _ bs = toList <$> decodeWith (decodeOpts p) HasHeader bs - where p = Proxy :: Proxy opt +-- | Decode with 'decodeWith'. +instance ( FromRecord a, DecodeOpts opt, SHasHeaderI hasHeader + ) => MimeUnrender (CSV' hasHeader opt) [a] where + mimeUnrender _ = fmap toList . decodeWith (decodeOpts p) (lowerSHasHeader sh) + where + p = Proxy :: Proxy opt + sh = shasheader :: SHasHeader hasHeader instance ( FromNamedRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Header, Vector a) where + ) => MimeUnrender (CSV' 'HasHeader opt) (Header, Vector a) where mimeUnrender _ = decodeByNameWith (decodeOpts p) where p = Proxy :: Proxy opt --- | Decode with 'decodeWith'. Assumes data has headers, which are stripped. -instance ( FromRecord a, DecodeOpts opt - ) => MimeUnrender (CSV', opt) (Vector a) where - mimeUnrender _ = decodeWith (decodeOpts p) HasHeader - where p = Proxy :: Proxy opt +-- | Decode with 'decodeWith'. +instance ( FromRecord a, DecodeOpts opt, SHasHeaderI hasHeader + ) => MimeUnrender (CSV' hasHeader opt) (Vector a) where + mimeUnrender _ = decodeWith (decodeOpts p) (lowerSHasHeader sh) + where + p = Proxy :: Proxy opt + sh = shasheader :: SHasHeader hasHeader + -- ** Decode Options