Language/Symantic/RNC/Write.hs

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