From: PHO 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;hp=09fe5429b2a1bcea6d6e57ab1c4a5178807cbacd;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)