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