{-# 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
  { ParsedResult n t c -> TreeSet n t c
prParseTree :: TreeSet n t c
    -- ^ The resulting parse tree.
  , ParsedResult n t c -> [LocAmbiguity n t c]
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 :: Result n t c -> String
prettyPrint (ParseError Error t c
e) = [String] -> String
unlines
    [ String
"Parse error at position " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":"
    , String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
showTokens String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
extraToken
    , Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
showTokens Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"^"
    , String
"Got:      " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
actual
    , String
"Expected: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Pretty t] -> String
forall a. Show a => a -> String
show ((t -> Pretty t) -> [t] -> [Pretty t]
forall a b. (a -> b) -> [a] -> [b]
map t -> Pretty t
forall a. a -> Pretty a
Pretty (Error t c -> [t]
forall t c. Error t c -> [t]
errorExpected Error t c
e))
    ] where
      i :: Int
i = Error t c -> Int
forall t c. Error t c -> Int
errorPosition Error t c
e
      tl :: [c]
tl = Int -> [c] -> [c]
forall a. Int -> [a] -> [a]
drop (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
10) (Int -> [c] -> [c]
forall a. Int -> [a] -> [a]
take Int
i (Error t c -> [c]
forall t c. Error t c -> [c]
errorInput Error t c
e))
      showTokens :: String
showTokens = [String] -> String
unwords ((c -> String) -> [c] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map c -> String
forall a. PrettyPrint a => a -> String
prettyPrint [c]
tl)
      (String
actual, String
extraToken) = case Error t c -> Maybe c
forall t c. Error t c -> Maybe c
errorToken Error t c
e of
        Maybe c
Nothing -> (String
"end of input", String
"")
        Just c
c -> (c -> String
forall a. PrettyPrint a => a -> String
prettyPrint c
c, Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: c -> String
forall a. PrettyPrint a => a -> String
prettyPrint c
c)
  prettyPrint (ParseSuccess ParsedResult n t c
r) = [String] -> String
unlines ([String]
pTree [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
pAmbig) where
    pTree :: [String]
pTree = Tree n t c -> [String]
forall n c t.
(PrettyPrint n, PrettyPrint c) =>
Tree n t c -> [String]
prettyTree (TreeSet n t c -> Tree n t c
forall n t c. TreeSet n t c -> Tree n t c
arbTree (ParsedResult n t c -> TreeSet n t c
forall n t c. ParsedResult n t c -> TreeSet n t c
prParseTree ParsedResult n t c
r))
    pAmbig :: [String]
pAmbig = case ParsedResult n t c -> [LocAmbiguity n t c]
forall n t c. ParsedResult n t c -> [LocAmbiguity n t c]
prAmbiguities ParsedResult n t c
r of
      [] -> []
      [LocAmbiguity n t c]
ambs ->
        let (Range
rg, Ambiguity Tree n t c
t1 Tree n t c
t2) = (LocAmbiguity n t c -> LocAmbiguity n t c -> Ordering)
-> [LocAmbiguity n t c] -> LocAmbiguity n t c
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((LocAmbiguity n t c -> Range)
-> LocAmbiguity n t c -> LocAmbiguity n t c -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing LocAmbiguity n t c -> Range
forall a b. (a, b) -> a
fst) (Int -> [LocAmbiguity n t c] -> [LocAmbiguity n t c]
forall a. Int -> [a] -> [a]
take Int
1000 [LocAmbiguity n t c]
ambs)
            pRange :: String
pRange = String
"Ambiguous parse between tokens number "
              String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Range -> Int
rangePos Range
rg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" and " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Range -> Int
rangePos Range
rg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Range -> Int
rangeLen Range
rg) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" in
        String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
pRange String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Tree n t c -> [String]
forall n c t.
(PrettyPrint n, PrettyPrint c) =>
Tree n t c -> [String]
prettyTree Tree n t c
t1 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Tree n t c -> [String]
forall n c t.
(PrettyPrint n, PrettyPrint c) =>
Tree n t c -> [String]
prettyTree Tree n t c
t2

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

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

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

nub_ :: Ord a => [a] -> [a]
nub_ :: [a] -> [a]
nub_ = Set a -> [a]
forall a. Set a -> [a]
Set.toList (Set a -> [a]) -> ([a] -> Set a) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Set a
forall a. Ord a => [a] -> Set a
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 :: Grammar n t c -> n -> [c] -> Result n t c
parse Grammar n t c
g n
n [c]
cs =
  case Grammar n t c
-> n -> [c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
forall n t c.
(Ord n, Ord t) =>
Grammar n t c
-> n -> [c] -> (Seq1 (Set (Item n t)), Maybe (TreeSet n t c))
parseTreeSet_ Grammar n t c
g n
n [c]
cs of
    (Seq1 (Set (Item n t))
hs, Maybe (TreeSet n t c)
Nothing) -> Error t c -> Result n t c
forall n t c. Error t c -> Result n t c
ParseError (Seq1 (Set (Item n t)) -> [c] -> Error t c
forall t n c. Ord t => Seq1 (Set (Item n t)) -> [c] -> Error t c
diagnoseError Seq1 (Set (Item n t))
hs [c]
cs)
    (Seq1 (Set (Item n t))
_, Just TreeSet n t c
t) -> ParsedResult n t c -> Result n t c
forall n t c. ParsedResult n t c -> Result n t c
ParseSuccess (ParsedResult :: forall n t c.
TreeSet n t c -> [LocAmbiguity n t c] -> ParsedResult n t c
ParsedResult
      { prParseTree :: TreeSet n t c
prParseTree = TreeSet n t c
t
      , prAmbiguities :: [LocAmbiguity n t c]
prAmbiguities = TreeSet n t c -> [LocAmbiguity n t c]
forall n t c. TreeSet n t c -> [LocAmbiguity n t c]
ambiguities TreeSet n t c
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 :: Grammar n t c -> n -> [c] -> Pretty (Result n t c)
pparse Grammar n t c
g n
n [c]
cs = Result n t c -> Pretty (Result n t c)
forall a. a -> Pretty a
Pretty (Grammar n t c -> n -> [c] -> Result n t c
forall n t c.
(Ord n, Ord t) =>
Grammar n t c -> n -> [c] -> Result n t c
parse Grammar n t c
g n
n [c]
cs)