Drop Mime{,Un}Render instances that do not shrink head.

servant-docs/example/greet.hs

@@ -30,6 +30,9 @@ instance ToJSON Greet
 instance MimeRender PlainText Greet where
     mimeRender Proxy (Greet s) = "\"" <> cs s <> "\""
 
+instance MimeRender JSON Greet where
+    mimeRender Proxy = encode
+
 -- We add some useful annotations to our captures,
 -- query parameters and request body to make the docs
 -- really helpful.

servant-docs/test/Servant/DocsSpec.hs

@@ -216,3 +216,6 @@ compareWith f msg x y = unless (f x y) $ assertFailure $
 golden :: TestName -> FilePath -> String -> TestTreeM ()
 golden n fp contents = TestTreeM $ tell
     [ goldenVsString n fp (return (cs contents)) ]
+
+instance ToJSON a => MimeRender JSON a where
+  mimeRender _ = encode

servant-server/example/greet.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PolyKinds         #-}
 {-# LANGUAGE TypeFamilies      #-}
@@ -26,6 +28,8 @@ newtype Greet = Greet { _msg :: Text }
 instance FromJSON Greet
 instance ToJSON Greet
 
+instance ToJSON a => MimeRender JSON a where mimeRender _ = encode
+
 -- API specification
 type TestApi =
        -- GET /hello/:name?capital={true, false}  returns a Greet as JSON

servant-server/test/Servant/ArbitraryMonadServerSpec.hs

@@ -1,9 +1,14 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 module Servant.ArbitraryMonadServerSpec where
 
 import           Control.Monad.Reader
+import           Data.Aeson
+                 (encode)
 import           Data.Functor.Identity
 import           Data.Proxy
 import           Servant.API
@@ -60,3 +65,7 @@ enterSpec = describe "Enter" $ do
   with (return (serve combinedAPI combinedReaderServer)) $ do
     it "allows combnation of enters" $ do
       get "bool" `shouldRespondWith` "true"
+
+instance MimeRender JSON Bool where mimeRender _ = encode
+instance MimeRender JSON Int where mimeRender _ = encode
+instance MimeRender JSON String where mimeRender _ = encode

servant-server/test/Servant/HoistSpec.hs

@@ -1,7 +1,13 @@
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 module Servant.HoistSpec where
 
+import           Data.Aeson
+                 (ToJSON, encode)
 import           Test.Hspec
                  (Spec)
 
@@ -31,6 +37,8 @@ f = id
 server' :: App Int :<|> (String -> App Bool)
 server' = hoistServer api f server
 
+instance ToJSON a => MimeRender JSON a where mimeRender _ = encode
+
 -------------------------------------------------------------------------------
 -- Spec
 -------------------------------------------------------------------------------

servant-server/test/Servant/Server/ErrorSpec.hs

@@ -360,4 +360,7 @@ instance MimeUnrender PlainText Int where
 
 instance MimeRender PlainText Int where
     mimeRender _ = BCL.pack . show
+
+instance MimeRender JSON Integer where mimeRender _ = encode
+instance MimeRender JSON Int where mimeRender _ = encode
 -- }}}

servant-server/test/Servant/Server/UsingContextSpec.hs

@@ -1,10 +1,14 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeSynonymInstances #-}
 
 module Servant.Server.UsingContextSpec where
 
+import           Data.Aeson
+                 (encode)
 import           Network.Wai
 import           Test.Hspec
                  (Spec, describe, it)
@@ -20,6 +24,8 @@ spec = do
   spec3
   spec4
 
+instance MimeRender JSON String where mimeRender _ = encode
+
 -- * API
 
 type OneEntryAPI =

servant-server/test/Servant/ServerSpec.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveGeneric       #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -50,6 +51,7 @@ import           Servant.API
                  BasicAuthData (BasicAuthData), Capture, Capture', CaptureAll,
                  Delete, EmptyAPI, Fragment, Get, HasStatus (StatusOf), Header,
                  Headers, HttpVersion, IsSecure (..), JSON, Lenient,
+                 MimeRender (..),
                  NoContent (..), NoContentVerb, NoFraming, OctetStream, Patch,
                  PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, Raw,
                  RemoteHost, ReqBody, SourceIO, StdMethod (..), Stream, Strict,
@@ -106,6 +108,8 @@ spec = do
 -- * verbSpec {{{
 ------------------------------------------------------------------------------
 
+instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where mimeRender _ = encode
+
 type VerbApi method status
     =                Verb method status '[JSON] Person
  :<|> "noContent" :> NoContentVerb method

servant/servant.cabal

@@ -154,6 +154,7 @@ test-suite spec
     , base-compat
     , aeson
     , bytestring
+    , http-api-data
     , http-media
     , mtl
     , servant

servant/src/Servant/API/ContentTypes.hs

@@ -74,7 +74,7 @@ import           Control.Monad.Compat
 import           Control.DeepSeq
                  (NFData)
 import           Data.Aeson
-                 (FromJSON (..), ToJSON (..), encode)
+                 (FromJSON (..))
 import           Data.Aeson.Parser
                  (value)
 import           Data.Aeson.Types
@@ -102,7 +102,7 @@ import qualified Network.HTTP.Media               as M
 import           Prelude ()
 import           Prelude.Compat
 import           Web.FormUrlEncoded
-                 (FromForm, ToForm, urlDecodeAsForm, urlEncodeAsForm)
+                 (FromForm, urlDecodeAsForm)
 
 -- * Provided content types
 data JSON deriving Typeable
@@ -327,18 +327,6 @@ instance ( MimeUnrender ctyp a
 --------------------------------------------------------------------------
 -- * MimeRender Instances
 
--- | `encode`
-instance {-# OVERLAPPABLE #-}
-         ToJSON a => MimeRender JSON a where
-    mimeRender _ = encode
-
--- | @urlEncodeAsForm@
--- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
--- holds if every element of x is non-null (i.e., not @("", "")@)
-instance {-# OVERLAPPABLE #-}
-         ToForm a => MimeRender FormUrlEncoded a where
-    mimeRender _ = urlEncodeAsForm
-
 -- | `TextL.encodeUtf8`
 instance MimeRender PlainText TextL.Text where
     mimeRender _ = TextL.encodeUtf8
@@ -388,16 +376,6 @@ eitherDecodeLenient input =
           <* skipSpace
           <* (endOfInput <?> "trailing junk after valid JSON")
 
--- | `eitherDecode`
-instance FromJSON a => MimeUnrender JSON a where
-    mimeUnrender _ = eitherDecodeLenient
-
--- | @urlDecodeAsForm@
--- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
--- holds if every element of x is non-null (i.e., not @("", "")@)
-instance FromForm a => MimeUnrender FormUrlEncoded a where
-    mimeUnrender _ = left TextS.unpack . urlDecodeAsForm
-
 -- | @left show . TextL.decodeUtf8'@
 instance MimeUnrender PlainText TextL.Text where
     mimeUnrender _ = left show . TextL.decodeUtf8'

servant/test/Servant/API/ContentTypesSpec.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE PackageImports        #-}
@@ -39,6 +40,8 @@ import           Test.QuickCheck
 import           "quickcheck-instances" Test.QuickCheck.Instances ()
 import           Text.Read
                  (readMaybe)
+import           Web.FormUrlEncoded
+                 (ToForm, urlEncodeAsForm)
 
 import           Servant.API.ContentTypes
 
@@ -271,3 +274,19 @@ addToAccept p (ZeroToOne f) (AcceptHeader h) = AcceptHeader (cont h)
     where new = cs (show $ contentType p) `append` "; q=" `append` pack (show f)
           cont "" = new
           cont old = old `append` ", " `append` new
+
+-- | `encode`
+--
+-- This instance is not provided with the library to avoid unsolvable ambiguous instance
+-- problems.  Example: @instance MimeRender a => MimeRender (WithStatus n a)@
+instance {-# OVERLAPPABLE #-} ToJSON a => MimeRender JSON a where
+  mimeRender _ = encode
+
+-- | @urlEncodeAsForm@
+-- Note that the @mimeUnrender p (mimeRender p x) == Right x@ law only
+-- holds if every element of x is non-null (i.e., not @("", "")@)
+--
+-- This instance is not provided with the library to avoid unsolvable ambiguous instance
+-- problems.
+instance {-# OVERLAPPABLE #-} ToForm a => MimeRender FormUrlEncoded a where
+  mimeRender _ = urlEncodeAsForm