@@ -1,15 +1,19 @@
1+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
2{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE DeriveGeneric #-}
5{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE KindSignatures #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE PolyKinds #-}
12{-# LANGUAGE PolyKinds #-}
10{-# LANGUAGE ScopedTypeVariables #-}
13{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
15{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
13module Web.Internal.FormUrlEncoded where
17module Web.Internal.FormUrlEncoded where
15#if __GLASGOW_HASKELL__ < 710
19#if __GLASGOW_HASKELL__ < 710
@@ -17,6 +21,13 @@ import Control.Applicative
17import Data.Traversable
21import Data.Traversable
24+#if __GLASGOW_HASKELL__ < 800
25+import GHC.Exts (IsList (..))
27+import GHC.Exts (IsList (..), Constraint)
20import Control.Arrow ((***))
31import Control.Arrow ((***))
21import Control.Monad ((<=<))
32import Control.Monad ((<=<))
22import Data.ByteString.Builder (toLazyByteString, shortByteString)
33import Data.ByteString.Builder (toLazyByteString, shortByteString)
@@ -41,6 +52,7 @@ import Data.Text.Encoding as Text
41import Data.Text.Encoding.Error (lenientDecode)
52import Data.Text.Encoding.Error (lenientDecode)
43import Data.Time
54import Data.Time
44import Data.Word
56import Data.Word
46#if MIN_VERSION_base(4,8,0)
58#if MIN_VERSION_base(4,8,0)
@@ -48,7 +60,6 @@ import Data.Void
48import Numeric.Natural
60import Numeric.Natural
51−import GHC.Exts (IsList (..))
52import GHC.Generics
63import GHC.Generics
53import URI.ByteString (urlEncodeQuery, urlDecodeQuery)
64import URI.ByteString (urlEncodeQuery, urlDecodeQuery)
@@ -216,7 +227,7 @@ instance IsList Form where
216class ToForm a where
227class ToForm a where
217 -- | Convert a value into 'Form'.
228 -- | Convert a value into 'Form'.
218 toForm :: a -> Form
229 toForm :: a -> Form
219− default toForm :: (Generic a, GToForm (Rep a)) => a -> Form
230+ default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form
220 toForm = genericToForm
231 toForm = genericToForm
222instance ToForm Form where toForm = id
233instance ToForm Form where toForm = id
@@ -242,6 +253,16 @@ fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQ
243data Proxy3 a b c = Proxy3
254data Proxy3 a b c = Proxy3
256+type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where
257+#if __GLASGOW_HASKELL__ < 800
259+ NotSupported cls a reason = TypeError
260+ ( 'Text "Cannot derive a Generic-based " :<>: 'ShowType cls :<>: 'Text " instance for " :<>: 'ShowType a :<>: 'Text "." :$$:
261+ 'ShowType a :<>: 'Text " " :<>: 'Text reason :<>: 'Text "," :$$:
262+ 'Text "but Generic-based " :<>: 'ShowType cls :<>: 'Text " instances can be derived only for records" :$$:
263+ 'Text "(i.e. product types with named fields)." )
245-- | A 'Generic'-based implementation of 'toForm'.
266-- | A 'Generic'-based implementation of 'toForm'.
246-- This is used as a default implementation in 'ToForm'.
267-- This is used as a default implementation in 'ToForm'.
@@ -253,26 +274,28 @@ data Proxy3 a b c = Proxy3
253-- , age :: Int
274-- , age :: Int
254-- } deriving ('Generic')
275-- } deriving ('Generic')
256−genericToForm :: (Generic a, GToForm (Rep a)) => a -> Form
277+genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => a -> Form
257−genericToForm = gToForm . from
278+genericToForm = gToForm (Proxy :: Proxy a) . from
259−class GToForm (f :: * -> *) where
280+class GToForm t (f :: * -> *) where
260− gToForm :: f x -> Form
281+ gToForm :: Proxy t -> f x -> Form
262−instance (GToForm f, GToForm g) => GToForm (f :*: g) where
283+instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where
263− gToForm (a :*: b) = gToForm a <> gToForm b
284+ gToForm p (a :*: b) = gToForm p a <> gToForm p b
265−instance (GToForm f) => GToForm (M1 D x f) where
286+instance (GToForm t f) => GToForm t (M1 D x f) where
266− gToForm (M1 a) = gToForm a
287+ gToForm p (M1 a) = gToForm p a
268−instance (GToForm f) => GToForm (M1 C x f) where
289+instance (GToForm t f) => GToForm t (M1 C x f) where
269− gToForm (M1 a) = gToForm a
290+ gToForm p (M1 a) = gToForm p a
271−instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
292+instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where
272− gToForm (M1 (K1 c)) = fromList [(key, toQueryParam c)]
293+ gToForm _ (M1 (K1 c)) = fromList [(key, toQueryParam c)]
274 key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
295 key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
297+instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible"
276-- | Parse 'Form' into a value.
299-- | Parse 'Form' into a value.
278-- An example type and instance:
301-- An example type and instance:
@@ -311,8 +334,7 @@ instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
311class FromForm a where
334class FromForm a where
312 -- | Parse 'Form' into a value.
335 -- | Parse 'Form' into a value.
313 fromForm :: Form -> Either Text a
336 fromForm :: Form -> Either Text a
314− default fromForm :: (Generic a, GFromForm (Rep a))
337+ default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
315− => Form -> Either Text a
316 fromForm = genericFromForm
338 fromForm = genericFromForm
318instance FromForm Form where fromForm = pure
340instance FromForm Form where fromForm = pure
@@ -349,26 +371,27 @@ toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
349-- , age :: Int
371-- , age :: Int
350-- } deriving ('Generic')
372-- } deriving ('Generic')
352−genericFromForm :: (Generic a, GFromForm (Rep a))
374+genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
353− => Form -> Either Text a
354−genericFromForm f = to <$> gFromForm f
375+genericFromForm f = to <$> gFromForm (Proxy :: Proxy a) f
356−class GFromForm (f :: * -> *) where
377+class GFromForm t (f :: * -> *) where
357− gFromForm :: Form -> Either Text (f x)
378+ gFromForm :: Proxy t -> Form -> Either Text (f x)
359−instance (GFromForm f, GFromForm g) => GFromForm (f :*: g) where
380+instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where
360− gFromForm f = (:*:) <$> gFromForm f <*> gFromForm f
381+ gFromForm p f = (:*:) <$> gFromForm p f <*> gFromForm p f
362−instance (Selector s, FromHttpApiData f) => GFromForm (M1 S s (K1 i f)) where
383+instance (Selector s, FromHttpApiData f) => GFromForm t (M1 S s (K1 i f)) where
363− gFromForm form = M1 . K1 <$> parseUnique key form
384+ gFromForm _ form = M1 . K1 <$> parseUnique key form
365 key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
386 key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
367−instance (GFromForm f) => GFromForm (M1 D x f) where
388+instance GFromForm t f => GFromForm t (M1 D x f) where
389+ gFromForm p f = M1 <$> gFromForm p f
391+instance GFromForm t f => GFromForm t (M1 C x f) where
368− gFromForm f = M1 <$> gFromForm f
392+ gFromForm p f = M1 <$> gFromForm p f
370−instance (GFromForm f) => GFromForm (M1 C x f) where
394+instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
371− gFromForm f = M1 <$> gFromForm f
373-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
396-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.