-- 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 (ErrorItem tok)
{-# LANGUAGE StandaloneDeriving #-} -- For Show (ErrorItem (InputToken inp))
{-# LANGUAGE TemplateHaskell #-}
-- | Semantic of the grammar combinators used to express parsers,
-- in the convenient tagless-final encoding.
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.Ord (Ord)
import Data.Proxy (Proxy(..))
import Data.String (String)
import GHC.TypeLits (KnownSymbol)
import Text.Show (Show(..))
import qualified Data.Functor as Functor
import qualified Data.List as List
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

-- * Class 'CombAlternable'
class CombAlternable 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 => CombAlternable (Sym.Output repr) =>
    repr a -> repr a -> repr a
  default empty ::
    Sym.Liftable repr => CombAlternable (Sym.Output repr) =>
    repr a
  default try ::
    Sym.Liftable1 repr => CombAlternable (Sym.Output 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.
  (<+>) :: CombApplicable repr => CombAlternable repr => repr a -> repr b -> repr (Either a b)
  p <+> q = H.left <$> p <|> H.right <$> q
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 <$>, <&>, <$, $>, <*>, <*, *>, <**>

{-# 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
  -}

{-
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.trans a) ps (Sym.trans 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)

-- * Class 'CombSatisfiable'
class CombSatisfiable tok repr where
  satisfy :: [ErrorItem tok] -> TermGrammar (tok -> Bool) -> repr tok
  default satisfy ::
    Sym.Liftable repr => CombSatisfiable tok (Sym.Output repr) =>
    [ErrorItem tok] ->
    TermGrammar (tok -> Bool) -> repr tok
  satisfy es = Sym.lift . satisfy es

  item :: repr tok
  item = satisfy [] (H.const H..@ H.bool True)

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

oneOf ::
  TH.Lift tok => Eq tok =>
  CombSatisfiable tok repr =>
  [tok] -> repr tok
oneOf ts = satisfy [ErrorItemLabel "oneOf"]
  (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 (ErrorItemToken Functor.<$> cs) (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 (\alt acc ->
  \inp -> [|| alt == $$inp || $$(acc inp) ||])
  (const [||False||])

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

char ::
  CombApplicable repr => CombSatisfiable Char repr =>
  Char -> repr Char
char c = satisfy [ErrorItemToken c] (H.eq H..@ H.char c) $> H.char c
-- char c = satisfy [ErrorItemToken c] (H.eq H..@ H.qual H..@ H.char c) $> H.char c

anyChar :: CombSatisfiable Char repr => repr Char
anyChar = satisfy [] (H.const H..@ H.bool True)

token ::
  TH.Lift tok => Show tok => Eq tok =>
  CombApplicable repr => CombSatisfiable tok repr =>
  tok -> repr tok
token tok = satisfy [ErrorItemToken tok] (H.eq H..@ H.char tok) $> H.char tok
-- token tok = satisfy [ErrorItemToken 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

-- * Class 'CombThrowable'
class CombThrowable repr where
  throw :: KnownSymbol lbl => Proxy lbl -> repr a
  default throw ::
    forall lbl a.
    Sym.Liftable repr => CombThrowable (Sym.Output repr) =>
    KnownSymbol lbl => Proxy lbl -> repr a
  throw lbl = Sym.lift (throw lbl)

-- ** Type 'ErrorItem'
data ErrorItem tok
  =  ErrorItemToken tok
  |  ErrorItemLabel String
  |  ErrorItemHorizon Int
  |  ErrorItemEnd
deriving instance Eq tok => Eq (ErrorItem tok)
deriving instance Ord tok => Ord (ErrorItem tok)
deriving instance Show tok => Show (ErrorItem tok)
deriving instance TH.Lift tok => TH.Lift (ErrorItem tok)

-- * 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 [ErrorItemAny] (H.const H..@ H.bool True))
             -- (item @Char)

-- 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)
-}