Class.hs

{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
module Data.Tup.Class where

--------------------------------------------------------------------------------

import Control.Applicative

import Data.Foldable    (Foldable)
import Data.Traversable (Traversable)

import qualified Data.Foldable    as Foldable
import qualified Data.Traversable as Traversable

import Data.List
import Data.Proxy

--------------------------------------------------------------------------------
-- * the Tup class

class (Functor f, Applicative f, Foldable f, Traversable f) => Tup f where

  tupSize      :: f a -> Int         -- ^ equivalent to @length . tupToList@
  tupToList    :: f a -> [a]         -- ^ equivalent to @Foldable.toList@
  tupFromList  :: [a] -> f a  

  tupProxy     :: f a -> Proxy a
  tupUndef     :: f a -> a           -- ^ poor man\'s version of 'tupProxy'

  constantTup  :: a -> f a  
  undefinedTup :: f a                -- ^ when possible \/ makes sense, you can still pattern-patch on the constructor 

  tupSize      = Foldable.foldl (\c _ -> c+1) 0 
  tupToList    = Foldable.toList
  tupFromList  = \ys -> snd $ Traversable.mapAccumL (\(x:xs) _ -> (xs,x)) ys (pure undefined)

  tupUndef _   = undefined
  tupProxy _   = Proxy

  constantTup  = pure
  undefinedTup = pure undefined

{-
-- | temporary, for testing
testTupFromList :: (Applicative f, Traversable f) => [a] -> f a
testTupFromList ys = snd $ Traversable.mapAccumL (\(x:xs) _ -> (xs,x)) ys (pure undefined)
-}

--------------------------------------------------------------------------------
-- * Misc 

-- | Safe version of 'tupFromList'.
maybeTupFromList :: Tup f => [a] -> Maybe (f a)
maybeTupFromList xs = result where
  result = if length xs == tupSize (undef result) 
    then Just (tupFromList xs)
    else Nothing    
  undef :: Maybe a -> a
  undef _ = undefined

-- | Transpose a Tup of Tups.
transposeTup :: (Tup f, Tup g) => f (g a) -> g (f a)
transposeTup = tupFromList . (map tupFromList) . transpose . (map tupToList) . tupToList

--------------------------------------------------------------------------------
-- * Concatenation

-- | Safe concatenation (going through lists)
maybeTupConcat :: (Tup f, Tup g, Tup h) => f a -> g a -> Maybe (h a)
maybeTupConcat x y = 
  if tupSize x + tupSize y == tupSize z 
    then Just z
    else Nothing  
  where
    z = tupFromList (tupToList x ++ tupToList y)

-- | Unsafe concatenation
unsafeTupConcat :: (Tup f, Tup g, Tup h) => f a -> g a -> h a
unsafeTupConcat x y = z
  where
    z = tupFromList (tupToList x ++ tupToList y)

--------------------------------------------------------------------------------
-- * Conversion

-- | Safe conversion between different Tup implementations
maybeConvertTup ::  (Tup f, Tup g) => f a -> Maybe (g a)
maybeConvertTup x =
  if tupSize x == tupSize y 
    then Just y
    else Nothing  
  where
    y = tupFromList (tupToList x)

-- | Unsafe conversion
unsafeConvertTup :: (Tup f, Tup g) => f a -> g a
unsafeConvertTup x = tupFromList (tupToList x)

--------------------------------------------------------------------------------
-- * zipping (only using the Applicative structure)

zipTupWith :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
zipTupWith f t1 t2 = f <$> t1 <*> t2

zipTupWith3 :: Applicative f => (a -> b -> c -> d) -> f a -> f b -> f c -> f d
zipTupWith3 f t1 t2 t3 = f <$> t1 <*> t2 <*> t3

zipTupWith4 :: Applicative f => (a -> b -> c -> d -> e) -> f a -> f b -> f c -> f d -> f e
zipTupWith4 f t1 t2 t3 t4 = f <$> t1 <*> t2 <*> t3 <*> t4

zipTup :: Applicative f => f a -> f b -> f (a,b)
zipTup t1 t2 = (,) <$> t1 <*> t2

zipTup3 :: Applicative f => f a -> f b -> f c -> f (a,b,c)
zipTup3 t1 t2 t3 = (,,) <$> t1 <*> t2 <*> t3

zipTup4 :: Applicative f => f a -> f b -> f c -> f d -> f (a,b,c,d)
zipTup4 t1 t2 t3 t4 = (,,,) <$> t1 <*> t2 <*> t3 <*> t4

--------------------------------------------------------------------------------