{-# LANGUAGE MagicHash, RecursiveDo, RankNTypes, EmptyDataDecls, GADTs,
             GeneralizedNewtypeDeriving, PatternGuards #-}
-- for the exported rank-2 type of runPeg,
-- as well as the implementation using GADTs, generalised newtype deriving,
-- also a phantom datatype used with unsafeCoerce

-- |
--
-- Linear time composable parser for PEG grammars.
--
-- frisby is a parser library that can parse arbitrary PEG grammars in linear
-- time. Unlike other parsers of PEG grammars, frisby need not be supplied with
-- all possible rules up front, allowing composition of smaller parsers.
--
-- PEG parsers are never ambiguous and allow infinite lookahead with no
-- backtracking penalty. Since PEG parsers can look ahead arbitrarily, they can
-- easily express rules such as the maximal munch rule used in lexers, meaning
-- no separate lexer is needed.
--
-- In addition to many standard combinators, frisby provides routines to
-- translate standard regex syntax into frisby parsers.
--
-- PEG based parsers have a number of advantages over other parsing strategies:
--
-- * PEG parsers are never ambiguous
--
-- * PEG is a generalization of regexes, they can be though of as extended regexes with recursion, predicates, and ordered choice
--
-- * you never need a separate lexing pass with PEG parsers, since you have arbitrary lookahead there is no need to break the stream into tokens to allow the limited LALR or LL lookahead to work.
--
-- * things like the maximal munch and minimal munch rules are trivial to specify with PEGs, yet tricky with other parsers
--
-- * since you have ordered choice, things like the if then else ambiguity are nonexistent.
--
-- * parsers are very very fast, guaranteeing time linear in the size of the input, at the cost of greater memory consumption
--
-- * the ability to make local choices about whether to accept something lets you write parsers that deal gracefully with errors very easy to write, no more uninformative "parse error" messages
--
-- * PEG parsers can be fully lazy, only as much of the input is read as is needed to satisfy the demand on the output, and once the output has been processed, the memory is immediately reclaimed since a PEG parser never 'backtracks'
--
-- * PEG parsers can deal with infinite input, acting in a streaming manner
--
-- * PEG parsers support predicates, letting you decide what rules to follow based on whether other rules apply, so you can have rules that match only if another rule does not match, or a rule that matches only if two other rules both match the same input.
--
-- Traditionally, PEG parsers have suffered from two major flaws:
--
-- * A global table of all productions must be generated or written by hand, disallowing composable parsers implemented as libraries and in general requiring the use of a parser generator tool like 'pappy'
--
-- * Although memory consumption is linear in the size of the input, the constant factor is very large.
--
-- frisby attempts to address both these concerns.
--
-- frisby parsers achieve composability by having a 'compilation' pass,
-- recursive parsers are specified using the recursive do notation 'mdo' which
-- builds up a description of your parser where the recursive calls for which
-- memoized entries must be made are explicit. then 'runPeg' takes this
-- description and compiles it into a form that can be applied, during this
-- compilation step it examines your composed parser, and collects the global
-- table of rules needed for a packrat parser to work.
--
-- Memory consumption is much less of an issue on modern machines; tests show
-- it is not a major concern, however frisby uses a couple of techniques
-- for reducing the impact. First it attempts to create parsers that are as
-- lazy as possible -- this means that no more of the file is read into memory
-- than is needed, and more importantly, memory used by the parser can be
-- reclaimed as you process its output.
--
-- frisby also attempts to 'optimize' your parser, using specialized strategies
-- when allowed to reduce the number of entries in your memoization tables.
--
-- frisby attempts to be lazy in reading the results of parsers, parsers tend
-- to work via sending out \'feeler\' predicates to get an idea of what the
-- rest of the file looks like before deciding what pass to take, frisby
-- attempts to optimize these feeler predicates via extra lazyness such that
-- they do not cause the actual computation of the results, but rather just
-- compute enough to determine whether a predicate would have succeeded or not.
--
-- (It is interesting to note that the memory efficiency of frisby depends
-- vitally on being as lazy as possible, in contrast to traditional thoughts
-- when it comes to memory consumption)
--
-- frisby is a work in progress, it has a darcs repo at
-- <http://repetae.net/repos/frisby> which may be browsed at
-- <http://repetae.net/dw/darcsweb.cgi?r=frisby;a=summary>
--
-- And its homepage is at <http://repetae.net/computer/frisby>
--
--
-- To learn more about PEG parsers, see this paper
-- <http://pdos.csail.mit.edu/~baford/packrat/popl04> and Bryan Ford's packrat
-- parsing page <http://pdos.csail.mit.edu/~baford/packrat/>
--


module Text.Parsers.Frisby(
-- * The basic types
-- ** The type of primitive parsers
    P(),
-- ** The monad used to create recursive parsers via rules
    PM(),
    newRule,
    runPeg,

    module Control.Applicative,

-- * Basic operators
    (//),
    (<>),
    (<++>),

-- ** Derived operators
    (->>),
    (<<-),
    (//>),
-- ** Modification operators
    (##),
    (##>),

-- * Basic combinators
    anyChar,
    bof,
    eof,
    getPos,
    char,
    noneOf,
    oneOf,
    text,
    unit,
    rest,
    discard,
    parseFailure,
-- ** Speculative combinators

-- | These are how a frisby parser decides what path to take, whereas a
-- backtracking parser might try a path, then backtrack if it got it wrong, a
-- frisby parser can look at all possible paths before deciding which one to
-- take via these predicates. this is what allows much of the power of packrat
-- parsing, a parser is free to evaluate every alternative fully before
-- committing to a particular path.
--
-- Packrat parsers have no past, but can \'see\' arbitrarily far into all of
-- its potential futures, traditional monadic parsers can accumulate a history, but
-- cannot see more than a token or two into the future, and evaluating multiple
-- futures to any degree imposes a significant run-time penalty due to backtracking.
--
    peek,
    doesNotMatch,
    isMatch,
    onlyIf,
    matches,
-- ** Looping combinators
    many,
    many1,
    manyUntil,

-- ** Various utility combinators
    between,
    choice,
    option,
    optional,
-- * Regular expression syntax
-- | Take a string in extended regex format and return a frisby parser that has the same behavior.
-- The behavior is slightly different than POSIX regular expressions.
-- frisby regular expressions always follow the 'true' maximal or minimal munch
-- rules, rather than the (unuseful and inefficient) greedy rule of POSIX regexs.
-- What this means is something like
-- @x*x@ will never match, because the first @x*@ will munch every x available so the second won't match.
-- Minimal munching can be expressed like in perl,
-- @.*?y@ will grab everything up to the next y. In posix it would grab everything up til the last y in the file.
-- These are much more natural semantics and much more efficient to implement.
--
    newRegex,
    regex,
    showRegex
   )where

import Control.Applicative
   hiding(many,optional) --though same meaning 'many', and superior 'optional'
import qualified Control.Applicative (many)
import qualified Data.IntSet as IntSet
import Control.Monad.Fix
import Control.Monad.Fail
import Control.Monad.Identity
import Data.Char(ord,chr)
import Control.Monad.State
import Data.Array hiding((//))
import Data.Semigroup (Semigroup)
import qualified Data.Semigroup as Semigroup
import Data.Monoid hiding(Any,(<>))
import qualified Data.Map as Map
import qualified Control.Monad.Fail as Fail
import Unsafe.Coerce (unsafeCoerce)
import Prelude hiding((<>))

-- Essentially we are manipulating a polytypic cyclic graph (the P structure).
-- This is difficult to do in Haskell.
-- Graphs have always been difficult in Haskell. They're not inductive.
-- GADTs suffice well for polytypic trees.
-- The moment it becomes non-inductive...
-- _Implicit_ (directed-)acyclic-graph sharing can be introduced
--                with non-recursive lets/lambdas.
-- _Implicit_ (directed or not)-cyclic-graph-sharing can be introduced
--                with recursive lets / the least fixed point operator.
-- But when sharing is implicit we can't detect it while performing induction
-- over the graph, so we get infinite loops or simply failing to detect
-- intended sharing.  After all Haskell is referentially transparent!
-- But we want to be able to optimize this graph to achieve the potential
-- of PEG parsers.  This is possible to do explicitly, though a bit ugly
-- and seems to be beyond Haskell's static type system when not everything
-- in the graph has the same type.
--
-- To specify input in a way that we can understand the finite structure,
-- the best we have, to recommend, is mdo.  With this, it's the user's
-- responsibility not to create cycles that don't go through the monad.
-- (e.g. let q p = (conid <++> text "." <++> q p) // p
-- needs to involve mdo/mfix such as
--  let q p = mfix $ \qp -> (conid <++> text "." <++> qp) // p
-- , which makes its usage a little different)
-- With rank-2 types, it is *not* the user's responsibility to avoid mixing
-- up P's from different PM's, which is a good thing because that's not
-- typesafe or at least not abstraction-safe.  (e.g. this can't be used
-- in a parser monad that is itself runPeg'd:
--     runPeg (mdo
--               good <- newRule $ text "good"
--               evil <- newRule $ unit good
--               return evil
--            )
-- ).
--
-- Now we have the polytypic cyclic graph, can we manipulate it with Haskell's
-- type-system?  Unfortunately, the Named graph-vertices pose a difficulty.
-- The PM monad could perhaps be based on, instead of numerical indexes,
-- ST(Refs) (since the ST interface cannot be implemented in any known Haskell
-- typesystem without unsafeCoerce, it constitutes an extension to the
-- type system, in a sense -- is this correct?).  But then we have to
-- duplicate the memoization for each character in the input stream, keeping
-- each reference to a top-level parser referring to it --
-- not to the original, but to the saturated, memoized (lazy thunk) version!
-- Not sure this is possible here without unsafeCoerce.
--
-- Of course, with unsafeCoerce we could theoretically eliminate a bunch of
-- other type system extensions we internally use, such as GADTs. That would
-- be a terrible hack.

newtype Token = Token Int
    deriving(Token -> Token -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Token -> Token -> Bool
$c/= :: Token -> Token -> Bool
== :: Token -> Token -> Bool
$c== :: Token -> Token -> Bool
Eq,Eq Token
Token -> Token -> Bool
Token -> Token -> Ordering
Token -> Token -> Token
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Token -> Token -> Token
$cmin :: Token -> Token -> Token
max :: Token -> Token -> Token
$cmax :: Token -> Token -> Token
>= :: Token -> Token -> Bool
$c>= :: Token -> Token -> Bool
> :: Token -> Token -> Bool
$c> :: Token -> Token -> Bool
<= :: Token -> Token -> Bool
$c<= :: Token -> Token -> Bool
< :: Token -> Token -> Bool
$c< :: Token -> Token -> Bool
compare :: Token -> Token -> Ordering
$ccompare :: Token -> Token -> Ordering
Ord,Integer -> Token
Token -> Token
Token -> Token -> Token
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> Token
$cfromInteger :: Integer -> Token
signum :: Token -> Token
$csignum :: Token -> Token
abs :: Token -> Token
$cabs :: Token -> Token
negate :: Token -> Token
$cnegate :: Token -> Token
* :: Token -> Token -> Token
$c* :: Token -> Token -> Token
- :: Token -> Token -> Token
$c- :: Token -> Token -> Token
+ :: Token -> Token -> Token
$c+ :: Token -> Token -> Token
Num,Int -> Token -> ShowS
[Token] -> ShowS
Token -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Token] -> ShowS
$cshowList :: [Token] -> ShowS
show :: Token -> String
$cshow :: Token -> String
showsPrec :: Int -> Token -> ShowS
$cshowsPrec :: Int -> Token -> ShowS
Show,Ord Token
(Token, Token) -> Int
(Token, Token) -> [Token]
(Token, Token) -> Token -> Bool
(Token, Token) -> Token -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (Token, Token) -> Int
$cunsafeRangeSize :: (Token, Token) -> Int
rangeSize :: (Token, Token) -> Int
$crangeSize :: (Token, Token) -> Int
inRange :: (Token, Token) -> Token -> Bool
$cinRange :: (Token, Token) -> Token -> Bool
unsafeIndex :: (Token, Token) -> Token -> Int
$cunsafeIndex :: (Token, Token) -> Token -> Int
index :: (Token, Token) -> Token -> Int
$cindex :: (Token, Token) -> Token -> Int
range :: (Token, Token) -> [Token]
$crange :: (Token, Token) -> [Token]
Ix)

-- the monad used for creating recursive values
newtype PM s a = PM (PMImp a)
    deriving(forall {s}. Applicative (PM s)
forall a. a -> PM s a
forall s a. a -> PM s a
forall a b. PM s a -> PM s b -> PM s b
forall a b. PM s a -> (a -> PM s b) -> PM s b
forall s a b. PM s a -> PM s b -> PM s b
forall s a b. PM s a -> (a -> PM s b) -> PM s b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> PM s a
$creturn :: forall s a. a -> PM s a
>> :: forall a b. PM s a -> PM s b -> PM s b
$c>> :: forall s a b. PM s a -> PM s b -> PM s b
>>= :: forall a b. PM s a -> (a -> PM s b) -> PM s b
$c>>= :: forall s a b. PM s a -> (a -> PM s b) -> PM s b
Monad,forall {s}. Functor (PM s)
forall a. a -> PM s a
forall s a. a -> PM s a
forall a b. PM s a -> PM s b -> PM s a
forall a b. PM s a -> PM s b -> PM s b
forall a b. PM s (a -> b) -> PM s a -> PM s b
forall s a b. PM s a -> PM s b -> PM s a
forall s a b. PM s a -> PM s b -> PM s b
forall s a b. PM s (a -> b) -> PM s a -> PM s b
forall a b c. (a -> b -> c) -> PM s a -> PM s b -> PM s c
forall s a b c. (a -> b -> c) -> PM s a -> PM s b -> PM s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. PM s a -> PM s b -> PM s a
$c<* :: forall s a b. PM s a -> PM s b -> PM s a
*> :: forall a b. PM s a -> PM s b -> PM s b
$c*> :: forall s a b. PM s a -> PM s b -> PM s b
liftA2 :: forall a b c. (a -> b -> c) -> PM s a -> PM s b -> PM s c
$cliftA2 :: forall s a b c. (a -> b -> c) -> PM s a -> PM s b -> PM s c
<*> :: forall a b. PM s (a -> b) -> PM s a -> PM s b
$c<*> :: forall s a b. PM s (a -> b) -> PM s a -> PM s b
pure :: forall a. a -> PM s a
$cpure :: forall s a. a -> PM s a
Applicative,forall s. Monad (PM s)
forall a. (a -> PM s a) -> PM s a
forall s a. (a -> PM s a) -> PM s a
forall (m :: * -> *).
Monad m -> (forall a. (a -> m a) -> m a) -> MonadFix m
mfix :: forall a. (a -> PM s a) -> PM s a
$cmfix :: forall s a. (a -> PM s a) -> PM s a
MonadFix,forall a b. a -> PM s b -> PM s a
forall a b. (a -> b) -> PM s a -> PM s b
forall s a b. a -> PM s b -> PM s a
forall s a b. (a -> b) -> PM s a -> PM s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> PM s b -> PM s a
$c<$ :: forall s a b. a -> PM s b -> PM s a
fmap :: forall a b. (a -> b) -> PM s a -> PM s b
$cfmap :: forall s a b. (a -> b) -> PM s a -> PM s b
Functor)

type PMImp a = State Token a


-- 's' added for safe state, just as the ST monad's interface uses
newtype P s a = P { forall s a. P s a -> PE a
fromP :: PE a }
    deriving(forall a b. a -> P s b -> P s a
forall a b. (a -> b) -> P s a -> P s b
forall s a b. a -> P s b -> P s a
forall s a b. (a -> b) -> P s a -> P s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> P s b -> P s a
$c<$ :: forall s a b. a -> P s b -> P s a
fmap :: forall a b. (a -> b) -> P s a -> P s b
$cfmap :: forall s a b. (a -> b) -> P s a -> P s b
Functor,forall s. Functor (P s)
forall a. a -> P s a
forall s a. a -> P s a
forall a b. P s a -> P s b -> P s a
forall a b. P s a -> P s b -> P s b
forall a b. P s (a -> b) -> P s a -> P s b
forall s a b. P s a -> P s b -> P s a
forall s a b. P s a -> P s b -> P s b
forall s a b. P s (a -> b) -> P s a -> P s b
forall a b c. (a -> b -> c) -> P s a -> P s b -> P s c
forall s a b c. (a -> b -> c) -> P s a -> P s b -> P s c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. P s a -> P s b -> P s a
$c<* :: forall s a b. P s a -> P s b -> P s a
*> :: forall a b. P s a -> P s b -> P s b
$c*> :: forall s a b. P s a -> P s b -> P s b
liftA2 :: forall a b c. (a -> b -> c) -> P s a -> P s b -> P s c
$cliftA2 :: forall s a b c. (a -> b -> c) -> P s a -> P s b -> P s c
<*> :: forall a b. P s (a -> b) -> P s a -> P s b
$c<*> :: forall s a b. P s (a -> b) -> P s a -> P s b
pure :: forall a. a -> P s a
$cpure :: forall s a. a -> P s a
Applicative,forall s. Applicative (P s)
forall a. P s a
forall a. P s a -> P s [a]
forall a. P s a -> P s a -> P s a
forall s a. P s a
forall s a. P s a -> P s [a]
forall s a. P s a -> P s a -> P s a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. P s a -> P s [a]
$cmany :: forall s a. P s a -> P s [a]
some :: forall a. P s a -> P s [a]
$csome :: forall s a. P s a -> P s [a]
<|> :: forall a. P s a -> P s a -> P s a
$c<|> :: forall s a. P s a -> P s a -> P s a
empty :: forall a. P s a
$cempty :: forall s a. P s a
Alternative,NonEmpty (P s a) -> P s a
P s a -> P s a -> P s a
forall b. Integral b => b -> P s a -> P s a
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall s a. NonEmpty (P s a) -> P s a
forall s a. P s a -> P s a -> P s a
forall s a b. Integral b => b -> P s a -> P s a
stimes :: forall b. Integral b => b -> P s a -> P s a
$cstimes :: forall s a b. Integral b => b -> P s a -> P s a
sconcat :: NonEmpty (P s a) -> P s a
$csconcat :: forall s a. NonEmpty (P s a) -> P s a
<> :: P s a -> P s a -> P s a
$c<> :: forall s a. P s a -> P s a -> P s a
Semigroup,P s a
[P s a] -> P s a
P s a -> P s a -> P s a
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall s a. Semigroup (P s a)
forall s a. P s a
forall s a. [P s a] -> P s a
forall s a. P s a -> P s a -> P s a
mconcat :: [P s a] -> P s a
$cmconcat :: forall s a. [P s a] -> P s a
mappend :: P s a -> P s a -> P s a
$cmappend :: forall s a. P s a -> P s a -> P s a
mempty :: P s a
$cmempty :: forall s a. P s a
Monoid)

data PE a where
    Char :: IntSet.IntSet -> PE Char
    Any  ::  PE Char
    Failure :: PE a
    Named :: Token -> PE a -> PE a
    Not :: PE a -> PE ()
    PMap :: (a -> b) -> PE a -> PE b
    Slash :: PE a -> PE a -> PE a
    ThenCat :: PE [a] -> PE [a] -> PE [a]
    Star :: PE a -> PE [a]
    StarUntil :: PE a -> PE b -> PE [a]
    StarMax :: Int -> PE a -> PE [a]

    Then :: PE a -> PE b -> PE (a,b)
    GetPos :: PE Int
    Unit :: a -> PE a
    When :: PE a -> (a -> Bool) -> PE a
    Rest :: PE [Char]
    Peek :: PE a -> PE a



instance Functor PE where
    fmap :: forall a b. (a -> b) -> PE a -> PE b
fmap = forall a b. (a -> b) -> PE a -> PE b
PMap

instance Applicative PE where
--should another constructor be added, rather?
--perhaps Then and ThenCat combined and parameterized by
--the function (++), (,) ... but, 'text', etc, does this too
    PE (a -> b)
mf <*> :: forall a b. PE (a -> b) -> PE a -> PE b
<*> PE a
ma = forall a b. (a -> b) -> PE a -> PE b
PMap (\(a -> b
f,a
a) -> a -> b
f a
a) (forall a b. PE a -> PE b -> PE (a, b)
Then PE (a -> b)
mf PE a
ma)
    pure :: forall a. a -> PE a
pure = forall a. a -> PE a
Unit

instance Alternative PE where
    <|> :: forall a. PE a -> PE a -> PE a
(<|>) = forall a. PE a -> PE a -> PE a
Slash
    empty :: forall a. PE a
empty = forall a. PE a
Failure
    some :: forall a. PE a -> PE [a]
some PE a
p = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. PE a -> PE b -> PE (a, b)
Then PE a
p (forall a. PE a -> PE [a]
Star PE a
p)
    many :: forall a. PE a -> PE [a]
many  = forall a. PE a -> PE [a]
Star

instance Semigroup (PE a) where
    <> :: PE a -> PE a -> PE a
(<>) = forall a. PE a -> PE a -> PE a
Slash

instance Monoid (PE a) where
    mappend :: PE a -> PE a -> PE a
mappend = forall a. Semigroup a => a -> a -> a
(Semigroup.<>)
    mempty :: PE a
mempty = forall a. PE a
Failure


-- | Return a value, always succeeds
unit :: a ->  P s a
unit :: forall a s. a -> P s a
unit a
a = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ forall a. a -> PE a
Unit a
a

-- | Match a specified character
char :: Char -> P s Char
char :: forall s. Char -> P s Char
char Char
c = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ IntSet -> PE Char
Char (Int -> IntSet
IntSet.singleton (Char -> Int
ord Char
c))

-- | Match some text
text :: String -> P s String
text :: forall s. String -> P s String
text (Char
x:String
xs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ( \ (Char
c,String
cs) -> Char
cforall a. a -> [a] -> [a]
:String
cs) forall a b. (a -> b) -> a -> b
$ forall s. Char -> P s Char
char Char
x forall s a b. P s a -> P s b -> P s (a, b)
<> forall s. String -> P s String
text String
xs
text [] = forall a s. a -> P s a
unit []

-- | Immediately consume and return the rest of the input
-- equivalent to (many anyChar), but more efficient.
rest :: P s String
rest :: forall s. P s String
rest = forall s a. PE a -> P s a
P PE String
Rest

-- | Match any character, fails on EOF
anyChar :: P s Char
anyChar :: forall s. P s Char
anyChar = forall s a. PE a -> P s a
P PE Char
Any

infixl 1 //, //>
infix  2 ##, ##>
infixl 3 <>, <++>
infixl 4 ->>, <<-

-- | Match first argument, then match the second, returning both in a tuple
(<>) :: P s a -> P s b -> P s (a,b)
P PE a
x <> :: forall s a b. P s a -> P s b -> P s (a, b)
<> P PE b
y = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ PE a
x forall a b. PE a -> PE b -> PE (a, b)
`Then` PE b
y

-- | Match a pair of lists and concatenate them
(<++>) :: P s [a] -> P s [a] -> P s [a]
P PE [a]
x <++> :: forall s a. P s [a] -> P s [a] -> P s [a]
<++> P PE [a]
y = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ PE [a]
x forall a. PE [a] -> PE [a] -> PE [a]
`ThenCat` PE [a]
y

-- | Match first argument, then match the second, returning only the value on the left.
--
-- > x <<- y = x <> y ## fst
--
(<<-) :: P s a -> P s b -> P s a
P s a
x <<- :: forall s a b. P s a -> P s b -> P s a
<<- P s b
y = P s a
x forall s a b. P s a -> P s b -> P s (a, b)
<> P s b
y forall s a b. P s a -> (a -> b) -> P s b
## forall a b. (a, b) -> a
fst

-- | Match first argument, then match the second, returning only the value on the right.
--
-- > x ->> y = x <> y ## snd
(->>) :: P s a -> P s b -> P s b
P s a
x ->> :: forall s a b. P s a -> P s b -> P s b
->> P s b
y = P s a
x forall s a b. P s a -> P s b -> P s (a, b)
<> P s b
y forall s a b. P s a -> (a -> b) -> P s b
## forall a b. (a, b) -> b
snd

-- | Ordered choice, try left argument, if it fails try the right one.
-- This does not introduce any backtracking or penalty.
(//) :: P s a -> P s a -> P s a
P PE a
x // :: forall s a. P s a -> P s a -> P s a
// P PE a
y = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ PE a
x forall a. PE a -> PE a -> PE a
`Slash` PE a
y

-- | Ordered choice, try left argument, if it fails then return right argument.
(//>) :: P s a -> a -> P s a
P s a
x //> :: forall s a. P s a -> a -> P s a
//> a
y = P s a
x forall s a. P s a -> P s a -> P s a
// forall a s. a -> P s a
unit a
y

-- | Map a parser through a function. a fancy version of 'fmap'.
(##) :: P s a -> (a -> b) -> P s b
P s a
x ## :: forall s a b. P s a -> (a -> b) -> P s b
## a -> b
y = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
y P s a
x

-- | Parse left argument and return the right argument.
(##>) :: P s a -> b -> P s b
P s a
x ##> :: forall s a b. P s a -> b -> P s b
##> b
y = forall s a. P s a -> P s ()
discard P s a
x forall s a b. P s a -> P s b -> P s b
->> forall a s. a -> P s a
unit b
y


-- | Succeeds when the argument does not.
doesNotMatch :: P s a -> P s ()
doesNotMatch :: forall s a. P s a -> P s ()
doesNotMatch (P PE a
x) = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ forall a. PE a -> PE ()
Not PE a
x

-- | Succeeds when the argument does, but consumes no input.
-- Equivalant to \p -> discard (peek p)
matches :: P s a -> P s ()
matches :: forall s a. P s a -> P s ()
matches =  forall s a. P s a -> P s a
peek forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. P s a -> P s ()
discard

-- | Parse something and return it,  but do not advance the input stream.
peek :: P s a -> P s a
peek :: forall s a. P s a -> P s a
peek (P PE a
p) = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ forall a. PE a -> PE a
Peek PE a
p

-- | Succeed only if thing parsed passes a predicate.
onlyIf :: P s a -> (a -> Bool) -> P s a
onlyIf :: forall s a. P s a -> (a -> Bool) -> P s a
onlyIf (P PE a
x) a -> Bool
y = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ forall a. PE a -> (a -> Bool) -> PE a
When PE a
x a -> Bool
y

-- | Parse many of something. Behaves like * in regexes.
-- This eats as much as it possibly can, if you want a minimal much rule, then use 'manyUntil' which stops when a.
--

many :: P s a -> P s [a]
many :: forall s a. P s a -> P s [a]
many (P PE a
p) = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ forall a. PE a -> PE [a]
Star PE a
p

-- | Parse many of something via the minimal munch rule. behaves like *? in
-- perl regexes. The final item is not consumed.

manyUntil :: P s b -> P s a -> PM s (P s [a])
manyUntil :: forall s b a. P s b -> P s a -> PM s (P s [a])
manyUntil P s b
final P s a
p =
  do rec P s [a]
rule <- forall s a. P s a -> PM s (P s a)
newRule forall a b. (a -> b) -> a -> b
$ forall s a. P s a -> P s ()
matches P s b
final forall s a b. P s a -> b -> P s b
##> []
                 forall s a. P s a -> P s a -> P s a
// P s a
p forall s a b. P s a -> P s b -> P s (a, b)
<> P s [a]
rule forall s a b. P s a -> (a -> b) -> P s b
## forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:)
     forall (m :: * -> *) a. Monad m => a -> m a
return P s [a]
rule

-- | First matching parse wins, a simple iteration of (\/\/).
choice :: [P s a] -> P s a
choice :: forall s a. [P s a] -> P s a
choice = forall a. Monoid a => [a] -> a
mconcat

-- | Get current position in file as number of characters since the beginning.
getPos :: P s Int
getPos :: forall s. P s Int
getPos = forall s a. PE a -> P s a
P PE Int
GetPos

-- | Equivalent to
--
-- > between open close thing = open ->> thing <<- close
between :: P s a -> P s b -> P s c -> P s c
between :: forall s a b c. P s a -> P s b -> P s c -> P s c
between P s a
open P s b
close P s c
thing = P s a
open forall s a b. P s a -> P s b -> P s b
->> P s c
thing forall s a b. P s a -> P s b -> P s a
<<- P s b
close

-- | Parse something if you can, else return first value
--
-- > option a p = p // unit a
option :: a -> P s a -> P s a
option :: forall a s. a -> P s a -> P s a
option a
a P s a
p = P s a
p forall s a. P s a -> P s a -> P s a
// forall a s. a -> P s a
unit a
a

-- | Parse something if you can, discarding it.
--
-- > option a p = discard p // unit ()
optional :: P s a -> P s ()
optional :: forall s a. P s a -> P s ()
optional P s a
p = forall s a. P s a -> P s ()
discard P s a
p forall s a. P s a -> P s a -> P s a
// forall a s. a -> P s a
unit ()

-- | Throw away the result of something.
--
-- > discard p = p ->> unit ()
discard :: P s a -> P s ()
discard :: forall s a. P s a -> P s ()
discard P s a
p = P s a
p forall s a b. P s a -> P s b -> P s b
->> forall a s. a -> P s a
unit ()

-- | am at the end of string.
eof :: P s ()
eof :: forall s. P s ()
eof = forall s a. P s a -> P s ()
doesNotMatch forall s. P s Char
anyChar

-- | am at the beginning of the string.
bof :: P s ()
bof :: forall s. P s ()
bof = forall s a. P s a -> P s ()
discard (forall s. P s Int
getPos forall s a. P s a -> (a -> Bool) -> P s a
`onlyIf` (forall a. Eq a => a -> a -> Bool
== Int
0))


-- | Match one or more of something via maximal munch rule.
many1 :: P s a -> P s [a]
many1 :: forall s a. P s a -> P s [a]
many1 P s a
x  = (\ (a
c,[a]
cs) -> a
cforall a. a -> [a] -> [a]
:[a]
cs)  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (P s a
x forall s a b. P s a -> P s b -> P s (a, b)
<> forall s a. P s a -> P s [a]
many P s a
x)

-- | Match one of the set of characters.
oneOf :: [Char] -> P s Char
oneOf :: forall s. String -> P s Char
oneOf [] = forall s a. P s a
parseFailure
oneOf String
xs = forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ IntSet -> PE Char
Char ([Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord String
xs) -- foldl (//) parseFailure (map char xs)

-- | Match any character other than the ones in the list.
noneOf :: [Char] -> P s Char
noneOf :: forall s. String -> P s Char
noneOf [] = forall s. P s Char
anyChar
noneOf String
xs = forall s a. P s a -> P s ()
doesNotMatch (forall s. String -> P s Char
oneOf String
xs) forall s a b. P s a -> P s b -> P s b
->> forall s. P s Char
anyChar  -- foldl (//) parseFailure (map char xs)

-- | Fails, is identity of (\/\/) and unit of (\<\>).
parseFailure :: P s a
parseFailure :: forall s a. P s a
parseFailure = forall s a. PE a -> P s a
P forall a. PE a
Failure




-- Just used to coerce values to so they can be stashed away in the array.
data Unknown

type DerivMapTo a = Array Token a

type NM a = State (Token,Map.Map Token Token,[(Token,PE Unknown)]) a

normalizePElem :: PE a -> (PE a, DerivMapTo (PE Unknown))
normalizePElem :: forall a. PE a -> (PE a, DerivMapTo (PE Unknown))
normalizePElem PE a
pe = (PE a
rootNormPE, DerivMapTo (PE Unknown)
normPEs)
  where
    (PE a
rootNormPE, (Token, Map Token Token, [(Token, PE Unknown)])
state) = forall s a. State s a -> s -> (a, s)
runState (forall a. PE a -> NM (PE a)
normalizePElemNM PE a
pe) (Token
0,forall a. Monoid a => a
mempty,forall a. Monoid a => a
mempty)
    normPEs :: DerivMapTo (PE Unknown)
normPEs = forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
array (Token
0, Token
nTokens forall a. Num a => a -> a -> a
- Token
1) [(Token, PE Unknown)]
assocNormPEs
                where (Token
nTokens, Map Token Token
_, [(Token, PE Unknown)]
assocNormPEs) = (Token, Map Token Token, [(Token, PE Unknown)])
state

normalizePElemNM :: PE a -> NM (PE a)
normalizePElemNM :: forall a. PE a -> NM (PE a)
normalizePElemNM PE a
pe = forall a. PE a -> NM (PE a)
f PE a
pe where
    f :: forall a . PE a -> NM (PE a)
    f :: forall a. PE a -> NM (PE a)
f (Then PE a
x PE b
y) = do
        PE a
x <- forall a. PE a -> NM (PE a)
f PE a
x
        PE b
y <- forall a. PE a -> NM (PE a)
f PE b
y
        case (PE a
x,PE b
y) of
            (PE a
Failure,PE b
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
            (PE a
_,PE b
Failure) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
            (Unit a
a,Unit b
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> PE a
Unit (a
a,b
b))
            (PE a
x,PE b
y) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. PE a -> PE b -> PE (a, b)
Then PE a
x PE b
y)
    f (ThenCat PE [a]
x PE [a]
y) = do
        PE [a]
x <- forall a. PE a -> NM (PE a)
f PE [a]
x
        PE [a]
y <- forall a. PE a -> NM (PE a)
f PE [a]
y
        case (PE [a]
x,PE [a]
y) of
            (PE [a]
Failure,PE [a]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
            (PE [a]
_,PE [a]
Failure) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
            (Unit [a]
a,Unit [a]
b) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> PE a
Unit ([a]
a forall a. [a] -> [a] -> [a]
++ [a]
b))
            (PE [a]
x,PE [a]
y) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PE [a] -> PE [a] -> PE [a]
ThenCat PE [a]
x PE [a]
y)
    f (Slash PE a
x PE a
y) = do
        PE a
x <- forall a. PE a -> NM (PE a)
f PE a
x
        PE a
y <- forall a. PE a -> NM (PE a)
f PE a
y
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. PE a -> PE a -> PE a
slash PE a
x PE a
y

    f (Char IntSet
x) | IntSet -> Bool
IntSet.null IntSet
x = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
    f c :: PE a
c@Char {} = forall (m :: * -> *) a. Monad m => a -> m a
return PE a
c
    f p :: PE a
p@PE a
Failure = forall (m :: * -> *) a. Monad m => a -> m a
return PE a
p
    f p :: PE a
p@Unit {} = forall (m :: * -> *) a. Monad m => a -> m a
return PE a
p
    f p :: PE a
p@PE a
Any = forall (m :: * -> *) a. Monad m => a -> m a
return PE a
p
    f p :: PE a
p@PE a
GetPos = forall (m :: * -> *) a. Monad m => a -> m a
return PE a
p
    f PE a
Rest = forall (m :: * -> *) a. Monad m => a -> m a
return PE String
Rest
    f (When PE a
p a -> Bool
fn) = forall a. PE a -> NM (PE a)
f PE a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PE a
p' -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PE a -> (a -> Bool) -> PE a
When PE a
p' a -> Bool
fn)
    f (PMap a -> a
fn PE a
x) = forall a b. (a -> b) -> PE a -> PE b
PMap a -> a
fn forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall a. PE a -> NM (PE a)
f PE a
x
    f (Star PE a
p) = forall a. PE a -> NM (PE a)
f PE a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PE a
x -> case PE a
x of
        PE a
Failure -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> PE a
Unit []
--        Unit x -> return $ repeat x
        PE a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PE a -> PE [a]
Star PE a
x)
    f (Not PE a
p) = do
        PE a
x <- forall a. PE a -> NM (PE a)
f PE a
p
        case PE a
x of
            PE a
Rest -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
            Unit {} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. PE a
Failure
            PE a
Failure -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> PE a
Unit ())
            PE a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PE a -> PE ()
Not PE a
x)
    f (Peek PE a
p) = forall a. PE a -> NM (PE a)
f PE a
p forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \PE a
x -> case PE a
x of
        -- No need to backtrack-Peek if we're not consuming anything anyway
        PE a
x | forall a. PE a -> Bool
mayConsumeInput PE a
x forall a. Eq a => a -> a -> Bool
== Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return PE a
x
        PE a
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. PE a -> PE a
Peek PE a
x)
    f (Named Token
n PE a
p) = do
        (Token
i,Map Token Token
m,[(Token, PE Unknown)]
cm) <- forall s (m :: * -> *). MonadState s m => m s
get
        case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Token
n Map Token Token
m of
            Just Token
v -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Token -> PE a -> PE a
Named Token
v (forall a. HasCallStack => String -> a
error String
"no need"))
            Maybe Token
Nothing -> do
                forall s (m :: * -> *). MonadState s m => s -> m ()
put (Token
i forall a. Num a => a -> a -> a
+ Token
1,forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Token
n Token
i Map Token Token
m,[(Token, PE Unknown)]
cm)
                PE a
p' <- forall a. PE a -> NM (PE a)
f PE a
p
                (Token
ni,Map Token Token
m,[(Token, PE Unknown)]
cm) <- forall s (m :: * -> *). MonadState s m => m s
get
                forall s (m :: * -> *). MonadState s m => s -> m ()
put (Token
ni,Map Token Token
m,(Token
i,forall a b. a -> b
unsafeCoerce PE a
p' :: PE Unknown)forall a. a -> [a] -> [a]
:[(Token, PE Unknown)]
cm)
                forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Token -> PE a -> PE a
Named Token
i (forall a. HasCallStack => String -> a
error String
"no need"))
    slash :: forall a . PE a -> PE a -> PE a
    slash :: forall a. PE a -> PE a -> PE a
slash PE a
a PE a
Failure  = PE a
a
    slash PE a
Failure PE a
b  = PE a
b
    slash (Unit a
a) PE a
_ = (forall a. a -> PE a
Unit a
a)
    slash (PE a
Rest) PE a
_   = PE String
Rest
    slash (Char IntSet
x) (Char IntSet
y) = (IntSet -> PE Char
Char (IntSet
x forall a. Monoid a => a -> a -> a
`mappend` IntSet
y))
    slash PE a
Any Char {} = PE Char
Any
    slash Char {} PE a
Any = PE Char
Any
    slash PE a
x PE a
y = forall a. PE a -> PE a -> PE a
Slash PE a
x PE a
y
    -- It's okay, just suboptimal, to return True when input can't be consumed;
    -- it's incorrect to return False when it might in fact consume input.
    mayConsumeInput :: PE a -> Bool
    mayConsumeInput :: forall a. PE a -> Bool
mayConsumeInput PE a
Failure = Bool
False
    mayConsumeInput Unit {} = Bool
False
    mayConsumeInput (Then PE a
x PE b
y) = forall a. PE a -> Bool
mayConsumeInput PE a
x Bool -> Bool -> Bool
|| forall a. PE a -> Bool
mayConsumeInput PE b
y
    mayConsumeInput (ThenCat PE [a]
x PE [a]
y) = forall a. PE a -> Bool
mayConsumeInput PE [a]
x Bool -> Bool -> Bool
|| forall a. PE a -> Bool
mayConsumeInput PE [a]
y
    mayConsumeInput (Slash PE a
x PE a
y) = forall a. PE a -> Bool
mayConsumeInput PE a
x Bool -> Bool -> Bool
|| forall a. PE a -> Bool
mayConsumeInput PE a
y
    mayConsumeInput Not {} = Bool
False
    mayConsumeInput PE a
_ = Bool
True

-- these fields must not be strict!
-- although, derivIndex is explicitly seq'd in one place before
-- being put into a Derivs, which is fine (in fact, important,
-- so that an unevaluated chain of thunks from the past doesn't
-- build up when the character index isn't needed for a while)
data Derivs = Derivs {
    Derivs -> Results Char
derivChar :: (Results Char),
    Derivs -> Int
derivIndex :: Int,
    Derivs -> DerivMapTo (Results Unknown)
derivArray :: DerivMapTo (Results Unknown),
    Derivs -> String
derivRest :: String
    }

data Results a = Parsed a Derivs | NoParse

--this instance really should be derived
--(once deriving Functor is available) :
instance Functor Results where
    fmap :: forall a b. (a -> b) -> Results a -> Results b
fmap a -> b
f (Parsed a
a Derivs
arr) = forall a. a -> Derivs -> Results a
Parsed (a -> b
f a
a) Derivs
arr
    fmap a -> b
_ Results a
NoParse = forall a. Results a
NoParse



-- | Run a PEG grammar. Takes the rank-2 argument in order to ensure a rule
-- created in one PM session isn't returned and used in another PEG parser.
--
-- There is no need for special error handling, as it can be trivially implemented via
--
-- >  -- parse complete file, returning 'Nothing' if parse fails
-- >  fmap Just (myParser <<- eof) // unit Nothing
--
-- There is also no need for the parser to return its unused input, as that can be retrieved via 'rest'.
--
-- > -- Now this returns (a,String) where String is the unconsumed input.
-- > myParser <> rest
--
--

runPeg :: (forall s . PM s (P s a)) -> String -> a
runPeg :: forall a. (forall s. PM s (P s a)) -> String -> a
runPeg forall s. PM s (P s a)
peg =
   --there is a nontrivial amount of work that only depends
   --on peg, so let's suggest that to be shared by using an
   --explicit lambda here that the where clause is not "inside"
    (\String
input -> String -> a
pout String
input)
  where
    pout :: String -> a
pout String
input = case Derivs -> Results a
rootParser (Int -> String -> Derivs
f Int
0 String
input) of
        Parsed a
a Derivs
_ -> a
a
        Results a
NoParse -> forall a. HasCallStack => String -> a
error String
"runPeg: no parse"
    emptyDAt :: Int -> Derivs
emptyDAt Int
n = Derivs
emptyD { derivIndex :: Int
derivIndex = Int
n }
      where emptyD :: Derivs
emptyD = Int -> String -> Derivs
f Int
0 [] --is the sharing here (particularly the array)
              -- worth much? (does it necessarily even exist if we stuff
              -- it into a where clause like this?)
    --Optimize the parser once initially
    --The two separate uses of state:
    -- -first (evalState) we number all parsers (newRules) to make
    --   loops detectable. The numbering scheme is entirely arbitrary here;
    --   it doesn't really matter what number to start with in the state.
    -- -then (runState) we optimize the parsers to be more similar to
    --   each other where possible(?), in the process renumbering the
    --   parsers such that unused ones are not included and the order
    --   is somewhat arbitrary.  The new set of numbers (called "Token"s)
    --   start counting from zero, to be compactly used in an
    --   array of length equal to the number of referenced (potentially-used)
    --   named parsers.  This state's Map is just to look up the meaning
    --   of the old token-numbering in terms of the new numbers.
    --
    --rootPElemBeforeNormalization actually contains all parsers it references,
    --recursively, just labelled by PM so the infinite recursion can be
    --detected and stopped.
    rootPElemBeforeNormalization :: PE a
rootPElemBeforeNormalization = forall s a. P s a -> PE a
fromP forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> a
evalState (case forall s. PM s (P s a)
peg of PM State Token (P Any a)
x -> State Token (P Any a)
x) Token
1
    --rootPElemAfterNormalization need not be among the array if it is just
    --the parser used to get started at the beginning of input, such as:
    --       mdo p <- newRule $ ...; return (p <> rest)
    (PE a
rootPElemAfterNormalization, DerivMapTo (PE Unknown)
arrayNormalizedPElems)
                      = forall a. PE a -> (PE a, DerivMapTo (PE Unknown))
normalizePElem PE a
rootPElemBeforeNormalization
    --arrayParsers, rootParser are out here for increased sharing of g's work
    arrayParsers :: Array Token (Derivs -> Results Unknown)
arrayParsers = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PE a -> Derivs -> Results a
g DerivMapTo (PE Unknown)
arrayNormalizedPElems
    rootParser :: Derivs -> Results a
rootParser = forall a. PE a -> Derivs -> Results a
g PE a
rootPElemAfterNormalization
    f :: Int -> String -> Derivs
f Int
n String
s = Int
n' seq :: forall a b. a -> b -> b
`seq` Derivs
d where
        --At each position in the file, we memoize (lazily) the results of all
        --our finite number of parsers.  Since lookahead is similarly
        --memoized... When(onlyIf) (some asymptotically complex function)
        --risks a more difficult than O(n) parse however.
        d :: Derivs
d = Results Char
-> Int -> DerivMapTo (Results Unknown) -> String -> Derivs
Derivs Results Char
chr Int
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> a -> b
$ Derivs
d) Array Token (Derivs -> Results Unknown)
arrayParsers) String
s
        --chr is the secret recursion over the input characters that
        --grabs all of their positions and generates the lazy shared
        --sequence of arrays.
        chr :: Results Char
chr = case String
s of (Char
x:String
xs) -> forall a. a -> Derivs -> Results a
Parsed Char
x (Int -> String -> Derivs
f Int
n' String
xs) ; [] -> forall a. Results a
NoParse
        n' :: Int
n' = Int
n forall a. Num a => a -> a -> a
+ Int
1
    --the lets are explicitly floated outside the deriv-lambdas so that
    --their results will be shared given the partial application in defs
    --(essentially this avoids repeating the process of turning the PE tree
    --into functions, nothing huge)
    g :: PE a -> Derivs -> Results a
    g :: forall a. PE a -> Derivs -> Results a
g (Named Token
n PE a
_) = \ (Derivs Results Char
_ Int
_ DerivMapTo (Results Unknown)
d String
_) -> forall a b. a -> b
unsafeCoerce (DerivMapTo (Results Unknown)
d forall i e. Ix i => Array i e -> i -> e
! Token
n)
    g PE a
Any = \ (Derivs Results Char
p Int
_ DerivMapTo (Results Unknown)
_ String
_) -> Results Char
p
    g (Char IntSet
cs) = \ (Derivs Results Char
p Int
_ DerivMapTo (Results Unknown)
_ String
_) -> case Results Char
p of
        Parsed Char
c Derivs
d | Char -> Int
ord Char
c Int -> IntSet -> Bool
`IntSet.member` IntSet
cs -> forall a. a -> Derivs -> Results a
Parsed Char
c Derivs
d
        Results Char
_ -> forall a. Results a
NoParse
    g PE a
GetPos = \Derivs
d -> forall a. a -> Derivs -> Results a
Parsed (Derivs -> Int
derivIndex Derivs
d) Derivs
d
    g PE a
Failure = \Derivs
_ -> forall a. Results a
NoParse
    g (Not PE a
p) = let m :: Derivs -> Results a
m = forall a. PE a -> Derivs -> Results a
g PE a
p in \Derivs
d -> case Derivs -> Results a
m Derivs
d of
        Parsed {} -> forall a. Results a
NoParse
        NoParse {} -> forall a. a -> Derivs -> Results a
Parsed () Derivs
d
    g (PMap a -> a
fn PE a
p) = let p' :: Derivs -> Results a
p' = forall a. PE a -> Derivs -> Results a
g PE a
p in \ Derivs
d -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> a
fn (Derivs -> Results a
p' Derivs
d)
    g (Slash PE a
x PE a
y) = let x' :: Derivs -> Results a
x' = forall a. PE a -> Derivs -> Results a
g PE a
x; y' :: Derivs -> Results a
y' = forall a. PE a -> Derivs -> Results a
g PE a
y in \Derivs
d -> case Derivs -> Results a
x' Derivs
d of
        p :: Results a
p@Parsed {} -> Results a
p
        Results a
NoParse -> Derivs -> Results a
y' Derivs
d
    g (Then PE a
x PE b
y) = let x' :: Derivs -> Results a
x' = forall a. PE a -> Derivs -> Results a
g PE a
x; y' :: Derivs -> Results b
y' = forall a. PE a -> Derivs -> Results a
g PE b
y in \Derivs
d -> case Derivs -> Results a
x' Derivs
d of
        Results a
NoParse -> forall a. Results a
NoParse
        Parsed a
a Derivs
d' -> case Derivs -> Results b
y' Derivs
d' of
            Parsed b
b Derivs
d'' -> forall a. a -> Derivs -> Results a
Parsed (a
a,b
b) Derivs
d''
            Results b
NoParse -> forall a. Results a
NoParse
    g (ThenCat PE [a]
x PE [a]
y) = let x' :: Derivs -> Results [a]
x' = forall a. PE a -> Derivs -> Results a
g PE [a]
x; y' :: Derivs -> Results [a]
y' = forall a. PE a -> Derivs -> Results a
g PE [a]
y in \Derivs
d -> case Derivs -> Results [a]
x' Derivs
d of
        Results [a]
NoParse -> forall a. Results a
NoParse
        Parsed [a]
a Derivs
d' -> case Derivs -> Results [a]
y' Derivs
d' of
            Parsed [a]
b Derivs
d'' -> forall a. a -> Derivs -> Results a
Parsed ([a]
a forall a. [a] -> [a] -> [a]
++ [a]
b) Derivs
d''
            Results [a]
NoParse -> forall a. Results a
NoParse
    g PE a
Rest = \Derivs
d -> forall a. a -> Derivs -> Results a
Parsed (Derivs -> String
derivRest Derivs
d) (Int -> Derivs
emptyDAt (Derivs -> Int
derivIndex Derivs
d forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length (Derivs -> String
derivRest Derivs
d)))
    g (Unit a
x) = \Derivs
d -> forall a. a -> Derivs -> Results a
Parsed a
x Derivs
d
    g (Peek PE a
p) = let p' :: Derivs -> Results a
p' = forall a. PE a -> Derivs -> Results a
g PE a
p in \Derivs
d -> case Derivs -> Results a
p' Derivs
d of
        Parsed a
r Derivs
_ -> forall a. a -> Derivs -> Results a
Parsed a
r Derivs
d
        Results a
NoParse -> forall a. Results a
NoParse
    g (When PE a
x a -> Bool
fn) = let x' :: Derivs -> Results a
x' = forall a. PE a -> Derivs -> Results a
g PE a
x in \Derivs
d -> case Derivs -> Results a
x' Derivs
d of
        Results a
NoParse -> forall a. Results a
NoParse
        Parsed a
x Derivs
d -> if a -> Bool
fn a
x then forall a. a -> Derivs -> Results a
Parsed a
x Derivs
d else forall a. Results a
NoParse
    g (Star PE a
p) = let p' :: Derivs -> Results a
p' = forall a. PE a -> Derivs -> Results a
g PE a
p in \Derivs
d -> let
        r :: Derivs -> ([a], Derivs)
r Derivs
d = case Derivs -> Results a
p' Derivs
d of
            Parsed a
x Derivs
d' -> let ([a]
a,Derivs
b) = Derivs -> ([a], Derivs)
r Derivs
d' in (a
xforall a. a -> [a] -> [a]
:[a]
a,Derivs
b)
            Results a
NoParse -> ([],Derivs
d)
        ([a]
fv,Derivs
fd) = Derivs -> ([a], Derivs)
r Derivs
d
        in forall a. a -> Derivs -> Results a
Parsed [a]
fv Derivs
fd




-- | Create a new rule, which may be used recursively and caches its results.
--
-- This is intended to be use in an 'mdo' block. such as the following.
--
-- > additive = mdo
-- >     additive <- newRule $ multitive <> char '+' ->> additive ## uncurry (+) // multitive
-- >     multitive <- newRule $ primary <> char '*' ->> multitive ## uncurry (*) // primary
-- >     primary <- newRule $ char '(' ->> additive <<- char ')' // decimal
-- >     decimal <- newRule $ many1 (oneOf ['0' .. '9']) ## read
-- >     return additive
--
-- All recursive calls must be bound via a rule. Left recursion should be avoided.
--

newRule :: P s a -> PM s (P s a)
newRule :: forall s a. P s a -> PM s (P s a)
newRule pe :: P s a
pe@(P Any {}) = forall (m :: * -> *) a. Monad m => a -> m a
return P s a
pe
newRule pe :: P s a
pe@(P Char {}) = forall (m :: * -> *) a. Monad m => a -> m a
return P s a
pe
newRule pe :: P s a
pe@(P PE a
x) = PE a -> PM s (P s a)
f PE a
x where
    f :: PE a -> PM s (P s a)
f Named {} = forall (m :: * -> *) a. Monad m => a -> m a
return P s a
pe
    f Unit {} = forall (m :: * -> *) a. Monad m => a -> m a
return P s a
pe
    --f Any {} = return pe
    --f Char {} = return pe
    f Failure {} = forall (m :: * -> *) a. Monad m => a -> m a
return P s a
pe
    f PE a
pe = forall s a. PMImp a -> PM s a
PM forall a b. (a -> b) -> a -> b
$ do
        Token
x <- forall s (m :: * -> *). MonadState s m => m s
get
        forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$! (Token
x forall a. Num a => a -> a -> a
+ Token
1)
        forall (m :: * -> *) a. Monad m => a -> m a
return (forall s a. PE a -> P s a
P forall a b. (a -> b) -> a -> b
$ forall a. Token -> PE a -> PE a
Named Token
x PE a
pe)


data Regex =
    RegexChars Bool IntSet.IntSet
    | RegexAny
    | RegexMany {
        Regex -> Regex
regexWhat :: Regex,
        Regex -> Int
regexMin  :: Int,
        Regex -> Maybe Int
regexMax  :: Maybe Int,
        Regex -> Bool
regexMunch:: Bool
        }
    | RegexCat [Regex]
    deriving(Int -> Regex -> ShowS
[Regex] -> ShowS
Regex -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Regex] -> ShowS
$cshowList :: [Regex] -> ShowS
show :: Regex -> String
$cshow :: Regex -> String
showsPrec :: Int -> Regex -> ShowS
$cshowsPrec :: Int -> Regex -> ShowS
Show,Regex -> Regex -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Regex -> Regex -> Bool
$c/= :: Regex -> Regex -> Bool
== :: Regex -> Regex -> Bool
$c== :: Regex -> Regex -> Bool
Eq,Eq Regex
Regex -> Regex -> Bool
Regex -> Regex -> Ordering
Regex -> Regex -> Regex
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Regex -> Regex -> Regex
$cmin :: Regex -> Regex -> Regex
max :: Regex -> Regex -> Regex
$cmax :: Regex -> Regex -> Regex
>= :: Regex -> Regex -> Bool
$c>= :: Regex -> Regex -> Bool
> :: Regex -> Regex -> Bool
$c> :: Regex -> Regex -> Bool
<= :: Regex -> Regex -> Bool
$c<= :: Regex -> Regex -> Bool
< :: Regex -> Regex -> Bool
$c< :: Regex -> Regex -> Bool
compare :: Regex -> Regex -> Ordering
$ccompare :: Regex -> Regex -> Ordering
Ord)

normalizeRegex :: Regex -> Regex
normalizeRegex :: Regex -> Regex
normalizeRegex Regex
r = Regex -> Regex
f Regex
r where
    f :: Regex -> Regex
f Regex
RegexAny = Regex
RegexAny
    f (RegexCat [Regex]
xs) = [Regex] -> Regex
regexCat forall a b. (a -> b) -> a -> b
$ [Regex] -> [Regex]
g (forall a b. (a -> b) -> [a] -> [b]
map Regex -> Regex
f [Regex]
xs)
    f rm :: Regex
rm@RegexMany { regexWhat :: Regex -> Regex
regexWhat = Regex
r }
        | RegexCat [] <- Regex
r' = [Regex] -> Regex
RegexCat []
        | Bool
otherwise = [Regex] -> Regex
regexCat (forall a. Int -> a -> [a]
replicate (Regex -> Int
regexMin Regex
rm) Regex
r' forall a. [a] -> [a] -> [a]
++ [Regex
rm { regexWhat :: Regex
regexWhat = Regex
r', regexMin :: Int
regexMin = Int
0, regexMax :: Maybe Int
regexMax = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
subtract forall a b. (a -> b) -> a -> b
$ Regex -> Int
regexMin Regex
rm) (Regex -> Maybe Int
regexMax Regex
rm) }])
       where r' :: Regex
r' = Regex -> Regex
f Regex
r
    f r :: Regex
r@RegexChars {} = Regex
r
    g :: [Regex] -> [Regex]
g (RegexCat [Regex]
x:[Regex]
xs) = [Regex]
x forall a. [a] -> [a] -> [a]
++ [Regex] -> [Regex]
g [Regex]
xs
    g (Regex
x:[Regex]
xs) = Regex
xforall a. a -> [a] -> [a]
:[Regex] -> [Regex]
g [Regex]
xs
    g [] = []

    regexCat :: [Regex] -> Regex
regexCat [Regex
x] = Regex
x
    regexCat [Regex]
xs = [Regex] -> Regex
RegexCat [Regex]
xs

regexToParser :: Regex -> P s String
regexToParser :: forall s. Regex -> P s String
regexToParser Regex
r = forall s. Regex -> P s String
f Regex
r where
    f :: Regex -> P s String
f Regex
RegexAny = forall s. P s Char
anyChar forall s a b. P s a -> (a -> b) -> P s b
## (forall a. a -> [a] -> [a]
:[])
    f (RegexChars Bool
True IntSet
m)  = forall s. String -> P s Char
oneOf  (forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
m) forall s a b. P s a -> (a -> b) -> P s b
## (forall a. a -> [a] -> [a]
:[])
    f (RegexChars Bool
False IntSet
m) = forall s. String -> P s Char
noneOf (forall a b. (a -> b) -> [a] -> [b]
map Int -> Char
chr forall a b. (a -> b) -> a -> b
$ IntSet -> [Int]
IntSet.toList IntSet
m) forall s a b. P s a -> (a -> b) -> P s b
## (forall a. a -> [a] -> [a]
:[])
    f (RegexCat []) = forall a s. a -> P s a
unit String
""
    f (RegexCat (Regex
x:[Regex]
xs)) = Regex -> P s String
f Regex
x forall s a. P s [a] -> P s [a] -> P s [a]
<++> Regex -> P s String
f ([Regex] -> Regex
RegexCat [Regex]
xs)
    f RegexMany { regexWhat :: Regex -> Regex
regexWhat = Regex
r, regexMin :: Regex -> Int
regexMin = Int
0, regexMax :: Regex -> Maybe Int
regexMax = Maybe Int
Nothing } = forall s a. P s a -> P s [a]
many (Regex -> P s String
f Regex
r) forall s a b. P s a -> (a -> b) -> P s b
## forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    f rm :: Regex
rm@RegexMany { regexWhat :: Regex -> Regex
regexWhat = Regex
r, regexMin :: Regex -> Int
regexMin = Int
n, regexMax :: Regex -> Maybe Int
regexMax = Maybe Int
Nothing } = Regex -> P s String
f Regex
r forall s a. P s [a] -> P s [a] -> P s [a]
<++> Regex -> P s String
f Regex
rm { regexMin :: Int
regexMin = Int
n forall a. Num a => a -> a -> a
- Int
1 }
    f RegexMany { regexWhat :: Regex -> Regex
regexWhat = Regex
r, regexMin :: Regex -> Int
regexMin = Int
0, regexMax :: Regex -> Maybe Int
regexMax = Just Int
1 } = Regex -> P s String
f Regex
r forall s a. P s a -> P s a -> P s a
// forall a s. a -> P s a
unit String
""



parseRegex :: forall s . PM s (P s (Maybe Regex))
parseRegex :: forall s. PM s (P s (Maybe Regex))
parseRegex =
    do rec P s Regex
regex <- forall s a. P s a -> PM s (P s a)
newRule forall a b. (a -> b) -> a -> b
$ P s Regex
primary forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
'*' forall s a b. P s a -> P s b -> P s (a, b)
<> forall s a. P s a -> P s Bool
isMatch (forall s. Char -> P s Char
char Char
'?')   forall s a b. P s a -> (a -> b) -> P s b
## (\ (Regex
r,Bool
m) -> RegexMany { regexWhat :: Regex
regexWhat = Regex
r, regexMin :: Int
regexMin = Int
0, regexMax :: Maybe Int
regexMax = forall a. Maybe a
Nothing, regexMunch :: Bool
regexMunch = Bool
m })
             forall s a. P s a -> P s a -> P s a
// P s Regex
primary forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
'+' forall s a b. P s a -> P s b -> P s (a, b)
<> forall s a. P s a -> P s Bool
isMatch (forall s. Char -> P s Char
char Char
'?')         forall s a b. P s a -> (a -> b) -> P s b
## (\ (Regex
r,Bool
m) -> RegexMany { regexWhat :: Regex
regexWhat = Regex
r, regexMin :: Int
regexMin = Int
1, regexMax :: Maybe Int
regexMax = forall a. Maybe a
Nothing, regexMunch :: Bool
regexMunch = Bool
m })
             forall s a. P s a -> P s a -> P s a
// P s Regex
primary forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
'?' forall s a b. P s a -> P s b -> P s (a, b)
<> forall s a. P s a -> P s Bool
isMatch (forall s. Char -> P s Char
char Char
'?')         forall s a b. P s a -> (a -> b) -> P s b
## (\ (Regex
r,Bool
m) -> RegexMany { regexWhat :: Regex
regexWhat = Regex
r, regexMin :: Int
regexMin = Int
0, regexMax :: Maybe Int
regexMax = forall a. a -> Maybe a
Just Int
1, regexMunch :: Bool
regexMunch = Bool
m })
             forall s a. P s a -> P s a -> P s a
// P s Regex
primary
           P s Regex
primary <- forall s a. P s a -> PM s (P s a)
newRule forall a b. (a -> b) -> a -> b
$ forall s. Char -> P s Char
char Char
'(' forall s a b. P s a -> P s b -> P s b
->> P s Regex
fregex forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
')'
                   forall s a. P s a -> P s a -> P s a
// forall s. Char -> P s Char
char Char
'.' forall s a b. P s a -> b -> P s b
##> Regex
RegexAny
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"[^" forall s a b. P s a -> P s b -> P s b
->> P s String
char_class forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
']' forall s a b. P s a -> (a -> b) -> P s b
## Bool -> IntSet -> Regex
RegexChars Bool
False forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IntSet
IntSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord
                   forall s a. P s a -> P s a -> P s a
// forall s. Char -> P s Char
char Char
'['  forall s a b. P s a -> P s b -> P s b
->> P s String
char_class forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
']' forall s a b. P s a -> (a -> b) -> P s b
## Bool -> IntSet -> Regex
RegexChars Bool
True  forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Int] -> IntSet
IntSet.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
ord
                   forall s a. P s a -> P s a -> P s a
// P s Char
rchar forall s a b. P s a -> (a -> b) -> P s b
## Bool -> IntSet -> Regex
RegexChars Bool
True forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> IntSet
IntSet.singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord
           P s Char
rchar <-   forall s a. P s a -> PM s (P s a)
newRule forall a b. (a -> b) -> a -> b
$ forall s. String -> P s String
text String
"\\n" forall s a b. P s a -> b -> P s b
##> Char
'\n'
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"\\t" forall s a b. P s a -> b -> P s b
##> Char
'\t'
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"\\f" forall s a b. P s a -> b -> P s b
##> Char
'\f'
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"\\a" forall s a b. P s a -> b -> P s b
##> Char
'\a'
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"\\e" forall s a b. P s a -> b -> P s b
##> Char
'\033'
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"\\r" forall s a b. P s a -> b -> P s b
##> Char
'\r'
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s String
text String
"\\0" forall s a b. P s a -> b -> P s b
##> Char
'\0'
                   forall s a. P s a -> P s a -> P s a
// forall s. Char -> P s Char
char Char
'\\' forall s a b. P s a -> P s b -> P s b
->> forall s. P s Char
anyChar
                   forall s a. P s a -> P s a -> P s a
// forall s. String -> P s Char
noneOf String
".[*+()\\"
           P s String
char_class1 <- forall s a. P s a -> PM s (P s a)
newRule forall a b. (a -> b) -> a -> b
$
                   forall s. P s Char
anyChar forall s a b. P s a -> P s b -> P s a
<<- forall s. Char -> P s Char
char Char
'-' forall s a b. P s a -> P s b -> P s (a, b)
<> forall s. P s Char
anyChar forall s a b. P s a -> (a -> b) -> P s b
## forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Enum a => a -> a -> [a]
enumFromTo
                   forall s a. P s a -> P s a -> P s a
// forall s. P s Char
anyChar forall s a b. P s a -> (a -> b) -> P s b
## (forall a. a -> [a] -> [a]
:[])
           P s String
char_class <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat) forall a b. (a -> b) -> a -> b
$ forall s b a. P s b -> P s a -> PM s (P s [a])
manyUntil (forall s. Char -> P s Char
char Char
']') P s String
char_class1
           P s Regex
fregex <- forall s a. P s a -> PM s (P s a)
newRule forall a b. (a -> b) -> a -> b
$  forall s a. P s a -> P s [a]
many P s Regex
regex forall s a b. P s a -> (a -> b) -> P s b
## [Regex] -> Regex
RegexCat
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Regex -> Regex
normalizeRegex) (P s Regex
fregex forall s a b. P s a -> P s b -> P s a
<<- forall s. P s ()
eof) forall s a. P s a -> P s a -> P s a
// forall a s. a -> P s a
unit forall a. Maybe a
Nothing


-- | always succeeds, returning true if it consumed something.
isMatch :: P s a -> P s Bool
isMatch :: forall s a. P s a -> P s Bool
isMatch P s a
p = P s a
p forall s a b. P s a -> P s b -> P s b
->> forall a s. a -> P s a
unit Bool
True forall s a. P s a -> P s a -> P s a
// forall a s. a -> P s a
unit Bool
False

parse_regex :: String -> Maybe Regex
parse_regex :: String -> Maybe Regex
parse_regex = forall a. (forall s. PM s (P s a)) -> String -> a
runPeg forall s. PM s (P s (Maybe Regex))
parseRegex




-- | Create a new regular expression matching parser. it returns something in a
-- possibly failing monad to indicate an error in the regular expression itself.

newRegex :: Fail.MonadFail m => String -> m (PM s (P s String))
newRegex :: forall (m :: * -> *) s.
MonadFail m =>
String -> m (PM s (P s String))
newRegex String
s = case String -> Maybe Regex
parse_regex String
s of
    Just Regex
r -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. Regex -> P s String
regexToParser Regex
r)
    Maybe Regex
Nothing -> m (PM s (P s String))
err
   where err :: m (PM s (P s String))
err = forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail forall a b. (a -> b) -> a -> b
$ String
"invalid regular expression: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s


-- | Show a representation of the parsed regex, mainly for debugging.
showRegex :: String -> IO ()
showRegex :: String -> IO ()
showRegex String
s = do
    String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"Parsing: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s
    forall a. Show a => a -> IO ()
print (String -> Maybe Regex
parse_regex String
s)

-- | Make a new regex but abort on an error in the regex string itself.
regex :: String -> PM s (P s String)
regex :: forall s. String -> PM s (P s String)
regex String
s =
  case String -> Maybe Regex
parse_regex String
s of
    Just Regex
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall s. Regex -> P s String
regexToParser Regex
r
    Maybe Regex
Nothing -> PM s (P s String)
err
   where err :: PM s (P s String)
err = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"invalid regular expression: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show String
s