X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Database%2FRRDtool%2FExpression.hs;h=fa6aa5452cd2137d494ee624bcacfb3e77f89612;hb=000307857df5266907964aff4ecc9e118314fe3f;hp=ec5b23adc20b6fab4c1f280edfa02dd828219957;hpb=57b97113a93d366f14278a12b8170a1c06e258a1;p=hs-rrdtool.git

diff --git a/Database/RRDtool/Expression.hs b/Database/RRDtool/Expression.hs
index ec5b23a..fa6aa54 100644
--- a/Database/RRDtool/Expression.hs
+++ b/Database/RRDtool/Expression.hs
@@ -1,19 +1,24 @@
+{-# LANGUAGE
+  EmptyDataDecls,
+  FlexibleInstances,
+  TypeFamilies,
+  TypeOperators,
+  MultiParamTypeClasses,
+  UndecidableInstances
+  #-}
 module Database.RRDtool.Expression
-    ( MentionedVars(..)
-    , ApplyMentionedVarsOf(..)
+    ( MentionedVars
+    , MentionedVarsA(..)
 
     , IsExpr
     , IsCommonExpr
-    , IterativeExpr
-    , IsAggregativeExpr
+    , IsIterativeExpr
 
-    , IsExprSet
-    , IsCommonExprSet
+    , IsVarName
+    , hString
 
     , Constant(..)
-    , IsVarName
     , Variable(..)
-    , IsVariableSet
     , CommonUnaryOp(..)
     , CommonBinaryOp(..)
     , CommonTrinaryOp(..)
@@ -30,63 +35,88 @@ module Database.RRDtool.Expression
 
 import Data.HList
 import Data.HList.String
+import Types.Data.Bool
+import Types.Data.Num hiding ((:*:))
+import Types.Data.Ord
 
 
 -- MentionedVars
-class IsVariableSet (MentionedVarsOf a) => MentionedVars a where
-    type MentionedVarsOf a
+type family MentionedVars a
 
--- ApplyMentionedVarsOf
-data ApplyMentionedVarsOf = ApplyMentionedVarsOf
+-- MentionedVarsA
+data MentionedVarsA = MentionedVarsA
 
-instance Applyable ApplyMentionedVarsOf a where
-    type Apply ApplyMentionedVarsOf a = MentionedVarsOf a
-    apply = undefined
+instance ApplyT MentionedVarsA a where
+    type Apply MentionedVarsA a = MentionedVars a
 
 -- IsExpr
-class (Show e, Eq e) => IsExpr e
-class IsExpr e => IsCommonExpr e
-class IsExpr e => IterativeExpr e
-class IsExpr e => IsAggregativeExpr e
+--class (Show e, Eq e) => IsExpr e
+type family IsExpr e
+type family IsCommonExpr e
+type family IsIterativeExpr e
 
-class (Show es, Eq es, HList es) => IsExprSet es
-instance IsExprSet HNil
-instance (IsExpr e, IsExprSet es) => IsExprSet (HCons e es)
+type family   IsExprSet es
+type instance IsExprSet Nil         = True
+type instance IsExprSet (Cons e es) = IsExpr e :&&: IsExprSet es
 
-class (Show es, Eq es, HList es) => IsCommonExprSet es
-instance IsCommonExprSet HNil
-instance (IsCommonExpr e, IsCommonExprSet es) => IsCommonExprSet (HCons e es)
+type family   IsCommonExprSet es
+type instance IsCommonExprSet Nil         = True
+type instance IsCommonExprSet (Cons e es) = IsCommonExpr e :&&: IsCommonExprSet es
 
+type family   IsIterativeExprSet es
+type instance IsIterativeExprSet Nil         = True
+type instance IsIterativeExprSet (Cons e es) = IsIterativeExpr e :&&: IsIterativeExprSet es
 
 -- Constants and variable names
 data Constant
     = Const !Double
     deriving (Show, Eq, Ord)
-instance IsExpr Constant
-instance IsCommonExpr Constant
-instance MentionedVars Constant where
-    type MentionedVarsOf Constant = HNil
+
+type instance IsExpr          Constant = True
+type instance IsCommonExpr    Constant = True
+type instance IsIterativeExpr Constant = True
+type instance MentionedVars   Constant = Nil
 
 {- This is what we want to do but GHC can't handle this for now. 
-class ( (HLengthOf a :<=: D255) ~ True
-      , HString a
+class ( (Length str :<=: D19) ~ True
+      , HString str
       )
-    => IsVarName a
+    => IsVarName str
 -}
-class HString a => IsVarName a
-
-data Variable vn
-    = Variable !vn
-    deriving (Show, Eq, Ord)
-
-instance IsVarName vn => IsExpr (Variable vn)
-instance IsVarName vn => IsCommonExpr (Variable vn)
-instance IsVarName vn => MentionedVars (Variable vn) where
-    type MentionedVarsOf (Variable vn) = vn :*: HNil
-
-class HList vs => IsVariableSet vs
-instance IsVariableSet HNil
-instance (IsVarName v, IsVariableSet vs) => IsVariableSet (HCons v vs)
+type family   IsVarName str
+type instance IsVarName str = ( (Length str :>: D0)
+                                :&&:
+                                (Length str :<=: D19)
+                                :&&:
+                                (All IsGoodLetterForVarNameA str)
+                              )
+
+type family   IsGoodLetterForVarName c
+type instance IsGoodLetterForVarName c = ( ((c :>=: D65) :&&: (c :<=:  D90)) -- A-Z
+                                           :||:
+                                           ((c :>=: D97) :&&: (c :<=: D122)) -- a-z
+                                           :||:
+                                           (c :==: D45) -- '-'
+                                           :||:
+                                           (c :==: D95) -- '_'
+                                         )
+
+data IsGoodLetterForVarNameA
+instance ApplyT IsGoodLetterForVarNameA c where
+    type Apply IsGoodLetterForVarNameA c = IsGoodLetterForVarName c
+
+-- Variable
+data Variable vn = Var !vn
+                   deriving (Show, Eq, Ord)
+
+type instance IsExpr          (Variable vn) = True
+type instance IsCommonExpr    (Variable vn) = True
+type instance IsIterativeExpr (Variable vn) = True
+type instance MentionedVars   (Variable vn) = vn :&: Nil
+
+type family   IsVariableSet vs
+type instance IsVariableSet Nil         = True
+type instance IsVariableSet (Cons v vs) = IsVarName v :&&: IsVariableSet vs
 
 -- Common operators
 data CommonUnaryOp a
@@ -104,10 +134,11 @@ data CommonUnaryOp a
     | Rad2Deg    !a
     | Abs        !a
     deriving (Show, Eq, Ord)
-instance IsExpr a => IsExpr (CommonUnaryOp a)
-instance IsCommonExpr a => IsCommonExpr (CommonUnaryOp a)
-instance IsVariableSet (MentionedVarsOf a) => MentionedVars (CommonUnaryOp a) where
-    type MentionedVarsOf (CommonUnaryOp a) = MentionedVarsOf a
+
+type instance IsExpr          (CommonUnaryOp a) = IsExpr a
+type instance IsCommonExpr    (CommonUnaryOp a) = IsCommonExpr a
+type instance IsIterativeExpr (CommonUnaryOp a) = IsIterativeExpr a
+type instance MentionedVars   (CommonUnaryOp a) = MentionedVars a
 
 data CommonBinaryOp a b
     = !a :<:  !b
@@ -127,16 +158,17 @@ data CommonBinaryOp a b
     | AtanXY !a !b
     deriving (Show, Eq, Ord)
 
-instance (IsExpr a, IsExpr b) =>
-    IsExpr (CommonBinaryOp a b)
+type instance IsExpr (CommonBinaryOp a b)
+    = IsExpr a :&&: IsExpr b
+
+type instance IsCommonExpr (CommonBinaryOp a b)
+    = IsCommonExpr a :&&: IsCommonExpr b
 
-instance (IsCommonExpr a, IsCommonExpr b) =>
-    IsCommonExpr (CommonBinaryOp a b)
+type instance IsIterativeExpr (CommonBinaryOp a b)
+    = IsIterativeExpr a :&&: IsIterativeExpr b
 
-instance IsVariableSet (MentionedVarsOf a :++: MentionedVarsOf b) =>
-    MentionedVars (CommonBinaryOp a b) where
-        type MentionedVarsOf (CommonBinaryOp a b)
-            = MentionedVarsOf a :++: MentionedVarsOf b
+type instance MentionedVars (CommonBinaryOp a b)
+    = MentionedVars a :++: MentionedVars b
         
 
 data CommonTrinaryOp a b c
@@ -144,58 +176,60 @@ data CommonTrinaryOp a b c
     | Limit !a !b !c
     deriving (Show, Eq, Ord)
 
-instance (IsExpr a, IsExpr b, IsExpr c)
-    => IsExpr (CommonTrinaryOp a b c)
+type instance IsExpr (CommonTrinaryOp a b c)
+    = IsExpr a :&&: IsExpr b :&&: IsExpr c
 
-instance (IsCommonExpr a, IsCommonExpr b, IsCommonExpr c)
-    => IsCommonExpr (CommonTrinaryOp a b c)
+type instance IsCommonExpr (CommonTrinaryOp a b c)
+    = IsCommonExpr a :&&: IsCommonExpr b :&&: IsCommonExpr c
 
-instance IsVariableSet (MentionedVarsOf a :++:
-                        MentionedVarsOf b :++:
-                        MentionedVarsOf c) =>
-    MentionedVars (CommonTrinaryOp a b c) where
-        type MentionedVarsOf (CommonTrinaryOp a b c)
-            = MentionedVarsOf a :++:
-              MentionedVarsOf b :++:
-              MentionedVarsOf c
+type instance IsIterativeExpr (CommonTrinaryOp a b c)
+    = IsIterativeExpr a :&&:
+      IsIterativeExpr b :&&:
+      IsIterativeExpr c
 
--- SORT and REV can't be expressed in this way as they pushes possibly
+type instance MentionedVars (CommonTrinaryOp a b c)
+    = MentionedVars a :++: MentionedVars b :++: MentionedVars c
+
+-- SORT and REV can't be expressed in this way as they push possibly
 -- multiple values onto the stack...
 
 data CommonSetOp es
     = AverageOf !es
     deriving (Show, Eq, Ord)
 
-instance IsExprSet es => IsExpr (CommonSetOp es)
-instance (IsExprSet es, IsCommonExprSet es) => IsCommonExpr (CommonSetOp es)
-instance IsVariableSet (HConcat (HMap ApplyMentionedVarsOf es)) =>
-    MentionedVars (CommonSetOp es) where
-        type MentionedVarsOf (CommonSetOp es)
-            = HConcat (HMap ApplyMentionedVarsOf es)
+type instance IsExpr          (CommonSetOp es) = IsExprSet          es
+type instance IsCommonExpr    (CommonSetOp es) = IsCommonExprSet    es
+type instance IsIterativeExpr (CommonSetOp es) = IsIterativeExprSet es
+type instance MentionedVars   (CommonSetOp es) = Concat (Map MentionedVarsA es)
 
-data TrendOp vn a
-    = Trend      !(Variable vn) !a
-    | TrendNan   !(Variable vn) !a
+-- TrendOp
+data TrendOp vn e
+    = Trend      !(Variable vn) !e
+    | TrendNan   !(Variable vn) !e
     deriving (Show, Eq, Ord)
-instance (IsVarName vn, IsExpr a) => IsExpr (TrendOp vn a)
-instance (IsVarName vn, IsCommonExpr a) => IsCommonExpr (TrendOp vn a)
 
-instance ( IsVariableSet (vn :*: MentionedVarsOf a)
-         ) => MentionedVars (TrendOp vn a) where
-    type MentionedVarsOf (TrendOp vn a) = vn :*: MentionedVarsOf a
+type instance IsExpr          (TrendOp vn e) = IsVarName vn :&&: IsExpr e
+type instance IsCommonExpr    (TrendOp vn e) = IsVarName vn :&&: IsCommonExpr e
+type instance IsIterativeExpr (TrendOp vn e) = IsVarName vn :&&: IsIterativeExpr e
+type instance MentionedVars   (TrendOp vn e) = vn :&: MentionedVars e
 
+-- VariableShiftPredictOp
 data VariableShiftPredictOp ss w vn
     = VariableShiftPredictAverage !ss !w !(Variable vn)
     | VariableShiftPredictSigma   !ss !w !(Variable vn)
     deriving (Show, Eq, Ord)
-instance (IsExprSet ss, IsExpr w, IsVarName vn)
-    => IsExpr (VariableShiftPredictOp ss w vn)
-instance (IsExprSet ss, IsCommonExprSet ss, IsCommonExpr w, IsVarName vn)
-    => IsCommonExpr (VariableShiftPredictOp ss w vn)
-instance ( IsVariableSet (vn :*: (MentionedVarsOf ss :++: MentionedVarsOf w))
-         ) => MentionedVars (VariableShiftPredictOp ss w vn) where
-    type MentionedVarsOf (VariableShiftPredictOp ss w vn)
-        = vn :*: (MentionedVarsOf ss :++: MentionedVarsOf w)
+
+type instance IsExpr (VariableShiftPredictOp ss w vn)
+    = IsExprSet ss :&&: IsExpr w :&&: IsVarName vn
+
+type instance IsCommonExpr (VariableShiftPredictOp ss w vn)
+    = IsCommonExprSet ss :&&: IsCommonExpr w :&&: IsVarName vn
+
+type instance IsIterativeExpr (VariableShiftPredictOp ss w vn)
+    = IsIterativeExprSet ss :&&: IsIterativeExpr w :&&: IsVarName vn
+
+type instance MentionedVars (VariableShiftPredictOp ss w vn)
+    = vn :&: (MentionedVars ss :++: MentionedVars w)
 
 -- FixedShiftPredictOp
 data FixedShiftPredictOp sm w vn
@@ -203,16 +237,17 @@ data FixedShiftPredictOp sm w vn
     | FixedShiftPredictSigma   !sm !w !(Variable vn)
     deriving (Show, Eq, Ord)
 
-instance (IsExpr sm, IsExpr w, IsVarName vn)
-    => IsExpr (FixedShiftPredictOp sm w vn)
+type instance IsExpr (FixedShiftPredictOp sm w vn)
+    = IsExpr sm :&&: IsExpr w :&&: IsVarName vn
+
+type instance IsCommonExpr (FixedShiftPredictOp sm w vn)
+    = IsCommonExpr sm :&&: IsCommonExpr w :&&: IsVarName vn
 
-instance (IsCommonExpr sm, IsCommonExpr w, IsVarName vn)
-    => IsCommonExpr (FixedShiftPredictOp sm w vn)
+type instance IsIterativeExpr (FixedShiftPredictOp sm w vn)
+    = IsIterativeExpr sm :&&: IsIterativeExpr w :&&: IsVarName vn
 
-instance ( IsVariableSet (vn :*: (MentionedVarsOf sm :++: MentionedVarsOf w))
-         ) => MentionedVars (FixedShiftPredictOp sm w vn) where
-    type MentionedVarsOf (FixedShiftPredictOp sm w vn)
-        = vn :*: (MentionedVarsOf sm :++: MentionedVarsOf w)
+type instance MentionedVars (FixedShiftPredictOp sm w vn)
+    = vn :&: (MentionedVars sm :++: MentionedVars w)
 
 -- Common special values
 data CommonValue
@@ -222,12 +257,10 @@ data CommonValue
     | Now
     deriving (Show, Eq, Ord)
 
-instance IsExpr CommonValue
-
-instance IsCommonExpr CommonValue
-
-instance MentionedVars CommonValue where
-    type MentionedVarsOf CommonValue = HNil
+type instance IsExpr          CommonValue = True
+type instance IsCommonExpr    CommonValue = True
+type instance IsIterativeExpr CommonValue = True
+type instance MentionedVars   CommonValue = Nil
 
 -- Iterative special values
 data IterativeValue
@@ -237,24 +270,20 @@ data IterativeValue
     | TakenLocalTime
     deriving (Show, Eq, Ord)
 
-instance IsExpr IterativeValue
-
-instance IterativeExpr IterativeValue
-
-instance MentionedVars IterativeValue where
-    type MentionedVarsOf IterativeValue = HNil
+type instance IsExpr          IterativeValue = True
+type instance IsCommonExpr    IterativeValue = False
+type instance IsIterativeExpr IterativeValue = True
+type instance MentionedVars   IterativeValue = Nil
 
 -- Iterative special values of something
 data IterativeValueOf vn
     = PreviousOf !(Variable vn)
     deriving (Show, Eq, Ord)
 
-instance IsVarName vn => IsExpr (IterativeValueOf vn)
-
-instance IsVarName vn => IterativeExpr (IterativeValueOf vn)
-
-instance IsVarName vn => MentionedVars (IterativeValueOf vn) where
-    type MentionedVarsOf (IterativeValueOf vn) = vn :*: HNil
+type instance IsExpr          (IterativeValueOf vn) = IsVarName vn
+type instance IsCommonExpr    (IterativeValueOf vn) = False
+type instance IsIterativeExpr (IterativeValueOf vn) = IsVarName vn
+type instance MentionedVars   (IterativeValueOf vn) = vn :&: Nil
 
 -- Aggregative operators (fairly restricted due to rrdtool's
 -- restriction)
@@ -273,9 +302,4 @@ data AggregativeUnaryOp vn
     | LSLCorrel  !(Variable vn)
     deriving (Show, Eq, Ord)
 
-instance IsVarName vn => IsExpr (AggregativeUnaryOp vn)
-
-instance IsVarName vn => IsAggregativeExpr (AggregativeUnaryOp vn)
-
-instance IsVarName vn => MentionedVars (AggregativeUnaryOp vn) where
-    type MentionedVarsOf (AggregativeUnaryOp vn) = vn :*: HNil
+type instance MentionedVars (AggregativeUnaryOp vn) = vn :&: Nil