content: -- |
  --   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,foldl',
                         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(), runFail_)
  import qualified Data.Edison.Seq as S
  import Data.Edison.Seq.Defaults
  import qualified Control.Monad.Fail as Fail
  import Control.Monad
  import Data.Monoid
  import Data.Semigroup as SG
  import Test.QuickCheck
  
  #ifdef __GLASGOW_HASKELL__
  import GHC.Exts (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          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
  lhead          :: Seq a -> a
  lheadM         :: (Fail.MonadFail m) => Seq a -> m a
  ltail          :: Seq a -> Seq a
  ltailM         :: (Fail.MonadFail m) => Seq a -> m (Seq a)
  rview          :: (Fail.MonadFail m) => Seq a -> m (a, Seq a)
  rhead          :: Seq a -> a
  rheadM         :: (Fail.MonadFail m) => Seq a -> m a
  rtail          :: Seq a -> Seq a
  rtailM         :: (Fail.MonadFail 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        :: (Fail.MonadFail 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 = runFail_ . lheadM
  ltail = runFail_ . ltailM
  rhead = runFail_ . rheadM
  rtail = runFail_ . 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.<>)
  