{-# 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