@@ -1,15 +1,19 @@
1+{-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
12{-# LANGUAGE CPP #-}
3+{-# LANGUAGE DataKinds #-}
24{-# LANGUAGE DefaultSignatures #-}
35{-# LANGUAGE DeriveGeneric #-}
46{-# LANGUAGE FlexibleContexts #-}
57{-# LANGUAGE FlexibleInstances #-}
68{-# LANGUAGE GeneralizedNewtypeDeriving #-}
79{-# LANGUAGE KindSignatures #-}
10+{-# LANGUAGE MultiParamTypeClasses #-}
811{-# LANGUAGE OverloadedStrings #-}
912{-# LANGUAGE PolyKinds #-}
1013{-# LANGUAGE ScopedTypeVariables #-}
1114{-# LANGUAGE TypeFamilies #-}
1215{-# LANGUAGE TypeOperators #-}
16+{-# LANGUAGE UndecidableInstances #-}
1317module Web.Internal.FormUrlEncoded where
1418
1519#if __GLASGOW_HASKELL__ < 710
@@ -17,6 +21,13 @@ import Control.Applicative
1721import Data.Traversable
1822#endif
1923
24+#if __GLASGOW_HASKELL__ < 800
25+import GHC.Exts (IsList (..))
26+#else
27+import GHC.Exts (IsList (..), Constraint)
28+import GHC.TypeLits
29+#endif
30+
2031import Control.Arrow ((***))
2132import Control.Monad ((<=<))
2233import Data.ByteString.Builder (toLazyByteString, shortByteString)
@@ -41,6 +52,7 @@ import Data.Text.Encoding as Text
4152import Data.Text.Encoding.Error (lenientDecode)
4253
4354import Data.Time
55+import Data.Proxy
4456import Data.Word
4557
4658#if MIN_VERSION_base(4,8,0)
@@ -48,7 +60,6 @@ import Data.Void
4860import Numeric.Natural
4961#endif
5062
51−import GHC.Exts (IsList (..))
5263import GHC.Generics
5364import URI.ByteString (urlEncodeQuery, urlDecodeQuery)
5465
@@ -216,7 +227,7 @@ instance IsList Form where
216227class ToForm a where
217228 -- | Convert a value into 'Form'.
218229 toForm :: a -> Form
219− default toForm :: (Generic a, GToForm (Rep a)) => a -> Form
230+ default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form
220231 toForm = genericToForm
221232
222233instance ToForm Form where toForm = id
@@ -242,6 +253,16 @@ fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQ
242253
243254data Proxy3 a b c = Proxy3
244255
256+type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where
257+#if __GLASGOW_HASKELL__ < 800
258+#else
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)." )
264+#endif
265+
245266-- | A 'Generic'-based implementation of 'toForm'.
246267-- This is used as a default implementation in 'ToForm'.
247268--
@@ -253,26 +274,28 @@ data Proxy3 a b c = Proxy3
253274-- , age :: Int
254275-- } deriving ('Generic')
255276-- @
256−genericToForm :: (Generic a, GToForm (Rep a)) => a -> Form
257−genericToForm = gToForm . from
277+genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => a -> Form
278+genericToForm = gToForm (Proxy :: Proxy a) . from
258279
259−class GToForm (f :: * -> *) where
260− gToForm :: f x -> Form
280+class GToForm t (f :: * -> *) where
281+ gToForm :: Proxy t -> f x -> Form
261282
262−instance (GToForm f, GToForm g) => GToForm (f :*: g) where
263− gToForm (a :*: b) = gToForm a <> gToForm b
283+instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where
284+ gToForm p (a :*: b) = gToForm p a <> gToForm p b
264285
265−instance (GToForm f) => GToForm (M1 D x f) where
266− gToForm (M1 a) = gToForm a
286+instance (GToForm t f) => GToForm t (M1 D x f) where
287+ gToForm p (M1 a) = gToForm p a
267288
268−instance (GToForm f) => GToForm (M1 C x f) where
269− gToForm (M1 a) = gToForm a
289+instance (GToForm t f) => GToForm t (M1 C x f) where
290+ gToForm p (M1 a) = gToForm p a
270291
271−instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
272− gToForm (M1 (K1 c)) = fromList [(key, toQueryParam c)]
292+instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where
293+ gToForm _ (M1 (K1 c)) = fromList [(key, toQueryParam c)]
273294 where
274295 key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
275296
297+instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible"
298+
276299-- | Parse 'Form' into a value.
277300--
278301-- An example type and instance:
@@ -311,8 +334,7 @@ instance (Selector s, ToHttpApiData c) => GToForm (M1 S s (K1 i c)) where
311334class FromForm a where
312335 -- | Parse 'Form' into a value.
313336 fromForm :: Form -> Either Text a
314− default fromForm :: (Generic a, GFromForm (Rep a))
315− => Form -> Either Text a
337+ default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
316338 fromForm = genericFromForm
317339
318340instance FromForm Form where fromForm = pure
@@ -349,26 +371,27 @@ toEntriesByKey = traverse parseGroup . HashMap.toList . unForm
349371-- , age :: Int
350372-- } deriving ('Generic')
351373-- @
352−genericFromForm :: (Generic a, GFromForm (Rep a))
353− => Form -> Either Text a
354−genericFromForm f = to <$> gFromForm f
374+genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => Form -> Either Text a
375+genericFromForm f = to <$> gFromForm (Proxy :: Proxy a) f
355376
356−class GFromForm (f :: * -> *) where
357− gFromForm :: Form -> Either Text (f x)
377+class GFromForm t (f :: * -> *) where
378+ gFromForm :: Proxy t -> Form -> Either Text (f x)
358379
359−instance (GFromForm f, GFromForm g) => GFromForm (f :*: g) where
360− gFromForm f = (:*:) <$> gFromForm f <*> gFromForm f
380+instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where
381+ gFromForm p f = (:*:) <$> gFromForm p f <*> gFromForm p f
361382
362−instance (Selector s, FromHttpApiData f) => GFromForm (M1 S s (K1 i f)) where
363− gFromForm form = M1 . K1 <$> parseUnique key form
383+instance (Selector s, FromHttpApiData f) => GFromForm t (M1 S s (K1 i f)) where
384+ gFromForm _ form = M1 . K1 <$> parseUnique key form
364385 where
365386 key = Text.pack $ selName (Proxy3 :: Proxy3 s g p)
366387
367−instance (GFromForm f) => GFromForm (M1 D x f) where
368− gFromForm f = M1 <$> gFromForm f
388+instance GFromForm t f => GFromForm t (M1 D x f) where
389+ gFromForm p f = M1 <$> gFromForm p f
390+
391+instance GFromForm t f => GFromForm t (M1 C x f) where
392+ gFromForm p f = M1 <$> gFromForm p f
369393
370−instance (GFromForm f) => GFromForm (M1 C x f) where
371− gFromForm f = M1 <$> gFromForm f
394+instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"
372395
373396-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.
374397--