From fe17c720081798175c9936d1624f428b565e310f Mon Sep 17 00:00:00 2001
From: Gregor Kleen <gkleen@yggdrasil.li>
Date: Tue, 12 Jan 2016 05:21:16 +0000
Subject: Rose-Tree labels now carry attributes

---
 bbcode/src/Text/BBCode.hs       | 28 ++++++++++++++++++++--------
 bbcode/src/Text/BBCode/Lexer.hs |  5 ++++-
 2 files changed, 24 insertions(+), 9 deletions(-)

(limited to 'bbcode/src')

diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs
index a6de7b4..3828c22 100644
--- a/bbcode/src/Text/BBCode.hs
+++ b/bbcode/src/Text/BBCode.hs
@@ -3,6 +3,7 @@
 
 module Text.BBCode
        ( TreeError(..)
+       , BBLabel
        , rose
        , matches
        ) where
@@ -14,6 +15,7 @@ import Control.Exception (Exception)
 import Data.Typeable (Typeable)
 
 import Control.Monad (unless)
+import Data.Function (on)
 
 import Text.BBCode.Lexer (BBToken(..), token)
 
@@ -21,32 +23,42 @@ import Data.Tree
 import Data.Tree.Zipper (TreePos, Empty, Full)
 import qualified Data.Tree.Zipper as Z
 
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import Data.CaseInsensitive (CI)
+import qualified Data.CaseInsensitive as CI
+
 data TreeError = ImbalancedTags Text Text
                | LeftoverClose Text
                deriving (Show, Eq, Generic, Typeable)
 
 instance Exception TreeError
 
+type BBLabel = (Text, Map Text (Maybe Text))
+
 matches :: Text -> Text -> Bool
 -- ^ @`matches` "open" "close"@ should be true iff @[/close]@ is a valid closing tag for @[open]@
 --
--- Until we allow for attributes this is equality according to `(==)`
-matches = (==)
+-- > (==) `on` CI.mk
+matches = (==) `on` CI.mk
 
-rose :: [BBToken] -> Either TreeError (Forest Text)
+rose :: [BBToken] -> Either TreeError (Forest BBLabel)
 -- ^ Assuming that both tags and content have the same type (we use 'Text') bbcode is a flat representation of a rose tree
 rose = fmap Z.toForest . flip rose' (Z.fromForest [])
   where
-    rose' :: [BBToken] -> TreePos Empty Text -> Either TreeError (TreePos Empty Text)
+    rose' :: [BBToken] -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel)
     rose' [] = return
     rose' (x:xs) = (>>= rose' xs) . rose'' x
 
-    rose'' (BBStr t) = return . Z.nextSpace . Z.insert (Node t [])
-    rose'' (BBOpen t _) = return . Z.children . Z.insert (Node t [])
+    rose'' (BBStr t) = return . Z.nextSpace . Z.insert (Node (t, Map.empty) [])
+    rose'' (BBOpen t attrs) = return . Z.children . Z.insert (Node (t, Map.fromList attrs) [])
     rose'' (BBClose t) = close t -- for more pointless
 
-    close :: Text -> TreePos Empty Text -> Either TreeError (TreePos Empty Text)
+    close :: Text -> TreePos Empty BBLabel -> Either TreeError (TreePos Empty BBLabel)
     close tag pos = do
       pos' <- maybe (Left $ LeftoverClose tag) Right $ Z.parent pos
-      unless (Z.label pos' `matches` tag) . Left $ ImbalancedTags (Z.label pos') tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have
+      let
+        pTag = fst $ Z.label pos'
+      unless (pTag `matches` tag) . Left $ ImbalancedTags pTag tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have
       return $ Z.nextSpace pos'
diff --git a/bbcode/src/Text/BBCode/Lexer.hs b/bbcode/src/Text/BBCode/Lexer.hs
index ad26113..2eb0022 100644
--- a/bbcode/src/Text/BBCode/Lexer.hs
+++ b/bbcode/src/Text/BBCode/Lexer.hs
@@ -29,9 +29,12 @@ data BBToken = BBOpen Text [(Text, Maybe Text)] -- ^ Tag open with attributes
 token :: Parser BBToken
 -- ^ Tokenizer
 token = BBClose <$> ("[/" *> escapedText' [']'] <* "]")
-        <|> BBOpen <$> ("[" *> escapedText' [']', ' ']) <*> (option [] attrs <* "]")
+        <|> uncurry BBOpen <$> openTag
         <|> BBStr <$> escapedText ['[']
 
+openTag :: Parser (Text, [(Text, Maybe Text)])
+openTag = (,) <$> ("[" *> escapedText' [']', ' ']) <*> (option [] attrs <* "]")
+
 attrs :: Parser [(Text, Maybe Text)]
 attrs = (:) <$> (attrs' <* takeWhile isSpace) <*> (option [] $ attrs)
   where
-- 
cgit v1.2.3