{-# LANGUAGE CPP #-}
module WeekDaze.Data.Location(
FacilityName,
FacilityNames,
WastedResources,
Locus,
Profile(
getCapacity,
getFacilityNames,
getAvailability,
getCampus
),
capacityTag,
facilityTypeIdTag,
facilityNameTag,
facilityValueTag,
defaultFacilityNames,
calculateWaste,
calculateRelativeWaste,
calculateRelativeUse,
#ifdef USE_HDBC
findFacilityNameByFacilityTypeId,
#endif
getWastedFacilityNames,
mkProfile,
hasFacilities,
isSuitable
) where
import Control.Arrow((&&&), (***))
import qualified Control.DeepSeq
import qualified Data.Default
import qualified Data.Set
import Data.Set((\\))
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified Text.XML.HXT.DOM.Util
import qualified ToolShed.SelfValidate
import qualified WeekDaze.Data.Resource as Data.Resource
import qualified WeekDaze.Size as Size
import qualified WeekDaze.Temporal.Availability as Temporal.Availability
#ifdef USE_HDBC
import qualified Database.HDBC
import qualified Data.IntMap
import qualified WeekDaze.Database.Selector as Database.Selector
facilityTypeTableName :: Database.Selector.TableName
facilityTypeTableName = Database.Selector.tablePrefix ++ "facilityType"
findFacilityNameByFacilityTypeId
:: Database.HDBC.IConnection connection
=> connection
-> Database.HDBC.SqlValue
-> IO (Data.IntMap.IntMap FacilityName)
findFacilityNameByFacilityTypeId connection projectIdSql = (
Data.IntMap.fromList . map (
\row -> case row of
[facilityTypeIdSql, facilityNameSql] -> (
either (
error . showString "WeekDaze.Data.Location.findFacilityNameByFacilityTypeId:\tfailed to parse the value for " . shows facilityTypeIdTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql facilityTypeIdSql,
Database.HDBC.fromSql facilityNameSql
)
_ -> error $ "WeekDaze.Data.Location.findFacilityNameByFacilityTypeId:\tunexpected number of columns=" ++ show (length row) ++ " in row of table " ++ show facilityTypeTableName ++ "."
)
) `fmap` Database.Selector.select connection [facilityTypeIdTag, facilityNameTag] [facilityTypeTableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
#endif /* USE_HDBC */
tag :: String
tag = "locationProfile"
capacityTag :: String
capacityTag = "capacity"
facilitiesTag :: String
facilitiesTag = "facilities"
facilityTypeIdTag :: String
facilityTypeIdTag = "facilityTypeId"
facilityNameTag :: String
facilityNameTag = "facilityName"
facilityValueTag :: String
facilityValueTag = "value"
type FacilityName = String
type FacilityNames = Data.Set.Set FacilityName
defaultFacilityNames :: FacilityNames
defaultFacilityNames = Data.Set.empty
data Profile campus = MkProfile {
getCapacity :: Size.NStudents,
getFacilityNames :: FacilityNames,
getAvailability :: Temporal.Availability.Availability,
getCampus :: campus
} deriving (Eq, Show)
instance Show campus => ToolShed.SelfValidate.SelfValidator (Profile campus) where
getErrors profile@MkProfile {
getAvailability = availability
}
| not $ ToolShed.SelfValidate.isValid availability = ToolShed.SelfValidate.getErrors availability
| otherwise = ToolShed.SelfValidate.extractErrors [
(getCapacity profile <= 0, show capacityTag ++ " must exceed zero; " ++ show profile)
]
instance Data.Resource.Resource (Profile campus) where
getAvailability = getAvailability
instance (
Data.Default.Default campus,
Eq campus,
HXT.XmlPickler campus,
Show campus
) => HXT.XmlPickler (Profile campus) where
xpickle = HXT.xpElem tag . HXT.xpWrap (
Text.XML.HXT.DOM.Util.uncurry4 mkProfile,
\MkProfile {
getCapacity = capacity,
getFacilityNames = facilityNames,
getAvailability = availability,
getCampus = campus
} -> (
capacity,
facilityNames,
availability,
campus
)
) $ HXT.xp4Tuple (
HXT.xpAttr capacityTag HXT.xpInt
) (
HXT.xpDefault defaultFacilityNames . HXT.xpElem facilitiesTag . HXT.xpWrap (
Data.Set.fromList,
Data.Set.toList
) . HXT.xpList1 . HXT.xpElem facilityNameTag $ HXT.xpTextAttr facilityValueTag
) (
HXT.xpDefault Data.Default.def HXT.xpickle
) (
HXT.xpDefault Data.Default.def HXT.xpickle
)
instance Control.DeepSeq.NFData campus => Control.DeepSeq.NFData (Profile campus) where
rnf (MkProfile x0 x1 x2 x3) = Control.DeepSeq.rnf (x0, x1, x2, x3)
mkProfile
:: Show campus
=> Size.NStudents
-> FacilityNames
-> Temporal.Availability.Availability
-> campus
-> Profile campus
mkProfile capacity facilityNames availability campus
| ToolShed.SelfValidate.isValid profile = profile
| otherwise = error $ "WeekDaze.Data.Location.mkProfile:\t" ++ ToolShed.SelfValidate.getFirstError profile ++ "."
where
profile = MkProfile capacity facilityNames availability campus
isSuitable
:: Size.NStudents
-> FacilityNames
-> Profile campus
-> Bool
isSuitable requiredCapacity requiredFacilityNames profile = requiredCapacity <= getCapacity profile && requiredFacilityNames `Data.Set.isSubsetOf` getFacilityNames profile
hasFacilities :: Profile campus -> Bool
hasFacilities = not . Data.Set.null . getFacilityNames
type WastedResources = (Size.NStudents, FacilityNames)
getWastedCapacity :: WastedResources -> Size.NStudents
getWastedCapacity = fst
getWastedFacilityNames :: WastedResources -> FacilityNames
getWastedFacilityNames = snd
calculateWaste
:: Size.NStudents
-> FacilityNames
-> Profile campus
-> WastedResources
calculateWaste requiredCapacity requiredFacilities = subtract requiredCapacity . getCapacity &&& (\\ requiredFacilities) . getFacilityNames
calculateRelativeWaste :: Fractional relativeWaste => Profile campus -> WastedResources -> (relativeWaste, relativeWaste)
calculateRelativeWaste profile wastedResources = (
fromIntegral (getWastedCapacity wastedResources) / fromIntegral (getCapacity profile),
let
nFacilities = Data.Set.size $ getFacilityNames profile
in if nFacilities == 0
then 0
else fromIntegral (Data.Set.size $ getWastedFacilityNames wastedResources) / fromIntegral nFacilities
)
calculateRelativeUse :: Fractional relativeUse => Profile campus -> WastedResources -> (relativeUse, relativeUse)
calculateRelativeUse profile = ((1 -) *** (1 -)) . calculateRelativeWaste profile
type Locus locationId = Data.Set.Set locationId