From 4914e4d7f638b7771ecdaf24ee0516c05505697c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 18 Jan 2016 05:42:26 +0000 Subject: Disallow paragraphs everywhere but at the top --- bbcode/bbcode.cabal | 2 +- bbcode/bbcode.nix | 2 +- bbcode/src/Text/BBCode.hs | 37 +++++++++++++++++++++---------------- bbcode/test/Text/BBCodeSpec.hs | 42 +++++++++++++++++++++--------------------- 4 files changed, 44 insertions(+), 39 deletions(-) (limited to 'bbcode') diff --git a/bbcode/bbcode.cabal b/bbcode/bbcode.cabal index d2f4932..f899d49 100644 --- a/bbcode/bbcode.cabal +++ b/bbcode/bbcode.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: bbcode -version: 0.0.0 +version: 1.0.0 synopsis: A parser for bbcode -- description: homepage: http://dirty-haskell.org/tags/thermoprint.html diff --git a/bbcode/bbcode.nix b/bbcode/bbcode.nix index 82ba2f4..97f8982 100644 --- a/bbcode/bbcode.nix +++ b/bbcode/bbcode.nix @@ -3,7 +3,7 @@ }: mkDerivation { pname = "bbcode"; - version = "0.0.0"; + version = "1.0.0"; src = ./.; libraryHaskellDepends = [ attoparsec base case-insensitive containers rosezipper text diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs index fbd8a33..8f04f19 100644 --- a/bbcode/src/Text/BBCode.hs +++ b/bbcode/src/Text/BBCode.hs @@ -6,6 +6,7 @@ module Text.BBCode ( bbcode , BBCodeError(..) , TreeError(..) + , DomForest , DomTree(..) -- , dom -- , BBLabel @@ -40,19 +41,23 @@ import Data.Bifunctor (Bifunctor(first)) -- | Our target structure -- a rose tree with an explicit terminal constructor data DomTree = Element (CI Text) (Map (CI Text) Text) [DomTree] - | Paragraph [DomTree] | Content Text deriving (Show, Eq) -dom :: Forest BBLabel -> [DomTree] +-- | List of paragraphs, which are comprised of lists of 'DomTree's +type DomForest = [[DomTree]] + +dom :: Forest BBLabel -> DomForest -- ^ Parse semantically constrained rose tree to syntactically constrained version -- --- Silently drops children of semantically terminal nodes ('BBPlain') -dom = map dom' +-- Silently drops children of semantically terminal nodes ('BBPlain') and paragraphs anywhere but at top level +dom = map fromPar where - dom' (Node (BBPlain t) _) = Content t - dom' (Node (BBTag t attrs) ts) = Element (CI.mk t) (Map.mapKeys CI.mk attrs) $ map dom' ts - dom' (Node BBPar ts) = Paragraph $ map dom' ts + fromPar (Node BBPar ts) = concatMap dom' ts + fromPar x = dom' x + dom' (Node (BBPlain t) _) = pure $ Content t + dom' (Node (BBTag t attrs) ts) = pure . Element (CI.mk t) (Map.mapKeys CI.mk attrs) $ concatMap dom' ts + dom' (Node BBPar _) = [] -- | Errors encountered during parsing data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens @@ -61,13 +66,14 @@ data BBCodeError = LexerError String -- ^ Error while parsing input to stream of instance Exception BBCodeError -bbcode :: Text -> Either BBCodeError [DomTree] +bbcode :: Text -> Either BBCodeError DomForest -- ^ Parse BBCode bbcode t = fmap dom $ first LexerError (parseOnly (many token <* endOfInput) t) >>= first TreeError . rose -- | Errors in input encountered during parsing of lexed token-stream data TreeError = MismatchedTags Text Text -- ^ Closing tags label does not match opening tags | ImbalancedTags Text -- ^ We found an extraneous closing tag + | ParagraphWithinTag -- ^ We found a paragraph-break within a tag deriving (Show, Eq, Generic, Typeable) instance Exception TreeError @@ -93,7 +99,7 @@ rose :: [BBToken] -> Either TreeError (Forest BBLabel) rose = fmap Z.toForest . foldM (flip rose') (Z.fromForest []) where rose' (BBStr t) = return . Z.nextSpace . Z.insert (Node (BBPlain t) []) - rose' BBNewPar = return . parBreak -- for more pointless + rose' BBNewPar = parBreak -- for more pointless rose' (BBOpen t attrs) = return . Z.children . Z.insert (Node (BBTag t $ Map.fromList attrs) []) rose' (BBContained t attrs) = return . Z.nextSpace . Z.insert (Node (BBTag t $ Map.fromList attrs) []) rose' (BBClose t) = close t -- for more pointless @@ -110,15 +116,14 @@ rose = fmap Z.toForest . foldM (flip rose') (Z.fromForest []) | isPar . Z.tree $ pos = Z.parent pos >>= traversePars | otherwise = return pos - parBreak :: TreePos Empty BBLabel -> TreePos Empty BBLabel - parBreak z = let siblings = reverse $ Z.before z -- We only move ever move right so Z.after will always be empty + parBreak :: TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel) + parBreak z = let siblings = reverse $ Z.before z siblingsAsPars - | all isPar siblings = z - | otherwise = case Z.parent z of - Nothing -> Z.fromForest $ [Node BBPar siblings] - Just p -> Z.children . Z.modifyTree (\(Node l _) -> Node l [Node BBPar siblings]) $ p - in Z.children . Z.insert (Node BBPar []) . Z.last $ siblingsAsPars + | all isPar siblings = Right z + | Z.isRoot z = Right . Z.fromForest $ [Node BBPar siblings] + | otherwise = Left ParagraphWithinTag + in Z.children . Z.insert (Node BBPar []) . Z.last <$> siblingsAsPars isPar (Node BBPar _) = True isPar _ = False diff --git a/bbcode/test/Text/BBCodeSpec.hs b/bbcode/test/Text/BBCodeSpec.hs index e24c661..241cd76 100644 --- a/bbcode/test/Text/BBCodeSpec.hs +++ b/bbcode/test/Text/BBCodeSpec.hs @@ -20,44 +20,44 @@ spec = do example n (s, ts) = let str = "Example " <> show n in specify str (bbcode s == Right ts) -examples :: [(Text, [DomTree])] +examples :: [(Text, DomForest)] examples = [ ("[t]test[/t]" - , [Element "t" [] [Content "test"]]) + , pure [Element "t" [] [Content "test"]]) , ("[t]te\\st[/t]" - , [Element "t" [] [Content "te\\st"]]) + , pure [Element "t" [] [Content "te\\st"]]) , ("[t]te\\[st[/t]" - , [Element "t" [] [Content "te[st"]]) + , pure [Element "t" [] [Content "te[st"]]) , ("[t]test\\\\[/t]" - , [Element "t" [] [Content "test\\"]]) + , pure [Element "t" [] [Content "test\\"]]) , ("[\\t]test[/\\t]" - , [Element "\\t" [] [Content "test"]]) + , pure [Element "\\t" [] [Content "test"]]) , ("[t attr]test[/t]" - , [Element "t" [("attr", "")] [Content "test"]]) + , pure [Element "t" [("attr", "")] [Content "test"]]) , ("[t=attr]test[/t]" - , [Element "t" [("", "attr")] [Content "test"]]) + , pure [Element "t" [("", "attr")] [Content "test"]]) , ("[t attr=val]test[/t]" - , [Element "t" [("attr", "val")] [Content "test"]]) + , pure [Element "t" [("attr", "val")] [Content "test"]]) , ("[t attr=\"val\"]test[/t]" - , [Element "t" [("attr", "val")] [Content "test"]]) + , pure [Element "t" [("attr", "val")] [Content "test"]]) , ("[t attr=\"va]l\"]test[/t]" - , [Element "t" [("attr", "va]l")] [Content "test"]]) + , pure [Element "t" [("attr", "va]l")] [Content "test"]]) , ("[t attr=\"va\\\"l\"]test[/t]" - , [Element "t" [("attr", "va\"l")] [Content "test"]]) + , pure [Element "t" [("attr", "va\"l")] [Content "test"]]) , ("[t attr=\"val\" attr2=\"val2\" ]test[/t]" - , [Element "t" [("attr", "val"), ("attr2", "val2")] [Content "test"]]) + , pure [Element "t" [("attr", "val"), ("attr2", "val2")] [Content "test"]]) , ("[br/]" - , [Element "br" [] []]) + , pure [Element "br" [] []]) , ("[br attr/]" - , [Element "br" [("attr", "")] []]) + , pure [Element "br" [("attr", "")] []]) , ("[br=val/]" - , [Element "br" [("", "val")] []]) + , pure [Element "br" [("", "val")] []]) , ("[br attr=val/]" - , [Element "br" [("attr", "val")] []]) + , pure [Element "br" [("attr", "val")] []]) , ("[br attr=val val2/]" - , [Element "br" [("attr", "val"), ("val2", "")] []]) + , pure [Element "br" [("attr", "val"), ("val2", "")] []]) , ("foo\n\nbar" - , [Paragraph [Content "foo"], Paragraph [Content "bar"]]) - , ("[b]foo\n\nbar[/b]" - , [Element "b" [] [Paragraph [Content "foo"], Paragraph [Content "bar"]]]) + , [[Content "foo"], [Content "bar"]]) + , ("[b]foo[/b]\n\n[b]bar[/b]" + , [[Element "b" [] [Content "foo"]], [Element "b" [] [Content "bar"]]]) ] -- cgit v1.2.3