From: PHO Date: Wed, 16 Nov 2011 16:35:01 +0000 (+0900) Subject: Fixed lots of bugs X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=commitdiff_plain;h=6df5f92e37d27641f53e271f043c66dd3d085bb7 Fixed lots of bugs Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/GNUmakefile b/GNUmakefile index 53a7251..4bc0a42 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -2,6 +2,5 @@ RUN_COMMAND = $(MAKE) -C examples run #CONFIGURE_ARGS = -O CONFIGURE_ARGS = -O -fssl -#CONFIGURE_ARGS = -O -fssl --enable-executable-profiling include cabal-package.mk diff --git a/Network/HTTP/Lucu/Headers.hs b/Network/HTTP/Lucu/Headers.hs index e83aa34..0d53d31 100644 --- a/Network/HTTP/Lucu/Headers.hs +++ b/Network/HTTP/Lucu/Headers.hs @@ -29,7 +29,7 @@ import Data.Collections.BaseInstances () import Data.Monoid import Data.Monoid.Unicode import Network.HTTP.Lucu.Parser.Http -import Prelude hiding (filter, foldr, lookup, null) +import Prelude hiding (filter, foldl, foldl1, foldr, foldr1, lookup, null) import Prelude.Unicode newtype Headers @@ -74,30 +74,37 @@ instance Unfoldable Headers (CIAscii, Ascii) where insert (key, val) (Headers m) = Headers $ insertWith merge key val m {-# INLINE empty #-} - empty - = Headers empty + empty = Headers empty {-# INLINE singleton #-} - singleton p - = Headers $ singleton p - {-# INLINE insertMany #-} - insertMany f (Headers m) - = Headers $ insertMany f m - {-# INLINE insertManySorted #-} - insertManySorted f (Headers m) - = Headers $ insertManySorted f m + singleton = Headers ∘ singleton +-- FIXME: auto-derive instance Foldable Headers (CIAscii, Ascii) where + {-# INLINE fold #-} + fold (Headers m) = fold m + {-# INLINE foldMap #-} + foldMap f (Headers m) = foldMap f m + {-# INLINE foldr #-} + foldr f b (Headers m) = foldr f b m + {-# INLINE foldl #-} + foldl f b (Headers m) = foldl f b m + {-# INLINE foldr1 #-} + foldr1 f (Headers m) = foldr1 f m + {-# INLINE foldl1 #-} + foldl1 f (Headers m) = foldl1 f m {-# INLINE null #-} null (Headers m) = null m {-# INLINE size #-} size (Headers m) = size m - {-# INLINE foldr #-} - foldr f b (Headers m) = foldr f b m + {-# INLINE isSingleton #-} + isSingleton (Headers m) = isSingleton m +-- FIXME: auto-derive instance Collection Headers (CIAscii, Ascii) where {-# INLINE filter #-} filter f (Headers m) = Headers $ filter f m +-- FIXME: auto-derive instance Indexed Headers CIAscii Ascii where {-# INLINE index #-} index k (Headers m) = index k m @@ -105,21 +112,50 @@ instance Indexed Headers CIAscii Ascii where adjust f k (Headers m) = Headers $ adjust f k m {-# INLINE inDomain #-} inDomain k (Headers m) = inDomain k m + {-# INLINE (//) #-} + Headers m // l = Headers $ m // l + {-# INLINE accum #-} + accum f (Headers m) l = Headers $ accum f m l instance Monoid Headers where {-# INLINE mempty #-} - mempty = empty + mempty = empty {-# INLINE mappend #-} - mappend (Headers α) (Headers β) - = Headers $ insertManySorted β α + mappend = insertMany --- FIXME: override every methods +-- FIXME: auto-derive instance Map Headers CIAscii Ascii where + {-# INLINE delete #-} + delete k (Headers m) = Headers $ delete k m + {-# INLINE member #-} + member k (Headers m) = member k m + {-# INLINE union #-} + union (Headers α) (Headers β) + = Headers $ union α β + {-# INLINE intersection #-} + intersection (Headers α) (Headers β) + = Headers $ intersection α β + {-# INLINE difference #-} + difference (Headers α) (Headers β) + = Headers $ difference α β + {-# INLINE isSubset #-} + isSubset (Headers α) (Headers β) + = isSubset α β + {-# INLINE isProperSubset #-} + isProperSubset (Headers α) (Headers β) + = isProperSubset α β {-# INLINE lookup #-} lookup k (Headers m) = lookup k m + {-# INLINE alter #-} + alter f k (Headers m) + = Headers $ alter f k m {-# INLINE insertWith #-} insertWith f k v (Headers m) = Headers $ insertWith f k v m + {-# INLINE fromFoldableWith #-} + fromFoldableWith = (Headers ∘) ∘ fromFoldableWith + {-# INLINE foldGroups #-} + foldGroups = ((Headers ∘) ∘) ∘ foldGroups {-# INLINE mapWithKey #-} mapWithKey f (Headers m) = Headers $ mapWithKey f m @@ -139,6 +175,7 @@ instance Map Headers CIAscii Ascii where isProperSubmapBy f (Headers α) (Headers β) = isProperSubmapBy f α β +-- FIXME: auto-derive instance SortingCollection Headers (CIAscii, Ascii) where {-# INLINE minView #-} minView (Headers m) = second Headers <$> minView m diff --git a/Network/HTTP/Lucu/Implant/PrettyPrint.hs b/Network/HTTP/Lucu/Implant/PrettyPrint.hs index fa842a1..acd1d7f 100644 --- a/Network/HTTP/Lucu/Implant/PrettyPrint.hs +++ b/Network/HTTP/Lucu/Implant/PrettyPrint.hs @@ -230,7 +230,8 @@ rules = [ qualifyAll "Codec.Compression.GZip" "G" , qualifyAll "Data.Ascii" "A" , qualifyAll "Data.ByteString.Char8" "B" , qualifyAll "Data.ByteString.Lazy.Internal" "L" - , qualifyAll "Data.Map" "M" + , qualifyAll "Data.CaseInsensitive" "CI" + , qualifyAll "Data.Collections" "C" , qualifyAll "Data.Text" "T" , unqualifyAll "Network.HTTP.Lucu.ETag" "Network.HTTP.Lucu" , unqualifyAll "Network.HTTP.Lucu.Resource" "Network.HTTP.Lucu" diff --git a/Network/HTTP/Lucu/Implant/Rewrite.hs b/Network/HTTP/Lucu/Implant/Rewrite.hs index 9abf628..affa897 100644 --- a/Network/HTTP/Lucu/Implant/Rewrite.hs +++ b/Network/HTTP/Lucu/Implant/Rewrite.hs @@ -81,6 +81,7 @@ data RewriteRule , rrImps ∷ !Imports } +-- |@'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,17 +102,22 @@ instance Unfoldable Imports ImportOp where (_ , Nothing ) → ui' (Just ns, Just ns') → ui { impNames = Just (ns ⊕ ns') } + empty = Imports empty + singleton = Imports ∘ singleton + +-- FIXME: auto-derive instance Foldable Imports ImportOp where foldr f b (Imports s) = foldr f b s +-- FIXME: auto-derive instance Collection Imports ImportOp where filter f (Imports s) = Imports $ filter f s instance Monoid Imports where - mempty = empty - mappend (Imports α) (Imports β) - = Imports $ insertManySorted β α + mempty = empty + mappend = insertMany +-- FIXME: auto-derive instance Map Imports ImportOp () where lookup k (Imports s) = lookup k s mapWithKey f (Imports m) @@ -127,9 +133,11 @@ instance Map Imports ImportOp () where isProperSubmapBy f (Imports α) (Imports β) = isProperSubmapBy f α β +-- FIXME: auto-derive instance Set Imports ImportOp where haddock_candy = haddock_candy +-- FIXME: auto-derive instance SortingCollection Imports ImportOp where minView (Imports s) = second Imports <$> minView s diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index f4b503e..ce0b691 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -40,7 +40,6 @@ import Data.Text.Encoding import Data.Text.Encoding.Error import Data.Typeable import Data.Word -import Language.Haskell.TH.Syntax import Network.HTTP.Lucu.OrphanInstances () import Network.HTTP.Lucu.Parser.Http import Network.HTTP.Lucu.Utils @@ -54,9 +53,7 @@ newtype MIMEParams = MIMEParams (M.Map CIAscii Text) deriving (Eq, Show, Read, Monoid, Typeable) -instance Lift MIMEParams where - lift (MIMEParams m) = [| MIMEParams $(lift m) |] - +-- FIXME: auto-derive instance Unfoldable MIMEParams (CIAscii, Text) where {-# INLINE insert #-} insert p (MIMEParams m) @@ -74,6 +71,7 @@ instance Unfoldable MIMEParams (CIAscii, Text) where insertManySorted f (MIMEParams m) = MIMEParams $ insertManySorted f m +-- FIXME: auto-derive instance Foldable MIMEParams (CIAscii, Text) where {-# INLINE null #-} null (MIMEParams m) = null m @@ -82,10 +80,12 @@ instance Foldable MIMEParams (CIAscii, Text) where {-# INLINE foldr #-} foldr f b (MIMEParams m) = foldr f b m +-- FIXME: auto-derive instance Collection MIMEParams (CIAscii, Text) where {-# INLINE filter #-} filter f (MIMEParams m) = MIMEParams $ filter f m +-- FIXME: auto-derive instance Indexed MIMEParams CIAscii Text where {-# INLINE index #-} index k (MIMEParams m) = index k m @@ -94,6 +94,7 @@ instance Indexed MIMEParams CIAscii Text where {-# INLINE inDomain #-} inDomain k (MIMEParams m) = inDomain k m +-- FIXME: auto-derive instance Map MIMEParams CIAscii Text where {-# INLINE lookup #-} lookup k (MIMEParams m) = lookup k m @@ -116,6 +117,7 @@ instance Map MIMEParams CIAscii Text where isProperSubmapBy f (MIMEParams α) (MIMEParams β) = isProperSubmapBy f α β +-- FIXME: auto-derive instance SortingCollection MIMEParams (CIAscii, Text) where {-# INLINE minView #-} minView (MIMEParams m) = second MIMEParams <$> minView m diff --git a/Network/HTTP/Lucu/OrphanInstances.hs b/Network/HTTP/Lucu/OrphanInstances.hs index a7e7b7e..b0bd421 100644 --- a/Network/HTTP/Lucu/OrphanInstances.hs +++ b/Network/HTTP/Lucu/OrphanInstances.hs @@ -1,6 +1,10 @@ {-# LANGUAGE - RecordWildCards + FlexibleContexts + , FlexibleInstances + , OverlappingInstances + , RecordWildCards , TemplateHaskell + , UndecidableInstances , UnicodeSyntax #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -15,8 +19,8 @@ import qualified Data.ByteString.Char8 as Strict import qualified Data.ByteString.Lazy.Internal as Lazy import Data.CaseInsensitive (CI, FoldCase) import qualified Data.CaseInsensitive as CI -import Data.Map (Map) -import qualified Data.Map as M +import Data.Collections +import Data.Collections.BaseInstances () import Data.Ratio import Data.Text (Text) import qualified Data.Text as T @@ -44,10 +48,10 @@ instance (Lift s, FoldCase s) ⇒ Lift (CI s) where instance Lift Text where lift t = [| T.pack $(litE $ stringL $ T.unpack t) |] -instance (Lift k, Lift v) ⇒ Lift (Map k v) where - lift m - | M.null m = [| M.empty |] - | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |] +instance (Lift k, Lift v, Collection c (k, v)) ⇒ Lift c where + lift c + | null c = [| empty |] + | otherwise = [| fromList $(liftPairs (fromFoldable c)) |] where liftPairs = listE ∘ map liftPair liftPair (k, v) = tupE [lift k, lift v]