From: PHO Date: Thu, 17 Nov 2011 10:09:06 +0000 (+0900) Subject: Automatic deriving of Unfoldable X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=8dc2ddc;p=Lucu.git Automatic deriving of Unfoldable Ditz-issue: e0312227f40a0fa92d4c5d69a64dad473f54389a --- diff --git a/Data/Collections/Newtype/TH.hs b/Data/Collections/Newtype/TH.hs new file mode 100644 index 0000000..c5393bb --- /dev/null +++ b/Data/Collections/Newtype/TH.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE + TemplateHaskell + , UnicodeSyntax + #-} +-- |FIXME: doc +module Data.Collections.Newtype.TH + ( derive + ) + where +import Control.Applicative hiding (empty) +import Control.Monad.Unicode +import Data.Collections +import Data.Collections.BaseInstances () +import Data.Maybe +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Syntax +import Prelude hiding (concat, exp) +import Prelude.Unicode + +type Deriver = Q Cxt → Q Type → Q Exp → Q Exp → Q Dec + +-- |FIXME: doc +derive ∷ Q [Dec] → Q [Dec] +derive = (concat <$>) ∘ (mapM go =≪) + where + go ∷ Dec → Q [Dec] + go (InstanceD c ty _) = deriveInstance c ty + go _ = fail "derive: usage: derive [d| instance A; instance B; ... |]" + +deriveInstance ∷ Cxt → Type → Q [Dec] +deriveInstance c ty + = do (wrapperTy, deriver) ← inspectInstance ty + (wrap , wrapD ) ← genWrap wrapperTy + (unwrap , unwrapD) ← genUnwrap wrapperTy + (: wrapD ⧺ unwrapD) <$> deriver (return c ) + (return ty ) + (return wrap ) + (return unwrap) + +inspectInstance ∷ Type → Q (Type, Deriver) +inspectInstance (AppT (AppT (ConT classTy) wrapperTy) _) + | classTy ≡ ''Unfoldable + = return (wrapperTy, deriveUnfoldable) +inspectInstance ty + = fail $ "deriveInstance: unsupported type: " ⧺ pprint ty + +genWrap ∷ Type → Q (Exp, [Dec]) +genWrap wrapperTy + = do name ← newName "wrap" + (con, ty) ← wrapperConTy wrapperTy + decls ← sequence + [ sigD name [t| $(return ty) → $(return wrapperTy) |] + , pragInlD name (inlineSpecNoPhase True True) + , funD name [clause [] (normalB (conE con)) []] + ] + return (VarE name, decls) + +genUnwrap ∷ Type → Q (Exp, [Dec]) +genUnwrap wrapperTy + = do name ← newName "unwrap" + i ← newName "i" + (con, ty) ← wrapperConTy wrapperTy + decls ← sequence + [ sigD name [t| $(return wrapperTy) → $(return ty) |] + , pragInlD name (inlineSpecNoPhase True True) + , funD name [clause [conP con [varP i]] (normalB (varE i)) []] + ] + return (VarE name, decls) + +wrapperConTy ∷ Type → Q (Name, Type) +wrapperConTy = (conTy =≪) ∘ tyInfo + where + tyInfo ∷ Type → Q Info + tyInfo (ConT name) = reify name + tyInfo (AppT ty _) = tyInfo ty + tyInfo (SigT ty _) = tyInfo ty + tyInfo ty + = fail $ "wrapperConTy: unsupported type: " ⧺ pprint ty + + conTy ∷ Info → Q (Name, Type) + conTy (TyConI (NewtypeD [] _ [] (NormalC con [(NotStrict, ty)]) [])) + = return (con, ty) + conTy info + = fail $ "wrapperConTy: unsupported type: " ⧺ pprint info + +methodNames ∷ Name → Q [Name] +methodNames = (names =≪) ∘ reify + where + names ∷ Info → Q [Name] + names (ClassI (ClassD _ _ _ _ decls) _) + = return ∘ catMaybes $ map name decls + names c = fail $ "methodNames: not a class: " ⧺ pprint c + + name ∷ Dec → Maybe Name + name (SigD n _) = Just n + name _ = Nothing + +pointfreeMethod ∷ (Name → Q Exp) → Name → Q Dec +pointfreeMethod f name + = funD name [clause [] (normalB (f name)) []] + +deriveUnfoldable ∷ Q Cxt → Q Type → Q Exp → Q Exp → Q Dec +deriveUnfoldable c ty wrap unwrap + = do names ← methodNames ''Unfoldable + instanceD c ty $ pointfreeMethod exp <$> names + where + exp ∷ Name → Q Exp + exp name + | name ≡ 'insert + = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insert |] + | name ≡ 'empty + = [| $wrap empty |] + | name ≡ 'singleton + = [| $wrap ∘ singleton |] + | name ≡ 'insertMany + = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertMany |] + | name ≡ 'insertManySorted + = [| ($wrap ∘) ∘ (∘ $unwrap) ∘ insertManySorted |] + | otherwise + = fail $ "deriveUnfoldable: unknown method: " ⧺ pprint name + +{- +instance Unfoldable MIMEParams (CIAscii, Text) where + {-# INLINE insert #-} + insert p (MIMEParams m) + = MIMEParams $ insert p m + {-# INLINE empty #-} + empty + = MIMEParams empty + {-# INLINE singleton #-} + singleton p + = MIMEParams $ singleton p + {-# INLINE insertMany #-} + insertMany f (MIMEParams m) + = MIMEParams $ insertMany f m + {-# INLINE insertManySorted #-} + insertManySorted f (MIMEParams m) + = MIMEParams $ insertManySorted f m +-} diff --git a/Lucu.cabal b/Lucu.cabal index 01da991..aa1a9b9 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -114,6 +114,7 @@ Library Network.HTTP.Lucu.Utils Other-Modules: + Data.Collections.Newtype.TH Network.HTTP.Lucu.Abortion.Internal Network.HTTP.Lucu.Chunk Network.HTTP.Lucu.ContentCoding diff --git a/Network/HTTP/Lucu/MIMEParams.hs b/Network/HTTP/Lucu/MIMEParams.hs index ce0b691..1304c23 100644 --- a/Network/HTTP/Lucu/MIMEParams.hs +++ b/Network/HTTP/Lucu/MIMEParams.hs @@ -10,6 +10,9 @@ , TypeSynonymInstances , UnicodeSyntax #-} +{-# OPTIONS_GHC -ddump-splices #-} -- FIXME +-- GHC 7.0.3 gives us a false warning. +{-# OPTIONS_GHC -fno-warn-missing-methods #-} -- |Parsing and printing MIME parameter values -- (). module Network.HTTP.Lucu.MIMEParams @@ -30,6 +33,7 @@ import qualified Data.ByteString.Char8 as BS import Data.Char import Data.Collections import Data.Collections.BaseInstances () +import qualified Data.Collections.Newtype.TH as C import qualified Data.Map as M (Map) import Data.Monoid import Data.Monoid.Unicode @@ -53,23 +57,8 @@ newtype MIMEParams = MIMEParams (M.Map CIAscii Text) deriving (Eq, Show, Read, Monoid, Typeable) --- FIXME: auto-derive -instance Unfoldable MIMEParams (CIAscii, Text) where - {-# INLINE insert #-} - insert p (MIMEParams m) - = MIMEParams $ insert p m - {-# INLINE empty #-} - empty - = MIMEParams empty - {-# INLINE singleton #-} - singleton p - = MIMEParams $ singleton p - {-# INLINE insertMany #-} - insertMany f (MIMEParams m) - = MIMEParams $ insertMany f m - {-# INLINE insertManySorted #-} - insertManySorted f (MIMEParams m) - = MIMEParams $ insertManySorted f m +C.derive [d| instance Unfoldable MIMEParams (CIAscii, Text) + |] -- FIXME: auto-derive instance Foldable MIMEParams (CIAscii, Text) where