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

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 Language.TCT.Elem

-- * Type 'Token'
data Token
 =   TokenPlain  Text
 |   TokenPair   Pair Tokens
 |   TokenTag    Tag
 |   TokenEscape Char
 |   TokenLink   Text
 deriving (Eq, Show)

instance Buildable Token where
	build (TokenPlain t)   = build t
	build (TokenTag t)     = "#"<>build t
	build (TokenLink lnk)  = build lnk
	build (TokenEscape c)  = "\\"<>build c
	build (TokenPair p ts) = build c<>build ts<>build o
		where (o,c) = pairBorders p ts

-- * Type 'Tokens'
newtype Tokens = Tokens (Seq Token)
 deriving (Eq, Show)

instance Semigroup Tokens where
	Tokens (Seq.viewr -> xs:>TokenPlain x) <>
	 Tokens (Seq.viewl -> TokenPlain y:<ys) =
		Tokens (xs<>(TokenPlain (x<>y)<|ys))
	Tokens x <> Tokens y = Tokens (x<>y)
instance Monoid Tokens where
	mempty  = Tokens mempty
	mappend = (<>)
instance Buildable Tokens where
	build (Tokens ts) = foldr (\a -> (<> build a)) "" ts

unTokens :: Tokens -> Seq Token
unTokens (Tokens ts) = ts

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

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

-- ** Type 'Pair'
data Pair
 =   PairHash            -- ^ @#value#@
 |   PairElem Elem Attrs -- ^ @<elem n0=v0 n1=v1>value</elem>@
 |   PairStar            -- ^ @*value*@
 |   PairSlash           -- ^ @/value/@
 |   PairUnderscore      -- ^ @_value_@
 |   PairDash            -- ^ @-value-@
 |   PairBackquote       -- ^ @`value`@
 |   PairSinglequote     -- ^ @'value'@
 |   PairDoublequote     -- ^ @"value"@
 |   PairFrenchquote     -- ^ @«value»@
 |   PairParen           -- ^ @(value)@
 |   PairBrace           -- ^ @{value}@
 |   PairBracket         -- ^ @[value]@
 deriving (Eq, Show)

pairBorders :: Pair -> Tokens -> (Text,Text)
pairBorders p ts =
	case p of
	 PairElem e attrs ->
		case ts of
		 Tokens s | Seq.null s -> ("<"<>e<>foldMap f attrs<>"/>","")
		 _ -> ("<"<>e<>foldMap f attrs<>">","</"<>e<>">")
		where f (attr_white,Attr{..}) =
			attr_white <>
			attr_name  <>
			attr_open  <>
			attr_value <>
			attr_close
	 PairHash        -> ("#","#")
	 PairStar        -> ("*","*")
	 PairSlash       -> ("/","/")
	 PairUnderscore  -> ("_","_")
	 PairDash        -> ("-","-")
	 PairBackquote   -> ("`","`")
	 PairSinglequote -> ("'","'")
	 PairDoublequote -> ("\"","\"")
	 PairFrenchquote -> ("«","»")
	 PairParen       -> ("(",")")
	 PairBrace       -> ("{","}")
	 PairBracket     -> ("[","]")