a newtype for HLists of functions
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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