Disallow paragraphs everywhere but at the top

4 files changed, 44 insertions, 39 deletions

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"]]])
            ]