{-# LANGUAGE DefaultSignatures #-}
-- The default type signature of type class methods are changed to introduce a Liftable constraint and the same type class but on the 'Unlift' 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 TemplateHaskell #-}
module Symantic.Parser.Grammar.Combinators where

import Data.Bool (Bool(..), not, (||))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Function ((.), flip, const)
import Data.Int (Int)
import Data.Maybe (Maybe(..))
import Data.String (String)
import Language.Haskell.TH (TExpQ)
import qualified Data.Functor as Functor
import qualified Data.List as List

import qualified Symantic.Univariant.Trans as Sym
import qualified Symantic.Parser.Staging as Hask

-- * Class 'Applicable'
-- | This is like the usual 'Functor' and 'Applicative' type classes from the @base@ package, but using @('Hask.Haskell' a)@ instead of just @(a)@ to be able to use and pattern match on some usual terms of type @(a)@ (like 'Hask.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 Applicable repr where
  -- | @(a2b '<$>' ra)@ parses like @(ra)@ but maps its returned value with @(a2b)@.
  (<$>) :: Hask.Haskell (a -> b) -> repr a -> repr b
  (<$>) f = (pure f <*>)

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

  -- | @(a '<$' rb)@ parses like @(rb)@ but discards its returned value by replacing it with @(a)@.
  (<$) :: Hask.Haskell 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 -> Hask.Haskell b -> repr b
  ($>) = flip (<$)

  -- | @('pure' a)@ parses the empty string, always succeeding in returning @(a)@.
  pure :: Hask.Haskell a -> repr a
  default pure ::
    Sym.Liftable repr => Applicable (Sym.Unlift repr) =>
    Hask.Haskell 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 => Applicable (Sym.Unlift 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 :: Hask.Haskell (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 Hask.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 = (Hask.id <$ x) <*> y

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

-- * Class 'Alternable'
class Alternable repr where
  -- | @(rl '<|>' rr)@ parses @(rl)@ and return its return value or, if it fails, parses @(rr)@ from where @(rl)@ has left the input stream, and returns its return value.
  (<|>) :: repr a -> repr a -> repr a
  -- | @(empty)@ parses nothing, always failing to return a value.
  empty :: 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 (<|>) ::
    Sym.Liftable2 repr => Alternable (Sym.Unlift repr) =>
    repr a -> repr a -> repr a
  default empty ::
    Sym.Liftable repr => Alternable (Sym.Unlift repr) =>
    repr a
  default try ::
    Sym.Liftable1 repr => Alternable (Sym.Unlift repr) =>
    repr a -> repr a
  (<|>) = Sym.lift2 (<|>)
  empty = Sym.lift empty
  try = Sym.lift1 try
  -- | Like @('<|>')@ but with different returning types for the alternatives, and a return value wrapped in an 'Either' accordingly.
  (<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
  p <+> q = Hask.left <$> p <|> Hask.right <$> q
infixl 3 <|>, <+>

optionally :: Applicable repr => Alternable repr => repr a -> Hask.Haskell b -> repr b
optionally p x = p $> x <|> pure x

optional :: Applicable repr => Alternable repr => repr a -> repr ()
optional = flip optionally Hask.unit

option :: Applicable repr => Alternable repr => Hask.Haskell a -> repr a -> repr a
option x p = p <|> pure x

choice :: Alternable 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 :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
maybeP p = option Hask.nothing (Hask.just <$> p)

manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
manyTill p end = let go = end $> Hask.nil <|> p <:> go in go

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

-- * Class 'Matchable'
class Matchable repr where
  conditional ::
    Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
  default conditional ::
    Sym.Unliftable repr => Sym.Liftable2 repr => Matchable (Sym.Unlift repr) =>
    Eq a => [Hask.Haskell (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
  conditional cs bs = Sym.lift2 (conditional cs (Sym.trans Functor.<$> bs))

  match :: Eq a => [Hask.Haskell a] -> repr a -> (Hask.Haskell a -> repr b) -> repr b -> repr b
  match as a a2b = conditional (Hask.eq Functor.<$> as) (a2b Functor.<$> as) a

-- * Class 'Foldable'
class Foldable repr where
  chainPre :: repr (a -> a) -> repr a -> repr a
  chainPost :: repr a -> repr (a -> a) -> repr a
  default chainPre ::
    Sym.Liftable2 repr => Foldable (Sym.Unlift repr) =>
    repr (a -> a) -> repr a -> repr a
  default chainPost ::
    Sym.Liftable2 repr => Foldable (Sym.Unlift repr) =>
    repr a -> repr (a -> a) -> repr a
  chainPre = Sym.lift2 chainPre
  chainPost = Sym.lift2 chainPost

{-
conditional :: Selectable repr => [(Hask.Haskell (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
-}

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

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

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

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

traverse :: Applicable 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 :: Applicable repr => Int -> repr a -> repr [a]
repeat n p = traverse (const p) [1..n]

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

string :: Applicable repr => Charable repr => String -> repr String
string = traverse char

-- oneOf :: [Char] -> repr Char
-- oneOf cs = satisfy (makeQ (flip elem cs) [||\c -> $$(ofChars cs [||c||])||])

noneOf :: Charable repr => String -> repr Char
noneOf cs = satisfy (Hask.Haskell Hask.ValueCode{..})
  where
  value = Hask.Value (not . flip List.elem cs)
  code = Hask.Code [||\c -> not $$(ofChars cs [||c||])||]

ofChars :: String -> TExpQ Char -> TExpQ Bool
ofChars = List.foldr (\c rest qc -> [|| c == $$qc || $$(rest qc) ||]) (const [||False||])

token :: Applicable repr => Alternable repr => Charable repr => String -> repr String
token = try . string

eof :: Charable repr => Lookable repr => repr ()
eof = negLook item

more :: Applicable repr => Charable repr => Lookable repr => repr ()
more = look (void item)

char :: Applicable repr => Charable repr => Char -> repr Char
char c = satisfy (Hask.eq (Hask.char c)) $> Hask.char c

item :: Charable repr => repr Char
item = satisfy (Hask.const Hask..@ Hask.bool True)

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

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

unit :: Applicable repr => repr ()
unit = pure Hask.unit

{-

constp :: Applicable repr => repr a -> repr (b -> a)
constp = (Hask.const <$>)


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

-- Monoidal Operations

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

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

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

-- Lift Operations
liftA2 ::
 Applicable repr =>
 Hask.Haskell (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)

liftA3 ::
 Applicable repr =>
 Hask.Haskell (a -> b -> c -> d) -> repr a -> repr b -> repr c -> repr d
liftA3 f a b c = liftA2 f a b <*> c

-}

-- Parser Folds
pfoldr ::
 Applicable repr => Foldable repr =>
 Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)

pfoldr1 ::
 Applicable repr => Foldable repr =>
 Hask.Haskell (a -> b -> b) -> Hask.Haskell b -> repr a -> repr b
pfoldr1 f k p = f <$> p <*> pfoldr f k p

pfoldl ::
 Applicable repr => Foldable repr =>
 Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
pfoldl f k p = chainPost (pure k) ((Hask.flip <$> pure f) <*> p)

pfoldl1 ::
 Applicable repr => Foldable repr =>
 Hask.Haskell (b -> a -> b) -> Hask.Haskell b -> repr a -> repr b
pfoldl1 f k p = chainPost (f <$> pure k <*> p) ((Hask.flip <$> pure f) <*> p)

-- Chain Combinators
chainl1' ::
 Applicable repr => Foldable repr =>
 Hask.Haskell (a -> b) -> repr a -> repr (b -> a -> b) -> repr b
chainl1' f p op = chainPost (f <$> p) (Hask.flip <$> op <*> p)

chainl1 ::
 Applicable repr => Foldable repr =>
 repr a -> repr (a -> a -> a) -> repr a
chainl1 = chainl1' Hask.id

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

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

chainr :: repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
chainr p op x = option x (chainr1 p op)
-}

chainl ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr (a -> a -> a) -> Hask.Haskell a -> repr a
chainl p op x = option x (chainl1 p op)

-- Derived Combinators
many ::
 Applicable repr => Foldable repr =>
 repr a -> repr [a]
many = pfoldr Hask.cons Hask.nil

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

some ::
 Applicable repr => Foldable repr =>
 repr a -> repr [a]
some = manyN 1

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

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

skipSome ::
 Applicable repr => Foldable repr =>
 repr a -> repr ()
skipSome = skipManyN 1

sepBy ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr b -> repr [a]
sepBy p sep = option Hask.nil (sepBy1 p sep)

sepBy1 ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr b -> repr [a]
sepBy1 p sep = p <:> many (sep *> p)

endBy ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr b -> repr [a]
endBy p sep = many (p <* sep)

endBy1 ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr b -> repr [a]
endBy1 p sep = some (p <* sep)

sepEndBy ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr b -> repr [a]
sepEndBy p sep = option Hask.nil (sepEndBy1 p sep)

sepEndBy1 ::
 Applicable repr => Alternable repr => Foldable repr =>
 repr a -> repr b -> repr [a]
sepEndBy1 p sep =
  let seb1 = p <**> (sep *> (Hask.flip Hask..@ Hask.cons <$> option Hask.nil seb1)
                 <|> pure (Hask.flip Hask..@ Hask.cons Hask..@ Hask.nil))
  in seb1

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

-- Combinators interpreters for 'Sym.Any'.
instance Applicable repr => Applicable (Sym.Any repr)
instance Charable repr => Charable (Sym.Any repr)
instance Alternable repr => Alternable (Sym.Any repr)
instance Selectable repr => Selectable (Sym.Any repr)
instance Matchable repr => Matchable (Sym.Any repr)
instance Lookable repr => Lookable (Sym.Any repr)
instance Foldable repr => Foldable (Sym.Any repr)