Generate HUnfoldable instances using TH.

Data/Tuple/Morph.hs

@@ -118,37 +118,20 @@ class HUnfoldable t where
 
 -- HFoldable instances.
 
-$(mapM (mkHFoldableInst ''HFoldable) [sizeLimit, sizeLimit-1 .. 2])
-
 instance HFoldable () where
     toHList () = HNil
 
 instance (Rep a ~ '[a]) => HFoldable a where
     toHList a = HCons a HNil
 
+$(mapM mkHFoldableInst [2 .. sizeLimit])
+
 -- HUnfoldable instances.
 
-instance (HUnfoldable a, HUnfoldable b, HUnfoldable c, HUnfoldable d) => HUnfoldable (a, b, c, d) where
-    hListParser = case appendRightId (Proxy :: Proxy (Rep b ++ Rep c ++ Rep d)) of
-                  Refl -> hListParser `bindMI` (\a ->
-                          hListParser `bindMI` (\(b, c, d) ->
-                          returnMI (a, b, c, d)))
-
-instance (HUnfoldable a, HUnfoldable b, HUnfoldable c) => HUnfoldable (a, b, c) where
-    hListParser = case appendRightId (Proxy :: Proxy (Rep c)) of
-                  Refl -> hListParser `bindMI` (\a ->
-                          hListParser `bindMI` (\b ->
-                          hListParser `bindMI` (\c ->
-                          returnMI (a, b, c))))
-
-instance (HUnfoldable a, HUnfoldable b) => HUnfoldable (a, b) where
-    hListParser = case appendRightId (Proxy :: Proxy (Rep b)) of 
-                  Refl -> hListParser `bindMI` (\a ->
-                          hListParser `bindMI` (\b ->
-                          returnMI (a, b)))
+instance HUnfoldable () where
+    hListParser = HParser $ \r -> ((), r)
 
 instance (Rep a ~ '[a]) => HUnfoldable a where
     hListParser = HParser $ \(HCons a r) -> (a, r)
 
-instance HUnfoldable () where
-    hListParser = HParser $ \r -> ((), r)
+$(mapM mkHUnfoldableInst [2 .. sizeLimit])

Data/Tuple/Morph/TH.hs

@@ -13,11 +13,14 @@ Stability   :  experimental
 module Data.Tuple.Morph.TH (
     sizeLimit,
     mkRep,
-    mkHFoldableInst
+    mkHFoldableInst,
+    mkHUnfoldableInst
     ) where
 
 import Control.Monad
+import Data.Proxy
 import Data.Tuple.Morph.Append
+import Data.Type.Equality
 import Language.Haskell.TH
 
 -- | Generates names starting with letters of the alphabet, then
@@ -61,23 +64,56 @@ mkRep n = fmap (:[])
             rep = foldr1 (\x y -> AppT (AppT append x) y) reps
         return $ TySynEqn [tuple] rep
 
--- | Creates a HFoldable instance for @k@ element tuples.
-mkHFoldableInst :: Name -> Int -> Q Dec
-mkHFoldableInst className k = do
+mkInst :: Name -> Int -> ([Name] -> [Dec]) -> Dec
+mkInst className k decs =
     let names = mkNames k
-        -- types a, b, c, ...
-        vars = map VarT names
-        -- type (a, b, c, ...)
-        tuple = tupleFrom vars
+        tvars = map VarT names
+    in InstanceD [ClassP className [tvar] | tvar <- tvars]
+                 (AppT (ConT className) (tupleFrom tvars))
+                 (decs names)
+
+-- | Creates a HFoldable instance for @k@ element tuples.
+mkHFoldableInst :: Int -> Q Dec
+mkHFoldableInst k = return $ mkInst (mkName "HFoldable") k $ \names ->
+    let toHListName = mkName "toHList"
         -- pattern (a, b, c, ...)
         tupleP = TupP $ map VarP names
-        toHListName = mkName "toHList"
         -- toHList a, toHList b, toHList c, ...
         hlists = map (\n -> AppE (VarE toHListName) (VarE n)) names
         -- toHList a ++@ toHList b ++@ toHList c ++@ ...
         body = NormalB $ foldr1 (\x y -> AppE (AppE (VarE '(++@)) x) y) hlists
         toHList = FunD toHListName [Clause [tupleP] body []]
-    return $ InstanceD
-             [ClassP className [var] | var <- vars]
-             (AppT (ConT className) tuple)
-             [toHList]
+    in [toHList]
+
+-- | Creates a HUnfoldable instance for @k@ element tuples.
+mkHUnfoldableInst :: Int -> Q Dec
+mkHUnfoldableInst k = return $ mkInst (mkName "HUnfoldable") k $ \names ->
+    let hListParserName = mkName "hListParser"
+        repName = mkName "Rep"
+        bindMIName = mkName "bindMI"
+        returnMIName = mkName "returnMI"
+
+        -- Proxy :: Proxy (Rep z)
+        proxy = SigE (ConE 'Proxy)
+                     (AppT (ConT ''Proxy)
+                           (AppT (ConT repName)
+                                 (VarT $ last names)))
+
+        -- appendRightId proxy
+        theorem = AppE (VarE 'appendRightId) proxy
+
+        -- bindMI hListParser (\a ->
+        -- bindMI hListParser (\b ->
+        -- ...
+        -- returnMI (a, b, c, ...))...)
+        bindE n e = AppE (AppE (VarE bindMIName)
+                               (VarE hListParserName))
+                         (LamE [VarP n] e)
+        returnE = (AppE (VarE returnMIName) (TupE (map VarE names)))
+
+        matchBody = NormalB $ foldr bindE returnE names
+
+        -- case theorem of Refl -> ???
+        body = NormalB $ CaseE theorem [Match (ConP 'Refl []) matchBody []]
+        hListParser = FunD hListParserName [Clause [] body []]
+    in [hListParser]