From d07e35733d4f0994a12202164c9065aef1fe98f4 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Fri, 23 Apr 2010 22:07:41 +0900
Subject: [PATCH] major rewrite

---
 Data/HList.hs                  |  22 +--
 Data/HList/Prelude.hs          | 113 +++++++---------
 Database/RRDtool/Create.hs     |   4 +-
 Database/RRDtool/Expression.hs | 240 ++++++++++++++-------------------
 4 files changed, 156 insertions(+), 223 deletions(-)

diff --git a/Data/HList.hs b/Data/HList.hs
index e39fb95..3a04702 100644
--- a/Data/HList.hs
+++ b/Data/HList.hs
@@ -1,25 +1,5 @@
 module Data.HList
-    ( -- Data.HList.Prelude
-      HList
-
-    , HNil(..)
-    , hNil
-
-    , HCons(..)
-    , hCons
-
-    , (:*:)
-    , (.*.)
-
-    , (:++:)
-    , (.++.)
-
-    , Applyable(..)
-
-    , HConcat
-    , HMap
-
-    , HLength
+    ( module Data.HList.Prelude
     )
     where
 
diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs
index d9ee19a..bbcc50c 100644
--- a/Data/HList/Prelude.hs
+++ b/Data/HList/Prelude.hs
@@ -15,20 +15,20 @@ module Data.HList.Prelude
     , HCons(..)
     , hCons
 
-    , HExtendable(..)
-    , HAppendable(..)
+    , HExtendT(..)
+    , HAppendT(..)
 
-    , Applyable(..)
-    , Applyable2(..)
+    , ApplyT(..)
+    , Apply2T(..)
 
     , Id(..)
-    , ApplyHAppend(..)
+    , HAppendA(..)
 
-    , HFoldrable(..)
-    , HConcatable(..)
-    , HMappable(..)
-    , HAllable(..)
+    , HFoldrT(..)
+    , HConcatT(..)
+    , HMapT(..)
 
+    , HAll
     , HLength
     )
     where
@@ -61,123 +61,110 @@ instance HList l => HList (HCons e l)
 hCons :: HList l => e -> l -> HCons e l
 hCons = HCons
 
--- HExtendable
+-- HExtendT
 infixr 2 :*:
 infixr 2 .*.
 
-class HExtendable e l where
+class HExtendT e l where
     type e :*: l
     (.*.) :: e -> l -> e :*: l
 
-instance HExtendable e HNil where
+instance HExtendT e HNil where
     type e :*: HNil = HCons e HNil
     e .*. nil = hCons e nil
 
-instance HList l => HExtendable e (HCons e' l) where
+instance HList l => HExtendT e (HCons e' l) where
     type e :*: HCons e' l = HCons e (HCons e' l)
     e .*. HCons e' l = hCons e (hCons e' l)
 
--- HAppendable
+-- HAppendT
 infixr 1 :++:
 infixr 1 .++.
 
-class HAppendable l l' where
+class HAppendT l l' where
     type l :++: l'
     (.++.) :: l -> l' -> l :++: l'
 
-instance HList l => HAppendable HNil l where
+instance HList l => HAppendT HNil l where
     type HNil :++: l = l
     _ .++. l = l
 
 instance ( HList (l :++: l')
-         , HAppendable l l'
-         ) => HAppendable (HCons e l) l' where
+         , HAppendT l l'
+         ) => HAppendT (HCons e l) l' where
     type HCons e l :++: l' = HCons e (l :++: l')
     (HCons e l) .++. l' = hCons e (l .++. l')
 
--- Applyable
-class Applyable f a where
+-- ApplyT
+class ApplyT f a where
     type Apply f a
     apply :: f -> a -> Apply f a
+    apply _ _ = undefined
 
--- Applyable2
-class Applyable2 f a b where
+-- Apply2T
+class Apply2T f a b where
     type Apply2 f a b
     apply2 :: f -> a -> b -> Apply2 f a b
+    apply2 _ _ _ = undefined
 
 -- Id
 data Id = Id
 
-instance Applyable Id a where
+instance ApplyT Id a where
     type Apply Id a = a
     apply _ a = a
 
--- ApplyHAppend
-data ApplyHAppend = ApplyHAppend
+-- HAppendA
+data HAppendA = HAppendA
 
-instance HAppendable a b => Applyable2 ApplyHAppend a b where
-    type Apply2 ApplyHAppend a b = a :++: b
+instance HAppendT a b => Apply2T HAppendA a b where
+    type Apply2 HAppendA a b = a :++: b
     apply2 _ a b = a .++. b
 
--- HFoldrable
-class HFoldrable f v l where
+-- HFoldrT
+class HFoldrT f v l where
     type HFoldr f v l
     hFoldr :: f -> v -> l -> HFoldr f v l
 
-instance HFoldrable f v HNil where
+instance HFoldrT 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 (HCons e l) where
+instance ( HFoldrT f v l
+         , Apply2T f e (HFoldr f v l)
+         ) => HFoldrT f v (HCons e l) where
     type HFoldr f v (HCons e l) = Apply2 f e (HFoldr f v l)
     hFoldr f v (HCons e l) = apply2 f e (hFoldr f v l)
 
--- HConcatable
-class HConcatable ls where
+-- HConcatT
+class HConcatT 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
+instance HFoldrT HAppendA HNil ls => HConcatT ls where
+    type HConcat ls = HFoldr HAppendA HNil ls
+    hConcat ls = hFoldr HAppendA hNil ls
 
--- HMappable
-class HMappable f l where
+-- HMapT
+class HMapT f l where
     type HMap f l
     hMap :: f -> l -> HMap f l
 
-instance HMappable f HNil where
+instance HMapT f HNil where
     type HMap f HNil = HNil
     hMap _ _ = hNil
 
-instance ( Applyable f x
-         , HMappable f xs
+instance ( ApplyT f x
+         , HMapT f xs
          , HList (HMap f xs)
-         ) => HMappable f (HCons x xs) where
+         ) => HMapT f (HCons x xs) where
     type HMap f (HCons x xs) = HCons (Apply f x) (HMap f xs)
     hMap f (HCons x xs) = hCons (apply f x) (hMap f xs)
 
--- HAllable
-class HAllable f l where
-    type HAll f l
-    hAll :: f -> l -> HAll f l
-
-instance HAllable f HNil where
-    type HAll f HNil = True
-    hAll _ _ = undefined :: True
-
-instance ( IfT (Apply f x) (HAll f xs) False
-         , Applyable f x
-         , HAllable f xs
-         ) => HAllable f (HCons x xs) where
-    type HAll f (HCons x xs) = If (Apply f x)
-                                 (HAll f xs)
-                                 False
-    hAll f (HCons x xs) = ifT (apply f x)
-                                 (hAll f xs)
-                                 (undefined :: False)
+-- HAll
+type family HAll f l
+type instance HAll f HNil         = True
+type instance HAll f (HCons x xs) = If (Apply f x) (HAll f xs) False
 
 -- HLength
 type family HLength l
diff --git a/Database/RRDtool/Create.hs b/Database/RRDtool/Create.hs
index a3b51e5..5438e04 100644
--- a/Database/RRDtool/Create.hs
+++ b/Database/RRDtool/Create.hs
@@ -28,6 +28,7 @@ import Data.HList
 import Data.Time.Clock
 import Data.Time.Clock.POSIX
 import Database.RRDtool.Expression
+import Types.Data.Bool
 
 
 -- |A single RRD can accept input from several data sources (DS), for
@@ -152,7 +153,8 @@ data ComputedDataSource e
     }
     deriving (Show, Eq, Ord)
 
-instance IsCommonExpr e => DataSource (ComputedDataSource e)
+instance (IsCommonExpr e ~ True) =>
+    DataSource (ComputedDataSource e)
 
 
 dsTest = ComputedDataSource {
diff --git a/Database/RRDtool/Expression.hs b/Database/RRDtool/Expression.hs
index 499a580..aed9539 100644
--- a/Database/RRDtool/Expression.hs
+++ b/Database/RRDtool/Expression.hs
@@ -1,18 +1,16 @@
 module Database.RRDtool.Expression
-    ( MentionedVars(..)
-    , ApplyMentionedVarsOf(..)
+    ( MentionedVars
+    , MentionedVarsA(..)
 
     , IsExpr
     , IsCommonExpr
-    , IterativeExpr
+    , IsIterativeExpr
     , IsAggregativeExpr
 
     , IsExprSet
     , IsCommonExprSet
 
     , IsVarName
-    , IsShortEnoughForVarName
-    , IsGoodLetterForVarName
 
     , Constant(..)
     , Variable(..)
@@ -32,46 +30,43 @@ module Database.RRDtool.Expression
     where
 
 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
+type family IsAggregativeExpr e
 
-class (Show es, Eq es, HList es) => IsExprSet es
-instance IsExprSet HNil
-instance (IsExpr e, IsExprSet es) => IsExprSet (HCons e es)
-
-class (Show es, Eq es, HList es) => IsCommonExprSet es
-instance IsCommonExprSet HNil
-instance (IsCommonExpr e, IsCommonExprSet es) => IsCommonExprSet (HCons e es)
+type family   IsExprSet es
+type instance IsExprSet HNil         = True
+type instance IsExprSet (HCons e es) = IsExpr e :&&: IsExprSet es
 
+type family   IsCommonExprSet es
+type instance IsCommonExprSet HNil         = True
+type instance IsCommonExprSet (HCons e es) = IsCommonExpr e :&&: IsCommonExprSet 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 MentionedVars Constant = HNil
 
 {- This is what we want to do but GHC can't handle this for now. 
 class ( (HLengthOf str :<=: D255) ~ True
@@ -79,44 +74,38 @@ class ( (HLengthOf str :<=: D255) ~ True
       )
     => IsVarName str
 -}
-class ( IsShortEnoughForVarName str
-      , HString str
-      )
-    => IsVarName str
-
-class HString str => IsShortEnoughForVarName str
-instance ( HString str
-         , (HLength str :<=: D255) ~ True
-         )
-    => IsShortEnoughForVarName str
-
-class IntegerT c => GoodLetterForVarName c where
-    type IsGoodLetterForVarName c
-
-instance IntegerT c => GoodLetterForVarName c where
-    type IsGoodLetterForVarName c = ( (c :>=: D65) :&&: (c :<=:  D90) ) -- A-Z
-                                    :||:
-                                    ( (c :>=: D99) :&&: (c :<=: D122) ) -- a-z
-                                    :||:
-                                    ( c :==: D45 ) -- '-'
-                                    :||:
-                                    ( c :==: D95 ) -- '_'
-
---instance (a :>=: D65) ~ True => IsGoodLetterForVarName a
+type family   IsVarName str
+type instance IsVarName str = ( (HLength str :<=: D255)
+                                :&&:
+                                (HAll IsGoodLetterForVarNameA str)
+                              )
+
+type family   IsGoodLetterForVarName c
+type instance IsGoodLetterForVarName c = ( ((c :>=: D65) :&&: (c :<=:  D90)) -- A-Z
+                                           :||:
+                                           ((c :>=: D99) :&&: (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
     = 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
+type instance IsExpr        (Variable vn) = True
+type instance IsCommonExpr  (Variable vn) = True
+type instance MentionedVars (Variable vn) = vn :*: HNil
 
-class HList vs => IsVariableSet vs
-instance IsVariableSet HNil
-instance (IsVarName v, IsVariableSet vs) => IsVariableSet (HCons v vs)
+type family   IsVariableSet vs
+type instance IsVariableSet HNil         = True
+type instance IsVariableSet (HCons v vs) = IsVarName v :&&: IsVariableSet vs
 
 -- Common operators
 data CommonUnaryOp a
@@ -134,10 +123,10 @@ 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) = IsExpr a
+type instance MentionedVars (CommonUnaryOp a) = MentionedVars a
 
 data CommonBinaryOp a b
     = !a :<:  !b
@@ -157,16 +146,14 @@ 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
 
-instance (IsCommonExpr a, IsCommonExpr b) =>
-    IsCommonExpr (CommonBinaryOp a b)
+type instance IsCommonExpr (CommonBinaryOp a b)
+    = IsCommonExpr a :&&: IsCommonExpr 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
@@ -174,58 +161,50 @@ 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 MentionedVars (CommonTrinaryOp a b c)
+    = MentionedVars a :++: MentionedVars b :++: MentionedVars c
 
--- SORT and REV can't be expressed in this way as they pushes possibly
+-- 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 MentionedVars (CommonSetOp es) = HConcat (HMap 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 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 MentionedVars (VariableShiftPredictOp ss w vn)
+    = vn :*: (MentionedVars ss :++: MentionedVars w)
 
 -- FixedShiftPredictOp
 data FixedShiftPredictOp sm w vn
@@ -233,16 +212,14 @@ 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
 
-instance (IsCommonExpr sm, IsCommonExpr w, IsVarName vn)
-    => IsCommonExpr (FixedShiftPredictOp sm w vn)
+type instance IsCommonExpr (FixedShiftPredictOp sm w vn)
+    = IsCommonExpr sm :&&: IsCommonExpr 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
@@ -252,12 +229,9 @@ 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 MentionedVars CommonValue = HNil
 
 -- Iterative special values
 data IterativeValue
@@ -267,24 +241,18 @@ 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 = True
+type instance MentionedVars IterativeValue = HNil
 
 -- 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 IsIterativeExpr (IterativeValueOf vn) = IsVarName vn
+type instance MentionedVars   (IterativeValueOf vn) = vn :*: HNil
 
 -- Aggregative operators (fairly restricted due to rrdtool's
 -- restriction)
@@ -303,9 +271,5 @@ 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 IsAggregativeExpr (AggregativeUnaryOp vn) = IsVarName vn
+type instance MentionedVars     (AggregativeUnaryOp vn) = vn :*: HNil
-- 
2.40.0