content: -- Copyright 2023 Lennart Augustsson
  -- See LICENSE file for full license.
  {-# OPTIONS_GHC -Wno-type-defaults #-}
  {-# LANGUAGE FunctionalDependencies #-}
  module Text.ParserComb(
    Prsr, runPrsr,
    satisfy, satisfyM,
    satisfyMany,
    choice,
    many, emany, optional, eoptional,
    some, esome,
    esepBy, sepBy1, esepBy1,
    esepEndBy, esepEndBy1,
    (<?>), (<|<),
    --notFollowedBy,
    --lookAhead,
    nextToken,
    LastFail(..),
    TokenMachine(..),
    mapTokenState,
    ) where
  import Control.Applicative
  import Control.Monad
  
  data LastFail t
    = LastFail Int [t] [String]
    deriving (Show)
  
  maxInt :: Int
  maxInt = 1000000000
  
  noFail :: LastFail t
  noFail = LastFail maxInt [] []
  
  longest :: LastFail t -> LastFail t -> LastFail t
  longest lf1@(LastFail l1 t1 x1) lf2@(LastFail l2 _ x2) =
    if l1 < l2 then
      lf1
    else if l2 < l1 then
      lf2
    else
      LastFail l1 t1 (x1 ++ x2)
  
  longests :: [LastFail t] -> LastFail t
  longests xs = foldl1 longest xs
  
  class TokenMachine tm t | tm -> t where
    tmNextToken :: tm -> (t, tm)
    tmRawTokens :: tm -> [t]
  
  tmLeft :: TokenMachine tm t => tm -> Int
  tmLeft = length . tmRawTokens
  
  firstToken :: TokenMachine tm t => tm -> [t]
  firstToken tm =
    case tmNextToken tm of
      (t, _) -> [t]
  
  data Res tm t a = Many [(a, tm)] (LastFail t)
    --deriving (Show)
  
  data Prsr tm t a = P (tm -> Res tm t a)
  --instance Show (Prsr s t a) where show _ = "<<Prsr>>"
  
  runP :: Prsr tm t a -> (tm -> Res tm t a)
  runP (P p) = p
  
  mapTokenState :: (tm -> tm) -> Prsr tm t ()
  mapTokenState f = P (\ tm -> Many [((), f tm)] noFail)
  
  instance Functor (Prsr tm t) where
    fmap f p = P $ \ t ->
      case runP p t of
        Many aus lf -> Many [ (f a, u) | (a, u) <- aus ] lf
  
  instance Applicative (Prsr tm t) where
    pure a = P $ \ t -> Many [(a, t)] noFail
    (<*>) = ap
    (*>) p k = p >>= \ _ -> k
  
  instance Monad (Prsr tm t) where
    (>>=) p k = P $ \ t ->
      case runP p t of
        Many aus plf ->
          let ms = map (\ (a, u) -> runP (k a) u) aus
              lfs = map (\ (Many _ lf) -> lf) ms
              rrs = [ r | Many rs _ <- ms, r <- rs ]
          in  Many rrs (longests (plf : lfs))
    return = pure
  
  instance TokenMachine tm t => MonadFail (Prsr tm t) where
    fail m = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) [m])
  
  instance TokenMachine tm t => Alternative (Prsr tm t) where
    empty = P $ \ ts -> Many [] (LastFail (tmLeft ts) (firstToken ts) ["empty"])
  
    (<|>) p q = P $ \ t ->
      case runP p t of
        Many a lfa ->
          case runP q t of
            Many b lfb -> Many (a ++ b) (longest lfa lfb)
  
  -- Left biased choice
  infixl 3 <|<
  (<|<) :: Prsr tm t a -> Prsr tm t a -> Prsr tm t a
  (<|<) p q = P $ \ t ->
    case runP p t of
      Many [] lfa ->
        case runP q t of
           Many b lfb -> Many b (longest lfa lfb)
      r -> r
  
  satisfy :: TokenMachine tm t => String -> (t -> Bool) -> Prsr tm t t
  satisfy msg f = P $ \ acs ->
    case tmNextToken acs of
      r@(c, _) | f c -> Many [r] noFail
      _ -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])
  
  satisfyM :: TokenMachine tm t => String -> (t -> Maybe a) -> Prsr tm t a
  satisfyM msg f = P $ \ acs ->
    case tmNextToken acs of
      (c, cs) ->
        case f c of
          Just a  -> Many [(a, cs)] noFail
          Nothing -> Many [] (LastFail (tmLeft acs) (firstToken acs) [msg])
  
  satisfyMany :: TokenMachine tm t => (t -> Bool) -> Prsr tm t [t]
  satisfyMany f = P $ loop []
    where loop res acs =
            case tmNextToken acs of
              (c, cs) | f c -> loop (c:res) cs
                      | otherwise -> Many [(reverse res, acs)] noFail
  
  infixl 9 <?>
  (<?>) :: Prsr tm t a -> String -> Prsr tm t a
  (<?>) p e = P $ \ t ->
  --  trace ("<?> " ++ show e) $
    case runP p t of
      Many rs (LastFail l ts _) -> Many rs (LastFail l ts [e])
  
  {-
  lookAhead :: forall tm t a . TokenMachine tm t => Prsr tm t a -> Prsr tm t ()
  lookAhead p = P $ \ t ->
    case runP p t of
      Many [] (LastFail l ts xs) -> Many [] (LastFail l (take 1 ts) xs)
      _                          -> Many [((), t)] noFail
  -}
  
  nextToken :: TokenMachine tm t => Prsr tm t t
  nextToken = P $ \ cs ->
    case tmNextToken cs of
      (c, _) -> Many [(c, cs)] noFail
  
  {-
  eof :: forall tm t . TokenMachine tm t => Prsr tm t ()
  eof = P $ \ t@(cs, _) ->
    case tmNextToken cs of
      Nothing -> Many [((), t)] noFail
      Just _  -> Many [] (LastFail (tmLeft cs) (firstToken cs) ["eof"])
  -}
  
  {-
  notFollowedBy :: forall t a . Prsr t a -> Prsr t ()
  notFollowedBy p = P $ \ t@(ts,_) ->
    case runP p t of
      Many [] _ -> Many [((), t)] noFail
      _         -> Many [] (LastFail (length ts) (take 1 ts) ["!"])
  -}
  
  runPrsr ::  --X(Show a, Show s) =>
             Prsr tm t a -> tm -> Either (LastFail t) [a]
  runPrsr (P p) f =
    case p f of
      Many [] lf -> Left lf
      Many xs _  -> Right [a | (a, _) <- xs ]
  
  -------------------------------
  
  emany :: Prsr tm t a -> Prsr tm t [a]
  emany p = esome p <|< pure []
  
  esome :: Prsr tm t a -> Prsr tm t [a]
  esome p = (:) <$> p <*> emany p
  
  eoptional :: Prsr tm t a -> Prsr tm t (Maybe a)
  eoptional p = (Just <$> p) <|< pure Nothing
  
  choice :: TokenMachine tm t => [Prsr tm t a] -> Prsr tm t a
  choice [] = empty
  choice ps = foldr1 (<|>) ps
  
  sepBy1 :: TokenMachine tm t => Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]
  sepBy1 p sep = (:) <$> p <*> many (sep *> p)
  
  esepBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]
  esepBy1 p sep = (:) <$> p <*> emany (sep *> p)
  
  esepBy :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]
  esepBy p sep = esepBy1 p sep <|< pure []
  
  esepEndBy :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]
  esepEndBy p sep = esepEndBy1 p sep <|< pure []
  
  esepEndBy1 :: Prsr tm t a -> Prsr tm t sep -> Prsr tm t [a]
  esepEndBy1 p sep = (:) <$> p <*> ((sep *> esepEndBy p sep) <|< pure [])
  