From: PHO Date: Thu, 22 Apr 2010 14:19:09 +0000 (+0900) Subject: beginning of my own HList with type families... X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=001f802dc89427aebb285f4e3a8b09be1120248f;p=hs-rrdtool.git beginning of my own HList with type families... --- diff --git a/Data/HList.hs b/Data/HList.hs new file mode 100644 index 0000000..77ad6cc --- /dev/null +++ b/Data/HList.hs @@ -0,0 +1,75 @@ +module Data.HList + ( HList + , HNil(..) + , hNil + , HCons(..) + , hCons + + , HExtendable(..) + , HAppendable(..) + + , (:*:) + , (.*.) + ) + where + +import Data.Typeable + +-- HList +class HList l + +-- HNil +data HNil + = HNil + deriving (Show, Eq, Ord, Read, Typeable) + +instance HList HNil + +hNil :: HNil +hNil = HNil + +-- HCons +data HCons e l + = HCons e l + deriving (Show, Eq, Ord, Read, Typeable) + +instance HList l => HList (HCons e l) + +hCons :: HList l => e -> l -> HCons e l +hCons = HCons + +-- HExtendable +class HExtendable e l where + type HExtend e l + hExtend :: e -> l -> HExtend e l + +instance HExtendable e HNil where + type HExtend e HNil = HCons e HNil + hExtend e nil = hCons 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) + +-- HAppendable +class HAppendable l l' where + type HAppend l l' + hAppend :: l -> l' -> HAppend 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 diff --git a/Database/RRDtool.hs b/Database/RRDtool.hs index 45ae91a..34867d0 100644 --- a/Database/RRDtool.hs +++ b/Database/RRDtool.hs @@ -1,6 +1,8 @@ module Database.RRDtool ( DataSource(..) + , MentionedVars(..) + , Expr , CommonExpr , IterativeExpr @@ -10,7 +12,9 @@ module Database.RRDtool , CommonExprSet , Constant(..) + , VarName(..) , Variable(..) + , VariableSet , CommonUnaryOp(..) , CommonBinaryOp(..) , CommonTrinaryOp(..) @@ -161,14 +165,15 @@ dsTest = COMPUTE { , dsExpr = AverageOf (Const 100 .*. Const 200 .*. HNil) } +class VariableSet (MentionedVarsOf a) => MentionedVars a where + type MentionedVarsOf a + class (Show e, Eq e) => Expr e class Expr e => CommonExpr e class Expr e => IterativeExpr e class Expr e => AggregativeExpr e instance CommonExpr e => IterativeExpr e ---class MentionedVars - class (Show es, Eq es, HList es) => ExprSet es instance ExprSet HNil instance (Expr e, ExprSet es) => ExprSet (HCons e es) @@ -185,12 +190,24 @@ data Constant deriving (Show, Eq, Ord) instance Expr Constant instance CommonExpr Constant +instance MentionedVars Constant where + type MentionedVarsOf Constant = HNil -class (Show a, Eq a) => Variable a where +class (Show a, Eq a, Ord a) => VarName a where varName :: a -> String -instance Variable a => Expr a -instance Variable a => CommonExpr a +data Variable vn + = Variable !vn + deriving (Show, Eq, Ord) + +instance VarName vn => Expr (Variable vn) +instance VarName vn => CommonExpr (Variable vn) +instance VarName vn => MentionedVars (Variable vn) where + type MentionedVarsOf (Variable vn) = vn :*: HNil + +class HList vs => VariableSet vs +instance VariableSet HNil +instance (VarName vn, VariableSet vs) => VariableSet (HCons vn vs) -- Common operators data CommonUnaryOp a @@ -210,6 +227,8 @@ data CommonUnaryOp a deriving (Show, Eq, Ord) instance Expr a => Expr (CommonUnaryOp a) instance CommonExpr a => CommonExpr (CommonUnaryOp a) +instance VariableSet (MentionedVarsOf a) => MentionedVars (CommonUnaryOp a) where + type MentionedVarsOf (CommonUnaryOp a) = MentionedVarsOf a data CommonBinaryOp a b = !a :<: !b @@ -228,10 +247,20 @@ data CommonBinaryOp a b | AddNaN !a !b | AtanXY !a !b deriving (Show, Eq, Ord) -instance (Expr a, Expr b) - => Expr (CommonBinaryOp a b) -instance (CommonExpr a, CommonExpr b) - => CommonExpr (CommonBinaryOp a b) + +instance (Expr a, Expr b) => + Expr (CommonBinaryOp a b) + +instance (CommonExpr a, CommonExpr b) => + CommonExpr (CommonBinaryOp a b) + +instance (VariableSet (MentionedVarsOf a), + VariableSet (MentionedVarsOf b), + VariableSet (HAppend (MentionedVarsOf a) (MentionedVarsOf b))) => + MentionedVars (CommonBinaryOp a b) where + type MentionedVarsOf (CommonBinaryOp a b) + = HAppend (MentionedVarsOf a) (MentionedVarsOf b) + data CommonTrinaryOp a b c = If !a !b !c @@ -251,30 +280,30 @@ data CommonSetOp es instance ExprSet es => Expr (CommonSetOp es) instance CommonExprSet es => CommonExpr (CommonSetOp es) -data TrendOp v a - = Trend !v !a - | TrendNan !v !a +data TrendOp vn a + = Trend !(Variable vn) !a + | TrendNan !(Variable vn) !a deriving (Show, Eq, Ord) -instance (Variable v, Expr a) => Expr (TrendOp v a) -instance (Variable v, CommonExpr a) => CommonExpr (TrendOp v a) +instance (VarName vn, Expr a) => Expr (TrendOp vn a) +instance (VarName vn, CommonExpr a) => CommonExpr (TrendOp vn a) -data VariableShiftPredictOp ss w v - = VariableShiftPredictAverage !ss !w !v - | VariableShiftPredictSigma !ss !w !v +data VariableShiftPredictOp ss w vn + = VariableShiftPredictAverage !ss !w !(Variable vn) + | VariableShiftPredictSigma !ss !w !(Variable vn) deriving (Show, Eq, Ord) -instance (ExprSet ss, Expr w, Variable v) - => Expr (VariableShiftPredictOp ss w v) -instance (CommonExprSet ss, CommonExpr w, Variable v) - => CommonExpr (VariableShiftPredictOp ss w v) - -data FixedShiftPredictOp sm w v - = FixedShiftPredictAverage !sm !w !v - | FixedShiftPredictSigma !sm !w !v +instance (ExprSet ss, Expr w, VarName vn) + => Expr (VariableShiftPredictOp ss w vn) +instance (CommonExprSet ss, CommonExpr w, VarName vn) + => CommonExpr (VariableShiftPredictOp ss w vn) + +data FixedShiftPredictOp sm w vn + = FixedShiftPredictAverage !sm !w !(Variable vn) + | FixedShiftPredictSigma !sm !w !(Variable vn) deriving (Show, Eq, Ord) -instance (Expr sm, Expr w, Variable v) - => Expr (FixedShiftPredictOp sm w v) -instance (CommonExpr sm, CommonExpr w, Variable v) - => CommonExpr (FixedShiftPredictOp sm w v) +instance (Expr sm, Expr w, VarName vn) + => Expr (FixedShiftPredictOp sm w vn) +instance (CommonExpr sm, CommonExpr w, VarName vn) + => CommonExpr (FixedShiftPredictOp sm w vn) -- Common special values data CommonValue @@ -296,30 +325,30 @@ data IterativeValue instance Expr IterativeValue instance IterativeExpr IterativeValue -data IterativeValueOf v - = PreviousOf !v +data IterativeValueOf vn + = PreviousOf !(Variable vn) deriving (Show, Eq, Ord) -instance Variable v => Expr (IterativeValueOf v) -instance Variable v => IterativeExpr (IterativeValueOf v) +instance VarName vn => Expr (IterativeValueOf vn) +instance VarName vn => IterativeExpr (IterativeValueOf vn) -- Aggregative operators (fairly restricted due to rrdtool's -- restriction) -data AggregativeUnaryOp v - = Maximum !v - | Minimum !v - | Average !v - | StandardDeviation !v - | First !v - | Last !v - | Total !v - | Percent !v !Constant - | PercentNan !v !Constant - | LSLSlope !v - | LSLInt !v - | LSLCorrel !v +data AggregativeUnaryOp vn + = Maximum !(Variable vn) + | Minimum !(Variable vn) + | Average !(Variable vn) + | StandardDeviation !(Variable vn) + | First !(Variable vn) + | Last !(Variable vn) + | Total !(Variable vn) + | Percent !(Variable vn) !Constant + | PercentNan !(Variable vn) !Constant + | LSLSlope !(Variable vn) + | LSLInt !(Variable vn) + | LSLCorrel !(Variable vn) deriving (Show, Eq, Ord) -instance Variable v => Expr (AggregativeUnaryOp v) -instance Variable v => AggregativeExpr (AggregativeUnaryOp v) +instance VarName vn => Expr (AggregativeUnaryOp vn) +instance VarName vn => AggregativeExpr (AggregativeUnaryOp vn) -- |The 'createRRD' function lets you set up new Round Robin Database -- (RRD) files. The file is created at its final, full size and filled diff --git a/rrdtool.cabal b/rrdtool.cabal index 6dbb994..880db98 100644 --- a/rrdtool.cabal +++ b/rrdtool.cabal @@ -23,22 +23,26 @@ Source-Repository head Library Build-Depends: - HList == 0.2.*, base == 4.2.*, bindings-librrd == 0.1.*, time == 1.1.* Extensions: + DeriveDataTypeable EmptyDataDecls ExistentialQuantification + FlexibleContexts FlexibleInstances IncoherentInstances + MultiParamTypeClasses + TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances Exposed-Modules: Database.RRDtool + Data.HList GHC-Options: -Wall \ No newline at end of file