X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FImplant%2FRewrite.hs;h=a341d82cbce61584231a953d4569a49d766660e9;hb=f7fdfa7b306619a37f31504109b23c362066ec8b;hp=9abf628b50c3f6c0142d71d28f81215cbfa6dc3c;hpb=bb121f1189d01b5089aa5c29f0d390fad36ade48;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index 9abf628..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,14 @@ 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
     insert ui@(UnqualifiedImp {}) (Imports s)
@@ -101,37 +111,12 @@ instance Unfoldable Imports ImportOp where
                   (_      , Nothing ) → ui'
                   (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') }
 
-instance Foldable Imports ImportOp where
-    foldr f b (Imports s) = foldr f b s
-
-instance Collection Imports ImportOp where
-    filter f (Imports s) = Imports $ filter f s
+    empty     = Imports empty
+    singleton = Imports ∘ singleton
 
 instance Monoid Imports where
-    mempty = empty
-    mappend (Imports α) (Imports β)
-        = Imports $ insertManySorted β α
-
-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 α β
-
-instance Set Imports ImportOp where
-    haddock_candy = haddock_candy
-
-instance SortingCollection Imports ImportOp where
-    minView (Imports s) = second Imports <$> minView s
+    mempty  = empty
+    mappend = insertMany
 
 instance Ord ImportOp where
     α `compare` β
@@ -163,8 +148,7 @@ qualifyAll m a
 unqualify ∷ Name → String → RewriteRule
 unqualify (Name o _) m
     = let pat = NamePat Nothing (Just o)
-          iop = UnqualifiedImp (mkModName m)
-                $ Just
+          iop = UnqualifiedImp (mkModName m) ∘ Just
                 $ singleton (VarName, o)
       in
         RewriteRule pat Unqualify (singleton iop)
@@ -175,8 +159,7 @@ unqualify (Name o _) m
 unqualifyIn ∷ Name → Name → String → RewriteRule
 unqualifyIn (Name name _) (Name tycl _) m
     = let pat = NamePat Nothing (Just name)
-          iop = UnqualifiedImp (mkModName m)
-                $ Just
+          iop = UnqualifiedImp (mkModName m) ∘ Just
                 $ singleton (TcClsName, tycl)
       in
         RewriteRule pat Unqualify (singleton iop)