{-# LANGUAGE OverloadedStrings, OverloadedLists, RankNTypes, ImpredicativeTypes #-}

module BBCode
       ( parse
       , make
       ) where

import Thermoprint

import BBCode.Tokenizer
import BBCode.Syntax

import Data.Maybe
import Data.Monoid
import Data.Either
import Data.Bifunctor
import Data.List
import Data.Ord
import Data.Foldable

import Data.Function (on)

import           Data.CaseInsensitive  ( CI )
import qualified Data.CaseInsensitive as CI

import           Data.Map  ( Map )
import qualified Data.Map as Map

import Prelude hiding (takeWhile)

import Debug.Trace

knownTags :: Map (CI String) (Either (Block String -> Block String) (Inline String -> Inline String))
knownTags = [ ("center", Left Center)
            , ("u", Right Underline)
            ]

isBlock, isInline :: String -> Bool
isBlock = testTag isLeft
isInline = testTag isRight
testTag f k = fromMaybe False (f <$> Map.lookup (CI.mk k) knownTags)

data Decorated c = Decorated c [String]
                 deriving (Show, Eq)

make :: Block String -> String
make (Over blocks) = concat $ map make blocks
make (Center block) = "[center]" ++ make block ++ "[/center]\n"
make (Paragraph inline) = make' inline ++ "\n"

make' :: Inline String -> String
make' (Beside inlines) = concat $ map make' inlines
make' (Underline inline) = "[u]" ++ make' inline ++ "[/u]"
make' (Cooked c) = c
make' (Raw _) = error "Cannot transform block containing raw data to bbcode"

parse :: String -> Either String (Block String)
parse input = (remerge . blockify <$> (tokenize input >>= treeify)) >>= semantics

blockify :: ContentForest -> [Decorated String]
blockify = map sortDeco . concat . map (blockify' [])
  where
    blockify' _ Empty = []
    blockify' initial (Content str) = [str `Decorated` initial]
    blockify' initial (Tagged cs tag) = concat $ map (blockify' $ tag : initial) cs
    sortDeco :: Decorated c -> Decorated c
    sortDeco (Decorated c tags) = Decorated c $ (nubBy ((==) `on` CI.mk) . sortBy blockiness) tags
    blockiness :: String -> String -> Ordering
    blockiness a b = comparing isBlock a b <> comparing CI.mk a b -- sort also alphabetically for the benefit of remerge

remerge :: [Decorated String] -> ContentForest
remerge [] = []
remerge [(Decorated c deco)] = [appEndo applyDeco $ Content c]
  where
    applyDeco = foldMap (\t -> Endo (\c -> Tagged [c] t)) $ reverse deco
remerge xs = concat $ map toTree $ groupLasts xs
  where
    groupLasts = groupBy ((==) `on` (listToMaybe . reverse . (\(Decorated _ ds) -> ds)))
    -- toTree :: [Decorated String] -> [ContentTree]
    toTree [] = []
    toTree (x@(Decorated _ []):xs) = map (Content . (\(Decorated c []) -> c)) (x:xs)
    toTree (x@(Decorated _ ds):xs) = [Tagged content tag]
      where
        tag = last ds
        content = toTree $ map stripLast (x:xs)
        stripLast (Decorated c ds) = Decorated c (init ds)

unknownTag :: forall a. String -> Either String a
unknownTag tag = Left $ "Unknown tag: " ++ tag

semantics :: ContentForest -> Either String (Block String)
semantics forest = Over <$> mapM semantics' forest

semantics' :: ContentTree -> Either String (Block String)
semantics' Empty = Right $ Over []
semantics' (Content str) = Right $ Paragraph (Cooked str)
semantics' (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
  Nothing -> unknownTag tag
  Just (Left f) -> Over . map f <$> mapM semantics' cs
  Just (Right f) -> Paragraph . Beside . map f<$> mapM iSemantics cs

iSemantics :: ContentTree -> Either String (Inline String)
iSemantics Empty = Right $ Beside []
iSemantics (Content str) = Right $ Cooked str
iSemantics (Tagged cs tag) = case Map.lookup (CI.mk tag) knownTags of
  Nothing -> unknownTag tag
  Just (Left f) -> error "Known inline tag sorted within block"
  Just (Right f) -> Beside . map f <$> mapM iSemantics cs