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

import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Foldable (foldMap, foldr)
import Data.Function ((.))
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq, ViewL(..), ViewR(..), (<|))
import Data.Text (Text)
import Data.Text.Buildable (Buildable(..))
import GHC.Exts (IsList(..))
import Text.Show (Show(..))
import qualified Data.Char as Char
import qualified Data.Sequence as Seq
import qualified Data.Text as Text

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
instance IsList Tokens where
	type Item Tokens = Token
	fromList = Tokens . fromList
	toList (Tokens ts) = toList ts

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

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

-- | Build 'Tokens' from one 'Token'.
tokens1 :: Token -> Tokens
tokens1 = Tokens . Seq.singleton

tokensPlainEmpty :: Tokens
tokensPlainEmpty = Tokens (Seq.singleton (TokenPlain ""))

isTokenWhite :: Token -> Bool
isTokenWhite (TokenPlain t) = Text.all Char.isSpace t
isTokenWhite _              = False

isTokenElem :: Tokens -> Bool
isTokenElem (Tokens ts) =
	case toList (Seq.dropWhileR isTokenWhite ts) of
	 [TokenPair PairElem{} _] -> True
	 _ -> False

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