Write.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Symantic.RNC.Write
 ( module Symantic.RNC.Write
 , module Symantic.RNC.Write.Fixity
 , module Symantic.RNC.Write.Namespaces
 ) where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad
import Data.Bool
import Data.Function (($), (.), id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Semigroup (Semigroup(..))
import Data.String (IsString(..))
import Text.Show (Show(..))
import qualified Data.HashMap.Strict as HM
import qualified Data.List as List
import qualified Data.Text.Lazy as TL
-- import qualified Data.Text.Lazy.Builder as TLB

import Symantic.RNC.Sym
import Symantic.RNC.Write.Fixity
import Symantic.RNC.Write.Namespaces
import qualified Symantic.XML as XML

-- | Get textual rendition of given 'RuleWriter'.
writeRNC :: [NS a] -> [Writer a] -> TL.Text
writeRNC ns ws =
	let namespaces@XML.Namespaces{..} = runNS ns in
	TL.unlines $ List.concat
	 [ [ "default namespace = \""<>XML.unNamespace namespaces_default<>"\""
		 | not $ TL.null $ XML.unNamespace namespaces_default
		 ]
	 , [ "namespace "<>p<>" = \""<>n<>"\""
		 | (XML.Namespace n, XML.NCName p) <- HM.toList namespaces_prefixes
		 ]
	 , runWriter namespaces <$> ws
	 ]

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

-- | Get textual rendition of given 'Writer'.
runWriter :: XML.Namespaces XML.NCName -> Writer a -> TL.Text
runWriter ns (Writer w) =
	w ns RuleMode_Def (infixN0, SideL) pairParen

coerceWriter :: Writer a -> Writer b
coerceWriter = Writer . unWriter
{-# INLINE coerceWriter #-}

{-
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 $ \ns rm po pp ->
		pairIfNeeded pp po op $
		TL.intercalate ", " $
		List.filter (not . TL.null) $
		 [ f ns rm (op, SideL) pairParen
		 , x ns rm (op, SideR) pairParen ]
		where op = infixB SideL 2
instance Alternative Writer where
	empty = writeText "empty"
	Writer wl <|> Writer wr = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		wl ns rm (op, SideL) pairParen <> " | " <> wr ns rm (op, SideR) pairParen
		where op = infixB SideL 2
	many (Writer w) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		w ns rm (op, SideL) pairParen <> "*"
		where op = infixN 9
	some (Writer w) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		w ns rm (op, SideL) pairParen <> "+"
		where op = infixN 9
instance Sym_Rule Writer where
	rule n wr@(Writer w) = Writer $ \ns rm po pp ->
		case rm of
		 RuleMode_Ref ->
			pairIfNeeded pp po op $
			fromString n
			where op = infixN 10
		 RuleMode_Body -> w ns RuleMode_Ref po pp
		 RuleMode_Def ->
			TL.intercalate " "
			 [ fromString n
			 , "="
			 , unWriter (rule n wr) ns RuleMode_Body (infixN0, SideR) pp
			 ]
	arg n =
		Writer $ \_ns rm _po _pp ->
			case rm of
			 RuleMode_Ref  -> fromString n
			 RuleMode_Body -> ""
			 RuleMode_Def  -> ""
type instance Permutation Writer = Compose [] Writer
instance Sym_Permutation Writer where
	runPermutation (Compose []) = writeText "empty"
	runPermutation (Compose [Writer w]) = Writer w
	runPermutation (Compose l@(_:_)) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		TL.intercalate " & " $
		List.filter (not . TL.null) $
		(unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen
		where op = infixB SideL 1
	toPermutation = Compose . pure
	toPermutationWithDefault _ = Compose . pure
instance Sym_RNC Writer where
	namespace _p _n = writeText ""
	element n (Writer w) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		"element "<>TL.pack (show $ XML.prefixifyQName ns n)
		 <>" "<>w ns rm (op,SideR) pairBrace
		where op = infixN 10
	anyElem (XML.Namespace n) f = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		(if TL.null n then "" else n<>":") <>
		"* "<>w ns rm (op,SideR) pairBrace
		where
		op = infixN 0
		Writer w = f ""
	attribute n (Writer w) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		"attribute "<>TL.pack (show $ XML.prefixifyQName ns n)
		 <>" "<>w ns rm (op,SideR) pairBrace
		where op = infixN 10
	try         = id
	fail        = writeText "fail"
	escapedText = writeText "text"
	text        = writeText "text"
	any         = writeText "any"
	choice []   = writeText "empty"
	choice [w]  = w
	choice l@(_:_) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		TL.intercalate " | " $
		(unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen
		where op = infixB SideL 2
	option _x (Writer w) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		w ns rm (op, SideL) pairParen <> "?"
		where op = infixN 9
	optional (Writer w) = Writer $ \ns rm po pp ->
		pairIfNeeded pp po op $
		w ns rm (op, SideL) pairParen <> "?"
		where op = infixN 9
	manySeq = coerceWriter . many
	someSeq = coerceWriter . some

-- | 'Writer' returns a constant rendition.
writeText :: TL.Text -> Writer a
writeText t = Writer $ \_ns _rm po pp ->
	pairIfNeeded pp po op t
	where op = infixN 10