Automatic deriving of Unfoldable

[Lucu.git] / Data / Collections / Newtype / TH.hs

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
+-}