diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2016, Xandaros +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. + +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 +OWNER 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/abnf.cabal b/abnf.cabal new file mode 100644 --- /dev/null +++ b/abnf.cabal @@ -0,0 +1,60 @@ +-- Initial abnf.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +name: abnf +version: 0.1.0.0 +synopsis: Parse ABNF and generate parsers for the specified document +description: You can use this library to parse an ABNF document and + generate a parser from that ABNF to read a document + described by the ABNF. +license: BSD2 +license-file: LICENSE +author: Xandaros +maintainer: mz.bremerhaven@gmail.com +-- copyright: +homepage: https://github.com/Xandaros/abnf.git +category: Text +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/Xandaros/abnf.git + +library + exposed-modules: Text.ABNF.Parser, + Text.ABNF.Parser.Types, + Text.ABNF.Canonicalizer, + Text.ABNF.Document, + Text.ABNF.Document.Types, + Text.ABNF.PrettyPrinter + ghc-options: -W + -- other-modules: + -- other-extensions: + build-depends: base >=4.8 && <4.9, + text, + megaparsec, + attoparsec, + containers + hs-source-dirs: src + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: ABNF, + Document + hs-source-dirs: test + build-depends: base >= 4.8 && <4.9, + text, + containers, + test-framework, + test-framework-hunit, + megaparsec, + attoparsec, + HUnit, + tasty, + tasty-hunit, + abnf + default-language: Haskell2010 diff --git a/src/Text/ABNF/Canonicalizer.hs b/src/Text/ABNF/Canonicalizer.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/Canonicalizer.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.ABNF.Canonicalizer (canonicalizeRules) where + +import Data.List (partition) +import Data.Monoid ((<>)) +import qualified Data.Map.Strict as Map +import qualified Data.Text as Text + +import Text.ABNF.Parser.Types + +type RuleMap = Map.Map Identifier Rule + +canonicalizeRules :: Identifier -> [Rule] -> Maybe Rule +canonicalizeRules mainRuleIdent rules = do + let (defs, adds) = partition isAdd rules + ruleMap = foldr (\rule@(Rule ident _ _) curMap -> + Map.insert ident rule curMap) + Map.empty + defs + ruleMap' = foldr (\rule@(Rule ident _ _) curMap -> + Map.insertWith mergeRules ident rule curMap) + ruleMap + adds + mainRule <- Map.lookup mainRuleIdent ruleMap' + pure $ inlineRulesRule ruleMap' mainRule --TODO: Catch missing rules here + where + isAdd (Rule _ Equals _) = False + isAdd (Rule _ Adds _) = True + +mergeRules :: Rule -> Rule -> Rule +mergeRules (Rule ident Equals left) (Rule ident2 Adds right) + | ident == ident2 = Rule ident Equals + ( SumSpec [ ProductSpec [ Repetition (Repeat 1 (Just 1)) + (GroupElement (Group left)) + ] + , ProductSpec [ Repetition (Repeat 1 (Just 1)) + (GroupElement (Group right)) + ] + ] + ) + -- TODO: Print location of error + | otherwise = error . Text.unpack + $ "Error while canocicalizing ABNF: Rule " <> ident + <> " appended (=/) without ever assigning(=)" +mergeRules _ _ = error "Bug in ABNF canonicalizer (mergeRules)!" + +inlineRulesRule :: RuleMap -> Rule -> Rule +inlineRulesRule rulemap (Rule ident def spec) = + Rule ident def (inlineRulesSumSpec rulemap spec) + +inlineRulesSumSpec :: RuleMap -> SumSpec -> SumSpec +inlineRulesSumSpec rulemap (SumSpec specs) = + SumSpec $ inlineRulesProdSpec rulemap <$> specs + +inlineRulesProdSpec :: RuleMap -> ProductSpec -> ProductSpec +inlineRulesProdSpec rulemap (ProductSpec reps) = + ProductSpec $ inlineRulesRepetition rulemap <$> reps + +inlineRulesRepetition :: RuleMap -> Repetition -> Repetition +inlineRulesRepetition rulemap (Repetition rep elem) = + Repetition rep $ inlineRulesElement rulemap elem + +inlineRulesElement :: RuleMap -> Element -> Element +inlineRulesElement rulemap oldrule@(RuleElement' ruleName) = + let rule = Map.lookup ruleName rulemap + in maybe oldrule (RuleElement . inlineRulesRule rulemap) rule +inlineRulesElement rulemap (GroupElement grp) = + GroupElement $ inlineRulesGroup rulemap grp +inlineRulesElement rulemap (OptionElement grp) = + OptionElement $ inlineRulesGroup rulemap grp +inlineRulesElement _ old = old + +inlineRulesGroup :: RuleMap -> Group -> Group +inlineRulesGroup rulemap (Group sumspec) = Group (inlineRulesSumSpec rulemap sumspec) diff --git a/src/Text/ABNF/Document.hs b/src/Text/ABNF/Document.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/Document.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE OverloadedStrings #-} +{-| +Module : Text.ABNF.Document +Description : Tools to parse ABNF into a Document +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : non-portable + +This module takes a canonicalized rule to parse a document described by it. +You use the function 'generateParser' to generate an attoparsec parser. +-} + +module Text.ABNF.Document where + +import Control.Applicative (liftA2, (<|>), many) +import Control.Monad (join, mzero) +import Data.Char (chr) +import Data.Foldable (asum) +import Data.Monoid ((<>)) + +import qualified Data.Text as Text +import Data.Attoparsec.Text + +import Text.ABNF.Parser.Types +import Text.ABNF.Document.Types + +import Debug.Trace + +generateParser :: Rule -> Parser Document +generateParser = parseRule + +parseRule :: Rule -> Parser Document +parseRule (Rule ident _ spec) = Document ident <$> + (traceM ("Rule: " ++ Text.unpack ident) *> parseSumSpec spec "Rule") + +parseSumSpec :: SumSpec -> Parser [Content] +parseSumSpec (SumSpec prodspecs) = asum (map parseProdSpec prodspecs) "Sum" + +parseProdSpec :: ProductSpec -> Parser [Content] +parseProdSpec (ProductSpec reps) = + join <$> (sequence $ map parseRepetition reps) "Product" + +parseRepetition :: Repetition -> Parser [Content] +-- any number of times +parseRepetition (Repetition (Repeat 0 Nothing) elem) = + join <$> (many $ parseElem elem) +-- Zero times +parseRepetition (Repetition (Repeat 0 (Just 0)) _) = pure [] +-- Less than n times +parseRepetition (Repetition (Repeat 0 (Just n)) elem) = do + el <- (Just <$> parseElem elem) <|> pure Nothing + case el of + Just el' -> liftA2 (++) (pure el') + (parseRepetition (Repetition (Repeat 0 (Just (n-1))) elem)) + Nothing -> pure [] +-- Between n and m times +parseRepetition (Repetition (Repeat n (Just m)) elem) = + liftA2 (++) (parseElem elem) + (parseRepetition (Repetition (Repeat (n-1) (Just (m-1))) elem)) +-- At least n times +parseRepetition (Repetition (Repeat n x) elem) = + liftA2 (++) (parseElem elem) + (parseRepetition (Repetition (Repeat (n-1) x) elem)) + +parseElem :: Element -> Parser [Content] +parseElem (RuleElement rule) = toList . NonTerminal <$> parseRule rule "Rule element" +parseElem (RuleElement' ruleName) = fail . Text.unpack $ "Unknown rule: " <> ruleName +parseElem (GroupElement (Group spec)) = parseSumSpec spec "Group element" +parseElem (OptionElement (Group spec)) = parseSumSpec spec <|> pure [] "Optional element" +parseElem (LiteralElement lit) = parseLiteral lit "Literal element" + +parseLiteral :: Literal -> Parser [Content] +parseLiteral (CharLit lit) = trace (Text.unpack lit) (toList . Terminal <$> asciiCI lit "String literal") +parseLiteral (NumLit lit) = toList . Terminal <$> parseNumLit lit + +parseNumLit :: NumLit -> Parser Text.Text +parseNumLit (IntLit ints) = (Text.pack <$> (sequence (char . chr <$> ints)) "Int-defined character") +parseNumLit (RangeLit x1 x2) = Text.pack . toList <$> (oneOf $ chr <$> [x1..x2]) "Range literal" + +toList :: a -> [a] +toList = pure + +oneOf :: String -> Parser Char +oneOf = foldr (<|>) mzero . fmap char diff --git a/src/Text/ABNF/Document/Types.hs b/src/Text/ABNF/Document/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/Document/Types.hs @@ -0,0 +1,21 @@ +{-| +Module : Text.ABNF.Document.Types +Description : Document type +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : portable +-} +module Text.ABNF.Document.Types where + +import qualified Data.Text as Text + +type Identifier = Text.Text + +data Document = Document Identifier [Content] + deriving (Show, Eq) + +data Content = Terminal Text.Text + | NonTerminal Document + deriving (Show, Eq) diff --git a/src/Text/ABNF/Parser.hs b/src/Text/ABNF/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/Parser.hs @@ -0,0 +1,170 @@ +{-| +Module : Text.ABNF.Parser +Description : ABNF Parser +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : portable + +This module provides facilities to parse ABNF documents. +To parse documents using ABNF, see "Text.ABNF.Document.Parser" + +The parser you will most likely be interested in is 'rulelist' +-} +module Text.ABNF.Parser where + +import Prelude hiding (repeat) + +import Data.Char (ord, isHexDigit, digitToInt) +import Data.Maybe (catMaybes) +import qualified Data.Text as Text +import Numeric (readInt) +import Text.Megaparsec +import Text.Megaparsec.Text + +import Text.ABNF.Parser.Types + +identifier :: Parser Identifier +identifier = Text.pack <$> do + firstChar <- letterChar + otherChars <- many $ alphaNumChar <|> char '-' + pure (firstChar:otherChars) + +rulelist :: Parser [Rule] +rulelist = catMaybes <$> (some $ Just <$> rule <|> (many wsp *> c_nl *> pure Nothing)) + +rule :: Parser Rule +rule = Rule <$> identifier + <*> defined_as + <*> elements + <* c_nl + +defined_as :: Parser DefinedAs +defined_as = many c_wsp *> ((try (string "=/") *> pure Adds) + <|> try (string "=") *> pure Equals) <* many c_wsp + +elements :: Parser SumSpec +elements = alternation <* many wsp + +c_wsp :: Parser String +c_wsp = sequence [wsp] <|> (try $ do + newl <- c_nl + white <- wsp + pure $ newl ++ [white]) + +c_nl :: Parser String +c_nl = comment <|> crlf + +comment :: Parser String +comment = char ';' *> many (wsp <|> vchar) <* crlf + +alternation :: Parser SumSpec +alternation = (do + first <- concatenation + rest <- many (try (many c_wsp *> char '/') *> many c_wsp *> concatenation) + pure . SumSpec $ first:rest) "alternation" + +concatenation :: Parser ProductSpec +concatenation = (do + first <- repetition + rest <- many (try $ some c_wsp *> repetition) + pure . ProductSpec $ first:rest) "concatenation" + +repetition :: Parser Repetition +repetition = Repetition <$> repeat <*> element + +repeat :: Parser Repeat +repeat = try asteriskNumbers <|> try singleNumber <|> pure (Repeat 1 (Just 1)) + where + singleNumber = Repeat 1 <$> (Just . read <$> some digitChar) + asteriskNumbers = do + firstNumber <- option 0 (read <$> some digitChar) + char '*' + secondNumber <- optional (read <$> some digitChar) + pure $ Repeat firstNumber secondNumber + +element :: Parser Element +element = RuleElement' <$> identifier + <|> GroupElement <$> group + <|> OptionElement <$> option_ + <|> LiteralElement <$> literal + +group :: Parser Group +group = Group <$> + (char '(' *> many c_wsp *> alternation <* many c_wsp <* char ')') + +option_ :: Parser Group +option_ = Group <$> + (char '[' *> many c_wsp *> alternation <* many c_wsp <* char ']') + +literal :: Parser Literal +literal = CharLit <$> char_val <|> NumLit <$> num_val <|> CharLit <$> prose_val + +char_val :: Parser Text.Text +char_val = Text.pack <$> (char '"' *> many schar <* char '"') + where + schar = satisfy (\c -> ord c >= 0x20 && ord c <= 0x21 + || ord c >= 0x23 && ord c <= 0x7E) + +num_val :: Parser NumLit +num_val = char '%' *> (bin_val <|> dec_val <|> hex_val) + +{-# WARNING bin_val "readBinInt is unsafe" #-} +bin_val :: Parser NumLit +bin_val = num_val' 'b' binInt + where + readBinInt :: String -> Int + readBinInt = fst . head . readInt 2 + (`elem` ['0', '1']) + digitToInt + binInt = readBinInt <$> many (char '0' <|> char '1') + +dec_val :: Parser NumLit +dec_val = num_val' 'd' readInt + where + readInt :: Parser Int + readInt = read <$> some digitChar + +{-# WARNING hex_val "readHexInt is unsafe" #-} +hex_val :: Parser NumLit +hex_val = num_val' 'x' hexInt + where + readHexInt :: String -> Int + readHexInt = fst . head . readInt 16 isHexDigit digitToInt + hexInt = readHexInt <$> many hexDigitChar + +num_val' :: Char -> Parser Int -> Parser NumLit +num_val' c hexInt = do + char c + digits <- hexInt + intLit digits <|> rangeLit digits <|> pure (IntLit [digits]) + where + intLit' :: Parser [Int] + intLit' = some $ char '.' *> hexInt + + intLit first = do + rest <- intLit' + pure $ IntLit (first:rest) + + rangeLit :: Int -> Parser NumLit + rangeLit startRange = do + char '-' + endRange <- hexInt + pure $ RangeLit startRange endRange + + --readHexInt :: String -> Int + --readHexInt = fst . head . readInt 16 isHexDigit digitToInt + --hexInt = readHexInt <$> many hexDigitChar + +prose_val :: Parser Text.Text +prose_val = Text.pack <$> (char '<' *> many pchar <* char '>') + where + pchar = satisfy (\c -> ord c >= 0x20 && ord c <= 0x3D + || ord c >= 0x3F && ord c <= 0x7E) + +vchar :: Parser Char +vchar = satisfy (\c -> ord c >= 0x21 && ord c <= 0x7E) + +wsp :: Parser Char +wsp = char ' ' <|> char '\t' diff --git a/src/Text/ABNF/Parser/Types.hs b/src/Text/ABNF/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/Parser/Types.hs @@ -0,0 +1,52 @@ +{-| +Module : Text.ABNF.Parser.Types +Description : Types used by the parser +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : portable + +These types are used by the parser and are loosely modeled after the ABNF +privded in +-} +module Text.ABNF.Parser.Types where + +import qualified Data.Text as Text + +type Identifier = Text.Text + +data Rule = Rule Identifier DefinedAs SumSpec + deriving (Show, Eq) + +data SumSpec = SumSpec [ProductSpec] + deriving (Show, Eq) + +data ProductSpec = ProductSpec [Repetition] + deriving (Show, Eq) + +data Repetition = Repetition Repeat Element + deriving (Show, Eq) + +data Repeat = Repeat Int (Maybe Int) + deriving (Show, Eq) + +data Element = RuleElement' Identifier + | RuleElement Rule + | GroupElement Group + | OptionElement Group + | LiteralElement Literal + deriving (Show, Eq) + +data Group = Group SumSpec + deriving (Show, Eq) + +data Literal = CharLit Text.Text | NumLit NumLit + deriving (Show, Eq) + +data NumLit = IntLit [Int] + | RangeLit Int Int + deriving (Show, Eq) + +data DefinedAs = Equals | Adds + deriving (Show, Eq) diff --git a/src/Text/ABNF/PrettyPrinter.hs b/src/Text/ABNF/PrettyPrinter.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/PrettyPrinter.hs @@ -0,0 +1,70 @@ +{-| +Module : Text.ABNF.PrettyPrinter +Description : Pretty printer for ABNF rules +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : portable +-} + +module Text.ABNF.PrettyPrinter where + +import Data.List (intersperse) +import qualified Data.Text as Text + +import Text.ABNF.Parser.Types + +class Pretty a where + prettyShow :: a -> String + +instance Pretty a => Pretty [a] where + prettyShow = unlines . map prettyShow + +instance Pretty Rule where + prettyShow (Rule ident definedAs sumSpec) = Text.unpack ident + ++ " " + ++ prettyShow definedAs + ++ " " + ++ prettyShow sumSpec + +instance Pretty DefinedAs where + prettyShow Equals = "=" + prettyShow Adds = "=/" + +instance Pretty SumSpec where + prettyShow (SumSpec prodspecs) = concat $ + intersperse " / " (map prettyShow prodspecs) + +instance Pretty ProductSpec where + prettyShow (ProductSpec reps) = concat $ + intersperse " " (map prettyShow reps) + +instance Pretty Repetition where + prettyShow (Repetition repeat elem) = prettyShow repeat + ++ prettyShow elem + +instance Pretty Repeat where + prettyShow (Repeat 1 (Just 1)) = "" + prettyShow (Repeat 0 Nothing) = "*" + prettyShow (Repeat l Nothing) = show l ++ "*" + prettyShow (Repeat l (Just h)) = show l ++ "*" ++ show h + +instance Pretty Element where + prettyShow (RuleElement' ident) = Text.unpack ident + prettyShow (RuleElement rule) = prettyShow rule + prettyShow (GroupElement group) = "(" ++ prettyShow group ++ ")" + prettyShow (OptionElement option) = "[" ++ prettyShow option ++ "]" + prettyShow (LiteralElement lit) = prettyShow lit + +instance Pretty Group where + prettyShow (Group sumSpec) = prettyShow sumSpec + +instance Pretty Literal where + prettyShow (CharLit lit) = "\"" ++ Text.unpack lit ++ "\"" + prettyShow (NumLit lit) = prettyShow lit + +instance Pretty NumLit where + prettyShow (IntLit lit) = "%d" ++ concat (intersperse "." (map show lit)) + prettyShow (RangeLit lit1 lit2) = "%d" ++ show lit1 ++ "-" ++ show lit2 + diff --git a/test/ABNF.hs b/test/ABNF.hs new file mode 100644 --- /dev/null +++ b/test/ABNF.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BinaryLiterals #-} +module ABNF where + +import Test.Tasty +import Test.Tasty.HUnit +import Text.Megaparsec +import Text.Megaparsec.Text +import qualified Data.Text as T + +import Text.ABNF.Parser +import Text.ABNF.Parser.Types +import Util + +testParser :: (Eq a, Show a) => Parser a -> T.Text -> a -> Assertion +testParser parser input expected = case parse parser "" input of + Left msg -> assertFailure (show msg) + Right a -> assertEqual "" expected a + +abnfTests :: TestTree +abnfTests = testGroup "ABNF Parser" + [ let testLit = testParser literal + in testGroup "Literals" $ + [ testCase "CharLit" $ testLit "\"a\"" + (CharLit "a") + , testCase "Long CharLit" $ testLit "\"asdfghjkl\"" + (CharLit "asdfghjkl") + , testCase "IntLit" $ testLit "%x20" + (NumLit $ IntLit [0x20]) + , testCase "IntLit.conat" $ testLit "%x20.20" + (NumLit $ IntLit [0x20,0x20]) + , testCase "IntLit decimal" $ testLit "%d32" + (NumLit $ IntLit [32]) + , testCase "IntLit binary" $ testLit "%b00100000" + (NumLit $ IntLit [0b00100000]) + , testCase "RangeLit" $ testLit "%x41-5A" + (NumLit $ RangeLit 0x41 0x5A) + ] + , let testRep = testParser repetition + in testGroup "Repetition" $ + [ testCase "single" $ testRep "%x20" + (single wsElement) + , testCase "1-2 times" $ testRep "1*2%x20" + (Repetition (Repeat 1 (Just 2)) wsElement) + , testCase "1-* times" $ testRep "1*%x20" + (Repetition (Repeat 1 Nothing) wsElement) + , testCase "* times" $ testRep "*%x20" + (Repetition (Repeat 0 Nothing) wsElement) + ] + , let testProd = testParser concatenation + in testGroup "Concatenation" $ + [ testCase "simple" $ testProd "%x20 %x20" + (ProductSpec [single wsElement, single wsElement]) + , testCase "group" $ testProd "%x20 (%x20 %x20)" + (ProductSpec [ single wsElement + , single $ GroupElement (Group (SumSpec + [ ProductSpec [ single wsElement + , single wsElement + ] + ])) + ]) + ] + , let testSum = testParser elements + in testGroup "Elements" $ + [ testCase "simple" $ testSum "%x20" + (SumSpec [simpleProd wsElement]) + , testCase "sum" $ testSum "%x20 / %x09" + (SumSpec [ simpleProd wsElement + , simpleProd (LiteralElement . NumLit $ IntLit [0x09])]) + , testCase "complex" $ testSum "%x20 / %x20 (%x20 / %x20)" + (SumSpec [ simpleProd wsElement + , ProductSpec [ single wsElement + , single $ GroupElement (Group (SumSpec [simpleProd wsElement, simpleProd wsElement])) + ] + ]) + ] + , let testRule = testParser rule + in testGroup "Rule" $ + [ testCase "equals" $ testRule "a = %x20\r\n" + (Rule "a" Equals (simpleSum wsElement)) + , testCase "adds" $ testRule "a =/ %x20\r\n" + (Rule "a" Adds (simpleSum wsElement)) + ] + ] diff --git a/test/Document.hs b/test/Document.hs new file mode 100644 --- /dev/null +++ b/test/Document.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE OverloadedStrings #-} +module Document where + +import qualified Data.Text as T +import Data.Attoparsec.Text +import Test.Tasty +import Test.Tasty.HUnit + +import Text.ABNF.Parser.Types +import Text.ABNF.Document +import Text.ABNF.Document.Types + +import Util + +testDoc :: (Eq a, Show a) => Parser a -> T.Text -> a -> Assertion +testDoc parser input expected = case parseOnly parser input of + Left msg -> assertFailure msg + Right a -> assertEqual "" expected a + +documentTests :: TestTree +documentTests = testGroup "Document Parser" $ + [ let testLit l = testDoc (parseLiteral l) + in testGroup "literal" $ + [ testCase "IntLit" $ + testLit wsLiteral " " [Terminal " "] + , testCase "IntLit concat" $ + testLit (NumLit (IntLit [0x20,0x20])) " " [Terminal " "] + , testCase "RangeLit left edge" $ + testLit (NumLit (RangeLit 0x41 0x5A)) "A" [Terminal "A"] + , testCase "RangeLit mid" $ + testLit (NumLit (RangeLit 0x41 0x5A)) "L" [Terminal "L"] + , testCase "RangeLit right edge" $ + testLit (NumLit (RangeLit 0x41 0x5A)) "Z" [Terminal "Z"] + , testCase "CharLit" $ + testLit (CharLit " ") " " [Terminal " "] + ] + , let testElem l = testDoc (parseElem l) + in testGroup "element" $ + [ testCase "RuleElement" $ + testElem (RuleElement $ simpleRule "x" wsElement) " " + [NonTerminal (Document "x" [Terminal " "])] + , testCase "GroupElement" $ + testElem (GroupElement (Group (simpleSum wsElement))) " " + [Terminal " "] + , testCase "OptionElement - empty" $ + testElem (OptionElement (Group (simpleSum wsElement))) "" + [] + , testCase "OptionElement - non-empty" $ + testElem (OptionElement (Group (simpleSum wsElement))) " " + [Terminal " "] + , testCase "LiteralElement" $ + testElem wsElement " " [Terminal " "] + ] + , let testRep l = testDoc (parseRepetition l) + in testGroup "repetition" $ + [ testCase "single" $ + testRep (single wsElement) " " [Terminal " "] + , testCase "1-3 - 1" $ + testRep (Repetition (Repeat 1 (Just 3)) wsElement) " " + [Terminal " "] + , testCase "1-3 - 2" $ + testRep (Repetition (Repeat 1 (Just 3)) wsElement) " " + [Terminal " ", Terminal " "] + , testCase "1-3 - 3" $ + testRep (Repetition (Repeat 1 (Just 3)) wsElement) " " + [Terminal " ", Terminal " ", Terminal " "] + , testCase "1-* - 1" $ + testRep (Repetition (Repeat 1 Nothing) wsElement) " " + [Terminal " "] + , testCase "1-* - 3" $ + testRep (Repetition (Repeat 1 Nothing) wsElement) " " + [Terminal " ", Terminal " ", Terminal " "] + , testCase "* - 0" $ + testRep (Repetition (Repeat 0 Nothing) wsElement) "" + [] + , testCase "* - 3" $ + testRep (Repetition (Repeat 0 Nothing) wsElement) " " + [Terminal " ", Terminal " ", Terminal " "] + ] + , let testProd l = testDoc (parseProdSpec l) + in testGroup "concatenation" $ + [ testCase "simple" $ + testProd (simpleProd wsElement) " " + [Terminal " "] + , testCase "two" $ + testProd (ProductSpec [single wsElement, single wsElement]) " " + [Terminal " ", Terminal " "] + ] + , let testSum l = testDoc (parseSumSpec l) + in testGroup "alternation" $ + [ testCase "simple" $ + testSum (simpleSum wsElement) " " + [Terminal " "] + , testCase "3-choice - 1st" $ + testSum (SumSpec [ simpleProd wsElement + , simpleProd (lit "a") + , simpleProd (lit "b") + ]) " " + [Terminal " "] + , testCase "3-choice - 2nd" $ + testSum (SumSpec [ simpleProd wsElement + , simpleProd (lit "a") + , simpleProd (lit "b") + ]) "a" + [Terminal "a"] + , testCase "3-choice - 3rd" $ + testSum (SumSpec [ simpleProd wsElement + , simpleProd (lit "a") + , simpleProd (lit "b") + ]) "b" + [Terminal "b"] + , testCase "group - 1st" $ + testSum (SumSpec [ProductSpec [ single wsElement + , single $ GroupElement (Group (SumSpec + [ simpleProd (lit "a") + , simpleProd (lit "b") + ])) + ]]) " a" + [Terminal " ", Terminal "a"] + , testCase "group - 2nd" $ + testSum (SumSpec [ProductSpec [ single wsElement + , single $ GroupElement (Group (SumSpec + [ simpleProd (lit "a") + , simpleProd (lit "b") + ])) + ]]) " b" + [Terminal " ", Terminal "b"] + ] + ] + +lit :: T.Text -> Element +lit = LiteralElement . CharLit + +simpleRule :: T.Text -> Element -> Rule +simpleRule ident = Rule ident Equals . simpleSum + +wsLiteral :: Literal +wsLiteral = NumLit $ IntLit [0x20] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,23 @@ +{-| +Module : Main +Description : Testsuite +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : non-portable +-} + +module Main where + +import Test.Tasty + +import ABNF (abnfTests) +import Document (documentTests) + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "tests" $ [abnfTests, documentTests] +