-- | A collection of parsing algorithms with a common interface, operating on grammars represented as records with
-- rank-2 field types.
{-# LANGUAGE FlexibleContexts, KindSignatures, OverloadedStrings, RankNTypes, ScopedTypeVariables,
             TypeFamilies, TypeOperators #-}
module Text.Grampa (
   -- * Applying parsers
   failureDescription, simply,
   -- * Types
   Grammar, GrammarBuilder, GrammarOverlay, ParseResults, ParseFailure(..), FailureDescription(..), Ambiguous(..), Pos,
   -- * Classes
   -- ** Parsing
   DeterministicParsing(..), AmbiguousParsing(..), CommittedParsing(..), TraceableParsing(..),
   LexicalParsing(..),
   -- ** Grammars
   MultiParsing(..), GrammarParsing(..), overlay,
   -- ** From the [input-parsers](http://hackage.haskell.org/package/input-parsers) library
   InputParsing(..), InputCharParsing(..), ConsumedInputParsing(..), Position(..),
   -- ** From the [parsers](http://hackage.haskell.org/package/parsers) library
   module Text.Parser.Char,
   module Text.Parser.Combinators,
   module Text.Parser.LookAhead,
   TokenParsing(..),
   -- * Other combinators
   module Text.Grampa.Combinators)
where

import Data.List (intersperse)
import Data.Kind (Type)
import Data.Monoid ((<>), Endo (Endo, appEndo))
import Data.Monoid.Factorial (drop)
import Data.Monoid.Null (null)
import Data.Monoid.Textual (TextualMonoid)
import Data.String (IsString(fromString))
import Text.Parser.Char (CharParsing(char, notChar, anyChar))
import Text.Parser.Combinators (Parsing((<?>), notFollowedBy, skipMany, skipSome, unexpected))
import Text.Parser.LookAhead (LookAheadParsing(lookAhead))
import Text.Parser.Token (TokenParsing(..))
import Text.Parser.Input.Position (Position)
import qualified Text.Parser.Input.Position as Position
import Text.Grampa.Combinators (concatMany, concatSome)

import qualified Rank2
import Text.Grampa.Class (MultiParsing(..), GrammarParsing(..),
                          InputParsing(..), InputCharParsing(..),
                          ConsumedInputParsing(..), LexicalParsing(..),
                          CommittedParsing(..), DeterministicParsing(..),
                          AmbiguousParsing(..), Ambiguous(..),
                          ParseResults, ParseFailure(..), FailureDescription(..), Pos)
import Text.Grampa.Internal (TraceableParsing(..))

import Prelude hiding (drop, null)

-- | A grammar is a record type @g@ whose fields are parsers of type @p@ on input streams of type @s@. A value of a
-- @Grammar@ type is typically produced by applying 'fixGrammar' or 'overlay' to a 'GrammarBuilder'.
type Grammar (g  :: (Type -> Type) -> Type) p s = g (p g s)

-- | A @GrammarBuilder g g' p s@ is an endomorphic function on a grammar @g@, whose parsers of type @p@ build on
-- grammars of type @g'@ and parse an input stream of type @s@. Grammar parameters @g@ and @g'@ are typically
-- identical in simple monolithic grammars, but when composing complex grammars the first grammar parameter @g@ would
-- be just a building block for the final grammar @g'@.
type GrammarBuilder (g  :: (Type -> Type) -> Type)
                    (g' :: (Type -> Type) -> Type)
                    (p  :: ((Type -> Type) -> Type) -> Type -> Type -> Type)
                    (s  :: Type)
   = g (p g' s) -> g (p g' s)

-- | A grammar overlay is a function that takes a final grammar @self@ and the parent grammar @super@ and builds a new
-- grammar from them. Use 'overlay' to apply a colection of overlays on top of a base grammar.
type GrammarOverlay (g  :: (Type -> Type) -> Type)
                    (m  :: Type -> Type)
   = g m -> g m -> g m

-- | Layers a sequence of 'GrammarOverlay' on top of a base 'GrammarBuilder' to produce a new grammar.
overlay :: (GrammarParsing m, g ~ ParserGrammar m, GrammarConstraint m g, Rank2.Distributive g, Foldable f)
        => (g m -> g m) -> f (GrammarOverlay g m) -> g m
overlay :: forall (m :: * -> *) (g :: (* -> *) -> *) (f :: * -> *).
(GrammarParsing m, g ~ ParserGrammar m, GrammarConstraint m g,
 Distributive g, Foldable f) =>
(g m -> g m) -> f (GrammarOverlay g m) -> g m
overlay g m -> g m
base f (GrammarOverlay g m)
layers = Endo (g m) -> g m -> g m
forall a. Endo a -> a -> a
appEndo ((GrammarOverlay g m -> Endo (g m))
-> f (GrammarOverlay g m) -> Endo (g m)
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((g m -> g m) -> Endo (g m)
forall a. (a -> a) -> Endo a
Endo ((g m -> g m) -> Endo (g m))
-> (GrammarOverlay g m -> g m -> g m)
-> GrammarOverlay g m
-> Endo (g m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ParserGrammar m m -> g m -> g m)
-> ParserGrammar m m -> g m -> g m
forall a b. (a -> b) -> a -> b
$ ParserGrammar m m
self)) f (GrammarOverlay g m)
layers) (g m -> g m
base g m
ParserGrammar m m
self)
   where self :: ParserGrammar m m
self = ParserGrammar m m
forall (m :: * -> *) (g :: (* -> *) -> *).
(GrammarParsing m, g ~ ParserGrammar m, GrammarConstraint m g,
 Distributive g) =>
g m
forall (g :: (* -> *) -> *).
(g ~ ParserGrammar m, GrammarConstraint m g, Distributive g) =>
g m
selfReferring

-- | Apply the given parsing function (typically `parseComplete` or `parsePrefix`) to the given grammar-agnostic
-- parser and its input. A typical invocation might be
--
-- > getCompose $ simply parsePrefix myParser myInput
simply :: (Rank2.Only r (p (Rank2.Only r) s) -> s -> Rank2.Only r f) -> p (Rank2.Only r) s r -> s -> f r
simply :: forall r (p :: ((* -> *) -> *) -> * -> * -> *) s (f :: * -> *).
(Only r (p (Only r) s) -> s -> Only r f)
-> p (Only r) s r -> s -> f r
simply Only r (p (Only r) s) -> s -> Only r f
parseGrammar p (Only r) s r
p s
input = Only r f -> f r
forall {k} (a :: k) (f :: k -> *). Only a f -> f a
Rank2.fromOnly (Only r (p (Only r) s) -> s -> Only r f
parseGrammar (p (Only r) s r -> Only r (p (Only r) s)
forall {k} (a :: k) (f :: k -> *). f a -> Only a f
Rank2.Only p (Only r) s r
p) s
input)

-- | Given the textual parse input, the parse failure on the input, and the number of lines preceding the failure to
-- show, produce a human-readable failure description.
failureDescription :: forall s pos. (Ord s, TextualMonoid s, Position pos) => s -> ParseFailure pos s -> Int -> s
failureDescription :: forall s pos.
(Ord s, TextualMonoid s, Position pos) =>
s -> ParseFailure pos s -> Int -> s
failureDescription s
input (ParseFailure pos
pos (FailureDescription [String]
expected [s]
inputs) [String]
erroneous) Int
contextLineCount =
   s -> pos -> Int -> s
forall s p.
(Eq s, TextualMonoid s, Position p) =>
s -> p -> Int -> s
Position.context s
input pos
pos Int
contextLineCount
   s -> s -> s
forall a. Semigroup a => a -> a -> a
<> [s] -> s
forall a. Monoid a => [a] -> a
mconcat
      (s -> [s] -> [s]
forall a. a -> [a] -> [a]
intersperse s
", but " ([s] -> [s]) -> [s] -> [s]
forall a b. (a -> b) -> a -> b
$ (s -> Bool) -> [s] -> [s]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (s -> Bool) -> s -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Bool
forall m. MonoidNull m => m -> Bool
null)
       [(s -> s) -> s -> s
forall {t}. MonoidNull t => (t -> t) -> t -> t
onNonEmpty (s
"expected " s -> s -> s
forall a. Semigroup a => a -> a -> a
<>) (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ s -> [s] -> s
oxfordComma s
" or " ((String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> [String] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
expected) [s] -> [s] -> [s]
forall a. Semigroup a => a -> a -> a
<> (s -> s
forall {a}. (Semigroup a, IsString a) => a -> a
fromLiteral (s -> s) -> [s] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [s]
inputs)),
        s -> [s] -> s
oxfordComma s
" and " (String -> s
forall a. IsString a => String -> a
fromString (String -> s) -> [String] -> [s]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
erroneous)])
   where oxfordComma :: s -> [s] -> s
         oxfordComma :: s -> [s] -> s
oxfordComma s
_ [] = s
""
         oxfordComma s
_ [s
x] = s
x
         oxfordComma s
conjunction [s
x, s
y] = s
x s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
conjunction s -> s -> s
forall a. Semigroup a => a -> a -> a
<> s
y
         oxfordComma s
conjunction (s
x:s
y:[s]
rest) = [s] -> s
forall a. Monoid a => [a] -> a
mconcat (s -> [s] -> [s]
forall a. a -> [a] -> [a]
intersperse s
", " (s
x s -> [s] -> [s]
forall a. a -> [a] -> [a]
: s
y s -> [s] -> [s]
forall a. a -> [a] -> [a]
: (s -> s) -> [s] -> [s]
forall {a}. (a -> a) -> [a] -> [a]
onLast (Int -> s -> s
forall m. FactorialMonoid m => Int -> m -> m
drop Int
1 s
conjunction s -> s -> s
forall a. Semigroup a => a -> a -> a
<>) [s]
rest))
         onNonEmpty :: (t -> t) -> t -> t
onNonEmpty t -> t
f t
x = if t -> Bool
forall m. MonoidNull m => m -> Bool
null t
x then t
x else t -> t
f t
x
         onLast :: (a -> a) -> [a] -> [a]
onLast a -> a
_ [] = []
         onLast a -> a
f [a
x] = [a -> a
f a
x]
         onLast a -> a
f (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: (a -> a) -> [a] -> [a]
onLast a -> a
f [a]
xs
         fromLiteral :: a -> a
fromLiteral a
s = a
"string \"" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"\""