From 2787678974b80d73e91b49b6b7c5469c6eb5ac1e Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 24 Apr 2010 14:10:44 +0900 Subject: [PATCH] HOccurs series --- Data/HList/Prelude.hs | 181 +++++++++++++++++++++++++++++++-- Database/RRDtool/Create.hs | 51 +++++++--- Database/RRDtool/Expression.hs | 12 +-- rrdtool.cabal | 2 + 4 files changed, 216 insertions(+), 30 deletions(-) diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs index e8d84ad..dc33147 100644 --- a/Data/HList/Prelude.hs +++ b/Data/HList/Prelude.hs @@ -1,8 +1,12 @@ +{- -*- coding: utf-8 -*- -} {-# LANGUAGE DeriveDataTypeable, + EmptyDataDecls, FlexibleContexts, FlexibleInstances, + FunctionalDependencies, MultiParamTypeClasses, + OverlappingInstances, TypeFamilies, TypeOperators, UndecidableInstances @@ -31,6 +35,15 @@ module Data.HList.Prelude , HAll , HLength + + , Fail + , TypeFound + , TypeNotFound + , HOccursMany(..) + , HOccursMany1(..) + , HOccursOpt(..) + , HOccurs(..) + , HOccursNot(..) ) where @@ -63,20 +76,20 @@ hCons :: HList l => e -> l -> HCons e l 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 :++: @@ -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) + +-- 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 diff --git a/Database/RRDtool/Create.hs b/Database/RRDtool/Create.hs index 3c403db..5dd3b9f 100644 --- a/Database/RRDtool/Create.hs +++ b/Database/RRDtool/Create.hs @@ -1,4 +1,6 @@ {-# LANGUAGE + FlexibleContexts, + FlexibleInstances, TypeFamilies, UndecidableInstances #-} @@ -10,7 +12,7 @@ module Database.RRDtool.Create , createRRD -- Data.HList - , (.*.) + , (.&.) , 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. -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 diff --git a/Database/RRDtool/Expression.hs b/Database/RRDtool/Expression.hs index 5c44213..077f40f 100644 --- a/Database/RRDtool/Expression.hs +++ b/Database/RRDtool/Expression.hs @@ -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 MentionedVars (Variable vn) = vn :*: HNil +type instance MentionedVars (Variable vn) = vn :&: HNil 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 MentionedVars (TrendOp vn e) = vn :*: MentionedVars e +type instance MentionedVars (TrendOp vn e) = vn :&: MentionedVars e -- 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) - = vn :*: (MentionedVars ss :++: MentionedVars w) + = vn :&: (MentionedVars ss :++: MentionedVars w) -- 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) - = vn :*: (MentionedVars sm :++: MentionedVars w) + = vn :&: (MentionedVars sm :++: MentionedVars w) -- 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 MentionedVars (IterativeValueOf vn) = vn :*: HNil +type instance MentionedVars (IterativeValueOf vn) = vn :&: HNil -- Aggregative operators (fairly restricted due to rrdtool's -- restriction) @@ -301,4 +301,4 @@ data AggregativeUnaryOp vn | LSLCorrel !(Variable vn) deriving (Show, Eq, Ord) -type instance MentionedVars (AggregativeUnaryOp vn) = vn :*: HNil +type instance MentionedVars (AggregativeUnaryOp vn) = vn :&: HNil diff --git a/rrdtool.cabal b/rrdtool.cabal index 2b3c9a7..a444e8f 100644 --- a/rrdtool.cabal +++ b/rrdtool.cabal @@ -34,7 +34,9 @@ Library Database.RRDtool.Create Database.RRDtool.Expression Data.HList + Data.HList.Graph Data.HList.Prelude +-- Data.HList.Record Data.HList.String Extensions: -- 2.40.0