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 ++++-
 bbcode/thermoprint-bbcode.cabal |  1 +
 bbcode/thermoprint-bbcode.nix   |  6 +++---
 4 files changed, 28 insertions(+), 12 deletions(-)

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
diff --git a/bbcode/thermoprint-bbcode.cabal b/bbcode/thermoprint-bbcode.cabal
index 80a9da5..f25ffdf 100644
--- a/bbcode/thermoprint-bbcode.cabal
+++ b/bbcode/thermoprint-bbcode.cabal
@@ -26,6 +26,7 @@ library
                      , text >=1.2.1 && <2
                      , containers >=0.4.0 && <1
                      , rosezipper >=0.2 && <1
+                     , case-insensitive >=1.2.0 && <2
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/bbcode/thermoprint-bbcode.nix b/bbcode/thermoprint-bbcode.nix
index c379053..896bb04 100644
--- a/bbcode/thermoprint-bbcode.nix
+++ b/bbcode/thermoprint-bbcode.nix
@@ -1,12 +1,12 @@
-{ mkDerivation, attoparsec, base, containers, hspec, QuickCheck
-, quickcheck-instances, rosezipper, stdenv, text
+{ mkDerivation, attoparsec, base, case-insensitive, containers
+, hspec, QuickCheck, quickcheck-instances, rosezipper, stdenv, text
 }:
 mkDerivation {
   pname = "thermoprint-bbcode";
   version = "0.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    attoparsec base containers rosezipper text
+    attoparsec base case-insensitive containers rosezipper text
   ];
   testHaskellDepends = [
     attoparsec base hspec QuickCheck quickcheck-instances text
-- 
cgit v1.2.3