{-# 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 Mikan.Utils.Parser.MemoisedCPS
  ( ParserClass(..)
  , sat, token, tok, doc
  , Regex
  , Parser
  , ParserWithGrammar
  ) where

import Control.Applicative ( Alternative((<|>), empty, many, some) )
import Control.Monad ((<=<))

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.Function (on)
import Data.Functor
import Data.Maybe
import Data.List (sortBy)
import GHC.Exts

import Mikan.Syntax.Common.Pretty hiding (annotate)

import Mikan.Utils.MinimalArray.Lifted qualified as A
import Mikan.Utils.List1 qualified as List1
import Mikan.Utils.Null qualified as Null
import Mikan.Utils.StrictState
import Mikan.Utils.Impossible
import Mikan.Utils.List


-- | 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 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) =>
      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 :: (Ord k, Pretty 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 :: (Regex -> Regex) -> 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, Pretty 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, Pretty 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 = (Regex -> Regex) -> p a -> p a
forall a. (Regex -> Regex) -> p a -> p a
forall (p :: * -> *) k r tok a.
ParserClass p k r tok =>
(Regex -> Regex) -> p a -> p a
annotate \Regex
_ -> Doc -> Regex
AtomP Doc
d

{-# 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. (Ord k, Pretty 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. (Regex -> Regex) -> Parser k r tok a -> Parser k r tok a
annotate          Regex -> Regex
_ Parser k r tok a
p = Parser k r tok a
p
  memoiseIfPrinting :: (Hashable k, Pretty 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, Pretty 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. (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
<=< 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.
(Eq k, 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.
(Eq k, 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
     }

-- | Concrete representation of 'Parser's that can be simplified for pretty-printing.
data Regex
  = AtomP Doc
    -- ^ Stand-in for a terminal or non-terminal.
  | ZeroP
    -- ^ Parser 'fail', zero for 'AltP'.
  | UnitP
    -- ^ Parser 'pure', unit for 'SeqP'.
  | AltP Regex Regex
    -- ^ Parser '(<|>)'.
  | SeqP Regex Regex
    -- ^ Parser '(<*>)'.
  | StarP !Char Regex
    -- ^ Parser 'some' or 'many'; the 'Char' argument indicates which.

isAtomic :: Regex -> Bool
isAtomic :: Regex -> Bool
isAtomic = \case
  AtomP{} -> Bool
True
  Regex
ZeroP   -> Bool
True
  Regex
UnitP   -> Bool
True
  Regex
_       -> Bool
False

instance Pretty Regex where
  pretty :: Regex -> Doc
pretty = Regex -> Doc
choice where
    choice :: Regex -> Doc
choice (AltP Regex
x Regex
y) = Regex -> Doc
choice Regex
x Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
hlSymbol Doc
"|" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Regex -> Doc
choice Regex
y
    choice Regex
x          = Regex -> Doc
sequence Regex
x

    sequence :: Regex -> Doc
sequence (SeqP Regex
x Regex
y) = Regex -> Doc
sequence Regex
x Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Regex -> Doc
sequence Regex
y
    sequence Regex
x          = Regex -> Doc
star Regex
x

    star :: Regex -> Doc
star (StarP Char
s Regex
x) = Regex -> Doc
atom Regex
x Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
hlKeyword (Char -> Doc
forall a. Pretty a => a -> Doc
pretty Char
s)
    star Regex
x           = Regex -> Doc
atom Regex
x

    atom :: Regex -> Doc
atom Regex
a = case Regex
a of
      AtomP Doc
doc -> Doc
doc
      Regex
ZeroP     -> Doc -> Doc
hlKeyword Doc
"∅"
      Regex
UnitP     -> Doc -> Doc
hlKeyword Doc
"ε"
      Regex
_         -> Doc -> Doc
parens (Regex -> Doc
choice Regex
a)

-- | 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 Regex)) Regex

seqP, altP :: Regex -> Regex -> Regex
seqP :: Regex -> Regex -> Regex
seqP Regex
x Regex
y = case Regex
x of
  SeqP Regex
x1 Regex
x2 -> Regex -> Regex -> Regex
seqP Regex
x1 (Regex -> Regex -> Regex
seqP Regex
x2 Regex
y)
  Regex
ZeroP      -> Regex
ZeroP
  Regex
UnitP      -> Regex
y
  Regex
_          -> case Regex
y of
    Regex
ZeroP      -> Regex
ZeroP
    Regex
UnitP      -> Regex
x
    Regex
_          -> Regex -> Regex -> Regex
SeqP Regex
x Regex
y

altP :: Regex -> Regex -> Regex
altP Regex
x Regex
y = case Regex
x of
  AltP Regex
x1 Regex
x2 -> Regex -> Regex -> Regex
altP Regex
x1 (Regex -> Regex -> Regex
altP Regex
x2 Regex
y)
  Regex
ZeroP -> Regex
y
  Regex
_     -> case Regex
y of
    Regex
ZeroP -> Regex
x
    Regex
_     -> Regex -> Regex -> Regex
AltP Regex
x Regex
y

-- | 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 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) (Regex -> Docs k
forall a. a -> State (HashMap k (Maybe Regex)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Regex
UnitP)
  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) (Docs k -> ParserWithGrammar k r tok b)
-> Docs k -> ParserWithGrammar k r tok b
forall a b. (a -> b) -> a -> b
$ Regex -> Regex -> Regex
seqP (Regex -> Regex -> Regex)
-> Docs k -> State (HashMap k (Maybe Regex)) (Regex -> Regex)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 State (HashMap k (Maybe Regex)) (Regex -> Regex)
-> Docs k -> Docs k
forall a b.
State (HashMap k (Maybe Regex)) (a -> b)
-> State (HashMap k (Maybe Regex)) a
-> State (HashMap k (Maybe Regex)) b
forall (f :: * -> *) a b. Applicative f => 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
p2

-- | A helper function.

starDocs :: Char -> ParserWithGrammar k r tok a -> Docs k
starDocs :: forall k r tok a. Char -> ParserWithGrammar k r tok a -> Docs k
starDocs Char
op 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 Docs k -> (Regex -> Regex) -> Docs k
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Char -> Regex -> Regex
StarP Char
op

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 (Regex -> Docs k
forall a. a -> State (HashMap k (Maybe Regex)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Regex
ZeroP)
  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) (Docs k -> ParserWithGrammar k r tok a)
-> Docs k -> ParserWithGrammar k r tok a
forall a b. (a -> b) -> a -> b
$ Regex -> Regex -> Regex
altP (Regex -> Regex -> Regex)
-> Docs k -> State (HashMap k (Maybe Regex)) (Regex -> Regex)
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
p1 State (HashMap k (Maybe Regex)) (Regex -> Regex)
-> Docs k -> Docs k
forall a b.
State (HashMap k (Maybe Regex)) (a -> b)
-> State (HashMap k (Maybe Regex)) a
-> State (HashMap k (Maybe Regex)) b
forall (f :: * -> *) a b. Applicative f => 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
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)) (Char -> ParserWithGrammar k r tok a -> Docs k
forall k r tok a. Char -> ParserWithGrammar k r tok a -> Docs k
starDocs Char
'⋆' 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)) (Char -> ParserWithGrammar k r tok a -> Docs k
forall k r tok a. Char -> ParserWithGrammar k r tok a -> Docs k
starDocs Char
'+' ParserWithGrammar k r tok a
p)

-- | Pretty-prints a memoisation key.

prettyKey :: Pretty k => k -> Regex
prettyKey :: forall k. Pretty k => k -> Regex
prettyKey k
key = Doc -> Regex
AtomP (k -> Doc
forall a. Pretty a => a -> Doc
pretty k
key)

-- | A helper function.

memoiseDocs ::
  (Hashable k, Pretty k) =>
  k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs :: forall k r tok.
(Hashable k, Pretty k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p = do
  r :: Maybe (Maybe Regex) <- k -> HashMap k (Maybe Regex) -> Maybe (Maybe Regex)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup k
key (HashMap k (Maybe Regex) -> Maybe (Maybe Regex))
-> State (HashMap k (Maybe Regex)) (HashMap k (Maybe Regex))
-> State (HashMap k (Maybe Regex)) (Maybe (Maybe Regex))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> State (HashMap k (Maybe Regex)) (HashMap k (Maybe Regex))
forall s (m :: * -> *). MonadState s m => m s
get
  case r of
    Just Maybe Regex
_  -> () -> State (HashMap k (Maybe Regex)) ()
forall a. a -> State (HashMap k (Maybe Regex)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    Maybe (Maybe Regex)
Nothing -> do
      (HashMap k (Maybe Regex) -> HashMap k (Maybe Regex))
-> State (HashMap k (Maybe Regex)) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (k
-> Maybe Regex
-> HashMap k (Maybe Regex)
-> HashMap k (Maybe Regex)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
key Maybe Regex
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))
  pure (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) (Regex -> Docs k
forall a. a -> State (HashMap k (Maybe Regex)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> Regex
AtomP Doc
"<sat ?>"))
  annotate :: forall a.
(Regex -> Regex)
-> ParserWithGrammar k r tok a -> ParserWithGrammar k r tok a
annotate Regex -> Regex
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) (Regex -> Regex
f (Regex -> Regex) -> 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, Pretty 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, Pretty 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, Pretty k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p)
  memoiseIfPrinting :: (Hashable k, Pretty 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, Pretty k) =>
k -> ParserWithGrammar k r tok r -> Docs k
memoiseDocs k
key ParserWithGrammar k r tok r
p)

  grammar :: forall a. (Ord k, Pretty k) => ParserWithGrammar k r tok a -> Doc
grammar ParserWithGrammar k r tok a
p =
    let
      (Regex
doc, HashMap k (Maybe Regex)
ds) = Docs k
-> HashMap k (Maybe Regex) -> (Regex, HashMap k (Maybe Regex))
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 Regex)
forall k v. HashMap k v
Map.empty

      alts :: Regex -> f Regex
alts (AltP Regex
x Regex
y) = Regex -> f Regex
alts Regex
x f Regex -> f Regex -> f Regex
forall a. Semigroup a => a -> a -> a
<> Regex -> f Regex
alts Regex
y
      alts Regex
d          = Regex -> f Regex
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Regex
d

      prettyRule :: k -> Maybe Regex -> Doc
prettyRule k
k Maybe Regex
Nothing = Doc
forall a. HasCallStack => a
__IMPOSSIBLE__
      prettyRule k
k (Just Regex
d) | Regex
one List1.:| [Regex]
rest <- Regex -> NonEmpty Regex
forall {f :: * -> *}.
(Semigroup (f Regex), Applicative f) =>
Regex -> f Regex
alts Regex
d = case [Regex]
rest of
        [] -> Regex -> Doc
forall a. Pretty a => a -> Doc
pretty (k -> Regex
forall k. Pretty k => k -> Regex
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
<+> Regex -> Doc
forall a. Pretty a => a -> Doc
pretty Regex
one
        [Regex]
os -> Doc -> Int -> Doc -> Doc
forall a. Doc a -> Int -> Doc a -> Doc a
hang (Regex -> Doc
forall a. Pretty a => a -> Doc
pretty (k -> Regex
forall k. Pretty k => k -> Regex
prettyKey k
k)) Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat
          ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc
hlSymbol Doc
":" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Regex -> Doc
forall a. Pretty a => a -> Doc
pretty Regex
one)
          Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (Regex -> Doc) -> [Regex] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\Regex
d -> Doc -> Doc
hlSymbol Doc
"|" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Regex -> Doc
forall a. Pretty a => a -> Doc
pretty Regex
d) [Regex]
os

      rules :: [(k, Maybe Regex)]
rules = ((k, Maybe Regex) -> (k, Maybe Regex) -> Ordering)
-> [(k, Maybe Regex)] -> [(k, Maybe Regex)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (k -> k -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (k -> k -> Ordering)
-> ((k, Maybe Regex) -> k)
-> (k, Maybe Regex)
-> (k, Maybe Regex)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (k, Maybe Regex) -> k
forall a b. (a, b) -> a
fst) (HashMap k (Maybe Regex) -> [(k, Maybe Regex)]
forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap k (Maybe Regex)
ds)
    in Doc
"Operator grammar:" Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Regex -> Doc
forall a. Pretty a => a -> Doc
pretty Regex
doc Doc -> Doc -> Doc
forall a. Doc a -> Doc a -> Doc a
<+> Doc -> Doc
hlKeyword Doc
"where" 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
forall (t :: * -> *). Foldable t => t Doc -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((k, Maybe Regex) -> Doc) -> [(k, Maybe Regex)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((k -> Maybe Regex -> Doc) -> (k, Maybe Regex) -> Doc
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry k -> Maybe Regex -> Doc
forall {k}. Pretty k => k -> Maybe Regex -> Doc
prettyRule) [(k, Maybe Regex)]
rules)