{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
module Hdoc.TCT.Read.Elem where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad(..))
import Data.Bool
import Data.Char (Char)
import Data.Eq (Eq(..))
import Data.Function (($))
import Data.Functor ((<$>), (<$))
import Data.Maybe (Maybe(..))
import Data.Semigroup (Semigroup(..))
import qualified Data.Char as Char
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Char as P
import qualified Data.Text.Lazy as TL

import Hdoc.TCT.Debug
import Hdoc.TCT.Elem
import Hdoc.TCT.Tree
import Hdoc.TCT.Read.Cell

-- * Word
p_Spaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Spaces = P.takeWhileP (Just "Space") Char.isSpace
p_Spaces1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Spaces1 = P.takeWhile1P (Just "Space") Char.isSpace
p_HSpaces :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_HSpaces = P.takeWhileP (Just "HSpace") (==' ')
p_Digits :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Digits = P.takeWhileP (Just "Digit") Char.isDigit
p_Digits1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_Digits1 = P.takeWhile1P (Just "Digit1") Char.isDigit
p_AlphaNums :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_AlphaNums = P.takeWhileP (Just "AlphaNum") Char.isAlphaNum
p_AlphaNums1 :: P.Tokens s ~ TL.Text => Parser e s TL.Text
p_AlphaNums1 = P.takeWhile1P (Just "AlphaNum1") Char.isAlphaNum
{-
-- NOTE: could be done with TL.Text, which has a less greedy (<>).
p_Word :: Parser e Text Text
p_Word = debugParser "Word" $ P.try p_take <|> p_copy
	where
	p_take = do
		P.notFollowedBy $ P.satisfy $ not . Char.isAlphaNum
		w <- P.takeWhile1P (Just "Word") $ \c ->
			Char.isAlphaNum c ||
			c == '_' ||
			c == '-'
		guard $ Char.isAlphaNum $ Text.last w
		return w
	p_copy =
		(<>)
		 <$> p_AlphaNums1
		 <*> P.option "" (P.try $
			(<>)
			 <$> ((Text.pack <$>) $ P.some $ P.char '_' <|> P.char '-')
			 <*> p_copy)
-}

-- * Elem
p_ElemSingle :: P.Tokens s ~ TL.Text => Parser e s Pair
p_ElemSingle = debugParser "ElemSingle" $
	PairElem
	 <$  P.char '<'
	 <*> p_ElemName
	 <*> p_ElemAttrs
	 <*  P.string "/>"

p_ElemOpen :: P.Tokens s ~ TL.Text => Parser e s Pair
p_ElemOpen = debugParser "ElemOpen" $
	PairElem
	 <$  P.char '<'
	 <*> p_ElemName
	 <*> p_ElemAttrs
	 <*  P.char '>'

p_ElemName :: P.Tokens s ~ TL.Text => Parser e s ElemName
p_ElemName = p_AlphaNums1
 -- TODO: namespace

p_ElemClose :: P.Tokens s ~ TL.Text => Parser e s Pair
p_ElemClose = debugParser "ElemClose" $
	(`PairElem` [])
	 <$  P.string "</"
	 <*> p_ElemName
	 <*  P.char '>'

{-
p_ElemOpenOrSingle :: Parser e Text Pair
p_ElemOpenOrSingle =
	p_ElemOpen >>= \p ->
		P.char    '>' $> LexemePairOpen p <|>
		P.string "/>" $> LexemePairAny  p
-}

-- * 'ElemAttr'
p_ElemAttrs :: P.Tokens s ~ TL.Text => Parser e s [(White,ElemAttr)]
p_ElemAttrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_ElemAttr
p_ElemAttr :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
p_ElemAttr = P.try p_ElemAttrEq <|> p_ElemAttrName

p_ElemAttrEq :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
p_ElemAttrEq =
	(\n (o,v,c) -> ElemAttr n ("="<>o) v c)
	 <$> p_ElemName
	 <*  P.char '='
	 <*> p_ElemAttrValue
p_ElemAttrName :: P.Tokens s ~ TL.Text => Parser e s ElemAttr
p_ElemAttrName =
	(\n -> ElemAttr n "" "" "")
	 <$> p_ElemName

p_ElemAttrValue :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
p_ElemAttrValue =
	p_ElemAttrValueQuote '\'' <|>
	p_ElemAttrValueQuote '"'  <|>
	p_ElemAttrValueWord

p_ElemAttrValueQuote :: Char -> P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
p_ElemAttrValueQuote q =
	(\o v c -> (TL.singleton o, v, TL.singleton c))
	 <$> P.char q
	 <*> P.takeWhile1P (Just "ElemAttrValueQuoted") (/=q)
	 <*> P.char q
p_ElemAttrValueWord :: P.Tokens s ~ TL.Text => Parser e s (TL.Text,TL.Text,TL.Text)
p_ElemAttrValueWord = do
	w <- P.takeWhile1P (Just "ElemAttrValueWord") $ \c ->
		Char.isPrint c &&
		not (Char.isSpace c) &&
		c /= '\'' &&
		c /= '"' &&
		c /= '=' &&
		c /= '/' &&
		c /= '<' &&
		c /= '>'
	return ("",w,"")