auto-derive Map

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

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index b3c7e59d41feb74a387e5939d59e0d6007a05ccf..d392758a4be3c3eaaaaa690037b2fdbef8b6aa97 100644 (file)
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -20,7 +20,9 @@ import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Ppr
 import Language.Haskell.TH.Syntax
 import Prelude hiding ( concat, concatMap, exp, filter
-                      , foldl, foldr, foldl1, foldr1, null)
+                      , foldl, foldr, foldl1, foldr1
+                      , lookup, null
+                      )
 import Prelude.Unicode
 
 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
@@ -62,6 +64,8 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
 inspectInstance (AppT (AppT (AppT (ConT classTy) wrapperTy) _) _)
     | classTy ≡ ''Indexed
         = return (wrapperTy, deriveIndexed)
+    | classTy ≡ ''Map
+        = return (wrapperTy, deriveMap)
 inspectInstance ty
     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
 
@@ -204,6 +208,52 @@ deriveIndexed c ty wrap unwrap
           | otherwise
               = fail $ "deriveIndexed: unknown method: " ⧺ pprint name
 
+deriveMap ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
+deriveMap c ty wrap unwrap
+    = do names ← methodNames ''Map
+         instanceD c ty $ concatMap (pointfreeMethod exp) names
+    where
+      exp ∷ Name → Q Exp
+      exp name
+          | name ≡ 'delete
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ delete |]
+          | name ≡ 'member
+              = [| (∘ $unwrap) ∘ member |]
+          | name ≡ 'union
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ union ∘ $unwrap |]
+          | name ≡ 'intersection
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ intersection ∘ $unwrap |]
+          | name ≡ 'difference
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ difference ∘ $unwrap |]
+          | name ≡ 'isSubset
+              = [| (∘ $unwrap) ∘ isSubset ∘ $unwrap |]
+          | name ≡ 'isProperSubset
+              = [| (∘ $unwrap) ∘ isProperSubset ∘ $unwrap |]
+          | name ≡ 'lookup
+              = [| (∘ $unwrap) ∘ lookup |]
+          | name ≡ 'alter
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ alter |]
+          | name ≡ 'insertWith
+              = [| ((($wrap ∘) ∘) ∘) ∘ flip flip $unwrap ∘ ((flip ∘ ((∘) ∘)) ∘) ∘ insertWith |]
+          | name ≡ 'fromFoldableWith
+              = [| ($wrap ∘) ∘ fromFoldableWith |]
+          | name ≡ 'foldGroups
+              = [| (($wrap ∘) ∘) ∘ foldGroups |]
+          | name ≡ 'mapWithKey
+              = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ mapWithKey |]
+          | name ≡ 'unionWith
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ unionWith |]
+          | name ≡ 'intersectionWith
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ intersectionWith |]
+          | name ≡ 'differenceWith
+              = [| (($wrap ∘) ∘) ∘ flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ differenceWith |]
+          | name ≡ 'isSubmapBy
+              = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isSubmapBy |]
+          | name ≡ 'isProperSubmapBy
+              = [| flip flip $unwrap ∘ ((∘) ∘) ∘ (∘ $unwrap) ∘ isProperSubmapBy |]
+          | otherwise
+              = fail $ "deriveMap: unknown method: " ⧺ pprint name
+
 deriveSortingCollection ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 deriveSortingCollection c ty wrap unwrap
     = do names ← methodNames ''SortingCollection