module WeekDaze.Aggregate.StudentBody(
Mnemonic,
StudentBody(
getMnemonic,
getStudentIds
),
mnemonicTag,
studentIdTag,
getSize,
toPair,
mkStudentBody
) where
import qualified Control.Arrow
import Control.Arrow((&&&))
import qualified Control.DeepSeq
import qualified Data.List
import qualified Data.Set
import qualified Text.XHtml.Strict
import Text.XHtml.Strict((<<), (!))
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.SelfValidate
import qualified WeekDaze.Data.Student as Data.Student
import qualified WeekDaze.Size as Size
tag :: String
tag = "studentBody"
mnemonicTag :: String
mnemonicTag = "mnemonic"
studentTag :: String
studentTag = "student"
studentIdTag :: String
studentIdTag = "studentId"
type Mnemonic = String
type Members = Data.Set.Set Data.Student.Id
data StudentBody = MkStudentBody {
getMnemonic :: Mnemonic,
getStudentIds :: Members
}
instance Ord StudentBody where
MkStudentBody mnemonicL _ `compare` MkStudentBody mnemonicR _ = mnemonicL `compare` mnemonicR
instance Eq StudentBody where
MkStudentBody mnemonicL _ == MkStudentBody mnemonicR _ = mnemonicL == mnemonicR
instance Read StudentBody where
readsPrec _ = map (Control.Arrow.first $ uncurry mkStudentBody . Control.Arrow.second Data.Set.fromList) . reads
instance Show StudentBody where
showsPrec _ = shows . Control.Arrow.second Data.Set.toList . toPair
instance Text.XHtml.Strict.HTML StudentBody where
toHtml studentBody = Text.XHtml.Strict.thespan ! [
Text.XHtml.Strict.theclass tag,
Text.XHtml.Strict.title . Data.List.intercalate ", " . map show . Data.Set.toList $ getStudentIds studentBody
] << getMnemonic studentBody
instance ToolShed.SelfValidate.SelfValidator StudentBody where
getErrors studentBody = ToolShed.SelfValidate.extractErrors [
(null $ getMnemonic studentBody, "null mnemonic for student-ids; " ++ show (getStudentIds studentBody)),
(Data.Set.null $ getStudentIds studentBody, "zero student-ids are members of the student-body of mnemonic " ++ show (getMnemonic studentBody))
]
instance HXT.XmlPickler StudentBody where
xpickle = HXT.xpElem tag . HXT.xpWrap (
uncurry mkStudentBody . Control.Arrow.second Data.Set.fromList,
Control.Arrow.second Data.Set.toList . toPair
) $ HXT.xpTextAttr mnemonicTag `HXT.xpPair` (
HXT.xpList1 . HXT.xpElem studentTag $ HXT.xpTextAttr studentIdTag
)
instance Control.DeepSeq.NFData StudentBody where
rnf = Control.DeepSeq.rnf . toPair
mkStudentBody :: Mnemonic -> Members -> StudentBody
mkStudentBody mnemonic students
| ToolShed.SelfValidate.isValid studentBody = studentBody
| otherwise = error $ "WeekDaze.Aggregate.StudentBody.mkStudentBody:\t" ++ ToolShed.SelfValidate.getFirstError studentBody ++ "."
where
studentBody = MkStudentBody mnemonic students
toPair :: StudentBody -> (Mnemonic, Members)
toPair = getMnemonic &&& getStudentIds
getSize :: StudentBody -> Size.NStudents
getSize = Data.Set.size . getStudentIds