Morph [BBNode] (Forest Text)

3 files changed, 51 insertions, 9 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'
diff --git a/bbcode/thermoprint-bbcode.cabal b/bbcode/thermoprint-bbcode.cabal
index f1018a5..80a9da5 100644
--- a/bbcode/thermoprint-bbcode.cabal
+++ b/bbcode/thermoprint-bbcode.cabal
@@ -24,6 +24,8 @@ library
   build-depends:       base >=4.8 && <4.9
                      , attoparsec >=0.13.0 && <1
                      , text >=1.2.1 && <2
+                     , containers >=0.4.0 && <1
+                     , rosezipper >=0.2 && <1
   hs-source-dirs:      src
   default-language:    Haskell2010
 
diff --git a/bbcode/thermoprint-bbcode.nix b/bbcode/thermoprint-bbcode.nix
index 5521b10..c379053 100644
--- a/bbcode/thermoprint-bbcode.nix
+++ b/bbcode/thermoprint-bbcode.nix
@@ -1,14 +1,16 @@
-{ mkDerivation, attoparsec, base, hspec, QuickCheck
-, quickcheck-instances, stdenv, text
+{ mkDerivation, attoparsec, base, containers, hspec, QuickCheck
+, quickcheck-instances, rosezipper, stdenv, text
 }:
 mkDerivation {
   pname = "thermoprint-bbcode";
   version = "0.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    attoparsec base QuickCheck quickcheck-instances text
+    attoparsec base containers rosezipper text
+  ];
+  testHaskellDepends = [
+    attoparsec base hspec QuickCheck quickcheck-instances text
   ];
-  testHaskellDepends = [ attoparsec base hspec QuickCheck text ];
   homepage = "http://dirty-haskell.org/tags/thermoprint.html";
   description = "A parser for a subset of bbcode compatible with thermoprint-spec";
   license = stdenv.lib.licenses.publicDomain;