check-cfg-ambiguity (empty) → 0.0.0.1
raw patch · 5 files changed
+465/−0 lines, 5 filesdep +basedep +containers
Dependencies added: base, containers
Files
- ChangeLog +0/−0
- CheckCFGAmbiguity.hs +429/−0
- LICENSE +8/−0
- README +3/−0
- check-cfg-ambiguity.cabal +25/−0
+ ChangeLog view
+ CheckCFGAmbiguity.hs view
@@ -0,0 +1,429 @@+{-# 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+a <&> b = fmap b a++data TerminalOrNonterminal t n = T t | N n deriving (Eq, Ord, 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 (Eq, Ord, Show)++toGrammar :: (Ord n) => Data.Map.Map n [[TerminalOrNonterminal t n]] -> Maybe (Grammar t n)+toGrammar g = if all (\prods -> all (\prod -> all (\case {+ T _ -> True;+ N nn -> Data.Map.member nn g;+}) prod) prods) g+ then Just (Grammar g)+ else 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 body = do {+ continue <- body;+ if continue+ then while body+ else return ();+}++data LowLevelTestAmbiguityResult = LLNoStart | LLAmbiguous | LLUnambiguous deriving (Eq, Ord, 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 g) start count = case Data.Map.member start g of {+ False -> LLNoStart;+ True -> runST $ do {+ allWords <- newSTRef $ Data.Set.singleton [N start];+ currWords <- newSTRef [[N start]];+ i <- newSTRef 0;+ collision <- newSTRef False;+ while $ do {+ do {+ currWordsV <- readSTRef currWords;+ writeSTRef currWords [];+ for_ currWordsV $ \word -> do {+ let { (before, after) = break (\case { N _ -> True; T _ -> False; }) word };+ case after of {+ [] -> return ();+ (N nn):rest -> for_ (fromJust $ Data.Map.lookup nn g) $ \prod -> do {+ let { newWord = before ++ prod ++ rest };+ do {+ allWordsV <- readSTRef allWords;+ if Data.Set.member newWord allWordsV+ then writeSTRef collision True+ else return ();+ writeSTRef allWords $ Data.Set.insert newWord allWordsV;+ };+ currWordsV2 <- readSTRef currWords;+ writeSTRef currWords $ newWord:currWordsV2;+ };+ _ -> error "Impossible";+ };+ };+ };+ iV <- readSTRef i;+ writeSTRef i (iV + 1);+ collisionV <- readSTRef collision;+ return (not collisionV && iV + 1 < count);+ };+ collisionV <- readSTRef collision;+ if collisionV+ then return LLAmbiguous+ else return 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 g) = let {+ g2 = g <&> (\prods -> prods <&> (\prod -> catMaybes $ prod <&> (\case {+ N a -> Just a;+ T _ -> Nothing;+ })));+ rec g3 = case Data.Map.null g3 of {+ True -> True;+ False -> case find (any null . snd) (Data.Map.toList g3) of {+ Just (x, _) -> rec $ fmap (map (filter (/= x))) (Data.Map.delete x g3);+ Nothing -> False;+ };+ };+} in rec 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 (Eq, Ord, 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 g start count = case count >= 1 of {+ False -> WrongCount;+ True -> case toGrammar g of {+ Nothing -> NTNotFound;+ Just gg -> case Data.Map.member start g of {+ False -> NoStart;+ True -> case ntsProduceNonEmptyLang gg of {+ False -> EmptyLang;+ True -> case lowLevelTestAmbiguity gg start count of {+ LLNoStart -> error "Impossible";+ LLAmbiguous -> Ambiguous;+ LLUnambiguous -> 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+-}
+ LICENSE view
@@ -0,0 +1,8 @@+Copyright (c) 2021 check-cfg-ambiguity authors. All rights reserved.++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE
+ README view
@@ -0,0 +1,3 @@+See https://hackage.haskell.org/package/check-cfg-ambiguity++You don't need to be registered on SourceHut to create bug report
+ check-cfg-ambiguity.cabal view
@@ -0,0 +1,25 @@+cabal-version: >= 1.10+name: check-cfg-ambiguity+version: 0.0.0.1+synopsis: Checks context free grammar for ambiguity using brute force up to given limit+description: Checks context free grammar for ambiguity using brute force up to given limit.+ .+ It is impossible to check arbitrary context free grammar for ambiguity on a Turing machine. So we provide you brute force algorithm up to a limit.+ .+ You can also use function "upTo" from package "Earley-0.13.0.1" for the same purpose, but it can freeze on infinitely ambiguous grammars: https://github.com/ollef/Earley/issues/54 . So I decided to write and publish this package.+ .+ You don't need to be registered on SourceHut to create bug report.+license: BSD3+license-file: LICENSE+maintainer: Askar Safin <safinaskar@mail.ru>+category: Parsing+build-type: Simple+extra-source-files: README ChangeLog+source-repository head+ type: git+ location: https://git.sr.ht/~safinaskar/check-cfg-ambiguity+library+ exposed-modules: CheckCFGAmbiguity+ build-depends: base >= 4.9.1 && < 4.17, containers >= 0.5.7 && < 0.7+ default-language: Haskell2010+ ghc-options: -Wall