gistfile1.hs

{-# LANGUAGE DataKinds, TypeFamilies, KindSignatures, TypeOperators, 
             GADTs, FlexibleInstances, FlexibleContexts, UndecidableInstances, 
             MultiParamTypeClasses, FunctionalDependencies #-}

module HeteroList 
  ( HList (HNil, (:::))
  , hhead, htail
  , hinit, hlast
  , hlength, hnull
  , hreverse, (+++)
  )
  where

import Debug.Trace

infixr 5 :::

data HList :: [*] -> * where
  HNil  :: HList '[]
  (:::) :: a -> HList t -> HList (a ': t)

------------------------------------------------------------------------------------
-- Abgeleitete Typklassen: Show, Eq
------------------------------------------------------------------------------------
class ShowHelper a where
  show' :: a -> String

instance ShowHelper (HList '[]) where
  show' _ = "]"
instance (Show a, ShowHelper (HList t)) => ShowHelper (HList (a ': t)) where
  show' (x ::: HNil) = show x ++ show' HNil
  show' (x ::: xs) = show x ++ "," ++ show' xs

instance Show (HList '[]) where
  show _ = "[]"
instance ShowHelper (HList (a ': t)) => Show (HList (a ': t)) where
  show lst = "[" ++ show' lst


instance Eq (HList '[]) where
  _ == _ = True
instance (Eq a, Eq (HList t)) => Eq (HList (a ': t)) where
  (x ::: xs) == (y ::: ys) = (x == y) && (xs == ys)


------------------------------------------------------------------------------------
-- Standard-Listenfunktionen: head, tail, last, init, length, null, reverse
------------------------------------------------------------------------------------

class HasLast a b | a -> b where
  hlast :: a -> b
instance HasLast (HList (a ': '[])) a where
  hlast (x ::: xs) = x
instance HasLast (HList (c ': t)) b => HasLast (HList (a ': c ': t )) b where
  hlast (x ::: xs) = hlast xs

class HasInit a b | a -> b where
  hinit :: a -> b
instance HasInit (HList (a ': '[])) (HList '[]) where
  hinit (x ::: xs) = HNil
instance HasInit (HList (b ': t)) (HList c) => HasInit (HList (a ': b ': t)) (HList (a ': c))  where
  hinit (x ::: xs) = x ::: (hinit xs)

class HasLength a where
  hlength :: a -> Int
instance HasLength (HList '[]) where
  hlength _ = 0
instance (HasLength (HList t)) => HasLength (HList (a ': t)) where
  hlength (x ::: xs) = 1 + hlength xs

class HasNull a where
  hnull :: a -> Bool
instance HasNull (HList '[]) where
  hnull _ = True
instance HasNull (HList t) => HasNull (HList (a ': t)) where
  hnull _ = False


class CanAppend a b c | a b -> c where
  (+++) :: a -> b -> c
  infixr 5 +++
instance CanAppend (HList '[]) (HList t) (HList t) where
  (+++) _ ys = ys
instance CanAppend (HList v) (HList t) (HList w) => CanAppend (HList (a ': v)) (HList t) (HList (a ': w)) where
  (+++) (x:::xs) ys = x ::: (xs +++ ys)

class HasReverse a b | a -> b where
  hreverse :: a -> b
instance HasReverse (HList '[]) (HList '[]) where
  hreverse _ = HNil
instance (HasReverse (HList t) (HList v), CanAppend (HList v) (HList (a ': '[])) (HList w)) => HasReverse (HList (a ': t)) (HList w) where
  hreverse (x:::xs) = hreverse xs +++ (x ::: HNil)

hhead :: HList (a ': t) -> a
hhead (x ::: xs) = x

htail :: HList (a ': t) -> HList t
htail (x ::: xs) = xs

foo = 1 ::: "Bar" ::: "Baz" ::: HNil