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