{-# LANGUAGE CPP           #-}
{-# LANGUAGE DeriveFunctor #-}

module Data.List.Trace
  ( Trace (..)
  , ppTrace
  , toList
  , fromList
  , head
  , tail
  , filter
  , length
  ) where

import           Prelude hiding (filter, head, length, tail)

import           Control.Applicative (Alternative (..))
import           Control.Monad (MonadPlus (..))
import           Control.Monad.Fix (MonadFix (..), fix)
import           Data.Bifoldable
import           Data.Bifunctor
import           Data.Bitraversable
import           Data.Functor.Classes

-- | A 'cons' list with polymorphic 'nil'.
--
-- * @'Trace' Void a@ is an infinite stream
-- * @'Trace' () a@ is isomorphic to @[a]@
--
-- Usually used with @a@ being a non empty sum type.
--
data Trace a b
    = Cons b (Trace a b)
    | Nil a
    deriving (Int -> Trace a b -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. (Show b, Show a) => Int -> Trace a b -> ShowS
forall a b. (Show b, Show a) => [Trace a b] -> ShowS
forall a b. (Show b, Show a) => Trace a b -> String
showList :: [Trace a b] -> ShowS
$cshowList :: forall a b. (Show b, Show a) => [Trace a b] -> ShowS
show :: Trace a b -> String
$cshow :: forall a b. (Show b, Show a) => Trace a b -> String
showsPrec :: Int -> Trace a b -> ShowS
$cshowsPrec :: forall a b. (Show b, Show a) => Int -> Trace a b -> ShowS
Show, Trace a b -> Trace a b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. (Eq b, Eq a) => Trace a b -> Trace a b -> Bool
/= :: Trace a b -> Trace a b -> Bool
$c/= :: forall a b. (Eq b, Eq a) => Trace a b -> Trace a b -> Bool
== :: Trace a b -> Trace a b -> Bool
$c== :: forall a b. (Eq b, Eq a) => Trace a b -> Trace a b -> Bool
Eq, Trace a b -> Trace a b -> Bool
Trace a b -> Trace a b -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a} {b}. (Ord b, Ord a) => Eq (Trace a b)
forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Bool
forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Ordering
forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Trace a b
min :: Trace a b -> Trace a b -> Trace a b
$cmin :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Trace a b
max :: Trace a b -> Trace a b -> Trace a b
$cmax :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Trace a b
>= :: Trace a b -> Trace a b -> Bool
$c>= :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Bool
> :: Trace a b -> Trace a b -> Bool
$c> :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Bool
<= :: Trace a b -> Trace a b -> Bool
$c<= :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Bool
< :: Trace a b -> Trace a b -> Bool
$c< :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Bool
compare :: Trace a b -> Trace a b -> Ordering
$ccompare :: forall a b. (Ord b, Ord a) => Trace a b -> Trace a b -> Ordering
Ord, forall a b. a -> Trace a b -> Trace a a
forall a b. (a -> b) -> Trace a a -> Trace a b
forall a a b. a -> Trace a b -> Trace a a
forall a a b. (a -> b) -> Trace a a -> Trace a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Trace a b -> Trace a a
$c<$ :: forall a a b. a -> Trace a b -> Trace a a
fmap :: forall a b. (a -> b) -> Trace a a -> Trace a b
$cfmap :: forall a a b. (a -> b) -> Trace a a -> Trace a b
Functor)

head :: Trace a b -> b
head :: forall a b. Trace a b -> b
head (Cons b
b Trace a b
_) = b
b
head Trace a b
_          = forall a. HasCallStack => String -> a
error String
"Trace.head: empty"

tail :: Trace a b -> Trace a b
tail :: forall a b. Trace a b -> Trace a b
tail (Cons b
_ Trace a b
o) = Trace a b
o
tail Nil {}     = forall a. HasCallStack => String -> a
error String
"Trace.tail: empty"

filter :: (b -> Bool) -> Trace a b -> Trace a b
filter :: forall b a. (b -> Bool) -> Trace a b -> Trace a b
filter b -> Bool
_fn o :: Trace a b
o@Nil {}   = Trace a b
o
filter  b -> Bool
fn (Cons b
b Trace a b
o) =
    case b -> Bool
fn b
b of
      Bool
True  -> forall a b. b -> Trace a b -> Trace a b
Cons b
b (forall b a. (b -> Bool) -> Trace a b -> Trace a b
filter b -> Bool
fn Trace a b
o)
      Bool
False ->         forall b a. (b -> Bool) -> Trace a b -> Trace a b
filter b -> Bool
fn Trace a b
o

length :: Trace a b -> Int
length :: forall a b. Trace a b -> Int
length (Cons b
_ Trace a b
o) = forall a. Num a => a -> a -> a
(+) Int
1 forall a b. (a -> b) -> a -> b
$! forall a b. Trace a b -> Int
length Trace a b
o
length  Nil {}    = Int
0

toList :: Trace a b -> [b]
toList :: forall a b. Trace a b -> [b]
toList = forall (p :: * -> * -> *) a c b.
Bifoldable p =>
(a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
bifoldr (\a
_ [b]
bs -> [b]
bs) (:) []

fromList :: a -> [b] -> Trace a b
fromList :: forall a b. a -> [b] -> Trace a b
fromList a
a = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall a b. b -> Trace a b -> Trace a b
Cons (forall a b. a -> Trace a b
Nil a
a)

-- | Pretty print a 'Trace'.
--
ppTrace :: (a -> String) -> (b -> String) -> Trace a b -> String
ppTrace :: forall a b. (a -> String) -> (b -> String) -> Trace a b -> String
ppTrace a -> String
sa  b -> String
sb (Cons b
b Trace a b
bs) = b -> String
sb b
b forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a b. (a -> String) -> (b -> String) -> Trace a b -> String
ppTrace a -> String
sa b -> String
sb Trace a b
bs
ppTrace a -> String
sa b -> String
_sb (Nil a
a)     = a -> String
sa a
a

instance Bifunctor Trace where
    bimap :: forall a b c d. (a -> b) -> (c -> d) -> Trace a c -> Trace b d
bimap a -> b
f c -> d
g (Cons c
b Trace a c
bs) = forall a b. b -> Trace a b -> Trace a b
Cons (c -> d
g c
b) (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap a -> b
f c -> d
g Trace a c
bs)
    bimap a -> b
f c -> d
_ (Nil a
a)     = forall a b. a -> Trace a b
Nil (a -> b
f a
a)

instance Bifoldable Trace where
    bifoldMap :: forall m a b. Monoid m => (a -> m) -> (b -> m) -> Trace a b -> m
bifoldMap a -> m
f b -> m
g (Cons b
b Trace a b
bs) = b -> m
g b
b forall a. Semigroup a => a -> a -> a
<> forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f b -> m
g Trace a b
bs
    bifoldMap a -> m
f b -> m
_ (Nil a
a)     = a -> m
f a
a

    bifoldr :: forall a c b. (a -> c -> c) -> (b -> c -> c) -> c -> Trace a b -> c
bifoldr a -> c -> c
f b -> c -> c
g c
c = Trace a b -> c
go
      where
        go :: Trace a b -> c
go (Cons b
b Trace a b
bs) = b
b b -> c -> c
`g` Trace a b -> c
go Trace a b
bs
        go (Nil  a
a)    = a
a a -> c -> c
`f` c
c
    {-# INLINE[0] bifoldr #-}

    bifoldl :: forall c a b. (c -> a -> c) -> (c -> b -> c) -> c -> Trace a b -> c
bifoldl c -> a -> c
f c -> b -> c
g = c -> Trace a b -> c
go
      where
        go :: c -> Trace a b -> c
go c
c (Cons b
b Trace a b
bs) = c -> Trace a b -> c
go (c
c c -> b -> c
`g` b
b) Trace a b
bs
        go c
c (Nil a
a)     = c
c c -> a -> c
`f` a
a
    {-# INLINE[0] bifoldl #-}

instance Bitraversable Trace where
    bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> Trace a b -> f (Trace c d)
bitraverse a -> f c
f b -> f d
g (Cons b
b Trace a b
bs) = forall a b. b -> Trace a b -> Trace a b
Cons forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse a -> f c
f b -> f d
g Trace a b
bs
    bitraverse a -> f c
f b -> f d
_ (Nil a
a)     = forall a b. a -> Trace a b
Nil forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
a

instance Semigroup a => Semigroup (Trace a b) where
    Cons b
b Trace a b
o  <> :: Trace a b -> Trace a b -> Trace a b
<> Trace a b
o'          = forall a b. b -> Trace a b -> Trace a b
Cons b
b (Trace a b
o forall a. Semigroup a => a -> a -> a
<> Trace a b
o')
    o :: Trace a b
o@Nil {}  <> (Cons b
b Trace a b
o') = forall a b. b -> Trace a b -> Trace a b
Cons b
b (Trace a b
o forall a. Semigroup a => a -> a -> a
<> Trace a b
o')
    Nil a
a     <> Nil a
a'      = forall a b. a -> Trace a b
Nil (a
a forall a. Semigroup a => a -> a -> a
<> a
a')

instance Monoid a => Monoid (Trace a b) where
    mempty :: Trace a b
mempty = forall a b. a -> Trace a b
Nil forall a. Monoid a => a
mempty

instance Monoid a => Applicative (Trace a) where
    pure :: forall a. a -> Trace a a
pure a
b = forall a b. b -> Trace a b -> Trace a b
Cons a
b (forall a b. a -> Trace a b
Nil forall a. Monoid a => a
mempty)
    Cons a -> b
f Trace a (a -> b)
fs <*> :: forall a b. Trace a (a -> b) -> Trace a a -> Trace a b
<*> Trace a a
o = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Trace a a
o forall a. Semigroup a => a -> a -> a
<> (Trace a (a -> b)
fs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Trace a a
o)
    Nil a
a <*> Trace a a
_     = forall a b. a -> Trace a b
Nil a
a

instance Monoid a => Monad (Trace a) where
    return :: forall a. a -> Trace a a
return  = forall (f :: * -> *) a. Applicative f => a -> f a
pure
    -- @bifoldMap Nil id@ is the @join@ of @Trace a@
    Trace a a
o >>= :: forall a b. Trace a a -> (a -> Trace a b) -> Trace a b
>>= a -> Trace a b
f = forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap forall a b. a -> Trace a b
Nil forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Trace a b
f Trace a a
o

#if MIN_VERSION_base(4,13,0)
instance Monoid a => MonadFail (Trace a) where
    fail :: forall a. String -> Trace a a
fail String
_ = forall (m :: * -> *) a. MonadPlus m => m a
mzero
#endif

instance Monoid a => Alternative (Trace a) where
    empty :: forall a. Trace a a
empty = forall a. Monoid a => a
mempty
    <|> :: forall a. Trace a a -> Trace a a -> Trace a a
(<|>) = forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => MonadPlus (Trace a) where
    mzero :: forall a. Trace a a
mzero = forall a. Monoid a => a
mempty
    mplus :: forall a. Trace a a -> Trace a a -> Trace a a
mplus = forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => MonadFix (Trace a) where
    mfix :: forall a. (a -> Trace a a) -> Trace a a
mfix a -> Trace a a
f = case forall a. (a -> a) -> a
fix (a -> Trace a a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Trace a b -> b
head) of
      o :: Trace a a
o@Nil {} -> Trace a a
o
      Cons a
b Trace a a
_ -> forall a b. b -> Trace a b -> Trace a b
Cons a
b (forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (forall a b. Trace a b -> Trace a b
tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Trace a a
f))

instance Eq a => Eq1 (Trace a) where
    liftEq :: forall a b. (a -> b -> Bool) -> Trace a a -> Trace a b -> Bool
liftEq a -> b -> Bool
f (Cons a
b Trace a a
o) (Cons b
b' Trace a b
o') = a -> b -> Bool
f a
b b
b' Bool -> Bool -> Bool
&& forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
f Trace a a
o Trace a b
o'
    liftEq a -> b -> Bool
_ Nil  {}     Cons {}     = Bool
False
    liftEq a -> b -> Bool
_ Cons {}     Nil  {}     = Bool
False
    liftEq a -> b -> Bool
_ (Nil a
a)    (Nil a
a')     = a
a forall a. Eq a => a -> a -> Bool
== a
a'

instance Ord a => Ord1 (Trace a) where
    liftCompare :: forall a b.
(a -> b -> Ordering) -> Trace a a -> Trace a b -> Ordering
liftCompare a -> b -> Ordering
f (Cons a
b Trace a a
o) (Cons b
b' Trace a b
o') = a -> b -> Ordering
f a
b b
b' forall a. Ord a => a -> a -> Ordering
`compare` forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
f Trace a a
o Trace a b
o'
    liftCompare a -> b -> Ordering
_  Nil  {}    Cons {}     = Ordering
LT
    liftCompare a -> b -> Ordering
_  Cons {}    Nil {}      = Ordering
GT
    liftCompare a -> b -> Ordering
_ (Nil a
a)    (Nil a
a')     = a
a forall a. Ord a => a -> a -> Ordering
`compare` a
a'

instance Show a => Show1 (Trace a) where
    liftShowsPrec :: forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Trace a a -> ShowS
liftShowsPrec  Int -> a -> ShowS
showsPrec_ [a] -> ShowS
showsList_ Int
prec (Cons a
b Trace a a
o)
      = String -> ShowS
showString String
"Cons "
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
showsPrec_ Int
prec a
b
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True (forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
showsPrec_ [a] -> ShowS
showsList_ Int
prec Trace a a
o)
    liftShowsPrec Int -> a -> ShowS
_showsPrec [a] -> ShowS
_showsList Int
_prec (Nil a
a)
      = String -> ShowS
showString String
"Nil "
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> ShowS
shows a
a