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

diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs
index e4ec832..37029a2 100644
--- a/Network/HTTP/Lucu/Implant/Rewrite.hs
+++ b/Network/HTTP/Lucu/Implant/Rewrite.hs
@@ -1,9 +1,12 @@
 {-# LANGUAGE
     FlexibleInstances
   , 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(..)
@@ -22,16 +25,17 @@ module Network.HTTP.Lucu.Implant.Rewrite
     , rewriteNames
     )
     where
-import Control.Applicative
+import Control.Applicative hiding (empty)
 import Control.Monad.State
+import Data.Collections
+import Data.Collections.BaseInstances ()
+import qualified Data.Collections.Newtype.TH as C
 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 qualified Data.Set as S (Set)
 import Language.Haskell.TH.Syntax
 import Prelude
 import Prelude.Unicode
@@ -48,8 +52,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 +68,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 +80,44 @@ data RewriteRule
     = RewriteRule {
         rrPat  ∷ !NamePat
       , rrOp   ∷ !RewriteOp
-      , rrImps ∷ !(Imports ImportOp)
+      , 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)
+        = 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') }
+
+    empty     = Imports empty
+    singleton = Imports ∘ singleton
+
+instance Monoid Imports where
+    mempty  = empty
+    mappend = insertMany
+
 instance Ord ImportOp where
     α `compare` β
         | impModule α < impModule β = LT
@@ -95,32 +133,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,18 +141,17 @@ 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@.
 unqualify ∷ Name → String → RewriteRule
 unqualify (Name o _) m
     = let pat = NamePat Nothing (Just o)
-          iop = UnqualifiedImp (mkModName m)
-                $ Just
-                $ S.singleton (VarName, o)
+          iop = UnqualifiedImp (mkModName m) ∘ Just
+                $ 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
@@ -148,11 +159,10 @@ 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
-                $ S.singleton (TcClsName, tycl)
+          iop = UnqualifiedImp (mkModName m) ∘ Just
+                $ 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 +171,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 +205,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)