{-# LANGUAGE UnicodeSyntax, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, FlexibleInstances, UndecidableInstances, PatternGuards, RecordWildCards, NamedFieldPuns, ViewPatterns, TypeSynonymInstances #-}

module Parsers where

import qualified Data.List as List
import qualified Text.ParserCombinators.Parsec as PS
import qualified Editing.Commands
import qualified Editing.Show ()
import qualified Data.Char as Ch

import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Foldable (toList)
import Control.Monad (liftM, liftM2)
import Control.Arrow (first)
import Data.List ((\\))
import Data.Maybe (fromMaybe)
import Editing.Basics (positionIn)
import Util ((.), Finite(..), commas_or, Option(..), (.∨.), isIdChar, (<<), NeList, MyMonadError(..))

import Prelude hiding ((.))
import Prelude.Unicode

-- To let us write parsers that work with both Parsec and our own Parser monad, we introduce the ParserLike class:

class (Functor m, Monad m) ⇒ ParserLike m t | m → t where
  anySymbol :: m t
  anySymbol = satisfy $ const True
  symbols :: (Eq t, Show t) ⇒ [t] → m [t]
  symbols = foldr (\ h → liftM2 (:) (satisfy (== h))) (return [])
  satisfy :: (t → Bool) → m t
  (<|>) :: m a → m a → m a
  (<?>) :: m a → String → m a
  lookAhead :: m a → m a
  pzero :: m a
  eof :: m ()
  try :: m a → m a
  getInput :: m [t]
  getInput = many anySymbol << eof

infix 0 <?>
infixr 1 <|>

-- Parsec is clearly ParserLike:

instance ParserLike (PS.GenParser Char st) Char where
  (<?>) = (PS.<?>)
  lookAhead = PS.lookAhead
  (<|>) = (PS.<|>)
  symbols = PS.string
  anySymbol = PS.anyChar
  satisfy = PS.satisfy
  pzero = PS.pzero
  eof = PS.eof
  try = PS.try

-- Utility parser combinators:

manyTill :: ParserLike m t ⇒ m a → m b → m ([a], b)
manyTill p e = ((,) [] . e) <|> liftM2 (\x (y, z) → (x:y, z)) p (manyTill p e)

many1Till :: ParserLike m t ⇒ m a → m b → m (NeList a, b)
many1Till p e = p >>= \v → first (v :|) . manyTill p e

optionMaybe :: ParserLike m t ⇒ m a → m (Maybe a)
optionMaybe p = Just . p <|> return Nothing

optional :: ParserLike m t ⇒ m a → m (Maybe a)
optional p = Just . p <|> return Nothing

option :: ParserLike m t ⇒ a → m a → m a
option x p = fromMaybe x . optional p

symbol :: (Show t, Eq t, ParserLike m t) ⇒ t → m t
symbol x = satisfy (== x) <?> show x

choice :: ParserLike m t ⇒ [m a] → m a
choice = foldl (<|>) pzero

many :: ParserLike m t ⇒ m a → m [a]
many p = liftM2 (:) p (many p) <|> return []

many1 :: ParserLike m t ⇒ m a → m (NeList a)
many1 p = liftM2 (:|) p (many p)

spaces :: ParserLike m Char ⇒ m String
spaces = many $ symbol ' '

noneOf :: (Eq t, ParserLike m t) ⇒ [t] → m t
noneOf l = satisfy (∉ l)

oneOf :: (Eq t, ParserLike m t) ⇒ [t] → m t
oneOf l = satisfy (∈ l)

sep :: ParserLike m t ⇒ m a → m b → m (a, [(b, a)])
sep p p' = liftM2 (,) p (many (liftM2 (,) p' p))

sepBy1' :: ParserLike m t ⇒ m a → m b → m (NeList a)
sepBy1' x y = (\(h, t) → h :| map snd t) . sep x y

sepBy1 :: ParserLike m t ⇒ m a → m b → m [a]
sepBy1 p e = liftM2 (:) p ((e >> sepBy1 p e) <|> return [])

kwd :: String → Parser Char String
kwd s = try $ symbols s << notFollowedBy (satisfy isIdChar) << spaces

kwds :: [String] → Parser Char String
kwds = choice . (kwd .)

char_unit :: (Eq a, Show a) ⇒ a → Parser a ()
char_unit = (>> return ()) . char

{-

Parsec's parse error descriptions aren't very good for parsers that backtrack. Consider

  parse (try (char 'x' >> char 'y') <|> char 'a') "" "x3"

This parse fails because (1) there is no 'y' at the second column, and (2) there is no 'a' at the first column. Intuitively, we feel that the first cause is the "real" cause, as it follows a longer partial match. Unfortunately, Parsec's errors do not reflect this:

  Left (line 1, column 1):
  unexpected "3"
  expecting "y" or "a"

Here, column numbers start at 1. Thus, while it /does/ mention the 'y' expectation and the unexpected '3', it fails to give the column number where 'y' was expected, and also does not show that the 'y' expectation followed a longer partial match than the 'a' expectation.

The parsing combinators in this module properly keep track of lengths of partial matches, to get intuitive error descriptions. For the parse above, they report only the 'y' expectation, at the second column.

Parsec mixes ordinary parse errors with custom parse errors. One can "fail" at any point. The parsers below can only fail due to unexpected symbols. Additional errors can be added by using parsers returning (Either String a)'s.

-}

data Expectation = Expected { expectedAt :: Int, expectedWhat :: [String] }

uninformativeExpectation :: Expectation
uninformativeExpectation = Expected 0 []

data ParseResult t a
  = ParseSuccess a [t] Int (Maybe Expectation)
  -- The Int is the length of the match. Hence, the [t] is strictly redundant, but there for efficiency. The Maybe is the furthest we've been able to parse successfully, with an indication of why we couldn't go even further.
  | ParseFailure Expectation Bool
  -- The Bool indicates whether the failure is terminal.

instance Functor (ParseResult t) where
  fmap f (ParseSuccess x t i m) = ParseSuccess (f x) t i m; fmap _ (ParseFailure e b) = ParseFailure e b

newtype Parser t a = Parser { run_parser :: [t] → ParseResult t a }

peek :: Parser t [t]
peek = Parser $ \s → ParseSuccess s s 0 Nothing

drain :: Parser t [t]
drain = Parser $ \s → ParseSuccess s [] (length s) Nothing

parseSuccess :: a → Parser t a
parseSuccess = return

-- Parser is a Functor, a Monad, and ParserLike:

instance Functor (Parser t) where fmap = liftM

instance Monad (Parser t) where
  return x = Parser $ \s → ParseSuccess x s 0 Nothing
  Parser p >>= f = Parser $ \s → case p s of
    ParseSuccess r s' n m → case run_parser (f r) s' of
      ParseSuccess r' s'' n' m' → ParseSuccess r' s'' (n + n') (furthest m (offset n . m'))
      ParseFailure (offset n → m') b → ParseFailure (maybe m' (furthest' m') m) b
    ParseFailure e b → ParseFailure e b
  fail = const pzero

instance ParserLike (Parser a) a where
  anySymbol = satisfy (const True) <?> "any symbol"
  satisfy p = Parser $ \s → case s of
    h:t | p h → ParseSuccess h t 1 Nothing
    _ → ParseFailure uninformativeExpectation False
  symbols t = Parser $ \s → case List.stripPrefix t s of
    Nothing → ParseFailure (Expected 0 [show t]) False
    Just s' → ParseSuccess t s' (length t) Nothing
  Parser p <|> Parser q = Parser $ \s → case p s of
    ParseFailure m False → case q s of
      ParseSuccess r u n' m' → ParseSuccess r u n' $ Just $ maybe m (furthest' m) m'
      ParseFailure m' b → ParseFailure (furthest' m m') b
    ps → ps
  Parser p <?> m = Parser $ \s → case p s of
    ParseFailure (Expected 0 _) b → ParseFailure (Expected 0 [m]) b
    b → b
  lookAhead (Parser p) = Parser $ \s → case p s of
    ParseSuccess r _ _ m → ParseSuccess r s 0 m
    e → e
  pzero = Parser $ const $ ParseFailure uninformativeExpectation False
  eof = Parser $ \s → if null s then ParseSuccess () [] 0 Nothing else ParseFailure (Expected 0 ["EOF"]) False
  try = id
  getInput = Parser $ \s → ParseSuccess s s 0 Nothing

notFollowedBy :: Parser t a → Parser t ()
notFollowedBy (Parser p) = Parser $ \s → case p s of
  ParseFailure{} → ParseSuccess () s 0 Nothing
  ParseSuccess{} → ParseFailure uninformativeExpectation False

-- Some Parser-specific parsers:

guarded :: (a → Bool) → Parser t a → Parser t a
guarded f (Parser p) = Parser $ \s → case p s of
  ParseSuccess x _ _ _ | not (f x) → ParseFailure uninformativeExpectation False
  k → k

char :: (Show t, Eq t) ⇒ t → Parser t t
char t = satisfy (== t) <?> show t

commit :: Parser t a → Parser t a
commit (Parser p) = Parser $ \s → case p s of
  ParseFailure x _ → ParseFailure x True
  ps → ps

silent :: Parser t a → Parser t a
silent (Parser p) = Parser $ \s → case p s of
  ParseFailure _ b → ParseFailure uninformativeExpectation b
  ParseSuccess r t n _ → ParseSuccess r t n Nothing

optParser :: (MyMonadError String m, Functor m, Finite o, Option o) ⇒ Parser Char (m [o])
optParser = (<?> "option") $ (char '-' >>) $ do
    char '-'
    n ← (<?> "option name") $ toList . many1 (satisfy $ isIdChar .∨. (== '-'))
    spaces
    case List.find ((== n) . long) all_values of
      Nothing → return $ throwError $ "No such option: --" ++ n
      Just o → ((o:) .) . option (return []) optParser
  <|> do
    x ← many1 $ do
      d ← satisfy Ch.isAlpha <?> "option letter"
      return $ case List.find ((== Just d) . short) all_values of
        Nothing → throwError $ "No such option: -" ++ [d]
        Just o → return o
    spaces
    y ← option (return []) optParser
    return (liftM2 (++) (sequence $ toList x) y)

-- Misc:

showParseError :: String → String → Int → [String] → String
showParseError subject_desc input column expectation =
  "Unexpected " ++ unexpectation ++ "." ++
  if null expectation' then "" else " Expected " ++ commas_or expectation' ++ "."
  where
    unexpectation
      | h:t ← drop column input =
        '`' : (if Ch.isAlphaNum h then h : takeWhile Ch.isAlphaNum t else [h]) ++ "` " ++
        show (Editing.Commands.describe_position_after (positionIn input column) input)
      | otherwise = "end of " ++ subject_desc
    expectation' = (List.nub expectation \\ ["EOF", "' '"]) ++
      ["end of " ++ subject_desc | "EOF" ∈ expectation]

furthest' :: Expectation → Expectation → Expectation
furthest' (Expected n s) (Expected n' s')
  | n < n' = Expected n' s'
  | n' < n = Expected n s
  | otherwise = Expected n (s ++ s')

furthest :: Maybe Expectation → Maybe Expectation → Maybe Expectation
furthest Nothing x = x
furthest x Nothing = x
furthest (Just x) (Just y) = Just $ furthest' x y

offset :: Int → Expectation → Expectation
offset n Expected{..} = Expected{expectedAt = expectedAt + n, ..}

parseOrFailE :: Parser Char (Either String a) → String → String → Either String a
parseOrFailE p input desc = case run_parser p input of
  ParseSuccess (Left e) _ _ _ → throwError e
  ParseSuccess (Right x) _ _ _ → return x
  ParseFailure (Expected x y) _ → throwError $ showParseError desc input x y

parseOrFail :: Parser Char a → String → String → Either String a
parseOrFail p input desc = case run_parser p input of
  ParseSuccess x _ _ _ → return x
  ParseFailure (Expected x y) _ → throwError $ showParseError desc input x y