auto-derive SortingCollection

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

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index c5393bbf1a1ab386bee2d70d302d728ab473133d..b3c7e59d41feb74a387e5939d59e0d6007a05ccf 100644 (file)
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -8,14 +8,19 @@ module Data.Collections.Newtype.TH
     )
     where
 import Control.Applicative hiding (empty)
+import Control.Arrow
 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
@@ -33,15 +38,30 @@ 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)
+    | classTy ≡ ''Collection
+        = return (wrapperTy, deriveCollection)
+    | classTy ≡ ''SortingCollection
+        = return (wrapperTy, deriveSortingCollection)
+inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
+    | classTy ≡ ''Indexed
+        = return (wrapperTy, deriveIndexed)
 inspectInstance ty
     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
 
@@ -96,14 +116,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 +144,74 @@ 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
+
+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
+
+deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveSortingCollection c ty wrap unwrap
+    = do names ← methodNames ''SortingCollection
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'minView
+              = [| (second $wrap <$>) ∘ minView ∘ $unwrap |]
+          | otherwise
+              = fail $ "deriveSortingCollection: unknown method: " ⧺ pprint name