auto-derive Foldable

[Lucu.git] / Data / Collections / Newtype / TH.hs

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index c5393bbf1a1ab386bee2d70d302d728ab473133d..d81cb0155662b3c2582374ba663a64e29ab19871 100644 (file)
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -11,11 +11,15 @@ import Control.Applicative hiding (empty)
 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
@@ -33,15 +37,23 @@ deriveInstance c ty
     = 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
 
@@ -96,14 +108,18 @@ methodNames = (names =≪) ∘ reify
       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
@@ -120,21 +136,30 @@ deriveUnfoldable c ty wrap unwrap
           | 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