]> Git — Sourcephile - haskell/symantic-xml.git/blob - Language/Symantic/RNC/Write.hs
Add XML.Write
[haskell/symantic-xml.git] / 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 text = writeText "text"
148 any = writeText "any"
149 choice [] = writeText "empty"
150 choice [w] = w
151 choice l@(_:_) = Writer $ \ns rm po pp ->
152 pairIfNeeded pp po op $
153 TL.intercalate " | " $
154 (unWriter <$> l) <*> pure ns <*> pure rm <*> pure (op, SideL) <*> pure pairParen
155 where op = infixB SideL 2
156 option _x (Writer w) = Writer $ \ns rm po pp ->
157 pairIfNeeded pp po op $
158 w ns rm (op, SideL) pairParen <> "?"
159 where op = infixN 9
160 optional (Writer w) = Writer $ \ns rm po pp ->
161 pairIfNeeded pp po op $
162 w ns rm (op, SideL) pairParen <> "?"
163 where op = infixN 9
164 manySeq = coerceWriter . many
165 someSeq = coerceWriter . some
166
167 -- | 'Writer' returns a constant rendition.
168 writeText :: TL.Text -> Writer a
169 writeText t = Writer $ \_ns _rm po pp ->
170 pairIfNeeded pp po op t
171 where op = infixN 10