From b2da45926a7900603a5426e0c6d65e3ca630a1a2 Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 21 Nov 2011 12:52:38 +0900 Subject: [PATCH] auto-derive Map Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- Data/Collections/Newtype/TH.hs | 52 +++++++++++++++++++++++- Lucu.cabal | 1 + Network/HTTP/Lucu/MIMEParams.hs | 40 ++---------------- Network/HTTP/Lucu/MIMEParams/Internal.hs | 20 +++++++++ Network/HTTP/Lucu/Resource/Internal.hs | 1 + 5 files changed, 77 insertions(+), 37 deletions(-) create mode 100644 Network/HTTP/Lucu/MIMEParams/Internal.hs diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs index b3c7e59..d392758 100644 --- 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 aa1a9b9..eecb8a7 100644 --- 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 a3722a3..89b2bfd 100644 --- 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 -- (). @@ -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 --- (). -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 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 +-- (). +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 b5fad59..f8ea1b2 100644 --- 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 -- 2.40.0