From 852d97c73c367bc7880600850d92463f580ca1ca Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Sat, 19 Nov 2011 15:31:50 +0900
Subject: [PATCH] auto-derive Collection / Indexed

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---
 Data/Collections/Newtype/TH.hs  | 39 ++++++++++++++++++++++++++++++++-
 Network/HTTP/Lucu/MIMEParams.hs | 18 +++------------
 2 files changed, 41 insertions(+), 16 deletions(-)

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index d81cb01..e3cb868 100644
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -18,7 +18,7 @@ import Data.Maybe
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Ppr
 import Language.Haskell.TH.Syntax
-import Prelude hiding ( concat, concatMap, exp
+import Prelude hiding ( concat, concatMap, exp, filter
                       , foldl, foldr, foldl1, foldr1, null)
 import Prelude.Unicode
 
@@ -54,6 +54,11 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
         = return (wrapperTy, deriveUnfoldable)
     | classTy ≡ ''Foldable
         = return (wrapperTy, deriveFoldable)
+    | classTy ≡ ''Collection
+        = return (wrapperTy, deriveCollection)
+inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
+    | classTy ≡ ''Indexed
+        = return (wrapperTy, deriveIndexed)
 inspectInstance ty
     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
 
@@ -163,3 +168,35 @@ deriveFoldable c ty _ unwrap
               = [| isSingleton ∘ $unwrap |]
           | otherwise
               = fail $ "deriveFoldable: unknown method: " ⧺ pprint name
+
+deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveCollection c ty wrap unwrap
+    = do names ← methodNames ''Collection
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'filter
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |]
+          | otherwise
+              = fail $ "deriveCollection: unknown method: " ⧺ pprint name
+
+deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveIndexed c ty wrap unwrap
+    = do names ← methodNames ''Indexed
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'index
+              = [| (∘ $unwrap) ∘ index |]
+          | name ≡ 'adjust
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |]
+          | name ≡ 'inDomain
+              = [| (∘ $unwrap) ∘ inDomain |]
+          | name ≡ '(//)
+              = [| ($wrap ∘) ∘ (//) ∘ $unwrap |]
+          | name ≡ 'accum
+              = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |]
+          | otherwise
+              = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index 183a4c0..3698213 100644
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -11,7 +11,7 @@
   , UnicodeSyntax
   #-}
 {-# OPTIONS_GHC -ddump-splices #-} -- FIXME
--- GHC 7.0.3 gives us a false warning.
+-- THINKME: GHC 7.0.3 gives us a false warning.
 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
 -- |Parsing and printing MIME parameter values
 -- (<http://tools.ietf.org/html/rfc2231>).
@@ -59,22 +59,10 @@ newtype MIMEParams
 
 C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text)
              instance Foldable   MIMEParams (CIAscii, Text)
+             instance Collection MIMEParams (CIAscii, Text)
+             instance Indexed    MIMEParams  CIAscii  Text
            |]
 
--- FIXME: auto-derive
-instance Collection MIMEParams (CIAscii, Text) where
-    {-# INLINE filter #-}
-    filter f (MIMEParams m) = MIMEParams $ filter f m
-
--- FIXME: auto-derive
-instance Indexed MIMEParams CIAscii Text where
-    {-# INLINE index #-}
-    index k (MIMEParams m) = index k m
-    {-# INLINE adjust #-}
-    adjust f k (MIMEParams m) = MIMEParams $ adjust f k m
-    {-# INLINE inDomain #-}
-    inDomain k (MIMEParams m) = inDomain k m
-
 -- FIXME: auto-derive
 instance Map MIMEParams CIAscii Text where
     {-# INLINE lookup #-}
-- 
2.40.0