From: PHO <pho@cielonegro.org>
Date: Mon, 14 Nov 2011 16:37:27 +0000 (+0900)
Subject: Rewrite.Imports is now instance of collection-api's type classes.
X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=19763f7;p=Lucu.git

Rewrite.Imports is now instance of collection-api's type classes.

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a
---

diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
index 93fb8da..573dff0 100644
--- a/Network/HTTP/Lucu/Abortion/Internal.hs
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -12,7 +12,7 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Control.Exception
-import Data.Collections
+import Data.Monoid.Unicode
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable
@@ -69,7 +69,7 @@ abortPage conf reqM res abo
         Nothing
             → let res' = res {
                             resStatus  = aboStatus abo
-                          , resHeaders = insertMany (aboHeaders abo) (resHeaders res)
+                          , resHeaders = resHeaders res ⊕ aboHeaders abo
                           }
                in
                  getDefaultPage conf reqM res'
diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs
index 8219624..2ee9cbb 100644
--- a/Network/HTTP/Lucu/Headers.hs
+++ b/Network/HTTP/Lucu/Headers.hs
@@ -15,7 +15,7 @@ module Network.HTTP.Lucu.Headers
     , printHeaders
     )
     where
-import Control.Applicative
+import Control.Applicative hiding (empty)
 import Control.Applicative.Unicode hiding ((∅))
 import Control.Arrow
 import Control.Monad
@@ -29,12 +29,12 @@ import Data.Collections.BaseInstances ()
 import Data.Monoid
 import Data.Monoid.Unicode
 import Network.HTTP.Lucu.Parser.Http
-import Prelude hiding (filter, lookup, null)
+import Prelude hiding (filter, foldr, lookup, null)
 import Prelude.Unicode
 
 newtype Headers
     = Headers (M.Map CIAscii Ascii)
-      deriving (Eq, Monoid, Show)
+      deriving (Eq, Show)
 
 class HasHeaders a where
     getHeaders ∷ a → Headers
@@ -73,10 +73,22 @@ instance Unfoldable Headers (CIAscii, Ascii) where
     {-# INLINE insert #-}
     insert (key, val) (Headers m)
         = Headers $ insertWith merge key val m
+    {-# INLINE empty #-}
+    empty
+        = Headers empty
+    {-# INLINE singleton #-}
+    singleton v
+        = Headers $ singleton v
+    {-# INLINE insertMany #-}
+    insertMany f (Headers m)
+        = Headers $ insertMany f m
+    {-# INLINE insertManySorted #-}
+    insertManySorted f (Headers m)
+        = Headers $ insertManySorted f m
 
 instance Foldable Headers (CIAscii, Ascii) where
-    {-# INLINE foldMap #-}
-    foldMap f (Headers m) = foldMap f m
+    {-# INLINE foldr #-}
+    foldr f b (Headers m) = foldr f b m
 
 instance Collection Headers (CIAscii, Ascii) where
     {-# INLINE filter #-}
@@ -90,6 +102,13 @@ instance Indexed Headers CIAscii Ascii where
     {-# INLINE inDomain #-}
     inDomain k (Headers m) = inDomain k m
 
+instance Monoid Headers where
+    {-# INLINE mempty #-}
+    mempty = empty
+    {-# INLINE mappend #-}
+    mappend (Headers α) (Headers β)
+        = Headers $ insertManySorted β α
+
 instance Map Headers CIAscii Ascii where
     {-# INLINE lookup #-}
     lookup k (Headers m) = lookup k m
diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
index ecdb4fe..85af3cb 100644
--- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs
+++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs
@@ -18,8 +18,8 @@ import Data.Ascii (CIAscii)
 import qualified Data.Ascii as A
 import qualified Data.ByteString.Lazy as L
 import Data.Char
-import Data.Foldable
-import Data.List
+import Data.Collections
+import Data.List (intersperse)
 import Data.Ratio
 import Data.Time
 import Language.Haskell.TH.Lib
@@ -32,6 +32,7 @@ import Network.HTTP.Lucu.Implant.Rewrite
 import Network.HTTP.Lucu.MIMEType
 import Network.HTTP.Lucu.Resource
 import Network.HTTP.Lucu.Utils
+import Prelude hiding (head)
 import Prelude.Unicode
 
 header ∷ Input → Doc
@@ -79,8 +80,8 @@ moduleDecl modName symName
                    , text "where"
                    ])
 
-importDecls ∷ Imports ImportOp → Doc
-importDecls = vcat ∘ map pprImport ∘ toList
+importDecls ∷ Imports → Doc
+importDecls = vcat ∘ map pprImport ∘ fromFoldable
 
 pprImport ∷ ImportOp → Doc
 pprImport (QualifiedImp {..})
@@ -100,7 +101,7 @@ pprImport (UnqualifiedImp {impNames = Just ns, ..})
            , hcat [ lparen
                   , sep $ punctuate comma
                         $ map (uncurry pprImpName)
-                        $ toList ns
+                        $ fromFoldable ns
                   , rparen
                   ]
            ]
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)