From 4914e4d7f638b7771ecdaf24ee0516c05505697c Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 18 Jan 2016 05:42:26 +0000
Subject: Disallow paragraphs everywhere but at the top

---
 bbcode/src/Text/BBCode.hs | 37 +++++++++++++++++++++----------------
 1 file changed, 21 insertions(+), 16 deletions(-)

(limited to 'bbcode/src')

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
-- 
cgit v1.2.3