{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
module Hdoc.RNC.Write where

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Bool
import Data.Eq (Eq(..))
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Semigroup
import Data.Text (Text)
import Text.Show (Show(..))
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
-- import qualified Data.Text.Lazy.Builder as TLB

import Hdoc.RNC.Sym
import Hdoc.RNC.Fixity

-- * Type 'Writer'
newtype Writer a
 =      Writer { unWriter :: RuleMode -> (Infix, Side) -> Pair -> TL.Text }

instance Show (Writer a) where
	show = TL.unpack . runWriter
instance Functor Writer where
	fmap _f (Writer x) = Writer x
instance Applicative Writer where
	pure _ = writeText $ "\"\""
	Writer f <*> Writer x = Writer $ \rm po pp ->
		pairInfix pp po op $
		TL.intercalate ", " $
		List.filter (not . TL.null) $
		 [ f rm (op, SideL) pp
		 , x rm (op, SideR) pp ]
		where op = infixB SideL 10
instance Sym_Rule Writer where
	rule n (Writer w) = Writer $ \rm po pp ->
		case rm of
		 RuleMode_Body -> w RuleMode_Ref po pp
		 RuleMode_Ref  -> TL.fromStrict n
type instance Perm Writer = Compose [] Writer
instance Sym_Interleaved Writer where
	interleaved (Compose []) = writeText "empty"
	interleaved (Compose [Writer w]) = Writer w
	interleaved (Compose l@(_:_)) = Writer $ \rm po pp ->
		pairInfix pp po op $
		TL.intercalate " & " $
		(unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
		where op = infixB SideL 2
	_f <$$> Writer w         = Compose [Writer w]
	_f <$?> (_,Writer w)     = Compose [Writer $ unWriter $ optional $ Writer w]
	_f <$*> Writer w         = Compose [Writer $ unWriter $ many (Writer w)]
	Compose ws <||> Writer w = Compose (Writer . unWriter <$> ws <> [Writer w])
	Compose ws <|?> (_,Writer w) =
		Compose ((Writer . unWriter <$> ws) <>
		[Writer $ unWriter $ optional $ Writer w])
	Compose ws <|*> (Writer w) =
		Compose (Writer . unWriter <$> ws <>
		[Writer $ unWriter $ many $ Writer w])
instance Sym_RNC Writer where
	element n (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		"element \""<>TL.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
		where op = infixN 10
	anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		"anyElem "<>w rm (op,SideR) PairBrace
		where op = infixN 10
	attribute n (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		"attribute \""<>TL.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
		where op = infixN 10
	try w    = w
	fail     = writeText "fail"
	comment  = writeText "comment"
	text     = writeText "text"
	none     = writeText "empty"
	any      = writeText "any"
	int      = writeText "xsd:int" -- FIXME: is it useful to use the xsd: namespace?
	rational = writeText "rational"
	nat      = writeText "nat"
	nat1     = writeText "nat1"
	-- anyElem r = Writer $ \_rm _po -> "empty"
	
	Writer wl <|> Writer wr = Writer $ \rm po pp ->
		pairInfix pp po op $
		wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
		where op = infixB SideL 2
	choice [] = writeText "empty"
	choice [w] = w
	choice l@(_:_) = Writer $ \rm po pp ->
		pairInfix pp po op $
		TL.intercalate " | " $
		(unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
		where op = infixB SideL 2
	many (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		w rm (op, SideL) PairParen <> "*"
		where op = infixN 10
	some (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		w rm (op, SideL) PairParen <> "+"
		where op = infixN 10
	option _x (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		w rm (op, SideL) PairParen <> "?"
		where op = infixN 10
	optional (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		w rm (op, SideL) PairParen <> "?"
		where op = infixN 10

-- | Get textual rendition of given 'Writer'.
runWriter :: Writer a -> TL.Text
runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen

-- | Get textual rendition of given 'RuleWriter'.
renderWriter :: RuleWriter a -> TL.Text
renderWriter = runWriter . unRuleWriter

-- | 'Writer' returns a constant rendition.
writeText :: TL.Text -> Writer a
writeText t = Writer $ \_rm _op _pp -> t

-- ** Type 'RuleMode'
data RuleMode
 =   RuleMode_Body -- ^ Request to generate the body of the rule.
 |   RuleMode_Ref  -- ^ Request to generate a reference to the rule.
 deriving (Eq, Show)

-- * Type 'RuleWriter'
newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
 deriving (Functor, Applicative)
instance Sym_Rule RuleWriter where
	rule n = ruleWriter (writeText $ TL.fromStrict n)
deriving instance Sym_RuleWriter RuleWriter
type instance Perm RuleWriter = Compose [] RuleWriter
instance Sym_Interleaved RuleWriter where
	interleaved (Compose l)          = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
	f <$$> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
	f <$?> (a,RuleWriter w)          = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
	f <$*> RuleWriter w              = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
	Compose ws <||> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
	Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
	Compose ws <|*> RuleWriter w     = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
deriving instance Sym_RNC RuleWriter

-- ** Class 'Sym_RuleWriter'
-- | Symantics for rendering 'Writer' rules.
-- 
-- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
-- * 'argWriter' renders an argument.
class Sym_RuleWriter g where
	ruleWriter :: Writer () -> g a -> RuleWriter a
	argWriter  :: Text -> g a
instance Sym_RuleWriter Writer where
	argWriter = writeText . TL.fromStrict
	ruleWriter call body =
		RuleWriter $ Writer $ \rm po pp ->
			case rm of
			 RuleMode_Ref -> unWriter call rm po pp
			 RuleMode_Body ->
				TL.intercalate " "
				 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
				 , "="
				 , unWriter body RuleMode_Ref (infixN0,SideR) pp
				 ]