-- <ghc2021+->
{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE EmptyCase, PostfixOperators, TupleSections, NamedFieldPuns, BangPatterns, BinaryLiterals, HexFloatLiterals, NumericUnderscores, GADTSyntax, RankNTypes, TypeApplications, PolyKinds, ExistentialQuantification, TypeOperators, ConstraintKinds, ExplicitForAll, KindSignatures, NamedWildCards, ScopedTypeVariables, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, ConstrainedClassMethods, InstanceSigs, TypeSynonymInstances, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveTraversable, StandaloneDeriving, EmptyDataDeriving, DeriveLift, DeriveGeneric #-}
-- Deleted GeneralisedNewtypeDeriving, because it is not compatible with Safe
-- Deleted ImportQualifiedPost, StandaloneKindSignatures, because they are not supported in ghc 8.8.1
{-# LANGUAGE MonoLocalBinds #-}
-- </ghc2021+->

{-# LANGUAGE LambdaCase #-}

{- |
(I assume you have read description at https://hackage.haskell.org/package/check-cfg-ambiguity .)

Example. Let's check grammar of expressions of form @1 + (2 + 3)@ for ambiguity.

>>> import CheckCFGAmbiguity
>>> import qualified Data.Map as M
>>> :{
checkAmbiguity (M.fromList [
  ("expr", [[N "term"],
            [N "expr", T "+", N "term"]]),
  ("term", [[T "number"],
            [T "(", N "expr", T ")"]])
]) "expr" 10
:}
SeemsUnambiguous
-}
module CheckCFGAmbiguity (TerminalOrNonterminal(..), checkAmbiguity, Result(..) {- $Earley -}) where

import qualified Data.Map
import qualified Data.Set
import Control.Monad.ST(runST)
import Data.STRef(newSTRef, readSTRef, writeSTRef)
import Data.Maybe(fromJust, catMaybes)
import Data.List(find)
import Data.Functor((<&>))
import Control.Monad(when)

data TerminalOrNonterminal t n = T t | N n deriving (TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
(TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool)
-> (TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool)
-> Eq (TerminalOrNonterminal t n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t n.
(Eq t, Eq n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
$c== :: forall t n.
(Eq t, Eq n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
== :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
$c/= :: forall t n.
(Eq t, Eq n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
/= :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
Eq, Eq (TerminalOrNonterminal t n)
Eq (TerminalOrNonterminal t n) =>
(TerminalOrNonterminal t n
 -> TerminalOrNonterminal t n -> Ordering)
-> (TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool)
-> (TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool)
-> (TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool)
-> (TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool)
-> (TerminalOrNonterminal t n
    -> TerminalOrNonterminal t n -> TerminalOrNonterminal t n)
-> (TerminalOrNonterminal t n
    -> TerminalOrNonterminal t n -> TerminalOrNonterminal t n)
-> Ord (TerminalOrNonterminal t n)
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t n. (Ord t, Ord n) => Eq (TerminalOrNonterminal t n)
forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
$ccompare :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
compare :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
$c< :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
< :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
$c<= :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
<= :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
$c> :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
> :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
$c>= :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
>= :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
$cmax :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
max :: TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
$cmin :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
min :: TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
Ord, Int -> TerminalOrNonterminal t n -> ShowS
[TerminalOrNonterminal t n] -> ShowS
TerminalOrNonterminal t n -> String
(Int -> TerminalOrNonterminal t n -> ShowS)
-> (TerminalOrNonterminal t n -> String)
-> ([TerminalOrNonterminal t n] -> ShowS)
-> Show (TerminalOrNonterminal t n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t n.
(Show t, Show n) =>
Int -> TerminalOrNonterminal t n -> ShowS
forall t n.
(Show t, Show n) =>
[TerminalOrNonterminal t n] -> ShowS
forall t n. (Show t, Show n) => TerminalOrNonterminal t n -> String
$cshowsPrec :: forall t n.
(Show t, Show n) =>
Int -> TerminalOrNonterminal t n -> ShowS
showsPrec :: Int -> TerminalOrNonterminal t n -> ShowS
$cshow :: forall t n. (Show t, Show n) => TerminalOrNonterminal t n -> String
show :: TerminalOrNonterminal t n -> String
$cshowList :: forall t n.
(Show t, Show n) =>
[TerminalOrNonterminal t n] -> ShowS
showList :: [TerminalOrNonterminal t n] -> ShowS
Show)

-- We always create values of this type using "toGrammar", thus we enforce that all RHS nonterminals appear in LHS
-- It is okey to have nonterminals (i. e. nonterminals present in LHS) without productions
-- Order of productions for single nonterminal is not important. But I use list anyway, not multiset
newtype Grammar t n = Grammar (Data.Map.Map n [[TerminalOrNonterminal t n]]) deriving (Grammar t n -> Grammar t n -> Bool
(Grammar t n -> Grammar t n -> Bool)
-> (Grammar t n -> Grammar t n -> Bool) -> Eq (Grammar t n)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t n. (Eq n, Eq t) => Grammar t n -> Grammar t n -> Bool
$c== :: forall t n. (Eq n, Eq t) => Grammar t n -> Grammar t n -> Bool
== :: Grammar t n -> Grammar t n -> Bool
$c/= :: forall t n. (Eq n, Eq t) => Grammar t n -> Grammar t n -> Bool
/= :: Grammar t n -> Grammar t n -> Bool
Eq, Eq (Grammar t n)
Eq (Grammar t n) =>
(Grammar t n -> Grammar t n -> Ordering)
-> (Grammar t n -> Grammar t n -> Bool)
-> (Grammar t n -> Grammar t n -> Bool)
-> (Grammar t n -> Grammar t n -> Bool)
-> (Grammar t n -> Grammar t n -> Bool)
-> (Grammar t n -> Grammar t n -> Grammar t n)
-> (Grammar t n -> Grammar t n -> Grammar t n)
-> Ord (Grammar t n)
Grammar t n -> Grammar t n -> Bool
Grammar t n -> Grammar t n -> Ordering
Grammar t n -> Grammar t n -> Grammar t n
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t n. (Ord n, Ord t) => Eq (Grammar t n)
forall t n. (Ord n, Ord t) => Grammar t n -> Grammar t n -> Bool
forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Ordering
forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Grammar t n
$ccompare :: forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Ordering
compare :: Grammar t n -> Grammar t n -> Ordering
$c< :: forall t n. (Ord n, Ord t) => Grammar t n -> Grammar t n -> Bool
< :: Grammar t n -> Grammar t n -> Bool
$c<= :: forall t n. (Ord n, Ord t) => Grammar t n -> Grammar t n -> Bool
<= :: Grammar t n -> Grammar t n -> Bool
$c> :: forall t n. (Ord n, Ord t) => Grammar t n -> Grammar t n -> Bool
> :: Grammar t n -> Grammar t n -> Bool
$c>= :: forall t n. (Ord n, Ord t) => Grammar t n -> Grammar t n -> Bool
>= :: Grammar t n -> Grammar t n -> Bool
$cmax :: forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Grammar t n
max :: Grammar t n -> Grammar t n -> Grammar t n
$cmin :: forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Grammar t n
min :: Grammar t n -> Grammar t n -> Grammar t n
Ord, Int -> Grammar t n -> ShowS
[Grammar t n] -> ShowS
Grammar t n -> String
(Int -> Grammar t n -> ShowS)
-> (Grammar t n -> String)
-> ([Grammar t n] -> ShowS)
-> Show (Grammar t n)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t n. (Show n, Show t) => Int -> Grammar t n -> ShowS
forall t n. (Show n, Show t) => [Grammar t n] -> ShowS
forall t n. (Show n, Show t) => Grammar t n -> String
$cshowsPrec :: forall t n. (Show n, Show t) => Int -> Grammar t n -> ShowS
showsPrec :: Int -> Grammar t n -> ShowS
$cshow :: forall t n. (Show n, Show t) => Grammar t n -> String
show :: Grammar t n -> String
$cshowList :: forall t n. (Show n, Show t) => [Grammar t n] -> ShowS
showList :: [Grammar t n] -> ShowS
Show)

toGrammar :: (Ord n) => Data.Map.Map n [[TerminalOrNonterminal t n]] -> Maybe (Grammar t n)
toGrammar :: forall n t.
Ord n =>
Map n [[TerminalOrNonterminal t n]] -> Maybe (Grammar t n)
toGrammar Map n [[TerminalOrNonterminal t n]]
g = if ([[TerminalOrNonterminal t n]] -> Bool)
-> Map n [[TerminalOrNonterminal t n]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[[TerminalOrNonterminal t n]]
prods -> ([TerminalOrNonterminal t n] -> Bool)
-> [[TerminalOrNonterminal t n]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[TerminalOrNonterminal t n]
prod -> (TerminalOrNonterminal t n -> Bool)
-> [TerminalOrNonterminal t n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case {
  T t
_ -> Bool
True;
  N n
nn -> n -> Map n [[TerminalOrNonterminal t n]] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Data.Map.member n
nn Map n [[TerminalOrNonterminal t n]]
g;
}) [TerminalOrNonterminal t n]
prod) [[TerminalOrNonterminal t n]]
prods) Map n [[TerminalOrNonterminal t n]]
g
  then Grammar t n -> Maybe (Grammar t n)
forall a. a -> Maybe a
Just (Map n [[TerminalOrNonterminal t n]] -> Grammar t n
forall t n. Map n [[TerminalOrNonterminal t n]] -> Grammar t n
Grammar Map n [[TerminalOrNonterminal t n]]
g)
  else Maybe (Grammar t n)
forall a. Maybe a
Nothing

{- $setup
>>> :set -XHaskell2010
>>> :set -XScopedTypeVariables
>>> import Test.QuickCheck((===))
>>> import Data.Maybe(isJust, isNothing)
>>> import Data.List(groupBy, sortBy)
>>> :{
conv2 g = let {
  nts = map fst g;
  g2 = g <&> \(nn, prod) -> (nn, prod <&> \symb -> if elem symb nts then N symb else T symb);
  g3 = sortBy (\(a, _) (b, _) -> compare a b) g2;
  g4 = groupBy (\(a, _) (b, _) -> a == b) g3 <&> \gr -> (fst $ (gr !! 0), map snd gr); -- "gr !! 0" instead of "head gr" to silence ghc warnings
} in Data.Map.fromList g4
conv g = fromJust $ toGrammar $ conv2 g -- We know that fromJust will not fail
:}
-}

-- $
-- prop> isJust $ toGrammar $ Data.Map.fromList [("a", [[N "b"]]), ("b", [[N "a"]])]
-- prop> isJust $ toGrammar $ Data.Map.fromList [("a", [[N "b"]]), ("b", [[]])]
-- prop> isJust $ toGrammar $ Data.Map.fromList [("a", [[N "b"]]), ("b", [])]
-- prop> isNothing $ toGrammar $ Data.Map.fromList [("a", [[N "b"]]), ("b", [[N "c", N "a"]])]

{- $
>>> :{
conv [
  ("term", ["id"]),
  ("prod", ["term"]),
  ("term", ["(", "prod", ")"]),
  ("prod", ["prod", "*", "term"])
] == (Grammar $ Data.Map.fromList [
  ("prod", [
    [N "term"],
    [N "prod", T "*", N "term"]
  ]),
  ("term", [
    [T "id"],
    [T "(", N "prod", T ")"]
  ])
])
:}
True
-}

while :: (Monad m) => m Bool -> m ()
while :: forall (m :: * -> *). Monad m => m Bool -> m ()
while m Bool
body = do {
  Bool
continue <- m Bool
body;
  if Bool
continue
    then m Bool -> m ()
forall (m :: * -> *). Monad m => m Bool -> m ()
while m Bool
body
    else () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ();
}

data LowLevelTestAmbiguityResult = LLNoStart | LLAmbiguous | LLUnambiguous deriving (LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
(LowLevelTestAmbiguityResult
 -> LowLevelTestAmbiguityResult -> Bool)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> Bool)
-> Eq LowLevelTestAmbiguityResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
== :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c/= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
/= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
Eq, Eq LowLevelTestAmbiguityResult
Eq LowLevelTestAmbiguityResult =>
(LowLevelTestAmbiguityResult
 -> LowLevelTestAmbiguityResult -> Ordering)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> Bool)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> Bool)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> Bool)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> Bool)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult)
-> (LowLevelTestAmbiguityResult
    -> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult)
-> Ord LowLevelTestAmbiguityResult
LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> Ordering
LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> Ordering
compare :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> Ordering
$c< :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
< :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c<= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
<= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c> :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
> :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c>= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
>= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$cmax :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
max :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
$cmin :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
min :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
Ord, Int -> LowLevelTestAmbiguityResult -> ShowS
[LowLevelTestAmbiguityResult] -> ShowS
LowLevelTestAmbiguityResult -> String
(Int -> LowLevelTestAmbiguityResult -> ShowS)
-> (LowLevelTestAmbiguityResult -> String)
-> ([LowLevelTestAmbiguityResult] -> ShowS)
-> Show LowLevelTestAmbiguityResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LowLevelTestAmbiguityResult -> ShowS
showsPrec :: Int -> LowLevelTestAmbiguityResult -> ShowS
$cshow :: LowLevelTestAmbiguityResult -> String
show :: LowLevelTestAmbiguityResult -> String
$cshowList :: [LowLevelTestAmbiguityResult] -> ShowS
showList :: [LowLevelTestAmbiguityResult] -> ShowS
Show)

-- Precondition: every nonterminal, reachable from start, should generate nonempty language
-- Precondition: count >= 1
lowLevelTestAmbiguity :: (Ord n, Ord t) => Grammar t n -> n -> Int -> LowLevelTestAmbiguityResult
lowLevelTestAmbiguity :: forall n t.
(Ord n, Ord t) =>
Grammar t n -> n -> Int -> LowLevelTestAmbiguityResult
lowLevelTestAmbiguity (Grammar Map n [[TerminalOrNonterminal t n]]
g) n
start Int
count = case n -> Map n [[TerminalOrNonterminal t n]] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Data.Map.member n
start Map n [[TerminalOrNonterminal t n]]
g of {
  Bool
False -> LowLevelTestAmbiguityResult
LLNoStart;
  Bool
True -> (forall s. ST s LowLevelTestAmbiguityResult)
-> LowLevelTestAmbiguityResult
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s LowLevelTestAmbiguityResult)
 -> LowLevelTestAmbiguityResult)
-> (forall s. ST s LowLevelTestAmbiguityResult)
-> LowLevelTestAmbiguityResult
forall a b. (a -> b) -> a -> b
$ do {
    STRef s (Set [TerminalOrNonterminal t n])
allWords <- Set [TerminalOrNonterminal t n]
-> ST s (STRef s (Set [TerminalOrNonterminal t n]))
forall a s. a -> ST s (STRef s a)
newSTRef (Set [TerminalOrNonterminal t n]
 -> ST s (STRef s (Set [TerminalOrNonterminal t n])))
-> Set [TerminalOrNonterminal t n]
-> ST s (STRef s (Set [TerminalOrNonterminal t n]))
forall a b. (a -> b) -> a -> b
$ [TerminalOrNonterminal t n] -> Set [TerminalOrNonterminal t n]
forall a. a -> Set a
Data.Set.singleton [n -> TerminalOrNonterminal t n
forall t n. n -> TerminalOrNonterminal t n
N n
start];
    STRef s [[TerminalOrNonterminal t n]]
currWords <- [[TerminalOrNonterminal t n]]
-> ST s (STRef s [[TerminalOrNonterminal t n]])
forall a s. a -> ST s (STRef s a)
newSTRef [[n -> TerminalOrNonterminal t n
forall t n. n -> TerminalOrNonterminal t n
N n
start]];
    STRef s Int
i <- Int -> ST s (STRef s Int)
forall a s. a -> ST s (STRef s a)
newSTRef Int
0;
    STRef s Bool
collision <- Bool -> ST s (STRef s Bool)
forall a s. a -> ST s (STRef s a)
newSTRef Bool
False;
    ST s Bool -> ST s ()
forall (m :: * -> *). Monad m => m Bool -> m ()
while (ST s Bool -> ST s ()) -> ST s Bool -> ST s ()
forall a b. (a -> b) -> a -> b
$ do {
      do {
        [[TerminalOrNonterminal t n]]
currWordsV <- STRef s [[TerminalOrNonterminal t n]]
-> ST s [[TerminalOrNonterminal t n]]
forall s a. STRef s a -> ST s a
readSTRef STRef s [[TerminalOrNonterminal t n]]
currWords;
        STRef s [[TerminalOrNonterminal t n]]
-> [[TerminalOrNonterminal t n]] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [[TerminalOrNonterminal t n]]
currWords ([[TerminalOrNonterminal t n]] -> ST s ())
-> [[TerminalOrNonterminal t n]] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [[[TerminalOrNonterminal t n]]] -> [[TerminalOrNonterminal t n]]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[[TerminalOrNonterminal t n]]] -> [[TerminalOrNonterminal t n]])
-> [[[TerminalOrNonterminal t n]]] -> [[TerminalOrNonterminal t n]]
forall a b. (a -> b) -> a -> b
$ [[TerminalOrNonterminal t n]]
currWordsV [[TerminalOrNonterminal t n]]
-> ([TerminalOrNonterminal t n] -> [[TerminalOrNonterminal t n]])
-> [[[TerminalOrNonterminal t n]]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[TerminalOrNonterminal t n]
word -> let {
          ([TerminalOrNonterminal t n]
before, [TerminalOrNonterminal t n]
after) = (TerminalOrNonterminal t n -> Bool)
-> [TerminalOrNonterminal t n]
-> ([TerminalOrNonterminal t n], [TerminalOrNonterminal t n])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (\case { N n
_ -> Bool
True; T t
_ -> Bool
False; }) [TerminalOrNonterminal t n]
word;
        } in case [TerminalOrNonterminal t n]
after of {
          [] -> [];
          (N n
nn):[TerminalOrNonterminal t n]
rest -> (Maybe [[TerminalOrNonterminal t n]]
-> [[TerminalOrNonterminal t n]]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [[TerminalOrNonterminal t n]]
 -> [[TerminalOrNonterminal t n]])
-> Maybe [[TerminalOrNonterminal t n]]
-> [[TerminalOrNonterminal t n]]
forall a b. (a -> b) -> a -> b
$ n
-> Map n [[TerminalOrNonterminal t n]]
-> Maybe [[TerminalOrNonterminal t n]]
forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup n
nn Map n [[TerminalOrNonterminal t n]]
g) [[TerminalOrNonterminal t n]]
-> ([TerminalOrNonterminal t n] -> [TerminalOrNonterminal t n])
-> [[TerminalOrNonterminal t n]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[TerminalOrNonterminal t n]
prod -> [TerminalOrNonterminal t n]
before [TerminalOrNonterminal t n]
-> [TerminalOrNonterminal t n] -> [TerminalOrNonterminal t n]
forall a. [a] -> [a] -> [a]
++ [TerminalOrNonterminal t n]
prod [TerminalOrNonterminal t n]
-> [TerminalOrNonterminal t n] -> [TerminalOrNonterminal t n]
forall a. [a] -> [a] -> [a]
++ [TerminalOrNonterminal t n]
rest;
          [TerminalOrNonterminal t n]
_ -> String -> [[TerminalOrNonterminal t n]]
forall a. HasCallStack => String -> a
error String
"Impossible";
        };
        [[TerminalOrNonterminal t n]]
currWordsV2 <- STRef s [[TerminalOrNonterminal t n]]
-> ST s [[TerminalOrNonterminal t n]]
forall s a. STRef s a -> ST s a
readSTRef STRef s [[TerminalOrNonterminal t n]]
currWords;
        Set [TerminalOrNonterminal t n]
allWordsV <- STRef s (Set [TerminalOrNonterminal t n])
-> ST s (Set [TerminalOrNonterminal t n])
forall s a. STRef s a -> ST s a
readSTRef STRef s (Set [TerminalOrNonterminal t n])
allWords;
        let { allWordsV2 :: Set [TerminalOrNonterminal t n]
allWordsV2 = Set [TerminalOrNonterminal t n]
-> Set [TerminalOrNonterminal t n]
-> Set [TerminalOrNonterminal t n]
forall a. Ord a => Set a -> Set a -> Set a
Data.Set.union Set [TerminalOrNonterminal t n]
allWordsV ([[TerminalOrNonterminal t n]] -> Set [TerminalOrNonterminal t n]
forall a. Ord a => [a] -> Set a
Data.Set.fromList [[TerminalOrNonterminal t n]]
currWordsV2); };
        STRef s (Set [TerminalOrNonterminal t n])
-> Set [TerminalOrNonterminal t n] -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Set [TerminalOrNonterminal t n])
allWords Set [TerminalOrNonterminal t n]
allWordsV2;
        Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Set [TerminalOrNonterminal t n] -> Int
forall a. Set a -> Int
Data.Set.size Set [TerminalOrNonterminal t n]
allWordsV2 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Set [TerminalOrNonterminal t n] -> Int
forall a. Set a -> Int
Data.Set.size Set [TerminalOrNonterminal t n]
allWordsV Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [[TerminalOrNonterminal t n]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[TerminalOrNonterminal t n]]
currWordsV2) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
collision Bool
True;
      };
      Int
iV <- STRef s Int -> ST s Int
forall s a. STRef s a -> ST s a
readSTRef STRef s Int
i;
      STRef s Int -> Int -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
i (Int
iV Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1);
      Bool
collisionV <- STRef s Bool -> ST s Bool
forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
collision;
      Bool -> ST s Bool
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
collisionV Bool -> Bool -> Bool
&& Int
iV Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
count);
    };
    Bool
collisionV <- STRef s Bool -> ST s Bool
forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
collision;
    if Bool
collisionV
      then LowLevelTestAmbiguityResult -> ST s LowLevelTestAmbiguityResult
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return LowLevelTestAmbiguityResult
LLAmbiguous
      else LowLevelTestAmbiguityResult -> ST s LowLevelTestAmbiguityResult
forall a. a -> ST s a
forall (m :: * -> *) a. Monad m => a -> m a
return LowLevelTestAmbiguityResult
LLUnambiguous;
  };
}

{- $
>>> :{
do {
  g :: Grammar String String <- toGrammar $ Data.Map.fromList [("start", [])];
  return $ lowLevelTestAmbiguity g "start" 10;
}
:}
Just LLUnambiguous

>>> :{
do {
  g :: Grammar String String <- toGrammar $ Data.Map.fromList [("start", [[N "a"]]), ("a", [])];
  return $ lowLevelTestAmbiguity g "start" 10;
}
:}
Just LLUnambiguous
-}

-- $
-- prop> lowLevelTestAmbiguity (conv []) "start" 10 === LLNoStart
-- prop> lowLevelTestAmbiguity (conv [("a", [])]) "start" 10 === LLNoStart
-- prop> lowLevelTestAmbiguity (conv [("a", ["a"])]) "a" 10 === LLAmbiguous
-- prop> lowLevelTestAmbiguity (conv [("a", ["b", "a"])]) "a" 10 == LLUnambiguous

-- Checks that all nonterminals generate nonempty languages
ntsProduceNonEmptyLang :: (Ord n) => Grammar t n -> Bool
ntsProduceNonEmptyLang :: forall n t. Ord n => Grammar t n -> Bool
ntsProduceNonEmptyLang (Grammar Map n [[TerminalOrNonterminal t n]]
g) = let {
  g2 :: Map n [[n]]
g2 = Map n [[TerminalOrNonterminal t n]]
g Map n [[TerminalOrNonterminal t n]]
-> ([[TerminalOrNonterminal t n]] -> [[n]]) -> Map n [[n]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[[TerminalOrNonterminal t n]]
prods -> [[TerminalOrNonterminal t n]]
prods [[TerminalOrNonterminal t n]]
-> ([TerminalOrNonterminal t n] -> [n]) -> [[n]]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[TerminalOrNonterminal t n]
prod -> [Maybe n] -> [n]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe n] -> [n]) -> [Maybe n] -> [n]
forall a b. (a -> b) -> a -> b
$ [TerminalOrNonterminal t n]
prod [TerminalOrNonterminal t n]
-> (TerminalOrNonterminal t n -> Maybe n) -> [Maybe n]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\case {
    N n
a -> n -> Maybe n
forall a. a -> Maybe a
Just n
a;
    T t
_ -> Maybe n
forall a. Maybe a
Nothing;
  })));
  rec :: Map k [[k]] -> Bool
rec Map k [[k]]
g3 = case Map k [[k]] -> Bool
forall k a. Map k a -> Bool
Data.Map.null Map k [[k]]
g3 of {
    Bool
True -> Bool
True;
    Bool
False -> case ((k, [[k]]) -> Bool) -> [(k, [[k]])] -> Maybe (k, [[k]])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (([k] -> Bool) -> [[k]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any [k] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([[k]] -> Bool) -> ((k, [[k]]) -> [[k]]) -> (k, [[k]]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (k, [[k]]) -> [[k]]
forall a b. (a, b) -> b
snd) (Map k [[k]] -> [(k, [[k]])]
forall k a. Map k a -> [(k, a)]
Data.Map.toList Map k [[k]]
g3) of {
      Just (k
x, [[k]]
_) -> Map k [[k]] -> Bool
rec (Map k [[k]] -> Bool) -> Map k [[k]] -> Bool
forall a b. (a -> b) -> a -> b
$ ([[k]] -> [[k]]) -> Map k [[k]] -> Map k [[k]]
forall a b. (a -> b) -> Map k a -> Map k b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([k] -> [k]) -> [[k]] -> [[k]]
forall a b. (a -> b) -> [a] -> [b]
map ((k -> Bool) -> [k] -> [k]
forall a. (a -> Bool) -> [a] -> [a]
filter (k -> k -> Bool
forall a. Eq a => a -> a -> Bool
/= k
x))) (k -> Map k [[k]] -> Map k [[k]]
forall k a. Ord k => k -> Map k a -> Map k a
Data.Map.delete k
x Map k [[k]]
g3);
      Maybe (k, [[k]])
Nothing -> Bool
False;
    };
  };
} in Map n [[n]] -> Bool
forall {k}. Ord k => Map k [[k]] -> Bool
rec Map n [[n]]
g2

{- $
>>> ntsProduceNonEmptyLang (conv [] :: Grammar String String)
True
>>> :{
do {
  g <- toGrammar $ Data.Map.fromList [("start", [])];
  return $ ntsProduceNonEmptyLang g;
}
:}
Just False

>>> :{
ntsProduceNonEmptyLang (conv [
  ("start", [])
])
:}
True

>>> :{
ntsProduceNonEmptyLang (conv [
  ("start", ["a"])
])
:}
True

>>> :{
ntsProduceNonEmptyLang (conv [
  ("start", ["a"]),
  ("a", [])
])
:}
True

>>> :{
ntsProduceNonEmptyLang (conv [
  ("start", ["a"]),
  ("a", ["b"])
])
:}
True

>>> :{
ntsProduceNonEmptyLang (conv [
  ("start", ["start"])
])
:}
False

>>> :{
ntsProduceNonEmptyLang (conv [
  ("term", ["id"]),
  ("term", ["(", "prod", ")"]),
  ("prod", ["term"]),
  ("prod", ["prod", "*", "term"])
])
:}
True
-}

data Result
  -- | Count of steps is less than 1
  = WrongCount
  -- | Some nonterminal from RHS is not found in LHS
  | NTNotFound
  -- | Start nonterminal is not found in LHS
  | NoStart
  -- | Some nonterminal generates empty language
  | EmptyLang
  -- | The grammar is 100% ambiguous (i. e. the library was able to find ambiguous string)
  | Ambiguous
  -- | The grammar seems to be unambiguous (i. e. the library was not able to find ambiguous string after specified number of steps)
  | SeemsUnambiguous deriving (Result -> Result -> Bool
(Result -> Result -> Bool)
-> (Result -> Result -> Bool) -> Eq Result
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
/= :: Result -> Result -> Bool
Eq, Eq Result
Eq Result =>
(Result -> Result -> Ordering)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Bool)
-> (Result -> Result -> Result)
-> (Result -> Result -> Result)
-> Ord Result
Result -> Result -> Bool
Result -> Result -> Ordering
Result -> Result -> Result
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Result -> Result -> Ordering
compare :: Result -> Result -> Ordering
$c< :: Result -> Result -> Bool
< :: Result -> Result -> Bool
$c<= :: Result -> Result -> Bool
<= :: Result -> Result -> Bool
$c> :: Result -> Result -> Bool
> :: Result -> Result -> Bool
$c>= :: Result -> Result -> Bool
>= :: Result -> Result -> Bool
$cmax :: Result -> Result -> Result
max :: Result -> Result -> Result
$cmin :: Result -> Result -> Result
min :: Result -> Result -> Result
Ord, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Result -> ShowS
showsPrec :: Int -> Result -> ShowS
$cshow :: Result -> String
show :: Result -> String
$cshowList :: [Result] -> ShowS
showList :: [Result] -> ShowS
Show)

-- |
-- Checks grammar for ambiguity (see example above). Before actual ambiguity checking this function checks that every nonterminal generates nonempty language. If some nonterminal generates empty language, this function reports this and doesn't do actual ambiguity checking
checkAmbiguity :: (Ord n, Ord t) => Data.Map.Map n [[TerminalOrNonterminal t n]] -- ^ Grammar (see example above)
 -> n -- ^ Start nonterminal
 -> Int -- ^ Count of steps. I don't try to document precise meaning of this argument
 -> Result
checkAmbiguity :: forall n t.
(Ord n, Ord t) =>
Map n [[TerminalOrNonterminal t n]] -> n -> Int -> Result
checkAmbiguity Map n [[TerminalOrNonterminal t n]]
g n
start Int
count = case Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 of {
  Bool
False -> Result
WrongCount;
  Bool
True -> case Map n [[TerminalOrNonterminal t n]] -> Maybe (Grammar t n)
forall n t.
Ord n =>
Map n [[TerminalOrNonterminal t n]] -> Maybe (Grammar t n)
toGrammar Map n [[TerminalOrNonterminal t n]]
g of {
    Maybe (Grammar t n)
Nothing -> Result
NTNotFound;
    Just Grammar t n
gg -> case n -> Map n [[TerminalOrNonterminal t n]] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Data.Map.member n
start Map n [[TerminalOrNonterminal t n]]
g of {
      Bool
False -> Result
NoStart;
      Bool
True -> case Grammar t n -> Bool
forall n t. Ord n => Grammar t n -> Bool
ntsProduceNonEmptyLang Grammar t n
gg of {
        Bool
False -> Result
EmptyLang;
        Bool
True -> case Grammar t n -> n -> Int -> LowLevelTestAmbiguityResult
forall n t.
(Ord n, Ord t) =>
Grammar t n -> n -> Int -> LowLevelTestAmbiguityResult
lowLevelTestAmbiguity Grammar t n
gg n
start Int
count of {
          LowLevelTestAmbiguityResult
LLNoStart -> String -> Result
forall a. HasCallStack => String -> a
error String
"Impossible";
          LowLevelTestAmbiguityResult
LLAmbiguous -> Result
Ambiguous;
          LowLevelTestAmbiguityResult
LLUnambiguous -> Result
SeemsUnambiguous;
        };
      };
    };
  };
}

{- $
>>> checkAmbiguity (conv2 [("start", [])]) "start" 1
SeemsUnambiguous

>>> checkAmbiguity (conv2 [("start", [])]) "start" 0
WrongCount

>>> checkAmbiguity (conv2 [("start", [])]) "start" (-1)
WrongCount

>>> checkAmbiguity (Data.Map.fromList [("start", [[N "a"]])]) "start" 10
NTNotFound

>>> :{
let {
  g :: Data.Map.Map String [[TerminalOrNonterminal String String]] = Data.Map.fromList [("start", [])];
} in checkAmbiguity g "start" 10
:}
EmptyLang

>>> :{
let {
  g :: Data.Map.Map String [[TerminalOrNonterminal String String]] = Data.Map.fromList [("start", [[N "a"]]), ("a", [])];
} in checkAmbiguity g "start" 10
:}
EmptyLang

>>> checkAmbiguity (conv2 []) "start" 10
NoStart

>>> checkAmbiguity (conv2 [("a", [])]) "start" 10
NoStart

>>> checkAmbiguity (conv2 [("a", [])]) "a" 10
SeemsUnambiguous

>>> checkAmbiguity (conv2 [("a", ["b"])]) "a" 10
SeemsUnambiguous

>>> :{
checkAmbiguity (conv2 [
  ("a", ["b"]),
  ("a", ["c"])
]) "a" 10
:}
SeemsUnambiguous

>>> checkAmbiguity (conv2 [("a", ["a"])]) "a" 10
EmptyLang

>>> :{
checkAmbiguity (conv2 [
  ("a", ["a"]),
  ("a", ["b"])
]) "a" 10
:}
Ambiguous

>>> checkAmbiguity (conv2 [("a", ["b", "a"])]) "a" 10
EmptyLang

>>> :{
checkAmbiguity (conv2 [
  ("a", ["b"]),
  ("a", ["b"])
]) "a" 10
:}
Ambiguous

>>> :{
checkAmbiguity (conv2 [
  ("a", []),
  ("a", ["(", "a", ")", "a"])
]) "a" 10
:}
SeemsUnambiguous

>>> :{
checkAmbiguity (conv2 [
  ("a", []),
  ("a", ["(", "a", ")"]),
  ("a", ["a", "a"])
]) "a" 10
:}
Ambiguous

>>> :{
checkAmbiguity (conv2 [
  ("term", ["id"]),
  ("term", ["(", "prod", ")"]),
  ("prod", ["term"]),
  ("prod", ["prod", "*", "term"])
]) "prod" 10
:}
SeemsUnambiguous

>>> :{
checkAmbiguity (conv2 [
  ("start", ["a"]),
  ("start", ["b"]),
  ("a", ["x"]),
  ("b", ["x"])
]) "start" 10
:}
Ambiguous

>>> :{
checkAmbiguity (conv2 [
  ("start", ["a1"]),
  ("start", ["b"]),
  ("a1", ["a2"]),
  ("a2", ["x"]),
  ("b", ["x"])
]) "start" 10
:}
Ambiguous

>>> :{
checkAmbiguity (conv2 [
  ("t1000", ["id"]),
  ("t1000", ["(", "t0", ")"]),
  ("t999", ["t999", "t1000"]),
  ("t3", ["t4", "::", "t3"]),
  ("t3", ["%", "id", "::", "t0", ".", "t3"]),
  ("t0", ["!!", "id", "::", "t0", ".", "t0"]),
  ("t1", ["t2", "==>", "t1"]),
  ("t0", ["t1"]),
  ("t1", ["t2"]),
  ("t2", ["t3"]),
  ("t3", ["t4"]),
  ("t4", ["t999"]),
  ("t999", ["t1000"])
]) "t0" 15
:}
SeemsUnambiguous

>>> :{
checkAmbiguity (conv2 [
  ("t1000", ["id"]),
  ("t1000", ["(", "t0", ")"]),
  ("t999", ["t999", "t1000"]),
  ("t3", ["t4", "::", "t0"]),
  ("t3", ["%", "id", "::", "t0", ".", "t3"]),
  ("t0", ["!!", "id", "::", "t0", ".", "t0"]),
  ("t1", ["t2", "==>", "t1"]),
  ("t0", ["t1"]),
  ("t1", ["t2"]),
  ("t2", ["t3"]),
  ("t3", ["t4"]),
  ("t4", ["t999"]),
  ("t999", ["t1000"])
]) "t0" 15
:}
Ambiguous
-}

{- $Earley
The following two grammars are from https://github.com/ollef/Earley/issues/54

>>> checkAmbiguity (Data.Map.fromList [("r1", [[T "A"], [N "r1"]])]) "r1" 10
Ambiguous

>>> checkAmbiguity (Data.Map.fromList [("r1", [[N "r1"], [T "A"]])]) "r1" 10
Ambiguous
-}