module Text.Grampa.Class (MultiParsing(..), AmbiguousParsing(..), GrammarParsing(..), MonoidParsing(..), Lexical(..),
ParseResults, ParseFailure(..), Ambiguous(..), completeParser) where
import Control.Applicative (Alternative(empty), liftA2, (<|>))
import Control.Monad (guard)
import Data.Char (isAlphaNum, isLetter, isSpace)
import Data.Functor.Classes (Show1(..))
import Data.Functor.Compose (Compose(..))
import Data.List.NonEmpty (NonEmpty((:|)))
import Data.Data (Data)
import Data.Typeable (Typeable)
import Data.Monoid (Monoid, (<>))
import Data.Monoid.Cancellative (LeftReductiveMonoid)
import qualified Data.Monoid.Null as Null
import Data.Monoid.Null (MonoidNull)
import Data.Monoid.Factorial (FactorialMonoid)
import Data.Monoid.Textual (TextualMonoid)
import Text.Parser.Combinators (Parsing(notFollowedBy), skipMany, skipSome)
import Text.Parser.Char (CharParsing(char))
import Text.Parser.Token (TokenParsing, IdentifierStyle)
import GHC.Exts (Constraint)
import qualified Rank2
type ParseResults = Either ParseFailure
data ParseFailure = ParseFailure Int [String] deriving (Eq, Show)
newtype Ambiguous a = Ambiguous (NonEmpty a) deriving (Data, Eq, Functor, Ord, Show, Typeable)
instance Show1 Ambiguous where
liftShowsPrec sp sl d (Ambiguous (h :| l)) t
| d > 5 = "(Ambiguous $ " <> sp 0 h (" :| " <> sl l (')' : t))
| otherwise = "Ambiguous (" <> sp 0 h (" :| " <> sl l (')' : t))
completeParser :: MonoidNull s => Compose ParseResults (Compose [] ((,) s)) r -> Compose ParseResults [] r
completeParser (Compose (Left failure)) = Compose (Left failure)
completeParser (Compose (Right (Compose results))) =
case filter (Null.null . fst) results
of [] -> Compose (Left $ ParseFailure 0 ["complete parse"])
completeResults -> Compose (Right $ snd <$> completeResults)
class MultiParsing m where
type ResultFunctor m :: * -> *
type GrammarConstraint m (g :: (* -> *) -> *) :: Constraint
type GrammarConstraint m g = Rank2.Functor g
parseComplete :: (GrammarConstraint m g, FactorialMonoid s) => g (m g s) -> s -> g (ResultFunctor m)
parsePrefix :: (GrammarConstraint m g, FactorialMonoid s) =>
g (m g s) -> s -> g (Compose (ResultFunctor m) ((,) s))
class MultiParsing m => GrammarParsing m where
type GrammarFunctor m :: ((* -> *) -> *) -> * -> * -> *
nonTerminal :: GrammarConstraint m g => (g (GrammarFunctor m g s) -> GrammarFunctor m g s a) -> m g s a
selfReferring :: (GrammarConstraint m g, Rank2.Distributive g) => g (m g s)
fixGrammar :: forall g s. (GrammarConstraint m g, Rank2.Distributive g) => (g (m g s) -> g (m g s)) -> g (m g s)
recursive :: m g s a -> m g s a
selfReferring = Rank2.cotraverse nonTerminal id
fixGrammar = ($ selfReferring)
recursive = id
class MonoidParsing m where
endOfInput :: FactorialMonoid s => m s ()
getInput :: FactorialMonoid s => m s s
anyToken :: FactorialMonoid s => m s s
satisfy :: FactorialMonoid s => (s -> Bool) -> m s s
satisfyChar :: TextualMonoid s => (Char -> Bool) -> m s Char
satisfyCharInput :: TextualMonoid s => (Char -> Bool) -> m s s
notSatisfy :: FactorialMonoid s => (s -> Bool) -> m s ()
notSatisfyChar :: TextualMonoid s => (Char -> Bool) -> m s ()
scan :: FactorialMonoid t => s -> (s -> t -> Maybe s) -> m t t
scanChars :: TextualMonoid t => s -> (s -> Char -> Maybe s) -> m t t
string :: (FactorialMonoid s, LeftReductiveMonoid s, Show s) => s -> m s s
takeWhile :: FactorialMonoid s => (s -> Bool) -> m s s
takeWhile1 :: FactorialMonoid s => (s -> Bool) -> m s s
takeCharsWhile :: TextualMonoid s => (Char -> Bool) -> m s s
takeCharsWhile1 :: TextualMonoid s => (Char -> Bool) -> m s s
concatMany :: Monoid a => m s a -> m s a
class AmbiguousParsing m where
ambiguous :: m a -> m (Ambiguous a)
class Lexical (g :: (* -> *) -> *) where
type LexicalConstraint (m :: ((* -> *) -> *) -> * -> * -> *) g s :: Constraint
lexicalWhiteSpace :: LexicalConstraint m g s => m g s ()
someLexicalSpace :: LexicalConstraint m g s => m g s ()
lexicalComment :: LexicalConstraint m g s => m g s ()
lexicalSemicolon :: LexicalConstraint m g s => m g s Char
lexicalToken :: LexicalConstraint m g s => m g s a -> m g s a
identifierToken :: LexicalConstraint m g s => m g s s -> m g s s
isIdentifierStartChar :: Char -> Bool
isIdentifierFollowChar :: Char -> Bool
identifier :: LexicalConstraint m g s => m g s s
keyword :: LexicalConstraint m g s => s -> m g s ()
type instance LexicalConstraint m g s = (Applicative (m g ()), Monad (m g s),
CharParsing (m g s), MonoidParsing (m g),
Show s, TextualMonoid s)
default lexicalComment :: Alternative (m g s) => m g s ()
default lexicalWhiteSpace :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
=> m g s ()
default someLexicalSpace :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
=> m g s ()
default lexicalSemicolon :: (LexicalConstraint m g s, CharParsing (m g s), MonoidParsing (m g), TextualMonoid s)
=> m g s Char
default lexicalToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
=> m g s a -> m g s a
default identifierToken :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), TextualMonoid s)
=> m g s s -> m g s s
default identifier :: (LexicalConstraint m g s, Monad (m g s), Alternative (m g s),
MonoidParsing (m g), TextualMonoid s) => m g s s
default keyword :: (LexicalConstraint m g s, Parsing (m g s), MonoidParsing (m g), Show s, TextualMonoid s)
=> s -> m g s ()
lexicalWhiteSpace = takeCharsWhile isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace)
someLexicalSpace = takeCharsWhile1 isSpace *> skipMany (lexicalComment *> takeCharsWhile isSpace)
<|> lexicalComment *> skipMany (takeCharsWhile isSpace *> lexicalComment)
lexicalComment = empty
lexicalSemicolon = lexicalToken (char ';')
lexicalToken p = p <* lexicalWhiteSpace
isIdentifierStartChar c = isLetter c || c == '_'
isIdentifierFollowChar c = isAlphaNum c || c == '_'
identifier = identifierToken (liftA2 (<>) (satisfyCharInput (isIdentifierStartChar @g))
(takeCharsWhile (isIdentifierFollowChar @g)))
identifierToken = lexicalToken
keyword s = lexicalToken (string s *> notSatisfyChar (isIdentifierFollowChar @g))