]> Git — Sourcephile - doclang.git/blob - Language/RNC/Write.hs
Fix TCT -> XML : NodePara.
[doclang.git] / Language / RNC / Write.hs
1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE StandaloneDeriving #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ViewPatterns #-}
6 module Language.RNC.Write where
7
8 import Control.Applicative (Applicative(..))
9 import Control.Monad
10 import Data.Bool
11 import Data.Functor.Compose (Compose(..))
12 import Data.Semigroup hiding (option)
13 import Data.Text (Text)
14 import Prelude hiding (any)
15 import qualified Data.Text as Text
16 import qualified Data.List as List
17
18 import Language.RNC.Sym
19 import Language.RNC.Fixity
20
21 -- * Type 'Writer'
22 newtype Writer a
23 = Writer { unWriter :: RuleMode -> (Infix, Side) -> Pair -> Text }
24
25 instance Show (Writer a) where
26 show = Text.unpack . runWriter
27 instance Functor Writer where
28 fmap _f (Writer x) = Writer x
29 instance Applicative Writer where
30 pure _ = writeText $ "\"\""
31 Writer f <*> Writer x = Writer $ \rm po pp ->
32 pairInfix pp po op $
33 Text.intercalate ", " $
34 List.filter (not . Text.null) $
35 [ f rm (op, SideL) pp
36 , x rm (op, SideR) pp ]
37 where op = infixB SideL 10
38 instance Sym_Rule Writer where
39 rule n (Writer w) = Writer $ \rm po pp ->
40 case rm of
41 RuleMode_Body -> w RuleMode_Ref po pp
42 RuleMode_Ref -> n
43 type instance Perm Writer = Compose [] Writer
44 instance Sym_Interleaved Writer where
45 interleaved (Compose []) = writeText "empty"
46 interleaved (Compose [Writer w]) = Writer w
47 interleaved (Compose l@(_:_)) = Writer $ \rm po pp ->
48 pairInfix pp po op $
49 Text.intercalate " & " $
50 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
51 where op = infixB SideL 2
52 _f <$$> Writer w = Compose [Writer w]
53 _f <$?> (_,Writer w) = Compose [Writer $ unWriter $ optional $ Writer w]
54 _f <$*> Writer w = Compose [Writer $ unWriter $ many (Writer w)]
55 Compose ws <||> Writer w = Compose (Writer . unWriter <$> ws <> [Writer w])
56 Compose ws <|?> (_,Writer w) =
57 Compose ((Writer . unWriter <$> ws) <>
58 [Writer $ unWriter $ optional $ Writer w])
59 Compose ws <|*> (Writer w) =
60 Compose (Writer . unWriter <$> ws <>
61 [Writer $ unWriter $ many $ Writer w])
62 instance Sym_RNC Writer where
63 element n (Writer w) = Writer $ \rm po pp ->
64 pairInfix pp po op $
65 "element \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
66 where op = infixN 10
67 anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
68 pairInfix pp po op $
69 "any "<>w rm (op,SideR) PairBrace
70 where op = infixN 10
71 attribute n (Writer w) = Writer $ \rm po pp ->
72 pairInfix pp po op $
73 "attribute \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
74 where op = infixN 10
75 try w = w
76 comment = writeText "comment"
77 text = writeText "text"
78 none = writeText "empty"
79 any = writeText "any"
80 int = writeText "xsd:int"
81 nat = writeText "xsd:nat"
82 nat1 = writeText "xsd:nat1"
83 -- anyElem r = Writer $ \_rm _po -> "empty"
84
85 Writer wl <|> Writer wr = Writer $ \rm po pp ->
86 pairInfix pp po op $
87 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
88 where op = infixB SideL 2
89 choice [] = writeText "empty"
90 choice [w] = w
91 choice l@(_:_) = Writer $ \rm po pp ->
92 pairInfix pp po op $
93 Text.intercalate " | " $
94 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
95 where op = infixB SideL 2
96 many (Writer w) = Writer $ \rm po pp ->
97 pairInfix pp po op $
98 w rm (op, SideL) PairParen <> "*"
99 where op = infixN 10
100 some (Writer w) = Writer $ \rm po pp ->
101 pairInfix pp po op $
102 w rm (op, SideL) PairParen <> "+"
103 where op = infixN 10
104 option _x (Writer w) = Writer $ \rm po pp ->
105 pairInfix pp po op $
106 w rm (op, SideL) PairParen <> "?"
107 where op = infixN 10
108 optional (Writer w) = Writer $ \rm po pp ->
109 pairInfix pp po op $
110 w rm (op, SideL) PairParen <> "?"
111 where op = infixN 10
112
113 -- | Get textual rendition of given 'Writer'.
114 runWriter :: Writer a -> Text
115 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
116
117 -- | Get textual rendition of given 'RuleWriter'.
118 renderWriter :: RuleWriter a -> Text
119 renderWriter = runWriter . unRuleWriter
120
121 -- | 'Writer' returns a constant rendition.
122 writeText :: Text -> Writer a
123 writeText t = Writer $ \_rm _op _pp -> t
124
125 -- ** Type 'RuleMode'
126 data RuleMode
127 = RuleMode_Body -- ^ Request to generate the body of the rule.
128 | RuleMode_Ref -- ^ Request to generate a reference to the rule.
129 deriving (Eq, Show)
130
131 -- * Type 'RuleWriter'
132 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
133 deriving (Functor, Applicative)
134 instance Sym_Rule RuleWriter where
135 rule n = ruleWriter (writeText n)
136 deriving instance Sym_RuleWriter RuleWriter
137 type instance Perm RuleWriter = Compose [] RuleWriter
138 instance Sym_Interleaved RuleWriter where
139 interleaved (Compose l) = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
140 f <$$> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
141 f <$?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
142 f <$*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
143 Compose ws <||> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
144 Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
145 Compose ws <|*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
146 deriving instance Sym_RNC RuleWriter
147
148 -- ** Class 'Sym_RuleWriter'
149 -- | Symantics for rendering 'Writer' rules.
150 --
151 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
152 -- * 'argWriter' renders an argument.
153 class Sym_RuleWriter g where
154 ruleWriter :: Writer () -> g a -> RuleWriter a
155 argWriter :: Text -> g a
156 instance Sym_RuleWriter Writer where
157 argWriter = writeText
158 ruleWriter call body =
159 RuleWriter $ Writer $ \rm po pp ->
160 case rm of
161 RuleMode_Ref -> unWriter call rm po pp
162 RuleMode_Body ->
163 Text.intercalate " "
164 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
165 , "="
166 , unWriter body RuleMode_Ref (infixN0,SideR) pp
167 ]