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

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Bool
import Data.Functor.Compose (Compose(..))
import Data.Semigroup hiding (option)
import Data.Text (Text)
import Prelude hiding (any)
import qualified Data.Text as Text
import qualified Data.List as List

import Language.RNC.Sym
import Language.RNC.Fixity

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

instance Show (Writer a) where
	show = Text.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 $
		Text.intercalate ", " $
		List.filter (not . Text.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  -> 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 $
		Text.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 \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
		where op = infixN 10
	anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		"any "<>w rm (op,SideR) PairBrace
		where op = infixN 10
	attribute n (Writer w) = Writer $ \rm po pp ->
		pairInfix pp po op $
		"attribute \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
		where op = infixN 10
	try w   = w
	comment = writeText "comment"
	text    = writeText "text"
	none    = writeText "empty"
	any     = writeText "any"
	int     = writeText "xsd:int"
	nat     = writeText "xsd:nat"
	nat1    = writeText "xsd: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 $
		Text.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 -> Text
runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen

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

-- | 'Writer' returns a constant rendition.
writeText :: 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 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
	ruleWriter call body =
		RuleWriter $ Writer $ \rm po pp ->
			case rm of
			 RuleMode_Ref -> unWriter call rm po pp
			 RuleMode_Body ->
				Text.intercalate " "
				 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
				 , "="
				 , unWriter body RuleMode_Ref (infixN0,SideR) pp
				 ]