X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Data%2FCollections%2FNewtype%2FTH.hs;h=0301fd37562222cc896bc9246dc20c0c423d1bba;hb=251831f3e465eb77666193efcb9b4c02531faa6c;hp=b3c7e59d41feb74a387e5939d59e0d6007a05ccf;hpb=68afccfff5a39e92903c467fac3a99734ce8a404;p=Lucu.git diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs index b3c7e59..0301fd3 100644 --- a/Data/Collections/Newtype/TH.hs +++ b/Data/Collections/Newtype/TH.hs @@ -2,7 +2,9 @@ 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 ) @@ -20,12 +22,49 @@ 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 --- |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 @@ -57,11 +96,15 @@ 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) _) _) | classTy ≡ ''Indexed = return (wrapperTy, deriveIndexed) + | classTy ≡ ''Map + = return (wrapperTy, deriveMap) inspectInstance ty = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty @@ -204,6 +247,64 @@ 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 + +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