Data/HList/Prelude.hs

   1 {- -*- coding: utf-8 -*- -}
   2 {-# LANGUAGE
   3   DeriveDataTypeable,
   4   EmptyDataDecls,
   5   FlexibleContexts,
   6   FlexibleInstances,
   7   FunctionalDependencies,
   8   MultiParamTypeClasses,
   9   OverlappingInstances,
  10   TypeFamilies,
  11   TypeOperators,
  12   UndecidableInstances
  13   #-}
  14 module Data.HList.Prelude
  15     ( HList
  16
  17     , HNil(..)
  18     , hNil
  19
  20     , HCons(..)
  21     , hCons
  22
  23     , HExtendT(..)
  24     , HAppendT(..)
  25
  26     , ApplyT(..)
  27     , Apply2T(..)
  28
  29     , Id(..)
  30     , HAppendA(..)
  31
  32     , HFoldrT(..)
  33     , HConcatT(..)
  34     , HMapT(..)
  35
  36     , HAll
  37     , HLength
  38
  39     , Fail
  40     , TypeFound
  41     , TypeNotFound
  42     , HOccursMany(..)
  43     , HOccursMany1(..)
  44     , HOccursOpt(..)
  45     , HOccurs(..)
  46     , HOccursNot(..)
  47     )
  48     where
  49
  50 import Data.Typeable
  51 import Types.Data.Bool
  52 import Types.Data.Num hiding ((:*:))
  53
  54
  55 -- HList
  56 class HList l
  57
  58 -- HNil
  59 data HNil
  60     = HNil
  61       deriving (Show, Eq, Ord, Read, Typeable)
  62
  63 instance HList HNil
  64
  65 hNil :: HNil
  66 hNil = HNil
  67
  68 -- HCons
  69 data HCons e l
  70     = HCons e l
  71       deriving (Show, Eq, Ord, Read, Typeable)
  72
  73 instance HList l => HList (HCons e l)
  74
  75 hCons :: HList l => e -> l -> HCons e l
  76 hCons = HCons
  77
  78 -- HExtendT
  79 infixr 2 :&:
  80 infixr 2 .&.
  81
  82 class HExtendT e l where
  83     type e :&: l
  84     (.&.) :: e -> l -> e :&: l
  85
  86 instance HExtendT e HNil where
  87     type e :&: HNil = HCons e HNil
  88     e .&. nil = hCons e nil
  89
  90 instance HList l => HExtendT e (HCons e' l) where
  91     type e :&: HCons e' l = HCons e (HCons e' l)
  92     e .&. HCons e' l = hCons e (hCons e' l)
  93
  94 -- HAppendT
  95 infixr 1 :++:
  96 infixr 1 .++.
  97
  98 class HAppendT l l' where
  99     type l :++: l'
 100     (.++.) :: l -> l' -> l :++: l'
 101
 102 instance HList l => HAppendT HNil l where
 103     type HNil :++: l = l
 104     _ .++. l = l
 105
 106 instance ( HList (l :++: l')
 107          , HAppendT l l'
 108          ) => HAppendT (HCons e l) l' where
 109     type HCons e l :++: l' = HCons e (l :++: l')
 110     (HCons e l) .++. l' = hCons e (l .++. l')
 111
 112 -- ApplyT
 113 class ApplyT f a where
 114     type Apply f a
 115     apply :: f -> a -> Apply f a
 116     apply _ _ = undefined
 117
 118 -- Apply2T
 119 class Apply2T f a b where
 120     type Apply2 f a b
 121     apply2 :: f -> a -> b -> Apply2 f a b
 122     apply2 _ _ _ = undefined
 123
 124 -- Id
 125 data Id = Id
 126
 127 instance ApplyT Id a where
 128     type Apply Id a = a
 129     apply _ a = a
 130
 131 -- HAppendA
 132 data HAppendA = HAppendA
 133
 134 instance HAppendT a b => Apply2T HAppendA a b where
 135     type Apply2 HAppendA a b = a :++: b
 136     apply2 _ a b = a .++. b
 137
 138 -- HFoldrT
 139 class HFoldrT f v l where
 140     type HFoldr f v l
 141     hFoldr :: f -> v -> l -> HFoldr f v l
 142
 143 instance HFoldrT f v HNil where
 144     type HFoldr f v HNil = v
 145     hFoldr _ v _ = v
 146
 147 instance ( HFoldrT f v l
 148          , Apply2T f e (HFoldr f v l)
 149          ) => HFoldrT f v (HCons e l) where
 150     type HFoldr f v (HCons e l) = Apply2 f e (HFoldr f v l)
 151     hFoldr f v (HCons e l) = apply2 f e (hFoldr f v l)
 152
 153 -- HConcatT
 154 class HConcatT ls where
 155     type HConcat ls
 156     hConcat :: ls -> HConcat ls
 157
 158 instance HFoldrT HAppendA HNil ls => HConcatT ls where
 159     type HConcat ls = HFoldr HAppendA HNil ls
 160     hConcat ls = hFoldr HAppendA hNil ls
 161
 162 -- HMapT
 163 class HMapT f l where
 164     type HMap f l
 165     hMap :: f -> l -> HMap f l
 166
 167 instance HMapT f HNil where
 168     type HMap f HNil = HNil
 169     hMap _ _ = hNil
 170
 171 instance ( ApplyT f x
 172          , HMapT f xs
 173          , HList (HMap f xs)
 174          ) => HMapT f (HCons x xs) where
 175     type HMap f (HCons x xs) = HCons (Apply f x) (HMap f xs)
 176     hMap f (HCons x xs) = hCons (apply f x) (hMap f xs)
 177
 178 -- HAll
 179 type family HAll f l
 180 type instance HAll f HNil         = True
 181 type instance HAll f (HCons x xs) = If (Apply f x) (HAll f xs) False
 182
 183 -- HLength
 184 type family HLength l
 185 type instance HLength HNil        = D0
 186 type instance HLength (HCons e l) = Succ (HLength l)
 187
 188 -- Fail
 189 class Fail a
 190
 191 -- HOccursMany (zero or more)
 192 class HOccursMany e l where
 193     hOccursMany :: l -> [e]
 194
 195 instance HOccursMany e HNil where
 196     hOccursMany _ = []
 197
 198 instance ( HList l
 199          , HOccursMany e l
 200          )
 201     => HOccursMany e (HCons e l)
 202     where
 203       hOccursMany (HCons e l) = e : hOccursMany l
 204
 205 instance ( HList l
 206          , HOccursMany e l
 207          )
 208     => HOccursMany e (HCons e' l)
 209     where
 210       hOccursMany (HCons _ l) = hOccursMany l
 211
 212 -- HOccursMany1 (one or more)
 213 class HOccursMany1 e l where
 214     hOccursMany1 :: l -> [e]
 215
 216 instance Fail (TypeNotFound e) => HOccursMany1 e HNil where
 217     hOccursMany1 _ = undefined
 218
 219 instance ( HList l
 220          , HOccursMany e l
 221          )
 222     => HOccursMany1 e (HCons e l)
 223     where
 224       hOccursMany1 (HCons e l) = e : hOccursMany l
 225
 226 instance ( HList l
 227          , HOccursMany1 e l
 228          )
 229     => HOccursMany1 e (HCons e' l)
 230     where
 231       hOccursMany1 (HCons _ l) = hOccursMany1 l
 232
 233 -- HOccursOpt (zero or one)
 234 class HOccursOpt e l where
 235     hOccursOpt :: l -> Maybe e
 236
 237 instance HOccursOpt e HNil where
 238     hOccursOpt _ = Nothing
 239
 240 instance HOccursNot e l => HOccursOpt e (HCons e l) where
 241     hOccursOpt (HCons e _) = Just e
 242
 243 instance HOccursOpt e l => HOccursOpt e (HCons e' l) where
 244     hOccursOpt (HCons _ l) = hOccursOpt l
 245
 246 -- HOccurs (one)
 247 class HOccurs e l where
 248     hOccurs :: l -> e
 249
 250 data TypeNotFound e
 251
 252 instance Fail (TypeNotFound e) => HOccurs e HNil
 253     where
 254       hOccurs = undefined
 255
 256 instance ( HList l
 257          , HOccursNot e l
 258          )
 259     => HOccurs e (HCons e l)
 260     where
 261       hOccurs (HCons e _) = e
 262
 263 instance ( HList l
 264          , HOccurs e l
 265          )
 266     => HOccurs e (HCons e' l)
 267     where
 268       hOccurs (HCons _ l) = hOccurs l
 269
 270 -- HOccursNot (zero)
 271 data     TypeFound e
 272 class    HOccursNot e l
 273 instance HOccursNot e HNil
 274 instance Fail (TypeFound e) => HOccursNot e (HCons e  l)
 275 instance HOccursNot e l     => HOccursNot e (HCons e' l)
 276
 277 {-
 278 {-
 279 "Strongly Typed Heterogeneous Collections"
 280    — August 26, 2004
 281        Oleg Kiselyov
 282        Ralf Lämmel
 283        Keean Schupke
 284 ==========================
 285 9 By chance or by design?
 286
 287 We will now discuss the issues surrounding the definition of type
 288 equality, inequality, and unification — and give implementations
 289 differing in simplicity, genericity, and portability.
 290
 291 We define the class TypeEq x y b for type equality. The class relates
 292 two types x and y to the type HTrue in case the two types are equal;
 293 otherwise, the types are related to HFalse. We should point out
 294 however groundness issues. If TypeEq is to return HTrue, the types
 295 must be ground; TypeEq can return HFalse even for unground types,
 296 provided they are instantiated enough to determine that they are not
 297 equal. So, TypeEq is total for ground types, and partial for unground
 298 types. We also define the class TypeCast x y: a constraint that holds
 299 only if the two types x and y are unifiable. Regarding groundness of x
 300 and y, the class TypeCast is less restricted than TypeEq. That is,
 301 TypeCast x y succeeds even for unground types x and y in case they can
 302 be made equal through unification. TypeEq and TypeCast are related to
 303 each other as fol- lows. Whenever TypeEq succeeds with HTrue, TypeCast
 304 succeeds as well. Whenever TypeEq succeeds with HFalse, TypeCast
 305 fails.  But for unground types, when TypeCast succeeds, TypeEq might
 306 fail. So the two complement each other for unground types. Also,
 307 TypeEq is a partial predicate, while TypeCast is a relation. That’s
 308 why both are useful.
 309  -}
 310 class    TypeEq x y b | x y -> b
 311 instance TypeEq x x True
 312 instance TypeCast False b =>
 313          TypeEq x y b
 314
 315 class TypeCast a b | a -> b, b -> a
 316     where
 317       typeCast :: a -> b
 318
 319 class TypeCast' t a b | t a -> b, t b -> a
 320     where
 321       typeCast' :: t -> a -> b
 322
 323 class TypeCast'' t a b | t a -> b, t b -> a
 324     where
 325       typeCast'' :: t -> a -> b
 326
 327 instance TypeCast' () a b => TypeCast a b
 328     where
 329       typeCast x = typeCast' () x
 330
 331 instance TypeCast'' t a b => TypeCast' t a b
 332     where
 333       typeCast' = typeCast''
 334
 335 instance TypeCast'' () a a
 336     where
 337       typeCast'' _ x = x
 338 -}