From 68afccfff5a39e92903c467fac3a99734ce8a404 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Sat, 19 Nov 2011 18:40:12 +0900
Subject: [PATCH] auto-derive SortingCollection

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---
 Data/Collections/Newtype/TH.hs  | 15 +++++++++++++++
 Network/HTTP/Lucu/MIMEParams.hs |  8 ++------
 2 files changed, 17 insertions(+), 6 deletions(-)

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index e3cb868..b3c7e59 100644
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -8,6 +8,7 @@ module Data.Collections.Newtype.TH
     )
     where
 import Control.Applicative hiding (empty)
+import Control.Arrow
 import Control.Monad.Unicode
 import Data.Collections
 import Data.Collections.BaseInstances ()
@@ -56,6 +57,8 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
         = return (wrapperTy, deriveFoldable)
     | classTy ≡ ''Collection
         = return (wrapperTy, deriveCollection)
+    | classTy ≡ ''SortingCollection
+        = return (wrapperTy, deriveSortingCollection)
 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
     | classTy ≡ ''Indexed
         = return (wrapperTy, deriveIndexed)
@@ -200,3 +203,15 @@ deriveIndexed c ty wrap unwrap
               = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
           | otherwise
               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
+
+deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveSortingCollection c ty wrap unwrap
+    = do names ← methodNames ''SortingCollection
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'minView
+              = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
+          | otherwise
+              = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name
diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 3698213..a3722a3 100644
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -22,7 +22,6 @@ module Network.HTTP.Lucu.MIMEParams
     )
     where
 import Control.Applicative hiding (empty)
-import Control.Arrow
 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
@@ -61,6 +60,8 @@ C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text)
              instance Foldable   MIMEParams (CIAscii, Text)
              instance Collection MIMEParams (CIAscii, Text)
              instance Indexed    MIMEParams  CIAscii  Text
+             -- instance Map        MIMEParams  CIAscii  Text
+             instance SortingCollection MIMEParams (CIAscii, Text)
            |]
 
 -- FIXME: auto-derive
@@ -86,11 +87,6 @@ instance Map MIMEParams CIAscii Text where
     isProperSubmapBy f (MIMEParams α) (MIMEParams β)
         = isProperSubmapBy f α β
 
--- FIXME: auto-derive
-instance SortingCollection MIMEParams (CIAscii, Text) where
-    {-# INLINE minView #-}
-    minView (MIMEParams m) = second MIMEParams <$> minView m
-
 -- |Convert MIME parameter values to an 'AsciiBuilder'.
 printMIMEParams ∷ MIMEParams → AsciiBuilder
 {-# INLINEABLE printMIMEParams #-}
-- 
2.40.0