{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module Symantic.Parser.Grammar.Combinators where
import Data.Function ((.))
import Data.Bool (Bool)
import Data.Char (Char)
import Data.Kind (Type)
import Data.Either (Either)

import Symantic.Base.Univariant

-- * Class 'Applicable'
class Applicable repr where
  type Pure repr :: Type -> Type
  pure :: Pure repr a -> repr a
  (<$>) :: Pure repr (a -> b) -> repr a -> repr b
  (<*>) :: repr (a -> b) -> repr a -> repr b
  (<*) :: repr a -> repr b -> repr a
  (*>) :: repr a -> repr b -> repr b
  default pure ::
    Liftable repr => Applicable (Unlift repr) =>
    Pure (Unlift repr) ~ Pure repr =>
    Pure repr a -> repr a
  default (<$>) ::
    Liftable repr => Applicable (Unlift repr) =>
    Pure (Unlift repr) ~ Pure repr =>
    Pure repr (a -> b) -> repr a -> repr b
  default (<*>) ::
    Liftable repr => Applicable (Unlift repr) =>
    repr (a -> b) -> repr a -> repr b
  default (<*) ::
    Liftable repr => Applicable (Unlift repr) =>
    repr a -> repr b -> repr a
  default (*>) ::
    Liftable repr => Applicable (Unlift repr) =>
    repr a -> repr b -> repr b
  pure = lift . pure
  (<$>) f = lift1 (f <$>)
  (<*>) = lift2 (<*>)
  (<*) = lift2 (<*)
  (*>) = lift2 (*>)
infixl 4 <$>, <*>, <*, *>

-- * Class 'Alternable'
class Alternable repr where
  (<|>) :: repr a -> repr a -> repr a
  empty :: repr a
  try :: repr a -> repr a
  default (<|>) ::
    Liftable repr => Alternable (Unlift repr) =>
    repr a -> repr a -> repr a
  default empty ::
    Liftable repr => Alternable (Unlift repr) =>
    repr a
  default try ::
    Liftable repr => Alternable (Unlift repr) =>
    repr a -> repr a
  (<|>) = lift2 (<|>)
  empty = lift empty
  try = lift1 try
infixl 3 <|>

-- * Class 'Selectable'
class Selectable repr where
  branch :: repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  default branch ::
    Liftable repr => Selectable (Unlift repr) =>
    repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  branch  = lift3 branch

-- * Class 'Charable'
class Charable repr where
  satisfy :: Pure repr (Char -> Bool) -> repr Char
  default satisfy ::
    Pure (Unlift repr) ~ Pure repr =>
    Liftable repr => Charable (Unlift repr) =>
    Pure repr (Char -> Bool) -> repr Char
  satisfy = lift . satisfy

-- * Class 'Lookable'
class Lookable repr where
  look :: repr a -> repr a
  negLook :: repr a -> repr ()
  default look    :: Liftable repr => Lookable (Unlift repr) => repr a -> repr a
  default negLook :: Liftable repr => Lookable (Unlift repr) => repr a -> repr ()
  look    = lift1 look
  negLook = lift1 negLook