1 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
2 {-# LANGUAGE StandaloneDeriving #-}
3 {-# LANGUAGE TypeFamilies #-}
4 {-# LANGUAGE OverloadedStrings #-}
5 {-# LANGUAGE ViewPatterns #-}
6 module Language.RNC.Write where
8 import Control.Applicative (Applicative(..))
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
18 import Language.RNC.Sym
19 import Language.RNC.Fixity
23 = Writer { unWriter :: RuleMode -> (Infix, Side) -> Pair -> Text }
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 ->
33 Text.intercalate ", " $
34 List.filter (not . Text.null) $
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 ->
41 RuleMode_Body -> w RuleMode_Ref po pp
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 ->
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 ->
65 "element \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
67 anyElem (($ "") -> Writer w) = Writer $ \rm po pp ->
69 "any "<>w rm (op,SideR) PairBrace
71 attribute n (Writer w) = Writer $ \rm po pp ->
73 "attribute \""<>Text.pack (show n)<>"\" "<>w rm (op,SideR) PairBrace
76 comment = writeText "comment"
77 text = writeText "text"
78 none = writeText "empty"
80 int = writeText "xsd:int"
81 nat = writeText "xsd:nat"
82 nat1 = writeText "xsd:nat1"
83 -- anyElem r = Writer $ \_rm _po -> "empty"
85 Writer wl <|> Writer wr = Writer $ \rm po pp ->
87 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
88 where op = infixB SideL 2
89 choice [] = writeText "empty"
91 choice l@(_:_) = Writer $ \rm po pp ->
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 ->
98 w rm (op, SideL) PairParen <> "*"
100 some (Writer w) = Writer $ \rm po pp ->
102 w rm (op, SideL) PairParen <> "+"
104 option _x (Writer w) = Writer $ \rm po pp ->
106 w rm (op, SideL) PairParen <> "?"
108 optional (Writer w) = Writer $ \rm po pp ->
110 w rm (op, SideL) PairParen <> "?"
113 -- | Get textual rendition of given 'Writer'.
114 runWriter :: Writer a -> Text
115 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
117 -- | Get textual rendition of given 'RuleWriter'.
118 renderWriter :: RuleWriter a -> Text
119 renderWriter = runWriter . unRuleWriter
121 -- | 'Writer' returns a constant rendition.
122 writeText :: Text -> Writer a
123 writeText t = Writer $ \_rm _op _pp -> t
125 -- ** Type 'RuleMode'
127 = RuleMode_Body -- ^ Request to generate the body of the rule.
128 | RuleMode_Ref -- ^ Request to generate a reference to the rule.
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
148 -- ** Class 'Sym_RuleWriter'
149 -- | Symantics for rendering 'Writer' rules.
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 ->
161 RuleMode_Ref -> unWriter call rm po pp
164 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
166 , unWriter body RuleMode_Ref (infixN0,SideR) pp