HList

gistfile1.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module HList where

import Prelude hiding (head, tail, zip)
import GHC.Exts (Constraint)

data HList :: [*] -> * where
    Nil :: HList '[]
    Cons :: a -> HList l -> HList (a ': l)

instance Show (HList '[]) where
    show Nil = "Nil"

instance (Show a, Show (HList l)) => Show (HList (a ': l)) where
    show (Cons x xs) = "Cons " ++ show x ++ " (" ++ show xs ++ show ")"

head :: HList (a ': l) -> a
head (Cons h _) = h

tail :: HList (a ': l) -> HList l
tail (Cons _ t) = t

type family Fun (l :: [*]) (r :: *) where
    Fun '[]       r = r
    Fun (a ': as) r = a -> Fun as r

apply :: Fun l c -> HList l -> c
apply x Nil = x
apply f (Cons h t) = apply (f h) t

type family Zip (l :: [*]) (k :: [*]) where
    Zip '[]       '[]       = '[]
    Zip (a ': as) (b ': bs) = (a,b) ': Zip as bs

type family Zippable (l :: [*]) (k :: [*]) :: Constraint where
    Zippable '[]       '[]       = ()
    Zippable (a ': as) (b ': bs) = Zippable as bs
    Zippable as        bs        = ("Error!" ~ "List lengths are unequal!")

zip :: Zippable l k => HList l -> HList k -> HList (Zip l k)
zip Nil Nil = Nil
zip (Cons a as) (Cons b bs) = Cons (a,b) (zip as bs)

someList :: HList [Bool, Char, Int]
someList = Cons True (Cons 'c' (Cons 1 Nil))

anotherList :: HList [Maybe (), [a], Double]
anotherList = Cons (Just ()) (Cons [] (Cons 2.0 Nil))

zippedList :: HList [(Bool, Maybe ()), (Char, [a]), (Int, Double)]
zippedList = zip someList anotherList

main :: IO ()
main = print $ apply (,,) someList