auto-derive Set

[Lucu.git] / Network / HTTP / Lucu / Implant / Rewrite.hs

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index 9ed1d8def3c5d2206cf0392a41bb6eeea40feb66..a341d82cbce61584231a953d4569a49d766660e9 100644 (file)
--- 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