{-# LANGUAGE CPP, FlexibleContexts, MultiParamTypeClasses #-}
module WeekDaze.ExecutionConfiguration.CriterionWeight(
CriterionWeights(..),
CriterionWeight(
deconstruct
),
mkCriterionWeight
) where
import qualified Control.DeepSeq
import qualified Data.Default
import qualified Text.XML.HXT.Arrow.Pickle as HXT
import qualified ToolShed.SelfValidate
#ifdef USE_HDBC
import qualified Database.HDBC
import qualified Data.Convertible
import qualified Data.Ratio
import qualified Data.Typeable
import qualified WeekDaze.Database.Selector as Database.Selector
instance (
Data.Convertible.Convertible Database.HDBC.SqlValue w,
Data.Typeable.Typeable w,
RealFrac w
) => Data.Convertible.Convertible Database.HDBC.SqlValue (CriterionWeight w) where
safeConvert = fmap (
mkCriterionWeight . (
\w -> if Data.Typeable.typeOf w == Data.Typeable.typeOf (undefined :: Data.Ratio.Rational)
then realToFrac $ Database.Selector.round' w
else w
)
) . Data.Convertible.safeConvert
#endif /* USE_HDBC */
newtype CriterionWeight w = MkCriterionWeight {
deconstruct :: w
} deriving (Eq, Ord, Show)
instance Num w => Bounded (CriterionWeight w) where
minBound = MkCriterionWeight 0
maxBound = MkCriterionWeight 1
instance Real w => ToolShed.SelfValidate.SelfValidator (CriterionWeight w) where
getErrors w = ToolShed.SelfValidate.extractErrors [
(
any ($ w) [(< minBound), (> maxBound)],
"'" ++ show (realToFrac $ deconstruct w :: Double ) ++ "' should be within the closed unit-interval '[0,1]'"
)
]
instance Num w => Data.Default.Default (CriterionWeight w) where
def = minBound
instance (HXT.XmlPickler w, Real w) => HXT.XmlPickler (CriterionWeight w) where
xpickle = HXT.xpWrap (mkCriterionWeight, deconstruct) HXT.xpickle
instance Control.DeepSeq.NFData w => Control.DeepSeq.NFData (CriterionWeight w) where
rnf = Control.DeepSeq.rnf . deconstruct
mkCriterionWeight :: Real w => w -> CriterionWeight w
mkCriterionWeight w
| ToolShed.SelfValidate.isValid criterionWeight = criterionWeight
| otherwise = error $ "WeekDaze.ExecutionConfiguration.CriterionWeight.mkCriterionWeight:\t" ++ ToolShed.SelfValidate.getFirstError criterionWeight ++ "."
where
criterionWeight = MkCriterionWeight w
class CriterionWeights a where
areAllZero :: a -> Bool
instance (Bounded a, Eq a) => CriterionWeights [a] where
areAllZero = all (== minBound)