{-# LANGUAGE CPP #-}
{-# LANGUAGE UndecidableInstances, GADTs,TypeSynonymInstances,FlexibleInstances,Rank2Types #-}
{-# LANGUAGE StandaloneDeriving #-}



-----------------------------------------------------------------------------
-- |
-- Module      :  Data.SequenceClass
-- Copyright   :  (c) Atze van der Ploeg 2014
-- License     :  BSD-style
-- Maintainer  :  atzeus@gmail.org
-- Stability   :  provisional
-- Portability :  portable
-- A type class for sequences.
--
-- See the package type-aligned for a generalization of this type class sequences.
-- 
-----------------------------------------------------------------------------
module Data.SequenceClass(Sequence(..), ViewL(..), ViewR(..)) where

import Data.Monoid
import Data.Foldable (foldl')
import qualified Data.Foldable as F
import qualified Data.Sequence as S

infixr 5 <|
infixl 5 |>
infix 5 ><
infixl 9 :<
infixr 9 :>
{- | A type class for (finite) sequences
 

Instances should be /free monoids/
(<http://comonad.com/reader/2015/free-monoids-in-haskell/ ignoring issues with infinite and partially defined structures>),
just like lists, with @singleton@ as the canonical injection and @foldMap@
factoring functions.  In particular, they should satisfy the following laws:

@Semigroup@ and @Monoid@ laws:

> (><) == (Data.Semigroup.<>)
> empty == mempty

In particular, this requires that

> empty >< x == x
> x >< empty == x
> (x >< y) >< z = x >< (y >< z)

@FoldMap@/@singleton@ laws:

For any 'Monoid' @m@ and any function @f :: c -> m@,

1. @'foldMap' f@ is a monoid morphism:

    * @'foldMap' f 'mempty' = 'mempty'@
    * @'foldMap' f (m '<>' n) = 'foldMap' f m <> 'foldMap' f n@

2. 'foldMap' undoes 'singleton':

    @'foldMap' f . 'singleton' = f@

Observation laws:

> viewl (singleton e >< s) == e :< s
> viewl empty == EmptyL

The behaviour of '<|','|>', and 'viewr' is implied by the above laws and their
default definitions.

Warning: the default definitions are typically awful. Check them carefully
before relying on them. In particular, they may well work in @O(n^2)@ time (or
worse?) when even definitions that convert to and from lists would work in
@O(n)@ time. Exceptions: for sequences with constant time concatenation, the
defaults for '<|' and '|>' are okay. For sequences with constant time '|>',
the default for 'fromList' is okay.
-}
class (F.Foldable s, Functor s) => Sequence s where

  {-# MINIMAL
    empty,
    singleton,
    (viewl | viewr),
    ((><) | (|>) | (<|))
    #-}

  empty     :: s c 
  singleton :: c  -> s c 
  -- | Append two sequences
  (><)       :: s c  -> s c   -> s c 
  -- | View a sequence from the left
  viewl     :: s c  -> ViewL s c 
  -- | View a sequence from the right
  --          
  -- Default definition:
  --
  -- > viewr q = case viewl q of 
  -- >    EmptyL -> EmptyR
  -- >    h :< t -> case viewr t of
  -- >        EmptyR -> empty   :> h
  -- >        p :> l   -> (h <| p) :> l
  --
  viewr     :: s c -> ViewR s c 
  -- | Append a single element to the right
  -- 
  -- Default definition:
  --
  -- > l |> r = l >< singleton r
  -- 
  (|>)       :: s c -> c  -> s c 
  -- | Append a single element to the left
  -- 
  -- Default definition:
  --
  -- > l <| r = singleton l >< r
  --
  (<|)       :: c  -> s c -> s c
  
  -- | Convert a list to a sequence
  --
  -- Default definition:
  --
  -- > fromList = foldl' (|>) empty
  fromList :: [c] -> s c

  s c
l |> c
r = s c
l s c -> s c -> s c
forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
>< c -> s c
forall (s :: * -> *) c. Sequence s => c -> s c
singleton c
r
  c
l <| s c
r = c -> s c
forall (s :: * -> *) c. Sequence s => c -> s c
singleton c
l s c -> s c -> s c
forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
>< s c
r
  s c
l >< s c
r = case s c -> ViewL s c
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl s c
l of
    ViewL s c
EmptyL -> s c
r
    c
h :< s c
t  -> c
h c -> s c -> s c
forall (s :: * -> *) c. Sequence s => c -> s c -> s c
<| (s c
t s c -> s c -> s c
forall (s :: * -> *) c. Sequence s => s c -> s c -> s c
>< s c
r)

  viewl s c
q = case s c -> ViewR s c
forall (s :: * -> *) c. Sequence s => s c -> ViewR s c
viewr s c
q of 
    ViewR s c
EmptyR -> ViewL s c
forall (s :: * -> *) c. ViewL s c
EmptyL
    s c
p :> c
l -> case s c -> ViewL s c
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl s c
p of
        ViewL s c
EmptyL -> c
l c -> s c -> ViewL s c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< s c
forall (s :: * -> *) c. Sequence s => s c
empty
        c
h :< s c
t   -> c
h c -> s c -> ViewL s c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< (s c
t s c -> c -> s c
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
|> c
l)

  viewr s c
q = case s c -> ViewL s c
forall (s :: * -> *) c. Sequence s => s c -> ViewL s c
viewl s c
q of 
    ViewL s c
EmptyL -> ViewR s c
forall (s :: * -> *) c. ViewR s c
EmptyR
    c
h :< s c
t -> case s c -> ViewR s c
forall (s :: * -> *) c. Sequence s => s c -> ViewR s c
viewr s c
t of
        ViewR s c
EmptyR -> s c
forall (s :: * -> *) c. Sequence s => s c
empty   s c -> c -> ViewR s c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
h
        s c
p :> c
l   -> (c
h c -> s c -> s c
forall (s :: * -> *) c. Sequence s => c -> s c -> s c
<| s c
p) s c -> c -> ViewR s c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
l

  fromList = (s c -> c -> s c) -> s c -> [c] -> s c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' s c -> c -> s c
forall (s :: * -> *) c. Sequence s => s c -> c -> s c
(|>) s c
forall (s :: * -> *) c. Sequence s => s c
empty

-- | A view of the left end of a 'Sequence'.
data ViewL s c where
   EmptyL  :: ViewL s c 
   (:<)    :: c -> s c -> ViewL s c

deriving instance (Show c, Show (s c)) => Show (ViewL s c)

-- | A view of the right end of a 'Sequence'.
data ViewR s c where
   EmptyR  :: ViewR s c 
   (:>)    :: s c -> c -> ViewR s c

deriving instance (Show c, Show (s c)) => Show (ViewR s c)

 
instance Sequence S.Seq where
 empty :: Seq c
empty = Seq c
forall c. Seq c
S.empty
 singleton :: c -> Seq c
singleton = c -> Seq c
forall c. c -> Seq c
S.singleton
 <| :: c -> Seq c -> Seq c
(<|) = c -> Seq c -> Seq c
forall c. c -> Seq c -> Seq c
(S.<|)
 |> :: Seq c -> c -> Seq c
(|>) = Seq c -> c -> Seq c
forall c. Seq c -> c -> Seq c
(S.|>)
 >< :: Seq c -> Seq c -> Seq c
(><) = Seq c -> Seq c -> Seq c
forall c. Seq c -> Seq c -> Seq c
(S.><)
 viewl :: Seq c -> ViewL Seq c
viewl Seq c
s = case Seq c -> ViewL c
forall a. Seq a -> ViewL a
S.viewl Seq c
s of
   ViewL c
S.EmptyL -> ViewL Seq c
forall (s :: * -> *) c. ViewL s c
EmptyL
   c
h S.:< Seq c
t -> c
h c -> Seq c -> ViewL Seq c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< Seq c
t
 viewr :: Seq c -> ViewR Seq c
viewr Seq c
s = case Seq c -> ViewR c
forall a. Seq a -> ViewR a
S.viewr Seq c
s of
   ViewR c
S.EmptyR -> ViewR Seq c
forall (s :: * -> *) c. ViewR s c
EmptyR
   Seq c
t S.:> c
h -> Seq c
t Seq c -> c -> ViewR Seq c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
h
 fromList :: [c] -> Seq c
fromList = [c] -> Seq c
forall c. [c] -> Seq c
S.fromList

instance Sequence [] where
  empty :: [c]
empty = []
  singleton :: c -> [c]
singleton c
x = [c
x]
  <| :: c -> [c] -> [c]
(<|) = (:)
  [c]
xs |> :: [c] -> c -> [c]
|> c
x = [c]
xs [c] -> [c] -> [c]
forall c. [c] -> [c] -> [c]
++ [c
x]
  >< :: [c] -> [c] -> [c]
(><) = [c] -> [c] -> [c]
forall c. [c] -> [c] -> [c]
(++)
  viewl :: [c] -> ViewL [] c
viewl [] = ViewL [] c
forall (s :: * -> *) c. ViewL s c
EmptyL
  viewl (c
h : [c]
t) = c
h c -> [c] -> ViewL [] c
forall c (s :: * -> *). c -> s c -> ViewL s c
:< [c]
t 

  -- This definition is entirely strict. I'm not sure whether there's
  -- a real benefit to making it lazy or not.
  -- NOTE: if we *do* make it lazy, then the definition of viewr
  -- for FastQueue will have to be adjusted to keep its bounds
  -- worst case.
  viewr :: [c] -> ViewR [] c
viewr [] = ViewR [] c
forall (s :: * -> *) c. ViewR s c
EmptyR
  viewr (c
x : [c]
xs) = case c -> [c] -> ([c], c)
forall t. t -> [t] -> ([t], t)
go c
x [c]
xs of ([c]
start, c
end) -> [c]
start [c] -> c -> ViewR [] c
forall (s :: * -> *) c. s c -> c -> ViewR s c
:> c
end
    where
      go :: t -> [t] -> ([t], t)
go t
y [] = ([], t
y)
      go t
y (t
z : [t]
zs) = case t -> [t] -> ([t], t)
go t
z [t]
zs of ([t]
start, t
end) -> (t
y t -> [t] -> [t]
forall c. c -> [c] -> [c]
: [t]
start, t
end)
  fromList :: [c] -> [c]
fromList = [c] -> [c]
forall a. a -> a
id