{-# LANGUAGE
  StrictData #-}

module Little.Earley.Internal.Result where

import Data.Foldable (minimumBy)
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Ord (comparing)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.Set (Set)
import qualified Data.Set as Set

import Little.Earley.Internal.Core
import Little.Earley.Internal.Tree
import Little.Earley.Internal.Pretty
import Little.Earley.Internal.Render

-- | Result of 'parse'.
data Result n t c
  = ParseError (Error t c)
  | ParseSuccess (ParsedResult n t c)

-- | Successful result of 'parse'.
data ParsedResult n t c = ParsedResult
  { prParseTree :: TreeSet n t c
    -- ^ The resulting parse tree.
  , prAmbiguities :: [LocAmbiguity n t c]
    -- ^ A stream of localized ambiguities, when the parse tree is ambiguous.
  }

instance (PrettyPrint n, PrettyPrint t, PrettyPrint c) => PrettyPrint (Result n t c) where
  prettyPrint (ParseError e) = unlines
    [ "Parse error at position " ++ show i ++ ":"
    , "    " ++ showTokens ++ extraToken
    , replicate (4 + length showTokens + 1) ' ' ++ "^"
    , "Got:      " ++ actual
    , "Expected: " ++ show (map Pretty (errorExpected e))
    ] where
      i = errorPosition e
      tl = drop (i-10) (take i (errorInput e))
      showTokens = unwords (map prettyPrint tl)
      (actual, extraToken) = case errorToken e of
        Nothing -> ("end of input", "")
        Just c -> (prettyPrint c, ' ' : prettyPrint c)
  prettyPrint (ParseSuccess r) = unlines (pTree ++ pAmbig) where
    pTree = prettyTree (arbTree (prParseTree r))
    pAmbig = case prAmbiguities r of
      [] -> []
      ambs ->
        let (rg, Ambiguity t1 t2) = minimumBy (comparing fst) (take 1000 ambs)
            pRange = "Ambiguous parse between tokens number "
              ++ show (rangePos rg) ++ " and " ++ show (rangePos rg + rangeLen rg) ++ ":" in
        "" : pRange : "" : prettyTree t1 ++ "" : prettyTree t2

-- | Parser error information.
data Error t c = Error
  { errorPosition :: Int
  , errorToken :: Maybe c  -- ^ @Nothing@ if end of input
  , errorExpected :: [t]
  , errorInput :: [c]
  }

diagnoseError :: Ord t => Seq1 (Set (Item n t)) -> [c] -> Error t c
diagnoseError hs xs =
  let (i, h) = lastNot Set.null hs
      x0 = listToMaybe (drop i xs)
  in Error
    { errorPosition = i
    , errorToken = x0
    , errorExpected = nub_ [t | Item _ (T t : _) _ <- Set.toList h]
    , errorInput = xs
    }

lastNot :: (a -> Bool) -> Seq1 a -> (Int, a)
lastNot f (hs ::> h)
  | f h =
    let (_, pre) = Seq.spanr f hs in
    case Seq.viewr pre of
      Seq.EmptyR -> (0, fromMaybe h (Seq.lookup 0 hs))
      h' Seq.:> h0 -> (Seq.length h', h0)
  | otherwise = (Seq.length hs, h)

nub_ :: Ord a => [a] -> [a]
nub_ = Set.toList . Set.fromList

--

-- | Parse a chain of tokens @[c]@ given a grammar and a starting symbol @n@.
--
-- Variants:
--
-- - 'Little.Earley.pparse': pretty-printed; use this in the REPL.
-- - 'Little.Earley.parseTreeSet': outputs just the parse tree.
-- - 'Little.Earley.accepts': outputs a mere boolean.
--
-- == Example
--
-- @
-- 'parse' arithG SUM \"1+2*3\"
-- @
parse :: (Ord n, Ord t) => Grammar n t c -> n -> [c] -> Result n t c
parse g n cs =
  case parseTreeSet_ g n cs of
    (hs, Nothing) -> ParseError (diagnoseError hs cs)
    (_, Just t) -> ParseSuccess (ParsedResult
      { prParseTree = t
      , prAmbiguities = ambiguities t
      })

-- | Wrapped 'parse' with a pretty-printed result. Use this in the REPL.
--
-- == Example
--
-- @
-- 'pparse' arithG SUM \"1+2*3\"
-- @
--
-- Output:
--
-- >      +-----+--SUM #1---+
-- >      |     |           |
-- >   SUM #0   |      +PRODUCT #1-+
-- >      |     |      |     |     |
-- > PRODUCT #0 | PRODUCT #0 |     |
-- >      |     |      |     |     |
-- >  FACTOR #0 |  FACTOR #0 | FACTOR #0
-- >      |     |      |     |     |
-- >  NUMBER #0 |  NUMBER #0 | NUMBER #0
-- >      |     |      |     |     |
-- > -----------------------------------
-- >      1     +      2     *     3
pparse :: (Ord n, Ord t) => Grammar n t c -> n -> [c] -> Pretty (Result n t c)
pparse g n cs = Pretty (parse g n cs)