From 1ec5c1cb2f118c906a27b3763c73c0098fe67b4a Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Mon, 18 Jan 2016 11:38:31 +0000
Subject: Added failure mode: UnclosedTags

---
 bbcode/bbcode.cabal       |  2 +-
 bbcode/bbcode.nix         |  2 +-
 bbcode/src/Text/BBCode.hs | 17 +++++++++++++++--
 3 files changed, 17 insertions(+), 4 deletions(-)

(limited to 'bbcode')

diff --git a/bbcode/bbcode.cabal b/bbcode/bbcode.cabal
index 49e7a01..ad8bb5a 100644
--- a/bbcode/bbcode.cabal
+++ b/bbcode/bbcode.cabal
@@ -2,7 +2,7 @@
 -- documentation, see http://haskell.org/cabal/users-guide/
 
 name:                bbcode
-version:             2.0.0
+version:             3.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 ddb055c..6426b0b 100644
--- a/bbcode/bbcode.nix
+++ b/bbcode/bbcode.nix
@@ -3,7 +3,7 @@
 }:
 mkDerivation {
   pname = "bbcode";
-  version = "2.0.0";
+  version = "3.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 ac56974..f3c9ca2 100644
--- a/bbcode/src/Text/BBCode.hs
+++ b/bbcode/src/Text/BBCode.hs
@@ -20,7 +20,7 @@ import GHC.Generics (Generic)
 import Control.Exception (Exception)
 import Data.Typeable (Typeable)
 
-import Control.Monad (unless, join, foldM)
+import Control.Monad (unless, join, foldM, (<=<))
 import Data.Function (on)
 import Control.Applicative
 
@@ -39,6 +39,8 @@ import qualified Data.CaseInsensitive as CI
 
 import Data.Bifunctor (Bifunctor(first))
 
+import Data.Maybe (catMaybes)
+
 -- | Our target structure -- a rose tree with an explicit terminal constructor
 data DomTree = Element (CI Text) (Map (CI Text) Text) [DomTree]
              | Content Text
@@ -75,6 +77,7 @@ bbcode t = fmap dom $ first LexerError (parseOnly (many token <* endOfInput) t)
 -- | 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
+               | UnclosedTags [Text] -- ^ We found opened tags that were not closed
                | ParagraphWithinTag -- ^ We found a paragraph-break within a tag
                deriving (Show, Eq, Generic, Typeable)
 
@@ -98,7 +101,7 @@ rose :: [BBToken] -> Either TreeError (Forest BBLabel)
 -- We use @'Tree' 'BBLabel'@ only as another intermediate structure because it carries no guarantee that the data is semantically valid -- a 'BBPlain'-value semantically has no children.
 --
 -- 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 [])
+rose = fmap Z.toForest . checkClosure <=< foldM (flip rose') (Z.fromForest [])
   where
     rose' (BBStr t)             = return . Z.nextSpace . Z.insert (Node (BBPlain t) [])
     rose'  BBNewPar             = parBreak -- for more pointless
@@ -129,3 +132,13 @@ rose = fmap Z.toForest . foldM (flip rose') (Z.fromForest [])
 
     isPar (Node BBPar _) = True
     isPar _              = False
+
+    checkClosure :: TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel)
+    -- This failure mode isn't required either
+    checkClosure z
+      | null parentTags = Right z
+      | otherwise       = Left . UnclosedTags $ parentTags
+      where
+        parentTags = catMaybes . map (getTag . (\(_, p, _) -> p)) $ Z.parents z
+        getTag (BBTag t _) = Just t
+        getTag _           = Nothing
-- 
cgit v1.2.3