{-# LANGUAGE CPP #-}
module WeekDaze.OutputConfiguration.Style(
DisplayRuntimeInformation,
DisplaySupplementaryInformation,
Style(
getDisplayViews,
getMaybeCSSURL,
getMergeDuplicateTimeslots,
getDisplayAxisLabels,
getDisplayRuntimeInformation,
getDisplaySupplementaryInformation,
getWeekend,
getMaybeGenerateLessonColour
),
displayViewsTag,
displayRuntimeInformationTag,
weekendTag,
mkStyle
) where
import qualified Control.DeepSeq
import qualified Data.Default
import qualified Data.Maybe
import qualified Data.Set
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.SelfValidate
import qualified WeekDaze.Model.GenerateLessonColourFrom as Model.GenerateLessonColourFrom
import qualified WeekDaze.OutputConfiguration.View as OutputConfiguration.View
import qualified WeekDaze.Temporal.Day as Temporal.Day
import qualified WeekDaze.Temporal.TimeAxes as Temporal.TimeAxes
import WeekDaze.Enhanced.EnhancedBool()
#ifdef USE_HDBC
import qualified Database.HDBC
import qualified Data.Convertible
import qualified WeekDaze.Database.Selector as Database.Selector
instance Fractional minimumContrastRatio => Database.Selector.Selector (Style minimumContrastRatio) where
fromDatabase connection projectIdSql = let
tableName :: Database.Selector.TableName
tableName = showString Database.Selector.tablePrefix tag
in do
styleRows <- Database.Selector.select connection [
cssURLTag,
showString mergeDuplicateTimeslotsTag byDayTag,
showString mergeDuplicateTimeslotsTag byTimeslotTag,
showString displayAxisLabelsTag byDayTag,
showString displayAxisLabelsTag byTimeslotTag,
displayRuntimeInformationTag,
displaySupplementaryInformationTag,
weekendTag,
Model.GenerateLessonColourFrom.tag,
minimumContrastRatioTag
] [tableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
return $ case styleRows of
[] -> Data.Default.def
[styleRow] -> case styleRow of
[
cssURLSql,
mergeDuplicateTimeslotsByDaySql,
mergeDuplicateTimeslotsByTimeslotSql,
displayAxisLabelsByDaySql,
displayAxisLabelsByTimeslotSql,
displayRuntimeInformationSql,
displaySupplementaryInformationSql,
weekendSql,
generateLessonColourFromSql,
minimumContrastRatioSql
] -> Data.Default.def {
getMaybeCSSURL = Database.HDBC.fromSql cssURLSql,
getMergeDuplicateTimeslots = either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows (mergeDuplicateTimeslotsTag ++ byDayTag) . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql mergeDuplicateTimeslotsByDaySql
) `Temporal.TimeAxes.mkTimeAxes` either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows (mergeDuplicateTimeslotsTag ++ byTimeslotTag) . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql mergeDuplicateTimeslotsByTimeslotSql
),
getDisplayAxisLabels = either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows (displayAxisLabelsTag ++ byDayTag) . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql displayAxisLabelsByDaySql
) `Temporal.TimeAxes.mkTimeAxes` either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows (displayAxisLabelsTag ++ byTimeslotTag) . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql displayAxisLabelsByTimeslotSql
),
getDisplayRuntimeInformation = either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows displayRuntimeInformationTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql displayRuntimeInformationSql,
getDisplaySupplementaryInformation = either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows displaySupplementaryInformationTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql displaySupplementaryInformationSql,
getWeekend = Database.HDBC.fromSql weekendSql,
getMaybeGenerateLessonColour = flip (,) (
Data.Maybe.maybe minimumContrastRatioDefault realToFrac (
either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows minimumContrastRatioTag . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql minimumContrastRatioSql :: Data.Convertible.ConvertResult (Maybe Double)
)
)
) `fmap` either (
error . showString "WeekDaze.OutputConfiguration.Style.fromDatabase:\tfailed to parse the value for " . shows Model.GenerateLessonColourFrom.tag . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql generateLessonColourFromSql
)
}
_ -> error $ "WeekDaze.OutputConfiguration.Style.fromDatabase:\tunexpected number of columns=" ++ show (length styleRow) ++ " in row of table " ++ show tableName ++ "."
_ -> error $ "WeekDaze.OutputConfiguration.Style.fromDatabase:\tunexpected number of rows=" ++ show (length styleRows) ++ " selected from table " ++ show tableName ++ "."
#endif /* USE_HDBC */
tag :: String
tag = "style"
byDayTag :: String
byDayTag = "ByDay"
byTimeslotTag :: String
byTimeslotTag = "ByTimeslot"
displayViewsTag :: String
displayViewsTag = "displayViews"
cssURLTag :: String
cssURLTag = "cssURL"
mergeDuplicateTimeslotsTag :: String
mergeDuplicateTimeslotsTag = "mergeDuplicateTimeslots"
displayAxisLabelsTag :: String
displayAxisLabelsTag = "displayAxisLabels"
displayRuntimeInformationTag :: String
displayRuntimeInformationTag = "displayRuntimeInformation"
displaySupplementaryInformationTag :: String
displaySupplementaryInformationTag = "displaySupplementaryInformation"
perspectiveTag :: String
perspectiveTag = "perspective"
weekendTag :: String
weekendTag = "weekend"
minimumContrastRatioTag :: String
minimumContrastRatioTag = "minimumContrastRatio"
minimumContrastRatioDefault :: Fractional minimumContrastRatio => minimumContrastRatio
minimumContrastRatioDefault = recip 16
type TimeAxes = Temporal.TimeAxes.TimeAxes Bool
type DisplayRuntimeInformation = Bool
type DisplaySupplementaryInformation = Bool
type GenerateLessonColour minimumContrastRatio = (Model.GenerateLessonColourFrom.GenerateLessonColourFrom, minimumContrastRatio)
data Style minimumContrastRatio = MkStyle {
getDisplayViews :: Data.Set.Set OutputConfiguration.View.View,
getMaybeCSSURL :: Maybe String,
getMergeDuplicateTimeslots :: TimeAxes,
getDisplayAxisLabels :: TimeAxes,
getDisplayRuntimeInformation :: DisplayRuntimeInformation,
getDisplaySupplementaryInformation :: DisplaySupplementaryInformation,
getWeekend :: Temporal.Day.Weekend,
getMaybeGenerateLessonColour :: Maybe (GenerateLessonColour minimumContrastRatio)
} deriving (Eq, Show)
instance (
Num minimumContrastRatio,
Ord minimumContrastRatio
) => ToolShed.SelfValidate.SelfValidator (Style minimumContrastRatio) where
getErrors MkStyle {
getDisplayViews = displayViews,
getMaybeGenerateLessonColour = maybeGenerateLessonColour
} = ToolShed.SelfValidate.extractErrors [
(
Data.Set.null displayViews,
"at least one view of the results must be specified; " ++ show displayViewsTag
), (
Data.Maybe.maybe False (
(
\minimumContrastRatio -> any ($ minimumContrastRatio) [(< 0), (> 1)]
) . snd
) maybeGenerateLessonColour,
show minimumContrastRatioTag ++ "' must be within the closed unit-interval '[0,1]'"
)
]
instance Data.Default.Default (Style minimumContrastRatio) where
def = MkStyle {
getDisplayViews = Data.Set.fromList OutputConfiguration.View.range,
getMaybeCSSURL = Nothing,
getMergeDuplicateTimeslots = Temporal.TimeAxes.mkTimeAxes True True,
getDisplayAxisLabels = Temporal.TimeAxes.mkTimeAxes True True,
getDisplayRuntimeInformation = True,
getDisplaySupplementaryInformation = True,
getWeekend = Data.Set.fromList [minBound, maxBound],
getMaybeGenerateLessonColour = Nothing
}
instance Control.DeepSeq.NFData minimumContrastRatio => Control.DeepSeq.NFData (Style minimumContrastRatio) where
rnf (MkStyle x0 x1 x2 x3 x4 x5 x6 x7) = Control.DeepSeq.rnf (x0, x1, x2, x3, x4, x5, x6, x7)
mkStyle :: (
Num minimumContrastRatio,
Ord minimumContrastRatio
)
=> Data.Set.Set OutputConfiguration.View.View
-> Maybe String
-> TimeAxes
-> TimeAxes
-> DisplayRuntimeInformation
-> DisplaySupplementaryInformation
-> Temporal.Day.Weekend
-> Maybe (Model.GenerateLessonColourFrom.GenerateLessonColourFrom, minimumContrastRatio)
-> Style minimumContrastRatio
mkStyle displayViews maybeCSSURL mergeDuplicateTimeslots displayAxisLabels displayRuntimeInformation displaySupplementaryInformation weekend maybeGenerateLessonColour
| ToolShed.SelfValidate.isValid style = style
| otherwise = error $ "WeekDaze.OutputConfiguration.Style.mkStyle:\t" ++ ToolShed.SelfValidate.getFirstError style ++ "."
where
style = MkStyle {
getDisplayViews = displayViews,
getMaybeCSSURL = maybeCSSURL,
getMergeDuplicateTimeslots = mergeDuplicateTimeslots,
getDisplayAxisLabels = displayAxisLabels,
getDisplayRuntimeInformation = displayRuntimeInformation,
getDisplaySupplementaryInformation = displaySupplementaryInformation,
getWeekend = weekend,
getMaybeGenerateLessonColour = maybeGenerateLessonColour
}
instance (
Fractional minimumContrastRatio,
HXT.XmlPickler minimumContrastRatio,
Ord minimumContrastRatio
) => HXT.XmlPickler (Style minimumContrastRatio) where
xpickle = HXT.xpDefault defaultStyle . HXT.xpElem tag . HXT.xpWrap (
\(a, b, c, d, e, f, g, h) -> mkStyle a b c d e f g h,
\MkStyle {
getDisplayViews = displayViews,
getMaybeCSSURL = maybeCSSURL,
getMergeDuplicateTimeslots = mergeDuplicateTimeslots,
getDisplayAxisLabels = displayAxisLabels,
getDisplayRuntimeInformation = displayRuntimeInformation,
getDisplaySupplementaryInformation = displaySupplementaryInformation,
getWeekend = weekend,
getMaybeGenerateLessonColour = maybeGenerateLessonColour
} -> (displayViews, maybeCSSURL, mergeDuplicateTimeslots, displayAxisLabels, displayRuntimeInformation, displaySupplementaryInformation, weekend, maybeGenerateLessonColour)
) $ HXT.xp8Tuple (
HXT.xpDefault (getDisplayViews Data.Default.def) . HXT.xpElem displayViewsTag . HXT.xpWrap (
Data.Set.fromList,
Data.Set.toList
) . HXT.xpList1 $ HXT.xpElem perspectiveTag HXT.xpickle
) (
HXT.xpOption $ HXT.xpTextAttr cssURLTag
) (
getMergeDuplicateTimeslots defaultStyle `HXT.xpDefault` HXT.xpElem mergeDuplicateTimeslotsTag HXT.xpickle
) (
getDisplayAxisLabels defaultStyle `HXT.xpDefault` HXT.xpElem displayAxisLabelsTag HXT.xpickle
) (
getDisplayRuntimeInformation defaultStyle `HXT.xpDefault` HXT.xpAttr displayRuntimeInformationTag HXT.xpickle
) (
getDisplaySupplementaryInformation defaultStyle `HXT.xpDefault` HXT.xpAttr displaySupplementaryInformationTag HXT.xpickle
) (
HXT.xpDefault (getWeekend defaultStyle) . HXT.xpElem weekendTag . HXT.xpWrap (
Data.Set.fromList,
Data.Set.toList
) $ HXT.xpList HXT.xpickle
) (
HXT.xpOption . HXT.xpElem "generateLessonColour" $ HXT.xpickle `HXT.xpPair` HXT.xpDefault minimumContrastRatioDefault (
HXT.xpAttr minimumContrastRatioTag HXT.xpickle
)
) where
defaultStyle = Data.Default.def