Internal.hs

{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DeriveFoldable      #-}
{-# LANGUAGE DeriveFunctor       #-}
{-# LANGUAGE DeriveTraversable   #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE InstanceSigs        #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Data.RAList.Internal (
    RAList (..),
    -- * Showing
    explicitShow,
    explicitShowsPrec,
    -- * Construction
    empty,
    singleton,
    cons,
    -- * Indexing
    (!),
    (!?),
    length,
    null,
    -- * Conversions
    toList,
    fromList,
    -- * Folding
    ifoldMap,
    -- * Mapping
    adjust,
    map,
    imap,
    itraverse,
    ) where

import Prelude
       (Bool (..), Eq, Functor (..), Int, Maybe (..), Ord (..), Show (..),
       ShowS, String, showParen, showString, ($), (.))

import Control.Applicative (Applicative (..), (<$>))
import Control.DeepSeq     (NFData (..))
import Control.Exception   (ArrayException (IndexOutOfBounds), throw)
import Data.Hashable       (Hashable (..))
import Data.List.NonEmpty  (NonEmpty (..))
import Data.Monoid         (Monoid (..))
import Data.Semigroup      (Semigroup (..))

import qualified Data.Foldable    as I (Foldable (..))
import qualified Data.Traversable as I (Traversable (..))
import qualified Test.QuickCheck  as QC

import qualified Data.RAList.NonEmpty.Internal as NE

-- $setup
-- >>> import Data.Char (toUpper)

-------------------------------------------------------------------------------
-- Type
-------------------------------------------------------------------------------

-- | Random access list.
data RAList a
    = Empty
    | NonEmpty (NE.NERAList a)
  deriving (Eq, Ord, Functor, I.Traversable)

-------------------------------------------------------------------------------
-- Instances
-------------------------------------------------------------------------------

-- |
--
-- >>> I.length $ fromList $ ['a' .. 'z']
-- 26
--
instance I.Foldable RAList where
    foldMap _ Empty = mempty
    foldMap f (NonEmpty xs) = I.foldMap f xs

#if MIN_VERSION_base(4,8,0)
    length = length
    null   = null
#endif

instance NFData a => NFData (RAList a) where
    rnf Empty         = ()
    rnf (NonEmpty xs) = rnf xs

instance Hashable a => Hashable (RAList a) where
    hashWithSalt salt Empty        = hashWithSalt salt (0 :: Int)
    hashWithSalt salt (NonEmpty r) = hashWithSalt salt r


-- |
--
-- >>> fromList "abc" <> fromList "xyz"
-- fromList "abcxyz"
--
instance Semigroup (RAList a) where
    Empty       <> ys          = ys
    xs          <> Empty       = xs
    NonEmpty xs <> NonEmpty ys = NonEmpty (xs <> ys)

instance Monoid (RAList a) where
    mempty  = Empty
    mappend = (<>)

-- TODO: Applicative, Monad

#ifdef MIN_VERSION_semigroupoids
-- Apply, Bind
#endif

-------------------------------------------------------------------------------
-- Showing
-------------------------------------------------------------------------------

instance Show a => Show (RAList a) where
    showsPrec d xs = showParen (d > 10) $ showString "fromList " . showsPrec 11 (toList xs)

explicitShow :: Show a => RAList a -> String
explicitShow xs = explicitShowsPrec 0 xs ""

explicitShowsPrec :: Show a => Int -> RAList a -> ShowS
explicitShowsPrec _ Empty         = showString "Empty"
explicitShowsPrec d (NonEmpty xs) = showParen (d > 10) $ showString "NonEmpty " . NE.explicitShowsPrec 11 xs

-------------------------------------------------------------------------------
-- Construction
-------------------------------------------------------------------------------

-- | Empty 'RAList'.
--
-- >>> empty :: RAList Int
-- fromList []
--
empty :: RAList a
empty = Empty

-- | Single element 'RAList'.
singleton :: a -> RAList a
singleton = NonEmpty . NE.singleton

-- | 'cons' for non-empty rals.
cons :: a -> RAList a -> RAList a
cons x Empty         = singleton x
cons x (NonEmpty xs) = NonEmpty (NE.cons x xs)

toList :: RAList a -> [a]
toList Empty         = []
toList (NonEmpty xs) = I.foldr (:) [] xs

-- |
--
-- >>> fromList ['a' .. 'f']
-- fromList "abcdef"
--
-- >>> explicitShow $ fromList ['a' .. 'f']
-- "NonEmpty (NE (Cons0 (Cons1 (Nd (Lf 'a') (Lf 'b')) (Last (Nd (Nd (Lf 'c') (Lf 'd')) (Nd (Lf 'e') (Lf 'f')))))))"
--
fromList :: [a] -> RAList a
fromList []     = Empty
fromList (x:xs) = NonEmpty (NE.fromNonEmpty (x :| xs))

-------------------------------------------------------------------------------
-- Indexing
-------------------------------------------------------------------------------

-- | List index.
--
--- >>> fromList ['a'..'f'] ! 0
-- 'a'
--
-- >>> fromList ['a'..'f'] ! 5
-- 'f'
--
-- >>> fromList ['a'..'f'] ! 6
-- *** Exception: array index out of range: RAList
-- ...
--
(!) :: RAList a -> Int -> a
(!) Empty         _ = throw $ IndexOutOfBounds "RAList"
(!) (NonEmpty xs) i = xs NE.! i

-- | safe list index.
--
-- >>> fromList ['a'..'f'] !? 0
-- Just 'a'
--
-- >>> fromList ['a'..'f'] !? 5
-- Just 'f'
--
-- >>> fromList ['a'..'f'] !? 6
-- Nothing
--
(!?) :: RAList a -> Int -> Maybe a
Empty       !? _ = Nothing
NonEmpty xs !? i = xs NE.!? i

length :: RAList a -> Int
length Empty         = 0
length (NonEmpty xs) = NE.length xs

null :: RAList a -> Bool
null Empty        = True
null (NonEmpty _) = False

-------------------------------------------------------------------------------
-- Folds
-------------------------------------------------------------------------------

ifoldMap :: Monoid m => (Int -> a -> m) -> RAList a -> m
ifoldMap _ Empty        = mempty
ifoldMap f (NonEmpty r) = NE.ifoldMap f r

-------------------------------------------------------------------------------
-- Mapping
-------------------------------------------------------------------------------

-- |
-- >>> map toUpper (fromList ['a'..'f'])
-- fromList "ABCDEF"
--
map :: (a -> b) -> RAList a -> RAList b
map = fmap

-- |
--
-- >>> imap (,) $ fromList ['a' .. 'f']
-- fromList [(0,'a'),(1,'b'),(2,'c'),(3,'d'),(4,'e'),(5,'f')]
imap :: (Int -> a -> b) -> RAList a -> RAList b
imap f xs = unI (itraverse (\i x -> I (f i x)) xs)

itraverse :: forall f a b. Applicative f => (Int -> a -> f b) -> RAList a -> f (RAList b)
itraverse _ Empty         = pure Empty
itraverse f (NonEmpty xs) = NonEmpty <$> NE.itraverse f xs

-- | Adjust a value in the list.
--
-- >>> adjust 3 toUpper $ fromList "bcdef"
-- fromList "bcdEf"
--
-- If index is out of bounds, the list is returned unmodified.
--
-- >>> adjust 10 toUpper $ fromList "bcdef"
-- fromList "bcdef"
--
-- >>> adjust (-1) toUpper $ fromList "bcdef"
-- fromList "bcdef"
--
adjust :: forall a. Int -> (a -> a) -> RAList a -> RAList a
adjust _ _ Empty         = Empty
adjust i f (NonEmpty xs) = NonEmpty (NE.adjust i f xs)

-------------------------------------------------------------------------------
-- QuickCheck
-------------------------------------------------------------------------------

instance QC.Arbitrary1 RAList where
    liftArbitrary = fmap fromList . QC.liftArbitrary
    liftShrink shr = fmap fromList . QC.liftShrink shr . toList

instance QC.Arbitrary a => QC.Arbitrary (RAList a) where
    arbitrary = QC.arbitrary1
    shrink    = QC.shrink1

instance QC.CoArbitrary a => QC.CoArbitrary (RAList a) where
    coarbitrary = QC.coarbitrary . toList

instance QC.Function a => QC.Function (RAList a) where
    function = QC.functionMap toList fromList

-------------------------------------------------------------------------------
-- Utilities
-------------------------------------------------------------------------------

newtype I a = I a
unI :: I a -> a
unI (I a) = a

instance Functor I where
    fmap f (I x) = I (f x)

instance Applicative I where
    pure        = I
    I f <*> I x = I (f x)
    _ *> x      = x
    x <* _      = x
#if MIN_VERSION_base(4,10,0)
    liftA2 f (I x) (I y) = I (f x y)
#endif