X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Data%2FCollections%2FNewtype%2FTH.hs;h=0301fd37562222cc896bc9246dc20c0c423d1bba;hb=8de439e0d2869f46e926d3132f6b1113201460e5;hp=d81cb0155662b3c2582374ba663a64e29ab19871;hpb=b8d4661ea67362e44cf4ec8d62d996a5d0d89bdf;p=Lucu.git

diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs
index d81cb01..0301fd3 100644
--- a/Data/Collections/Newtype/TH.hs
+++ b/Data/Collections/Newtype/TH.hs
@@ -2,12 +2,15 @@
     TemplateHaskell
   , UnicodeSyntax
   #-}
--- |FIXME: doc
+-- |Doesn't anyone know why these instances can't be derived using
+-- GeneralizedNewtypeDeriving? I think its limitation isn't reasonable
+-- at all...
 module Data.Collections.Newtype.TH
     ( derive
     )
     where
 import Control.Applicative hiding (empty)
+import Control.Arrow
 import Control.Monad.Unicode
 import Data.Collections
 import Data.Collections.BaseInstances ()
@@ -18,13 +21,50 @@ import Data.Maybe
 import Language.Haskell.TH.Lib
 import Language.Haskell.TH.Ppr
 import Language.Haskell.TH.Syntax
-import Prelude hiding ( concat, concatMap, exp
-                      , foldl, foldr, foldl1, foldr1, null)
+import Prelude hiding ( concat, concatMap, exp, filter
+                      , foldl, foldr, foldl1, foldr1
+                      , lookup, null
+                      )
 import Prelude.Unicode
 
 type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec
 
--- |FIXME: doc
+-- |Automatic newtype instance deriver for type classes defined by the
+-- collections-api package.
+--
+-- @
+--   {-\# LANGUAGE TemplateHaskell \#-}
+--   module Foo (T) where
+--   import "Data.Collections"
+--   import "Data.Collections.BaseInstances" ()
+--   import qualified Data.Collections.Newtype.TH as C
+--   import qualified "Data.Map" as M
+--
+--   newtype T = T (M.Map 'Int' 'Bool')
+--
+--   C.derive [d| instance 'Unfoldable' T ('Int', 'Bool')
+--                instance 'Foldable'   T ('Int', 'Bool')
+--                instance 'Indexed'    T  'Int'  'Bool'
+--                ...
+--              |]
+-- @
+--
+-- This function can derive the following instances:
+--
+--   * 'Unfoldable'
+--
+--   * 'Foldable'
+--
+--   * 'Collection'
+--
+--   * 'Indexed'
+--
+--   * 'Map'
+--
+--   * 'Set'
+--
+--   * 'SortingCollection'
+--
 derive ∷ Q [Dec] → Q [Dec]
 derive = (concat <$>) ∘ (mapM go =≪)
     where
@@ -54,6 +94,17 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _)
         = return (wrapperTy, deriveUnfoldable)
     | classTy ≡ ''Foldable
         = 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) _) _)
+    | classTy ≡ ''Indexed
+        = return (wrapperTy, deriveIndexed)
+    | classTy ≡ ''Map
+        = return (wrapperTy, deriveMap)
 inspectInstance ty
     = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty
 
@@ -163,3 +214,105 @@ 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
+
+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
+
+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
+         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