]> gitweb @ CieloNegro.org - hs-rrdtool.git/commitdiff
HOccurs series
authorPHO <pho@cielonegro.org>
Sat, 24 Apr 2010 05:10:44 +0000 (14:10 +0900)
committerPHO <pho@cielonegro.org>
Sat, 24 Apr 2010 05:10:44 +0000 (14:10 +0900)
Data/HList/Prelude.hs
Database/RRDtool/Create.hs
Database/RRDtool/Expression.hs
rrdtool.cabal

index e8d84adf88a3af162aa32576d7c1a6d7b949ebc2..dc33147be63c7de93cc58dae3df25d723c3b680b 100644 (file)
@@ -1,8 +1,12 @@
+{- -*- coding: utf-8 -*- -}
 {-# LANGUAGE
   DeriveDataTypeable,
 {-# LANGUAGE
   DeriveDataTypeable,
+  EmptyDataDecls,
   FlexibleContexts,
   FlexibleInstances,
   FlexibleContexts,
   FlexibleInstances,
+  FunctionalDependencies,
   MultiParamTypeClasses,
   MultiParamTypeClasses,
+  OverlappingInstances,
   TypeFamilies,
   TypeOperators,
   UndecidableInstances
   TypeFamilies,
   TypeOperators,
   UndecidableInstances
@@ -31,6 +35,15 @@ module Data.HList.Prelude
 
     , HAll
     , HLength
 
     , HAll
     , HLength
+
+    , Fail
+    , TypeFound
+    , TypeNotFound
+    , HOccursMany(..)
+    , HOccursMany1(..)
+    , HOccursOpt(..)
+    , HOccurs(..)
+    , HOccursNot(..)
     )
     where
 
     )
     where
 
@@ -63,20 +76,20 @@ hCons :: HList l => e -> l -> HCons e l
 hCons = HCons
 
 -- HExtendT
 hCons = HCons
 
 -- HExtendT
-infixr 2 :*:
-infixr 2 .*.
+infixr 2 :&:
+infixr 2 .&.
 
 class HExtendT e l where
 
 class HExtendT e l where
-    type e :*: l
-    (.*.) :: e -> l -> e :*: l
+    type e :&: l
+    (.&.) :: e -> l -> e :&: l
 
 instance HExtendT e HNil where
 
 instance HExtendT e HNil where
-    type e :*: HNil = HCons e HNil
-    e .*. nil = hCons e nil
+    type e :&: HNil = HCons e HNil
+    e .&. nil = hCons e nil
 
 instance HList l => HExtendT 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)
+    type e :&: HCons e' l = HCons e (HCons e' l)
+    e .&. HCons e' l = hCons e (hCons e' l)
 
 -- HAppendT
 infixr 1 :++:
 
 -- HAppendT
 infixr 1 :++:
@@ -171,3 +184,155 @@ type instance HAll f (HCons x xs) = If (Apply f x) (HAll f xs) False
 type family HLength l
 type instance HLength HNil        = D0
 type instance HLength (HCons e l) = Succ (HLength l)
 type family HLength l
 type instance HLength HNil        = D0
 type instance HLength (HCons e l) = Succ (HLength l)
+
+-- Fail
+class Fail a
+
+-- HOccursMany (zero or more)
+class HOccursMany e l where
+    hOccursMany :: l -> [e]
+
+instance HOccursMany e HNil where
+    hOccursMany _ = []
+
+instance ( HList l
+         , HOccursMany e l
+         )
+    => HOccursMany e (HCons e l)
+    where
+      hOccursMany (HCons e l) = e : hOccursMany l
+
+instance ( HList l
+         , HOccursMany e l
+         )
+    => HOccursMany e (HCons e' l)
+    where
+      hOccursMany (HCons _ l) = hOccursMany l
+
+-- HOccursMany1 (one or more)
+class HOccursMany1 e l where
+    hOccursMany1 :: l -> [e]
+
+instance Fail (TypeNotFound e) => HOccursMany1 e HNil where
+    hOccursMany1 _ = undefined
+
+instance ( HList l
+         , HOccursMany e l
+         )
+    => HOccursMany1 e (HCons e l)
+    where
+      hOccursMany1 (HCons e l) = e : hOccursMany l
+
+instance ( HList l
+         , HOccursMany1 e l
+         )
+    => HOccursMany1 e (HCons e' l)
+    where
+      hOccursMany1 (HCons _ l) = hOccursMany1 l
+
+-- HOccursOpt (zero or one)
+class HOccursOpt e l where
+    hOccursOpt :: l -> Maybe e
+
+instance HOccursOpt e HNil where
+    hOccursOpt _ = Nothing
+
+instance HOccursNot e l => HOccursOpt e (HCons e l) where
+    hOccursOpt (HCons e _) = Just e
+
+instance HOccursOpt e l => HOccursOpt e (HCons e' l) where
+    hOccursOpt (HCons _ l) = hOccursOpt l
+
+-- HOccurs (one)
+class HOccurs e l where
+    hOccurs :: l -> e
+
+data TypeNotFound e
+
+instance Fail (TypeNotFound e) => HOccurs e HNil
+    where
+      hOccurs = undefined
+
+instance ( HList l
+         , HOccursNot e l
+         )
+    => HOccurs e (HCons e l)
+    where
+      hOccurs (HCons e _) = e
+
+instance ( HList l
+         , HOccurs e l
+         )
+    => HOccurs e (HCons e' l)
+    where
+      hOccurs (HCons _ l) = hOccurs l
+
+-- HOccursNot (zero)
+data     TypeFound e
+class    HOccursNot e l
+instance HOccursNot e HNil
+instance Fail (TypeFound e) => HOccursNot e (HCons e  l)
+instance HOccursNot e l     => HOccursNot e (HCons e' l)
+
+{-
+{-
+"Strongly Typed Heterogeneous Collections"
+   — August 26, 2004
+       Oleg Kiselyov
+       Ralf Lämmel
+       Keean Schupke
+==========================
+9 By chance or by design? 
+
+We will now discuss the issues surrounding the definition of type
+equality, inequality, and unification — and give implementations
+differing in simplicity, genericity, and portability.
+
+We define the class TypeEq x y b for type equality. The class relates
+two types x and y to the type HTrue in case the two types are equal;
+otherwise, the types are related to HFalse. We should point out
+however groundness issues. If TypeEq is to return HTrue, the types
+must be ground; TypeEq can return HFalse even for unground types,
+provided they are instantiated enough to determine that they are not
+equal. So, TypeEq is total for ground types, and partial for unground
+types. We also define the class TypeCast x y: a constraint that holds
+only if the two types x and y are unifiable. Regarding groundness of x
+and y, the class TypeCast is less restricted than TypeEq. That is,
+TypeCast x y succeeds even for unground types x and y in case they can
+be made equal through unification. TypeEq and TypeCast are related to
+each other as fol- lows. Whenever TypeEq succeeds with HTrue, TypeCast
+succeeds as well. Whenever TypeEq succeeds with HFalse, TypeCast
+fails.  But for unground types, when TypeCast succeeds, TypeEq might
+fail. So the two complement each other for unground types. Also,
+TypeEq is a partial predicate, while TypeCast is a relation. That’s
+why both are useful.
+ -}
+class    TypeEq x y b | x y -> b
+instance TypeEq x x True
+instance TypeCast False b =>
+         TypeEq x y b
+
+class TypeCast a b | a -> b, b -> a
+    where
+      typeCast :: a -> b
+
+class TypeCast' t a b | t a -> b, t b -> a
+    where
+      typeCast' :: t -> a -> b
+
+class TypeCast'' t a b | t a -> b, t b -> a
+    where
+      typeCast'' :: t -> a -> b
+
+instance TypeCast' () a b => TypeCast a b
+    where
+      typeCast x = typeCast' () x
+
+instance TypeCast'' t a b => TypeCast' t a b
+    where
+      typeCast' = typeCast''
+
+instance TypeCast'' () a a
+    where
+      typeCast'' _ x = x
+-}
\ No newline at end of file
index 3c403db46f99de5ad8af3c9bfb41b90145692361..5dd3b9f8fc12aadee9c64bef068dd335ee99b289 100644 (file)
@@ -1,4 +1,6 @@
 {-# LANGUAGE
 {-# LANGUAGE
+  FlexibleContexts,
+  FlexibleInstances,
   TypeFamilies,
   UndecidableInstances
   #-}
   TypeFamilies,
   UndecidableInstances
   #-}
@@ -10,7 +12,7 @@ module Database.RRDtool.Create
     , createRRD
 
     -- Data.HList
     , createRRD
 
     -- Data.HList
-    , (.*.)    
+    , (.&.)
     , HNil(..)
 
     -- Database.RRDtool.Expression
     , HNil(..)
 
     -- Database.RRDtool.Expression
@@ -173,22 +175,39 @@ dsTest = ComputedDataSource {
          }
 -}
 
          }
 -}
 
+-- |The name of the RRD you want to create. RRD files should end with
+-- the extension @.rrd@. However, RRDtool will accept any filename.
+newtype RRDPath = RRDPath FilePath
+
+-- |Do not clobber an existing file of the same name.
+data KeepOldRRD = KeepOldRRD
+
+-- |Specifies the time in seconds since @1970-01-01 UTC@ when the
+-- first value should be added to the RRD. RRDtool will not accept any
+-- data timed before or at the time specified. (default: @now - 10s@)
+newtype RRDStartTime = RRDStartTime POSIXTime
+
+-- |Specifies the base interval in seconds with which data will be fed
+-- into the RRD. (default: 300 sec)
+newtype RRDInterval = RRDInterval NominalDiffTime
+
+class RRDSpec s
+instance ( HOccurs    RRDPath      s
+         , HOccursOpt KeepOldRRD   s
+         , HOccursOpt RRDStartTime s
+         , HOccursOpt RRDInterval  s
+         )
+    => RRDSpec s
+
 -- |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.
 -- |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.
-createRRD
-    :: FilePath -- ^The name of the RRD you want to create. RRD files
-                -- should end with the extension @.rrd@. However,
-                -- RRDtool will accept any filename.
-    -> Bool -- ^Do not clobber an existing file of the same name.
-    -> Maybe POSIXTime -- ^Specifies the time in seconds since
-                       -- @1970-01-01 UTC@ when the first value should
-                       -- be added to the RRD. RRDtool will not accept
-                       -- any data timed before or at the time
-                       -- specified. (default: @now - 10s@)
-    -> Maybe NominalDiffTime -- ^Specifies the base interval in
-                             -- seconds with which data will be fed
-                             -- into the RRD. (default: 300 sec)
---    -> [DataSource] -- ^Data sources to accept input from.
-    -> IO ()
+createRRD :: RRDSpec s => s -> IO ()
 createRRD = error "FIXME"
 createRRD = error "FIXME"
+
+testMain :: IO ()
+testMain = let s = RRDPath "test.rrd" .&.
+                   KeepOldRRD         .&.
+                   HNil
+           in
+             createRRD s
index 5c44213e47fb2fa4649b82c489e5d543cc3af79d..077f40fa38c177f8477a75c7a8860626216b0426 100644 (file)
@@ -111,7 +111,7 @@ data Variable vn
 type instance IsExpr          (Variable vn) = True
 type instance IsCommonExpr    (Variable vn) = True
 type instance IsIterativeExpr (Variable vn) = True
 type instance IsExpr          (Variable vn) = True
 type instance IsCommonExpr    (Variable vn) = True
 type instance IsIterativeExpr (Variable vn) = True
-type instance MentionedVars   (Variable vn) = vn :*: HNil
+type instance MentionedVars   (Variable vn) = vn :&: HNil
 
 type family   IsVariableSet vs
 type instance IsVariableSet HNil         = True
 
 type family   IsVariableSet vs
 type instance IsVariableSet HNil         = True
@@ -210,7 +210,7 @@ data TrendOp vn e
 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 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
+type instance MentionedVars   (TrendOp vn e) = vn :&: MentionedVars e
 
 -- VariableShiftPredictOp
 data VariableShiftPredictOp ss w vn
 
 -- VariableShiftPredictOp
 data VariableShiftPredictOp ss w vn
@@ -228,7 +228,7 @@ type instance IsIterativeExpr (VariableShiftPredictOp ss w vn)
     = IsIterativeExprSet ss :&&: IsIterativeExpr w :&&: IsVarName vn
 
 type instance MentionedVars (VariableShiftPredictOp ss w vn)
     = IsIterativeExprSet ss :&&: IsIterativeExpr w :&&: IsVarName vn
 
 type instance MentionedVars (VariableShiftPredictOp ss w vn)
-    = vn :*: (MentionedVars ss :++: MentionedVars w)
+    = vn :&: (MentionedVars ss :++: MentionedVars w)
 
 -- FixedShiftPredictOp
 data FixedShiftPredictOp sm w vn
 
 -- FixedShiftPredictOp
 data FixedShiftPredictOp sm w vn
@@ -246,7 +246,7 @@ type instance IsIterativeExpr (FixedShiftPredictOp sm w vn)
     = IsIterativeExpr sm :&&: IsIterativeExpr w :&&: IsVarName vn
 
 type instance MentionedVars (FixedShiftPredictOp sm w vn)
     = IsIterativeExpr sm :&&: IsIterativeExpr w :&&: IsVarName vn
 
 type instance MentionedVars (FixedShiftPredictOp sm w vn)
-    = vn :*: (MentionedVars sm :++: MentionedVars w)
+    = vn :&: (MentionedVars sm :++: MentionedVars w)
 
 -- Common special values
 data CommonValue
 
 -- Common special values
 data CommonValue
@@ -282,7 +282,7 @@ data IterativeValueOf vn
 type instance IsExpr          (IterativeValueOf vn) = IsVarName vn
 type instance IsCommonExpr    (IterativeValueOf vn) = False
 type instance IsIterativeExpr (IterativeValueOf vn) = IsVarName vn
 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 :*: HNil
+type instance MentionedVars   (IterativeValueOf vn) = vn :&: HNil
 
 -- Aggregative operators (fairly restricted due to rrdtool's
 -- restriction)
 
 -- Aggregative operators (fairly restricted due to rrdtool's
 -- restriction)
@@ -301,4 +301,4 @@ data AggregativeUnaryOp vn
     | LSLCorrel  !(Variable vn)
     deriving (Show, Eq, Ord)
 
     | LSLCorrel  !(Variable vn)
     deriving (Show, Eq, Ord)
 
-type instance MentionedVars (AggregativeUnaryOp vn) = vn :*: HNil
+type instance MentionedVars (AggregativeUnaryOp vn) = vn :&: HNil
index 2b3c9a782edcc18ec3f23c26af2642c72f2d0cfb..a444e8f59f4425cbe1e5537a6d058410aa39f19b 100644 (file)
@@ -34,7 +34,9 @@ Library
         Database.RRDtool.Create
         Database.RRDtool.Expression
         Data.HList
         Database.RRDtool.Create
         Database.RRDtool.Expression
         Data.HList
+        Data.HList.Graph
         Data.HList.Prelude
         Data.HList.Prelude
+--        Data.HList.Record
         Data.HList.String
 
     Extensions:
         Data.HList.String
 
     Extensions: