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  ]