{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeSynonymInstances #-}
module Main where
import Text.ANTLR.Example.Grammar
import Text.ANTLR.Grammar
import Text.ANTLR.LR
import Text.ANTLR.Parser
import qualified Data.Text as T
import qualified Text.ANTLR.Lex.Tokenizer as T
import Text.ANTLR.Set (fromList, union, empty, Set(..), (\\), Hashable(..), Generic(..))
import qualified Text.ANTLR.Set as S
import qualified Text.ANTLR.MultiMap as M
import System.IO.Unsafe (unsafePerformIO)
import Data.Monoid
import Test.Framework
import Test.Framework.Providers.HUnit
import Test.Framework.Providers.QuickCheck2
import Test.HUnit hiding ((@?=), assertEqual)
import Test.QuickCheck
--import Test.QuickCheck ( Property, quickCheck, (==>)
-- , elements, Arbitrary(..)
-- )
import qualified Test.QuickCheck.Monadic as TQM
import Text.ANTLR.HUnit
import Text.ANTLR.Pretty (pshow)
import qualified Debug.Trace as D
uPIO = unsafePerformIO
grm = dragonBook41
slrItem x y z = Item x y z ()
testClosure =
slrClosure grm (S.singleton $ slrItem (Init "E") [] [NT "E"])
@?=
fromList
[ slrItem (Init "E") [] [NT "E"]
, slrItem (ItemNT "E") [] [NT "E", T "+", NT "T"]
, slrItem (ItemNT "E") [] [NT "T"]
, slrItem (ItemNT "T") [] [NT "T", T "*", NT "F"]
, slrItem (ItemNT "T") [] [NT "F"]
, slrItem (ItemNT "F") [] [T "(", NT "E", T ")"]
, slrItem (ItemNT "F") [] [T "id"]
]
testKernel =
kernel (slrClosure grm (S.singleton $ slrItem (Init "E") [] [NT "E"]))
@?=
fromList
[ slrItem (Init "E") [] [NT "E"] ]
type LR1Terminal = String
type LR1NonTerminal = String
newtype Item' = I' (Item () String String)
deriving (Eq, Show, Generic, Hashable)
instance Arbitrary Item' where
arbitrary = (elements . map I' . S.toList . allSLRItems) grm
instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (Set a) where
arbitrary = fmap S.fromList arbitrary
shrink = map S.fromList . shrink . S.toList
c' = slrClosure grm
propClosureClosure :: Set Item' -> Property
propClosureClosure items' = let items = S.map (\(I' is) -> is) items' in True ==>
(c' . c') items == c' items
newtype Grammar' = G' (Grammar () String String)
deriving (Eq, Show)
instance Arbitrary Grammar' where
arbitrary = return $ G' grm
{-
arbitrary = do
(uPIO $ print "damnit") `seq` return ()
i <- elements [1..10]
j <- elements [1..10]
ns' <- infiniteList :: Gen [NonTerminal]
ts' <- infiniteList :: Gen [Terminal]
let ns = take i ns'
let ts = take j ts'
s0 <- elements ns
let g = defaultGrammar {ns = fromList ns, ts = fromList ts, s0 = s0}
let prod = do
lhs <- elements ns
rhs <- listOf (elements $ S.toList $ symbols g)
return (lhs, Prod rhs)
ps <- suchThat (listOf1 prod) (\ps -> validGrammar $ g { ps = ps })
(uPIO $ print $ G' $ g { ps = ps }) `seq` return ()
return $ G' $ g { ps = ps }
-}
closedItems :: Grammar' -> Property
closedItems (G' g) = True ==> null (S.foldr union empty (slrItems g) \\ allSLRItems g)
closedItems0 =
S.foldr union empty (slrItems grm) \\ allSLRItems grm
@?=
empty
testItems =
slrItems grm
@?=
fromList [_I0, _I1, _I2, _I3, _I4, _I5, _I6, _I7, _I8, _I9, _I10, _I11]
_I0 = fromList [ slrItem (Init "E") [] [NT "E"]
, slrItem (ItemNT "E") [] [NT "E",T "+",NT "T"]
, slrItem (ItemNT "E") [] [NT "T"]
, slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]
, slrItem (ItemNT "F") [] [T "id"]
, slrItem (ItemNT "T") [] [NT "F"]
, slrItem (ItemNT "T") [] [NT "T",T "*",NT "F"]]
_I1 = fromList [ slrItem (Init "E") [NT "E"] []
, slrItem (ItemNT "E") [NT "E"] [T "+",NT "T"]]
_I4 = fromList [ slrItem (ItemNT "E") [] [NT "E",T "+",NT "T"]
, slrItem (ItemNT "E") [] [NT "T"]
, slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]
, slrItem (ItemNT "F") [] [T "id"]
, slrItem (ItemNT "F") [T "("] [NT "E",T ")"]
, slrItem (ItemNT "T") [] [NT "F"]
, slrItem (ItemNT "T") [] [NT "T",T "*",NT "F"]]
_I8 = fromList [ slrItem (ItemNT "E") [NT "E"] [T "+",NT "T"]
, slrItem (ItemNT "F") [NT "E",T "("] [T ")"]]
_I2 = fromList [ slrItem (ItemNT "E") [NT "T"] []
, slrItem (ItemNT "T") [NT "T"] [T "*",NT "F"]]
_I9 = fromList [ slrItem (ItemNT "E") [NT "T",T "+",NT "E"] []
, slrItem (ItemNT "T") [NT "T"] [T "*",NT "F"]]
_I6 = fromList [ slrItem (ItemNT "E") [T "+",NT "E"] [NT "T"]
, slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]
, slrItem (ItemNT "F") [] [T "id"]
, slrItem (ItemNT "T") [] [NT "F"]
, slrItem (ItemNT "T") [] [NT "T",T "*",NT "F"]]
_I7 = fromList [ slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]
, slrItem (ItemNT "F") [] [T "id"]
, slrItem (ItemNT "T") [T "*",NT "T"] [NT "F"]]
_I11 = fromList [ slrItem (ItemNT "F") [T ")",NT "E",T "("] []]
_I5 = fromList [ slrItem (ItemNT "F") [T "id"] []]
_I3 = fromList [ slrItem (ItemNT "T") [NT "F"] []]
_I10 = fromList [ slrItem (ItemNT "T") [NT "F",T "*",NT "T"] []]
r1 = Reduce $ Production "E" $ Prod Pass [NT "E", T "+", NT "T"]
r2 = Reduce $ Production "E" $ Prod Pass [NT "T"]
r3 = Reduce $ Production "T" $ Prod Pass [NT "T", T "*", NT "F"]
r4 = Reduce $ Production "T" $ Prod Pass [NT "F"]
r5 = Reduce $ Production "F" $ Prod Pass [T "(", NT "E", T ")"]
r6 = Reduce $ Production "F" $ Prod Pass [T "id"]
-- Easier to debug when shown separately:
testSLRTable =
M.size (slrTable grm
`M.difference`
testSLRExp)
@?=
0
testSLRTable2 =
M.size (testSLRExp
`M.difference`
slrTable grm)
@?=
0
testSLRTable3 =
slrTable grm
@?=
testSLRExp
testSLRExp = M.fromList
[ ((_I0, Icon "id"), Shift _I5)
, ((_I0, Icon "("), Shift _I4)
, ((_I1, Icon "+"), Shift _I6)
, ((_I1, IconEOF), Accept)
, ((_I2, Icon "+"), r2)
, ((_I2, Icon "*"), Shift _I7)
, ((_I2, Icon ")"), r2)
, ((_I2, IconEOF), r2)
, ((_I3, Icon "+"), r4)
, ((_I3, Icon "*"), r4)
, ((_I3, Icon ")"), r4)
, ((_I3, IconEOF), r4)
, ((_I4, Icon "id"), Shift _I5)
, ((_I4, Icon "("), Shift _I4)
, ((_I5, Icon "+"), r6)
, ((_I5, Icon "*"), r6)
, ((_I5, Icon ")"), r6)
, ((_I5, IconEOF), r6)
, ((_I6, Icon "id"), Shift _I5)
, ((_I6, Icon "("), Shift _I4)
, ((_I7, Icon "id"), Shift _I5)
, ((_I7, Icon "("), Shift _I4)
, ((_I8, Icon "+"), Shift _I6)
, ((_I8, Icon ")"), Shift _I11)
, ((_I9, Icon "+"), r1)
, ((_I9, Icon "*"), Shift _I7)
, ((_I9, Icon ")"), r1)
, ((_I9, IconEOF), r1)
, ((_I10, Icon "+"), r3)
, ((_I10, Icon "*"), r3)
, ((_I10, Icon ")"), r3)
, ((_I10, IconEOF), r3)
, ((_I11, Icon "+"), r5)
, ((_I11, Icon "*"), r5)
, ((_I11, Icon ")"), r5)
, ((_I11, IconEOF), r5)
]
testLRRecognize =
slrRecognize grm w0
@?=
True
testLRRecognize2 =
slrRecognize grm ["id", "*", "id", "+", "+", ""]
@?=
False
type LRAST = AST LR1NonTerminal LR1Terminal
action0 :: ParseEvent LRAST LR1NonTerminal LR1Terminal -> LRAST
action0 (TermE "") = LeafEps
action0 (TermE t) = Leaf t
action0 (NonTE (nt, ss, asts)) = AST nt ss asts
testLRParse =
slrParse grm action0 w0
@?=
(ResultAccept $
AST "E" [NT "E", T "+", NT "T"]
[ AST "E" [NT "T"]
[ AST "T" [NT "T", T "*", NT "F"]
[ AST "T" [NT "F"] [AST "F" [T "id"] [Leaf "id"]]
, Leaf "*"
, AST "F" [T "id"] [Leaf "id"]
]
]
, Leaf "+"
, AST "T" [NT "F"] [AST "F" [T "id"] [Leaf "id"]]
])
testLRParse2 =
isError (slrParse grm action0 ["id", "*", "id", "+", "+", "_"])
@?=
True
w0 = ["id", "*", "id", "+", "id", ""]
testLR1Table =
lr1Table dragonBook455
@?=
lr1TableExp
lr1TableExp = M.fromList
[ ((i0, Icon "c"), Shift i3)
, ((i0, Icon "d"), Shift i4)
, ((i1, IconEOF), Accept)
, ((i2, Icon "c"), Shift i6)
, ((i2, Icon "d"), Shift i7)
, ((i3, Icon "c"), Shift i3)
, ((i3, Icon "d"), Shift i4)
, ((i4, Icon "c"), r3')
, ((i4, Icon "d"), r3')
, ((i5, IconEOF), r1')
, ((i6, Icon "c"), Shift i6)
, ((i6, Icon "d"), Shift i7)
, ((i7, IconEOF), r3')
, ((i8, Icon "c"), r2')
, ((i8, Icon "d"), r2')
, ((i9, IconEOF), r2')
]
--r5 = Reduce ("F", Prod Pass [T "(", NT "E", T ")"])
r1' = Reduce $ Production "S" $ Prod Pass [NT "C", NT "C"]
r2' = Reduce $ Production "C" $ Prod Pass [T "c", NT "C"]
r3' = Reduce $ Production "C" $ Prod Pass [T "d"]
testLR1Items =
lr1Items dragonBook455
@?=
fromList [i0,i1,i2,i3,i4,i5,i6,i7,i8,i9]
-- page 262 of soft cover dragon book:
i0 = fromList
[ Item (Init "S") [] [NT "S"] IconEOF
, Item (ItemNT "S") [] [NT "C", NT "C"] IconEOF
, Item (ItemNT "C") [] [T "c", NT "C"] (Icon "c")
, Item (ItemNT "C") [] [T "c", NT "C"] (Icon "d")
, Item (ItemNT "C") [] [T "d"] (Icon "c")
, Item (ItemNT "C") [] [T "d"] (Icon "d")
]
i1 = fromList [ Item (Init "S") [NT "S"] [] IconEOF ]
i2 = fromList
[ Item (ItemNT "S") [NT "C"] [NT "C"] IconEOF
, Item (ItemNT "C") [] [T "c", NT "C"] IconEOF
, Item (ItemNT "C") [] [T "d"] IconEOF
]
i3 = fromList
[ Item (ItemNT "C") [T "c"] [NT "C"] (Icon "c")
, Item (ItemNT "C") [T "c"] [NT "C"] (Icon "d")
, Item (ItemNT "C") [] [T "c", NT "C"] (Icon "c")
, Item (ItemNT "C") [] [T "c", NT "C"] (Icon "d")
, Item (ItemNT "C") [] [T "d"] (Icon "c")
, Item (ItemNT "C") [] [T "d"] (Icon "d")
]
i4 = fromList
[ Item (ItemNT "C") [T "d"] [] (Icon "c")
, Item (ItemNT "C") [T "d"] [] (Icon "d")
]
i5 = fromList [ Item (ItemNT "S") [NT "C", NT "C"] [] IconEOF ]
i6 = fromList
[ Item (ItemNT "C") [T "c"] [NT "C"] IconEOF
, Item (ItemNT "C") [] [T "c", NT "C"] IconEOF
, Item (ItemNT "C") [] [T "d"] IconEOF
]
i7 = fromList [ Item (ItemNT "C") [T "d"] [] IconEOF ]
i8 = fromList
[ Item (ItemNT "C") [NT "C", T "c"] [] (Icon "c")
, Item (ItemNT "C") [NT "C", T "c"] [] (Icon "d")
]
i9 = fromList [ Item (ItemNT "C") [NT "C", T "c"] [] IconEOF ]
getAST (ResultAccept ast) = ast
getAST _ = error "bad parse"
testLR1Parse =
getAST (lr1Parse grm action0 w0)
@?=
getAST (slrParse grm action0 w0)
testPrettify = unsafePerformIO $ putStrLn $ T.unpack $ pshow testSLRExp
testGLRParse =
glrParse grm action0 w0
@?=
(ResultSet $ S.fromList [ ResultAccept (
AST "E" [NT "E",T "+",NT "T"]
[AST "E" [NT "T"]
[AST "T" [NT "T",T "*",NT "F"]
[AST "T" [NT "F"]
[AST "F" [T "id"] [Leaf "id"]]
,Leaf "*"
,AST "F" [T "id"]
[Leaf "id"]]]
,Leaf "+"
,AST "T" [NT "F"]
[AST "F" [T "id"] [Leaf "id"]]])])
main :: IO ()
main = defaultMainWithOpts
[ testCase "closure" testClosure
, testCase "kernel" testKernel
, testProperty "closure-closure" propClosureClosure
, testCase "items" testItems
, testCase "closedItems0" closedItems0
, testProperty "closedItems" closedItems
, testCase "slrTable" testSLRTable
, testCase "slrTable2" testSLRTable2
, testCase "slrTable3" testSLRTable3
, testCase "testLRRecognize" testLRRecognize
, testCase "testLRRecognize2" testLRRecognize2
, testCase "testLRParse" testLRParse
, testCase "testLRParse2" testLRParse2
, testCase "testLR1Parse" testLR1Parse
, testCase "testLR1Items" testLR1Items
, testCase "testLR1Table" testLR1Table
, testCase "testPrettify" (testPrettify @?= ())
, testCase "testGLR" testGLRParse
] mempty