+{-# LANGUAGE DeriveDataTypeable,
+ FlexibleContexts,
+ FlexibleInstances,
+ MultiParamTypeClasses,
+ TypeFamilies,
+ TypeOperators,
+ UndecidableInstances
+ #-}
module Data.HList.Prelude
( HList
+
, HNil(..)
, hNil
- , (:*:)(..)
- , (.*.)
- , HExtendable(..)
- , HAppendable(..)
+ , HCons(..)
+ , hCons
+
+ , HExtendT(..)
+ , HAppendT(..)
- , Applyable(..)
- , Applyable2(..)
+ , ApplyT(..)
+ , Apply2T(..)
, Id(..)
- , ApplyHAppend(..)
+ , HAppendA(..)
+
+ , HFoldrT(..)
+ , HConcatT(..)
+ , HMapT(..)
- , HFoldrable(..)
- , HConcatable(..)
- , HMappable(..)
+ , HAll
+ , HLength
)
where
import Data.Typeable
+import Types.Data.Bool
+import Types.Data.Num hiding ((:*:))
-- HList
hNil :: HNil
hNil = HNil
--- :*:
-infixr 2 :*:
-infixr 2 .*.
-
-data e :*: l
- = e :*: l
+-- HCons
+data HCons e l
+ = HCons e l
deriving (Show, Eq, Ord, Read, Typeable)
-instance HList l => HList (e :*: l)
+instance HList l => HList (HCons e l)
+
+hCons :: HList l => e -> l -> HCons e l
+hCons = HCons
-(.*.) :: HList l => e -> l -> e :*: l
-(.*.) = (:*:)
+-- HExtendT
+infixr 2 :*:
+infixr 2 .*.
--- HExtendable
-class HExtendable e l where
- type HExtend e l
- hExtend :: e -> l -> HExtend e l
+class HExtendT e l where
+ type e :*: l
+ (.*.) :: e -> l -> e :*: l
-instance HExtendable e HNil where
- type HExtend e HNil = e :*: HNil
- hExtend e nil = e .*. nil
+instance HExtendT e HNil where
+ type e :*: HNil = HCons e HNil
+ e .*. nil = hCons e nil
-instance HList l => HExtendable e (e' :*: l) where
- type HExtend e (e' :*: l) = e :*: e' :*: l
- hExtend e (e' :*: l) = e .*. e' .*. l
+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)
--- HAppendable
+-- HAppendT
infixr 1 :++:
infixr 1 .++.
-class HAppendable l l' where
+class HAppendT l l' where
type l :++: l'
(.++.) :: l -> l' -> l :++: l'
-instance HList l => HAppendable HNil l where
+instance HList l => HAppendT HNil l where
type HNil :++: l = l
_ .++. l = l
-instance ( HAppendable l l'
- , HList (l :++: l')
- ) => HAppendable (e :*: l) l' where
- type (e :*: l) :++: l' = e :*: (l :++: l')
- (e :*: l) .++. l' = e .*. (l .++. l')
+instance ( HList (l :++: l')
+ , HAppendT l l'
+ ) => HAppendT (HCons e l) l' where
+ type HCons e l :++: l' = HCons e (l :++: l')
+ (HCons 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
+-- HAppendA
+data HAppendA = HAppendA
-instance HAppendable a b => Applyable2 ApplyHAppend a b where
- type Apply2 ApplyHAppend a b = a :++: b
+instance HAppendT a b => Apply2T HAppendA a b where
+ type Apply2 HAppendA a b = a :++: b
apply2 _ a b = a .++. b
--- HFoldrable
-class HFoldrable f v l where
+-- HFoldrT
+class HFoldrT f v l where
type HFoldr f v l
hFoldr :: f -> v -> l -> HFoldr f v l
-instance HFoldrable f v HNil where
+instance HFoldrT f v HNil where
type HFoldr f v HNil = v
hFoldr _ v _ = v
-instance ( HFoldrable f v l
- , Applyable2 f e (HFoldr f v l)
- ) => HFoldrable f v (e :*: l) where
- type HFoldr f v (e :*: l) = Apply2 f e (HFoldr f v l)
- hFoldr f v (e :*: l) = apply2 f e (hFoldr f v l)
+instance ( HFoldrT f v l
+ , Apply2T f e (HFoldr f v l)
+ ) => HFoldrT 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)
--- HConcatable
-class HConcatable ls where
+-- HConcatT
+class HConcatT ls where
type HConcat ls
hConcat :: ls -> HConcat ls
-instance HFoldrable ApplyHAppend HNil ls => HConcatable ls where
- type HConcat ls = HFoldr ApplyHAppend HNil ls
- hConcat ls = hFoldr ApplyHAppend hNil ls
+instance HFoldrT HAppendA HNil ls => HConcatT ls where
+ type HConcat ls = HFoldr HAppendA HNil ls
+ hConcat ls = hFoldr HAppendA hNil ls
--- HMappable
-class HMappable f l where
+-- HMapT
+class HMapT f l where
type HMap f l
hMap :: f -> l -> HMap f l
-instance HMappable f HNil where
+instance HMapT f HNil where
type HMap f HNil = HNil
- hMap _ _ = HNil
-
-instance ( HList (HMap f xs)
- , Applyable f x
- , HMappable f xs
- ) => HMappable f (x :*: xs) where
- type HMap f (x :*: xs) = Apply f x :*: HMap f xs
- hMap f (x :*: xs) = apply f x .*. hMap f xs
+ hMap _ _ = hNil
+
+instance ( ApplyT f x
+ , HMapT f xs
+ , HList (HMap f xs)
+ ) => HMapT 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)
+
+-- HAll
+type family HAll f l
+type instance HAll f HNil = True
+type instance HAll f (HCons x xs) = If (Apply f x) (HAll f xs) False
+
+-- HLength
+type family HLength l
+type instance HLength HNil = D0
+type instance HLength (HCons e l) = Succ (HLength l)