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