auto-derive Set

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

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index d392758a4be3c3eaaaaa690037b2fdbef8b6aa97..c60ea2b9b823311c05a1b9fa6faf4e5b365055a5 100644 (file)
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -59,6 +59,8 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
         = return (wrapperTy, deriveFoldable)
     | classTy ≡ ''Collection
         = return (wrapperTy, deriveCollection)
+    | classTy ≡ ''Set
+        = return (wrapperTy, deriveSet)
     | classTy ≡ ''SortingCollection
         = return (wrapperTy, deriveSortingCollection)
 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
@@ -254,6 +256,18 @@ deriveMap c ty wrap unwrap
           | otherwise
               = fail $ "deriveMap: unknown method: " ⧺ pprint name
 
+deriveSet ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveSet c ty _ _
+    = do names ← methodNames ''Set
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'haddock_candy
+              = [| haddock_candy |]
+          | otherwise
+              = fail $ "deriveSet: unknown method: " ⧺ pprint name
+
 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 deriveSortingCollection c ty wrap unwrap
     = do names ← methodNames ''SortingCollection