-- The default type signature of type class methods are changed
-- to introduce a Liftable constraint and the same type class but on the 'Output' repr,
-- this setup avoids to define the method with boilerplate code when its default
-- definition with lift* and 'trans' does what is expected by an instance
-- of the type class. This is almost as explained in:
-- https://ro-che.info/articles/2016-02-03-finally-tagless-boilerplate
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveLift #-} -- For TH.Lift (Exception tok)
{-# LANGUAGE PatternSynonyms #-} -- For Failure
{-# LANGUAGE StandaloneDeriving #-} -- For Show (Exception (InputToken inp))
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-} -- For unSomeFailure
-- | Semantic of the grammar combinators used to express parsers,
-- in the convenient tagless-final encoding.
module Symantic.Parser.Grammar.Combinators where

import Data.Proxy (Proxy(..))
import Control.Monad (Monad(..))
-- import Data.Set (Set)
-- import GHC.TypeLits (KnownSymbol)
import Data.Bool (Bool(..), not, (||))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Ord (Ord(..))
import Data.Function ((.), flip, const)
import Data.Int (Int)
import Data.Kind (Type, Constraint)
import Data.Maybe (Maybe(..))
import Data.Set (Set)
import Data.String (String)
import Text.Show (Show(..))
import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..), SomeTypeRep(..))
import qualified Data.Functor as Functor
import qualified Data.List as List
import qualified Data.Set as Set
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH

import qualified Symantic.Univariant.Trans as Sym
import qualified Symantic.Parser.Haskell as H

-- * Type 'TermGrammar'
type TermGrammar = H.Term H.ValueCode

-- * Type 'ReprComb'
type ReprComb = Type -> Type

code :: TH.Lift a => a -> TermGrammar a
code x = H.Term (H.ValueCode x [||x||])

-- * Class 'CombAlternable'
class CombAlternable repr where
  -- | @('alt' es l r)@ parses @(l)@ and return its return value or,
  -- if it fails with an 'Exception' within @(es)@,
  -- parses @(r)@ from where @(l)@ has left the input stream,
  -- and returns its return value,
  -- otherwise throw the 'Exception' again.
  alt :: Exception -> repr a -> repr a -> repr a
  throw :: ExceptionLabel -> repr a
  -- | @('try' ra)@ records the input stream position,
  -- then parses like @(ra)@ and either returns its value it it succeeds or fails
  -- if it fails but with a reset of the input stream to the recorded position.
  -- Generally used on the first alternative: @('try' rl '<|>' rr)@.
  try :: repr a -> repr a
  default alt ::
    Sym.Liftable2 repr => CombAlternable (Sym.Output repr) =>
    Exception -> repr a -> repr a -> repr a
  default throw ::
    Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
    ExceptionLabel -> repr a
  default try ::
    Sym.Liftable1 repr => CombAlternable (Sym.Output repr) =>
    repr a -> repr a
  alt = Sym.lift2 . alt
  throw = Sym.lift . throw
  try = Sym.lift1 try

  failure :: SomeFailure -> repr a
  default failure ::
    Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
    SomeFailure -> repr a
  failure = Sym.lift . failure

  -- | @(empty)@ parses nothing, always failing to return a value.
  empty :: repr a
  empty = failure (SomeFailure FailureEmpty)

data instance Failure CombAlternable
  = FailureEmpty
  deriving (Eq, Ord, Show, TH.Lift)

-- ** Data family 'Failure'
-- | 'Failure's of the 'Grammar'.
-- This is an extensible data-type.
data family Failure
  (comb :: ReprComb -> Constraint)
  :: Type

{-
-- | Convenient utility to pattern-match a 'SomeFailure'.
pattern Failure :: Typeable comb => Failure comb -> SomeFailure
pattern Failure x <- (unSomeFailure -> Just x)
-}

-- ** Type 'SomeFailure'
data SomeFailure =
  forall comb.
  ({-Trans (Failure comb repr) repr,-}
    Eq (Failure comb)
  , Show (Failure comb)
  , TH.Lift (Failure comb)
  , Typeable comb
  ) =>
  SomeFailure (Failure comb {-repr a-})
instance Eq SomeFailure where
  SomeFailure (_x::Failure x) == SomeFailure (_y::Failure y) =
    case typeRep @x `eqTypeRep` typeRep @y of
      Just HRefl -> True
      Nothing -> False
instance Ord SomeFailure where
  SomeFailure (_x::Failure x) `compare` SomeFailure (_y::Failure y) =
    SomeTypeRep (typeRep @x) `compare`
    SomeTypeRep (typeRep @y)
instance Show SomeFailure where
  showsPrec p (SomeFailure x) = showsPrec p x
instance TH.Lift SomeFailure where
  liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]

{-
instance Trans (SomeFailure repr) repr where
  trans (SomeFailure x) = trans x
-}

-- | @(unSomeFailure c :: 'Maybe' ('Failure' comb repr a))@
-- extract the data-constructor from the given 'SomeFailure'
-- iif. it belongs to the @('Failure' comb repr a)@ data-instance.
unSomeFailure :: forall comb.  Typeable comb => SomeFailure -> Maybe (Failure comb)
unSomeFailure (SomeFailure (c::Failure c)) =
  case typeRep @comb `eqTypeRep` typeRep @c of
    Just HRefl -> Just c
    Nothing -> Nothing

-- ** Type 'Exception'
data Exception
  =  ExceptionLabel ExceptionLabel
  |  ExceptionFailure
  deriving (Eq, Ord, Show, TH.Lift)
type ExceptionLabel = String
-- type Exceptions = Set Exception

-- | Like @('<|>')@ but with different returning types for the alternatives,
-- and a return value wrapped in an 'Either' accordingly.
(<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
p <+> q = H.left <$> p <|> H.right <$> q

(<|>) :: CombAlternable repr => repr a -> repr a -> repr a
(<|>) = alt ExceptionFailure

infixl 3 <|>, <+>

optionally :: CombApplicable repr => CombAlternable repr => repr a -> TermGrammar b -> repr b
optionally p x = p $> x <|> pure x

optional :: CombApplicable repr => CombAlternable repr => repr a -> repr ()
optional = flip optionally H.unit

option :: CombApplicable repr => CombAlternable repr => TermGrammar a -> repr a -> repr a
option x p = p <|> pure x

choice :: CombAlternable repr => [repr a] -> repr a
choice = List.foldr (<|>) empty
 -- FIXME: Here hlint suggests to use Data.Foldable.asum,
 -- but at this point there is no asum for our own (<|>)

maybeP :: CombApplicable repr => CombAlternable repr => repr a -> repr (Maybe a)
maybeP p = option H.nothing (H.just <$> p)

manyTill :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr [a]
manyTill p end = let go = end $> H.nil <|> p <:> go in go


-- * Class 'CombApplicable'
-- | This is like the usual 'Functor' and 'Applicative' type classes
-- from the @base@ package, but using @('TermGrammar' a)@ instead of just @(a)@
-- to be able to use and pattern match on some usual terms of type @(a)@ (like 'H.id')
-- and thus apply some optimizations.
-- @(repr)@, for "representation", is the usual tagless-final abstraction
-- over the many semantics that this syntax (formed by the methods
-- of type class like this one) will be interpreted.
class CombApplicable repr where
  -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
  (<$>) :: TermGrammar (a -> b) -> repr a -> repr b
  (<$>) f = (pure f <*>)

  -- | Like '<$>' but with its arguments 'flip'-ped.
  (<&>) :: repr a -> TermGrammar (a -> b) -> repr b
  (<&>) = flip (<$>)

  -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
  (<$) :: TermGrammar a -> repr b -> repr a
  (<$) x = (pure x <*)

  -- | @(ra '$>' b)@ parses like @(ra)@ but discards its returned value by replacing it with @(b)@.
  ($>) :: repr a -> TermGrammar b -> repr b
  ($>) = flip (<$)

  -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
  pure :: TermGrammar a -> repr a
  default pure ::
    Sym.Liftable repr => CombApplicable (Sym.Output repr) =>
    TermGrammar a -> repr a
  pure = Sym.lift . pure

  -- | @(ra2b '<*>' ra)@ parses sequentially @(ra2b)@ and then @(ra)@,
  -- and returns the application of the function returned by @(ra2b)@
  -- to the value returned by @(ra)@.
  (<*>) :: repr (a -> b) -> repr a -> repr b
  default (<*>) ::
    Sym.Liftable2 repr => CombApplicable (Sym.Output repr) =>
    repr (a -> b) -> repr a -> repr b
  (<*>) = Sym.lift2 (<*>)

  -- | @('liftA2' a2b2c ra rb)@ parses sequentially @(ra)@ and then @(rb)@,
  -- and returns the application of @(a2b2c)@ to the values returned by those parsers.
  liftA2 :: TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
  liftA2 f x = (<*>) (f <$> x)

  -- | @(ra '<*' rb)@ parses sequentially @(ra)@ and then @(rb)@,
  -- and returns like @(ra)@, discarding the return value of @(rb)@.
  (<*) :: repr a -> repr b -> repr a
  (<*) = liftA2 H.const

  -- | @(ra '*>' rb)@ parses sequentially @(ra)@ and then @(rb)@,
  -- and returns like @(rb)@, discarding the return value of @(ra)@.
  (*>) :: repr a -> repr b -> repr b
  x *> y = (H.id <$ x) <*> y

  -- | Like '<*>' but with its arguments 'flip'-ped.
  (<**>) :: repr a -> repr (a -> b) -> repr b
  (<**>) = liftA2 (H.flip H..@ (H.$))
  {-
  (<**>) :: repr a -> repr (a -> b) -> repr b
  (<**>) = liftA2 (\a f -> f a)
  -}
infixl 4 <$>, <&>, <$, $>, <*>, <*, *>, <**>
data instance Failure CombApplicable

{-# INLINE (<:>) #-}
infixl 4 <:>
(<:>) :: CombApplicable repr => repr a -> repr [a] -> repr [a]
(<:>) = liftA2 H.cons

sequence :: CombApplicable repr => [repr a] -> repr [a]
sequence = List.foldr (<:>) (pure H.nil)

traverse :: CombApplicable repr => (a -> repr b) -> [a] -> repr [b]
traverse f = sequence . List.map f
 -- FIXME: Here hlint suggests to use Control.Monad.mapM,
 -- but at this point there is no mapM for our own sequence

repeat :: CombApplicable repr => Int -> repr a -> repr [a]
repeat n p = traverse (const p) [1..n]

between :: CombApplicable repr => repr o -> repr c -> repr a -> repr a
between open close p = open *> p <* close

void :: CombApplicable repr => repr a -> repr ()
void p = p *> unit

unit :: CombApplicable repr => repr ()
unit = pure H.unit

-- * Class 'CombFoldable'
class CombFoldable repr where
  chainPre :: repr (a -> a) -> repr a -> repr a
  chainPost :: repr a -> repr (a -> a) -> repr a
  {-
  default chainPre ::
    Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
    repr (a -> a) -> repr a -> repr a
  default chainPost ::
    Sym.Liftable2 repr => CombFoldable (Sym.Output repr) =>
    repr a -> repr (a -> a) -> repr a
  chainPre = Sym.lift2 chainPre
  chainPost = Sym.lift2 chainPost
  -}
  default chainPre ::
    CombApplicable repr =>
    CombAlternable repr =>
    repr (a -> a) -> repr a -> repr a
  default chainPost ::
    CombApplicable repr =>
    CombAlternable repr =>
    repr a -> repr (a -> a) -> repr a
  chainPre op p = go <*> p where go = (H..) <$> op <*> go <|> pure H.id
  chainPost p op = p <**> go where go = (H..) <$> op <*> go <|> pure H.id
  {-
  chainPre op p = flip (foldr ($)) <$> many op <*> p
  chainPost p op = foldl' (flip ($)) <$> p <*> many op
  -}
data instance Failure CombFoldable

{-
conditional :: CombSelectable repr => [(TermGrammar (a -> Bool), repr b)] -> repr a -> repr b -> repr b
conditional cs p def = match p fs qs def
  where (fs, qs) = List.unzip cs
-}

-- Parser Folds
pfoldr ::
 CombApplicable repr => CombFoldable repr =>
 TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)

pfoldr1 ::
 CombApplicable repr => CombFoldable repr =>
 TermGrammar (a -> b -> b) -> TermGrammar b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p

pfoldl ::
 CombApplicable repr => CombFoldable repr =>
 TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
pfoldl f k p = chainPost (pure k) ((H.flip <$> pure f) <*> p)

pfoldl1 ::
 CombApplicable repr => CombFoldable repr =>
 TermGrammar (b -> a -> b) -> TermGrammar b -> repr a -> repr b
pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((H.flip <$> pure f) <*> p)

-- Chain Combinators
chainl1' ::
 CombApplicable repr => CombFoldable repr =>
 TermGrammar (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
chainl1' f p op = chainPost (f <$> p) (H.flip <$> op <*> p)

chainl1 ::
 CombApplicable repr => CombFoldable repr =>
 repr a -> repr (a -> a -> a) -> repr a
chainl1 = chainl1' H.id

{-
chainr1' :: ParserOps rep => rep (a -> b) -> repr a -> repr (a -> b -> b) -> repr b
chainr1' f p op = newRegister_ H.id $ \acc ->
  let go = bind p $ \x ->
           modify acc (H.flip (H..@) <$> (op <*> x)) *> go
       <|> f <$> x
  in go <**> get acc

chainr1 :: repr a -> repr (a -> a -> a) -> repr a
chainr1 = chainr1' H.id

chainr :: repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
chainr p op x = option x (chainr1 p op)
-}

chainl ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr (a -> a -> a) -> TermGrammar a -> repr a
chainl p op x = option x (chainl1 p op)

-- Derived Combinators
many ::
 CombApplicable repr => CombFoldable repr =>
 repr a -> repr [a]
many = pfoldr H.cons H.nil

manyN ::
 CombApplicable repr => CombFoldable repr =>
 Int -> repr a -> repr [a]
manyN n p = List.foldr (const (p <:>)) (many p) [1..n]

some ::
 CombApplicable repr => CombFoldable repr =>
 repr a -> repr [a]
some = manyN 1

skipMany ::
 CombApplicable repr => CombFoldable repr =>
 repr a -> repr ()
--skipMany p = let skipManyp = p *> skipManyp <|> unit in skipManyp
skipMany = void . pfoldl H.const H.unit -- the void here will encourage the optimiser to recognise that the register is unused

skipManyN ::
 CombApplicable repr => CombFoldable repr =>
 Int -> repr a -> repr ()
skipManyN n p = List.foldr (const (p *>)) (skipMany p) [1..n]

skipSome ::
 CombApplicable repr => CombFoldable repr =>
 repr a -> repr ()
skipSome = skipManyN 1

sepBy ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr b -> repr [a]
sepBy p sep = option H.nil (sepBy1 p sep)

sepBy1 ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr b -> repr [a]
sepBy1 p sep = p <:> many (sep *> p)

endBy ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr b -> repr [a]
endBy p sep = many (p <* sep)

endBy1 ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr b -> repr [a]
endBy1 p sep = some (p <* sep)

sepEndBy ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr b -> repr [a]
sepEndBy p sep = option H.nil (sepEndBy1 p sep)

sepEndBy1 ::
 CombApplicable repr => CombAlternable repr => CombFoldable repr =>
 repr a -> repr b -> repr [a]
sepEndBy1 p sep =
  let seb1 = p <**> (sep *> (H.flip H..@ H.cons <$> option H.nil seb1)
                 <|> pure (H.flip H..@ H.cons H..@ H.nil))
  in seb1

{-
sepEndBy1 :: repr a -> repr b -> repr [a]
sepEndBy1 p sep = newRegister_ H.id $ \acc ->
  let go = modify acc ((H.flip (H..)) H..@ H.cons <$> p)
         *> (sep *> (go <|> get acc) <|> get acc)
  in go <*> pure H.nil
-}

-- * Class 'CombMatchable'
class CombMatchable repr where
  conditional ::
    Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
  default conditional ::
    Sym.Unliftable repr => Sym.Liftable1 repr => CombMatchable (Sym.Output repr) =>
    Eq a => repr a -> [TermGrammar (a -> Bool)] -> [repr b] -> repr b -> repr b
  conditional a ps bs = Sym.lift1 (conditional (Sym.unlift a) ps (Sym.unlift Functor.<$> bs))

  match :: Eq a => repr a -> [TermGrammar a] -> (TermGrammar a -> repr b) -> repr b -> repr b
  match a as a2b = conditional a ((H.eq H..@) Functor.<$> as) (a2b Functor.<$> as)
  -- match a as a2b = conditional a (((H.eq H..@ H.qual) H..@) Functor.<$> as) (a2b Functor.<$> as)
data instance Failure CombMatchable

-- * Class 'CombSatisfiable'
class CombSatisfiable tok repr where
  satisfy :: TermGrammar (tok -> Bool) -> repr tok
  satisfy = satisfyOrFail Set.empty
  satisfyOrFail ::
    Set SomeFailure ->
    TermGrammar (tok -> Bool) -> repr tok
  default satisfyOrFail ::
    Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
    Set SomeFailure ->
    TermGrammar (tok -> Bool) -> repr tok
  satisfyOrFail fs = Sym.lift . satisfyOrFail fs

data instance Failure (CombSatisfiable tok)
  =  FailureAny
  |  FailureHorizon Int -- FIXME: use Natural?
  |  FailureLabel String
  |  FailureToken tok
  deriving (Eq, Show, Typeable)
inputTokenProxy :: TH.Name
inputTokenProxy = TH.mkName "inputToken"
instance TH.Lift tok => TH.Lift (Failure (CombSatisfiable tok)) where
  liftTyped :: forall m. TH.Quote m => Failure (CombSatisfiable tok) -> TH.Code m (Failure (CombSatisfiable tok))
  liftTyped x = [||
    case
      $$(let inputToken :: TH.Code m (Proxy tok) =
              TH.unsafeCodeCoerce (return (TH.VarE inputTokenProxy))
      in inputToken) of
      (Proxy :: Proxy tok') ->
        $$(case x of
          FailureAny -> [|| FailureAny @tok' ||]
          FailureHorizon h -> [|| FailureHorizon @tok' h ||]
          FailureLabel lbl -> [|| FailureLabel @tok' lbl ||]
          FailureToken tok -> [|| FailureToken $$(TH.liftTyped tok) ||]
        )
    ||]

char ::
  CombApplicable repr =>
  CombSatisfiable Char repr =>
  Char -> repr Char
char c = satisfyOrFail (Set.singleton (SomeFailure (FailureToken c)))
                       (H.eq H..@ H.char c) $> H.char c

item :: forall tok repr.
  Eq tok => Show tok => Typeable tok => TH.Lift tok =>
  CombSatisfiable tok repr => repr tok
item = satisfyOrFail (Set.singleton (SomeFailure (FailureAny @tok)))
                     (H.const H..@ H.bool True)

anyChar ::
  CombAlternable repr =>
  CombSatisfiable Char repr =>
  repr Char
anyChar = item

string ::
  CombApplicable repr => CombAlternable repr =>
  CombSatisfiable Char repr =>
  [Char] -> repr [Char]
string = try . traverse char

oneOf ::
  Eq tok => Show tok => Typeable tok => TH.Lift tok =>
  CombSatisfiable tok repr =>
  [tok] -> repr tok
oneOf ts = satisfyOrFail
  (Set.fromList (SomeFailure . FailureToken Functor.<$> ts))
  (Sym.trans H.ValueCode
    { value = (`List.elem` ts)
    , code = [||\t -> $$(ofChars ts [||t||])||] })

noneOf ::
  TH.Lift tok => Eq tok =>
  CombSatisfiable tok repr =>
  [tok] -> repr tok
noneOf cs = satisfy (Sym.trans H.ValueCode
  { value = not . (`List.elem` cs)
  , code = [||\c -> not $$(ofChars cs [||c||])||]
  })

ofChars ::
  TH.Lift tok => Eq tok =>
  {-alternatives-}[tok] ->
  {-input-}TH.CodeQ tok ->
  TH.CodeQ Bool
ofChars = List.foldr (\tok acc ->
  \inp -> [|| tok == $$inp || $$(acc inp) ||])
  (const [||False||])

more ::
  CombAlternable repr =>
  CombApplicable repr =>
  CombSatisfiable Char repr =>
  CombLookable repr => repr ()
more = look (void (item @Char))

token ::
  TH.Lift tok => Show tok => Eq tok =>
  CombAlternable repr =>
  CombApplicable repr =>
  CombSatisfiable tok repr =>
  tok -> repr tok
token tok = satisfy (H.eq H..@ H.char tok) $> H.char tok
-- token tok = satisfy [ExceptionToken tok] (H.eq H..@ H.qual H..@ H.char tok) $> H.char tok

tokens ::
  TH.Lift tok => Eq tok => Show tok =>
  CombApplicable repr => CombAlternable repr =>
  CombSatisfiable tok repr => [tok] -> repr [tok]
tokens = try . traverse token

-- * Class 'CombSelectable'
class CombSelectable repr where
  branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  default branch ::
    Sym.Liftable3 repr => CombSelectable (Sym.Output repr) =>
    repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  branch = Sym.lift3 branch
data instance Failure CombSelectable

-- * Class 'CombLookable'
class CombLookable repr where
  look :: repr a -> repr a
  negLook :: repr a -> repr ()
  default look :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr a
  default negLook :: Sym.Liftable1 repr => CombLookable (Sym.Output repr) => repr a -> repr ()
  look = Sym.lift1 look
  negLook = Sym.lift1 negLook

  eof :: repr ()
  eof = Sym.lift eof
  default eof :: Sym.Liftable repr => CombLookable (Sym.Output repr) => repr ()
  -- eof = negLook (satisfy @Char (H.const H..@ H.bool True))
             -- (item @Char)
data instance Failure CombLookable
  = FailureEnd
  deriving (Eq, Show, Typeable, TH.Lift)

-- Composite Combinators
-- someTill :: repr a -> repr b -> repr [a]
-- someTill p end = negLook end *> (p <:> manyTill p end)

{-
constp :: CombApplicable repr => repr a -> repr (b -> a)
constp = (H.const <$>)


-- Alias Operations
infixl 1 >>
(>>) :: CombApplicable repr => repr a -> repr b -> repr b
(>>) = (*>)

-- Monoidal Operations

infixl 4 <~>
(<~>) :: CombApplicable repr => repr a -> repr b -> repr (a, b)
(<~>) = liftA2 (H.runtime (,))

infixl 4 <~
(<~) :: CombApplicable repr => repr a -> repr b -> repr a
(<~) = (<*)

infixl 4 ~>
(~>) :: CombApplicable repr => repr a -> repr b -> repr b
(~>) = (*>)

-- Lift Operations
liftA2 ::
 CombApplicable repr =>
 TermGrammar (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)

liftA3 ::
 CombApplicable repr =>
 TermGrammar (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
liftA3 f a b c = liftA2 f a b <*> c

-}

{-
-- Combinators interpreters for 'Sym.Any'.
instance CombApplicable repr => CombApplicable (Sym.Any repr)
instance CombSatisfiable repr => CombSatisfiable (Sym.Any repr)
instance CombAlternable repr => CombAlternable (Sym.Any repr)
instance CombSelectable repr => CombSelectable (Sym.Any repr)
instance CombMatchable repr => CombMatchable (Sym.Any repr)
instance CombLookable repr => CombLookable (Sym.Any repr)
instance CombFoldable repr => CombFoldable (Sym.Any repr)
-}