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

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

import Data.Text (Text)

import GHC.Generics (Generic)
import Control.Exception (Exception)
import Data.Typeable (Typeable)

import Control.Monad (unless)
import Data.Function (on)

import Text.BBCode.Lexer (BBToken(..), token)

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]@
--
-- > (==) `on` CI.mk
matches = (==) `on` CI.mk

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 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, 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 BBLabel -> Either TreeError (TreePos Empty BBLabel)
    close tag pos = do
      pos' <- maybe (Left $ LeftoverClose tag) Right $ Z.parent pos
      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'