{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.TCT.Token where

import Control.Monad (Monad(..))
import Data.Bool (Bool(..))
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Monoid (Monoid(..))
import Data.Function ((.))
import Data.Foldable (Foldable(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|), (|>))
import Data.Text (Text)
import Data.Text.Buildable (Buildable(..))
import Text.Show (Show(..))
import qualified Data.Sequence as Seq
import qualified Data.Text as Text

import Language.TCT.Elem

-- * Type 'Token'
data Token
 =   Tokens (Seq Token)
 |   TokenPlain Text
 |   TokenGroup Group Token
 |   TokenTag Tag
 |   TokenEscape Char
 |   TokenLink Text
 deriving (Eq, Show)
instance Semigroup Token where
	TokenPlain (Text.null -> True) <> y = y
	x <> TokenPlain (Text.null -> True) = x
	
	TokenPlain x <> TokenPlain y = TokenPlain (x<>y)
	Tokens (Seq.viewr -> xs:>x@TokenPlain{}) <> y@TokenPlain{} = Tokens (xs|>(x<>y))
	x@TokenPlain{} <> Tokens (Seq.viewl -> y@TokenPlain{}:<ys) = Tokens ((x<>y)<|ys)
	
	Tokens x <> Tokens y = Tokens (x<>y)
	Tokens x <> y = Tokens (x|>y)
	x <> Tokens y = Tokens (x<|y)
	
	x <> y = Tokens (Seq.fromList [x,y])
instance Monoid Token where
	mempty  = TokenPlain mempty
	mappend = (<>)
instance Buildable Token where
	build (TokenPlain t) = build t
	build (Tokens ms) = foldr (\a b -> b <> build a) "" ms
	build (TokenTag t) = "#"<>build t
	build (TokenLink lnk) = build lnk
	build (TokenEscape c) = "\\"<>build c
	build (TokenGroup g m) =
		let (o,c) = groupBorders g m in
		build c<>build m<>build o

-- | Build a 'Token' from many.
tokens :: [Token] -> Token
tokens = Tokens . Seq.fromList

-- | Remove 'Tokens' in given 'Token'
-- by flattening all 'Token's in a single 'Seq'.
unTokens :: Token -> Seq Token
unTokens (Tokens ts) = ts >>= unTokens
unTokens tok = Seq.singleton tok

-- ** Type 'Tag'
type Tag = Text

-- ** Type 'Group'
data Group
 =   GroupHash            -- ^ @#value#@
 |   GroupElem Elem Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
 |   GroupStar            -- ^ @*value*@
 |   GroupSlash           -- ^ @/value/@
 |   GroupUnderscore      -- ^ @_value_@
 |   GroupDash            -- ^ @-value-@
 |   GroupBackquote       -- ^ @`value`@
 |   GroupSinglequote     -- ^ @'value'@
 |   GroupDoublequote     -- ^ @"value"@
 |   GroupFrenchquote     -- ^ @«value»@
 |   GroupParen           -- ^ @(value)@
 |   GroupBrace           -- ^ @{value}@
 |   GroupBracket         -- ^ @[value]@
 deriving (Eq, Show)

groupBorders :: Group -> Token -> (Text,Text)
groupBorders g m =
	case g of
	 GroupElem e attrs ->
		case m of
		 Tokens ms | Seq.null ms -> ("<"<>e<>foldMap f attrs<>"/>","")
		 _ -> ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
		where f (attr_white,Attr{..}) =
			attr_white <>
			attr_name  <>
			attr_open  <>
			attr_value <>
			attr_close
	 GroupHash        -> ("#","#")
	 GroupStar        -> ("*","*")
	 GroupSlash       -> ("/","/")
	 GroupUnderscore  -> ("_","_")
	 GroupDash        -> ("-","-")
	 GroupBackquote   -> ("`","`")
	 GroupSinglequote -> ("'","'")
	 GroupDoublequote -> ("\"","\"")
	 GroupFrenchquote -> ("«","»")
	 GroupParen       -> ("(",")")
	 GroupBrace       -> ("{","}")
	 GroupBracket     -> ("[","]")