Fixed lots of bugs

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/GNUmakefile b/GNUmakefile
index 53a725153accef78955b56951450dd984cc0546d..4bc0a42bc64f38a7b066068caabd5ca930ba2cae 100644 (file)
--- 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 e83aa34fdc181022584693abf28578a91b9360b9..0d53d3186c154c5c716c6fdc5fb1380d18852615 100644 (file)
--- 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 fa842a174f53989b6f286fe0fb2cf9b18c2297ec..acd1d7f762a1d97181da38764e0864efeb783c1f 100644 (file)
--- 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 9abf628b50c3f6c0142d71d28f81215cbfa6dc3c..affa89791d0cbe520fcc124e9232fadaea5978d7 100644 (file)
--- 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 f4b503ee6ddd176d3febb9e61aa0691967844070..ce0b6915a4118c2dbf178b786960ce8556f85355 100644 (file)
--- 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 a7e7b7ee8d5ac42cc9b1e6a4bdff4a88c1905157..b0bd421082eb10cb4948d1e6ebf58dafb0e3f751 100644 (file)
--- 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]