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 ++++++++++++++++++++--------
 1 file changed, 20 insertions(+), 8 deletions(-)

(limited to 'bbcode/src/Text/BBCode.hs')

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