import Control.Monad.Unicode
import Data.Collections
import Data.Collections.BaseInstances ()
+import Data.Data
+import Data.Generics.Aliases
+import Data.Generics.Schemes
import Data.Maybe
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Ppr
import Language.Haskell.TH.Syntax
-import Prelude hiding (concat, exp)
+import Prelude hiding ( concat, concatMap, exp, filter
+ , foldl, foldr, foldl1, foldr1, null)
import Prelude.Unicode
type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
= do (wrapperTy, deriver) ← inspectInstance ty
(wrap , wrapD ) ← genWrap wrapperTy
(unwrap , unwrapD) ← genUnwrap wrapperTy
- (: wrapD ⧺ unwrapD) <$> deriver (return c )
- (return ty )
- (return wrap )
- (return unwrap)
+ instanceDecl ← deriver (return c )
+ (return ty )
+ (return wrap )
+ (return unwrap)
+ return $ [ d | d ← wrapD , wrap `isUsedIn` instanceDecl ]
+ ⧺ [ d | d ← unwrapD, unwrap `isUsedIn` instanceDecl ]
+ ⧺ [ instanceDecl ]
+
+isUsedIn ∷ (Eq α, Typeable α, Data β) ⇒ α → β → Bool
+isUsedIn α = (> 0) ∘ gcount (mkQ False (≡ α))
inspectInstance ∷ Type → Q (Type, Deriver)
inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
| classTy ≡ ''Unfoldable
= 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
name (SigD n _) = Just n
name _ = Nothing
-pointfreeMethod ∷ (Name → Q Exp) → Name → Q Dec
+pointfreeMethod ∷ (Name → Q Exp) → Name → [Q Dec]
pointfreeMethod f name
- = funD name [clause [] (normalB (f name)) []]
+ = [ funD name [clause [] (normalB (f name)) []]
+ -- THINKME: Inserting PragmaD in an InstanceD causes an error
+ -- least GHC 7.0.3. Why?
+ -- , pragInlD name (inlineSpecNoPhase True False)
+ ]
deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
deriveUnfoldable c ty wrap unwrap
= do names ← methodNames ''Unfoldable
- instanceD c ty $ pointfreeMethod exp <$> names
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
where
exp ∷ Name → Q Exp
exp name
| otherwise
= fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name
-{-
-instance Unfoldable MIMEParams (CIAscii, Text) where
- {-# INLINE insert #-}
- insert p (MIMEParams m)
- = MIMEParams $ insert p m
- {-# INLINE empty #-}
- empty
- = MIMEParams empty
- {-# INLINE singleton #-}
- singleton p
- = MIMEParams $ singleton p
- {-# INLINE insertMany #-}
- insertMany f (MIMEParams m)
- = MIMEParams $ insertMany f m
- {-# INLINE insertManySorted #-}
- insertManySorted f (MIMEParams m)
- = MIMEParams $ insertManySorted f m
--}
+deriveFoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveFoldable c ty _ unwrap
+ = do names ← methodNames ''Foldable
+ instanceD c ty $ concatMap (pointfreeMethod exp) names
+ where
+ exp ∷ Name → Q Exp
+ exp name
+ | name ≡ 'fold
+ = [| fold ∘ $unwrap |]
+ | name ≡ 'foldMap
+ = [| (∘ $unwrap) ∘ foldMap |]
+ | name ≡ 'foldr
+ = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldr |]
+ | name ≡ 'foldl
+ = [| flip flip $unwrap ∘ ((∘) ∘) ∘ foldl |]
+ | name ≡ 'foldr1
+ = [| (∘ $unwrap) ∘ foldr1 |]
+ | name ≡ 'foldl1
+ = [| (∘ $unwrap) ∘ foldl1 |]
+ | name ≡ 'null
+ = [| null ∘ $unwrap |]
+ | name ≡ 'size
+ = [| size ∘ $unwrap |]
+ | name ≡ 'isSingleton
+ = [| 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