From 7e721a4376f8b8e4f6fbe4e994236b6850bde3b2 Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 23 Apr 2010 01:41:52 +0900 Subject: [PATCH] major refactoring --- Data/HList.hs | 135 +++++++++++++++++++++++++++++++++----------- Database/RRDtool.hs | 75 +++++++++++++++++++++--- 2 files changed, 170 insertions(+), 40 deletions(-) diff --git a/Data/HList.hs b/Data/HList.hs index 77ad6cc..05dd901 100644 --- a/Data/HList.hs +++ b/Data/HList.hs @@ -2,14 +2,21 @@ module Data.HList ( HList , HNil(..) , hNil - , HCons(..) - , hCons + , (:*:)(..) + , (.*.) , HExtendable(..) , HAppendable(..) - , (:*:) - , (.*.) + , Applyable(..) + , Applyable2(..) + + , Id(..) + , ApplyHAppend(..) + + , HFoldrable(..) + , HConcatable(..) + , HMappable(..) ) where @@ -28,15 +35,18 @@ instance HList HNil hNil :: HNil hNil = HNil --- HCons -data HCons e l - = HCons e l +-- :*: +infixr 2 :*: +infixr 2 .*. + +data e :*: l + = e :*: l deriving (Show, Eq, Ord, Read, Typeable) -instance HList l => HList (HCons e l) +instance HList l => HList (e :*: l) -hCons :: HList l => e -> l -> HCons e l -hCons = HCons +(.*.) :: HList l => e -> l -> e :*: l +(.*.) = (:*:) -- HExtendable class HExtendable e l where @@ -44,32 +54,91 @@ class HExtendable e l where hExtend :: e -> l -> HExtend e l instance HExtendable e HNil where - type HExtend e HNil = HCons e HNil - hExtend e nil = hCons e nil + type HExtend e HNil = e :*: HNil + hExtend e nil = e .*. nil -instance HList l => HExtendable e (HCons e' l) where - type HExtend e (HCons e' l) = HCons e (HCons e' l) - hExtend e (HCons e' l) = hCons e (hCons e' l) +instance HList l => HExtendable e (e' :*: l) where + type HExtend e (e' :*: l) = e :*: e' :*: l + hExtend e (e' :*: l) = e .*. e' .*. l -- HAppendable +infixr 1 :++: +infixr 1 .++. + class HAppendable l l' where - type HAppend l l' - hAppend :: l -> l' -> HAppend l l' + type l :++: l' + (.++.) :: l -> l' -> l :++: l' instance HList l => HAppendable HNil l where - type HAppend HNil l = l - hAppend _ l = l - -instance (HAppendable l l', - HList (HAppend l l')) => HAppendable (HCons e l) l' where - type HAppend (HCons e l) l' = HCons e (HAppend l l') - hAppend (HCons e l) l' = hCons e (hAppend l l') - --- :*: -infixr 2 :*: -infixr 2 .*. - -type e :*: l = HCons e l - -(.*.) :: HExtendable e l => e -> l -> HExtend e l -e .*. l = hExtend e l + type HNil :++: l = l + _ .++. l = l + +instance ( HAppendable l l' + , HList (l :++: l') + ) => HAppendable (e :*: l) l' where + type (e :*: l) :++: l' = e :*: (l :++: l') + (e :*: l) .++. l' = e .*. (l .++. l') + +-- Applyable +class Applyable f a where + type Apply f a + apply :: f -> a -> Apply f a + +-- Applyable2 +class Applyable2 f a b where + type Apply2 f a b + apply2 :: f -> a -> b -> Apply2 f a b + +-- Id +data Id = Id + +instance Applyable Id a where + type Apply Id a = a + apply _ a = a + +-- ApplyHAppend +data ApplyHAppend = ApplyHAppend + +instance HAppendable a b => Applyable2 ApplyHAppend a b where + type Apply2 ApplyHAppend a b = a :++: b + apply2 _ a b = a .++. b + +-- HFoldrable +class HFoldrable f v l where + type HFoldr f v l + hFoldr :: f -> v -> l -> HFoldr f v l + +instance HFoldrable f v HNil where + type HFoldr f v HNil = v + hFoldr _ v _ = v + +instance ( HFoldrable f v l + , Applyable2 f e (HFoldr f v l) + ) => HFoldrable f v (e :*: l) where + type HFoldr f v (e :*: l) = Apply2 f e (HFoldr f v l) + hFoldr f v (e :*: l) = apply2 f e (hFoldr f v l) + +-- HConcatable +class HConcatable ls where + type HConcat ls + hConcat :: ls -> HConcat ls + +instance HFoldrable ApplyHAppend HNil ls => HConcatable ls where + type HConcat ls = HFoldr ApplyHAppend HNil ls + hConcat ls = hFoldr ApplyHAppend hNil ls + +-- HMappable +class HMappable f l where + type HMap f l + hMap :: f -> l -> HMap f l + +instance HMappable f HNil where + type HMap f HNil = HNil + hMap _ _ = HNil + +instance ( HList (HMap f xs) + , Applyable f x + , HMappable f xs + ) => HMappable f (x :*: xs) where + type HMap f (x :*: xs) = Apply f x :*: HMap f xs + hMap f (x :*: xs) = apply f x .*. hMap f xs diff --git a/Database/RRDtool.hs b/Database/RRDtool.hs index 34867d0..df0fc48 100644 --- a/Database/RRDtool.hs +++ b/Database/RRDtool.hs @@ -2,6 +2,7 @@ module Database.RRDtool ( DataSource(..) , MentionedVars(..) + , ApplyMentionedVarsOf(..) , Expr , CommonExpr @@ -165,9 +166,18 @@ dsTest = COMPUTE { , dsExpr = AverageOf (Const 100 .*. Const 200 .*. HNil) } +-- MentionedVars class VariableSet (MentionedVarsOf a) => MentionedVars a where type MentionedVarsOf a +-- ApplyMentionedVarsOf +data ApplyMentionedVarsOf = ApplyMentionedVarsOf + +instance Applyable ApplyMentionedVarsOf a where + type Apply ApplyMentionedVarsOf a = MentionedVarsOf a + apply = undefined + +-- Expr class (Show e, Eq e) => Expr e class Expr e => CommonExpr e class Expr e => IterativeExpr e @@ -176,12 +186,12 @@ instance CommonExpr e => IterativeExpr e class (Show es, Eq es, HList es) => ExprSet es instance ExprSet HNil -instance (Expr e, ExprSet es) => ExprSet (HCons e es) +instance (Expr e, ExprSet es) => ExprSet (e :*: es) class (Show es, Eq es, HList es) => CommonExprSet es instance CommonExprSet es => ExprSet es instance CommonExprSet HNil -instance (CommonExpr e, CommonExprSet es) => CommonExprSet (HCons e es) +instance (CommonExpr e, CommonExprSet es) => CommonExprSet (e :*: es) -- Constants and variable names @@ -207,7 +217,7 @@ instance VarName vn => MentionedVars (Variable vn) where class HList vs => VariableSet vs instance VariableSet HNil -instance (VarName vn, VariableSet vs) => VariableSet (HCons vn vs) +instance (VarName v, VariableSet vs) => VariableSet (v :*: vs) -- Common operators data CommonUnaryOp a @@ -254,31 +264,45 @@ instance (Expr a, Expr b) => instance (CommonExpr a, CommonExpr b) => CommonExpr (CommonBinaryOp a b) -instance (VariableSet (MentionedVarsOf a), - VariableSet (MentionedVarsOf b), - VariableSet (HAppend (MentionedVarsOf a) (MentionedVarsOf b))) => +instance VariableSet (MentionedVarsOf a :++: MentionedVarsOf b) => MentionedVars (CommonBinaryOp a b) where type MentionedVarsOf (CommonBinaryOp a b) - = HAppend (MentionedVarsOf a) (MentionedVarsOf b) + = MentionedVarsOf a :++: MentionedVarsOf b data CommonTrinaryOp a b c = If !a !b !c | Limit !a !b !c deriving (Show, Eq, Ord) + instance (Expr a, Expr b, Expr c) => Expr (CommonTrinaryOp a b c) + instance (CommonExpr a, CommonExpr b, CommonExpr c) => CommonExpr (CommonTrinaryOp a b c) +instance VariableSet (MentionedVarsOf a :++: + MentionedVarsOf b :++: + MentionedVarsOf c) => + MentionedVars (CommonTrinaryOp a b c) where + type MentionedVarsOf (CommonTrinaryOp a b c) + = MentionedVarsOf a :++: + MentionedVarsOf b :++: + MentionedVarsOf c + -- SORT and REV can't be expressed in this way as they pushes possibly -- multiple values onto the stack... data CommonSetOp es = AverageOf !es deriving (Show, Eq, Ord) + instance ExprSet es => Expr (CommonSetOp es) instance CommonExprSet es => CommonExpr (CommonSetOp es) +instance VariableSet (HConcat (HMap ApplyMentionedVarsOf es)) => + MentionedVars (CommonSetOp es) where + type MentionedVarsOf (CommonSetOp es) + = HConcat (HMap ApplyMentionedVarsOf es) data TrendOp vn a = Trend !(Variable vn) !a @@ -286,6 +310,8 @@ data TrendOp vn a deriving (Show, Eq, Ord) instance (VarName vn, Expr a) => Expr (TrendOp vn a) instance (VarName vn, CommonExpr a) => CommonExpr (TrendOp vn a) +instance (VarName vn, MentionedVars a) => MentionedVars (TrendOp vn a) where + type MentionedVarsOf (TrendOp vn a) = vn :*: MentionedVarsOf a data VariableShiftPredictOp ss w vn = VariableShiftPredictAverage !ss !w !(Variable vn) @@ -295,16 +321,30 @@ instance (ExprSet ss, Expr w, VarName vn) => Expr (VariableShiftPredictOp ss w vn) instance (CommonExprSet ss, CommonExpr w, VarName vn) => CommonExpr (VariableShiftPredictOp ss w vn) +instance ( VarName vn + , VariableSet (MentionedVarsOf ss :++: MentionedVarsOf w) + ) => MentionedVars (VariableShiftPredictOp ss w vn) where + type MentionedVarsOf (VariableShiftPredictOp ss w vn) + = vn :*: (MentionedVarsOf ss :++: MentionedVarsOf w) +-- FixedShiftPredictOp data FixedShiftPredictOp sm w vn = FixedShiftPredictAverage !sm !w !(Variable vn) | FixedShiftPredictSigma !sm !w !(Variable vn) deriving (Show, Eq, Ord) + instance (Expr sm, Expr w, VarName vn) => Expr (FixedShiftPredictOp sm w vn) + instance (CommonExpr sm, CommonExpr w, VarName vn) => CommonExpr (FixedShiftPredictOp sm w vn) +instance ( VarName vn + , VariableSet (MentionedVarsOf sm :++: MentionedVarsOf w) + ) => MentionedVars (FixedShiftPredictOp sm w vn) where + type MentionedVarsOf (FixedShiftPredictOp sm w vn) + = vn :*: (MentionedVarsOf sm :++: MentionedVarsOf w) + -- Common special values data CommonValue = Unknown @@ -312,9 +352,14 @@ data CommonValue | NegativeInfinity | Now deriving (Show, Eq, Ord) + instance Expr CommonValue + instance CommonExpr CommonValue +instance MentionedVars CommonValue where + type MentionedVarsOf CommonValue = HNil + -- Iterative special values data IterativeValue = Previous @@ -322,15 +367,26 @@ data IterativeValue | TakenTime | TakenLocalTime deriving (Show, Eq, Ord) + instance Expr IterativeValue + instance IterativeExpr IterativeValue +instance MentionedVars IterativeValue where + type MentionedVarsOf IterativeValue = HNil + +-- Iterative special values of something data IterativeValueOf vn = PreviousOf !(Variable vn) deriving (Show, Eq, Ord) + instance VarName vn => Expr (IterativeValueOf vn) + instance VarName vn => IterativeExpr (IterativeValueOf vn) +instance VarName vn => MentionedVars (IterativeValueOf vn) where + type MentionedVarsOf (IterativeValueOf vn) = vn :*: HNil + -- Aggregative operators (fairly restricted due to rrdtool's -- restriction) data AggregativeUnaryOp vn @@ -347,9 +403,14 @@ data AggregativeUnaryOp vn | LSLInt !(Variable vn) | LSLCorrel !(Variable vn) deriving (Show, Eq, Ord) + instance VarName vn => Expr (AggregativeUnaryOp vn) + instance VarName vn => AggregativeExpr (AggregativeUnaryOp vn) +instance VarName vn => MentionedVars (AggregativeUnaryOp vn) where + type MentionedVarsOf (AggregativeUnaryOp vn) = vn :*: HNil + -- |The 'createRRD' function lets you set up new Round Robin Database -- (RRD) files. The file is created at its final, full size and filled -- with @*UNKNOWN*@ data. -- 2.40.0