BBCode now understands paragraphs

1 files changed, 26 insertions, 5 deletions

diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs
index 6fef446..0773124 100644
--- a/bbcode/src/Text/BBCode.hs
+++ b/bbcode/src/Text/BBCode.hs
@@ -40,6 +40,7 @@ import Data.Bifunctor (Bifunctor(first))
 
 -- | Our target structure -- a rose tree with an explicit terminal constructor
 data DomTree = Element Text (Map Text Text) [DomTree]
+             | Paragraph [DomTree]
              | Content Text
              deriving (Show, Eq)
 
@@ -51,6 +52,7 @@ dom = map dom'
   where
     dom' (Node (BBPlain t) _) = Content t
     dom' (Node (BBTag t attrs) ts) = Element t attrs $ map dom' ts
+    dom' (Node BBPar ts) = Paragraph $ map dom' ts
 
 -- | Errors encountered during parsing
 data BBCodeError = LexerError String -- ^ Error while parsing input to stream of tokens
@@ -72,6 +74,7 @@ instance Exception TreeError
 
 -- | The label of our rose-tree nodes carries the tag name and a map of attributes
 data BBLabel = BBTag Text (Map Text Text)
+             | BBPar
              | BBPlain Text
              deriving (Show, Eq)
 
@@ -89,15 +92,33 @@ rose :: [BBToken] -> Either TreeError (Forest BBLabel)
 -- The use of 'Tree' was still deemed desirable because the morphism to a more sensible structure is straightforward and 'Data.Tree.Zipper' provides all the tools needed to implement 'rose' in a sensible fashion
 rose = fmap Z.toForest . foldM (flip rose') (Z.fromForest [])
   where
-    rose' (BBStr t) = return . Z.nextSpace . Z.insert (Node (BBPlain t) [])
-    rose' (BBOpen t attrs) = return . Z.children . Z.insert (Node (BBTag t $ Map.fromList attrs) [])
+    rose' (BBStr t)             = return . Z.nextSpace . Z.insert (Node (BBPlain t) [])
+    rose'  BBNewPar             = return . 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
+    rose' (BBClose t)           = close t -- for more pointless
 
     close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel)
     close tag pos = do
-      pos' <- maybe (Left $ ImbalancedTags tag) Right $ Z.parent pos
+      pos' <- maybe (Left $ ImbalancedTags tag) Right $ Z.parent pos >>= traversePars
       let
-        pTag = (\(BBTag t _) -> t) $ Z.label pos'
+        pTag = (\(BBTag t _) -> t) . Z.label $ pos'
       unless (pTag `matches` tag) . Left $ MismatchedTags pTag tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have
       return $ Z.nextSpace pos'
+      where
+        traversePars pos
+          | 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
+
+                     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
+
+    isPar (Node BBPar _) = True
+    isPar _              = False