X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FImplant%2FRewrite.hs;h=37029a27a2b8cae169bb40605cf96fb559359296;hb=545053db37e71ed18ca59c12467a8ecb10bf5f83;hp=69b8aee28ecfb276d139d4c434cc05e01cd01e2e;hpb=19763f7de78daf2d4c794f4010039f70c7f73994;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index 69b8aee..37029a2 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,18 +26,18 @@ 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
 import Data.Monoid
 import Data.Monoid.Unicode
-import qualified Data.Set as S
+import qualified Data.Set as S (Set)
 import Language.Haskell.TH.Syntax
-import Prelude hiding (filter, foldr, lookup)
+import Prelude
 import Prelude.Unicode
 
 -- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
@@ -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)