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
+ , 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)
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