auto-derive Map

Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index b3c7e59d41feb74a387e5939d59e0d6007a05ccf..d392758a4be3c3eaaaaa690037b2fdbef8b6aa97 100644 (file)
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -20,7 +20,9 @@ import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Ppr
 import Language.Haskell.TH.Syntax
 import Prelude hiding ( concat, concatMap, exp, filter
-                      , foldl, foldr, foldl1, foldr1, null)
+                      , foldl, foldr, foldl1, foldr1
+                      , lookup, null
+                      )
 import Prelude.Unicode
 
 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
@@ -62,6 +64,8 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
     | classTy ≡ ''Indexed
         = return (wrapperTy, deriveIndexed)
+    | classTy ≡ ''Map
+        = return (wrapperTy, deriveMap)
 inspectInstance ty
     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
 
@@ -204,6 +208,52 @@ deriveIndexed c ty wrap unwrap
           | otherwise
               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
 
+deriveMap ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveMap c ty wrap unwrap
+    = do names ← methodNames ''Map
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'delete
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ delete |]
+          | name ≡ 'member
+              = [| (∘ $unwrap) ∘ member |]
+          | name ≡ 'union
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ union ∘ $unwrap |]
+          | name ≡ 'intersection
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ intersection ∘ $unwrap |]
+          | name ≡ 'difference
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ difference ∘ $unwrap |]
+          | name ≡ 'isSubset
+              = [| (∘ $unwrap) ∘ isSubset ∘ $unwrap |]
+          | name ≡ 'isProperSubset
+              = [| (∘ $unwrap) ∘ isProperSubset ∘ $unwrap |]
+          | name ≡ 'lookup
+              = [| (∘ $unwrap) ∘ lookup |]
+          | name ≡ 'alter
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ alter |]
+          | name ≡ 'insertWith
+              = [| ((($wrap ∘) ∘) ∘) ∘ flip flip $unwrap ∘ ((flip ∘ ((∘) ∘)) ∘) ∘ insertWith |]
+          | name ≡ 'fromFoldableWith
+              = [| ($wrap ∘) ∘ fromFoldableWith |]
+          | name ≡ 'foldGroups
+              = [| (($wrap ∘) ∘) ∘ foldGroups |]
+          | name ≡ 'mapWithKey
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ mapWithKey |]
+          | name ≡ 'unionWith
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ unionWith |]
+          | name ≡ 'intersectionWith
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ intersectionWith |]
+          | name ≡ 'differenceWith
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ differenceWith |]
+          | name ≡ 'isSubmapBy
+              = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isSubmapBy |]
+          | name ≡ 'isProperSubmapBy
+              = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isProperSubmapBy |]
+          | otherwise
+              = fail $ "deriveMap: unknown method: " ⧺ pprint name
+
 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 deriveSortingCollection c ty wrap unwrap
     = do names ← methodNames ''SortingCollection

diff --git a/Lucu.cabal b/Lucu.cabal
index aa1a9b9f27784baf6ae4f7ffb6e4ffbe97dba0fd..eecb8a79c583db12454fabfc8af03ca79182f510 100644 (file)
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -120,6 +120,7 @@ Library
         Network.HTTP.Lucu.ContentCoding
         Network.HTTP.Lucu.DefaultPage
         Network.HTTP.Lucu.Interaction
+        Network.HTTP.Lucu.MIMEParams.Internal
         Network.HTTP.Lucu.OrphanInstances
         Network.HTTP.Lucu.Postprocess
         Network.HTTP.Lucu.Preprocess

diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs
index a3722a34958bfae90194a724e823c5c380fca553..89b2bfda4e0ecb15beb5781f7d45a88e48e2bd4a 100644 (file)
--- a/Network/HTTP/Lucu/MIMEParams.hs
+++ b/Network/HTTP/Lucu/MIMEParams.hs
@@ -10,8 +10,7 @@
   , TypeSynonymInstances
   , UnicodeSyntax
   #-}
-{-# OPTIONS_GHC -ddump-splices #-} -- FIXME
--- THINKME: GHC 7.0.3 gives us a false warning.
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-missing-methods #-}
 -- |Parsing and printing MIME parameter values
 -- (<http://tools.ietf.org/html/rfc2231>).
@@ -34,59 +33,28 @@ import Data.Collections
 import Data.Collections.BaseInstances ()
 import qualified Data.Collections.Newtype.TH as C
 import qualified Data.Map as M (Map)
-import Data.Monoid
 import Data.Monoid.Unicode
 import Data.Sequence (Seq)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Text.Encoding.Error
-import Data.Typeable
 import Data.Word
+import Network.HTTP.Lucu.MIMEParams.Internal
 import Network.HTTP.Lucu.OrphanInstances ()
 import Network.HTTP.Lucu.Parser.Http
 import Network.HTTP.Lucu.Utils
-import Prelude hiding (concat, filter, foldr, lookup, mapM, null, takeWhile)
+import Prelude hiding (concat, lookup, mapM, takeWhile)
 import Prelude.Unicode
 
--- |A 'Map' from MIME parameter attributes to values. Attributes are
--- always case-insensitive according to RFC 2045
--- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
-newtype MIMEParams
-    = MIMEParams (M.Map CIAscii Text)
-    deriving (Eq, Show, Read, Monoid, Typeable)
-
 C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text)
              instance Foldable   MIMEParams (CIAscii, Text)
              instance Collection MIMEParams (CIAscii, Text)
              instance Indexed    MIMEParams  CIAscii  Text
-             -- instance Map        MIMEParams  CIAscii  Text
+             instance Map        MIMEParams  CIAscii  Text
              instance SortingCollection MIMEParams (CIAscii, Text)
            |]
 
--- FIXME: auto-derive
-instance Map MIMEParams CIAscii Text where
-    {-# INLINE lookup #-}
-    lookup k (MIMEParams m) = lookup k m
-    {-# INLINE mapWithKey #-}
-    mapWithKey f (MIMEParams m)
-        = MIMEParams $ mapWithKey f m
-    {-# INLINE unionWith #-}
-    unionWith f (MIMEParams α) (MIMEParams β)
-        = MIMEParams $ unionWith f α β
-    {-# INLINE intersectionWith #-}
-    intersectionWith f (MIMEParams α) (MIMEParams β)
-        = MIMEParams $ intersectionWith f α β
-    {-# INLINE differenceWith #-}
-    differenceWith f (MIMEParams α) (MIMEParams β)
-        = MIMEParams $ differenceWith f α β
-    {-# INLINE isSubmapBy #-}
-    isSubmapBy f (MIMEParams α) (MIMEParams β)
-        = isSubmapBy f α β
-    {-# INLINE isProperSubmapBy #-}
-    isProperSubmapBy f (MIMEParams α) (MIMEParams β)
-        = isProperSubmapBy f α β
-
 -- |Convert MIME parameter values to an 'AsciiBuilder'.
 printMIMEParams ∷ MIMEParams → AsciiBuilder
 {-# INLINEABLE printMIMEParams #-}

diff --git a/Network/HTTP/Lucu/MIMEParams/Internal.hs b/Network/HTTP/Lucu/MIMEParams/Internal.hs
new file mode 100644 (file)
index 0000000..b863f0f
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEParams/Internal.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE
+    DeriveDataTypeable
+  , GeneralizedNewtypeDeriving
+  #-}
+module Network.HTTP.Lucu.MIMEParams.Internal
+    ( MIMEParams(..)
+    )
+    where
+import Data.Ascii (CIAscii)
+import qualified Data.Map as M (Map)
+import Data.Monoid
+import Data.Text (Text)
+import Data.Typeable
+
+-- |A 'Map' from MIME parameter attributes to values. Attributes are
+-- always case-insensitive according to RFC 2045
+-- (<http://tools.ietf.org/html/rfc2045#section-5.1>).
+newtype MIMEParams
+    = MIMEParams (M.Map CIAscii Text)
+    deriving (Eq, Show, Read, Monoid, Typeable)

diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs
index b5fad5952f8463b16adbdcf27e98a91cbcfed909..f8ea1b2aaf5b3b35edad73d7b3da2731d4b08d18 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Internal.hs
+++ b/Network/HTTP/Lucu/Resource/Internal.hs
@@ -376,6 +376,7 @@ deleteHeader name = liftIO ∘ atomically ∘ go =≪ getInteraction
 putBuilder ∷ Builder → Resource ()
 putBuilder b = liftIO ∘ atomically ∘ go =≪ getInteraction
     where
+      -- FIXME: should see if resCanHaveBody.
       go ∷ NormalInteraction → STM ()
       go ni@(NI {..})
           = do driftTo' ni SendingBody