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

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index e4ec832..69b8aee 100644
--- a/Network/HTTP/Lucu/Implant/Rewrite.hs
+++ b/Network/HTTP/Lucu/Implant/Rewrite.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE
     FlexibleInstances
   , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
   , RecordWildCards
   , UnicodeSyntax
   #-}
@@ -22,18 +23,19 @@ module Network.HTTP.Lucu.Implant.Rewrite
     , rewriteNames
     )
     where
-import Control.Applicative
+import Control.Applicative hiding (empty)
+import Control.Arrow
 import Control.Monad.State
+import Data.Collections
+import Data.Collections.BaseInstances ()
 import Data.Data
-import Data.Foldable
 import Data.Generics.Aliases hiding (GT)
 import Data.Generics.Schemes
 import Data.Monoid
 import Data.Monoid.Unicode
-import Data.Set (Set)
 import qualified Data.Set as S
 import Language.Haskell.TH.Syntax
-import Prelude
+import Prelude hiding (filter, foldr, lookup)
 import Prelude.Unicode
 
 -- |Pattern for 'Name's. 'Just' represents a perfect matching pattern,
@@ -48,8 +50,7 @@ data RewriteOp
     | Qualify !ModName
 
 -- |A 'Set' of modules and names to be imported.
-newtype Imports α = Imports (Set α)
-    deriving Foldable
+newtype Imports = Imports (S.Set ImportOp)
 
 -- |Instruction for declaring module imports.
 data ImportOp
@@ -65,7 +66,7 @@ data ImportOp
       -- > import M (a, b, c, ...)
     | UnqualifiedImp {
         impModule ∷ !ModName
-      , impNames  ∷ !(Maybe (Set (NameSpace, OccName)))
+      , impNames  ∷ !(Maybe (S.Set (NameSpace, OccName)))
       }
     deriving Eq
 
@@ -77,9 +78,61 @@ data RewriteRule
     = RewriteRule {
         rrPat  ∷ !NamePat
       , rrOp   ∷ !RewriteOp
-      , rrImps ∷ !(Imports ImportOp)
+      , rrImps ∷ !Imports
       }
 
+instance Unfoldable Imports ImportOp where
+    insert qi@(QualifiedImp   {}) (Imports s) = Imports $ insert qi s
+    insert ui@(UnqualifiedImp {}) (Imports s)
+        = case find sameMod s of
+            Nothing  → Imports $ insert ui s
+            Just ui' → Imports $ insert (merge ui') (delete ui' s)
+        where
+          sameMod ∷ ImportOp → Bool
+          sameMod ui'@(UnqualifiedImp {})
+              = impModule ui ≡ impModule ui'
+          sameMod _
+              = False
+
+          merge ∷ ImportOp → ImportOp
+          merge ui'
+              = case (impNames ui, impNames ui') of
+                  (Nothing, _       ) → ui
+                  (_      , 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
+
+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
+
 instance Ord ImportOp where
     α `compare` β
         | impModule α < impModule β = LT
@@ -95,32 +148,6 @@ instance Ord ImportOp where
                 (UnqualifiedImp {}, _                )
                     → LT
 
-instance Monoid (Imports ImportOp) where
-    mempty
-        = Imports (∅)
-    mappend (Imports α) (Imports β)
-        = Imports (foldl' insertImp α β)
-
-insertImp ∷ Set ImportOp → ImportOp → Set ImportOp
-insertImp α qi@(QualifiedImp   {}) = S.insert qi α
-insertImp α ui@(UnqualifiedImp {})
-    = case find sameMod α of
-        Nothing  → S.insert ui α
-        Just ui' → S.insert (merge ui') (S.delete ui' α)
-    where
-      sameMod ∷ ImportOp → Bool
-      sameMod ui'@(UnqualifiedImp {})
-          = impModule ui ≡ impModule ui'
-      sameMod _
-          = False
-
-      merge ∷ ImportOp → ImportOp
-      merge ui'
-          = case (impNames ui, impNames ui') of
-              (Nothing, _      ) → ui
-              (_      , Nothing) → ui'
-              (Just s , Just s') → ui { impNames = Just (s ⊕ s') }
-
 -- |@'qualifyAll' module alias@: qualify every symbols defined in
 -- @module@ with @alias@.
 qualifyAll ∷ String → String → RewriteRule
@@ -129,7 +156,7 @@ qualifyAll m a
           rop = Qualify (mkModName a)
           iop = QualifiedImp (mkModName m) (mkModName a)
       in
-        RewriteRule pat rop (Imports (S.singleton iop))
+        RewriteRule pat rop (singleton iop)
 
 -- |@'unqualify' name module@: unqualify the symbol @name@ with
 -- importing @module@.
@@ -138,9 +165,9 @@ unqualify (Name o _) m
     = let pat = NamePat Nothing (Just o)
           iop = UnqualifiedImp (mkModName m)
                 $ Just
-                $ S.singleton (VarName, o)
+                $ singleton (VarName, o)
       in
-        RewriteRule pat Unqualify (Imports (S.singleton iop))
+        RewriteRule pat Unqualify (singleton iop)
 
 -- |@'unqualifyIn' name tycl module@: unqualify a constructor, field
 -- name, or whatever resides in the type or class @tycl@ with
@@ -150,9 +177,9 @@ unqualifyIn (Name name _) (Name tycl _) m
     = let pat = NamePat Nothing (Just name)
           iop = UnqualifiedImp (mkModName m)
                 $ Just
-                $ S.singleton (TcClsName, tycl)
+                $ singleton (TcClsName, tycl)
       in
-        RewriteRule pat Unqualify (Imports (S.singleton iop))
+        RewriteRule pat Unqualify (singleton iop)
 
 -- |@'unqualifyAll' origMod impMod@: unqualify every symbols
 -- defined in @origMod@ with importing @impMod@.
@@ -161,15 +188,15 @@ unqualifyAll origMod impMod
     = let pat = NamePat (Just (mkModName origMod)) Nothing
           iop = UnqualifiedImp (mkModName impMod) Nothing
       in
-        RewriteRule pat Unqualify (Imports (S.singleton iop))
+        RewriteRule pat Unqualify (singleton iop)
 
 -- |@'rewriteNames' rules d@ rewrites each and every 'Name's included
 -- in @d@ according to the name-rewriting @rules@ while at the same
 -- time building a set of modules to be imported.
-rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports ImportOp)
+rewriteNames ∷ Data d ⇒ Rules → d → (d, Imports)
 rewriteNames rules = flip runState (∅) ∘ gmapM (everywhereM (mkM f))
     where
-      f ∷ (Functor m, Monad m) ⇒ Name → StateT (Imports ImportOp) m Name
+      f ∷ (Functor m, Monad m) ⇒ Name → StateT Imports m Name
       f n = case findRule rules n of
               Nothing → fail $ "No rules matches to name: " ⧺ showName n
               Just r  → applyRule r n
@@ -195,7 +222,7 @@ matchPat m o (NamePat mp op)
 applyRule ∷ (Functor m, Monad m)
           ⇒ RewriteRule
           → Name
-          → StateT (Imports ImportOp) m Name
+          → StateT Imports m Name
 applyRule (RewriteRule {..}) n
     = modify (⊕ rrImps) *> pure (rewrite rrOp n)