{-# LANGUAGE CPP, FlexibleContexts, UndecidableInstances #-}
module WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights (
OptimiseLessonCriteriaWeights(
getNTrials,
getChangeMagnitude,
getReductionFactor,
getUseMeanOverRasterScans
),
tag,
changeMagnitudeTag,
mkOptimiseLessonCriteriaWeights,
isRequired
) where
import qualified Control.Arrow
import qualified Control.DeepSeq
import qualified Data.Default
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.Data.Quadruple
import qualified ToolShed.SelfValidate
import WeekDaze.Enhanced.EnhancedBool()
#ifdef USE_HDBC
import qualified Database.HDBC
import qualified Data.Convertible
import qualified Data.Maybe
import qualified Data.Typeable
import qualified WeekDaze.Database.Selector as Database.Selector
instance (
Data.Convertible.Convertible Database.HDBC.SqlValue criterionWeight,
Data.Typeable.Typeable criterionWeight,
RealFrac criterionWeight
) => Database.Selector.Selector (OptimiseLessonCriteriaWeights criterionWeight) where
fromDatabase connection projectIdSql = let
optimiseLessonCriteriaWeightsTableName :: Database.Selector.TableName
optimiseLessonCriteriaWeightsTableName = Database.Selector.tablePrefix ++ tag
in do
optimiseLessonCriteriaWeightsRows <- Database.Selector.select connection [
nTrialsTag,
changeMagnitudeTag,
reductionFactorTag,
useMeanOverRasterScansTag
] [optimiseLessonCriteriaWeightsTableName] [(Database.Selector.projectIdColumnName, projectIdSql)]
return $ (
case optimiseLessonCriteriaWeightsRows of
[] -> id
[optimiseLessonCriteriaWeightsRow] -> case optimiseLessonCriteriaWeightsRow of
[nTrialsSql, changeMagnitudeSql, reductionFactorSql, useMeanOverRasterScansSql] -> (
\optimiseLessonCriteriaWeights -> Data.Maybe.maybe optimiseLessonCriteriaWeights (
\value -> optimiseLessonCriteriaWeights { getNTrials = value }
) . either (
error . showString "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.fromDatabase:\tfailed to parse the value for " . shows nTrialsTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql nTrialsSql
) . (
\optimiseLessonCriteriaWeights -> Data.Maybe.maybe optimiseLessonCriteriaWeights (
\value -> optimiseLessonCriteriaWeights { getChangeMagnitude = value }
) . either (
error . showString "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.fromDatabase:\tfailed to parse the value for " . shows changeMagnitudeTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql changeMagnitudeSql
) . (
\optimiseLessonCriteriaWeights -> Data.Maybe.maybe optimiseLessonCriteriaWeights (
\value -> optimiseLessonCriteriaWeights { getReductionFactor = value }
) . either (
error . showString "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.fromDatabase:\tfailed to parse the value for " . shows reductionFactorTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql reductionFactorSql
) . (
\optimiseLessonCriteriaWeights -> Data.Maybe.maybe optimiseLessonCriteriaWeights (
\value -> optimiseLessonCriteriaWeights { getUseMeanOverRasterScans = value }
) . either (
error . showString "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.fromDatabase:\tfailed to parse the value for " . shows useMeanOverRasterScansTag . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql useMeanOverRasterScansSql
)
_ -> error $ "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.fromDatabase:\tunexpected number of columns=" ++ show (length optimiseLessonCriteriaWeightsRow) ++ " in row of table " ++ show optimiseLessonCriteriaWeightsTableName
_ -> error $ "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.fromDatabase:\tunexpected number of rows=" ++ show (length optimiseLessonCriteriaWeightsRows) ++ " selected from table " ++ show optimiseLessonCriteriaWeightsTableName
) Data.Default.def
#endif /* USE_HDBC */
tag :: String
tag = "optimiseLessonCriteriaWeights"
nTrialsTag :: String
nTrialsTag = "nTrials"
changeMagnitudeTag :: String
changeMagnitudeTag = "changeMagnitude"
reductionFactorTag :: String
reductionFactorTag = "reductionFactor"
useMeanOverRasterScansTag :: String
useMeanOverRasterScansTag = "useMeanOverRasterScans"
type NTrials = Int
data OptimiseLessonCriteriaWeights criterionWeight = MkOptimiseLessonCriteriaWeights {
getNTrials :: NTrials,
getChangeMagnitude :: criterionWeight,
getReductionFactor :: criterionWeight,
getUseMeanOverRasterScans :: Bool
} deriving Eq
instance Show criterionWeight => Show (OptimiseLessonCriteriaWeights criterionWeight) where
showsPrec _ optimiseLessonCriteriaWeights = shows (
getNTrials optimiseLessonCriteriaWeights,
getChangeMagnitude optimiseLessonCriteriaWeights,
getReductionFactor optimiseLessonCriteriaWeights,
getUseMeanOverRasterScans optimiseLessonCriteriaWeights
)
instance (
Read criterionWeight,
Real criterionWeight,
Show criterionWeight
) => Read (OptimiseLessonCriteriaWeights criterionWeight) where
readsPrec _ = map (Control.Arrow.first $ ToolShed.Data.Quadruple.uncurry4 mkOptimiseLessonCriteriaWeights) . reads
instance Control.DeepSeq.NFData criterionWeight => Control.DeepSeq.NFData (OptimiseLessonCriteriaWeights criterionWeight) where
rnf (MkOptimiseLessonCriteriaWeights x0 x1 x2 x3) = Control.DeepSeq.rnf (x0, x1, x2, x3)
mkOptimiseLessonCriteriaWeights :: (Real criterionWeight, Show criterionWeight)
=> NTrials
-> criterionWeight
-> criterionWeight
-> Bool
-> OptimiseLessonCriteriaWeights criterionWeight
mkOptimiseLessonCriteriaWeights nTrials changeMagnitude reductionFactor useMeanOverRasterScans
| ToolShed.SelfValidate.isValid optimiseLessonCriteriaWeights = optimiseLessonCriteriaWeights
| otherwise = error $ "WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights.mkOptimiseLessonCriteriaWeights:\t" ++ ToolShed.SelfValidate.getFirstError optimiseLessonCriteriaWeights ++ "."
where
optimiseLessonCriteriaWeights = MkOptimiseLessonCriteriaWeights nTrials changeMagnitude reductionFactor useMeanOverRasterScans
instance Fractional criterionWeight => Data.Default.Default (OptimiseLessonCriteriaWeights criterionWeight) where
def = MkOptimiseLessonCriteriaWeights {
getNTrials = 0,
getChangeMagnitude = 1,
getReductionFactor = 9 / 10,
getUseMeanOverRasterScans = True
}
instance (Real criterionWeight, Show criterionWeight) => ToolShed.SelfValidate.SelfValidator (OptimiseLessonCriteriaWeights criterionWeight) where
getErrors optimiseLessonCriteriaWeights@MkOptimiseLessonCriteriaWeights {
getNTrials = nTrials,
getChangeMagnitude = changeMagnitude,
getReductionFactor = reductionFactor
} = ToolShed.SelfValidate.extractErrors [
(
nTrials < 0,
show nTrialsTag ++ " must be positive; " ++ show optimiseLessonCriteriaWeights
), (
changeMagnitude <= 0,
show changeMagnitudeTag ++ " must be greater than zero; " ++ show optimiseLessonCriteriaWeights
), (
any ($ reductionFactor) [(< 0), (> 1)],
show reductionFactorTag ++ " must be within the closed unit-interval; " ++ show optimiseLessonCriteriaWeights
)
]
instance (
Fractional criterionWeight,
HXT.XmlPickler criterionWeight,
Real criterionWeight,
Show criterionWeight
) => HXT.XmlPickler (OptimiseLessonCriteriaWeights criterionWeight) where
xpickle = HXT.xpElem tag . HXT.xpWrap (
\(a, b, c, d) -> mkOptimiseLessonCriteriaWeights a b c d,
\MkOptimiseLessonCriteriaWeights {
getNTrials = nTrials,
getChangeMagnitude = changeMagnitude,
getReductionFactor = reductionFactor,
getUseMeanOverRasterScans = useMeanOverRasterScans
} -> (
nTrials,
changeMagnitude,
reductionFactor,
useMeanOverRasterScans
)
) $ HXT.xp4Tuple (
getNTrials def `HXT.xpDefault` HXT.xpAttr nTrialsTag HXT.xpickle
) (
getChangeMagnitude def `HXT.xpDefault` HXT.xpAttr changeMagnitudeTag HXT.xpickle
) (
getReductionFactor def `HXT.xpDefault` HXT.xpAttr reductionFactorTag HXT.xpickle
) (
getUseMeanOverRasterScans def `HXT.xpDefault` HXT.xpAttr useMeanOverRasterScansTag HXT.xpickle
) where
def = Data.Default.def
isRequired :: OptimiseLessonCriteriaWeights criterionWeight -> Bool
isRequired MkOptimiseLessonCriteriaWeights { getNTrials = nTrials } = nTrials > 0