-- <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.Foldable(for_)
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall t n.
(Eq t, Eq n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
Eq, TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
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
min :: 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
max :: TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
$cmax :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n
-> TerminalOrNonterminal t n -> TerminalOrNonterminal t n
>= :: 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
$c< :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Bool
compare :: TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
$ccompare :: forall t n.
(Ord t, Ord n) =>
TerminalOrNonterminal t n -> TerminalOrNonterminal t n -> Ordering
Ord, Int -> TerminalOrNonterminal t n -> ShowS
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
showList :: [TerminalOrNonterminal t n] -> ShowS
$cshowList :: forall t n.
(Show t, Show n) =>
[TerminalOrNonterminal t n] -> ShowS
show :: TerminalOrNonterminal t n -> String
$cshow :: forall t n. (Show t, Show n) => TerminalOrNonterminal t n -> String
showsPrec :: Int -> TerminalOrNonterminal t n -> ShowS
$cshowsPrec :: forall t n.
(Show t, Show n) =>
Int -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
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
$c== :: forall t n. (Eq n, Eq t) => Grammar t n -> Grammar t n -> Bool
Eq, 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
min :: 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
max :: Grammar t n -> Grammar t n -> Grammar t n
$cmax :: forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Grammar t n
>= :: 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
$c< :: forall t n. (Ord n, Ord t) => Grammar t n -> Grammar t n -> Bool
compare :: Grammar t n -> Grammar t n -> Ordering
$ccompare :: forall t n.
(Ord n, Ord t) =>
Grammar t n -> Grammar t n -> Ordering
Ord, Int -> Grammar t n -> ShowS
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
showList :: [Grammar t n] -> ShowS
$cshowList :: forall t n. (Show n, Show t) => [Grammar t n] -> ShowS
show :: Grammar t n -> String
$cshow :: forall t n. (Show n, Show t) => Grammar t n -> String
showsPrec :: Int -> Grammar t n -> ShowS
$cshowsPrec :: forall t n. (Show n, Show t) => Int -> 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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[[TerminalOrNonterminal t n]]
prods -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\[TerminalOrNonterminal t n]
prod -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\case {
  T t
_ -> Bool
True;
  N n
nn -> 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 forall a. a -> Maybe a
Just (forall t n. Map n [[TerminalOrNonterminal t n]] -> Grammar t n
Grammar Map n [[TerminalOrNonterminal t n]]
g)
  else 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 $ head gr, map snd gr);
} 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 forall (m :: * -> *). Monad m => m Bool -> m ()
while m Bool
body
    else forall (m :: * -> *) a. Monad m => a -> m a
return ();
}

data LowLevelTestAmbiguityResult = LLNoStart | LLAmbiguous | LLUnambiguous deriving (LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c/= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
== :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c== :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
Eq, Eq 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
min :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
$cmin :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
max :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
$cmax :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult
>= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$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
compare :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> Ordering
$ccompare :: LowLevelTestAmbiguityResult
-> LowLevelTestAmbiguityResult -> Ordering
Ord, Int -> LowLevelTestAmbiguityResult -> ShowS
[LowLevelTestAmbiguityResult] -> ShowS
LowLevelTestAmbiguityResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LowLevelTestAmbiguityResult] -> ShowS
$cshowList :: [LowLevelTestAmbiguityResult] -> ShowS
show :: LowLevelTestAmbiguityResult -> String
$cshow :: LowLevelTestAmbiguityResult -> String
showsPrec :: Int -> LowLevelTestAmbiguityResult -> ShowS
$cshowsPrec :: Int -> 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 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 a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do {
    STRef s (Set [TerminalOrNonterminal t n])
allWords <- forall a s. a -> ST s (STRef s a)
newSTRef forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Data.Set.singleton [forall t n. n -> TerminalOrNonterminal t n
N n
start];
    STRef s [[TerminalOrNonterminal t n]]
currWords <- forall a s. a -> ST s (STRef s a)
newSTRef [[forall t n. n -> TerminalOrNonterminal t n
N n
start]];
    STRef s Int
i <- forall a s. a -> ST s (STRef s a)
newSTRef Int
0;
    STRef s Bool
collision <- forall a s. a -> ST s (STRef s a)
newSTRef Bool
False;
    forall (m :: * -> *). Monad m => m Bool -> m ()
while forall a b. (a -> b) -> a -> b
$ do {
      do {
        [[TerminalOrNonterminal t n]]
currWordsV <- forall s a. STRef s a -> ST s a
readSTRef STRef s [[TerminalOrNonterminal t n]]
currWords;
        forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s [[TerminalOrNonterminal t n]]
currWords forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ [[TerminalOrNonterminal t n]]
currWordsV 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) = 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 -> (forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup n
nn Map n [[TerminalOrNonterminal t n]]
g) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \[TerminalOrNonterminal t n]
prod -> [TerminalOrNonterminal t n]
before forall a. [a] -> [a] -> [a]
++ [TerminalOrNonterminal t n]
prod forall a. [a] -> [a] -> [a]
++ [TerminalOrNonterminal t n]
rest;
          [TerminalOrNonterminal t n]
_ -> forall a. HasCallStack => String -> a
error String
"Impossible";
        };
        [[TerminalOrNonterminal t n]]
currWordsV2 <- forall s a. STRef s a -> ST s a
readSTRef STRef s [[TerminalOrNonterminal t n]]
currWords;
        Set [TerminalOrNonterminal t n]
allWordsV <- forall s a. STRef s a -> ST s a
readSTRef STRef s (Set [TerminalOrNonterminal t n])
allWords;
        let { allWordsV2 :: Set [TerminalOrNonterminal t n]
allWordsV2 = forall a. Ord a => Set a -> Set a -> Set a
Data.Set.union Set [TerminalOrNonterminal t n]
allWordsV (forall a. Ord a => [a] -> Set a
Data.Set.fromList [[TerminalOrNonterminal t n]]
currWordsV2); };
        forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s (Set [TerminalOrNonterminal t n])
allWords Set [TerminalOrNonterminal t n]
allWordsV2;
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Set a -> Int
Data.Set.size Set [TerminalOrNonterminal t n]
allWordsV2 forall a. Eq a => a -> a -> Bool
/= forall a. Set a -> Int
Data.Set.size Set [TerminalOrNonterminal t n]
allWordsV forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length [[TerminalOrNonterminal t n]]
currWordsV2) forall a b. (a -> b) -> a -> b
$ forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
collision Bool
True;
      };
      Int
iV <- forall s a. STRef s a -> ST s a
readSTRef STRef s Int
i;
      forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Int
i (Int
iV forall a. Num a => a -> a -> a
+ Int
1);
      Bool
collisionV <- forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
collision;
      forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Bool
not Bool
collisionV Bool -> Bool -> Bool
&& Int
iV forall a. Num a => a -> a -> a
+ Int
1 forall a. Ord a => a -> a -> Bool
< Int
count);
    };
    Bool
collisionV <- forall s a. STRef s a -> ST s a
readSTRef STRef s Bool
collision;
    if Bool
collisionV
      then forall (m :: * -> *) a. Monad m => a -> m a
return LowLevelTestAmbiguityResult
LLAmbiguous
      else 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 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[[TerminalOrNonterminal t n]]
prods -> [[TerminalOrNonterminal t n]]
prods forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\[TerminalOrNonterminal t n]
prod -> forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ [TerminalOrNonterminal t n]
prod forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\case {
    N n
a -> forall a. a -> Maybe a
Just n
a;
    T t
_ -> forall a. Maybe a
Nothing;
  })));
  rec :: Map k [[k]] -> Bool
rec Map k [[k]]
g3 = case forall k a. Map k a -> Bool
Data.Map.null Map k [[k]]
g3 of {
    Bool
True -> Bool
True;
    Bool
False -> case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (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 forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= k
x))) (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 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: Result -> Result -> Bool
Eq, Eq 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
min :: Result -> Result -> Result
$cmin :: Result -> Result -> Result
max :: Result -> Result -> Result
$cmax :: Result -> Result -> Result
>= :: Result -> Result -> Bool
$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
compare :: Result -> Result -> Ordering
$ccompare :: Result -> Result -> Ordering
Ord, Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> 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 forall a. Ord a => a -> a -> Bool
>= Int
1 of {
  Bool
False -> Result
WrongCount;
  Bool
True -> case 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 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 forall n t. Ord n => Grammar t n -> Bool
ntsProduceNonEmptyLang Grammar t n
gg of {
        Bool
False -> Result
EmptyLang;
        Bool
True -> case 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 -> 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
-}