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(..))
13 import Data.Text (Text)
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 "anyElem "<>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 fail = writeText "fail"
77 comment = writeText "comment"
78 text = writeText "text"
79 none = writeText "empty"
81 int = writeText "xsd:int"
82 nat = writeText "xsd:nat"
83 nat1 = writeText "xsd:nat1"
84 -- anyElem r = Writer $ \_rm _po -> "empty"
86 Writer wl <|> Writer wr = Writer $ \rm po pp ->
88 wl rm (op, SideL) PairParen <> " | " <> wr rm (op, SideR) PairParen
89 where op = infixB SideL 2
90 choice [] = writeText "empty"
92 choice l@(_:_) = Writer $ \rm po pp ->
94 Text.intercalate " | " $
95 (unWriter <$> l) <*> pure rm <*> pure (op, SideL) <*> pure PairParen
96 where op = infixB SideL 2
97 many (Writer w) = Writer $ \rm po pp ->
99 w rm (op, SideL) PairParen <> "*"
101 some (Writer w) = Writer $ \rm po pp ->
103 w rm (op, SideL) PairParen <> "+"
105 option _x (Writer w) = Writer $ \rm po pp ->
107 w rm (op, SideL) PairParen <> "?"
109 optional (Writer w) = Writer $ \rm po pp ->
111 w rm (op, SideL) PairParen <> "?"
114 -- | Get textual rendition of given 'Writer'.
115 runWriter :: Writer a -> Text
116 runWriter (Writer w) = w RuleMode_Body (infixN0, SideL) PairParen
118 -- | Get textual rendition of given 'RuleWriter'.
119 renderWriter :: RuleWriter a -> Text
120 renderWriter = runWriter . unRuleWriter
122 -- | 'Writer' returns a constant rendition.
123 writeText :: Text -> Writer a
124 writeText t = Writer $ \_rm _op _pp -> t
126 -- ** Type 'RuleMode'
128 = RuleMode_Body -- ^ Request to generate the body of the rule.
129 | RuleMode_Ref -- ^ Request to generate a reference to the rule.
132 -- * Type 'RuleWriter'
133 newtype RuleWriter a = RuleWriter { unRuleWriter :: Writer a }
134 deriving (Functor, Applicative)
135 instance Sym_Rule RuleWriter where
136 rule n = ruleWriter (writeText n)
137 deriving instance Sym_RuleWriter RuleWriter
138 type instance Perm RuleWriter = Compose [] RuleWriter
139 instance Sym_Interleaved RuleWriter where
140 interleaved (Compose l) = RuleWriter $ interleaved $ Compose $ unRuleWriter <$> l
141 f <$$> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$$> w
142 f <$?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ f <$?> (a,w)
143 f <$*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ f <$*> w
144 Compose ws <||> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <||> w
145 Compose ws <|?> (a,RuleWriter w) = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|?> (a,w)
146 Compose ws <|*> RuleWriter w = Compose $ (RuleWriter <$>) $ getCompose $ Compose (unRuleWriter <$> ws) <|*> w
147 deriving instance Sym_RNC RuleWriter
149 -- ** Class 'Sym_RuleWriter'
150 -- | Symantics for rendering 'Writer' rules.
152 -- * 'ruleWriter' renders a rule, either its body or a reference to it, according to 'RuleMode'.
153 -- * 'argWriter' renders an argument.
154 class Sym_RuleWriter g where
155 ruleWriter :: Writer () -> g a -> RuleWriter a
156 argWriter :: Text -> g a
157 instance Sym_RuleWriter Writer where
158 argWriter = writeText
159 ruleWriter call body =
160 RuleWriter $ Writer $ \rm po pp ->
162 RuleMode_Ref -> unWriter call rm po pp
165 [ unWriter call RuleMode_Ref (infixN0,SideL) pp
167 , unWriter body RuleMode_Ref (infixN0,SideR) pp