zipx and unzipx bijective functions

ZipX.hs

{-# LANGUAGE NoImplicitPrelude #-}

module ZipX where

import Data.List(intercalate, unzip, concat, null, map, (++))
import Prelude(Show(..), Eq(..), Bool(..), String, (.), (||), not)

-- $setup
-- >>> import Test.QuickCheck(Arbitrary(..))
-- >>> import Control.Applicative(liftA2)
-- >>> import Prelude(Functor(..), Int, uncurry)
-- >>> import Data.Maybe(maybe)
-- >>> import Data.Either(either)
--
-- >>> instance Arbitrary a => Arbitrary (NonEmptyList a) where arbitrary = liftA2 NonEmptyList arbitrary arbitrary
--
-- >>> instance (Arbitrary a, Arbitrary b) => Arbitrary (ZipRest a b) where arbitrary = fmap (maybe ZipN (either ZipA ZipB)) arbitrary
--
-- >>> instance (Arbitrary a, Arbitrary b) => Arbitrary (ZipX a b) where arbitrary = liftA2 ZipX arbitrary arbitrary

data NonEmptyList a =
  NonEmptyList a [a]
  deriving Eq

toList :: 
  NonEmptyList a
  -> [a]
toList (NonEmptyList a as) =
  a : as

instance Show a => Show (NonEmptyList a) where
  show =
    show . toList

data ZipRest a b =
  ZipA (NonEmptyList a)
  | ZipB (NonEmptyList b)
  | ZipN
  deriving Eq

isEmptyRest ::
  ZipRest a b
  -> Bool
isEmptyRest ZipN =
  True
isEmptyRest (ZipA _) =
  False
isEmptyRest (ZipB _) =
  False

instance (Show a, Show b) => Show (ZipRest a b) where
  show (ZipA a) =
    comma (\a' -> '(' : show a' ++ ",)") (toList a)
  show (ZipB b) =
    comma (\b' -> "(," ++ show b' ++ ")") (toList b)    
  show ZipN =
    []

data ZipX a b =
  ZipX [(a, b)] (ZipRest a b)
  deriving Eq

instance (Show a, Show b) => Show (ZipX a b) where
  show (ZipX z r) =
    concat
      [
        "["
      , comma show z
      , if null z || isEmptyRest r then [] else ","
      , show r
      , "]"
      ] 

-- | Zip two lists, maintaining any suffixes if the two lists do not align
-- (are of unequal length). The two lists are recoverable from the result of
-- this (bijective) function.
--
-- An /inverse/ for @unzipx@.
--
-- >>> zipx [] [] -- zip two empty lists
-- []
--
-- >>> zipx [1] ['a'] -- zip two lists of equal length (1)
-- [(1,'a')]
--
-- >>> zipx [] ['a'] -- zip empty list with singleton list
-- [(,'a')]
--
-- >>> zipx [1] [] -- zip singleton list with empty list
-- [(1,)]
--
-- > zipx [] ['a', 'b', 'c', 'd'] -- zip empty list with substantially long list (4)
-- [(,'a'),(,'b'),(,'c'),(,'d')]
--
-- >>> zipx [1,2,3,4] [] -- zip substantially long list (4) with empty list
-- [(1,),(2,),(3,),(4,)]
--
-- >>> zipx [1,2,3,4] ['a', 'b', 'c', 'd'] -- zip two equally substantially long lists (4)
-- [(1,'a'),(2,'b'),(3,'c'),(4,'d')]
--
-- >>> zipx [1,2,3,4,5] ['a', 'b', 'c', 'd'] -- zip substantially long list (5) with substantially long list (4)
-- [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(5,)]
--
-- >>> zipx [1,2,3,4] ['a', 'b', 'c', 'd', 'e'] -- zip substantially long list (4) with substantially long list (5)
-- [(1,'a'),(2,'b'),(3,'c'),(4,'d'),(,'e')]
--
-- unzipx is an inverse for zipx
-- prop> unzipx (zipx a b) == (a :: [Int], b :: [Int])
zipx ::
  [a]
  -> [b]
  -> ZipX a b
zipx [] [] =
  ZipX [] ZipN
zipx (a:as) [] =
  ZipX [] (ZipA (NonEmptyList a as))
zipx [] (b:bs) =
  ZipX [] (ZipB (NonEmptyList b bs))
zipx (a:as) (b:bs) =
  let ZipX z r = zipx as bs
  in ZipX ((a, b):z) r

-- | Unzip a list of pairs with possible list suffixes on each side of the pair.
-- (denoting unequal length). The input list is recoverable from the result of
-- this (bijective) function.
--
-- An /inverse/ for @zipx@.
--
-- >>> unzipx (ZipX [] ZipN) -- unzip an empty list with no suffixes
-- ([],[])
--
-- >>> unzipx (ZipX [(1, 'a')] ZipN) -- unzip a singleton list with no suffixes
-- ([1],"a")
--
-- >>> unzipx (ZipX [] (ZipA (NonEmptyList 1 [2,3]))) -- unzip an empty list with a left suffix
-- ([1,2,3],[])
-- 
-- >>> unzipx (ZipX [] (ZipB (NonEmptyList 'a' ['b','c']))) -- unzip an empty list with a right suffix
-- ([],"abc")
--
-- >>> unzipx (ZipX [(1, 'a')] (ZipA (NonEmptyList 2 [3,4]))) -- unzip a singleton list with a left suffix
-- ([1,2,3,4],"a")
--
-- >>> unzipx (ZipX [(1, 'a')] (ZipB (NonEmptyList 'b' ['c','d']))) -- unzip a singleton list with a right suffix
-- ([1],"abcd")
-- 
-- >>> unzipx (ZipX [(1, 'a'), (2, 'b'), (3, 'c'), (4, 'd')] ZipN) -- unzip a substantial list (4) with no suffixes
-- ([1,2,3,4],"abcd")
--
-- >>> unzipx (ZipX [(1, 'a'), (2, 'b'), (3, 'c'), (4, 'd')] (ZipA (NonEmptyList 5 [6,7]))) -- unzip a substantial list (4) with a right suffix
-- ([1,2,3,4,5,6,7],"abcd")
--
-- >>> unzipx (ZipX [(1, 'a'), (2, 'b'), (3, 'c'), (4, 'd')] (ZipB (NonEmptyList 'e' ['f','g']))) -- unzip a substantial list (4) with a left suffix
-- ([1,2,3,4],"abcdefg")
--
-- zipx is an inverse for unzipx
-- prop> uncurry zipx (unzipx z) == (z :: ZipX Int Int)
unzipx ::
  ZipX a b
  -> ([a], [b])
unzipx (ZipX z r) =
  let (as, bs) = unzip z
  in case r of
       ZipN -> (as, bs)
       ZipA ar -> (as ++ toList ar, bs)
       ZipB br -> (as, bs ++ toList br)

-- utility for Show instances  
comma ::
  (a -> String)
  -> [a]
  -> String
comma f = 
  intercalate "," . map f