From: PHO Date: Sat, 19 Nov 2011 06:31:50 +0000 (+0900) Subject: auto-derive Collection / Indexed X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=852d97c;p=Lucu.git auto-derive Collection / Indexed Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs index d81cb01..e3cb868 100644 --- a/Data/Collections/Newtype/TH.hs +++ b/Data/Collections/Newtype/TH.hs @@ -18,7 +18,7 @@ import Data.Maybe import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax -import Prelude hiding ( concat, concatMap, exp +import Prelude hiding ( concat, concatMap, exp, filter , foldl, foldr, foldl1, foldr1, null) import Prelude.Unicode @@ -54,6 +54,11 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _) = return (wrapperTy, deriveUnfoldable) | classTy ≡ ''Foldable = return (wrapperTy, deriveFoldable) + | classTy ≡ ''Collection + = return (wrapperTy, deriveCollection) +inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _) + | classTy ≡ ''Indexed + = return (wrapperTy, deriveIndexed) inspectInstance ty = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty @@ -163,3 +168,35 @@ deriveFoldable c ty _ unwrap = [| isSingleton ∘ $unwrap |] | otherwise = fail $ "deriveFoldable: unknown method: " ⧺ pprint name + +deriveCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec +deriveCollection c ty wrap unwrap + = do names ← methodNames ''Collection + instanceD c ty $ concatMap (pointfreeMethod exp) names + where + exp ∷ Name → Q Exp + exp name + | name ≡ 'filter + = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ filter |] + | otherwise + = fail $ "deriveCollection: unknown method: " ⧺ pprint name + +deriveIndexed ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec +deriveIndexed c ty wrap unwrap + = do names ← methodNames ''Indexed + instanceD c ty $ concatMap (pointfreeMethod exp) names + where + exp ∷ Name → Q Exp + exp name + | name ≡ 'index + = [| (∘ $unwrap) ∘ index |] + | name ≡ 'adjust + = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ adjust |] + | name ≡ 'inDomain + = [| (∘ $unwrap) ∘ inDomain |] + | name ≡ '(//) + = [| ($wrap ∘) ∘ (//) ∘ $unwrap |] + | name ≡ 'accum + = [| (($wrap ∘) ∘) ∘ (∘ $unwrap) ∘ accum |] + | otherwise + = fail $ "deriveIndexed: unknown method: " ⧺ pprint name diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index 183a4c0..3698213 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -11,7 +11,7 @@ , UnicodeSyntax #-} {-# OPTIONS_GHC -ddump-splices #-} -- FIXME --- GHC 7.0.3 gives us a false warning. +-- THINKME: GHC 7.0.3 gives us a false warning. {-# OPTIONS_GHC -fno-warn-missing-methods #-} -- |Parsing and printing MIME parameter values -- (). @@ -59,22 +59,10 @@ newtype MIMEParams C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text) instance Foldable MIMEParams (CIAscii, Text) + instance Collection MIMEParams (CIAscii, Text) + instance Indexed MIMEParams CIAscii Text |] --- 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 - {-# INLINE adjust #-} - adjust f k (MIMEParams m) = MIMEParams $ adjust f k m - {-# INLINE inDomain #-} - inDomain k (MIMEParams m) = inDomain k m - -- FIXME: auto-derive instance Map MIMEParams CIAscii Text where {-# INLINE lookup #-}