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.Fixity
   6  , module Language.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 Language.Symantic.RNC.Sym
  24 import Language.Symantic.RNC.Write.Fixity
  25 import Language.Symantic.RNC.Write.Namespaces
  26 import qualified Language.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 Perm Writer = Compose [] Writer
 108 instance Sym_Interleaved Writer where
 109         interleaved (Compose []) = writeText "empty"
 110         interleaved (Compose [Writer w]) = Writer w
 111         interleaved (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         _f <$$> Writer w         = Compose [Writer w]
 118         _f <$?> (_,Writer w)     = Compose [coerceWriter $ optional $ Writer w]
 119         _f <$*> Writer w         = Compose [coerceWriter $ many (Writer w)]
 120         Compose ws <||> Writer w = Compose (coerceWriter <$> ws <> [Writer w])
 121         Compose ws <|?> (_,Writer w) =
 122                 Compose ((coerceWriter <$> ws) <>
 123                 [coerceWriter $ optional $ Writer w])
 124         Compose ws <|*> (Writer w) =
 125                 Compose (coerceWriter <$> ws <>
 126                 [coerceWriter $ many $ Writer w])
 127 instance Sym_RNC Writer where
 128         namespace _p _n = writeText ""
 129         element n (Writer w) = Writer $ \ns rm po pp ->
 130                 pairIfNeeded pp po op $
 131                 "element "<>TL.pack (show $ XML.prefixifyQName ns n)
 132                  <>" "<>w ns rm (op,SideR) pairBrace
 133                 where op = infixN 10
 134         anyElem (XML.Namespace n) f = Writer $ \ns rm po pp ->
 135                 pairIfNeeded pp po op $
 136                 (if TL.null n then "" else n<>":") <>
 137                 "* "<>w ns rm (op,SideR) pairBrace
 138                 where
 139                 op = infixN 0
 140                 Writer w = f ""
 141         attribute n (Writer w) = Writer $ \ns rm po pp ->
 142                 pairIfNeeded pp po op $
 143                 "attribute "<>TL.pack (show $ XML.prefixifyQName ns n)
 144                  <>" "<>w ns rm (op,SideR) pairBrace
 145                 where op = infixN 10
 146         try         = id
 147         fail        = writeText "fail"
 148         escapedText = writeText "text"
 149         text        = writeText "text"
 150         any         = writeText "any"
 151         choice []   = writeText "empty"
 152         choice [w]  = w
 153         choice l@(_:_) = Writer $ \ns rm po pp ->
 154                 pairIfNeeded pp po op $
 155                 TL.intercalate " | " $
 156                 (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen
 157                 where op = infixB SideL 2
 158         option _x (Writer w) = Writer $ \ns rm po pp ->
 159                 pairIfNeeded pp po op $
 160                 w ns rm (op, SideL) pairParen <> "?"
 161                 where op = infixN 9
 162         optional (Writer w) = Writer $ \ns rm po pp ->
 163                 pairIfNeeded pp po op $
 164                 w ns rm (op, SideL) pairParen <> "?"
 165                 where op = infixN 9
 166         manySeq = coerceWriter . many
 167         someSeq = coerceWriter . some
 168
 169 -- | 'Writer' returns a constant rendition.
 170 writeText :: TL.Text -> Writer a
 171 writeText t = Writer $ \_ns _rm po pp ->
 172         pairIfNeeded pp po op t
 173         where op = infixN 10