{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Primus.LRHist (
LRHist (..),
rhi,
rh,
lh,
lhskip,
rhi',
rh',
lh',
lhskip',
lhToEitherI,
lhToEither,
lhToEitherTuples,
lhBool,
lhMaybe,
lhMaybe',
lhEither,
lhEither',
appLR,
appLRS,
appLRB,
traverseLRHistB,
traverseLRHist,
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
type LRHist :: [Type] -> Type -> Type -> Type
data LRHist as e a where
LhSkip ::
LRHist as e a' ->
LRHist (a' ': as) e a
Lh ::
e ->
LRHist as e a' ->
LRHist (a' ': as) e a
Rhi ::
a ->
LRHist '[] e a
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
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
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
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
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
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)
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)
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)
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
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 ())
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
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
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
type OrgAT :: [Type] -> Type -> Type
type family OrgAT as a where
OrgAT '[] a' = a'
OrgAT (a ': as) _ = OrgAT as a
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
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 RHistT :: Type -> [Type] -> Type
type family RHistT a as where
RHistT a '[] = (a, ())
RHistT a (a' ': as) = (a, RHistT a' as)
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"
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"
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)
)
)
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
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
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
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
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
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
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
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)
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)
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)
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)