+{- -*- coding: utf-8 -*- -}
{-# LANGUAGE
DeriveDataTypeable,
+ EmptyDataDecls,
FlexibleContexts,
FlexibleInstances,
+ FunctionalDependencies,
MultiParamTypeClasses,
+ OverlappingInstances,
TypeFamilies,
TypeOperators,
UndecidableInstances
, HAll
, HLength
+
+ , Fail
+ , TypeFound
+ , TypeNotFound
+ , HOccursMany(..)
+ , HOccursMany1(..)
+ , HOccursOpt(..)
+ , HOccurs(..)
+ , HOccursNot(..)
)
where
hCons = HCons
-- HExtendT
-infixr 2 :*:
-infixr 2 .*.
+infixr 2 :&:
+infixr 2 .&.
class HExtendT e l where
- type e :*: l
- (.*.) :: e -> l -> e :*: l
+ type e :&: l
+ (.&.) :: e -> l -> e :&: l
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
- 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 :++:
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
{-# LANGUAGE
+ FlexibleContexts,
+ FlexibleInstances,
TypeFamilies,
UndecidableInstances
#-}
, createRRD
-- Data.HList
- , (.*.)
+ , (.&.)
, HNil(..)
-- Database.RRDtool.Expression
}
-}
+-- |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.
-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"
+
+testMain :: IO ()
+testMain = let s = RRDPath "test.rrd" .&.
+ KeepOldRRD .&.
+ HNil
+ in
+ createRRD s
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 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
= 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
= 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
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)
| LSLCorrel !(Variable vn)
deriving (Show, Eq, Ord)
-type instance MentionedVars (AggregativeUnaryOp vn) = vn :*: HNil
+type instance MentionedVars (AggregativeUnaryOp vn) = vn :&: HNil
projects / hs-rrdtool.git / commitdiff