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 (file)
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 01da991f9af972796de59d8586d4ae8548d0cd49..aa1a9b9f27784baf6ae4f7ffb6e4ffbe97dba0fd 100644 (file)
--- 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 ce0b6915a4118c2dbf178b786960ce8556f85355..1304c2328a5db1fd3931e332b07948928dc32bdb 100644 (file)
--- 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
 -- (<http://tools.ietf.org/html/rfc2231>).
 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