]> Git — Sourcephile - doclang.git/blob - Hdoc/RNC/Write.hs
Fix nested notes and prepare for checking.
[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 int = writeText "xsd:int" -- FIXME: is it useful to use the xsd: namespace?
86 rational = writeText "rational"
87 nat = writeText "nat"
88 nat1 = writeText "nat1"
89 -- anyElem r = Writer $ \_rm _po -> "empty"
90
91 Writer wl <|> Writer wr = Writer $ \rm po pp ->
92 pairInfix pp po op $
93 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
94 where op = infixB SideL 2
95 choice [] = writeText "empty"
96 choice [w] = w
97 choice l@(_:_) = Writer $ \rm po pp ->
98 pairInfix pp po op $
99 TL.intercalate " | " $
100 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
101 where op = infixB SideL 2
102 many (Writer w) = Writer $ \rm po pp ->
103 pairInfix pp po op $
104 w rm (op, SideL) PairParen <> "*"
105 where op = infixN 10
106 some (Writer w) = Writer $ \rm po pp ->
107 pairInfix pp po op $
108 w rm (op, SideL) PairParen <> "+"
109 where op = infixN 10
110 option _x (Writer w) = Writer $ \rm po pp ->
111 pairInfix pp po op $
112 w rm (op, SideL) PairParen <> "?"
113 where op = infixN 10
114 optional (Writer w) = Writer $ \rm po pp ->
115 pairInfix pp po op $
116 w rm (op, SideL) PairParen <> "?"
117 where op = infixN 10
118
119 -- | Get textual rendition of given 'Writer'.
120 runWriter :: Writer a -> TL.Text
121 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
122
123 -- | Get textual rendition of given 'RuleWriter'.
124 renderWriter :: RuleWriter a -> TL.Text
125 renderWriter = runWriter . unRuleWriter
126
127 -- | 'Writer' returns a constant rendition.
128 writeText :: TL.Text -> Writer a
129 writeText t = Writer $ \_rm _op _pp -> t
130
131 -- ** Type 'RuleMode'
132 data RuleMode
133 = RuleMode_Body -- ^ Request to generate the body of the rule.
134 | RuleMode_Ref -- ^ Request to generate a reference to the rule.
135 deriving (Eq, Show)
136
137 -- * Type 'RuleWriter'
138 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
139 deriving (Functor, Applicative)
140 instance Sym_Rule RuleWriter where
141 rule n = ruleWriter (writeText $ TL.fromStrict n)
142 deriving instance Sym_RuleWriter RuleWriter
143 type instance Perm RuleWriter = Compose [] RuleWriter
144 instance Sym_Interleaved RuleWriter where
145 interleaved (Compose l) = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
146 f <$$> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
147 f <$?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
148 f <$*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
149 Compose ws <||> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
150 Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
151 Compose ws <|*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
152 deriving instance Sym_RNC RuleWriter
153
154 -- ** Class 'Sym_RuleWriter'
155 -- | Symantics for rendering 'Writer' rules.
156 --
157 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
158 -- * 'argWriter' renders an argument.
159 class Sym_RuleWriter g where
160 ruleWriter :: Writer () -> g a -> RuleWriter a
161 argWriter :: Text -> g a
162 instance Sym_RuleWriter Writer where
163 argWriter = writeText . TL.fromStrict
164 ruleWriter call body =
165 RuleWriter $ Writer $ \rm po pp ->
166 case rm of
167 RuleMode_Ref -> unWriter call rm po pp
168 RuleMode_Body ->
169 TL.intercalate " "
170 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
171 , "="
172 , unWriter body RuleMode_Ref (infixN0,SideR) pp
173 ]