------------------------------------------------------------------------
-- | Parser combinators with support for left recursion, following
-- Johnson\'s \"Memoization in Top-Down Parsing\".
--
-- This implementation is based on an implementation due to Atkey
-- (attached to an edlambda-members mailing list message from
-- 2011-02-15 titled \'Slides for \"Introduction to Parser
-- Combinators\"\').
--
-- Note that non-memoised left recursion is not guaranteed to work.
--
-- The code contains an important deviation from Johnson\'s paper: the
-- check for subsumed results is not included. This means that one can
-- get the same result multiple times when parsing using ambiguous
-- grammars. As an example, parsing the empty string using @S ∷= ε |
-- ε@ succeeds twice. This change also means that parsing fails to
-- terminate for some cyclic grammars that would otherwise be handled
-- successfully, such as @S ∷= S | ε@. However, the library is not
-- intended to handle infinitely ambiguous grammars. (It is unclear to
-- the author of this module whether the change leads to more
-- non-termination for grammars that are not cyclic.)


module Agda.Utils.Parser.MemoisedCPS
  ( ParserClass(..)
  , sat, token, tok, doc
  , DocP, bindP, choiceP, seqP, starP, atomP
  , Parser
  , ParserWithGrammar
  ) where

import Control.Applicative ( Alternative((<|>), empty, many, some) )
import Control.Monad (liftM2, (<=<))
import Control.Monad.State.Strict (State, evalState, runState, get, modify')

import Data.Array
import Data.Hashable
import qualified Data.HashMap.Strict as Map
import Data.HashMap.Strict (HashMap)


import qualified Data.IntMap.Strict as IntMap
import Data.IntMap.Strict (IntMap)
import qualified Data.List as List
import Data.Maybe

import Text.PrettyPrint.HughesPJ hiding (empty)
import qualified Text.PrettyPrint.HughesPJ as PP

import Agda.Utils.Pretty ( mparens )

import Agda.Utils.Impossible

-- | Positions.

type Pos = Int

-- | State monad used by the parser.

type M k r tok b = State (IntMap (HashMap k (Value k r tok b)))

-- | Continuations.

type Cont k r tok b a = Pos -> a -> M k r tok b [b]

-- | Memoised values.

data Value k r tok b = Value
  { forall k r tok b. Value k r tok b -> IntMap [r]
_results       :: !(IntMap [r])
  , forall k r tok b. Value k r tok b -> [Cont k r tok b r]
_continuations :: [Cont k r tok b r]
  }

-- | The parser type.
--
-- The parameters of the type @Parser k r tok a@ have the following
-- meanings:
--
-- [@k@] Type used for memoisation keys.
--
-- [@r@] The type of memoised values. (Yes, all memoised values have
-- to have the same type.)
--
-- [@tok@] The token type.
--
-- [@a@] The result type.

newtype Parser k r tok a =
  P { forall k r tok a.
Parser k r tok a
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP :: forall b.
             Array Pos tok ->
             Pos ->
             Cont k r tok b a ->
             M k r tok b [b]
    }

instance Monad (Parser k r tok) where
  return :: forall a. a -> Parser k r tok a
return    = a -> Parser k r tok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  P forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p >>= :: forall a b.
Parser k r tok a -> (a -> Parser k r tok b) -> Parser k r tok b
>>= a -> Parser k r tok b
f = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
-> Parser k r tok b
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
 -> Parser k r tok b)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
-> Parser k r tok b
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
input Pos
i Cont k r tok b b
k ->
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p Array Pos tok
input Pos
i (Cont k r tok b a -> M k r tok b [b])
-> Cont k r tok b a -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$ \Pos
j a
x -> Parser k r tok b
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b]
forall k r tok a.
Parser k r tok a
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP (a -> Parser k r tok b
f a
x) Array Pos tok
input Pos
j Cont k r tok b b
k

instance Functor (Parser k r tok) where
  fmap :: forall a b. (a -> b) -> Parser k r tok a -> Parser k r tok b
fmap a -> b
f (P forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p) = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
-> Parser k r tok b
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
 -> Parser k r tok b)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
-> Parser k r tok b
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
input Pos
i Cont k r tok b b
k ->
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p Array Pos tok
input Pos
i (Cont k r tok b a -> M k r tok b [b])
-> Cont k r tok b a -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$ \Pos
i -> Cont k r tok b b
k Pos
i (b -> M k r tok b [b]) -> (a -> b) -> a -> M k r tok b [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f

instance Applicative (Parser k r tok) where
  pure :: forall a. a -> Parser k r tok a
pure a
x        = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
 -> Parser k r tok a)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
_ Pos
i Cont k r tok b a
k -> Cont k r tok b a
k Pos
i a
x
  P forall b.
Array Pos tok -> Pos -> Cont k r tok b (a -> b) -> M k r tok b [b]
p1 <*> :: forall a b.
Parser k r tok (a -> b) -> Parser k r tok a -> Parser k r tok b
<*> P forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
-> Parser k r tok b
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
 -> Parser k r tok b)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b b -> M k r tok b [b])
-> Parser k r tok b
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
input Pos
i Cont k r tok b b
k ->
    Array Pos tok -> Pos -> Cont k r tok b (a -> b) -> M k r tok b [b]
forall b.
Array Pos tok -> Pos -> Cont k r tok b (a -> b) -> M k r tok b [b]
p1 Array Pos tok
input Pos
i (Cont k r tok b (a -> b) -> M k r tok b [b])
-> Cont k r tok b (a -> b) -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$ \Pos
i a -> b
f ->
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 Array Pos tok
input Pos
i (Cont k r tok b a -> M k r tok b [b])
-> Cont k r tok b a -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$ \Pos
i a
x ->
    Cont k r tok b b
k Pos
i (a -> b
f a
x)

instance Alternative (Parser k r tok) where
  empty :: forall a. Parser k r tok a
empty         = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
 -> Parser k r tok a)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
_ Pos
_ Cont k r tok b a
_ -> [b] -> M k r tok b [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
  P forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p1 <|> :: forall a. Parser k r tok a -> Parser k r tok a -> Parser k r tok a
<|> P forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
 -> Parser k r tok a)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
input Pos
i Cont k r tok b a
k ->
    ([b] -> [b] -> [b])
-> M k r tok b [b] -> M k r tok b [b] -> M k r tok b [b]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++) (Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p1 Array Pos tok
input Pos
i Cont k r tok b a
k) (Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b.
Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 Array Pos tok
input Pos
i Cont k r tok b a
k)

class (Functor p, Applicative p, Alternative p, Monad p) =>
      ParserClass p k r tok | p -> k, p -> r, p -> tok where
  -- | Runs the parser.
  parse :: p a -> [tok] -> [a]

  -- | Tries to print the parser, or returns 'PP.empty', depending on
  -- the implementation. This function might not terminate.
  grammar :: Show k => p a -> Doc

  -- | Parses a token satisfying the given predicate. The computed
  -- value is returned.
  sat' :: (tok -> Maybe a) -> p a

  -- | Uses the given function to modify the printed representation
  -- (if any) of the given parser.
  annotate :: (DocP -> DocP) -> p a -> p a

  -- | Memoises the given parser.
  --
  -- Every memoised parser must be annotated with a /unique/ key.
  -- (Parametrised parsers must use distinct keys for distinct
  -- inputs.)
  memoise :: (Eq k, Hashable k, Show k) => k -> p r -> p r

  -- | Memoises the given parser, but only if printing, not if
  -- parsing.
  --
  -- Every memoised parser must be annotated with a /unique/ key.
  -- (Parametrised parsers must use distinct keys for distinct
  -- inputs.)
  memoiseIfPrinting :: (Eq k, Hashable k, Show k) => k -> p r -> p r

-- | Uses the given document as the printed representation of the
-- given parser. The document's precedence is taken to be 'atomP'.

doc :: ParserClass p k r tok => Doc -> p a -> p a
doc :: forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
Doc -> p a -> p a
doc Doc
d = (DocP -> DocP) -> p a -> p a
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
(DocP -> DocP) -> p a -> p a
annotate (\DocP
_ -> (Doc
d, Pos
atomP))

-- | Parses a token satisfying the given predicate.

sat :: ParserClass p k r tok => (tok -> Bool) -> p tok
sat :: forall (p :: * -> *) k r tok.
ParserClass p k r tok =>
(tok -> Bool) -> p tok
sat tok -> Bool
p = (tok -> Maybe tok) -> p tok
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
(tok -> Maybe a) -> p a
sat' (\tok
t -> if tok -> Bool
p tok
t then tok -> Maybe tok
forall a. a -> Maybe a
Just tok
t else Maybe tok
forall a. Maybe a
Nothing)

-- | Parses a single token.

token :: ParserClass p k r tok => p tok
token :: forall (p :: * -> *) k r tok. ParserClass p k r tok => p tok
token = Doc -> p tok -> p tok
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
Doc -> p a -> p a
doc Doc
"·" ((tok -> Maybe tok) -> p tok
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
(tok -> Maybe a) -> p a
sat' tok -> Maybe tok
forall a. a -> Maybe a
Just)

-- | Parses a given token.

tok :: (ParserClass p k r tok, Eq tok, Show tok) => tok -> p tok
tok :: forall (p :: * -> *) k r tok.
(ParserClass p k r tok, Eq tok, Show tok) =>
tok -> p tok
tok tok
t = Doc -> p tok -> p tok
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
Doc -> p a -> p a
doc (String -> Doc
text (tok -> String
forall a. Show a => a -> String
show tok
t)) ((tok -> Bool) -> p tok
forall (p :: * -> *) k r tok.
ParserClass p k r tok =>
(tok -> Bool) -> p tok
sat (tok
t tok -> tok -> Bool
forall a. Eq a => a -> a -> Bool
==))

instance ParserClass (Parser k r tok) k r tok where
  parse :: forall a. Parser k r tok a -> [tok] -> [a]
parse Parser k r tok a
p [tok]
toks =
    (State (IntMap (HashMap k (Value k r tok a))) [a]
 -> IntMap (HashMap k (Value k r tok a)) -> [a])
-> IntMap (HashMap k (Value k r tok a))
-> State (IntMap (HashMap k (Value k r tok a))) [a]
-> [a]
forall a b c. (a -> b -> c) -> b -> a -> c
flip State (IntMap (HashMap k (Value k r tok a))) [a]
-> IntMap (HashMap k (Value k r tok a)) -> [a]
forall s a. State s a -> s -> a
evalState IntMap (HashMap k (Value k r tok a))
forall a. IntMap a
IntMap.empty (State (IntMap (HashMap k (Value k r tok a))) [a] -> [a])
-> State (IntMap (HashMap k (Value k r tok a))) [a] -> [a]
forall a b. (a -> b) -> a -> b
$
    Parser k r tok a
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall k r tok a.
Parser k r tok a
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP Parser k r tok a
p ((Pos, Pos) -> [tok] -> Array Pos tok
forall i e. Ix i => (i, i) -> [e] -> Array i e
listArray (Pos
0, Pos
n Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
- Pos
1) [tok]
toks) Pos
0 (Cont k r tok a a
 -> State (IntMap (HashMap k (Value k r tok a))) [a])
-> Cont k r tok a a
-> State (IntMap (HashMap k (Value k r tok a))) [a]
forall a b. (a -> b) -> a -> b
$ \Pos
j a
x ->
      if Pos
j Pos -> Pos -> Bool
forall a. Eq a => a -> a -> Bool
== Pos
n then [a] -> State (IntMap (HashMap k (Value k r tok a))) [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a
x] else [a] -> State (IntMap (HashMap k (Value k r tok a))) [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    where n :: Pos
n = [tok] -> Pos
forall i a. Num i => [a] -> i
List.genericLength [tok]
toks

  grammar :: forall a. Show k => Parser k r tok a -> Doc
grammar Parser k r tok a
_ = Doc
PP.empty

  sat' :: forall a. (tok -> Maybe a) -> Parser k r tok a
sat' tok -> Maybe a
p = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
 -> Parser k r tok a)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
input Pos
i Cont k r tok b a
k ->
    if (Pos, Pos) -> Pos -> Bool
forall a. Ix a => (a, a) -> a -> Bool
inRange (Array Pos tok -> (Pos, Pos)
forall i e. Array i e -> (i, i)
bounds Array Pos tok
input) Pos
i then
      case tok -> Maybe a
p (Array Pos tok
input Array Pos tok -> Pos -> tok
forall i e. Ix i => Array i e -> i -> e
! Pos
i) of
        Maybe a
Nothing -> [b] -> M k r tok b [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        Just a
x  -> (Cont k r tok b a
k Cont k r tok b a -> Cont k r tok b a
forall a b. (a -> b) -> a -> b
$! (Pos
i Pos -> Pos -> Pos
forall a. Num a => a -> a -> a
+ Pos
1)) (a -> M k r tok b [b]) -> a -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$! a
x
    else
      [b] -> M k r tok b [b]
forall (m :: * -> *) a. Monad m => a -> m a
return []

  annotate :: forall a. (DocP -> DocP) -> Parser k r tok a -> Parser k r tok a
annotate DocP -> DocP
_ Parser k r tok a
p = Parser k r tok a
p

  memoiseIfPrinting :: (Eq k, Hashable k, Show k) =>
k -> Parser k r tok r -> Parser k r tok r
memoiseIfPrinting k
_ Parser k r tok r
p = Parser k r tok r
p

  memoise :: (Eq k, Hashable k, Show k) =>
k -> Parser k r tok r -> Parser k r tok r
memoise k
key Parser k r tok r
p = (forall b.
 Array Pos tok -> Pos -> Cont k r tok b r -> M k r tok b [b])
-> Parser k r tok r
forall k r tok a.
(forall b.
 Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P ((forall b.
  Array Pos tok -> Pos -> Cont k r tok b r -> M k r tok b [b])
 -> Parser k r tok r)
-> (forall b.
    Array Pos tok -> Pos -> Cont k r tok b r -> M k r tok b [b])
-> Parser k r tok r
forall a b. (a -> b) -> a -> b
$ \Array Pos tok
input Pos
i Cont k r tok b r
k -> do

    let alter :: Pos -> b -> (b -> b) -> IntMap b -> IntMap b
alter Pos
j b
zero b -> b
f IntMap b
m =
          (Maybe b -> Maybe b) -> Pos -> IntMap b -> IntMap b
forall a. (Maybe a -> Maybe a) -> Pos -> IntMap a -> IntMap a
IntMap.alter (b -> Maybe b
forall a. a -> Maybe a
Just (b -> Maybe b) -> (Maybe b -> b) -> Maybe b -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
f (b -> b) -> (Maybe b -> b) -> Maybe b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Maybe b -> b
forall a. a -> Maybe a -> a
fromMaybe b
zero) Pos
j IntMap b
m

        lookupTable :: StateT
  (IntMap (HashMap k (Value k r tok b)))
  Identity
  (Maybe (Value k r tok b))
lookupTable   = (IntMap (HashMap k (Value k r tok b)) -> Maybe (Value k r tok b))
-> StateT
     (IntMap (HashMap k (Value k r tok b)))
     Identity
     (IntMap (HashMap k (Value k r tok b)))
-> StateT
     (IntMap (HashMap k (Value k r tok b)))
     Identity
     (Maybe (Value k r tok b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (k -> HashMap k (Value k r tok b) -> Maybe (Value k r tok b)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
key (HashMap k (Value k r tok b) -> Maybe (Value k r tok b))
-> (IntMap (HashMap k (Value k r tok b))
    -> Maybe (HashMap k (Value k r tok b)))
-> IntMap (HashMap k (Value k r tok b))
-> Maybe (Value k r tok b)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Pos
-> IntMap (HashMap k (Value k r tok b))
-> Maybe (HashMap k (Value k r tok b))
forall a. Pos -> IntMap a -> Maybe a
IntMap.lookup Pos
i) StateT
  (IntMap (HashMap k (Value k r tok b)))
  Identity
  (IntMap (HashMap k (Value k r tok b)))
forall s (m :: * -> *). MonadState s m => m s
get
        insertTable :: Value k r tok b
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity ()
insertTable Value k r tok b
v = (IntMap (HashMap k (Value k r tok b))
 -> IntMap (HashMap k (Value k r tok b)))
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((IntMap (HashMap k (Value k r tok b))
  -> IntMap (HashMap k (Value k r tok b)))
 -> StateT (IntMap (HashMap k (Value k r tok b))) Identity ())
-> (IntMap (HashMap k (Value k r tok b))
    -> IntMap (HashMap k (Value k r tok b)))
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity ()
forall a b. (a -> b) -> a -> b
$ Pos
-> HashMap k (Value k r tok b)
-> (HashMap k (Value k r tok b) -> HashMap k (Value k r tok b))
-> IntMap (HashMap k (Value k r tok b))
-> IntMap (HashMap k (Value k r tok b))
forall {b}. Pos -> b -> (b -> b) -> IntMap b -> IntMap b
alter Pos
i HashMap k (Value k r tok b)
forall k v. HashMap k v
Map.empty (k
-> Value k r tok b
-> HashMap k (Value k r tok b)
-> HashMap k (Value k r tok b)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
key Value k r tok b
v)

    Maybe (Value k r tok b)
v <- StateT
  (IntMap (HashMap k (Value k r tok b)))
  Identity
  (Maybe (Value k r tok b))
lookupTable
    case Maybe (Value k r tok b)
v of
      Maybe (Value k r tok b)
Nothing -> do
        Value k r tok b
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity ()
insertTable (IntMap [r] -> [Cont k r tok b r] -> Value k r tok b
forall k r tok b.
IntMap [r] -> [Cont k r tok b r] -> Value k r tok b
Value IntMap [r]
forall a. IntMap a
IntMap.empty [Cont k r tok b r
k])
        Parser k r tok r
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b r -> M k r tok b [b]
forall k r tok a.
Parser k r tok a
-> forall b.
   Array Pos tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP Parser k r tok r
p Array Pos tok
input Pos
i (Cont k r tok b r -> M k r tok b [b])
-> Cont k r tok b r -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$ \Pos
j r
r -> do
          ~(Just (Value IntMap [r]
rs [Cont k r tok b r]
ks)) <- StateT
  (IntMap (HashMap k (Value k r tok b)))
  Identity
  (Maybe (Value k r tok b))
lookupTable
          Value k r tok b
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity ()
insertTable (IntMap [r] -> [Cont k r tok b r] -> Value k r tok b
forall k r tok b.
IntMap [r] -> [Cont k r tok b r] -> Value k r tok b
Value (Pos -> [r] -> ([r] -> [r]) -> IntMap [r] -> IntMap [r]
forall {b}. Pos -> b -> (b -> b) -> IntMap b -> IntMap b
alter Pos
j [] (r
r r -> [r] -> [r]
forall a. a -> [a] -> [a]
:) IntMap [r]
rs) [Cont k r tok b r]
ks)
          [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[b]] -> [b])
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity [[b]]
-> M k r tok b [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cont k r tok b r -> M k r tok b [b])
-> [Cont k r tok b r]
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Cont k r tok b r
k -> Cont k r tok b r
k Pos
j r
r) [Cont k r tok b r]
ks  -- See note [Reverse ks?].
      Just (Value IntMap [r]
rs [Cont k r tok b r]
ks) -> do
        Value k r tok b
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity ()
insertTable (IntMap [r] -> [Cont k r tok b r] -> Value k r tok b
forall k r tok b.
IntMap [r] -> [Cont k r tok b r] -> Value k r tok b
Value IntMap [r]
rs (Cont k r tok b r
k Cont k r tok b r -> [Cont k r tok b r] -> [Cont k r tok b r]
forall a. a -> [a] -> [a]
: [Cont k r tok b r]
ks))
        [[b]] -> [b]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[b]] -> [b]) -> ([[[b]]] -> [[b]]) -> [[[b]]] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[[b]]] -> [[b]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[b]]] -> [b])
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity [[[b]]]
-> M k r tok b [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          ((Pos, [r])
 -> StateT (IntMap (HashMap k (Value k r tok b))) Identity [[b]])
-> [(Pos, [r])]
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity [[[b]]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Pos
i, [r]
rs) -> (r -> M k r tok b [b])
-> [r]
-> StateT (IntMap (HashMap k (Value k r tok b))) Identity [[b]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Cont k r tok b r
k Pos
i) [r]
rs) (IntMap [r] -> [(Pos, [r])]
forall a. IntMap a -> [(Pos, a)]
IntMap.toList IntMap [r]
rs)

-- [Reverse ks?]
--
-- If ks were reversed, then the code would be productive for some
-- infinitely ambiguous grammars, including S ∷= S | ε. However, in
-- some cases the results would not be fair (some valid results would
-- never be returned).

-- | An extended parser type, with some support for printing parsers.

data ParserWithGrammar k r tok a =
  PG (Bool -> Either (Parser k r tok a) (Docs k))
  -- ^ Invariant: If the boolean is 'True', then the result must be
  -- @'Left' something@, and if the boolean is 'False', then the
  -- result must be @'Right' something@.

-- | Documents paired with precedence levels.

type DocP = (Doc, Int)

-- | Precedence of @>>=@.

bindP :: Int
bindP :: Pos
bindP = Pos
10

-- | Precedence of @<|>@.

choiceP :: Int
choiceP :: Pos
choiceP = Pos
20

-- | Precedence of @<*>@.

seqP :: Int
seqP :: Pos
seqP = Pos
30

-- | Precedence of @⋆@ and @+@.

starP :: Int
starP :: Pos
starP = Pos
40

-- | Precedence of atoms.

atomP :: Int
atomP :: Pos
atomP = Pos
50

-- | The extended parser type computes one top-level document, plus
-- one document per encountered memoisation key.
--
-- 'Nothing' is used to mark that a given memoisation key has been
-- seen, but that no corresponding document has yet been stored.

type Docs k = State (HashMap k (Maybe DocP)) DocP

-- | A smart constructor.

pg :: Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg :: forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg Parser k r tok a
p Docs k
d = (Bool -> Either (Parser k r tok a) (Docs k))
-> ParserWithGrammar k r tok a
forall k r tok a.
(Bool -> Either (Parser k r tok a) (Docs k))
-> ParserWithGrammar k r tok a
PG ((Bool -> Either (Parser k r tok a) (Docs k))
 -> ParserWithGrammar k r tok a)
-> (Bool -> Either (Parser k r tok a) (Docs k))
-> ParserWithGrammar k r tok a
forall a b. (a -> b) -> a -> b
$ \Bool
b -> if Bool
b then Parser k r tok a -> Either (Parser k r tok a) (Docs k)
forall a b. a -> Either a b
Left Parser k r tok a
p else Docs k -> Either (Parser k r tok a) (Docs k)
forall a b. b -> Either a b
Right Docs k
d

-- | Extracts the parser.

parser :: ParserWithGrammar k r tok a -> Parser k r tok a
parser :: forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser (PG Bool -> Either (Parser k r tok a) (Docs k)
p) = (Parser k r tok a -> Parser k r tok a)
-> (Docs k -> Parser k r tok a)
-> Either (Parser k r tok a) (Docs k)
-> Parser k r tok a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Parser k r tok a -> Parser k r tok a
forall a. a -> a
id Docs k -> Parser k r tok a
forall a. HasCallStack => a
__IMPOSSIBLE__ (Bool -> Either (Parser k r tok a) (Docs k)
p Bool
True)

-- | Extracts the documents.

docs :: ParserWithGrammar k r tok a -> Docs k
docs :: forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs (PG Bool -> Either (Parser k r tok a) (Docs k)
p) = (Parser k r tok a -> Docs k)
-> (Docs k -> Docs k)
-> Either (Parser k r tok a) (Docs k)
-> Docs k
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Parser k r tok a -> Docs k
forall a. HasCallStack => a
__IMPOSSIBLE__ Docs k -> Docs k
forall a. a -> a
id (Bool -> Either (Parser k r tok a) (Docs k)
p Bool
False)

instance Monad (ParserWithGrammar k r tok) where
  return :: forall a. a -> ParserWithGrammar k r tok a
return  = a -> ParserWithGrammar k r tok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  ParserWithGrammar k r tok a
p >>= :: forall a b.
ParserWithGrammar k r tok a
-> (a -> ParserWithGrammar k r tok b)
-> ParserWithGrammar k r tok b
>>= a -> ParserWithGrammar k r tok b
f =
    Parser k r tok b -> Docs k -> ParserWithGrammar k r tok b
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p Parser k r tok a -> (a -> Parser k r tok b) -> Parser k r tok b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ParserWithGrammar k r tok b -> Parser k r tok b
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser (ParserWithGrammar k r tok b -> Parser k r tok b)
-> (a -> ParserWithGrammar k r tok b) -> a -> Parser k r tok b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ParserWithGrammar k r tok b
f)
       ((\(Doc
d, Pos
p) -> (Bool -> Doc -> Doc
mparens (Pos
p Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
bindP) Doc
d Doc -> Doc -> Doc
<+> Doc
">>= ?", Pos
bindP))
          (DocP -> DocP) -> Docs k -> Docs k
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p)

instance Functor (ParserWithGrammar k r tok) where
  fmap :: forall a b.
(a -> b)
-> ParserWithGrammar k r tok a -> ParserWithGrammar k r tok b
fmap a -> b
f ParserWithGrammar k r tok a
p = Parser k r tok b -> Docs k -> ParserWithGrammar k r tok b
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg ((a -> b) -> Parser k r tok a -> Parser k r tok b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p)) (ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p)

instance Applicative (ParserWithGrammar k r tok) where
  pure :: forall a. a -> ParserWithGrammar k r tok a
pure a
x    = Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (a -> Parser k r tok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (DocP -> Docs k
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
"ε", Pos
atomP))
  ParserWithGrammar k r tok (a -> b)
p1 <*> :: forall a b.
ParserWithGrammar k r tok (a -> b)
-> ParserWithGrammar k r tok a -> ParserWithGrammar k r tok b
<*> ParserWithGrammar k r tok a
p2 =
    Parser k r tok b -> Docs k -> ParserWithGrammar k r tok b
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (ParserWithGrammar k r tok (a -> b) -> Parser k r tok (a -> b)
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok (a -> b)
p1 Parser k r tok (a -> b) -> Parser k r tok a -> Parser k r tok b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p2)
       ((DocP -> DocP -> DocP) -> Docs k -> Docs k -> Docs k
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\(Doc
d1, Pos
p1) (Doc
d2, Pos
p2) ->
                   ([Doc] -> Doc
sep [ Bool -> Doc -> Doc
mparens (Pos
p1 Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
seqP) Doc
d1
                        , Bool -> Doc -> Doc
mparens (Pos
p2 Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
seqP) Doc
d2
                        ], Pos
seqP))
               (ParserWithGrammar k r tok (a -> b) -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok (a -> b)
p1) (ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p2))

-- | A helper function.

starDocs :: String -> ParserWithGrammar k r tok a -> Docs k
starDocs :: forall k r tok a. String -> ParserWithGrammar k r tok a -> Docs k
starDocs String
s ParserWithGrammar k r tok a
p =
  (\(Doc
d, Pos
p) -> (Bool -> Doc -> Doc
mparens (Pos
p Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
starP) Doc
d Doc -> Doc -> Doc
<+> String -> Doc
text String
s, Pos
starP)) (DocP -> DocP)
-> StateT (HashMap k (Maybe DocP)) Identity DocP
-> StateT (HashMap k (Maybe DocP)) Identity DocP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserWithGrammar k r tok a
-> StateT (HashMap k (Maybe DocP)) Identity DocP
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p

instance Alternative (ParserWithGrammar k r tok) where
  empty :: forall a. ParserWithGrammar k r tok a
empty     = Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg Parser k r tok a
forall (f :: * -> *) a. Alternative f => f a
empty (DocP -> Docs k
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
"∅", Pos
atomP))
  ParserWithGrammar k r tok a
p1 <|> :: forall a.
ParserWithGrammar k r tok a
-> ParserWithGrammar k r tok a -> ParserWithGrammar k r tok a
<|> ParserWithGrammar k r tok a
p2 =
    Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p1 Parser k r tok a -> Parser k r tok a -> Parser k r tok a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p2)
       ((DocP -> DocP -> DocP) -> Docs k -> Docs k -> Docs k
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\(Doc
d1, Pos
p1) (Doc
d2, Pos
p2) ->
                   ([Doc] -> Doc
sep [ Bool -> Doc -> Doc
mparens (Pos
p1 Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
choiceP) Doc
d1
                        , Doc
"|"
                        , Bool -> Doc -> Doc
mparens (Pos
p2 Pos -> Pos -> Bool
forall a. Ord a => a -> a -> Bool
< Pos
choiceP) Doc
d2
                        ], Pos
choiceP))
               (ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p1) (ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p2))

  many :: forall a.
ParserWithGrammar k r tok a -> ParserWithGrammar k r tok [a]
many ParserWithGrammar k r tok a
p = Parser k r tok [a] -> Docs k -> ParserWithGrammar k r tok [a]
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (Parser k r tok a -> Parser k r tok [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p)) (String -> ParserWithGrammar k r tok a -> Docs k
forall k r tok a. String -> ParserWithGrammar k r tok a -> Docs k
starDocs String
"⋆" ParserWithGrammar k r tok a
p)
  some :: forall a.
ParserWithGrammar k r tok a -> ParserWithGrammar k r tok [a]
some ParserWithGrammar k r tok a
p = Parser k r tok [a] -> Docs k -> ParserWithGrammar k r tok [a]
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (Parser k r tok a -> Parser k r tok [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
some (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p)) (String -> ParserWithGrammar k r tok a -> Docs k
forall k r tok a. String -> ParserWithGrammar k r tok a -> Docs k
starDocs String
"+" ParserWithGrammar k r tok a
p)

-- | Pretty-prints a memoisation key.

prettyKey :: Show k => k -> DocP
prettyKey :: forall k. Show k => k -> DocP
prettyKey k
key = (String -> Doc
text (String
"<" String -> String -> String
forall a. [a] -> [a] -> [a]
++ k -> String
forall a. Show a => a -> String
show k
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"), Pos
atomP)

-- | A helper function.

memoiseDocs ::
  (Eq k, Hashable k, Show k) =>
  k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs :: forall k r tok.
(Eq k, Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p = do
  Maybe (Maybe DocP)
r <- k -> HashMap k (Maybe DocP) -> Maybe (Maybe DocP)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
key (HashMap k (Maybe DocP) -> Maybe (Maybe DocP))
-> StateT
     (HashMap k (Maybe DocP)) Identity (HashMap k (Maybe DocP))
-> StateT (HashMap k (Maybe DocP)) Identity (Maybe (Maybe DocP))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (HashMap k (Maybe DocP)) Identity (HashMap k (Maybe DocP))
forall s (m :: * -> *). MonadState s m => m s
get
  case Maybe (Maybe DocP)
r of
    Just Maybe DocP
_  -> () -> StateT (HashMap k (Maybe DocP)) Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe (Maybe DocP)
Nothing -> do
      (HashMap k (Maybe DocP) -> HashMap k (Maybe DocP))
-> StateT (HashMap k (Maybe DocP)) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (k -> Maybe DocP -> HashMap k (Maybe DocP) -> HashMap k (Maybe DocP)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
key Maybe DocP
forall a. Maybe a
Nothing)
      DocP
d <- ParserWithGrammar k r tok r -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok r
p
      (HashMap k (Maybe DocP) -> HashMap k (Maybe DocP))
-> StateT (HashMap k (Maybe DocP)) Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (k -> Maybe DocP -> HashMap k (Maybe DocP) -> HashMap k (Maybe DocP)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
key (DocP -> Maybe DocP
forall a. a -> Maybe a
Just DocP
d))
  DocP -> Docs k
forall (m :: * -> *) a. Monad m => a -> m a
return (k -> DocP
forall k. Show k => k -> DocP
prettyKey k
key)

instance ParserClass (ParserWithGrammar k r tok) k r tok where
  parse :: forall a. ParserWithGrammar k r tok a -> [tok] -> [a]
parse ParserWithGrammar k r tok a
p                 = Parser k r tok a -> [tok] -> [a]
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
p a -> [tok] -> [a]
parse (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p)
  sat' :: forall a. (tok -> Maybe a) -> ParserWithGrammar k r tok a
sat' tok -> Maybe a
p                  = Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg ((tok -> Maybe a) -> Parser k r tok a
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
(tok -> Maybe a) -> p a
sat' tok -> Maybe a
p) (DocP -> Docs k
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
"<sat ?>", Pos
atomP))
  annotate :: forall a.
(DocP -> DocP)
-> ParserWithGrammar k r tok a -> ParserWithGrammar k r tok a
annotate DocP -> DocP
f ParserWithGrammar k r tok a
p            = Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (ParserWithGrammar k r tok a -> Parser k r tok a
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok a
p) (DocP -> DocP
f (DocP -> DocP) -> Docs k -> Docs k
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p)
  memoise :: (Eq k, Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> ParserWithGrammar k r tok r
memoise k
key ParserWithGrammar k r tok r
p           = Parser k r tok r -> Docs k -> ParserWithGrammar k r tok r
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (k -> Parser k r tok r -> Parser k r tok r
forall (p :: * -> *) k r tok.
(ParserClass p k r tok, Eq k, Hashable k, Show k) =>
k -> p r -> p r
memoise k
key (ParserWithGrammar k r tok r -> Parser k r tok r
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok r
p))
                               (k -> ParserWithGrammar k r tok r -> Docs k
forall k r tok.
(Eq k, Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p)
  memoiseIfPrinting :: (Eq k, Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> ParserWithGrammar k r tok r
memoiseIfPrinting k
key ParserWithGrammar k r tok r
p = Parser k r tok r -> Docs k -> ParserWithGrammar k r tok r
forall k r tok a.
Parser k r tok a -> Docs k -> ParserWithGrammar k r tok a
pg (ParserWithGrammar k r tok r -> Parser k r tok r
forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser ParserWithGrammar k r tok r
p) (k -> ParserWithGrammar k r tok r -> Docs k
forall k r tok.
(Eq k, Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p)

  grammar :: forall a. Show k => ParserWithGrammar k r tok a -> Doc
grammar ParserWithGrammar k r tok a
p =
    Doc
d
      Doc -> Doc -> Doc
$+$
    Pos -> Doc -> Doc
nest Pos
2 ((Doc -> Doc -> Doc) -> [Doc] -> Doc
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
($+$) ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
      Doc
"where" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
:
      ((k, Maybe DocP) -> Doc) -> [(k, Maybe DocP)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(k
k, Maybe DocP
d) -> DocP -> Doc
forall a b. (a, b) -> a
fst (k -> DocP
forall k. Show k => k -> DocP
prettyKey k
k) Doc -> Doc -> Doc
<+> Doc
"∷=" Doc -> Doc -> Doc
<+>
                        Doc -> (DocP -> Doc) -> Maybe DocP -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
forall a. HasCallStack => a
__IMPOSSIBLE__ DocP -> Doc
forall a b. (a, b) -> a
fst Maybe DocP
d)
          (HashMap k (Maybe DocP) -> [(k, Maybe DocP)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (Maybe DocP)
ds))
    where
    ((Doc
d, Pos
_), HashMap k (Maybe DocP)
ds) = Docs k -> HashMap k (Maybe DocP) -> (DocP, HashMap k (Maybe DocP))
forall s a. State s a -> s -> (a, s)
runState (ParserWithGrammar k r tok a -> Docs k
forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs ParserWithGrammar k r tok a
p) HashMap k (Maybe DocP)
forall k v. HashMap k v
Map.empty