{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-- need PolyKinds else could fail for callers using TP type families
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

{- |
Module      : Primus.LRHist
Description : like 'Either' but keeps history of all successes
Copyright   : (c) Grant Weyburne, 2022
License     : BSD-3

tracks one or more successes and optionally a failure

prefer the smart constructors to enforce correctness or use the apply methods
-}
module Primus.LRHist (
  -- * datatype
  LRHist (..),

  -- * smart constructors
  rhi,
  rh,
  lh,
  lhskip,

  -- * constructors with better type application order
  rhi',
  rh',
  lh',
  lhskip',

  -- * converters
  lhToEitherI,
  lhToEither,
  lhToEitherTuples,

  -- * function application
  lhBool,
  lhMaybe,
  lhMaybe',
  lhEither,
  lhEither',
  appLR,
  appLRS,
  appLRB,

  -- * traversals
  traverseLRHistB,
  traverseLRHist,

  -- * miscellaneous
  eitherToLH,
  maybeToLH,
  validateLRHist,
) where

import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Bool
import Data.Kind
import qualified Data.List as L
import Data.Proxy
import Data.These
import qualified GHC.Read as GR
import Primus.AsMaybe
import Primus.Bool
import Primus.Error (programmError)
import qualified Primus.TypeLevel as TP
import qualified Text.ParserCombinators.ReadPrec as PC
import qualified Text.Read.Lex as TRL

{- | like 'Either' but keeps track of history of all successes
  if there is a failure it wraps the previous successes and stops adding data to 'LRHist'
 "e" the error type
 "as" is the typelevel list in reverse order that tracks all previous "a"s
 "a" is the latest success type
-}
type LRHist :: [Type] -> Type -> Type -> Type
data LRHist as e a where
  -- | wraps an existing error
  LhSkip ::
    LRHist as e a' ->
    LRHist (a' ': as) e a
  -- | wraps previous nested successes with an error
  Lh ::
    e ->
    LRHist as e a' ->
    LRHist (a' ': as) e a
  -- | initial success value
  Rhi ::
    a ->
    LRHist '[] e a
  -- | subsequent success
  Rh ::
    a ->
    LRHist as e a' ->
    LRHist (a' ': as) e a

deriving stock instance Functor (LRHist as e)
deriving stock instance Foldable (LRHist as e)
deriving stock instance Traversable (LRHist as e)
deriving stock instance (Show a, Show e, TP.ApplyConstraints '[Show] as) => Show (LRHist as e a)
deriving stock instance (TP.ApplyConstraints '[Eq, Ord] as, Eq e, Ord e, Ord a) => Ord (LRHist as e a)
deriving stock instance (TP.ApplyConstraints '[Eq] as, Eq e, Eq a) => Eq (LRHist as e a)
instance
  (Semigroup e, Monoid a) =>
  Monoid (LRHist '[] e a)
  where
  mempty :: LRHist '[] e a
mempty = a -> LRHist '[] e a
forall a e. a -> LRHist '[] e a
Rhi a
forall a. Monoid a => a
mempty
instance
  ( Monoid a
  , Monoid e
  , Monoid a'
  , TP.ApplyConstraints '[Semigroup, Monoid] as
  , Monoid (LRHist as e a')
  ) =>
  Monoid (LRHist (a' ': as) e a)
  where
  mempty :: LRHist (a' : as) e a
mempty = a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh a
forall a. Monoid a => a
mempty LRHist as e a'
forall a. Monoid a => a
mempty

instance
  ( Semigroup a
  , Semigroup e
  , TP.ApplyConstraints '[Semigroup] as
  ) =>
  Semigroup (LRHist as e a)
  where
  LRHist as e a
x <> :: LRHist as e a -> LRHist as e a -> LRHist as e a
<> LRHist as e a
y = case (LRHist as e a
x, LRHist as e a
y) of
    (Rhi a
a, Rhi a
a') -> a -> LRHist '[] e a
forall a e. a -> LRHist '[] e a
Rhi (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a')
    (Rh a
a LRHist as e a'
ls, Rh a
a' LRHist as e a'
ls') -> a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh (a
a a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a') (LRHist as e a'
ls LRHist as e a' -> LRHist as e a' -> LRHist as e a'
forall a. Semigroup a => a -> a -> a
<> LRHist as e a'
LRHist as e a'
ls')
    (Lh e
e LRHist as e a'
ls, Lh e
e' LRHist as e a'
ls') -> e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh (e
e e -> e -> e
forall a. Semigroup a => a -> a -> a
<> e
e') (LRHist as e a'
ls LRHist as e a' -> LRHist as e a' -> LRHist as e a'
forall a. Semigroup a => a -> a -> a
<> LRHist as e a'
LRHist as e a'
ls')
    (LhSkip LRHist as e a'
ls, LhSkip LRHist as e a'
ls') -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip (LRHist as e a'
ls LRHist as e a' -> LRHist as e a' -> LRHist as e a'
forall a. Semigroup a => a -> a -> a
<> LRHist as e a'
LRHist as e a'
ls')
    (z :: LRHist as e a
z@LhSkip{}, LRHist as e a
_) -> LRHist as e a
z
    (LRHist as e a
_, z :: LRHist as e a
z@LhSkip{}) -> LRHist as e a
z
    (z :: LRHist as e a
z@Lh{}, LRHist as e a
_) -> LRHist as e a
z
    (LRHist as e a
_, z :: LRHist as e a
z@Lh{}) -> LRHist as e a
z

-- | constructor for 'Rhi' with more convenient type application order
rhi' :: forall e a. a -> LRHist '[] e a
rhi' :: a -> LRHist '[] e a
rhi' = a -> LRHist '[] e a
forall a e. a -> LRHist '[] e a
Rhi

-- | constructor for 'Rh' with more convenient type application order
rh' :: forall e a a' as. a -> LRHist as e a' -> LRHist (a' : as) e a
rh' :: a -> LRHist as e a' -> LRHist (a' : as) e a
rh' = a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh

-- | constructor for 'Lh' with more convenient type application order
lh' :: forall a e a' as. e -> LRHist as e a' -> LRHist (a' : as) e a
lh' :: e -> LRHist as e a' -> LRHist (a' : as) e a
lh' = e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh

-- | constructor for 'LhSkip' with more convenient type application order
lhskip' :: forall a e a' as. LRHist as e a' -> LRHist (a' : as) e a
lhskip' :: LRHist as e a' -> LRHist (a' : as) e a
lhskip' = LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip

-- | smart constructor for 'Rhi'
rhi :: forall e a. a -> (Proxy 'True, LRHist '[] e a)
rhi :: a -> (Proxy 'True, LRHist '[] e a)
rhi a
a = (Proxy 'True
forall k (t :: k). Proxy t
Proxy, a -> LRHist '[] e a
forall a e. a -> LRHist '[] e a
Rhi a
a)

-- | smart constructor for 'Rh'
rh ::
  forall e a a' as proxy.
  a ->
  (proxy 'True, LRHist as e a') ->
  (proxy 'True, LRHist (a' : as) e a)
rh :: a
-> (proxy 'True, LRHist as e a')
-> (proxy 'True, LRHist (a' : as) e a)
rh a
a = (LRHist as e a' -> LRHist (a' : as) e a)
-> (proxy 'True, LRHist as e a')
-> (proxy 'True, LRHist (a' : as) e a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh a
a)

-- | smart constructor for 'Lh'
lh ::
  forall a e a' as proxy.
  e ->
  (proxy 'True, LRHist as e a') ->
  (Proxy 'False, LRHist (a' : as) e a)
lh :: e
-> (proxy 'True, LRHist as e a')
-> (Proxy 'False, LRHist (a' : as) e a)
lh e
e (proxy 'True
_p, LRHist as e a'
z) = (Proxy 'False
forall k (t :: k). Proxy t
Proxy, e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh e
e LRHist as e a'
z)

-- | smart constructor for 'LhSkip'
lhskip ::
  forall a e a' as proxy.
  (proxy 'False, LRHist as e a') ->
  (proxy 'False, LRHist (a' : as) e a)
lhskip :: (proxy 'False, LRHist as e a')
-> (proxy 'False, LRHist (a' : as) e a)
lhskip = (LRHist as e a' -> LRHist (a' : as) e a)
-> (proxy 'False, LRHist as e a')
-> (proxy 'False, LRHist (a' : as) e a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip

-- | initialise 'LRHist' with an 'Either' by wrapping a unit
eitherToLH :: Either e a -> LRHist '[()] e a
eitherToLH :: Either e a -> LRHist '[()] e a
eitherToLH Either e a
lr = (e -> LRHist '[] e () -> LRHist '[()] e a)
-> (a -> LRHist '[] e () -> LRHist '[()] e a)
-> Either e a
-> LRHist '[] e ()
-> LRHist '[()] e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> LRHist '[] e () -> LRHist '[()] e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh a -> LRHist '[] e () -> LRHist '[()] e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh Either e a
lr (() -> LRHist '[] e ()
forall a e. a -> LRHist '[] e a
Rhi ())

-- | initialise 'LRHist' with an 'Maybe' by wrapping a unit
maybeToLH :: Monoid e => Maybe a -> LRHist '[()] e a
maybeToLH :: Maybe a -> LRHist '[()] e a
maybeToLH = Either e a -> LRHist '[()] e a
forall e a. Either e a -> LRHist '[()] e a
eitherToLH (Either e a -> LRHist '[()] e a)
-> (Maybe a -> Either e a) -> Maybe a -> LRHist '[()] e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> (a -> Either e a) -> Maybe a -> Either e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> Either e a
forall a b. a -> Either a b
Left e
forall a. Monoid a => a
mempty) a -> Either e a
forall a b. b -> Either a b
Right

-- | returns an inductive tuple on success and Either for failure
lhToEitherI ::
  forall e a as.
  RHistC as =>
  LRHist as e a ->
  Either e (RHistT a as)
lhToEitherI :: LRHist as e a -> Either e (RHistT a as)
lhToEitherI = LRHist as e a -> Either e (RHistT a as)
forall (as :: [*]) e a.
RHistC as =>
LRHist as e a -> Either e (RHistT a as)
rhist

-- | convert 'LRHist' to an 'Either'
lhToEither :: forall e a as. LRHist as e a -> Either e a
lhToEither :: LRHist as e a -> Either e a
lhToEither = \case
  Rhi a
a -> a -> Either e a
forall a b. b -> Either a b
Right a
a
  Rh a
a LRHist as e a'
_ -> a -> Either e a
forall a b. b -> Either a b
Right a
a
  Lh e
e LRHist as e a'
_ -> e -> Either e a
forall a b. a -> Either a b
Left e
e
  z :: LRHist as e a
z@LhSkip{} -> e -> Either e a
forall a b. a -> Either a b
Left (e -> Either e a) -> e -> Either e a
forall a b. (a -> b) -> a -> b
$ LRHist as e a -> e
forall (as' :: [*]) a'. LRHist as' e a' -> e
go LRHist as e a
z
 where
  go :: forall as' a'. LRHist as' e a' -> e
  go :: LRHist as' e a' -> e
go = \case
    Rhi{} -> String -> e
forall a. HasCallStack => String -> a
programmError String
"malformed LRHist: LhSkip expects inner LhSkip or Lh but found Rhi"
    Rh{} -> String -> e
forall a. HasCallStack => String -> a
programmError String
"malformed LRHist: LhSkip expects LhSkip or Lh but found Rh"
    Lh e
e LRHist as e a'
_ -> e
e
    LhSkip LRHist as e a'
ls -> LRHist as e a' -> e
forall (as' :: [*]) a'. LRHist as' e a' -> e
go LRHist as e a'
ls

-- | extract the initial type for 'LRHist'
type OrgAT :: [Type] -> Type -> Type
type family OrgAT as a where
  OrgAT '[] a' = a'
  OrgAT (a ': as) _ = OrgAT as a

-- | extracts the initial value from 'LRHist'
type OrgAC :: [Type] -> Type -> Constraint
class OrgAC as a where
  orgA :: LRHist as e a -> OrgAT as a

instance OrgAC '[] a' where
  orgA :: LRHist '[] e a' -> OrgAT '[] a'
orgA = \case
    Rhi a'
a -> a'
OrgAT '[] a'
a
instance OrgAC as a => OrgAC (a ': as) a' where
  orgA :: LRHist (a : as) e a' -> OrgAT (a : as) a'
orgA = \case
    Rh a'
_ LRHist as e a'
ls -> LRHist as e a' -> OrgAT as a'
forall (as :: [*]) a e. OrgAC as a => LRHist as e a -> OrgAT as a
orgA LRHist as e a'
ls
    Lh e
_ LRHist as e a'
ls -> LRHist as e a' -> OrgAT as a'
forall (as :: [*]) a e. OrgAC as a => LRHist as e a -> OrgAT as a
orgA LRHist as e a'
ls
    LhSkip LRHist as e a'
ls -> LRHist as e a' -> OrgAT as a'
forall (as :: [*]) a e. OrgAC as a => LRHist as e a -> OrgAT as a
orgA LRHist as e a'
ls

-- | returns flattened n-tuple with all the history of successes on success and Either for failure
lhToEitherTuples ::
  forall e a as tp.
  ( TP.ITupleC tp
  , RHistC as
  , TP.ToITupleT tp ~ RHistT a as
  ) =>
  LRHist as e a ->
  Either e tp
lhToEitherTuples :: LRHist as e a -> Either e tp
lhToEitherTuples = (RHistT a as -> tp) -> Either e (RHistT a as) -> Either e tp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RHistT a as -> tp
forall x. ITupleC x => ToITupleT x -> x
TP.fromITupleC (Either e (RHistT a as) -> Either e tp)
-> (LRHist as e a -> Either e (RHistT a as))
-> LRHist as e a
-> Either e tp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LRHist as e a -> Either e (RHistT a as)
forall (as :: [*]) e a.
RHistC as =>
LRHist as e a -> Either e (RHistT a as)
rhist

-- | type family for creating an inductive tuple
type RHistT :: Type -> [Type] -> Type
type family RHistT a as where
  RHistT a '[] = (a, ())
  RHistT a (a' ': as) = (a, RHistT a' as)

-- | return an inductive tuple on success
type RHistC :: [Type] -> Constraint
class RHistC as where
  rhist :: LRHist as e a -> Either e (RHistT a as)

instance RHistC '[] where
  rhist :: LRHist '[] e a -> Either e (RHistT a '[])
rhist = \case
    Rhi a
a -> (a, ()) -> Either e (a, ())
forall a b. b -> Either a b
Right (a
a, ())
instance RHistC as => RHistC (a ': as) where
  rhist :: LRHist (a : as) e a -> Either e (RHistT a (a : as))
rhist = \case
    Rh a
a LRHist as e a'
ls -> (a
a,) (RHistT a as -> (a, RHistT a as))
-> Either e (RHistT a as) -> Either e (a, RHistT a as)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LRHist as e a' -> Either e (RHistT a' as)
forall (as :: [*]) e a.
RHistC as =>
LRHist as e a -> Either e (RHistT a as)
rhist LRHist as e a'
ls
    Lh e
e LRHist as e a'
_ -> e -> Either e (a, RHistT a as)
forall a b. a -> Either a b
Left e
e
    LhSkip LRHist as e a'
ls -> case LRHist as e a' -> Either e (RHistT a' as)
forall (as :: [*]) e a.
RHistC as =>
LRHist as e a -> Either e (RHistT a as)
rhist LRHist as e a'
ls of
      Left e
e -> e -> Either e (a, RHistT a as)
forall a b. a -> Either a b
Left e
e
      Right RHistT a' as
_a -> String -> Either e (a, RHistT a as)
forall a. HasCallStack => String -> a
programmError String
"malformed LRHist: LhSkip wrapping Rh or Rhi"

-- | validate that the composition of constructors for 'LRHist' is valid
validateLRHist :: forall e a as. LRHist as e a -> Either String ()
validateLRHist :: LRHist as e a -> Either String ()
validateLRHist =
  \case
    Rhi{} -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    Rh a
_ LRHist as e a'
ls -> case LRHist as e a'
ls of
      Lh{} -> String -> Either String ()
forall a b. a -> Either a b
Left String
"Rh cannot wrap Lh"
      LhSkip{} -> String -> Either String ()
forall a b. a -> Either a b
Left String
"Rh cannot wrap LhSkip"
      Rhi{} -> LRHist as e a' -> Either String ()
forall e a (as :: [*]). LRHist as e a -> Either String ()
validateLRHist LRHist as e a'
ls
      Rh{} -> LRHist as e a' -> Either String ()
forall e a (as :: [*]). LRHist as e a -> Either String ()
validateLRHist LRHist as e a'
ls
    Lh e
_ LRHist as e a'
ls -> case LRHist as e a'
ls of
      Lh{} -> String -> Either String ()
forall a b. a -> Either a b
Left String
"Lh cannot wrap Lh"
      LhSkip{} -> String -> Either String ()
forall a b. a -> Either a b
Left String
"Lh cannot wrap LhSkip"
      Rhi{} -> LRHist as e a' -> Either String ()
forall e a (as :: [*]). LRHist as e a -> Either String ()
validateLRHist LRHist as e a'
ls
      Rh{} -> LRHist as e a' -> Either String ()
forall e a (as :: [*]). LRHist as e a -> Either String ()
validateLRHist LRHist as e a'
ls
    LhSkip LRHist as e a'
ls -> case LRHist as e a'
ls of
      Lh{} -> LRHist as e a' -> Either String ()
forall e a (as :: [*]). LRHist as e a -> Either String ()
validateLRHist LRHist as e a'
ls
      LhSkip{} -> LRHist as e a' -> Either String ()
forall e a (as :: [*]). LRHist as e a -> Either String ()
validateLRHist LRHist as e a'
ls
      Rhi{} -> String -> Either String ()
forall a b. a -> Either a b
Left String
"LhSkip cannot wrap Rhi"
      Rh{} -> String -> Either String ()
forall a b. a -> Either a b
Left String
"LhSkip cannot wrap Rh"

-- | base case for 'LRHist' Read instance for '[] so only supports 'Rhi' constructor
instance
  (Read a, Read e) =>
  Read (LRHist '[] e a)
  where
  readPrec :: ReadPrec (LRHist '[] e a)
readPrec =
    ReadPrec (LRHist '[] e a) -> ReadPrec (LRHist '[] e a)
forall a. ReadPrec a -> ReadPrec a
GR.parens
      ( Int -> ReadPrec (LRHist '[] e a) -> ReadPrec (LRHist '[] e a)
forall a. Int -> ReadPrec a -> ReadPrec a
PC.prec
          Int
10
          ( do
              Lexeme -> ReadPrec ()
GR.expectP (String -> Lexeme
TRL.Ident String
"Rhi")
              a
a <- ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
PC.step ReadPrec a
forall a. Read a => ReadPrec a
GR.readPrec
              LRHist '[] e a -> ReadPrec (LRHist '[] e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> LRHist '[] e a
forall a e. a -> LRHist '[] e a
Rhi a
a)
          )
      )

-- | successor case for 'LRHist' Read instance (a' ': as) so supports 'Rh', 'Lh', 'LhSkip' constructors
instance
  ( Read a
  , Read e
  , Read a'
  , Read (LRHist as e a')
  , TP.ApplyConstraints '[Read] as
  ) =>
  Read (LRHist (a' ': as) e a)
  where
  readPrec :: ReadPrec (LRHist (a' : as) e a)
readPrec =
    ReadPrec (LRHist (a' : as) e a) -> ReadPrec (LRHist (a' : as) e a)
forall a. ReadPrec a -> ReadPrec a
GR.parens
      ( Int
-> ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
forall a. Int -> ReadPrec a -> ReadPrec a
PC.prec
          Int
10
          ( do
              Lexeme -> ReadPrec ()
GR.expectP (String -> Lexeme
TRL.Ident String
"LhSkip")
              LRHist as e a'
rst <- ReadPrec (LRHist as e a') -> ReadPrec (LRHist as e a')
forall a. ReadPrec a -> ReadPrec a
PC.step ReadPrec (LRHist as e a')
forall a. Read a => ReadPrec a
GR.readPrec
              LRHist (a' : as) e a -> ReadPrec (LRHist (a' : as) e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
rst)
          )
          ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
PC.+++ Int
-> ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
forall a. Int -> ReadPrec a -> ReadPrec a
PC.prec
            Int
10
            ( do
                Lexeme -> ReadPrec ()
GR.expectP (String -> Lexeme
TRL.Ident String
"Lh")
                e
e <- ReadPrec e -> ReadPrec e
forall a. ReadPrec a -> ReadPrec a
PC.step ReadPrec e
forall a. Read a => ReadPrec a
GR.readPrec
                LRHist as e a'
rst <- ReadPrec (LRHist as e a') -> ReadPrec (LRHist as e a')
forall a. ReadPrec a -> ReadPrec a
PC.step ReadPrec (LRHist as e a')
forall a. Read a => ReadPrec a
GR.readPrec
                LRHist (a' : as) e a -> ReadPrec (LRHist (a' : as) e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh e
e LRHist as e a'
rst)
            )
          ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
PC.+++ Int
-> ReadPrec (LRHist (a' : as) e a)
-> ReadPrec (LRHist (a' : as) e a)
forall a. Int -> ReadPrec a -> ReadPrec a
PC.prec
            Int
10
            ( do
                Lexeme -> ReadPrec ()
GR.expectP (String -> Lexeme
TRL.Ident String
"Rh")
                a
a <- ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
PC.step ReadPrec a
forall a. Read a => ReadPrec a
GR.readPrec
                LRHist as e a'
rst <- ReadPrec (LRHist as e a') -> ReadPrec (LRHist as e a')
forall a. ReadPrec a -> ReadPrec a
PC.step ReadPrec (LRHist as e a')
forall a. Read a => ReadPrec a
GR.readPrec
                LRHist (a' : as) e a -> ReadPrec (LRHist (a' : as) e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh a
a LRHist as e a'
rst)
            )
      )

instance Bifunctor (LRHist as) where
  bimap :: (a -> b) -> (c -> d) -> LRHist as a c -> LRHist as b d
bimap a -> b
f c -> d
g = \case
    Rhi c
a -> d -> LRHist '[] b d
forall a e. a -> LRHist '[] e a
Rhi (c -> d
g c
a)
    Rh c
a LRHist as a a'
ls -> d -> LRHist as b a' -> LRHist (a' : as) b d
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh (c -> d
g c
a) ((a -> b) -> LRHist as a a' -> LRHist as b a'
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f LRHist as a a'
ls)
    Lh a
e LRHist as a a'
ls -> b -> LRHist as b a' -> LRHist (a' : as) b d
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh (a -> b
f a
e) ((a -> b) -> LRHist as a a' -> LRHist as b a'
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f LRHist as a a'
ls)
    LhSkip LRHist as a a'
ls -> LRHist as b a' -> LRHist (a' : as) b d
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip ((a -> b) -> LRHist as a a' -> LRHist as b a'
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first a -> b
f LRHist as a a'
ls)

instance Bifoldable (LRHist as) where
  bifoldMap :: (a -> m) -> (b -> m) -> LRHist as a b -> m
bifoldMap a -> m
f b -> m
g = \case
    Rhi b
a -> b -> m
g b
a
    Rh b
a LRHist as a a'
ls -> b -> m
g b
a m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> (a' -> m) -> LRHist as a a' -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f (m -> a' -> m
forall a b. a -> b -> a
const m
forall a. Monoid a => a
mempty) LRHist as a a'
ls
    Lh a
e LRHist as a a'
ls -> a -> m
f a
e m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (a -> m) -> (a' -> m) -> LRHist as a a' -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f (m -> a' -> m
forall a b. a -> b -> a
const m
forall a. Monoid a => a
mempty) LRHist as a a'
ls
    LhSkip LRHist as a a'
ls -> (a -> m) -> (a' -> m) -> LRHist as a a' -> m
forall (p :: * -> * -> *) m a b.
(Bifoldable p, Monoid m) =>
(a -> m) -> (b -> m) -> p a b -> m
bifoldMap a -> m
f (m -> a' -> m
forall a b. a -> b -> a
const m
forall a. Monoid a => a
mempty) LRHist as a a'
ls

instance Bitraversable (LRHist as) where
  bitraverse :: (a -> f c) -> (b -> f d) -> LRHist as a b -> f (LRHist as c d)
bitraverse a -> f c
f b -> f d
g = \case
    Rhi b
a -> d -> LRHist '[] c d
forall a e. a -> LRHist '[] e a
Rhi (d -> LRHist '[] c d) -> f d -> f (LRHist '[] c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
a
    Rh b
a LRHist as a a'
ls -> d -> LRHist as c a' -> LRHist (a' : as) c d
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh (d -> LRHist as c a' -> LRHist (a' : as) c d)
-> f d -> f (LRHist as c a' -> LRHist (a' : as) c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f d
g b
a f (LRHist as c a' -> LRHist (a' : as) c d)
-> f (LRHist as c a') -> f (LRHist (a' : as) c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f c) -> (a' -> f a') -> LRHist as a a' -> f (LRHist as c a')
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 a' -> f a'
forall (f :: * -> *) a. Applicative f => a -> f a
pure LRHist as a a'
ls
    Lh a
e LRHist as a a'
ls -> c -> LRHist as c a' -> LRHist (a' : as) c d
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh (c -> LRHist as c a' -> LRHist (a' : as) c d)
-> f c -> f (LRHist as c a' -> LRHist (a' : as) c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
e f (LRHist as c a' -> LRHist (a' : as) c d)
-> f (LRHist as c a') -> f (LRHist (a' : as) c d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (a -> f c) -> (a' -> f a') -> LRHist as a a' -> f (LRHist as c a')
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 a' -> f a'
forall (f :: * -> *) a. Applicative f => a -> f a
pure LRHist as a a'
ls
    LhSkip LRHist as a a'
ls -> LRHist as c a' -> LRHist (a' : as) c d
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip (LRHist as c a' -> LRHist (a' : as) c d)
-> f (LRHist as c a') -> f (LRHist (a' : as) c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f c) -> (a' -> f a') -> LRHist as a a' -> f (LRHist as c a')
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 a' -> f a'
forall (f :: * -> *) a. Applicative f => a -> f a
pure LRHist as a a'
ls

-- | uses a boolean predicate to determine success or failure
lhBool ::
  forall e a a' as.
  (a ~ a', Monoid e) =>
  (a' -> Bool) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
lhBool :: (a' -> Bool) -> LRHist as e a' -> LRHist (a' : as) e a
lhBool a' -> Bool
f LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> a' -> LRHist (a' : as) e a'
k a'
a
    Rh a'
a LRHist as e a'
_ls -> a' -> LRHist (a' : as) e a'
k a'
a
    Lh{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
    LhSkip{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
 where
  k :: a' -> LRHist (a' : as) e a'
k a'
a = (LRHist as e a' -> LRHist (a' : as) e a')
-> (LRHist as e a' -> LRHist (a' : as) e a')
-> Bool
-> LRHist as e a'
-> LRHist (a' : as) e a'
forall a. a -> a -> Bool -> a
bool (e -> LRHist as e a' -> LRHist (a' : as) e a'
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh e
forall a. Monoid a => a
mempty) (a' -> LRHist as e a' -> LRHist (a' : as) e a'
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh a'
a) (a' -> Bool
f a'
a) LRHist as e a'
w

-- | uses a maybe function to determine success or failure and also allow change of type "a"
lhMaybe ::
  forall e a a' as.
  Monoid e =>
  (a' -> Maybe a) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
lhMaybe :: (a' -> Maybe a) -> LRHist as e a' -> LRHist (a' : as) e a
lhMaybe a' -> Maybe a
f LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> a' -> LRHist (a' : as) e a
k a'
a
    Rh a'
a LRHist as e a'
_ls -> a' -> LRHist (a' : as) e a
k a'
a
    Lh{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
    LhSkip{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
 where
  k :: a' -> LRHist (a' : as) e a
k a'
a = (LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> Maybe a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh e
forall a. Monoid a => a
mempty) a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh (a' -> Maybe a
f a'
a) LRHist as e a'
w

-- | similar to 'lhMaybe' leveraging 'boolMaybe'
lhMaybe' ::
  forall e a a' as.
  Monoid e =>
  (a' -> Bool) ->
  (a' -> a) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
lhMaybe' :: (a' -> Bool) -> (a' -> a) -> LRHist as e a' -> LRHist (a' : as) e a
lhMaybe' a' -> Bool
p a' -> a
f LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> a' -> LRHist (a' : as) e a
k a'
a
    Rh a'
a LRHist as e a'
_ls -> a' -> LRHist (a' : as) e a
k a'
a
    Lh{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
    LhSkip{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
 where
  k :: a' -> LRHist (a' : as) e a
k a'
a = (LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> Maybe a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh e
forall a. Monoid a => a
mempty) a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh ((a' -> Bool) -> (a' -> a) -> a' -> Maybe a
forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
boolMaybe a' -> Bool
p a' -> a
f a'
a) LRHist as e a'
w

-- | uses an either function to determine success or failure and also allow change of type "a"
lhEither ::
  forall e a a' as.
  (a' -> Either e a) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
lhEither :: (a' -> Either e a) -> LRHist as e a' -> LRHist (a' : as) e a
lhEither a' -> Either e a
f LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> (e -> LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> Either e a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh (a' -> Either e a
f a'
a) LRHist as e a'
w
    Rh a'
a LRHist as e a'
_ls -> (e -> LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> Either e a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh (a' -> Either e a
f a'
a) LRHist as e a'
w
    Lh{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
    LhSkip{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w

-- | similar to 'lhEither' leveraging 'boolEither'
lhEither' ::
  forall e a a' as.
  (a' -> Bool) ->
  (a' -> e) ->
  (a' -> a) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
lhEither' :: (a' -> Bool)
-> (a' -> e) -> (a' -> a) -> LRHist as e a' -> LRHist (a' : as) e a
lhEither' a' -> Bool
p a' -> e
l a' -> a
r LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> a' -> LRHist (a' : as) e a
k a'
a
    Rh a'
a LRHist as e a'
_ls -> a' -> LRHist (a' : as) e a
k a'
a
    Lh{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
    LhSkip{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
 where
  k :: a' -> LRHist (a' : as) e a
k a'
a = (e -> LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> Either e a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh ((a' -> Bool) -> (a' -> e) -> (a' -> a) -> a' -> Either e a
forall a e b.
(a -> Bool) -> (a -> e) -> (a -> b) -> a -> Either e b
boolEither a' -> Bool
p a' -> e
l a' -> a
r a'
a) LRHist as e a'
w

-- | apply a function to 'LRHist' using 'ApTheseF'
appLR ::
  forall e a a' as x.
  (ApTheseF e a' x a) =>
  (a' -> x) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
appLR :: (a' -> x) -> LRHist as e a' -> LRHist (a' : as) e a
appLR a' -> x
f LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> a' -> LRHist (a' : as) e a
k a'
a
    Rh a'
a LRHist as e a'
_ls -> a' -> LRHist (a' : as) e a
k a'
a
    Lh{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
    LhSkip{} -> LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w
 where
  k :: a' -> LRHist (a' : as) e a
k a'
a =
    let th :: These e a
th = a' -> x -> These e a
forall e a x b. ApTheseF e a x b => a -> x -> These e b
apTheseF a'
a (a' -> x
f a'
a)
     in (e -> LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> (e -> a -> LRHist as e a' -> LRHist (a' : as) e a)
-> These e a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh ((a -> LRHist as e a' -> LRHist (a' : as) e a)
-> e -> a -> LRHist as e a' -> LRHist (a' : as) e a
forall a b. a -> b -> a
const a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh) These e a
th LRHist as e a'
w

-- | similar to 'appLR' with state
appLRS ::
  forall e a' x a as z.
  (ApTheseF e a' x a) =>
  (z -> a' -> (z, x)) ->
  z ->
  LRHist as e a' ->
  (z, LRHist (a' ': as) e a)
appLRS :: (z -> a' -> (z, x))
-> z -> LRHist as e a' -> (z, LRHist (a' : as) e a)
appLRS z -> a' -> (z, x)
f z
z LRHist as e a'
w =
  case LRHist as e a'
w of
    Rhi a'
a -> a' -> (z, LRHist (a' : as) e a)
k a'
a
    Rh a'
a LRHist as e a'
_ls -> a' -> (z, LRHist (a' : as) e a)
k a'
a
    Lh{} -> (z
z, LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w)
    LhSkip{} -> (z
z, LRHist as e a' -> LRHist (a' : as) e a
forall (as :: [*]) e a' a. LRHist as e a' -> LRHist (a' : as) e a
LhSkip LRHist as e a'
w)
 where
  k :: a' -> (z, LRHist (a' : as) e a)
k a'
a =
    let (z
z1, These e a
th) = (x -> These e a) -> (z, x) -> (z, These e a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a' -> x -> These e a
forall e a x b. ApTheseF e a x b => a -> x -> These e b
apTheseF a'
a) (z -> a' -> (z, x)
f z
z a'
a)
     in (z
z1, (e -> LRHist as e a' -> LRHist (a' : as) e a)
-> (a -> LRHist as e a' -> LRHist (a' : as) e a)
-> (e -> a -> LRHist as e a' -> LRHist (a' : as) e a)
-> These e a
-> LRHist as e a'
-> LRHist (a' : as) e a
forall a c b.
(a -> c) -> (b -> c) -> (a -> b -> c) -> These a b -> c
these e -> LRHist as e a' -> LRHist (a' : as) e a
forall e (as :: [*]) a' a.
e -> LRHist as e a' -> LRHist (a' : as) e a
Lh a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh ((a -> LRHist as e a' -> LRHist (a' : as) e a)
-> e -> a -> LRHist as e a' -> LRHist (a' : as) e a
forall a b. a -> b -> a
const a -> LRHist as e a' -> LRHist (a' : as) e a
forall a (as :: [*]) e a'.
a -> LRHist as e a' -> LRHist (a' : as) e a
Rh) These e a
th LRHist as e a'
w)

-- | apply a function to a 'LRHist' via 'boolEither'
appLRB ::
  forall e a a' as.
  (a' -> Bool) ->
  (a' -> e) ->
  (a' -> a) ->
  LRHist as e a' ->
  LRHist (a' ': as) e a
appLRB :: (a' -> Bool)
-> (a' -> e) -> (a' -> a) -> LRHist as e a' -> LRHist (a' : as) e a
appLRB a' -> Bool
p a' -> e
l a' -> a
r = (a' -> Either e a) -> LRHist as e a' -> LRHist (a' : as) e a
forall e a a' (as :: [*]) x.
ApTheseF e a' x a =>
(a' -> x) -> LRHist as e a' -> LRHist (a' : as) e a
appLR ((a' -> Bool) -> (a' -> e) -> (a' -> a) -> a' -> Either e a
forall a e b.
(a -> Bool) -> (a -> e) -> (a -> b) -> a -> Either e b
boolEither a' -> Bool
p a' -> e
l a' -> a
r)

-- | convenience method to apply 'appLR' to a container of 'LRHist' with state
traverseLRHist ::
  forall e a t a' as z.
  Traversable t =>
  (z -> a' -> (z, Either e a)) ->
  z ->
  t (LRHist as e a') ->
  (z, t (LRHist (a' ': as) e a))
traverseLRHist :: (z -> a' -> (z, Either e a))
-> z -> t (LRHist as e a') -> (z, t (LRHist (a' : as) e a))
traverseLRHist z -> a' -> (z, Either e a)
f = (z -> LRHist as e a' -> (z, LRHist (a' : as) e a))
-> z -> t (LRHist as e a') -> (z, t (LRHist (a' : as) e a))
forall (t :: * -> *) a b c.
Traversable t =>
(a -> b -> (a, c)) -> a -> t b -> (a, t c)
L.mapAccumL ((z -> a' -> (z, Either e a))
-> z -> LRHist as e a' -> (z, LRHist (a' : as) e a)
forall e a' x a (as :: [*]) z.
ApTheseF e a' x a =>
(z -> a' -> (z, x))
-> z -> LRHist as e a' -> (z, LRHist (a' : as) e a)
appLRS z -> a' -> (z, Either e a)
f)

-- | convenience method to apply 'appLRB' to a container of 'LRHist'
traverseLRHistB ::
  forall e a t a' as.
  Functor t =>
  (a' -> Bool) ->
  (a' -> e) ->
  (a' -> a) ->
  t (LRHist as e a') ->
  t (LRHist (a' ': as) e a)
traverseLRHistB :: (a' -> Bool)
-> (a' -> e)
-> (a' -> a)
-> t (LRHist as e a')
-> t (LRHist (a' : as) e a)
traverseLRHistB a' -> Bool
p a' -> e
l a' -> a
r = (LRHist as e a' -> LRHist (a' : as) e a)
-> t (LRHist as e a') -> t (LRHist (a' : as) e a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a' -> Bool)
-> (a' -> e) -> (a' -> a) -> LRHist as e a' -> LRHist (a' : as) e a
forall e a a' (as :: [*]).
(a' -> Bool)
-> (a' -> e) -> (a' -> a) -> LRHist as e a' -> LRHist (a' : as) e a
appLRB a' -> Bool
p a' -> e
l a' -> a
r)