module Data.Vector.HFixed.Class (
S
, Z
#if __GLASGOW_HASKELL__ >= 708
, NatIso
, ToPeano
, ToNat
#endif
, Fn
, Fun(..)
, TFun(..)
, funToTFun
, tfunToFun
, Proxy(..)
, (++)()
, Len
, Wrap
, HomList
, Arity(..)
, ArityC(..)
, HVector(..)
, HVectorF(..)
, WitWrapped(..)
, WitConcat(..)
, WitNestedFun(..)
, WitLenWrap(..)
, WitWrapIndex(..)
, WitAllInstances(..)
, ContVec(..)
, ContVecF(..)
, toContVec
, toContVecF
, cons
, consF
, HomArity(..)
, homInspect
, homConstruct
, curryFun
, uncurryFun
, uncurryFun2
, curryMany
, constFun
, stepFun
, curryTFun
, uncurryTFun
, uncurryTFun2
, shuffleTF
, concatF
, shuffleF
, lensWorkerF
, Index(..)
) where
import Control.Applicative (Applicative(..),(<$>))
import Data.Complex (Complex(..))
import Data.Vector.Fixed.Cont (S,Z)
#if __GLASGOW_HASKELL__ >= 708
import Data.Vector.Fixed.Cont (ToPeano,ToNat,NatIso)
#endif
import qualified Data.Vector.Fixed as F
import qualified Data.Vector.Fixed.Cont as F (apFun)
import qualified Data.Vector.Fixed.Unboxed as U
import qualified Data.Vector.Fixed.Primitive as P
import qualified Data.Vector.Fixed.Storable as S
import qualified Data.Vector.Fixed.Boxed as B
import GHC.Generics hiding (Arity(..),S)
import Data.Vector.HFixed.TypeFuns
type family Fn (as :: [*]) b
type instance Fn '[] b = b
type instance Fn (a ': as) b = a -> Fn as b
newtype Fun (as :: [*]) b = Fun { unFun :: Fn as b }
newtype TFun f as b = TFun { unTFun :: Fn (Wrap f as) b }
funToTFun :: Fun (Wrap f xs) b -> TFun f xs b
funToTFun = TFun . unFun
tfunToFun :: TFun f xs b -> Fun (Wrap f xs) b
tfunToFun = Fun . unTFun
class F.Arity (Len xs) => Arity (xs :: [*]) where
accum :: (forall a as. t (a ': as) -> a -> t as)
-> (t '[] -> b)
-> t xs
-> Fn xs b
apply :: (forall a as. t (a ': as) -> (a, t as))
-> t xs
-> ContVec xs
applyM :: Monad m
=> (forall a as. t (a ': as) -> m (a, t as))
-> t xs
-> m (ContVec xs)
accumTy :: (forall a as. t (a ': as) -> f a -> t as)
-> (t '[] -> b)
-> t xs
-> Fn (Wrap f xs) b
applyTy :: (forall a as. t (a ': as) -> (f a, t as))
-> t xs
-> Fn (Wrap f xs) b
-> b
arity :: p xs -> Int
witWrapped :: WitWrapped f xs
witConcat :: Arity ys => WitConcat xs ys
witNestedFun :: WitNestedFun xs ys r
witLenWrap :: WitLenWrap f xs
class Arity xs => ArityC c xs where
witAllInstances :: WitAllInstances c xs
instance ArityC c '[] where
witAllInstances = WitAllInstancesNil
instance (c x, ArityC c xs) => ArityC c (x ': xs) where
witAllInstances = WitAllInstancesCons (witAllInstances :: WitAllInstances c xs)
data WitWrapped f xs where
WitWrapped :: Arity (Wrap f xs) => WitWrapped f xs
data WitConcat xs ys where
WitConcat :: (Arity (xs++ys)) => WitConcat xs ys
data WitNestedFun xs ys r where
WitNestedFun :: (Fn (xs++ys) r ~ Fn xs (Fn ys r)) => WitNestedFun xs ys r
data WitLenWrap f xs where
WitLenWrap :: Len xs ~ Len (Wrap f xs) => WitLenWrap f xs
data WitAllInstances c xs where
WitAllInstancesNil :: WitAllInstances c '[]
WitAllInstancesCons :: c x => WitAllInstances c xs -> WitAllInstances c (x ': xs)
instance Arity '[] where
accum _ f t = f t
apply _ _ = ContVec unFun
applyM _ _ = return (ContVec unFun)
accumTy _ f t = f t
applyTy _ _ b = b
arity _ = 0
witWrapped = WitWrapped
witConcat = WitConcat
witNestedFun = WitNestedFun
witLenWrap = WitLenWrap
instance Arity xs => Arity (x ': xs) where
accum f g t = \a -> accum f g (f t a)
apply f t = case f t of (a,u) -> cons a (apply f u)
applyM f t = do (a,t') <- f t
vec <- applyM f t'
return $ cons a vec
accumTy f g t = \a -> accumTy f g (f t a)
applyTy f t h = case f t of (a,u) -> applyTy f u (h a)
arity _ = 1 + arity (Proxy :: Proxy xs)
witWrapped :: forall f. WitWrapped f (x ': xs)
witWrapped = case witWrapped :: WitWrapped f xs of
WitWrapped -> WitWrapped
witConcat :: forall ys. Arity ys => WitConcat (x ': xs) ys
witConcat = case witConcat :: WitConcat xs ys of
WitConcat -> WitConcat
witNestedFun :: forall ys r. WitNestedFun (x ': xs) ys r
witNestedFun = case witNestedFun :: WitNestedFun xs ys r of
WitNestedFun -> WitNestedFun
witLenWrap :: forall f. WitLenWrap f (x ': xs)
witLenWrap = case witLenWrap :: WitLenWrap f xs of
WitLenWrap -> WitLenWrap
class Arity (Elems v) => HVector v where
type Elems v :: [*]
type Elems v = GElems (Rep v)
construct :: Fun (Elems v) v
default construct :: (Generic v, GHVector (Rep v), GElems (Rep v) ~ Elems v, Functor (Fun (Elems v)))
=> Fun (Elems v) v
construct = fmap to gconstruct
inspect :: v -> Fun (Elems v) a -> a
default inspect :: (Generic v, GHVector (Rep v), GElems (Rep v) ~ Elems v)
=> v -> Fun (Elems v) a -> a
inspect v = ginspect (from v)
class Arity (ElemsF v) => HVectorF (v :: (* -> *) -> *) where
type ElemsF v :: [*]
inspectF :: v f -> TFun f (ElemsF v) a -> a
constructF :: TFun f (ElemsF v) (v f)
class (F.Arity n, Arity (HomList n a)) => HomArity n a where
toHeterogeneous :: F.Fun n a r -> Fun (HomList n a) r
toHomogeneous :: Fun (HomList n a) r -> F.Fun n a r
instance HomArity Z a where
toHeterogeneous = Fun . F.unFun
toHomogeneous = F.Fun . unFun
instance HomArity n a => HomArity (S n) a where
toHeterogeneous f
= Fun $ \a -> unFun $ toHeterogeneous (F.apFun f a)
toHomogeneous (f :: Fun (a ': HomList n a) r)
= F.Fun $ \a -> F.unFun (toHomogeneous $ curryFun f a :: F.Fun n a r)
homInspect :: (F.Vector v a, HomArity (F.Dim v) a)
=> v a -> Fun (HomList (F.Dim v) a) r -> r
homInspect v f = F.inspect v (toHomogeneous f)
homConstruct :: forall v a.
(F.Vector v a, HomArity (F.Dim v) a)
=> Fun (HomList (F.Dim v) a) (v a)
homConstruct = toHeterogeneous (F.construct :: F.Fun (F.Dim v) a (v a))
instance HomArity n a => HVector (B.Vec n a) where
type Elems (B.Vec n a) = HomList n a
inspect = homInspect
construct = homConstruct
instance (U.Unbox n a, HomArity n a) => HVector (U.Vec n a) where
type Elems (U.Vec n a) = HomList n a
inspect = homInspect
construct = homConstruct
instance (S.Storable a, HomArity n a) => HVector (S.Vec n a) where
type Elems (S.Vec n a) = HomList n a
inspect = homInspect
construct = homConstruct
instance (P.Prim a, HomArity n a) => HVector (P.Vec n a) where
type Elems (P.Vec n a) = HomList n a
inspect = homInspect
construct = homConstruct
newtype ContVec xs = ContVec { runContVec :: forall r. Fun xs r -> r }
instance Arity xs => HVector (ContVec xs) where
type Elems (ContVec xs) = xs
construct = Fun $
accum (\(T_mkN f) x -> T_mkN (f . cons x))
(\(T_mkN f) -> f (ContVec unFun))
(T_mkN id :: T_mkN xs xs)
inspect (ContVec cont) f = cont f
newtype T_mkN all xs = T_mkN (ContVec xs -> ContVec all)
newtype ContVecF xs f = ContVecF (forall r. TFun f xs r -> r)
instance Arity xs => HVectorF (ContVecF xs) where
type ElemsF (ContVecF xs) = xs
inspectF (ContVecF cont) = cont
constructF = constructFF
constructFF :: forall f xs. (Arity xs) => TFun f xs (ContVecF xs f)
constructFF = TFun $ accumTy (\(TF_mkN f) x -> TF_mkN (f . consF x))
(\(TF_mkN f) -> f $ ContVecF unTFun)
(TF_mkN id :: TF_mkN f xs xs)
newtype TF_mkN f all xs = TF_mkN (ContVecF xs f -> ContVecF all f)
toContVec :: ContVecF xs f -> ContVec (Wrap f xs)
toContVec (ContVecF cont) = ContVec $ cont . TFun . unFun
toContVecF :: ContVec (Wrap f xs) -> ContVecF xs f
toContVecF (ContVec cont) = ContVecF $ cont . Fun . unTFun
cons :: x -> ContVec xs -> ContVec (x ': xs)
cons x (ContVec cont) = ContVec $ \f -> cont $ curryFun f x
consF :: f x -> ContVecF xs f -> ContVecF (x ': xs) f
consF x (ContVecF cont) = ContVecF $ \f -> cont $ curryTFun f x
instance (Arity xs) => Functor (Fun xs) where
fmap (f :: a -> b) (Fun g0 :: Fun xs a)
= Fun $ accum (\(T_fmap g) a -> T_fmap (g a))
(\(T_fmap r) -> f r)
(T_fmap g0 :: T_fmap a xs)
instance Arity xs => Applicative (Fun xs) where
pure r = Fun $ accum (\T_pure _ -> T_pure)
(\T_pure -> r)
(T_pure :: T_pure xs)
(Fun f0 :: Fun xs (a -> b)) <*> (Fun g0 :: Fun xs a)
= Fun $ accum (\(T_ap f g) a -> T_ap (f a) (g a))
(\(T_ap f g) -> f g)
( T_ap f0 g0 :: T_ap (a -> b) a xs)
instance Arity xs => Monad (Fun xs) where
return = pure
f >>= g = shuffleF g <*> f
newtype T_fmap a xs = T_fmap (Fn xs a)
data T_pure xs = T_pure
data T_ap a b xs = T_ap (Fn xs a) (Fn xs b)
instance (Arity xs) => Functor (TFun f xs) where
fmap (f :: a -> b) (TFun g0 :: TFun f xs a)
= TFun $ accumTy (\(TF_fmap g) a -> TF_fmap (g a))
(\(TF_fmap r) -> f r)
(TF_fmap g0 :: TF_fmap f a xs)
instance (Arity xs) => Applicative (TFun f xs) where
pure r = TFun $ accumTy step
(\TF_pure -> r)
(TF_pure :: TF_pure f xs)
where
step :: forall a as. TF_pure f (a ': as) -> f a -> TF_pure f as
step _ _ = TF_pure
(TFun f0 :: TFun f xs (a -> b)) <*> (TFun g0 :: TFun f xs a)
= TFun $ accumTy (\(TF_ap f g) a -> TF_ap (f a) (g a))
(\(TF_ap f g) -> f g)
( TF_ap f0 g0 :: TF_ap f (a -> b) a xs)
instance Arity xs => Monad (TFun f xs) where
return = pure
f >>= g = shuffleTF g <*> f
newtype TF_fmap f a xs = TF_fmap (Fn (Wrap f xs) a)
data TF_pure f xs = TF_pure
data TF_ap f a b xs = TF_ap (Fn (Wrap f xs) a) (Fn (Wrap f xs) b)
curryFun :: Fun (x ': xs) r -> x -> Fun xs r
curryFun (Fun f) x = Fun (f x)
uncurryFun :: (x -> Fun xs r) -> Fun (x ': xs) r
uncurryFun = Fun . fmap unFun
uncurryFun2 :: (Arity xs)
=> (x -> y -> Fun xs (Fun ys r))
-> Fun (x ': xs) (Fun (y ': ys) r)
uncurryFun2 = uncurryFun . fmap (fmap uncurryFun . shuffleF)
uncurryMany :: forall xs ys r. Arity xs => Fun xs (Fun ys r) -> Fun (xs ++ ys) r
uncurryMany f =
case witNestedFun :: WitNestedFun xs ys r of
WitNestedFun ->
case fmap unFun f :: Fun xs (Fn ys r) of
Fun g -> Fun g
curryMany :: forall xs ys r. Arity xs => Fun (xs ++ ys) r -> Fun xs (Fun ys r)
curryMany (Fun f0)
= Fun $ accum (\(T_curry f) a -> T_curry (f a))
(\(T_curry f) -> Fun f :: Fun ys r)
(T_curry f0 :: T_curry r ys xs)
newtype T_curry r ys xs = T_curry (Fn (xs ++ ys) r)
constFun :: Fun xs r -> Fun (x ': xs) r
constFun = uncurryFun . const
stepFun :: (Fun xs a -> Fun ys b) -> Fun (x ': xs) a -> Fun (x ': ys) b
stepFun g = uncurryFun . fmap g . curryFun
concatF :: (Arity xs, Arity ys)
=> (a -> b -> c) -> Fun xs a -> Fun ys b -> Fun (xs ++ ys) c
concatF f funA funB = uncurryMany $ fmap go funA
where
go a = fmap (\b -> f a b) funB
shuffleF :: forall x xs r. Arity xs => (x -> Fun xs r) -> Fun xs (x -> r)
shuffleF fun = Fun $ accum
(\(T_shuffle f) a -> T_shuffle (\x -> f x a))
(\(T_shuffle f) -> f)
(T_shuffle (fmap unFun fun) :: T_shuffle x r xs)
data T_shuffle x r xs = T_shuffle (Fn (x ': xs) r)
lensWorkerF :: forall f r x y xs. (Functor f, Arity xs)
=> (x -> f y) -> Fun (y ': xs) r -> Fun (x ': xs) (f r)
lensWorkerF g f
= uncurryFun
$ \x -> (\r -> fmap (r $) (g x)) <$> shuffleF (curryFun f)
curryTFun :: TFun f (x ': xs) r -> f x -> TFun f xs r
curryTFun (TFun f) = TFun . f
uncurryTFun :: (f x -> TFun f xs r) -> TFun f (x ': xs) r
uncurryTFun = TFun . fmap unTFun
uncurryTFun2 :: (Arity xs, Arity ys)
=> (f x -> f y -> TFun f xs (TFun f ys r))
-> TFun f (x ': xs) (TFun f (y ': ys) r)
uncurryTFun2 = uncurryTFun . fmap (fmap uncurryTFun . shuffleTF)
shuffleTF :: forall f x xs r. Arity xs
=> (x -> TFun f xs r) -> TFun f xs (x -> r)
shuffleTF fun0 = TFun $ accumTy
(\(TF_shuffle f) a -> TF_shuffle (\x -> f x a))
(\(TF_shuffle f) -> f)
(TF_shuffle (fmap unTFun fun0) :: TF_shuffle f x r xs)
data TF_shuffle f x r xs = TF_shuffle (x -> (Fn (Wrap f xs) r))
class F.Arity n => Index (n :: *) (xs :: [*]) where
type ValueAt n xs :: *
getF :: n -> Fun xs (ValueAt n xs)
putF :: n -> ValueAt n xs -> Fun xs r -> Fun xs r
lensF :: (Functor f, v ~ ValueAt n xs)
=> n -> (v -> f v) -> Fun xs r -> Fun xs (f r)
witWrapIndex :: WitWrapIndex f n xs
data WitWrapIndex f n xs where
WitWrapIndex :: ( ValueAt n (Wrap f xs) ~ f (ValueAt n xs)
, Index n (Wrap f xs)
, Arity (Wrap f xs)
) => WitWrapIndex f n xs
instance Arity xs => Index Z (x ': xs) where
type ValueAt Z (x ': xs) = x
getF _ = Fun $ \x -> unFun (pure x :: Fun xs x)
putF _ x f = constFun $ curryFun f x
lensF _ = lensWorkerF
witWrapIndex :: forall f. WitWrapIndex f Z (x ': xs)
witWrapIndex = case witWrapped :: WitWrapped f xs of
WitWrapped -> WitWrapIndex
instance Index n xs => Index (S n) (x ': xs) where
type ValueAt (S n) (x ': xs) = ValueAt n xs
getF _ = constFun $ getF (undefined :: n)
putF _ x = stepFun $ putF (undefined :: n) x
lensF _ f = stepFun $ lensF (undefined :: n) f
witWrapIndex :: forall f. WitWrapIndex f (S n) (x ': xs)
witWrapIndex = case witWrapIndex :: WitWrapIndex f n xs of
WitWrapIndex -> WitWrapIndex
instance HVector () where
type Elems () = '[]
construct = Fun ()
inspect () (Fun f) = f
instance HVector (Complex a) where
type Elems (Complex a) = '[a,a]
construct = Fun (:+)
inspect (r :+ i) (Fun f) = f r i
instance HVector (a,b) where
type Elems (a,b) = '[a,b]
construct = Fun (,)
inspect (a,b) (Fun f) = f a b
instance HVector (a,b,c) where
type Elems (a,b,c) = '[a,b,c]
construct = Fun (,,)
inspect (a,b,c) (Fun f) = f a b c
instance HVector (a,b,c,d) where
type Elems (a,b,c,d) = '[a,b,c,d]
construct = Fun (,,,)
inspect (a,b,c,d) (Fun f) = f a b c d
instance HVector (a,b,c,d,e) where
type Elems (a,b,c,d,e) = '[a,b,c,d,e]
construct = Fun (,,,,)
inspect (a,b,c,d,e) (Fun f) = f a b c d e
instance HVector (a,b,c,d,e,f) where
type Elems (a,b,c,d,e,f) = '[a,b,c,d,e,f]
construct = Fun (,,,,,)
inspect (a,b,c,d,e,f) (Fun fun) = fun a b c d e f
instance HVector (a,b,c,d,e,f,g) where
type Elems (a,b,c,d,e,f,g) = '[a,b,c,d,e,f,g]
construct = Fun (,,,,,,)
inspect (a,b,c,d,e,f,g) (Fun fun) = fun a b c d e f g
class GHVector (v :: * -> *) where
type GElems v :: [*]
gconstruct :: Fun (GElems v) (v p)
ginspect :: v p -> Fun (GElems v) r -> r
instance (GHVector f, Functor (Fun (GElems f))) => GHVector (M1 i c f) where
type GElems (M1 i c f) = GElems f
gconstruct = fmap M1 gconstruct
ginspect v = ginspect (unM1 v)
instance ( GHVector f, GHVector g
, Arity xs, GElems f ~ xs
, Arity ys, GElems g ~ ys
) => GHVector (f :*: g) where
type GElems (f :*: g) = GElems f ++ GElems g
gconstruct = concatF (:*:) gconstruct gconstruct
ginspect (f :*: g) fun
= ginspect g $ ginspect f $ curryMany fun
instance GHVector (K1 R x) where
type GElems (K1 R x) = '[x]
gconstruct = Fun K1
ginspect (K1 x) (Fun f) = f x
instance GHVector U1 where
type GElems U1 = '[]
gconstruct = Fun U1
ginspect _ (Fun f) = f