{-# 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 Symantic.RNC.Sym
import Symantic.RNC.Write.Fixity
import Symantic.RNC.Write.Namespaces
import qualified Symantic.XML as XML
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
]
newtype Writer a
= Writer { unWriter :: XML.Namespaces XML.NCName ->
RuleMode ->
(Infix, Side) ->
Pair -> TL.Text }
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 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
writeText :: TL.Text -> Writer a
writeText t = Writer $ \_ns _rm po pp ->
pairIfNeeded pp po op t
where op = infixN 10