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
 CONFIGURE_ARGS = -O -fssl

-#CONFIGURE_ARGS = -O -fssl --enable-executable-profiling

 
 include cabal-package.mk
 
 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 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
 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 #-}
     insert (key, val) (Headers m)
         = Headers $ insertWith merge key val m
     {-# INLINE empty #-}

-    empty
-        = Headers empty
+    empty     = Headers empty

     {-# INLINE singleton #-}
     {-# 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
 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 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
 
 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
 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
     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 #-}
 
 instance Monoid Headers where
     {-# INLINE mempty #-}

-    mempty = empty
+    mempty  = empty

     {-# INLINE mappend #-}
     {-# INLINE mappend #-}

-    mappend (Headers α) (Headers β)
-        = Headers $ insertManySorted β α
+    mappend = insertMany

 
 

--- FIXME: override every methods
+-- FIXME: auto-derive

 instance Map Headers CIAscii Ascii where
 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 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 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
     {-# 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 α β
 
     isProperSubmapBy f (Headers α) (Headers β)
         = isProperSubmapBy f α β
 

+-- FIXME: auto-derive

 instance SortingCollection Headers (CIAscii, Ascii) where
     {-# INLINE minView #-}
     minView (Headers m) = second Headers <$> minView m
 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.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"
         , 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
       }
 
       , 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)
 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') }
 
                   (_      , 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
 
 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
 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)
 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 α β
 
     isProperSubmapBy f (Imports α) (Imports β)
         = isProperSubmapBy f α β
 

+-- FIXME: auto-derive

 instance Set Imports ImportOp where
     haddock_candy = haddock_candy
 
 instance Set Imports ImportOp where
     haddock_candy = haddock_candy
 

+-- FIXME: auto-derive

 instance SortingCollection Imports ImportOp where
     minView (Imports s) = second Imports <$> minView s
 
 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 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
 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)
 
     = 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)
 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
 
     insertManySorted f (MIMEParams m)
         = MIMEParams $ insertManySorted f m
 

+-- FIXME: auto-derive

 instance Foldable MIMEParams (CIAscii, Text) where
     {-# INLINE null #-}
     null (MIMEParams m) = null m
 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
 
     {-# 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
 
 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
 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
 
     {-# 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
 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 α β
 
     isProperSubmapBy f (MIMEParams α) (MIMEParams β)
         = isProperSubmapBy f α β
 

+-- FIXME: auto-derive

 instance SortingCollection MIMEParams (CIAscii, Text) where
     {-# INLINE minView #-}
     minView (MIMEParams m) = second MIMEParams <$> minView m
 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
 {-# LANGUAGE

-    RecordWildCards
+    FlexibleContexts
+  , FlexibleInstances
+  , OverlappingInstances
+  , RecordWildCards

   , TemplateHaskell
   , TemplateHaskell

+  , UndecidableInstances

   , UnicodeSyntax
   #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
   , 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 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
 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 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]
         where
           liftPairs       = listE ∘ map liftPair
           liftPair (k, v) = tupE [lift k, lift v]