]> Git — Sourcephile - haskell/symantic-xml.git/blob - test/RNC/Commoning.hs
RNC: add some tests
[haskell/symantic-xml.git] / test / RNC / Commoning.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
3 {-# LANGUAGE OverloadedStrings #-}
4 {-# LANGUAGE Rank2Types #-}
5 {-# LANGUAGE StrictData #-}
6 module RNC.Commoning where
7
8 import Control.Applicative (Applicative(..), Alternative(..))
9 import Control.Monad (Monad, void)
10 import Data.Default.Class (Default(..))
11 import Data.Eq (Eq)
12 import Data.Function (($), (.))
13 import Data.Functor ((<$>))
14 import Data.Hashable (Hashable)
15 import Data.Maybe (Maybe(..))
16 import Data.Ord (Ord)
17 import Data.Sequence (Seq)
18 import Text.Show (Show)
19 import qualified Data.Text.Lazy as TL
20 import qualified Data.TreeSeq.Strict as TS
21 import qualified Text.Megaparsec as P
22
23 import Language.Symantic.RNC (Sym_Permutation(..))
24 import qualified Language.Symantic.RNC as RNC
25 import qualified Language.Symantic.XML as XML
26
27 import RNC.Parser
28
29 -- * Type 'Commoning'
30 data Commoning = Commoning
31 { commoning_persons :: Persons
32 , commoning_opinions :: Opinions
33 , commoning_groups :: Groups
34 , commoning_operations :: Operations
35 , commoning_resources :: Resources
36 } deriving (Show)
37
38 -- ** Type 'Person'
39 data Person = Person
40 { person_id :: Ident
41 , person_fields :: Seq Fields
42 } deriving (Show)
43 -- *** Type 'Persons'
44 type Persons = [Person]
45
46 -- ** Type 'Group'
47 type Group = TS.Tree NodeGroup
48 -- *** Type 'NodeGroup'
49 data NodeGroup = NodeGroup
50 { group_id :: Ident
51 , group_name :: Maybe Name
52 , group_fields :: Seq Fields
53 , group_members :: Members
54 } deriving (Show)
55 -- *** Type 'Groups'
56 type Groups = Seq Group
57
58 -- ** Type 'Member'
59 newtype Member = Member
60 { member_person :: Ident
61 } deriving (Show)
62 -- *** Type 'Members'
63 type Members = [Member]
64
65 -- ** Type 'Resource'
66 type Resource = TS.Tree NodeResource
67 -- *** Type 'NodeResource'
68 data NodeResource = NodeResource
69 { resource_name :: Name
70 , resource_policies :: Policies
71 } deriving (Show)
72 -- *** Type 'Resources'
73 type Resources = Seq Resource
74
75 -- ** Type 'Policy'
76 data Policy = Policy
77 { policy_operation :: Name
78 , policy_by :: Ident
79 , policy_toward :: (Maybe Ident)
80 , policy_rules :: Rules
81 } deriving (Show)
82 -- *** Type 'Policies'
83 type Policies = [Policy]
84
85 -- ** Type 'Rule'
86 data Rule = Rule
87 { rule_grades :: Ident
88 , rule_gradeRange :: GradeRange
89 } deriving (Show)
90 -- *** Type 'Rules'
91 type Rules = [Rule]
92
93 -- *** Type 'GradeRange'
94 data GradeRange
95 = GradeRange_Single Name
96 | GradeRange_Min Name
97 | GradeRange_Max Name
98 | GradeRange Name Name
99 deriving (Show)
100
101 -- * Type 'Opinions'
102 type Opinions = [Grades]
103
104 -- ** Type 'Grade'
105 data Grade = Grade
106 { grade_name :: Name
107 , grade_abbrev :: Maybe Name
108 , grade_color :: Maybe Color
109 } deriving (Show)
110 -- *** Type 'Grades'
111 data Grades = Grades
112 { grades_id :: Ident
113 , grades_name :: Maybe Name
114 , grades_list :: [Grade]
115 } deriving (Show)
116 -- *** Type 'Color'
117 type Color = TL.Text
118
119 -- ** Type 'Operation'
120 type Operation = TS.Tree NodeOperation
121 -- *** Type 'NodeOperation'
122 newtype NodeOperation = NodeOperation
123 { operation_id :: Ident
124 } deriving (Show)
125 -- *** Type 'Operations'
126 type Operations = Seq Operation
127
128 -- ** Type 'Field'
129 data Field = Field
130 { field_name :: Name
131 , field_value :: TL.Text
132 } deriving (Show)
133 -- *** Type 'Fields'
134 type Fields = TS.Tree NodeField
135 -- **** Type 'NodeField'
136 data NodeField
137 = NodeField Field
138 | NodeFields { fields_name :: Name }
139 deriving (Show)
140
141 -- * Type 'Ident'
142 newtype Ident = Ident TL.Text
143 deriving (Eq,Ord,Show,Hashable)
144 -- * Type 'Name'
145 newtype Name = Name TL.Text
146 deriving (Eq,Ord,Show,Hashable)
147
148 -- * Class 'Sym_Commoning'
149 xmlns_commoning :: XML.Namespace
150 xmlns_commoning = "http://commonsoft.org/xml/2018/commoning.rnc"
151 element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
152 element = RNC.element . XML.QName xmlns_commoning
153 attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
154 attribute = RNC.attribute . XML.QName ""
155
156 class RNC.Sym_RNC repr => Sym_Commoning repr where
157 commoning :: repr Commoning
158 persons :: repr Persons
159 person :: repr Person
160 opinions :: repr Opinions
161 grades :: repr Grades
162 grade :: repr Grade
163 fields :: repr Fields
164 field :: repr Field
165 groups :: repr Groups
166 group :: repr Group
167 members :: repr Members
168 member :: repr Member
169 operations :: repr Operations
170 operation :: repr Operation
171 resources :: repr Resources
172 resource :: repr Resource
173 policy :: repr Policy
174 rule :: repr Rule
175 ident :: repr Ident
176 name :: repr Name
177 color :: repr Color
178
179 commoning = RNC.rule "commoning" $
180 element "commoning" $
181 runPermutation $
182 Commoning
183 <$$> persons
184 <||> opinions
185 <||> groups
186 <||> operations
187 <||> resources
188 persons = RNC.rule "persons" $
189 element "persons" $ RNC.many person
190 person = RNC.rule "person" $
191 element "person" $ attrs <*> RNC.manySeq fields
192 where
193 attrs =
194 runPermutation $
195 Person
196 <$$> attribute "id" ident
197 opinions = RNC.rule "opinions" $
198 element "opinions" $
199 RNC.many grades
200 grades = RNC.rule "grades" $
201 element "grades" $ attrs <*> RNC.many grade
202 where
203 attrs =
204 runPermutation $
205 Grades
206 <$$> attribute "id" ident
207 <|?> (def, Just <$> attribute "name" name)
208 grade = RNC.rule "grade" $
209 element "grade" $ attrs
210 where
211 attrs =
212 runPermutation $
213 Grade
214 <$$> attribute "name" name
215 <|?> (def, Just <$> attribute "abbrev" name)
216 <|?> (def, Just <$> attribute "color" color)
217 fields = RNC.rule "fields" $
218 element "fields" $
219 (TS.Tree <$> attrs <*>) $
220 RNC.manySeq $
221 TS.tree0 . NodeField <$> field
222 <|> fields
223 where
224 attrs =
225 runPermutation $
226 NodeFields
227 <$$> attribute "name" name
228 field = RNC.rule "field" $
229 element "field" $ attrs <*> RNC.text
230 where
231 attrs =
232 runPermutation $
233 Field
234 <$$> attribute "name" name
235 groups = RNC.rule "groups" $
236 element "groups" $ RNC.manySeq group
237 group = RNC.rule "group" $
238 element "group" $
239 (((TS.Tree <$>) $ attrs <*> RNC.manySeq fields <*> members) <*>) $
240 RNC.manySeq group
241 where
242 attrs =
243 runPermutation $
244 NodeGroup
245 <$$> attribute "id" ident
246 <|?> (def, Just <$> attribute "name" name)
247 members = RNC.rule "members" $ RNC.many member
248 member = RNC.rule "member" $
249 element "member" $ attrs
250 where
251 attrs =
252 runPermutation $
253 Member
254 <$$> attribute "person" ident
255 operations = RNC.rule "operations" $
256 element "operations" $ RNC.manySeq operation
257 operation = RNC.rule "operation" $
258 element "operation" $
259 (((TS.Tree <$>) $ attrs) <*>) $
260 RNC.manySeq operation
261 where
262 attrs =
263 runPermutation $
264 NodeOperation
265 <$$> attribute "id" ident
266 resources = RNC.rule "resources" $
267 element "resources" $ RNC.manySeq resource
268 resource = RNC.rule "resource" $
269 element "resource" $
270 (((TS.Tree <$>) $ attrs <*> RNC.many policy) <*>) $
271 RNC.manySeq resource
272 where
273 attrs =
274 runPermutation $
275 NodeResource
276 <$$> attribute "name" name
277 policy = RNC.rule "policy" $
278 element "policy" $ attrs
279 where
280 attrs =
281 runPermutation $
282 Policy
283 <$$> attribute "operation" name
284 <||> attribute "by" ident
285 <|?> (def, Just <$> attribute "toward" ident)
286 <|*> rule
287 rule = RNC.rule "rule" $
288 element "rule" $ attrs
289 where
290 attrs
291 = RNC.try attrsGrade
292 <|> RNC.try attrsGradeMin
293 <|> attrsGradeMax
294 attrsGrade =
295 runPermutation $
296 Rule
297 <$$> attribute "grades" ident
298 <||> (GradeRange_Single <$> attribute "grade" name)
299 attrsGradeMin =
300 runPermutation $
301 (\gs gMin mgMax -> Rule gs $ case mgMax of
302 Nothing -> GradeRange_Min gMin
303 Just gMax -> GradeRange gMin gMax)
304 <$$> attribute "grades" ident
305 <||> attribute "gradeMin" name
306 <|?> (def, Just <$> attribute "gradeMax" name)
307 attrsGradeMax =
308 runPermutation $
309 (\gs mgMin gMax -> Rule gs $ case mgMin of
310 Nothing -> GradeRange_Max gMax
311 Just gMin -> GradeRange gMin gMax)
312 <$$> attribute "grades" ident
313 <|?> (def, Just <$> attribute "gradeMin" name)
314 <||> attribute "gradeMax" name
315
316 ident = RNC.rule "ident" $ Ident <$> RNC.text
317 name = RNC.rule "name" $ Name <$> RNC.text
318 color = RNC.rule "color" $ RNC.text
319 instance Sym_Commoning RNC.NS
320 instance Sym_Commoning RNC.Writer
321 instance
322 ( Ord err
323 , Ord src
324 , XML.NoSource src
325 ) => Sym_Commoning (P.Parsec err (XML.XMLs src))
326
327 -- newtype Forall cl a = Forall { unForall :: forall repr. cl repr => repr a }
328 rnc :: forall repr. Sym_Commoning repr => [repr ()]
329 rnc =
330 [ void $ RNC.namespace Nothing xmlns_commoning
331 , void $ commoning
332 , void $ persons
333 , void $ person
334 , void $ opinions
335 , void $ grades
336 , void $ grade
337 , void $ fields
338 , void $ field
339 , void $ groups
340 , void $ group
341 , void $ members
342 , void $ member
343 , void $ resources
344 , void $ resource
345 , void $ policy
346 , void $ rule
347 , void $ ident
348 , void $ name
349 , void $ color
350 ]