Skip to content

Instantly share code, notes, and snippets.

@aavogt
Created February 17, 2016 04:29
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save aavogt/50d5313c99b7224b62dd to your computer and use it in GitHub Desktop.
a newtype for HLists of functions
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
-- response to https://clintonmeadprogramming.wordpress.com/2016/02/16/generalising-categories/
import Data.HList.CommonMain
import Control.Category
import Prelude hiding (id, (.), ($))
type family TupToArr (xs :: [*]) where
TupToArr ( (x,y) ': xs) = (x -> y) ': TupToArr xs
TupToArr '[] = '[]
type family ArrToTup (xs :: [*]) where
ArrToTup ( (x -> y) ': xs) = (x,y) ': ArrToTup xs
ArrToTup '[] = '[]
newtype HF xs ys = HF (HList (TupToArr (HZipR xs ys)))
mkHF :: (HZipList xs ys tfs, ArrToTup fs ~ tfs, fs ~ TupToArr (HZipR xs ys)) => HList fs -> HF xs ys
mkHF = HF
-- together with compHF this could make a Category instance,
-- but the classes used to implement hReplicateF need access
-- parameters hidden
idHF = mkHF (hReplicateF Proxy ConstId ())
compHF :: _ => HF b c -> HF a b -> HF a c
compHF (HF bc) (HF ab) = mkHF (hMap Comp (hZip ab bc))
data ConstId = ConstId
instance (id ~ (a -> a)) => ApplyAB ConstId x id where
applyAB _ _ = id
data App = App
instance (fxy ~ (x -> y, x)) => ApplyAB App fxy y where
applyAB _ (f,x) = f x
applyHF :: _ => HF x y -> HList x -> HList y
applyHF (HF fs) x = hMap App (hZip fs x)
class Dollar f x y where
($) :: f -> x -> y
infixr 0 $
instance (a ~ a', b ~ b') => Dollar (a -> b) a' b' where
f $ x = f x
instance (HZipList fs x a,
fs ~ TupToArr (HZipR x y),
HMapCxt HList App a y,
SameLengths '[fs,x,a]
, hx ~ HList x, hy ~ HList y) => Dollar (HF x y) hx hy where
f $ x = applyHF f x
f1 = mkHF $ hBuild (+1) succ (/3)
f2 = mkHF $ hBuild fromInteger succ (** 3)
x = hEnd $ hBuild 1 LT 9
main = do
let (.) = compHF
print $ (f1 . idHF) $ x
print $ (idHF . f1) $ x
print $ (f2 . f1) $ x
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment