X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Data%2FCollections%2FNewtype%2FTH.hs;fp=Data%2FCollections%2FNewtype%2FTH.hs;h=b3c7e59d41feb74a387e5939d59e0d6007a05ccf;hp=e3cb868e5ab460428cc7fbdce00427f00a7d0300;hb=68afccfff5a39e92903c467fac3a99734ce8a404;hpb=852d97c73c367bc7880600850d92463f580ca1ca diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs index e3cb868..b3c7e59 100644 --- 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 () @@ -56,6 +57,8 @@ inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _) = 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) @@ -200,3 +203,15 @@ deriveIndexed c ty wrap unwrap = [| (($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