]> Git — Sourcephile - haskell/symantic-xml.git/blob - Symantic/RNC/Write.hs
cabal: add a warning
[haskell/symantic-xml.git] / 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