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

import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Foldable (foldMap, foldr)
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import Data.Sequence (Seq)
import Data.Ord (Ord)
import Data.Text (Text)
import Data.Text.Buildable (Buildable(..))
import Data.Text.Lazy.Builder (Builder)
import Data.TreeSeq.Strict (Tree(..), Trees)
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.Cell
import Language.TCT.Elem

-- * Type 'Token'
type Token = Tree (Cell TokenKey) (Cell TokenValue)

-- ** Type 'Tokens'
type Tokens = Seq Token

-- ** Type 'TokenKey'
type TokenKey = 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,Ord,Show)

-- ** Type 'TokenValue'
data TokenValue
 =   TokenPlain  !Text
 |   TokenTag    !Tag
 |   TokenEscape !Char
 |   TokenLink   !Text
 deriving (Eq,Ord,Show)

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

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

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

tokensPlainEmpty :: Tokens
tokensPlainEmpty = tokens1 $ Tree0 $ cell1 $ TokenPlain ""

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

unTokenElem :: Tokens -> Maybe (Cell (Elem,Attrs,Tokens))
unTokenElem toks =
	case toList $ Seq.dropWhileR isTokenWhite toks of
	 [TreeN (Cell bp ep (PairElem e as)) ts] -> Just (Cell bp ep (e,as,ts))
	 _ -> Nothing

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

pairBorders :: TokenKey -> Tokens -> (Text,Text)
pairBorders p ts =
	case p of
	 PairElem e attrs ->
		if Seq.null ts
		then ("<"<>e<>foldMap f attrs<>"/>","")
		else ("<"<>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     -> ("[","]")


{-
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<>buildTokens ts<>build o
		where (o,c) = pairBorders p ts

buildTokens :: Tokens -> Builder
buildTokens = foldr (\a -> (<> build (unCell a))) ""

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
-}