X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Data%2FHList%2FPrelude.hs;h=dc33147be63c7de93cc58dae3df25d723c3b680b;hb=2787678974b80d73e91b49b6b7c5469c6eb5ac1e;hp=bbcc50c60194078a17e10f6af8c150f6315825d3;hpb=d07e35733d4f0994a12202164c9065aef1fe98f4;p=hs-rrdtool.git diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs index bbcc50c..dc33147 100644 --- a/Data/HList/Prelude.hs +++ b/Data/HList/Prelude.hs @@ -1,10 +1,15 @@ -{-# LANGUAGE DeriveDataTypeable, - FlexibleContexts, - FlexibleInstances, - MultiParamTypeClasses, - TypeFamilies, - TypeOperators, - UndecidableInstances +{- -*- coding: utf-8 -*- -} +{-# LANGUAGE + DeriveDataTypeable, + EmptyDataDecls, + FlexibleContexts, + FlexibleInstances, + FunctionalDependencies, + MultiParamTypeClasses, + OverlappingInstances, + TypeFamilies, + TypeOperators, + UndecidableInstances #-} module Data.HList.Prelude ( HList @@ -30,6 +35,15 @@ module Data.HList.Prelude , HAll , HLength + + , Fail + , TypeFound + , TypeNotFound + , HOccursMany(..) + , HOccursMany1(..) + , HOccursOpt(..) + , HOccurs(..) + , HOccursNot(..) ) where @@ -62,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 :++: @@ -170,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