test/RelaxNG/Commoning.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DeriveGeneric #-}
   3 {-# LANGUAGE FlexibleContexts #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE NoMonomorphismRestriction #-}
   6 {-# LANGUAGE OverloadedStrings #-}
   7 {-# LANGUAGE StrictData #-}
   8 {-# LANGUAGE TypeApplications #-}
   9 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
  10 module RelaxNG.Commoning where
  11
  12 import Data.Eq (Eq)
  13 import Data.Either (Either(..))
  14 import Data.Foldable (toList)
  15 import Data.Functor ((<$>))
  16 import Data.Function (($), (.))
  17 import Data.Hashable (Hashable)
  18 import Data.Maybe (Maybe(..))
  19 import Data.Ord (Ord)
  20 import Data.Sequence (Seq)
  21 import Data.Tuple (fst)
  22 import Text.Show (Show)
  23 import GHC.Generics (Generic)
  24 import qualified Data.Sequence as Seq
  25 import qualified Data.Text.Lazy as TL
  26 import qualified Data.TreeSeq.Strict as TS
  27 import qualified Text.Megaparsec as P
  28
  29 import Symantic.XML as XML
  30 import Symantic.XML.RelaxNG as RelaxNG
  31
  32 schema =
  33   namespace Nothing xmlns_commoning <.>
  34   namespace (Just "xsd") "http://www/w3/org/2001/XMLSchema-datatypes" <.>
  35   commoning
  36
  37 -- * Class 'Commonable'
  38 xmlns_commoning :: Namespace
  39 xmlns_commoning = "2018/commoning.rnc"
  40 elem = element . QName xmlns_commoning
  41 attr n = attribute (QName "" n) text
  42 many0Seq = dimap Seq.fromList toList . many0
  43
  44 -- * Type 'Ident'
  45 newtype Ident = Ident TL.Text
  46  deriving (Eq,Ord,Show,Hashable)
  47
  48 instance RNCText Ident where
  49   rncText_qname = QName xmlns_xsd "id"
  50 instance EncodeText Ident where
  51   encodeText (Ident t) = t
  52 instance DecodeText Ident where
  53   decodeText = Ident . fst <$> P.match (P.many P.anySingle)
  54
  55 -- * Type 'Name'
  56 newtype Name = Name TL.Text
  57  deriving (Eq,Ord,Show,Hashable)
  58 instance RNCText Name where
  59   rncText_qname  = rncText_qname  @TL.Text
  60   rncText_params = rncText_params @TL.Text
  61
  62 instance EncodeText Name where
  63   encodeText (Name t) = t
  64 instance DecodeText Name where
  65   decodeText = Name . fst <$> P.match (P.many P.anySingle)
  66
  67 -- * Type 'Commoning'
  68 data Commoning
  69  =   Commoning
  70  {   commoning_persons    :: Persons
  71  ,   commoning_opinions   :: Opinions
  72  ,   commoning_groups     :: Groups
  73  ,   commoning_operations :: Operations
  74  ,   commoning_resources  :: Resources
  75  } deriving (Show, Generic)
  76
  77 commoning =
  78   define "commoning" $
  79   elem "commoning" $
  80   adt @Commoning $
  81     permutable $
  82     persons <&>
  83     opinions <&>
  84     groups <&>
  85     operations <&>
  86     perm resources
  87
  88 -- ** Type 'Person'
  89 data Person
  90  =   Person
  91  {   person_id     :: Ident
  92  ,   person_fields :: Seq Fields
  93  } deriving (Show, Generic)
  94
  95 person =
  96   define "person" $
  97   adt @Person $
  98   elem "person" $
  99     attr "id" <:>
 100     many0Seq fields
 101
 102 -- *** Type 'Persons'
 103 type Persons = [Person]
 104
 105 persons =
 106   define "persons" $
 107   elem "persons" $
 108     many0 person
 109
 110 -- * Type 'Opinions'
 111 type Opinions = [Grades]
 112
 113 opinions =
 114   define "opinions" $
 115   elem "opinions" $
 116     many0 grades
 117
 118 -- ** Type 'Grade'
 119 data Grade
 120  =   Grade
 121  {   grade_name   :: Name
 122  ,   grade_abbrev :: Maybe Name
 123  ,   grade_color  :: Maybe Color
 124  } deriving (Show, Generic)
 125
 126 grade =
 127   define "grade" $
 128   elem "grade" $
 129   adt @Grade $
 130     attr "name" <:>
 131     optional (attr "abbrev") <:>
 132     optional (attr "color")
 133
 134 -- *** Type 'Color'
 135 type Color = TL.Text
 136
 137 -- *** Type 'Grades'
 138 data Grades
 139  =   Grades
 140  {   grades_id   :: Ident
 141  ,   grades_name :: Maybe Name
 142  ,   grades_list :: [Grade]
 143  } deriving (Show, Generic)
 144
 145 grades =
 146   define "grades" $
 147   elem "grades" $
 148   adt @Grades $
 149     attr "id" <:>
 150     optional (attr "name") <:>
 151     many0 grade
 152
 153 -- ** Type 'Field'
 154 data Field
 155  =   Field
 156  {   field_name  :: Name
 157  ,   field_value :: TL.Text
 158  } deriving (Show, Generic)
 159
 160 -- *** Type 'Fields'
 161 type Fields = TS.Tree NodeField
 162
 163 -- **** Type 'NodeField'
 164 data NodeField
 165  =   NodeField Field
 166  |   NodeFields { fields_name :: Name }
 167  deriving (Show, Generic)
 168
 169 fields =
 170   define "fields" $
 171   elem "fields" $
 172   adt @(TS.Tree NodeField) $
 173     (dimap NodeFields fields_name $
 174       attr "name")
 175     <:>
 176     many0Seq (
 177       dimap
 178       (\case
 179        Left f -> TS.tree0 $ NodeField f
 180        Right fs -> fs)
 181       (\case
 182        TS.Tree (NodeField f) _ -> Left f
 183        fs -> Right fs) $
 184       field
 185       <+>
 186       fields
 187     )
 188
 189 field =
 190   define "field" $
 191   elem "field" $
 192   adt @Field $
 193     attr "name" <:>
 194     text
 195
 196 -- ** Type 'Group'
 197 type Group = TS.Tree NodeGroup
 198
 199 -- *** Type 'NodeGroup'
 200 data NodeGroup
 201  =   NodeGroup
 202  {   group_id      :: Ident
 203  ,   group_name    :: Maybe Name
 204  ,   group_fields  :: Seq Fields
 205  ,   group_members :: Members
 206  } deriving (Show, Generic)
 207
 208 -- *** Type 'Groups'
 209 type Groups = Seq Group
 210
 211 groups =
 212   define "groups" $
 213   elem "groups" $
 214     many0Seq group
 215
 216 group =
 217   define "group" $
 218   elem "group" $
 219   adt @(TS.Tree NodeGroup) $
 220     (adt @NodeGroup $
 221       attr "id" <:>
 222       optional (attr "name") <:>
 223       many0Seq fields <:>
 224       members
 225     ) <:>
 226     many0Seq group
 227
 228 -- ** Type 'Member'
 229 newtype Member
 230  =      Member
 231  {      member_person :: Ident
 232  } deriving (Show, Generic)
 233
 234 -- *** Type 'Members'
 235 type Members = [Member]
 236
 237 members = define "members" $ many0 member
 238 member =
 239   define "member" $
 240   elem "member" $
 241   adt @Member $
 242    attr "person"
 243
 244 -- ** Type 'Operation'
 245 type Operation = TS.Tree NodeOperation
 246 -- *** Type 'NodeOperation'
 247 newtype NodeOperation
 248  =      NodeOperation
 249  {      operation_id :: Ident
 250  } deriving (Show, Generic)
 251 -- *** Type 'Operations'
 252 type Operations = Seq Operation
 253
 254 operations =
 255   define "operations" $
 256   elem "operations" $
 257   many0Seq operation
 258
 259 operation =
 260   define "operation" $
 261   elem "operation" $
 262   adt @(TS.Tree NodeOperation) $
 263     (adt $ attr "id") <:>
 264     many0Seq operation
 265
 266 -- ** Type 'Resource'
 267 type Resource = TS.Tree NodeResource
 268 -- *** Type 'NodeResource'
 269 data NodeResource
 270  =   NodeResource
 271  {   resource_name     :: Name
 272  ,   resource_policies :: Policies
 273  } deriving (Show, Generic)
 274
 275 -- *** Type 'Resources'
 276 type Resources = Seq Resource
 277
 278 resources =
 279   define "resources" $
 280   elem "resources" $
 281     many0Seq resource
 282
 283 resource =
 284   define "resource" $
 285   elem "resource" $
 286   adt @(TS.Tree NodeResource) $
 287     (adt $ attr "name" <:> many0 policy) <:>
 288     many0Seq resource
 289
 290 -- ** Type 'Policy'
 291 data Policy
 292  =   Policy
 293  {   policy_operation :: Name
 294  ,   policy_by        :: Ident
 295  ,   policy_toward    :: Maybe Ident
 296  ,   policy_rules     :: Rules
 297  } deriving (Show, Generic)
 298
 299 policy =
 300   define "policy" $
 301   adt @Policy $
 302   elem "policy" $
 303     attr "operation" <:>
 304     attr "by" <:>
 305     optional (attr "toward") <:>
 306     many0 rule
 307
 308 -- *** Type 'Policies'
 309 type Policies = [Policy]
 310
 311 -- ** Type 'Rule'
 312 data Rule
 313  =   Rule
 314  {   rule_grades     :: Ident
 315  ,   rule_gradeRange :: GradeRange
 316  } deriving (Show, Generic)
 317
 318 rule =
 319   define "rule" $
 320   adt @Rule $
 321   elem "rule" $
 322     attr "grades" <:>
 323     gradeRange
 324
 325 -- *** Type 'Rules'
 326 type Rules = [Rule]
 327
 328 -- *** Type 'GradeRange'
 329 data GradeRange
 330  =   GradeRange_Single Name
 331  |   GradeRange_Min    Name
 332  |   GradeRange_Max    Name
 333  |   GradeRange        Name Name
 334  deriving (Show, Generic)
 335
 336 gradeRange =
 337   define "gradeRange" $
 338   adt @GradeRange $
 339     attr "grade" <+>
 340     attr "gradeMin" <+>
 341     attr "gradeMax" <+> (
 342       attr "gradeMin" <:>
 343       attr "gradeMax"
 344     )
 345
 346 {-
 347 rule = define "rule" $
 348   element "rule" attrs
 349   where
 350   attrs
 351    =   attrsGrade
 352    <+> attrsGradeMin
 353    <+> attrsGradeMax
 354   attrsGrade =
 355     permutable $
 356     Rule
 357      <$> attribute "grades" ident
 358      <*> (GradeRange_Single <$> attribute "grade" name)
 359   attrsGradeMin =
 360     permutable $
 361     (\gs gMin mgMax -> Rule gs $ case mgMax of
 362        Nothing   -> GradeRange_Min gMin
 363        Just gMax -> GradeRange gMin gMax)
 364      <$> attribute "grades" ident
 365      <*> attribute "gradeMin" name
 366      <*> optionalPerm (attribute "gradeMax" name)
 367   attrsGradeMax =
 368     permutable $
 369     (\gs mgMin gMax -> Rule gs $ case mgMin of
 370        Nothing   -> GradeRange_Max gMax
 371        Just gMin -> GradeRange gMin gMax)
 372      <$> attribute "grades" ident
 373      <*> optionalPerm (attribute "gradeMin" name)
 374      <*> attribute "gradeMax" name
 375 -}