{-# LANGUAGE GADTs #-}

-- | This module provides the 'Container' type, which wraps monomorphic types,
-- and makes them conform to the "Prelude"'s non-monomorphic typeclasses.
module Data.MonoTraversable.Container where

import           Data.Foldable
import           Data.MonoTraversable

import           Text.Read

-- | This type can wrap a monomorphic  type to allow it to conform to
-- 'Foldable'. For instance, the wrapper for 'Data.Text.Text' would be
-- defined as:
--
-- @type FoldableText = 'Container' 'Text' 'Char'@
--
-- Now, this type conforms to 'Foldable'.
data Container xs a b where
        -- | Can only construct when last type variable is equal to second.
        Container :: (a ~ b) => xs -> Container xs a b

-- | Selector for 'Container'
getContainer :: Container xs a b -> xs
getContainer (Container xs) = xs
{-# INLINE getContainer #-}

instance Eq xs => Eq (Container xs a b) where
  Container x == Container y = x == y
  {-# INLINE (==) #-}

instance Ord xs => Ord (Container xs a b) where
  compare (Container x) (Container y) = compare x y
  {-# INLINE compare #-}
  Container x < Container y = x < y
  {-# INLINE (<) #-}
  Container x >= Container y = x >= y
  {-# INLINE (>=) #-}
  Container x > Container y = x > y
  {-# INLINE (>) #-}
  Container x <= Container y = x <= y
  {-# INLINE (<=) #-}
  max (Container x) (Container y) = Container (max x y)
  {-# INLINE max #-}
  min (Container x) (Container y) = Container (min x y)
  {-# INLINE min #-}

instance Show xs => Show (Container xs a b) where
  showsPrec d (Container a) =
    showParen (d >= 11)
      $ showString "Container "
      . showsPrec 11 a

instance (Read xs, a ~ b) => Read (Container xs a b) where
  readPrec = parens $ prec 10 $ do
    Ident "Container" <- lexP
    Container <$> step (readS_to_Prec readsPrec)

instance (MonoFoldable xs, element ~ Element xs) =>
         Foldable (Container xs element) where
    foldr f b (Container xs) = ofoldr f b xs
    {-# INLINE foldr #-}
    foldMap f (Container xs) = ofoldMap f xs
    {-# INLINE foldMap #-}
    foldl' f b (Container xs) = ofoldl' f b xs
    {-# INLINE foldl' #-}
    toList (Container xs) = otoList xs
    {-# INLINE toList #-}
    null (Container xs) = onull xs
    {-# INLINE null #-}
    length (Container xs) = olength xs
    {-# INLINE length #-}
    foldr1 f (Container xs) = ofoldr1Ex f xs
    {-# INLINE foldr1 #-}
    elem x (Container xs) = oelem x xs
    {-# INLINE elem #-}
    maximum (Container xs) = maximumEx xs
    {-# INLINE maximum #-}
    minimum (Container xs) = minimumEx xs
    {-# INLINE minimum #-}
    sum (Container xs) = osum xs
    {-# INLINE sum #-}
    product (Container xs) = oproduct xs
    {-# INLINE product #-}