{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Language.DTC.RNC where

import Control.Applicative (Applicative(..))
import Control.Monad
import Data.Semigroup hiding (option)
import Data.String (IsString(..))
import Data.Text (Text)
import Prelude hiding (any)
import qualified Data.Bool as Bool
import qualified Data.Text as Text

-- * Type 'RNC'
-- | Relax NG Compact
newtype RNC a = RNC { unRNC :: RuleMode -> (Infix, Side) -> Text }
instance Show (RNC a) where
	show = Text.unpack . runRNC
instance Functor RNC where
	fmap _f (RNC x) = RNC x
instance Applicative RNC where
	pure _ = rnc_const $ "\"\""
	RNC f <*> RNC x = RNC $ \bo po -> parenInfix po op $
		f bo (op, SideL) <> ", " <> x bo (op, SideR)
		where op = infixB SideL 10

-- ** Class 'Sym_Rule'
class Sym_Rule g where
	rule :: Text -> Rule (g a)
	rule _n = id
instance Sym_Rule RuleRNC where
	rule n = ruleRNC (rnc_const n)
instance Sym_Rule RNC where
	rule n g = RNC $ \rm po ->
		case rm of
		 RuleMode_Body -> unRNC g RuleMode_Ref po
		 RuleMode_Ref  -> n

-- | Get textual rendition of given 'RNC'.
runRNC :: RNC a -> Text
runRNC (RNC g) = g RuleMode_Body (infixN0, SideL)

-- | Get textual rendition of given 'RuleRNC'.
renderRNC :: RuleRNC a -> Text
renderRNC = runRNC . unRuleRNC

-- | 'RNC' returns a constant rendition.
rnc_const :: Text -> RNC a
rnc_const t = RNC $ \_rm _op -> 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 'Rule'
type Rule a = a -> a

-- * Type 'RuleRNC'
newtype RuleRNC a = RuleRNC { unRuleRNC :: RNC a }
 deriving (Functor, Applicative)
deriving instance Sym_RuleRNC RuleRNC

-- ** Class 'Sym_RuleRNC'
-- | Symantics for rendering 'RNC' rules.
-- 
-- * 'ruleRNC' renders a rule, either its body or a reference to it, according to 'RuleMode'.
-- * 'argRNC' renders an argument.
class Sym_RuleRNC g where
	ruleRNC :: RNC () -> g a -> RuleRNC a
	argRNC  :: Text -> g a
instance Sym_RuleRNC RNC where
	argRNC = rnc_const
	ruleRNC call body =
		RuleRNC $ RNC $ \mo po ->
			case mo of
			 RuleMode_Ref -> unRNC call mo po
			 RuleMode_Body ->
				Text.intercalate " "
				 [ unRNC call RuleMode_Ref (infixN0, SideL)
				 , "="
				 , unRNC body RuleMode_Ref (infixN0, SideR)
				 ]