{-# 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', thus an octopus.
--
-- * @'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
[Trace a b] -> ShowS
Trace a b -> String
(Int -> Trace a b -> ShowS)
-> (Trace a b -> String)
-> ([Trace a b] -> ShowS)
-> Show (Trace a b)
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
(Trace a b -> Trace a b -> Bool)
-> (Trace a b -> Trace a b -> Bool) -> Eq (Trace a b)
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, Eq (Trace a b)
Eq (Trace a b)
-> (Trace a b -> Trace a b -> Ordering)
-> (Trace a b -> Trace a b -> Bool)
-> (Trace a b -> Trace a b -> Bool)
-> (Trace a b -> Trace a b -> Bool)
-> (Trace a b -> Trace a b -> Bool)
-> (Trace a b -> Trace a b -> Trace a b)
-> (Trace a b -> Trace a b -> Trace a b)
-> Ord (Trace a b)
Trace a b -> Trace a b -> Bool
Trace a b -> Trace a b -> Ordering
Trace a b -> Trace a b -> Trace a b
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
$cp1Ord :: forall a b. (Ord b, Ord a) => Eq (Trace a b)
Ord, a -> Trace a b -> Trace a a
(a -> b) -> Trace a a -> Trace a b
(forall a b. (a -> b) -> Trace a a -> Trace a b)
-> (forall a b. a -> Trace a b -> Trace a a) -> Functor (Trace a)
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
<$ :: a -> Trace a b -> Trace a a
$c<$ :: forall a a b. a -> Trace a b -> Trace a a
fmap :: (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 :: Trace a b -> b
head (Cons b
b Trace a b
_) = b
b
head Trace a b
_          = String -> b
forall a. HasCallStack => String -> a
error String
"Trace.head: empty"

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

filter :: (b -> Bool) -> Trace a b -> Trace a b
filter :: (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  -> b -> Trace a b -> Trace a b
forall a b. b -> Trace a b -> Trace a b
Cons b
b ((b -> Bool) -> Trace a b -> Trace a b
forall b a. (b -> Bool) -> Trace a b -> Trace a b
filter b -> Bool
fn Trace a b
o)
      Bool
False ->         (b -> Bool) -> Trace a b -> Trace a b
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 :: Trace a b -> Int
length (Cons b
_ Trace a b
o) = Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
1 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$! Trace a b -> Int
forall a b. Trace a b -> Int
length Trace a b
o
length  Nil {}    = Int
0

toList :: Trace a b -> [b]
toList :: Trace a b -> [b]
toList = (a -> [b] -> [b]) -> (b -> [b] -> [b]) -> [b] -> Trace a b -> [b]
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 :: a -> [b] -> Trace a b
fromList a
a = (b -> Trace a b -> Trace a b) -> Trace a b -> [b] -> Trace a b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr b -> Trace a b -> Trace a b
forall a b. b -> Trace a b -> Trace a b
Cons (a -> Trace a b
forall a b. a -> Trace a b
Nil a
a)

-- | Pretty print an 'Trace'.
--
ppTrace :: (a -> String) -> (b -> String) -> Trace a b -> String
ppTrace :: (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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (a -> String) -> (b -> String) -> Trace a b -> String
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 :: (a -> b) -> (c -> d) -> Trace a c -> Trace b d
bimap a -> b
f c -> d
g (Cons c
b Trace a c
bs) = d -> Trace b d -> Trace b d
forall a b. b -> Trace a b -> Trace a b
Cons (c -> d
g c
b) ((a -> b) -> (c -> d) -> Trace a c -> Trace b d
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)     = b -> Trace b d
forall a b. a -> Trace a b
Nil (a -> b
f a
a)

instance Bifoldable Trace where
    bifoldMap :: (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 m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> (b -> m) -> Trace a b -> m
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 :: (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 :: (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 :: (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) = d -> Trace c d -> Trace c d
forall a b. b -> Trace a b -> Trace a b
Cons (d -> Trace c d -> Trace c d) -> f d -> f (Trace c d -> Trace c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
b f (Trace c d -> Trace c d) -> f (Trace c d) -> f (Trace c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f c) -> (b -> f d) -> Trace a b -> f (Trace c d)
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)     = c -> Trace c d
forall a b. a -> Trace a b
Nil (c -> Trace c d) -> f c -> f (Trace c d)
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'          = b -> Trace a b -> Trace a b
forall a b. b -> Trace a b -> Trace a b
Cons b
b (Trace a b
o Trace a b -> Trace a b -> Trace a b
forall a. Semigroup a => a -> a -> a
<> Trace a b
o')
    o :: Trace a b
o@Nil {}  <> (Cons b
b Trace a b
o') = b -> Trace a b -> Trace a b
forall a b. b -> Trace a b -> Trace a b
Cons b
b (Trace a b
o Trace a b -> Trace a b -> Trace a b
forall a. Semigroup a => a -> a -> a
<> Trace a b
o')
    Nil a
a     <> Nil a
a'      = a -> Trace a b
forall a b. a -> Trace a b
Nil (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a')

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

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

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

instance Monoid a => MonadFail (Trace a) where
    fail :: String -> Trace a a
fail String
_ = Trace a a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance Monoid a => Alternative (Trace a) where
    empty :: Trace a a
empty = Trace a a
forall a. Monoid a => a
mempty
    <|> :: Trace a a -> Trace a a -> Trace a 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 :: Trace a a
mzero = Trace a a
forall a. Monoid a => a
mempty
    mplus :: Trace a a -> Trace a a -> Trace a a
mplus = Trace a a -> Trace a a -> Trace a a
forall a. Semigroup a => a -> a -> a
(<>)

instance Monoid a => MonadFix (Trace a) where
    mfix :: (a -> Trace a a) -> Trace a a
mfix a -> Trace a a
f = case (Trace a a -> Trace a a) -> Trace a a
forall a. (a -> a) -> a
fix (a -> Trace a a
f (a -> Trace a a) -> (Trace a a -> a) -> Trace a a -> Trace a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Trace a a -> a
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
_ -> a -> Trace a a -> Trace a a
forall a b. b -> Trace a b -> Trace a b
Cons a
b ((a -> Trace a a) -> Trace a a
forall (m :: * -> *) a. MonadFix m => (a -> m a) -> m a
mfix (Trace a a -> Trace a a
forall a b. Trace a b -> Trace a b
tail (Trace a a -> Trace a a) -> (a -> Trace a a) -> a -> Trace a a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Trace a a
f))

instance Eq a => Eq1 (Trace a) where
    liftEq :: (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
&& (a -> b -> Bool) -> Trace a a -> Trace a b -> 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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a'

instance Ord a => Ord1 (Trace a) where
    liftCompare :: (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' Ordering -> Ordering -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` (a -> b -> Ordering) -> Trace a a -> Trace a b -> Ordering
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 a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
`compare` a
a'

instance Show a => Show1 (Trace a) where
    liftShowsPrec :: (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 "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
showsPrec_ Int
prec a
b
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' '
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> ShowS -> ShowS
showParen Bool
True ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> Trace a a -> ShowS
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 "
      ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ShowS
forall a. Show a => a -> ShowS
shows a
a