Commoning.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
module RelaxNG.Commoning where

import Data.Eq (Eq)
import Data.Either (Either(..))
import Data.Foldable (toList)
import Data.Functor ((<$>))
import Data.Function (($), (.))
import Data.Hashable (Hashable)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Data.Sequence (Seq)
import Data.Tuple (fst)
import Text.Show (Show)
import GHC.Generics (Generic)
import qualified Data.Sequence as Seq
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
import qualified Text.Megaparsec as P

import Symantic.XML as XML
import Symantic.XML.RelaxNG as RelaxNG

schema =
  namespace Nothing xmlns_commoning <.>
  namespace (Just "xsd") "http://www/w3/org/2001/XMLSchema-datatypes" <.>
  commoning

-- * Class 'Commonable'
xmlns_commoning :: Namespace
xmlns_commoning = "2018/commoning.rnc"
elem = element . QName xmlns_commoning
attr n = attribute (QName "" n) text
many0Seq = dimap Seq.fromList toList . many0

-- * Type 'Ident'
newtype Ident = Ident TL.Text
 deriving (Eq,Ord,Show,Hashable)

instance RNCText Ident where
  rncText_qname = QName xmlns_xsd "id"
instance EncodeText Ident where
  encodeText (Ident t) = t
instance DecodeText Ident where
  decodeText = Ident . fst <$> P.match (P.many P.anySingle)

-- * Type 'Name'
newtype Name = Name TL.Text
 deriving (Eq,Ord,Show,Hashable)
instance RNCText Name where
  rncText_qname  = rncText_qname  @TL.Text
  rncText_params = rncText_params @TL.Text

instance EncodeText Name where
  encodeText (Name t) = t
instance DecodeText Name where
  decodeText = Name . fst <$> P.match (P.many P.anySingle)

-- * Type 'Commoning'
data Commoning
 =   Commoning
 {   commoning_persons    :: Persons
 ,   commoning_opinions   :: Opinions
 ,   commoning_groups     :: Groups
 ,   commoning_operations :: Operations
 ,   commoning_resources  :: Resources
 } deriving (Show, Generic)

commoning =
  define "commoning" $
  elem "commoning" $
  adt @Commoning $
    permutable $
    persons <&>
    opinions <&>
    groups <&>
    operations <&>
    perm resources

-- ** Type 'Person'
data Person
 =   Person
 {   person_id     :: Ident
 ,   person_fields :: Seq Fields
 } deriving (Show, Generic)

person =
  define "person" $
  adt @Person $
  elem "person" $
    attr "id" <:>
    many0Seq fields

-- *** Type 'Persons'
type Persons = [Person]

persons =
  define "persons" $
  elem "persons" $
    many0 person

-- * Type 'Opinions'
type Opinions = [Grades]

opinions =
  define "opinions" $
  elem "opinions" $
    many0 grades

-- ** Type 'Grade'
data Grade
 =   Grade
 {   grade_name   :: Name
 ,   grade_abbrev :: Maybe Name
 ,   grade_color  :: Maybe Color
 } deriving (Show, Generic)

grade =
  define "grade" $
  elem "grade" $
  adt @Grade $
    attr "name" <:>
    optional (attr "abbrev") <:>
    optional (attr "color")

-- *** Type 'Color'
type Color = TL.Text

-- *** Type 'Grades'
data Grades
 =   Grades
 {   grades_id   :: Ident
 ,   grades_name :: Maybe Name
 ,   grades_list :: [Grade]
 } deriving (Show, Generic)

grades =
  define "grades" $
  elem "grades" $
  adt @Grades $
    attr "id" <:>
    optional (attr "name") <:>
    many0 grade

-- ** Type 'Field'
data Field
 =   Field
 {   field_name  :: Name
 ,   field_value :: TL.Text
 } deriving (Show, Generic)

-- *** Type 'Fields'
type Fields = TS.Tree NodeField

-- **** Type 'NodeField'
data NodeField
 =   NodeField Field
 |   NodeFields { fields_name :: Name }
 deriving (Show, Generic)

fields =
  define "fields" $
  elem "fields" $
  adt @(TS.Tree NodeField) $
    (dimap NodeFields fields_name $
      attr "name")
    <:>
    many0Seq (
      dimap
      (\case
       Left f -> TS.tree0 $ NodeField f
       Right fs -> fs)
      (\case
       TS.Tree (NodeField f) _ -> Left f
       fs -> Right fs) $
      field
      <+>
      fields
    )

field =
  define "field" $
  elem "field" $
  adt @Field $
    attr "name" <:>
    text

-- ** Type 'Group'
type Group = TS.Tree NodeGroup

-- *** Type 'NodeGroup'
data NodeGroup
 =   NodeGroup
 {   group_id      :: Ident
 ,   group_name    :: Maybe Name
 ,   group_fields  :: Seq Fields
 ,   group_members :: Members
 } deriving (Show, Generic)

-- *** Type 'Groups'
type Groups = Seq Group

groups =
  define "groups" $
  elem "groups" $
    many0Seq group

group =
  define "group" $
  elem "group" $
  adt @(TS.Tree NodeGroup) $
    (adt @NodeGroup $
      attr "id" <:>
      optional (attr "name") <:>
      many0Seq fields <:>
      members
    ) <:>
    many0Seq group

-- ** Type 'Member'
newtype Member
 =      Member
 {      member_person :: Ident
 } deriving (Show, Generic)

-- *** Type 'Members'
type Members = [Member]

members = define "members" $ many0 member
member =
  define "member" $
  elem "member" $
  adt @Member $
   attr "person"

-- ** Type 'Operation'
type Operation = TS.Tree NodeOperation
-- *** Type 'NodeOperation'
newtype NodeOperation
 =      NodeOperation
 {      operation_id :: Ident
 } deriving (Show, Generic)
-- *** Type 'Operations'
type Operations = Seq Operation

operations =
  define "operations" $
  elem "operations" $
  many0Seq operation

operation =
  define "operation" $
  elem "operation" $
  adt @(TS.Tree NodeOperation) $
    (adt $ attr "id") <:>
    many0Seq operation

-- ** Type 'Resource'
type Resource = TS.Tree NodeResource
-- *** Type 'NodeResource'
data NodeResource
 =   NodeResource
 {   resource_name     :: Name
 ,   resource_policies :: Policies
 } deriving (Show, Generic)

-- *** Type 'Resources'
type Resources = Seq Resource

resources =
  define "resources" $
  elem "resources" $
    many0Seq resource

resource =
  define "resource" $
  elem "resource" $
  adt @(TS.Tree NodeResource) $
    (adt $ attr "name" <:> many0 policy) <:>
    many0Seq resource

-- ** Type 'Policy'
data Policy
 =   Policy
 {   policy_operation :: Name
 ,   policy_by        :: Ident
 ,   policy_toward    :: Maybe Ident
 ,   policy_rules     :: Rules
 } deriving (Show, Generic)

policy =
  define "policy" $
  adt @Policy $
  elem "policy" $
    attr "operation" <:>
    attr "by" <:>
    optional (attr "toward") <:>
    many0 rule

-- *** Type 'Policies'
type Policies = [Policy]

-- ** Type 'Rule'
data Rule
 =   Rule
 {   rule_grades     :: Ident
 ,   rule_gradeRange :: GradeRange
 } deriving (Show, Generic)

rule =
  define "rule" $
  adt @Rule $
  elem "rule" $
    attr "grades" <:>
    gradeRange

-- *** Type 'Rules'
type Rules = [Rule]

-- *** Type 'GradeRange'
data GradeRange
 =   GradeRange_Single Name
 |   GradeRange_Min    Name
 |   GradeRange_Max    Name
 |   GradeRange        Name Name
 deriving (Show, Generic)

gradeRange =
  define "gradeRange" $
  adt @GradeRange $
    attr "grade" <+>
    attr "gradeMin" <+>
    attr "gradeMax" <+> (
      attr "gradeMin" <:>
      attr "gradeMax"
    )

{-
rule = define "rule" $
  element "rule" attrs
  where
  attrs
   =   attrsGrade
   <+> attrsGradeMin
   <+> attrsGradeMax
  attrsGrade =
    permutable $
    Rule
     <$> attribute "grades" ident
     <*> (GradeRange_Single <$> attribute "grade" name)
  attrsGradeMin =
    permutable $
    (\gs gMin mgMax -> Rule gs $ case mgMax of
       Nothing   -> GradeRange_Min gMin
       Just gMax -> GradeRange gMin gMax)
     <$> attribute "grades" ident
     <*> attribute "gradeMin" name
     <*> optionalPerm (attribute "gradeMax" name)
  attrsGradeMax =
    permutable $
    (\gs mgMin gMax -> Rule gs $ case mgMin of
       Nothing   -> GradeRange_Max gMax
       Just gMin -> GradeRange gMin gMax)
     <$> attribute "grades" ident
     <*> optionalPerm (attribute "gradeMin" name)
     <*> attribute "gradeMax" name
-}