-- |
--   Module      :  Data.Edison.Seq.FingerSeq
--   Copyright   :  Copyright (c) 2006, 2008 Robert Dockins
--   License     :  MIT; see COPYRIGHT file for terms and conditions
--
--   Maintainer  :  robdockins AT fastmail DOT fm
--   Stability   :  stable
--   Portability :  GHC, Hugs (MPTC and FD)


module Data.Edison.Seq.FingerSeq (
    -- * Sequence Type
    Seq, -- instance of Sequence, Functor, Monad, MonadPlus

    -- * Sequence Operations
    empty,singleton,lcons,rcons,append,lview,lhead,ltail,rview,rhead,rtail,
    lheadM,ltailM,rheadM,rtailM,
    null,size,concat,reverse,reverseOnto,fromList,toList,map,concatMap,
    fold,fold',fold1,fold1',foldr,foldr',foldl,foldl',foldr1,foldr1',foldl1,foldl1',
    reducer,reducer',reducel,reducel',reduce1,reduce1',
    copy,inBounds,lookup,lookupM,lookupWithDefault,update,adjust,
    mapWithIndex,foldrWithIndex,foldlWithIndex,
    take,drop,splitAt,subseq,filter,partition,takeWhile,dropWhile,splitWhile,
    zip,zip3,zipWith,zipWith3,unzip,unzip3,unzipWith,unzipWith3,
    strict, strictWith,

    -- * Unit testing
    structuralInvariant,

    -- * Documentation
    moduleName
) where

import qualified Prelude
import Prelude hiding (concat,reverse,map,concatMap,foldr,foldl,foldr1,foldl1,
                       filter,takeWhile,dropWhile,lookup,take,drop,splitAt,
                       zip,zip3,zipWith,zipWith3,unzip,unzip3,null)

import qualified Control.Applicative as App
import Data.Edison.Prelude (measure, Measured())
import qualified Data.Edison.Seq as S
import Data.Edison.Seq.Defaults
import Control.Monad.Identity
import Data.Monoid
import Data.Semigroup as SG
import Test.QuickCheck

#ifdef __GLASGOW_HASKELL__
import GHC.Base (unsafeCoerce#)
#endif


import qualified Data.Edison.Concrete.FingerTree as FT

moduleName     :: String
moduleName = "Data.Edison.Seq.FingerSeq"


newtype SizeM = SizeM Int deriving (Eq,Ord,Num,Enum,Show)

unSizeM :: SizeM -> Int
unSizeM (SizeM x) = x

instance Semigroup SizeM where
   (<>) = (+)
instance Monoid SizeM where
   mempty  = 0
   mappend = (SG.<>)

newtype Elem a = Elem a

unElem :: Elem t -> t
unElem (Elem x) = x

instance Measured SizeM (Elem a) where
   measure _ = 1

newtype Seq a = Seq (FT.FingerTree SizeM (Elem a))

unSeq :: Seq t -> FT.FingerTree SizeM (Elem t)
unSeq (Seq ft) = ft



empty          :: Seq a
singleton      :: a -> Seq a
lcons          :: a -> Seq a -> Seq a
rcons          :: a -> Seq a -> Seq a
append         :: Seq a -> Seq a -> Seq a
lview          :: (Monad m) => Seq a -> m (a, Seq a)
lhead          :: Seq a -> a
lheadM         :: (Monad m) => Seq a -> m a
ltail          :: Seq a -> Seq a
ltailM         :: (Monad m) => Seq a -> m (Seq a)
rview          :: (Monad m) => Seq a -> m (a, Seq a)
rhead          :: Seq a -> a
rheadM         :: (Monad m) => Seq a -> m a
rtail          :: Seq a -> Seq a
rtailM         :: (Monad m) => Seq a -> m (Seq a)
null           :: Seq a -> Bool
size           :: Seq a -> Int
concat         :: Seq (Seq a) -> Seq a
reverse        :: Seq a -> Seq a
reverseOnto    :: Seq a -> Seq a -> Seq a
fromList       :: [a] -> Seq a
toList         :: Seq a -> [a]
map            :: (a -> b) -> Seq a -> Seq b
concatMap      :: (a -> Seq b) -> Seq a -> Seq b
fold           :: (a -> b -> b) -> b -> Seq a -> b
fold'          :: (a -> b -> b) -> b -> Seq a -> b
fold1          :: (a -> a -> a) -> Seq a -> a
fold1'         :: (a -> a -> a) -> Seq a -> a
foldr          :: (a -> b -> b) -> b -> Seq a -> b
foldl          :: (b -> a -> b) -> b -> Seq a -> b
foldr1         :: (a -> a -> a) -> Seq a -> a
foldl1         :: (a -> a -> a) -> Seq a -> a
reducer        :: (a -> a -> a) -> a -> Seq a -> a
reducel        :: (a -> a -> a) -> a -> Seq a -> a
reduce1        :: (a -> a -> a) -> Seq a -> a
foldr'         :: (a -> b -> b) -> b -> Seq a -> b
foldl'         :: (b -> a -> b) -> b -> Seq a -> b
foldr1'        :: (a -> a -> a) -> Seq a -> a
foldl1'        :: (a -> a -> a) -> Seq a -> a
reducer'       :: (a -> a -> a) -> a -> Seq a -> a
reducel'       :: (a -> a -> a) -> a -> Seq a -> a
reduce1'       :: (a -> a -> a) -> Seq a -> a
copy           :: Int -> a -> Seq a
inBounds       :: Int -> Seq a -> Bool
lookup         :: Int -> Seq a -> a
lookupM        :: (Monad m) => Int -> Seq a -> m a
lookupWithDefault :: a -> Int -> Seq a -> a
update         :: Int -> a -> Seq a -> Seq a
adjust         :: (a -> a) -> Int -> Seq a -> Seq a
mapWithIndex   :: (Int -> a -> b) -> Seq a -> Seq b
foldrWithIndex :: (Int -> a -> b -> b) -> b -> Seq a -> b
foldlWithIndex :: (b -> Int -> a -> b) -> b -> Seq a -> b
foldrWithIndex' :: (Int -> a -> b -> b) -> b -> Seq a -> b
foldlWithIndex' :: (b -> Int -> a -> b) -> b -> Seq a -> b
take           :: Int -> Seq a -> Seq a
drop           :: Int -> Seq a -> Seq a
splitAt        :: Int -> Seq a -> (Seq a, Seq a)
subseq         :: Int -> Int -> Seq a -> Seq a
filter         :: (a -> Bool) -> Seq a -> Seq a
partition      :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
takeWhile      :: (a -> Bool) -> Seq a -> Seq a
dropWhile      :: (a -> Bool) -> Seq a -> Seq a
splitWhile     :: (a -> Bool) -> Seq a -> (Seq a, Seq a)
zip            :: Seq a -> Seq b -> Seq (a,b)
zip3           :: Seq a -> Seq b -> Seq c -> Seq (a,b,c)
zipWith        :: (a -> b -> c) -> Seq a -> Seq b -> Seq c
zipWith3       :: (a -> b -> c -> d) -> Seq a -> Seq b -> Seq c -> Seq d
unzip          :: Seq (a,b) -> (Seq a, Seq b)
unzip3         :: Seq (a,b,c) -> (Seq a, Seq b, Seq c)
unzipWith      :: (a -> b) -> (a -> c) -> Seq a -> (Seq b, Seq c)
unzipWith3     :: (a -> b) -> (a -> c) -> (a -> d) -> Seq a -> (Seq b, Seq c, Seq d)
strict         :: Seq a -> Seq a
strictWith     :: (a -> b) -> Seq a -> Seq a
structuralInvariant :: Seq a -> Bool

#ifdef __GLASGOW_HASKELL__

mapElem, mapUnElem :: t -> b
mapElem   = unsafeCoerce#
mapUnElem = unsafeCoerce#

#else

mapElem   = Prelude.map Elem
mapUnElem = Prelude.map unElem

#endif

null         = FT.null . unSeq
empty        = Seq FT.empty
singleton    = Seq . FT.singleton . Elem
lcons x      = Seq . FT.lcons (Elem x) . unSeq
rcons x      = Seq . FT.rcons (Elem x) . unSeq
append p q   = Seq $ FT.append (unSeq p) (unSeq q)
fromList     = Seq . FT.fromList . mapElem
toList       = mapUnElem . FT.toList . unSeq
reverse      = Seq . FT.reverse . unSeq
size         = unSizeM . measure . unSeq
strict       = Seq . FT.strict . unSeq
strictWith f = Seq . FT.strictWith (f . unElem) . unSeq
structuralInvariant = FT.structuralInvariant . unSeq

#ifdef __GLASGOW_HASKELL__

lview (Seq xs) =
  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)
  in  f (FT.lview xs)

rview (Seq xs) =
  let f = unsafeCoerce# :: Monad m => m (Elem a,FT.FingerTree SizeM (Elem a)) -> m (a,Seq a)
  in  f (FT.rview xs)

#else

lview (Seq xs) = FT.lview xs >>= \(Elem a, zs) -> return (a, Seq zs)
rview (Seq xs) = FT.rview xs >>= \(Elem a, zs) -> return (a, Seq zs)

#endif


lheadM xs = lview xs >>= return . fst
ltailM xs = lview xs >>= return . snd
rheadM xs = rview xs >>= return . fst
rtailM xs = rview xs >>= return . snd
lhead = runIdentity . lheadM
ltail = runIdentity . ltailM
rhead = runIdentity . rheadM
rtail = runIdentity . rtailM

fold     = foldr
fold'    = foldr'
fold1    = foldr1
fold1'   = foldr1'

#ifdef __GLASGOW_HASKELL__

foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)
foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) (unsafeCoerce# f) xs (Elem z)

reduce1  f (Seq xs) = unElem $ FT.reduce1  (unsafeCoerce# f) xs
reduce1' f (Seq xs) = unElem $ FT.reduce1' (unsafeCoerce# f) xs

map f (Seq xs) = Seq $ FT.mapTree (unsafeCoerce# f) xs

#else

foldr  f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)
foldr' f z (Seq xs) = unElem $ FT.foldFT id (.) ( \(Elem x) (Elem y) -> Elem $ f x y) xs (Elem z)

reduce1  f (Seq xs) = unElem $ FT.reduce1  ( \(Elem x) (Elem y) -> Elem $ f x y) xs
reduce1' f (Seq xs) = unElem $ FT.reduce1' ( \(Elem x) (Elem y) -> Elem $ f x y) xs

map f (Seq xs) = Seq $ FT.mapTree ( \(Elem x) -> Elem $ f x) xs

#endif

lookupM i (Seq xs)
    | inBounds i (Seq xs) =
        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
           FT.Split _ (Elem x) _ -> return x

    | otherwise = fail "FingerSeq.lookupM: index out of bounds"

lookupWithDefault d i (Seq xs)
    | inBounds i (Seq xs) =
        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
           FT.Split _ (Elem x) _ -> x

    | otherwise = d

update i x (Seq xs)
    | inBounds i (Seq xs) =
        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
           FT.Split l _ r -> Seq $ FT.append l $ FT.lcons (Elem x) $ r

    | otherwise = Seq xs

adjust f i (Seq xs)
    | inBounds i (Seq xs) =
        case FT.splitTree (> (SizeM i)) (SizeM 0) xs of
           FT.Split l x r -> Seq $ FT.append l $ FT.lcons (Elem (f (unElem x))) $ r

    | otherwise = Seq xs

take i (Seq xs) = Seq $ FT.takeUntil (> (SizeM i)) xs
drop i (Seq xs) = Seq $ FT.dropUntil (> (SizeM i)) xs
splitAt i (Seq xs) = let (a,b) = FT.split (> (SizeM i)) xs in (Seq a, Seq b)


inBounds = inBoundsUsingSize
lookup   = lookupUsingLookupM

foldr1 f xs =
   case rview xs of
      Nothing      -> error "FingerSeq.foldr1: empty sequence"
      Just (x,xs') -> foldr f x xs'

foldr1' f xs =
   case rview xs of
      Nothing      -> error "FingerSeq.foldr1': empty sequence"
      Just (x,xs') -> foldr' f x xs'

foldl    = foldlUsingLists
foldl'   = foldl'UsingLists
foldl1   = foldl1UsingLists
foldl1'  = foldl1'UsingLists

reducer  = reducerUsingReduce1
reducer' = reducer'UsingReduce1'
reducel  = reducelUsingReduce1
reducel' = reducel'UsingReduce1'

copy        = copyUsingLists
concat      = concatUsingFoldr
reverseOnto = reverseOntoUsingReverse
concatMap   = concatMapUsingFoldr
subseq      = subseqDefault
filter      = filterUsingLview
partition   = partitionUsingFoldr
takeWhile   = takeWhileUsingLview
dropWhile   = dropWhileUsingLview
splitWhile  = splitWhileUsingLview

mapWithIndex    = mapWithIndexUsingLists
foldrWithIndex  = foldrWithIndexUsingLists
foldrWithIndex' = foldrWithIndex'UsingLists
foldlWithIndex  = foldlWithIndexUsingLists
foldlWithIndex' = foldlWithIndex'UsingLists

zip = zipUsingLview
zip3 = zip3UsingLview
zipWith = zipWithUsingLview
zipWith3 = zipWith3UsingLview

unzip = unzipUsingFoldr
unzip3 = unzip3UsingFoldr
unzipWith = unzipWithUsingFoldr
unzipWith3 = unzipWith3UsingFoldr

-- instances

instance S.Sequence Seq where
  {lcons = lcons; rcons = rcons;
   lview = lview; lhead = lhead; ltail = ltail;
   lheadM = lheadM; ltailM = ltailM; rheadM = rheadM; rtailM = rtailM;
   rview = rview; rhead = rhead; rtail = rtail; null = null;
   size = size; concat = concat; reverse = reverse;
   reverseOnto = reverseOnto; fromList = fromList; toList = toList;
   fold = fold; fold' = fold'; fold1 = fold1; fold1' = fold1';
   foldr = foldr; foldr' = foldr'; foldl = foldl; foldl' = foldl';
   foldr1 = foldr1; foldr1' = foldr1'; foldl1 = foldl1; foldl1' = foldl1';
   reducer = reducer; reducer' = reducer'; reducel = reducel;
   reducel' = reducel'; reduce1 = reduce1;  reduce1' = reduce1';
   copy = copy; inBounds = inBounds; lookup = lookup;
   lookupM = lookupM; lookupWithDefault = lookupWithDefault;
   update = update; adjust = adjust; mapWithIndex = mapWithIndex;
   foldrWithIndex = foldrWithIndex; foldlWithIndex = foldlWithIndex;
   foldrWithIndex' = foldrWithIndex'; foldlWithIndex' = foldlWithIndex';
   take = take; drop = drop; splitAt = splitAt; subseq = subseq;
   filter = filter; partition = partition; takeWhile = takeWhile;
   dropWhile = dropWhile; splitWhile = splitWhile; zip = zip;
   zip3 = zip3; zipWith = zipWith; zipWith3 = zipWith3; unzip = unzip;
   unzip3 = unzip3; unzipWith = unzipWith; unzipWith3 = unzipWith3;
   strict = strict; strictWith = strictWith;
   structuralInvariant = structuralInvariant; instanceName _ = moduleName}

instance Functor Seq where
  fmap = map

instance App.Alternative Seq where
  empty = empty
  (<|>) = append

instance App.Applicative Seq where
  pure = return
  x <*> y = do
     x' <- x
     y' <- y
     return (x' y')

instance Monad Seq where
  return = singleton
  xs >>= k = concatMap k xs

instance MonadPlus Seq where
  mplus = append
  mzero = empty

instance Eq a => Eq (Seq a) where
  xs == ys = toList xs == toList ys

instance Ord a => Ord (Seq a) where
  compare = defaultCompare

instance Show a => Show (Seq a) where
  showsPrec = showsPrecUsingToList

instance Read a => Read (Seq a) where
  readsPrec = readsPrecUsingFromList

instance Arbitrary a => Arbitrary (Elem a) where
   arbitrary   = arbitrary >>= return . Elem

instance CoArbitrary a => CoArbitrary (Elem a) where
   coarbitrary = coarbitrary . unElem

instance Arbitrary a => Arbitrary (Seq a) where
   arbitrary   = arbitrary >>= return . Seq

instance CoArbitrary a => CoArbitrary (Seq a) where
   coarbitrary = coarbitrary . unSeq

instance Semigroup (Seq a) where
  (<>) = append
instance Monoid (Seq a) where
  mempty  = empty
  mappend = (SG.<>)