Commoning.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE StrictData #-}
module RNC.Commoning where

import Control.Applicative (Applicative(..), Alternative(..))
import Control.Monad (Monad, void)
import Data.Default.Class (Default(..))
import Data.Eq (Eq)
import Data.Function (($), (.))
import Data.Functor ((<$>))
import Data.Hashable (Hashable)
import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Data.Sequence (Seq)
import Text.Show (Show)
import qualified Data.Text.Lazy as TL
import qualified Data.TreeSeq.Strict as TS
import qualified Text.Megaparsec as P

import Symantic.RNC (Sym_Permutation(..))
import qualified Symantic.RNC as RNC
import qualified Symantic.XML as XML

import RNC.Parser

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

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

-- ** 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)
-- *** Type 'Groups'
type Groups = Seq Group

-- ** Type 'Member'
newtype Member = Member
 { member_person :: Ident
 } deriving (Show)
-- *** Type 'Members'
type Members = [Member]

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

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

-- ** Type 'Rule'
data Rule = Rule
 { rule_grades     :: Ident
 , rule_gradeRange :: GradeRange
 } deriving (Show)
-- *** Type 'Rules'
type Rules = [Rule]

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

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

-- ** Type 'Grade'
data Grade = Grade
 { grade_name   :: Name
 , grade_abbrev :: Maybe Name
 , grade_color  :: Maybe Color
 } deriving (Show)
-- *** Type 'Grades'
data Grades = Grades
 { grades_id   :: Ident
 , grades_name :: Maybe Name
 , grades_list :: [Grade]
 } deriving (Show)
-- *** Type 'Color'
type Color = TL.Text

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

-- ** Type 'Field'
data Field = Field
 { field_name  :: Name
 , field_value :: TL.Text
 } deriving (Show)
-- *** Type 'Fields'
type Fields = TS.Tree NodeField
-- **** Type 'NodeField'
data NodeField
 = NodeField  Field
 | NodeFields { fields_name :: Name }
 deriving (Show)

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

-- * Class 'Sym_Commoning'
xmlns_commoning :: XML.Namespace
xmlns_commoning = "http://commonsoft.org/xml/2018/commoning.rnc"
element :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
element = RNC.element . XML.QName xmlns_commoning
attribute :: RNC.Sym_RNC repr => XML.NCName -> repr a -> repr a
attribute = RNC.attribute . XML.QName ""

class RNC.Sym_RNC repr => Sym_Commoning repr where
	commoning  :: repr Commoning
	persons    :: repr Persons
	person     :: repr Person
	opinions   :: repr Opinions
	grades     :: repr Grades
	grade      :: repr Grade
	fields     :: repr Fields
	field      :: repr Field
	groups     :: repr Groups
	group      :: repr Group
	members    :: repr Members
	member     :: repr Member
	operations :: repr Operations
	operation  :: repr Operation
	resources  :: repr Resources
	resource   :: repr Resource
	policy     :: repr Policy
	rule       :: repr Rule
	ident      :: repr Ident
	name       :: repr Name
	color      :: repr Color
	
	commoning = RNC.rule "commoning" $
		element "commoning" $
		runPermutation $
		Commoning
		 <$$> persons
		 <||> opinions
		 <||> groups
		 <||> operations
		 <||> resources
	persons = RNC.rule "persons" $
		element "persons" $ RNC.many person
	person  = RNC.rule "person" $
		element "person" $ attrs <*> RNC.manySeq fields
		where
		attrs =
			runPermutation $
			Person
			 <$$> attribute "id" ident
	opinions = RNC.rule "opinions" $
		element "opinions" $
			RNC.many grades
	grades = RNC.rule "grades" $
		element "grades" $ attrs <*> RNC.many grade
		where
		attrs =
			runPermutation $
			Grades
			 <$$> attribute "id" ident
			 <|?> (def, Just <$> attribute "name" name)
	grade = RNC.rule "grade" $
		element "grade" $ attrs
		where
		attrs =
			runPermutation $
			Grade
			 <$$> attribute "name" name
			 <|?> (def, Just <$> attribute "abbrev" name)
			 <|?> (def, Just <$> attribute "color" color)
	fields = RNC.rule "fields" $
		element "fields" $
			(TS.Tree <$> attrs <*>) $
			RNC.manySeq $
				TS.tree0 . NodeField <$> field
				<|> fields
		where
		attrs =
			runPermutation $
			NodeFields
			 <$$> attribute "name" name
	field = RNC.rule "field" $
		element "field" $ attrs <*> RNC.text
		where
		attrs =
			runPermutation $
			Field
			 <$$> attribute "name" name
	groups = RNC.rule "groups" $
		element "groups" $ RNC.manySeq group
	group = RNC.rule "group" $
		element "group" $
			(((TS.Tree <$>) $ attrs <*> RNC.manySeq fields <*> members) <*>) $
				RNC.manySeq group
		where
		attrs =
			runPermutation $
			NodeGroup
			 <$$> attribute "id" ident
			 <|?> (def, Just <$> attribute "name" name)
	members = RNC.rule "members" $ RNC.many member
	member = RNC.rule "member" $
		element "member" $ attrs
		where
		attrs =
			runPermutation $
			Member
			 <$$> attribute "person" ident
	operations = RNC.rule "operations" $
		element "operations" $ RNC.manySeq operation
	operation = RNC.rule "operation" $
		element "operation" $
			(((TS.Tree <$>) $ attrs) <*>) $
				RNC.manySeq operation
		where
		attrs =
			runPermutation $
			NodeOperation
			 <$$> attribute "id" ident
	resources = RNC.rule "resources" $
		element "resources" $ RNC.manySeq resource
	resource = RNC.rule "resource" $
		element "resource" $
			(((TS.Tree <$>) $ attrs <*> RNC.many policy) <*>) $
				RNC.manySeq resource
		where
		attrs =
			runPermutation $
			NodeResource
			 <$$> attribute "name" name
	policy = RNC.rule "policy" $
		element "policy" $ attrs
		where
		attrs =
			runPermutation $
			Policy
			 <$$> attribute "operation" name
			 <||> attribute "by" ident
			 <|?> (def, Just <$> attribute "toward" ident)
			 <|*> rule
	rule = RNC.rule "rule" $
		element "rule" $ attrs
		where
		attrs
		 =   RNC.try attrsGrade
		 <|> RNC.try attrsGradeMin
		 <|> attrsGradeMax
		attrsGrade =
			runPermutation $
			Rule
			 <$$> attribute "grades" ident
			 <||> (GradeRange_Single <$> attribute "grade" name)
		attrsGradeMin =
			runPermutation $
			(\gs gMin mgMax -> Rule gs $ case mgMax of
				 Nothing -> GradeRange_Min gMin
				 Just gMax -> GradeRange gMin gMax)
			 <$$> attribute "grades" ident
			 <||> attribute "gradeMin" name
			 <|?> (def, Just <$> attribute "gradeMax" name)
		attrsGradeMax =
			runPermutation $
			(\gs mgMin gMax -> Rule gs $ case mgMin of
				 Nothing -> GradeRange_Max gMax
				 Just gMin -> GradeRange gMin gMax)
			 <$$> attribute "grades" ident
			 <|?> (def, Just <$> attribute "gradeMin" name)
			 <||> attribute "gradeMax" name
	
	ident = RNC.rule "ident" $ Ident <$> RNC.text
	name  = RNC.rule "name" $ Name <$> RNC.text
	color = RNC.rule "color" $ RNC.text
instance Sym_Commoning RNC.NS
instance Sym_Commoning RNC.Writer
instance
 ( Ord err
 , Ord src
 , XML.NoSource src
 ) => Sym_Commoning (P.Parsec err (XML.XMLs src))

-- newtype Forall cl a = Forall { unForall :: forall repr. cl repr => repr a }
rnc :: forall repr. Sym_Commoning repr => [repr ()]
rnc =
 [ void $ RNC.namespace Nothing xmlns_commoning
 , void $ commoning
 , void $ persons
 , void $ person
 , void $ opinions
 , void $ grades
 , void $ grade
 , void $ fields
 , void $ field
 , void $ groups
 , void $ group
 , void $ members
 , void $ member
 , void $ resources
 , void $ resource
 , void $ policy
 , void $ rule
 , void $ ident
 , void $ name
 , void $ color
 ]