{-# LANGUAGE Haskell2010 #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}

{- |
(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 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(..)) 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)

-- For package "base" before 4.11.0.0
infixl 1 <&>
(<&>) :: (Functor f) => f a -> (a -> b) -> f b
f a
a <&> :: f a -> (a -> b) -> f b
<&> a -> b
b = (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
b f a
a

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
/= :: 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, 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
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
$cp1Ord :: forall t n. (Ord t, Ord n) => Eq (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
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
data 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
/= :: 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, 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
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
$cp1Ord :: forall t n. (Ord n, Ord t) => Eq (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
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 :: 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

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

{- $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
:}
-}

{- $
>>> :{
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 :: 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 (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
/= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c/= :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
== :: LowLevelTestAmbiguityResult -> LowLevelTestAmbiguityResult -> Bool
$c== :: 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
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
$cp1Ord :: Eq 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
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 :: 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]]
-> ([TerminalOrNonterminal t n] -> ST s ()) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [[TerminalOrNonterminal t n]]
currWordsV (([TerminalOrNonterminal t n] -> ST s ()) -> ST s ())
-> ([TerminalOrNonterminal t n] -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \[TerminalOrNonterminal t n]
word -> do {
          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 };
          case [TerminalOrNonterminal t n]
after of {
            [] -> () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ();
            (N n
nn):[TerminalOrNonterminal t n]
rest -> [[TerminalOrNonterminal t n]]
-> ([TerminalOrNonterminal t n] -> ST s ()) -> ST s ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ (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] -> ST s ()) -> ST s ())
-> ([TerminalOrNonterminal t n] -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \[TerminalOrNonterminal t n]
prod -> do {
              let { newWord :: [TerminalOrNonterminal t n]
newWord = [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 };
              do {
                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;
                if [TerminalOrNonterminal t n]
-> Set [TerminalOrNonterminal t n] -> Bool
forall a. Ord a => a -> Set a -> Bool
Data.Set.member [TerminalOrNonterminal t n]
newWord Set [TerminalOrNonterminal t n]
allWordsV
                  then STRef s Bool -> Bool -> ST s ()
forall s a. STRef s a -> a -> ST s ()
writeSTRef STRef s Bool
collision Bool
True
                  else () -> ST s ()
forall (m :: * -> *) a. Monad m => a -> m a
return ();
                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] -> ST s ())
-> Set [TerminalOrNonterminal t n] -> ST s ()
forall a b. (a -> b) -> a -> b
$ [TerminalOrNonterminal t n]
-> Set [TerminalOrNonterminal t n]
-> Set [TerminalOrNonterminal t n]
forall a. Ord a => a -> Set a -> Set a
Data.Set.insert [TerminalOrNonterminal t n]
newWord Set [TerminalOrNonterminal t n]
allWordsV;
              };
              [[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;
              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]
newWord[TerminalOrNonterminal t n]
-> [[TerminalOrNonterminal t n]] -> [[TerminalOrNonterminal t n]]
forall a. a -> [a] -> [a]
:[[TerminalOrNonterminal t n]]
currWordsV2;
            };
            [TerminalOrNonterminal t n]
_ -> String -> ST s ()
forall a. HasCallStack => String -> a
error String
"Impossible";
          };
        };
      };
      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 (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 (m :: * -> *) a. Monad m => a -> m a
return LowLevelTestAmbiguityResult
LLAmbiguous
      else LowLevelTestAmbiguityResult -> ST s LowLevelTestAmbiguityResult
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 :: 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 (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 (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
/= :: Result -> Result -> Bool
$c/= :: Result -> Result -> Bool
== :: Result -> Result -> Bool
$c== :: 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
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
$cp1Ord :: Eq 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
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 :: 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;
        };
      };
    };
  };
}

{- $
>>> :{
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
-}