1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE StandaloneDeriving #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ViewPatterns #-}
6 module Hdoc.RNC.Write where
8 import Control.Applicative (Applicative(..))
11 import Data.Eq (Eq(..))
12 import Data.Function (($), (.))
13 import Data.Functor ((<$>))
14 import Data.Functor.Compose (Compose(..))
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
23 import Hdoc.RNC.Fixity
27 = Writer { unWriter :: RuleMode -> (Infix, Side) -> Pair -> TL.Text }
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 ->
38 List.filter (not . TL.null) $
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 ->
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 ->
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 ->
69 "element \""<>TL.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
71 anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
73 "anyElem "<>w rm (op,SideR) PairBrace
75 attribute n (Writer w) = Writer $ \rm po pp ->
77 "attribute \""<>TL.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
80 fail = writeText "fail"
81 comment = writeText "comment"
82 text = writeText "text"
83 none = writeText "empty"
85 int = writeText "xsd:int" -- FIXME: is it useful to use the xsd: namespace?
86 rational = writeText "rational"
87 rationalPositive = writeText "rationalPositive"
89 nat1 = writeText "nat1"
90 -- anyElem r = Writer $ \_rm _po -> "empty"
92 Writer wl <|> Writer wr = Writer $ \rm po pp ->
94 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
95 where op = infixB SideL 2
96 choice [] = writeText "empty"
98 choice l@(_:_) = Writer $ \rm po pp ->
100 TL.intercalate " | " $
101 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
102 where op = infixB SideL 2
103 many (Writer w) = Writer $ \rm po pp ->
105 w rm (op, SideL) PairParen <> "*"
107 some (Writer w) = Writer $ \rm po pp ->
109 w rm (op, SideL) PairParen <> "+"
111 option _x (Writer w) = Writer $ \rm po pp ->
113 w rm (op, SideL) PairParen <> "?"
115 optional (Writer w) = Writer $ \rm po pp ->
117 w rm (op, SideL) PairParen <> "?"
120 -- | Get textual rendition of given 'Writer'.
121 runWriter :: Writer a -> TL.Text
122 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
124 -- | Get textual rendition of given 'RuleWriter'.
125 renderWriter :: RuleWriter a -> TL.Text
126 renderWriter = runWriter . unRuleWriter
128 -- | 'Writer' returns a constant rendition.
129 writeText :: TL.Text -> Writer a
130 writeText t = Writer $ \_rm _op _pp -> t
132 -- ** Type 'RuleMode'
134 = RuleMode_Body -- ^ Request to generate the body of the rule.
135 | RuleMode_Ref -- ^ Request to generate a reference to the rule.
138 -- * Type 'RuleWriter'
139 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
140 deriving (Functor, Applicative)
141 instance Sym_Rule RuleWriter where
142 rule n = ruleWriter (writeText $ TL.fromStrict n)
143 deriving instance Sym_RuleWriter RuleWriter
144 type instance Perm RuleWriter = Compose [] RuleWriter
145 instance Sym_Interleaved RuleWriter where
146 interleaved (Compose l) = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
147 f <$$> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
148 f <$?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
149 f <$*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
150 Compose ws <||> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
151 Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
152 Compose ws <|*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
153 deriving instance Sym_RNC RuleWriter
155 -- ** Class 'Sym_RuleWriter'
156 -- | Symantics for rendering 'Writer' rules.
158 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
159 -- * 'argWriter' renders an argument.
160 class Sym_RuleWriter g where
161 ruleWriter :: Writer () -> g a -> RuleWriter a
162 argWriter :: Text -> g a
163 instance Sym_RuleWriter Writer where
164 argWriter = writeText . TL.fromStrict
165 ruleWriter call body =
166 RuleWriter $ Writer $ \rm po pp ->
168 RuleMode_Ref -> unWriter call rm po pp
171 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
173 , unWriter body RuleMode_Ref (infixN0,SideR) pp