auto-derive SortingCollection

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index e3cb868e5ab460428cc7fbdce00427f00a7d0300..b3c7e59d41feb74a387e5939d59e0d6007a05ccf 100644 (file)
--- 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)
     )
     where
 import Control.Applicative hiding (empty)

+import Control.Arrow

 import Control.Monad.Unicode
 import Data.Collections
 import Data.Collections.BaseInstances ()
 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)
         = 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)
 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
               = [| (($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 36982139ce257433018b4530f5f9058352c041a6..a3722a34958bfae90194a724e823c5c380fca553 100644 (file)
--- 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)
     )
     where
 import Control.Applicative hiding (empty)

-import Control.Arrow

 import Control.Monad hiding (mapM)
 import Control.Monad.Unicode
 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
 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 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
            |]
 
 -- FIXME: auto-derive


@@ -86,11 +87,6 @@ instance Map MIMEParams CIAscii Text where
     isProperSubmapBy f (MIMEParams α) (MIMEParams β)
         = isProperSubmapBy f α β
 
     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 #-}
 -- |Convert MIME parameter values to an 'AsciiBuilder'.
 printMIMEParams ∷ MIMEParams → AsciiBuilder
 {-# INLINEABLE printMIMEParams #-}