{-# LANGUAGE MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -Wunused-imports #-}

------------------------------------------------------------------------
-- | 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 Data.Hashable
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict (HashMap)

import Data.IntMap.Strict qualified as IntMap
import Data.IntMap.Strict (IntMap)
import Data.Maybe
import GHC.Exts

import Agda.Utils.Null qualified as Null
import Agda.Syntax.Common.Pretty hiding (annotate)

import Agda.Utils.List
import Agda.Utils.Impossible
import Agda.Utils.StrictState
import Agda.Utils.MinimalArray.Lifted qualified as A

-- | 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP :: forall b.
             A.Array tok ->
             Pos ->
             Cont k r tok b a ->
             M k r tok b [b]
    }

instance Monad (Parser k r tok) where
  {-# INLINE return #-}
  return :: forall a. a -> Parser k r tok a
return    = a -> Parser k r tok a
forall a. a -> Parser k r tok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
  {-# INLINE (>>=) #-}
  P forall b. Array 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 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
input Pos
i Cont k r tok b b
k ->
    Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b. Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p Array tok
input Pos
i \Pos
j a
x -> Parser k r tok b
-> forall b.
   Array 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 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 tok
input Pos
j Cont k r tok b b
k

instance Functor (Parser k r tok) where
  {-# INLINE fmap #-}
  fmap :: forall a b. (a -> b) -> Parser k r tok a -> Parser k r tok b
fmap a -> b
f (P forall b. Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p) = (forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
input Pos
i Cont k r tok b b
k ->
    Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b. Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p Array tok
input Pos
i \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
  {-# INLINE pure #-}
  pure :: forall a. a -> Parser k r tok a
pure a
x        = (forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
_ Pos
i Cont k r tok b a
k -> Cont k r tok b a
k Pos
i a
x
  {-# INLINE (<*>) #-}
  P forall b.
Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 = (forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
input Pos
i Cont k r tok b b
k ->
    Array tok -> Pos -> Cont k r tok b (a -> b) -> M k r tok b [b]
forall b.
Array tok -> Pos -> Cont k r tok b (a -> b) -> M k r tok b [b]
p1 Array tok
input Pos
i \Pos
i a -> b
f ->
    Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b. Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 Array tok
input Pos
i \Pos
i a
x ->
    Cont k r tok b b
k Pos
i (b -> M k r tok b [b]) -> b -> M k r tok b [b]
forall a b. (a -> b) -> a -> b
$! a -> b
f a
x

instance Alternative (Parser k r tok) where
  {-# INLINE empty #-}
  empty :: forall a. Parser k r tok a
empty         = (forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
_ Pos
_ Cont k r tok b a
_ -> [b] -> M k r tok b [b]
forall a. a -> State (IntMap (HashMap k (Value k r tok b))) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  {-# INLINE (<|>) #-}
  P forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 = (forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
input Pos
i Cont k r tok b a
k ->
    [b] -> [b] -> [b]
forall a. [a] -> [a] -> [a]
(++!) ([b] -> [b] -> [b])
-> M k r tok b [b]
-> State (IntMap (HashMap k (Value k r tok b))) ([b] -> [b])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b. Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p1 Array tok
input Pos
i Cont k r tok b a
k State (IntMap (HashMap k (Value k r tok b))) ([b] -> [b])
-> M k r tok b [b] -> M k r tok b [b]
forall a b.
State (IntMap (HashMap k (Value k r tok b))) (a -> b)
-> State (IntMap (HashMap k (Value k r tok b))) a
-> State (IntMap (HashMap k (Value k r tok b))) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
forall b. Array tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
p2 Array 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 :: (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 :: (Hashable k, Show k) => k -> p r -> p r

{-# INLINE doc #-}
-- | 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 a. (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, Int
atomP))

{-# INLINE sat #-}
-- | 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 a. (tok -> Maybe a) -> p a
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)

{-# INLINE token #-}
-- | 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 a. (tok -> Maybe a) -> p a
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)

{-# INLINE tok #-}
-- | 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
forall a. String -> Doc a
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
==))

-- | List of positions and values with much better memory layout than @[(Pos, v)]@.
data Assocs v = ANil | ACons Pos !v !(Assocs v)

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 =
    let !arr :: Array tok
arr = [tok] -> Array tok
forall a. [a] -> Array a
A.fromList [tok]
toks
        !n :: Int
n   = Array tok -> Int
forall a. Array a -> Int
A.size Array tok
arr in
    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 (Parser k r tok a
-> forall b.
   Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP Parser k r tok a
p Array tok
arr Pos
0# \Pos
j a
x -> if Pos -> Int
I# Pos
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n then [a] -> State (IntMap (HashMap k (Value k r tok a))) [a]
forall a. 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 a. a -> State (IntMap (HashMap k (Value k r tok a))) a
forall (m :: * -> *) a. Monad m => a -> m a
return [])
              IntMap (HashMap k (Value k r tok a))
forall a. Monoid a => a
mempty

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

  {-# INLINE sat' #-}
  sat' :: forall a. (tok -> Maybe a) -> Parser k r tok a
sat' tok -> Maybe a
p = (forall b. Array 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
input Pos
i Cont k r tok b a
k -> (IntMap (HashMap k (Value k r tok b))
 -> (# [b], IntMap (HashMap k (Value k r tok b)) #))
-> M k r tok b [b]
forall s a. (s -> (# a, s #)) -> State s a
State \IntMap (HashMap k (Value k r tok b))
s ->
    if Int
0 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Pos -> Int
I# Pos
i Bool -> Bool -> Bool
&& Pos -> Int
I# Pos
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Array tok -> Int
forall a. Array a -> Int
A.size Array tok
input then
      case tok -> Maybe a
p (Array tok -> Int -> tok
forall a. Array a -> Int -> a
A.unsafeIndex Array tok
input (Pos -> Int
I# Pos
i)) of
        Maybe a
Nothing  -> (# [], IntMap (HashMap k (Value k r tok b))
s #)
        Just !a
x  -> M k r tok b [b]
-> IntMap (HashMap k (Value k r tok b))
-> (# [b], IntMap (HashMap k (Value k r tok b)) #)
forall s a. State s a -> s -> (# a, s #)
runState# (Cont k r tok b a
k (Pos
i Pos -> Pos -> Pos
+# Pos
1#) a
x) IntMap (HashMap k (Value k r tok b))
s
    else
      (# [], IntMap (HashMap k (Value k r tok b))
s #)

  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 :: (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 :: (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 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b])
-> Parser k r tok a
P \Array tok
input Pos
i Cont k r tok b r
k -> do

    let alter :: Int -> b -> (b -> b) -> IntMap b -> IntMap b
alter Int
j b
zero b -> b
f IntMap b
m =
          (Maybe b -> Maybe b) -> Int -> IntMap b -> IntMap b
forall a. (Maybe a -> Maybe a) -> Int -> 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) Int
j IntMap b
m

        lookupTable :: State
  (IntMap (HashMap k (Value k r tok b))) (Maybe (Value k r tok b))
lookupTable   = (k -> HashMap k (Value k r tok b) -> Maybe (Value k r tok b)
forall k v. 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
<=< Int
-> IntMap (HashMap k (Value k r tok b))
-> Maybe (HashMap k (Value k r tok b))
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup (Pos -> Int
I# Pos
i)) (IntMap (HashMap k (Value k r tok b)) -> Maybe (Value k r tok b))
-> State
     (IntMap (HashMap k (Value k r tok b)))
     (IntMap (HashMap k (Value k r tok b)))
-> State
     (IntMap (HashMap k (Value k r tok b))) (Maybe (Value k r tok b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State
  (IntMap (HashMap k (Value k r tok b)))
  (IntMap (HashMap k (Value k r tok b)))
forall s (m :: * -> *). MonadState s m => m s
get
        lookupTable' :: State (IntMap (HashMap k (Value k r tok b))) (Value k r tok b)
lookupTable'  = (\IntMap (HashMap k (Value k r tok b))
tbl -> (IntMap (HashMap k (Value k r tok b))
tbl IntMap (HashMap k (Value k r tok b))
-> Int -> HashMap k (Value k r tok b)
forall a. IntMap a -> Int -> a
IntMap.! Pos -> Int
I# Pos
i) HashMap k (Value k r tok b) -> k -> Value k r tok b
forall k v. (Hashable k, HasCallStack) => HashMap k v -> k -> v
Map.! k
key) (IntMap (HashMap k (Value k r tok b)) -> Value k r tok b)
-> State
     (IntMap (HashMap k (Value k r tok b)))
     (IntMap (HashMap k (Value k r tok b)))
-> State (IntMap (HashMap k (Value k r tok b))) (Value k r tok b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State
  (IntMap (HashMap k (Value k r tok b)))
  (IntMap (HashMap k (Value k r tok b)))
forall s (m :: * -> *). MonadState s m => m s
get
        insertTable :: Value k r tok b -> State (IntMap (HashMap k (Value k r tok b))) ()
insertTable Value k r tok b
v = (IntMap (HashMap k (Value k r tok b))
 -> IntMap (HashMap k (Value k r tok b)))
-> State (IntMap (HashMap k (Value k r tok b))) ()
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)))
 -> State (IntMap (HashMap k (Value k r tok b))) ())
-> (IntMap (HashMap k (Value k r tok b))
    -> IntMap (HashMap k (Value k r tok b)))
-> State (IntMap (HashMap k (Value k r tok b))) ()
forall a b. (a -> b) -> a -> b
$ Int
-> 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}. Int -> b -> (b -> b) -> IntMap b -> IntMap b
alter (Pos -> Int
I# 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. Hashable k => k -> v -> HashMap k v -> HashMap k v
Map.insert k
key Value k r tok b
v)

    v <- State
  (IntMap (HashMap k (Value k r tok b))) (Maybe (Value k r tok b))
lookupTable
    case v of
      Maybe (Value k r tok b)
Nothing -> do
        Value k r tok b -> State (IntMap (HashMap k (Value k r tok b))) ()
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 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 tok -> Pos -> Cont k r tok b a -> M k r tok b [b]
unP Parser k r tok r
p Array tok
input Pos
i \Pos
j r
r -> do
          Value rs ks <- State (IntMap (HashMap k (Value k r tok b))) (Value k r tok b)
lookupTable'
          insertTable (Value (alter (I# j) [] (r :) rs) ks)

          let catMap (Pos
j :: Pos) !t
r []     = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
              catMap Pos
j           t
r (Pos -> t -> f [a]
k:[Pos -> t -> f [a]]
ks) = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++!) ([a] -> [a] -> [a]) -> f [a] -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pos -> t -> f [a]
k Pos
j t
r f ([a] -> [a]) -> f [a] -> f [a]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Pos -> t -> [Pos -> t -> f [a]] -> f [a]
catMap Pos
j t
r [Pos -> t -> f [a]]
ks

          catMap j r ks -- See note [Reverse ks?].

      Just (Value IntMap [r]
rs [Cont k r tok b r]
ks) -> do
        Value k r tok b -> State (IntMap (HashMap k (Value k r tok b))) ()
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))
        let !assocs :: Assocs [r]
assocs = (Int -> [r] -> Assocs [r] -> Assocs [r])
-> Assocs [r] -> IntMap [r] -> Assocs [r]
forall a b. (Int -> a -> b -> b) -> b -> IntMap a -> b
IntMap.foldrWithKey' (\(I# Pos
i) [r]
rs Assocs [r]
acc -> Pos -> [r] -> Assocs [r] -> Assocs [r]
forall v. Pos -> v -> Assocs v -> Assocs v
ACons Pos
i [r]
rs Assocs [r]
acc) Assocs [r]
forall v. Assocs v
ANil IntMap [r]
rs

        let go :: (Pos -> t -> f [a]) -> Assocs [t] -> f [a]
go Pos -> t -> f [a]
k Assocs [t]
ANil                = [a] -> f [a]
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
            go Pos -> t -> f [a]
k (ACons Pos
i [t]
rs Assocs [t]
assocs) = (Pos -> t -> f [a]) -> Pos -> [t] -> Assocs [t] -> f [a]
go' Pos -> t -> f [a]
k Pos
i [t]
rs Assocs [t]
assocs
            go' :: (Pos -> t -> f [a]) -> Pos -> [t] -> Assocs [t] -> f [a]
go' Pos -> t -> f [a]
k (Pos
i :: Pos) []     Assocs [t]
assocs = (Pos -> t -> f [a]) -> Assocs [t] -> f [a]
go Pos -> t -> f [a]
k Assocs [t]
assocs
            go' Pos -> t -> f [a]
k Pos
i          (t
r:[t]
rs) Assocs [t]
assocs = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++!) ([a] -> [a] -> [a]) -> f [a] -> f ([a] -> [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pos -> t -> f [a]
k Pos
i t
r f ([a] -> [a]) -> f [a] -> f [a]
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Pos -> t -> f [a]) -> Pos -> [t] -> Assocs [t] -> f [a]
go' Pos -> t -> f [a]
k Pos
i [t]
rs Assocs [t]
assocs

        Cont k r tok b r -> Assocs [r] -> M k r tok b [b]
forall {f :: * -> *} {t} {a}.
Applicative f =>
(Pos -> t -> f [a]) -> Assocs [t] -> f [a]
go Cont k r tok b r
k Assocs [r]
assocs

-- [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 =
  -- | This must be a lazy tuple so that we don't generate the docs eagerly.
  PG { forall k r tok a. ParserWithGrammar k r tok a -> Parser k r tok a
parser :: Parser k r tok a
     , forall k r tok a. ParserWithGrammar k r tok a -> Docs k
docs   :: Docs k
     }

-- | Documents paired with precedence levels.

type DocP = (Doc, Int)

-- | Precedence of @>>=@.

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

-- | Precedence of @<|>@.

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

-- | Precedence of @<*>@.

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

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

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

-- | Precedence of atoms.

atomP :: Int
atomP :: Int
atomP = Int
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

-- | The 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 -> 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

instance Monad (ParserWithGrammar k r tok) where
  return :: forall a. a -> ParserWithGrammar k r tok a
return  = a -> ParserWithGrammar k r tok a
forall a. 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 a b.
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, Int
p) -> (Bool -> Doc -> Doc
mparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
bindP) Doc
d Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc
">>= ?", Int
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 a b. (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 a. a -> Parser k r tok a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x) (DocP -> Docs k
forall a. a -> State (HashMap k (Maybe DocP)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
"ε", Int
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 a b.
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, Int
p1) (Doc
d2, Int
p2) ->
                   ([Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Bool -> Doc -> Doc
mparens (Int
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
seqP) Doc
d1
                        , Bool -> Doc -> Doc
mparens (Int
p2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
seqP) Doc
d2
                        ], Int
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, Int
p) -> (Bool -> Doc -> Doc
mparens (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
starP) Doc
d Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> String -> Doc
forall a. String -> Doc a
text String
s, Int
starP)) (DocP -> DocP)
-> State (HashMap k (Maybe DocP)) DocP
-> State (HashMap k (Maybe DocP)) DocP
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParserWithGrammar k r tok a -> State (HashMap k (Maybe DocP)) 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 a. Parser k r tok a
forall (f :: * -> *) a. Alternative f => f a
empty (DocP -> Docs k
forall a. a -> State (HashMap k (Maybe DocP)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
"∅", Int
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 a. 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, Int
p1) (Doc
d2, Int
p2) ->
                   ([Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
sep [ Bool -> Doc -> Doc
mparens (Int
p1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
choiceP) Doc
d1
                        , Doc
"|"
                        , Bool -> Doc -> Doc
mparens (Int
p2 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
choiceP) Doc
d2
                        ], Int
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 a. 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 a. 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
forall a. String -> Doc a
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
">"), Int
atomP)

-- | A helper function.

memoiseDocs ::
  (Hashable k, Show k) =>
  k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs :: forall k r tok.
(Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p = do
  r <- k -> HashMap k (Maybe DocP) -> Maybe (Maybe DocP)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup k
key (HashMap k (Maybe DocP) -> Maybe (Maybe DocP))
-> State (HashMap k (Maybe DocP)) (HashMap k (Maybe DocP))
-> State (HashMap k (Maybe DocP)) (Maybe (Maybe DocP))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State (HashMap k (Maybe DocP)) (HashMap k (Maybe DocP))
forall s (m :: * -> *). MonadState s m => m s
get
  case r of
    Just Maybe DocP
_  -> () -> State (HashMap k (Maybe DocP)) ()
forall a. a -> State (HashMap k (Maybe DocP)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe (Maybe DocP)
Nothing -> do
      (HashMap k (Maybe DocP) -> HashMap k (Maybe DocP))
-> State (HashMap k (Maybe DocP)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (k -> Maybe DocP -> HashMap k (Maybe DocP) -> HashMap k (Maybe DocP)
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
Map.insert k
key Maybe DocP
forall a. Maybe a
Nothing)
      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
      modify (Map.insert key (Just d))
  return (prettyKey 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 a. 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 a. (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 a. a -> State (HashMap k (Maybe DocP)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Doc
"<sat ?>", Int
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 :: (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, 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.
(Hashable k, Show k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p)
  memoiseIfPrinting :: (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.
(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
forall a. Doc a -> Doc a -> Doc a
$+$
    Int -> Doc -> Doc
forall a. Int -> Doc a -> Doc a
nest Int
2 ((Doc -> Doc -> Doc) -> [Doc] -> Doc
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
($+$) ([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
forall a. Doc a -> Doc a -> Doc a
<+> Doc
"∷=" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+>
                        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, Int
_), 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