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
= 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
= [| 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
, 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
-- (<http://tools.ietf.org/html/rfc2231>).
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 #-}