{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module Symantic.Parser.Grammar.Combinators where
import Data.Function ((.), flip, const)
import Data.Bool (Bool(..), not, (||))
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq(..))
import Data.Int (Int)
import Data.Kind (Type)
import Data.Maybe (Maybe(..))
import Data.String (String)
import Language.Haskell.TH (TExpQ)
import qualified Data.Functor as F
import qualified Prelude as Pre
import qualified Data.List as List

import Symantic.Base.Univariant
import qualified Symantic.Parser.Staging as S

-- * Class 'Applicable'
class Applicable repr where
  (<$>) :: S.Runtime (a -> b) -> repr a -> repr b
  (<$>) f = (pure f <*>)

  (<&>) :: repr a -> S.Runtime (a -> b) -> repr b
  (<&>) = flip (<$>)

  (<$) :: S.Runtime a -> repr b -> repr a
  (<$) x = (pure x <*)

  ($>) :: repr a -> S.Runtime b -> repr b
  ($>) = flip (<$)

  --type Pure repr :: Type -> Type
  pure :: S.Runtime a -> repr a
  default pure ::
    Liftable repr => Applicable (Unlift repr) =>
    S.Runtime a -> repr a
  pure = lift . pure

  (<*>) :: repr (a -> b) -> repr a -> repr b
  default (<*>) ::
    Liftable repr => Applicable (Unlift repr) =>
    repr (a -> b) -> repr a -> repr b
  (<*>) = lift2 (<*>)

  liftA2 :: S.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
  liftA2 f x = (<*>) (f <$> x)

  (*>) :: repr a -> repr b -> repr b
  x *> y = (S.id <$ x) <*> y

  (<*) :: repr a -> repr b -> repr a
  (<*) = liftA2 S.const

  {-
  (<**>) :: repr a -> repr (a -> b) -> repr b
  (<**>) = liftA2 (\a f -> f a)
  -}
infixl 4 <$>, <&>, <$, $>, <*>, <*, *>

infixl 4 <**>
(<**>) :: Applicable repr => repr a -> repr (a -> b) -> repr b
(<**>) = liftA2 (S.flip S..@ (S.$))

-- * 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 <|>

infixl 3 <+>
(<+>) :: Applicable repr => Alternable repr => repr a -> repr b -> repr (Either a b)
p <+> q = S.Runtime (S.Eval Left) (S.Code [||Left||]) <$> p <|>
          S.Runtime (S.Eval Right) (S.Code [||Right||]) <$> q

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

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

option :: Applicable repr => Alternable repr => S.Runtime a -> repr a -> repr a
option x p = p <|> pure x

choice :: Alternable repr => [repr a] -> repr a
choice = List.foldr (<|>) empty

maybeP :: Applicable repr => Alternable repr => repr a -> repr (Maybe a)
maybeP p = option (S.Runtime (S.Eval Nothing) (S.Code [||Nothing||]))
                  (S.Runtime (S.Eval Just) (S.Code [||Just||]) <$> p)

manyTill :: Applicable repr => Alternable repr => repr a -> repr b -> repr [a]
manyTill p end = let go = end $> S.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 ::
    Liftable repr => Selectable (Unlift repr) =>
    repr (Either a b) -> repr (a -> c) -> repr (b -> c) -> repr c
  branch  = lift3 branch

class Matchable repr where
  conditional ::
    Eq a => [S.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
  default conditional ::
    Unliftable repr => Liftable repr => Matchable (Unlift repr) =>
    Eq a => [S.Runtime (a -> Bool)] -> [repr b] -> repr a -> repr b -> repr b
  conditional cs bs = lift2 (conditional cs (unlift Pre.<$> bs))

  match :: Eq a => [S.Runtime a] -> repr a -> (S.Runtime a -> repr b) -> repr b -> repr b
  match as a a2b b = conditional (S.eq Pre.<$> as) (a2b Pre.<$> as) a b

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

{-
conditional :: Selectable repr => [(S.Runtime (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 :: S.Runtime (Char -> Bool) -> repr Char
  default satisfy ::
    Liftable repr => Charable (Unlift repr) =>
    S.Runtime (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

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

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

traverse :: Applicable repr => (a -> repr b) -> [a] -> repr [b]
traverse f = sequence . List.map f

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 => [Char] -> repr Char
noneOf cs = satisfy ((S.Runtime (S.Eval (not . flip List.elem cs)) (S.Code [||\c -> not $$(ofChars cs [||c||])||])))

ofChars :: [Char] -> 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 (S.eq (S.char c)) $> S.char c

item :: Charable repr => repr Char
item = satisfy (S.const S..@ S.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 S.unit

{-

constp :: Applicable repr => repr a -> repr (b -> a)
constp = (S.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 (S.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 =>
 S.Runtime (a -> b -> c) -> repr a -> repr b -> repr c
liftA2 f x = (<*>) (fmap f x)

liftA3 ::
 Applicable repr =>
 S.Runtime (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 =>
 S.Runtime (a -> b -> b) -> S.Runtime b -> repr a -> repr b
pfoldr f k p = chainPre (f <$> p) (pure k)

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

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

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

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

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

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

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

chainr :: repr a -> repr (a -> a -> a) -> S.Runtime 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) -> S.Runtime 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 S.cons S.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 S.const S.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 S.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 S.nil (sepEndBy1 p sep)

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

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