Symantic/RNC/Write.hs

   1 {-# LANGUAGE TypeFamilies #-}
   2 {-# LANGUAGE OverloadedStrings #-}
   3 module Symantic.RNC.Write
   4  ( module Symantic.RNC.Write
   5  , module Symantic.RNC.Write.Fixity
   6  , module Symantic.RNC.Write.Namespaces
   7  ) where
   8
   9 import Control.Applicative (Applicative(..), Alternative(..))
  10 import Control.Monad
  11 import Data.Bool
  12 import Data.Function (($), (.), id)
  13 import Data.Functor ((<$>))
  14 import Data.Functor.Compose (Compose(..))
  15 import Data.Semigroup (Semigroup(..))
  16 import Data.String (IsString(..))
  17 import Text.Show (Show(..))
  18 import qualified Data.HashMap.Strict as HM
  19 import qualified Data.List as List
  20 import qualified Data.Text.Lazy as TL
  21 -- import qualified Data.Text.Lazy.Builder as TLB
  22
  23 import Symantic.RNC.Sym
  24 import Symantic.RNC.Write.Fixity
  25 import Symantic.RNC.Write.Namespaces
  26 import qualified Symantic.XML as XML
  27
  28 -- | Get textual rendition of given 'RuleWriter'.
  29 writeRNC :: [NS a] -> [Writer a] -> TL.Text
  30 writeRNC ns ws =
  31         let namespaces@XML.Namespaces{..} = runNS ns in
  32         TL.unlines $ List.concat
  33          [ [ "default namespace = \""<>XML.unNamespace namespaces_default<>"\""
  34                  | not $ TL.null $ XML.unNamespace namespaces_default
  35                  ]
  36          , [ "namespace "<>p<>" = \""<>n<>"\""
  37                  | (XML.Namespace n, XML.NCName p) <- HM.toList namespaces_prefixes
  38                  ]
  39          , runWriter namespaces <$> ws
  40          ]
  41
  42 -- * Type 'Writer'
  43 newtype Writer a
  44  = Writer { unWriter :: XML.Namespaces XML.NCName ->
  45                         RuleMode ->
  46                         (Infix, Side) ->
  47                         Pair -> TL.Text }
  48
  49 -- | Get textual rendition of given 'Writer'.
  50 runWriter :: XML.Namespaces XML.NCName -> Writer a -> TL.Text
  51 runWriter ns (Writer w) =
  52         w ns RuleMode_Def (infixN0, SideL) pairParen
  53
  54 coerceWriter :: Writer a -> Writer b
  55 coerceWriter = Writer . unWriter
  56 {-# INLINE coerceWriter #-}
  57
  58 {-
  59 instance Show (Writer a) where
  60         show = TL.unpack . runWriter
  61 -}
  62 instance Functor Writer where
  63         fmap _f (Writer x) = Writer x
  64 instance Applicative Writer where
  65         pure _ = writeText $ "\"\""
  66         Writer f <*> Writer x = Writer $ \ns rm po pp ->
  67                 pairIfNeeded pp po op $
  68                 TL.intercalate ", " $
  69                 List.filter (not . TL.null) $
  70                  [ f ns rm (op, SideL) pairParen
  71                  , x ns rm (op, SideR) pairParen ]
  72                 where op = infixB SideL 2
  73 instance Alternative Writer where
  74         empty = writeText "empty"
  75         Writer wl <|> Writer wr = Writer $ \ns rm po pp ->
  76                 pairIfNeeded pp po op $
  77                 wl ns rm (op, SideL) pairParen <> " | " <> wr ns rm (op, SideR) pairParen
  78                 where op = infixB SideL 2
  79         many (Writer w) = Writer $ \ns rm po pp ->
  80                 pairIfNeeded pp po op $
  81                 w ns rm (op, SideL) pairParen <> "*"
  82                 where op = infixN 9
  83         some (Writer w) = Writer $ \ns rm po pp ->
  84                 pairIfNeeded pp po op $
  85                 w ns rm (op, SideL) pairParen <> "+"
  86                 where op = infixN 9
  87 instance Sym_Rule Writer where
  88         rule n wr@(Writer w) = Writer $ \ns rm po pp ->
  89                 case rm of
  90                  RuleMode_Ref ->
  91                         pairIfNeeded pp po op $
  92                         fromString n
  93                         where op = infixN 10
  94                  RuleMode_Body -> w ns RuleMode_Ref po pp
  95                  RuleMode_Def ->
  96                         TL.intercalate " "
  97                          [ fromString n
  98                          , "="
  99                          , unWriter (rule n wr) ns RuleMode_Body (infixN0, SideR) pp
 100                          ]
 101         arg n =
 102                 Writer $ \_ns rm _po _pp ->
 103                         case rm of
 104                          RuleMode_Ref  -> fromString n
 105                          RuleMode_Body -> ""
 106                          RuleMode_Def  -> ""
 107 type instance Permutation Writer = Compose [] Writer
 108 instance Sym_Permutation Writer where
 109         runPermutation (Compose []) = writeText "empty"
 110         runPermutation (Compose [Writer w]) = Writer w
 111         runPermutation (Compose l@(_:_)) = Writer $ \ns rm po pp ->
 112                 pairIfNeeded pp po op $
 113                 TL.intercalate " & " $
 114                 List.filter (not . TL.null) $
 115                 (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen
 116                 where op = infixB SideL 1
 117         toPermutation = Compose . pure
 118         toPermutationWithDefault _ = Compose . pure
 119 instance Sym_RNC Writer where
 120         namespace _p _n = writeText ""
 121         element n (Writer w) = Writer $ \ns rm po pp ->
 122                 pairIfNeeded pp po op $
 123                 "element "<>TL.pack (show $ XML.prefixifyQName ns n)
 124                  <>" "<>w ns rm (op,SideR) pairBrace
 125                 where op = infixN 10
 126         anyElem (XML.Namespace n) f = Writer $ \ns rm po pp ->
 127                 pairIfNeeded pp po op $
 128                 (if TL.null n then "" else n<>":") <>
 129                 "* "<>w ns rm (op,SideR) pairBrace
 130                 where
 131                 op = infixN 0
 132                 Writer w = f ""
 133         attribute n (Writer w) = Writer $ \ns rm po pp ->
 134                 pairIfNeeded pp po op $
 135                 "attribute "<>TL.pack (show $ XML.prefixifyQName ns n)
 136                  <>" "<>w ns rm (op,SideR) pairBrace
 137                 where op = infixN 10
 138         try         = id
 139         fail        = writeText "fail"
 140         escapedText = writeText "text"
 141         text        = writeText "text"
 142         any         = writeText "any"
 143         choice []   = writeText "empty"
 144         choice [w]  = w
 145         choice l@(_:_) = Writer $ \ns rm po pp ->
 146                 pairIfNeeded pp po op $
 147                 TL.intercalate " | " $
 148                 (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen
 149                 where op = infixB SideL 2
 150         option _x (Writer w) = Writer $ \ns rm po pp ->
 151                 pairIfNeeded pp po op $
 152                 w ns rm (op, SideL) pairParen <> "?"
 153                 where op = infixN 9
 154         optional (Writer w) = Writer $ \ns rm po pp ->
 155                 pairIfNeeded pp po op $
 156                 w ns rm (op, SideL) pairParen <> "?"
 157                 where op = infixN 9
 158         manySeq = coerceWriter . many
 159         someSeq = coerceWriter . some
 160
 161 -- | 'Writer' returns a constant rendition.
 162 writeText :: TL.Text -> Writer a
 163 writeText t = Writer $ \_ns _rm po pp ->
 164         pairIfNeeded pp po op t
 165         where op = infixN 10