{-# LANGUAGE CPP, FlexibleContexts #-}
module WeekDaze.Aggregate.StudentBodyRegister(
StudentBodyRegister,
KnowledgeByStudentBody,
tag,
countAvailableStudentDays,
countSubjectsRequired,
extractDistinctSubjects,
reduce,
reduce',
getStudentBodies,
#ifdef USE_HDBC
fromDatabase,
#endif
hasAnyFreePeriodPreference,
hasAnyCoreKnowledgeRequirements,
hasAnyOptionalKnowledgeRequirements
) where
import Control.Arrow((&&&))
import qualified Control.Monad.Writer
import qualified Data.Foldable
import qualified Data.Map
import qualified Data.Set
import qualified WeekDaze.Aggregate.StudentBody as Aggregate.StudentBody
import qualified WeekDaze.Aggregate.StudentClass as Aggregate.StudentClass
import qualified WeekDaze.Data.HumanResource as Data.HumanResource
import qualified WeekDaze.Data.Resource as Data.Resource
import qualified WeekDaze.Data.Student as Data.Student
import qualified WeekDaze.Data.Subject as Data.Subject
import qualified WeekDaze.Size as Size
#ifdef USE_HDBC
import qualified Database.HDBC
import qualified Data.Convertible
import qualified Data.Default
import qualified Data.IntMap
import qualified Data.Maybe
import qualified Data.Typeable
import qualified WeekDaze.Database.Selector as Database.Selector
import qualified WeekDaze.Data.Group as Data.Group
import qualified WeekDaze.Data.Requirements as Data.Requirements
import qualified WeekDaze.Temporal.Availability as Temporal.Availability
import qualified WeekDaze.Temporal.FreePeriodPreference as Temporal.FreePeriodPreference
fromDatabase :: (
Database.HDBC.IConnection connection,
Data.Convertible.Convertible Database.HDBC.SqlValue level,
Data.Convertible.Convertible Database.HDBC.SqlValue stream,
Data.Convertible.Convertible Database.HDBC.SqlValue teachingRatio,
Data.Default.Default stream,
Data.Typeable.Typeable teachingRatio,
Ord level,
RealFrac teachingRatio,
Show level
)
=> connection
-> Database.HDBC.SqlValue
-> IO (StudentBodyRegister level stream teachingRatio)
fromDatabase connection projectIdSql = let
priorityColumnName, streamIdColumnName, streamNameColumnName, studentBodyRegisterIdColumnName :: Database.Selector.ColumnName
priorityColumnName = "priority"
streamIdColumnName = "streamId"
streamNameColumnName = "streamName"
studentBodyRegisterIdColumnName = showString tag "Id";
knowledgeRequirementsTableName, streamTableName, studentBodyRegisterTableName, studentBodyMembershipTableName, studentGroupMembershipTableName :: Database.Selector.TableName
[knowledgeRequirementsTableName, streamTableName, studentBodyRegisterTableName, studentBodyMembershipTableName, studentGroupMembershipTableName] = map (showString Database.Selector.tablePrefix) ["knowledgeRequirement", "stream", tag, "studentBodyMembership", "studentGroupMembership"]
in do
streamNameByStreamId <- (
Data.IntMap.fromList . map (
\row -> case row of
[streamIdSql, streamNameSql] -> (
either (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tfailed to parse the value for " . shows streamIdColumnName . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql streamIdSql,
Database.HDBC.fromSql streamNameSql
)
_ -> error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tunexpected number of columns=" . shows (length row) . showString " in row of table " $ shows streamTableName "."
)
) `fmap` Database.Selector.select connection [streamIdColumnName, streamNameColumnName] [streamTableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
#ifdef USE_HDBC_ODBC
[
selectStudentIdsForStudentBodyRegisterId,
selectKnowledgeRequirementsForStudentBodyRegisterId,
selectGroupIdsForStudentBodyRegisterId
] <- mapM (
\(columnNames, tableName) -> Database.Selector.prepare connection columnNames [tableName] [studentBodyRegisterIdColumnName]
) [
(
[Aggregate.StudentBody.studentIdTag],
studentBodyMembershipTableName
), (
[
priorityColumnName,
Data.Subject.topicTag,
Data.Subject.levelTag
],
knowledgeRequirementsTableName
), (
[Data.Group.groupIdTag],
studentGroupMembershipTableName
)
]
#endif /* USE_HDBC_ODBC */
Database.Selector.select connection [
studentBodyRegisterIdColumnName,
Aggregate.StudentBody.mnemonicTag,
Temporal.Availability.tag,
streamIdColumnName,
Data.Student.teachingRatioTag,
Temporal.FreePeriodPreference.tag
] [studentBodyRegisterTableName] [(Database.Selector.projectIdColumnName, projectIdSql)] >>= fmap Data.Map.fromList . mapM (
\studentRow -> case studentRow of
[studentBodyRegisterIdSql, mnemonicSql, availabilitySql, streamIdSql, teachingRatioSql, freePeriodPreferenceSql] -> do
#ifndef USE_HDBC_ODBC
let primaryKey = [(studentBodyRegisterIdColumnName, studentBodyRegisterIdSql)]
#endif
studentIds <- map (
Database.HDBC.fromSql . head
#ifdef USE_HDBC_ODBC
) `fmap` (
Database.HDBC.execute selectStudentIdsForStudentBodyRegisterId [studentBodyRegisterIdSql] >> Database.HDBC.fetchAllRows' selectStudentIdsForStudentBodyRegisterId
)
#else
) `fmap` Database.Selector.select connection [Aggregate.StudentBody.studentIdTag] [studentBodyMembershipTableName] primaryKey
#endif
knowledgeRequirements <- (
(
Data.Maybe.fromMaybe Data.Set.empty . Data.Map.lookup Data.Requirements.coreTag &&& Data.Maybe.fromMaybe Data.Set.empty . Data.Map.lookup Data.Requirements.optionalTag
) . Data.Map.fromListWith Data.Set.union . map (
\knowledgeRequirementRow -> case knowledgeRequirementRow of
[prioritySql, topicSql, levelSql] -> (
Data.Maybe.fromMaybe (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tnull " $ shows priorityColumnName "."
) $ Database.HDBC.fromSql prioritySql,
Data.Set.singleton $ Data.Subject.mkSubjectFromSql topicSql levelSql
)
_ -> error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tunexpected number of columns=" . shows (length knowledgeRequirementRow) . showString " in row of table " $ shows knowledgeRequirementsTableName "."
)
#ifdef USE_HDBC_ODBC
) `fmap` (
Database.HDBC.execute selectKnowledgeRequirementsForStudentBodyRegisterId [studentBodyRegisterIdSql] >> Database.HDBC.fetchAllRows' selectKnowledgeRequirementsForStudentBodyRegisterId
)
#else
) `fmap` Database.Selector.select connection [
priorityColumnName,
Data.Subject.topicTag,
Data.Subject.levelTag
] [knowledgeRequirementsTableName] primaryKey
#endif
groupMembership <- (
Data.Set.fromList . map (
either (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tfailed to parse the value for " . shows Data.Group.groupIdTag . showString " read from the database; " . show
) id . Database.HDBC.safeFromSql . head
)
#ifdef USE_HDBC_ODBC
) `fmap` (
Database.HDBC.execute selectGroupIdsForStudentBodyRegisterId [studentBodyRegisterIdSql] >> Database.HDBC.fetchAllRows' selectGroupIdsForStudentBodyRegisterId
)
#else
) `fmap` Database.Selector.select connection [Data.Group.groupIdTag] [studentGroupMembershipTableName] primaryKey
#endif
return (
Aggregate.StudentBody.mkStudentBody (
either (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tfailed to parse the value for " . shows Aggregate.StudentBody.mnemonicTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql mnemonicSql
) . Data.Set.fromList $ map (
Data.Maybe.fromMaybe (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tnull " $ shows Aggregate.StudentBody.studentIdTag "."
)
) studentIds,
Data.Student.mkProfile (
Data.Maybe.maybe Data.Default.def (
Data.Maybe.fromMaybe (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tfailed to find a " . shows streamNameColumnName . showString " corresponding to the value for " $ shows streamIdColumnName " read from the database."
) . (
`Data.IntMap.lookup` streamNameByStreamId
)
) . either (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tfailed to parse the value for " . shows streamIdColumnName . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql streamIdSql
) knowledgeRequirements (
Data.Maybe.fromMaybe (
error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tnull " $ shows Temporal.Availability.tag "."
) $ Database.HDBC.fromSql availabilitySql
) (
Database.Selector.fromSqlFractional Data.Student.defaultTeachingRatio teachingRatioSql
) groupMembership $ Database.HDBC.fromSql freePeriodPreferenceSql
)
_ -> error . showString "WeekDaze.Aggregate.StudentBodyRegister.fromDatabase:\tunexpected number of columns=" . shows (length studentRow) . showString" in row of table " $ shows studentBodyRegisterTableName "."
)
#endif /* USE_HDBC */
tag :: String
tag = "studentBodyRegister"
type StudentBodyRegister level stream teachingRatio = Data.Resource.ResourceMap Aggregate.StudentBody.StudentBody (Data.Student.Profile level stream teachingRatio)
getStudentBodies :: StudentBodyRegister level stream teachingRatio -> [Aggregate.StudentBody.StudentBody]
getStudentBodies = Data.Map.keys
extractDistinctSubjects :: Ord level => StudentBodyRegister level stream teachingRatio -> Data.Subject.Knowledge level
extractDistinctSubjects = Data.Map.foldr (Data.Set.union . Data.Student.deriveAmalgamatedKnowledgeRequirement) Data.Set.empty
reduce :: (
Ord level,
Ord stream,
Ord teachingRatio
)
=> Aggregate.StudentClass.MnemonicSeparator
-> StudentBodyRegister level stream teachingRatio
-> Control.Monad.Writer.Writer [[Aggregate.StudentBody.StudentBody]] (StudentBodyRegister level stream teachingRatio)
reduce mnemonicSeparator studentBodyRegister
| null ambiguousMnemonics = Control.Monad.Writer.writer (studentBodyRegister', mergeableStudentBodies)
| otherwise = error . showString "WeekDaze.Aggregate.StudentBodyRegister.reduce:\tsome of the mnemonics composed by merging those of student-bodies with identical profiles, are ambiguous; " $ shows ambiguousMnemonics "."
where
(studentBodyRegister', (ambiguousMnemonics, mergeableStudentBodies)) = (
Data.Map.fromList . map (
\(sharedStudentProfile, studentClass) -> (Aggregate.StudentClass.merge mnemonicSeparator studentClass, sharedStudentProfile)
) . Data.Map.toList &&& (
Data.Set.toList . Data.Set.intersection (
Data.Set.map Aggregate.StudentBody.getMnemonic $ Data.Map.keysSet studentBodyRegister
) . Data.Set.fromList . map (
Aggregate.StudentBody.getMnemonic . Aggregate.StudentClass.merge mnemonicSeparator
) &&& map Data.Set.toList
) . filter (
(/= 1) . Data.Set.size
) . Data.Map.elems
) . Data.Map.fromListWith Data.Set.union . map (
\(studentBody, studentProfile) -> (studentProfile, Data.Set.singleton studentBody)
) $ Data.Map.toList studentBodyRegister
reduce' :: (
Ord level,
Ord stream,
Ord teachingRatio
)
=> Aggregate.StudentClass.MnemonicSeparator
-> StudentBodyRegister level stream teachingRatio
-> StudentBodyRegister level stream teachingRatio
reduce' s = fst . Control.Monad.Writer.runWriter . reduce s
countAvailableStudentDays :: StudentBodyRegister level stream teachingRatio -> Size.NDays
countAvailableStudentDays = Data.Map.foldrWithKey (\studentBody -> (+) . (* Aggregate.StudentBody.getSize studentBody) . Data.Resource.countDaysPerWeekAvailable) 0
type KnowledgeByStudentBody level = Data.Map.Map Aggregate.StudentBody.StudentBody (Data.Subject.Knowledge level)
countSubjectsRequired :: KnowledgeByStudentBody level -> Int
countSubjectsRequired = Data.Map.foldrWithKey (\studentBody -> (+) . (* Aggregate.StudentBody.getSize studentBody) . Data.Set.size) 0
hasAnyFreePeriodPreference :: RealFrac teachingRatio => StudentBodyRegister level stream teachingRatio -> Bool
hasAnyFreePeriodPreference = Data.Foldable.any Data.HumanResource.hasFreePeriodPreference
hasAnyCoreKnowledgeRequirements :: StudentBodyRegister level stream teachingRatio -> Bool
hasAnyCoreKnowledgeRequirements = Data.Foldable.any Data.Student.hasAnyCoreKnowledgeRequirements
hasAnyOptionalKnowledgeRequirements :: StudentBodyRegister level stream teachingRatio -> Bool
hasAnyOptionalKnowledgeRequirements = Data.Foldable.any Data.Student.hasAnyOptionalKnowledgeRequirements