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 d81cb0155662b3c2582374ba663a64e29ab19871..b3c7e59d41feb74a387e5939d59e0d6007a05ccf 100644 (file)
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -8,6 +8,7 @@ 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 ()
@@ -18,7 +19,7 @@ import Data.Maybe
 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
 
@@ -54,6 +55,13 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
         = 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
 
@@ -163,3 +171,47 @@ deriveFoldable c ty _ unwrap
               = [| 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