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

-- | An implementation of BBcode parsing 'Text' to a syntax tree (@'Forest' 'BBLabel'@)
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

-- | Errors in input encountered during parsing of lexed token-stream 
data TreeError = MismatchedTags Text Text -- ^ Closing tags does not match opening tags
               | ImbalancedTags Text -- ^ We found an extraneous closing tag
               deriving (Show, Eq, Generic, Typeable)

instance Exception TreeError

-- | The label of our rose-tree nodes carries the tag name and a map of attributes
type BBLabel = (Text, Maybe (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, Nothing) [])
    rose'' (BBOpen t attrs) = return . Z.children . Z.insert (Node (t, Just $ 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 $ ImbalancedTags tag) Right $ Z.parent pos
      let
        pTag = fst $ Z.label pos'
      unless (pTag `matches` tag) . Left $ MismatchedTags pTag tag -- The structure shows that this mode of failure is not logically required -- it's just nice to have
      return $ Z.nextSpace pos'