Morph [BBNode] (Forest Text)

1 files changed, 43 insertions, 5 deletions

diff --git a/bbcode/src/Text/BBCode.hs b/bbcode/src/Text/BBCode.hs
index 7a328a8..dfa1db7 100644
--- a/bbcode/src/Text/BBCode.hs
+++ b/bbcode/src/Text/BBCode.hs
@@ -1,14 +1,52 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 module Text.BBCode
-       (
+       ( TreeError(..)
+       , rose
+       , matches
        ) where
 
-import Data.Attoparsec.Text
-
 import Data.Text (Text)
-import qualified Data.Text as T (singleton, head, tail)
 
-import Control.Applicative
+import GHC.Generics (Generic)
+import Control.Exception (Exception)
+import Data.Typeable (Typeable)
+
+import Control.Monad (unless)
 
 import Text.BBCode.Lexer (BBToken(..), token)
+
+import Data.Tree
+import Data.Tree.Zipper (TreePos, Empty, Full)
+import qualified Data.Tree.Zipper as Z
+
+data TreeError = ImbalancedTags Text Text
+               | LeftoverClose Text
+               deriving (Show, Eq, Generic, Typeable)
+
+instance Exception TreeError
+
+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 = (==)
+
+rose :: [BBToken] -> Either TreeError (Forest Text)
+-- ^ 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' [] = 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'' (BBClose t) = close t -- for more pointless
+
+    close :: Text -> TreePos Empty Text -> Either TreeError (TreePos Empty Text)
+    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
+      return $ Z.nextSpace pos'