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

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

markups :: [Token] -> Token
markups = Tokens . Seq.fromList

-- ** 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     -> ("[","]")