diff --git a/abnf.cabal b/abnf.cabal --- a/abnf.cabal +++ b/abnf.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: abnf -version: 0.2.0.0 +version: 0.3.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 @@ -15,6 +15,7 @@ homepage: https://github.com/Xandaros/abnf.git category: Text build-type: Simple +stability: alpha -- extra-source-files: cabal-version: >=1.10 @@ -23,13 +24,15 @@ location: https://github.com/Xandaros/abnf.git library - exposed-modules: Text.ABNF.ABNF, + exposed-modules: Text.ABNF, + Text.ABNF.ABNF, Text.ABNF.ABNF.Parser, Text.ABNF.ABNF.Types, Text.ABNF.ABNF.Canonicalizer, Text.ABNF.Document, Text.ABNF.Document.Parser, Text.ABNF.Document.Types, + Text.ABNF.Document.Operations, Text.ABNF.PrettyPrinter ghc-options: -W -- other-modules: diff --git a/src/Text/ABNF.hs b/src/Text/ABNF.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF.hs @@ -0,0 +1,17 @@ +{-| +Module : Text.ABNF +Description : Top-level module +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : non-portable +-} + +module Text.ABNF + ( module Text.ABNF.ABNF + , module Text.ABNF.Document + ) where + +import Text.ABNF.ABNF +import Text.ABNF.Document diff --git a/src/Text/ABNF/ABNF.hs b/src/Text/ABNF/ABNF.hs --- a/src/Text/ABNF/ABNF.hs +++ b/src/Text/ABNF/ABNF.hs @@ -1,1 +1,27 @@ -module Text.ABNF.ABNF where +{-| +Module : Text.ABNF.ABNF +Description : ABNF +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : non-portable +-} + +module Text.ABNF.ABNF + ( + -- * ABNF types + -- | Re-exported from "Text.ABNF.ABNF.Types" + Rule(..) + -- * Parsing ABNF Rules + -- | Re-exported from "Text.ABNF.ABNF.Parser" + , rulelist + , parseABNF + -- * Canonicalizing ABNF Rules + -- | Re-exported from "Text.ABNF.ABNF.Canonicalizer" + , canonicalizeRules + ) where + +import Text.ABNF.ABNF.Types (Rule(..)) +import Text.ABNF.ABNF.Parser (rulelist, parseABNF) +import Text.ABNF.ABNF.Canonicalizer (canonicalizeRules) diff --git a/src/Text/ABNF/ABNF/Canonicalizer.hs b/src/Text/ABNF/ABNF/Canonicalizer.hs --- a/src/Text/ABNF/ABNF/Canonicalizer.hs +++ b/src/Text/ABNF/ABNF/Canonicalizer.hs @@ -18,9 +18,14 @@ import Text.ABNF.ABNF.Types -type RuleMap = Map.Map Identifier Rule +type RuleMap = Map.Map Text.Text Rule -canonicalizeRules :: Identifier -> [Rule] -> Maybe Rule +-- | Canonicalize a list of 'Rule's, leaving only a single 'Rule'. +canonicalizeRules :: Text.Text -- ^ The main, or top-level, 'Rule' + -> [Rule] -- ^ List of 'Rule's to canonicalize + -> Maybe Rule -- ^ The operation may fail for a number of + -- reasons, for example, because the main 'Rule' + -- does not exist canonicalizeRules mainRuleIdent rules = do let (defs, adds) = partition isAdd rules ruleMap = foldr (\rule@(Rule ident _ _) curMap -> diff --git a/src/Text/ABNF/ABNF/Parser.hs b/src/Text/ABNF/ABNF/Parser.hs --- a/src/Text/ABNF/ABNF/Parser.hs +++ b/src/Text/ABNF/ABNF/Parser.hs @@ -25,12 +25,22 @@ import Text.ABNF.ABNF.Types -identifier :: Parser Identifier +identifier :: Parser Text.Text identifier = Text.pack <$> do firstChar <- letterChar otherChars <- many $ alphaNumChar <|> char '-' pure (firstChar:otherChars) +-- | Convencience function to directly parse a list of rules. +-- This is equivalent to +-- +-- @ +-- 'parse' 'rulelist' +-- @ +parseABNF :: String -> Text.Text -> Either (ParseError Char Dec) [Rule] +parseABNF = parse rulelist + +-- | The main parser, which parses a list of 'Rule's. rulelist :: Parser [Rule] rulelist = catMaybes <$> (some $ Just <$> rule <|> (many wsp *> c_nl *> pure Nothing)) diff --git a/src/Text/ABNF/ABNF/Types.hs b/src/Text/ABNF/ABNF/Types.hs --- a/src/Text/ABNF/ABNF/Types.hs +++ b/src/Text/ABNF/ABNF/Types.hs @@ -14,9 +14,13 @@ import qualified Data.Text as Text -type Identifier = Text.Text - -data Rule = Rule Identifier DefinedAs SumSpec +-- | A 'Rule' represents a single entry in your ABNF. It could, for example, +-- look like this: +-- +-- @ +-- CRLF = %x0D.0A +-- @ +data Rule = Rule Text.Text DefinedAs SumSpec deriving (Show, Eq) data SumSpec = SumSpec [ProductSpec] @@ -31,7 +35,7 @@ data Repeat = Repeat Int (Maybe Int) deriving (Show, Eq) -data Element = RuleElement' Identifier +data Element = RuleElement' Text.Text | RuleElement Rule | GroupElement Group | OptionElement Group diff --git a/src/Text/ABNF/Document.hs b/src/Text/ABNF/Document.hs --- a/src/Text/ABNF/Document.hs +++ b/src/Text/ABNF/Document.hs @@ -1,1 +1,48 @@ -module Text.ABNF.Document where +{-| +Module : Text.ABNF.Document +Description : Documents according to an ABNF definition +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : non-portable +-} + +module Text.ABNF.Document + ( + -- * Document types + -- | Re-exported from "Text.ABNF.Document.Types" + Document(..) + , Content(..) + -- * Reducing documents + -- | Re-exported from "Text.ABNF.Document.Operations" + -- + -- In most cases, you don't want to work with the full tree of a 'Document'. + -- You can use these cases to 'filterDocument' away any branches you do not + -- need and 'squashDocumentOn' those, where you don't need it as + -- fine-grained. + -- + -- This is incredibly useful if you have rules that parse single characters. + , filterDocument + , squashDocument + , squashDocumentOn + , squashContent + -- * Parsing documents + -- | Re-exported from "Text.ABNF.Document.Parser" + , generateParser + , parseDocument + ) where + +import Text.ABNF.Document.Types ( Document(..) + , Content(..) + ) + +import Text.ABNF.Document.Operations ( filterDocument + , squashDocument + , squashDocumentOn + , squashContent + ) + +import Text.ABNF.Document.Parser ( generateParser + , parseDocument + ) diff --git a/src/Text/ABNF/Document/Operations.hs b/src/Text/ABNF/Document/Operations.hs new file mode 100644 --- /dev/null +++ b/src/Text/ABNF/Document/Operations.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-| +Module : Text.ABNF.Document.Operations +Description : Some operations on documents +Copyright : (c) Martin Zeller, 2016 +License : BSD2 +Maintainer : Martin Zeller +Stability : experimental +Portability : ScopedTypeVariables +-} + +module Text.ABNF.Document.Operations where + +import Data.Maybe (catMaybes) +import Data.Monoid ((<>)) + +import Text.ABNF.Document.Types + +-- | Filter documents according to some predicate. +-- Similar to 'filter' in the Prelude. +filterDocument :: forall a. (Document a -> Bool) -- ^ Predicate to check + -> Document a -- ^ Document to filter + -> Maybe (Document a) -- ^ Returns 'Nothing' if the + -- predicate fails, cascades + -- otherwise +filterDocument pred doc@(Document ident conts) | pred doc = Just . Document ident $ (catMaybes . fmap filterNT $ conts) + | otherwise = Nothing + where + filterNT :: Content a -> Maybe (Content a) + filterNT a@(Terminal _) = Just a + filterNT (NonTerminal doc) | pred doc = NonTerminal <$> filterDocument pred doc + | otherwise = Nothing + +-- | Squash all contents of a 'Document' into a single 'Terminal' +squashDocument :: Monoid a => Document a -> Document a +squashDocument (Document ident conts) = Document ident [Terminal $ squashContent conts] + +-- | Squash all contents of a 'Document' which matches the predicate +-- See also 'squashDocument' +squashDocumentOn :: forall a. Monoid a => (Document a -> Bool) -> Document a -> Document a +squashDocumentOn pred doc@(Document ident conts) | pred doc = squashDocument doc + | otherwise = Document ident (squashNT <$> conts) + where + squashNT :: Content a -> Content a + squashNT (Terminal a) = Terminal a + squashNT (NonTerminal doc) = NonTerminal $ squashDocumentOn pred doc + +-- | Squash all contents using the 'Monoid' instance of @a@, cascading into +-- 'NonTerminal's. +squashContent :: Monoid a => [Content a] -> a +squashContent [] = mempty +squashContent ((Terminal a):xs) = a <> squashContent xs +squashContent ((NonTerminal (Document _ conts)):xs) = squashContent conts <> squashContent xs diff --git a/src/Text/ABNF/Document/Parser.hs b/src/Text/ABNF/Document/Parser.hs --- a/src/Text/ABNF/Document/Parser.hs +++ b/src/Text/ABNF/Document/Parser.hs @@ -20,26 +20,40 @@ import Data.Foldable (asum) import Data.Monoid ((<>)) -import qualified Data.Text as Text +import qualified Data.Text as T import Data.Attoparsec.Text import Text.ABNF.ABNF.Types import Text.ABNF.Document.Types -generateParser :: Rule -> Parser Document +-- | Convenience function to directly parse a 'Document' +parseDocument :: Rule -- ^ 'Rule' to parse against + -> T.Text -- ^ 'Text' to parse + -> Either String (Document T.Text) -- ^ Return a 'String' + -- describing the error or the + -- successfully parsed + -- 'Document'. + -- + -- The format of the 'String' + -- is as returned by + -- . +parseDocument = parseOnly . generateParser + +-- | Generate an parser +generateParser :: Rule -> Parser (Document T.Text) generateParser = parseRule -parseRule :: Rule -> Parser Document +parseRule :: Rule -> Parser (Document T.Text) parseRule (Rule ident _ spec) = Document ident <$> parseSumSpec spec "Rule" -parseSumSpec :: SumSpec -> Parser [Content] +parseSumSpec :: SumSpec -> Parser [Content T.Text] parseSumSpec (SumSpec prodspecs) = asum (map parseProdSpec prodspecs) "Sum" -parseProdSpec :: ProductSpec -> Parser [Content] +parseProdSpec :: ProductSpec -> Parser [Content T.Text] parseProdSpec (ProductSpec reps) = join <$> (sequence $ map parseRepetition reps) "Product" -parseRepetition :: Repetition -> Parser [Content] +parseRepetition :: Repetition -> Parser [Content T.Text] -- any number of times parseRepetition (Repetition (Repeat 0 Nothing) elem) = join <$> (many $ parseElem elem) @@ -61,20 +75,20 @@ liftA2 (++) (parseElem elem) (parseRepetition (Repetition (Repeat (n-1) x) elem)) -parseElem :: Element -> Parser [Content] +parseElem :: Element -> Parser [Content T.Text] parseElem (RuleElement rule) = toList . NonTerminal <$> parseRule rule "Rule element" -parseElem (RuleElement' ruleName) = fail . Text.unpack $ "Unknown rule: " <> ruleName +parseElem (RuleElement' ruleName) = fail . T.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 :: Literal -> Parser [Content T.Text] parseLiteral (CharLit 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" +parseNumLit :: NumLit -> Parser T.Text +parseNumLit (IntLit ints) = (T.pack <$> (sequence (char . chr <$> ints)) "Int-defined character") +parseNumLit (RangeLit x1 x2) = T.pack . toList <$> (oneOf $ chr <$> [x1..x2]) "Range literal" toList :: a -> [a] toList = pure diff --git a/src/Text/ABNF/Document/Types.hs b/src/Text/ABNF/Document/Types.hs --- a/src/Text/ABNF/Document/Types.hs +++ b/src/Text/ABNF/Document/Types.hs @@ -11,11 +11,29 @@ import qualified Data.Text as Text -type Identifier = Text.Text - -data Document = Document Identifier [Content] +-- | A 'Document' represents a tree of the parsed input. Directly after parsing, +-- every 'Rule' that was applied, gets a node in the tree. +-- +-- You can use 'Text.ABNF.Document.filterDocument' and +-- 'Text.ABNF.Document.squashDocumentOn' to reduce the tree into a more +-- managable shape. +data Document a = Document Text.Text [Content a] deriving (Show, Eq) -data Content = Terminal Text.Text - | NonTerminal Document +data Content a = Terminal a + | NonTerminal (Document a) deriving (Show, Eq) + +instance Functor Document where + fmap f (Document ident conts) = Document ident $ fmap (fmap f) conts + +instance Functor Content where + fmap f (Terminal a) = Terminal $ f a + fmap f (NonTerminal doc) = NonTerminal $ fmap f doc + +instance Applicative Content + +instance Monad Content where + return = Terminal + Terminal a >>= f = f a + NonTerminal (Document ident cs) >>= f = NonTerminal (Document ident (map (>>= f) cs))