X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Data%2FHList%2FPrelude.hs;h=3a46616662132331d8479a57ee70692cf9eed6ef;hb=000307857df5266907964aff4ecc9e118314fe3f;hp=3eb7e81cc37e80809878498b610dc86ee15b772a;hpb=4611522487b382b839a53e75e3feb2aac8764074;p=hs-rrdtool.git

diff --git a/Data/HList/Prelude.hs b/Data/HList/Prelude.hs
index 3eb7e81..3a46616 100644
--- a/Data/HList/Prelude.hs
+++ b/Data/HList/Prelude.hs
@@ -1,155 +1,345 @@
-{-# 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
+    ( List
 
-    , HNil(..)
+    , Nil(..)
     , hNil
 
-    , HCons(..)
+    , Cons(..)
     , hCons
 
-    , HExtendable(..)
-    , HAppendable(..)
+    , ExtendT(..)
+    , AppendT(..)
 
-    , Applyable(..)
-    , Applyable2(..)
+    , ApplyT(..)
+    , Apply2T(..)
 
     , Id(..)
-    , ApplyHAppend(..)
+    , AppendA(..)
 
-    , HFoldrable(..)
-    , HConcatable(..)
-    , HMappable(..)
+    , FoldrT(..)
+    , ConcatT(..)
+    , MapT(..)
+
+    , All
+    , Length
+
+    , Fail
+    , TypeFound
+    , TypeNotFound
+    , OccursMany(..)
+    , OccursMany1(..)
+    , OccursOpt(..)
+    , Occurs(..)
+    , OccursNot
+
+    , NoDuplicates
     )
     where
 
 import Data.Typeable
+import Types.Data.Bool
+import Types.Data.Num hiding ((:*:))
 
 
--- HList
-class HList l
+-- List
+class List l
 
--- HNil
-data HNil
-    = HNil
+-- Nil
+data Nil
+    = Nil
       deriving (Show, Eq, Ord, Read, Typeable)
 
-instance HList HNil
+instance List Nil
 
-hNil :: HNil
-hNil = HNil
+hNil :: Nil
+hNil = Nil
 
--- HCons
-data HCons e l
-    = HCons e l
+-- Cons
+data Cons e l
+    = Cons e l
       deriving (Show, Eq, Ord, Read, Typeable)
 
-instance HList l => HList (HCons e l)
+instance List l => List (Cons e l)
 
-hCons :: HList l => e -> l -> HCons e l
-hCons = HCons
+hCons :: List l => e -> l -> Cons e l
+hCons = Cons
 
--- HExtendable
-infixr 2 :*:
-infixr 2 .*.
+-- ExtendT
+infixr 2 :&:
+infixr 2 .&.
 
-class HExtendable e l where
-    type e :*: l
-    (.*.) :: e -> l -> e :*: l
+class ExtendT e l where
+    type e :&: l
+    (.&.) :: e -> l -> e :&: l
 
-instance HExtendable e HNil where
-    type e :*: HNil = HCons e HNil
-    e .*. nil = hCons e nil
+instance ExtendT e Nil where
+    type e :&: Nil = Cons e Nil
+    e .&. nil = hCons e nil
 
-instance HList l => HExtendable e (HCons e' l) where
-    type e :*: HCons e' l = HCons e (HCons e' l)
-    e .*. HCons e' l = hCons e (hCons e' l)
+instance List l => ExtendT e (Cons e' l) where
+    type e :&: Cons e' l = Cons e (Cons e' l)
+    e .&. Cons e' l = hCons e (hCons e' l)
 
--- HAppendable
+-- AppendT
 infixr 1 :++:
 infixr 1 .++.
 
-class HAppendable l l' where
+class AppendT l l' where
     type l :++: l'
     (.++.) :: l -> l' -> l :++: l'
 
-instance HList l => HAppendable HNil l where
-    type HNil :++: l = l
+instance List l => AppendT Nil l where
+    type Nil :++: l = l
     _ .++. l = l
 
-instance ( HList (l :++: l')
-         , HAppendable l l'
-         ) => HAppendable (HCons e l) l' where
-    type HCons e l :++: l' = HCons e (l :++: l')
-    (HCons e l) .++. l' = hCons e (l .++. l')
+instance ( List (l :++: l')
+         , AppendT l l'
+         ) => AppendT (Cons e l) l' where
+    type Cons e l :++: l' = Cons e (l :++: l')
+    (Cons 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
+-- AppendA
+data AppendA = AppendA
 
-instance HAppendable a b => Applyable2 ApplyHAppend a b where
-    type Apply2 ApplyHAppend a b = a :++: b
+instance AppendT a b => Apply2T AppendA a b where
+    type Apply2 AppendA a b = a :++: b
     apply2 _ a b = a .++. b
 
--- HFoldrable
-class HFoldrable f v l where
-    type HFoldr f v l
-    hFoldr :: f -> v -> l -> HFoldr f v l
+-- FoldrT
+class FoldrT f v l where
+    type Foldr f v l
+    hFoldr :: f -> v -> l -> Foldr f v l
 
-instance HFoldrable f v HNil where
-    type HFoldr f v HNil = v
+instance FoldrT f v Nil where
+    type Foldr f v Nil = v
     hFoldr _ v _ = v
 
-instance ( HFoldrable f v l
-         , Applyable2 f e (HFoldr f v l)
-         ) => HFoldrable 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)
+instance ( FoldrT f v l
+         , Apply2T f e (Foldr f v l)
+         ) => FoldrT f v (Cons e l) where
+    type Foldr f v (Cons e l) = Apply2 f e (Foldr f v l)
+    hFoldr f v (Cons e l) = apply2 f e (hFoldr f v l)
 
--- HConcatable
-class HConcatable ls where
-    type HConcat ls
-    hConcat :: ls -> HConcat ls
+-- ConcatT
+class ConcatT ls where
+    type Concat ls
+    hConcat :: ls -> Concat ls
 
-instance HFoldrable ApplyHAppend HNil ls => HConcatable ls where
-    type HConcat ls = HFoldr ApplyHAppend HNil ls
-    hConcat ls = hFoldr ApplyHAppend hNil ls
+instance FoldrT AppendA Nil ls => ConcatT ls where
+    type Concat ls = Foldr AppendA Nil ls
+    hConcat ls = hFoldr AppendA hNil ls
 
--- HMappable
-class HMappable f l where
-    type HMap f l
-    hMap :: f -> l -> HMap f l
+-- MapT
+class MapT f l where
+    type Map f l
+    hMap :: f -> l -> Map f l
 
-instance HMappable f HNil where
-    type HMap f HNil = HNil
+instance MapT f Nil where
+    type Map f Nil = Nil
     hMap _ _ = hNil
 
-instance ( Applyable f x
-         , HMappable f xs
-         , HList (HMap f xs)
-         ) => HMappable 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)
+instance ( ApplyT f x
+         , MapT f xs
+         , List (Map f xs)
+         ) => MapT f (Cons x xs) where
+    type Map f (Cons x xs) = Cons (Apply f x) (Map f xs)
+    hMap f (Cons x xs) = hCons (apply f x) (hMap f xs)
+
+-- All
+type family All f l
+type instance All f Nil         = True
+type instance All f (Cons x xs) = If (Apply f x) (All f xs) False
+
+-- Length
+type family Length l
+type instance Length Nil        = D0
+type instance Length (Cons e l) = Succ (Length l)
+
+-- Fail
+class Fail a
+
+-- OccursMany (zero or more)
+class OccursMany e l where
+    hOccursMany :: l -> [e]
+
+instance OccursMany e Nil where
+    hOccursMany _ = []
+
+instance ( List l
+         , OccursMany e l
+         )
+    => OccursMany e (Cons e l)
+    where
+      hOccursMany (Cons e l) = e : hOccursMany l
+
+instance ( List l
+         , OccursMany e l
+         )
+    => OccursMany e (Cons e' l)
+    where
+      hOccursMany (Cons _ l) = hOccursMany l
+
+-- OccursMany1 (one or more)
+class OccursMany1 e l where
+    hOccursMany1 :: l -> [e]
+
+instance Fail (TypeNotFound e) => OccursMany1 e Nil where
+    hOccursMany1 _ = undefined
+
+instance ( List l
+         , OccursMany e l
+         )
+    => OccursMany1 e (Cons e l)
+    where
+      hOccursMany1 (Cons e l) = e : hOccursMany l
+
+instance ( List l
+         , OccursMany1 e l
+         )
+    => OccursMany1 e (Cons e' l)
+    where
+      hOccursMany1 (Cons _ l) = hOccursMany1 l
+
+-- OccursOpt (zero or one)
+class OccursOpt e l where
+    hOccursOpt :: l -> Maybe e
+
+instance OccursOpt e Nil where
+    hOccursOpt _ = Nothing
+
+instance OccursNot e l => OccursOpt e (Cons e l) where
+    hOccursOpt (Cons e _) = Just e
+
+instance OccursOpt e l => OccursOpt e (Cons e' l) where
+    hOccursOpt (Cons _ l) = hOccursOpt l
+
+-- Occurs (one)
+class Occurs e l where
+    hOccurs :: l -> e
+
+data TypeNotFound e
+
+instance Fail (TypeNotFound e) => Occurs e Nil
+    where
+      hOccurs = undefined
+
+instance ( List l
+         , OccursNot e l
+         )
+    => Occurs e (Cons e l)
+    where
+      hOccurs (Cons e _) = e
+
+instance ( List l
+         , Occurs e l
+         )
+    => Occurs e (Cons e' l)
+    where
+      hOccurs (Cons _ l) = hOccurs l
+
+-- OccursNot (zero)
+data     TypeFound e
+class    OccursNot e l
+instance OccursNot e Nil
+instance Fail (TypeFound e) => OccursNot e (Cons e  l)
+instance OccursNot e l     => OccursNot e (Cons e' l)
+
+-- NoDuplicates
+class    NoDuplicates l
+instance NoDuplicates Nil
+instance OccursNot e l => NoDuplicates (Cons 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