Generate HFoldable instances using TH.

Data/Tuple/Morph.hs

@@ -21,12 +21,12 @@ Stability   :  experimental
 
 Allows you to flatten, unflatten and morph tuples of matching types.
 
-Note: by design units are ignored. For example @(Int, (), Char)@ is 
-      the same as @(Int, Char)@.
+Note: by design units are ignored. For example @(Int, (), Char)@ is the same as @(Int, Char)@.
 -}
 module Data.Tuple.Morph (
     -- * Morphing tuples.
     morph,
+    sizeLimit,
 
     -- * Converting between tuples and HLists.
     Rep,
@@ -46,11 +46,11 @@ import Data.Tuple.Morph.Append
 import Data.Tuple.Morph.TH
 
 -- | Recurisvely break down a tuple type, representing it as a type list.
-$(mkRep 13)
+$(mkRep sizeLimit)
 
 -- | Morph a tuple to some isomorphic tuple with the same order of types.
 --
--- Works with arbitrary nested tuples, each tuple can have size up to 13.
+-- Works with arbitrary nested tuples, each tuple can have size up to 'sizeLimit'.
 --
 -- >>> morph ("a", ("b", "c")) :: (String, String, String)
 -- ("a","b","c")
@@ -116,17 +116,9 @@ class HUnfoldable t where
     -- | Builds a structure from a heterogenous list and yields the leftovers.
     hListParser :: HParser (Rep t) t
 
-instance (HFoldable a, HFoldable b, HFoldable c, HFoldable d, HFoldable e) => HFoldable (a, b, c, d, e) where
-    toHList (a, b, c, d, e) = toHList a ++@ toHList b ++@ toHList c ++@ toHList d ++@ toHList e
+-- HFoldable instances.
 
-instance (HFoldable a, HFoldable b, HFoldable c, HFoldable d) => HFoldable (a, b, c, d) where
-    toHList (a, b, c, d) = toHList a ++@ toHList b ++@ toHList c ++@ toHList d
-
-instance (HFoldable a, HFoldable b, HFoldable c) => HFoldable (a, b, c) where
-    toHList (a, b, c) = toHList a ++@ toHList b ++@ toHList c
-
-instance (HFoldable a, HFoldable b) => HFoldable (a, b) where
-    toHList (a, b) = toHList a ++@ toHList b
+$(mapM (mkHFoldableInst ''HFoldable) [sizeLimit, sizeLimit-1 .. 2])
 
 instance HFoldable () where
     toHList () = HNil
@@ -134,18 +126,20 @@ instance HFoldable () where
 instance (Rep a ~ '[a]) => HFoldable a where
     toHList a = HCons a HNil
 
+-- HUnfoldable instances.
 
 instance (HUnfoldable a, HUnfoldable b, HUnfoldable c, HUnfoldable d) => HUnfoldable (a, b, c, d) where
-    hListParser = case appendRightId (Proxy :: Proxy (Rep d)) of
-                  Refl -> hListParser `bindMI` (\(a, b, c) ->
-                          hListParser `bindMI` (\d ->
+    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, b) ->
+                  Refl -> hListParser `bindMI` (\a ->
+                          hListParser `bindMI` (\b ->
                           hListParser `bindMI` (\c ->
-                          returnMI (a, b, c)))
+                          returnMI (a, b, c))))
 
 instance (HUnfoldable a, HUnfoldable b) => HUnfoldable (a, b) where
     hListParser = case appendRightId (Proxy :: Proxy (Rep b)) of 

Data/Tuple/Morph/Append.hs

@@ -20,6 +20,8 @@ import Data.Proxy
 import Data.Type.Equality
 import Unsafe.Coerce
 
+infixr 5 ++, ++@
+
 -- | Appends two type lists.
 type family (++) (a :: [k]) (b :: [k]) :: [k] where
     '[]       ++ b = b

Data/Tuple/Morph/TH.hs

@@ -10,11 +10,30 @@ License     :  MIT
 Maintainer  :  Paweł Nowak <pawel834@gmail.com>
 Stability   :  experimental
 -}
-module Data.Tuple.Morph.TH where
+module Data.Tuple.Morph.TH (
+    sizeLimit,
+    mkRep,
+    mkHFoldableInst
+    ) where
 
+import Control.Monad
 import Data.Tuple.Morph.Append
 import Language.Haskell.TH
 
+-- | Generates names starting with letters of the alphabet, then
+-- pairs of letters, triples of letters and so on.
+mkNames :: Int -> [Name]
+mkNames n = take n $ map mkName $ [1 ..] >>= flip replicateM ['a' .. 'z']
+
+tupleFrom :: [Type] -> Type
+tupleFrom vars = foldl AppT (TupleT (length vars)) vars
+
+-- | Size of the largest tuple that this library will work with. Equal to 13.
+--
+-- Note that size of ((((((1, 1), 1), 1), 1), 1), 1) is 2, not 7.
+sizeLimit :: Int
+sizeLimit = 13
+
 -- | Creates the "Rep" type family.
 mkRep :: Int -> Q [Dec]
 mkRep n = fmap (:[])
@@ -31,13 +50,34 @@ mkRep n = fmap (:[])
     repName = mkName "Rep"
     append = VarT ''(++)
     mkEqn k = do
-        names <- sequence $ take k $ map (newName . (:[])) ['a' .. 'z']
-        let -- a, b, c, ...
+        let names = mkNames k
+            -- a, b, c, ...
             vars = map VarT names
             -- (a, b, c, ...)
-            tuple = foldl AppT (TupleT k) vars
+            tuple = tupleFrom vars
             -- Rep a, Rep b, Rep c, ...
             reps = map (AppT (ConT repName)) vars
             -- Rep a ++ Rep b ++ Rep c ++ ...
-            rep = foldl1 (\x y -> AppT (AppT append x) y) reps
+            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
+    let names = mkNames k
+        -- types a, b, c, ...
+        vars = map VarT names
+        -- type (a, b, c, ...)
+        tuple = tupleFrom vars
+        -- 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]