From: PHO <pho@cielonegro.org>
Date: Mon, 21 Nov 2011 09:13:05 +0000 (+0900)
Subject: auto-derive Set
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=f7fdfa7b306619a37f31504109b23c362066ec8b;p=Lucu.git

auto-derive Set

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index d392758..c60ea2b 100644
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -59,6 +59,8 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
         = return (wrapperTy, deriveFoldable)
     | classTy ≡ ''Collection
         = return (wrapperTy, deriveCollection)
+    | classTy ≡ ''Set
+        = return (wrapperTy, deriveSet)
     | classTy ≡ ''SortingCollection
         = return (wrapperTy, deriveSortingCollection)
 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
@@ -254,6 +256,18 @@ deriveMap c ty wrap unwrap
           | otherwise
               = fail $ "deriveMap: unknown method: " ⧺ pprint name
 
+deriveSet ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveSet c ty _ _
+    = do names ← methodNames ''Set
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'haddock_candy
+              = [| haddock_candy |]
+          | otherwise
+              = fail $ "deriveSet: unknown method: " ⧺ pprint name
+
 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 deriveSortingCollection c ty wrap unwrap
     = do names ← methodNames ''SortingCollection
diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index 9ed1d8d..a341d82 100644
--- a/Network/HTTP/Lucu/Implant/Rewrite.hs
+++ b/Network/HTTP/Lucu/Implant/Rewrite.hs
@@ -3,8 +3,10 @@
   , GeneralizedNewtypeDeriving
   , MultiParamTypeClasses
   , RecordWildCards
+  , TemplateHaskell
   , UnicodeSyntax
   #-}
+{-# OPTIONS_GHC -fno-warn-missing-methods #-}
 -- |An internal module for rewriting 'Name's in Template Haskell AST.
 module Network.HTTP.Lucu.Implant.Rewrite
     ( NamePat(..)
@@ -24,10 +26,10 @@ module Network.HTTP.Lucu.Implant.Rewrite
     )
     where
 import Control.Applicative hiding (empty)
-import Control.Arrow
 import Control.Monad.State
 import Data.Collections
 import Data.Collections.BaseInstances ()
+import qualified Data.Collections.Newtype.TH as C
 import Data.Data
 import Data.Generics.Aliases hiding (GT)
 import Data.Generics.Schemes
@@ -81,6 +83,13 @@ data RewriteRule
       , rrImps ∷ !Imports
       }
 
+C.derive [d| instance Foldable   Imports ImportOp
+             instance Collection Imports ImportOp
+             instance Map        Imports ImportOp ()
+             instance Set        Imports ImportOp
+             instance SortingCollection Imports ImportOp
+           |]
+
 -- |@'insert' imp@ merges @imp@ with an existing one if any.
 instance Unfoldable Imports ImportOp where
     insert qi@(QualifiedImp   {}) (Imports s) = Imports $ insert qi s
@@ -105,42 +114,10 @@ instance Unfoldable Imports ImportOp where
     empty     = Imports empty
     singleton = Imports ∘ singleton
 
--- FIXME: auto-derive
-instance Foldable Imports ImportOp where
-    foldr f b (Imports s) = foldr f b s
-
--- FIXME: auto-derive
-instance Collection Imports ImportOp where
-    filter f (Imports s) = Imports $ filter f s
-
 instance Monoid Imports where
     mempty  = empty
     mappend = insertMany
 
--- FIXME: auto-derive
-instance Map Imports ImportOp () where
-    lookup k (Imports s) = lookup k s
-    mapWithKey f (Imports m)
-        = Imports $ mapWithKey f m
-    unionWith f (Imports α) (Imports β)
-        = Imports $ unionWith f α β
-    intersectionWith f (Imports α) (Imports β)
-        = Imports $ intersectionWith f α β
-    differenceWith f (Imports α) (Imports β)
-        = Imports $ differenceWith f α β
-    isSubmapBy f (Imports α) (Imports β)
-        = isSubmapBy f α β
-    isProperSubmapBy f (Imports α) (Imports β)
-        = isProperSubmapBy f α β
-
--- FIXME: auto-derive
-instance Set Imports ImportOp where
-    haddock_candy = haddock_candy
-
--- FIXME: auto-derive
-instance SortingCollection Imports ImportOp where
-    minView (Imports s) = second Imports <$> minView s
-
 instance Ord ImportOp where
     α `compare` β
         | impModule α < impModule β = LT