{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}

module Text.BBCode
       ( TreeError(..)
       , rose
       , matches
       ) where

import Data.Text (Text)

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'