{-# LANGUAGE AllowAmbiguousTypes,
ConstraintKinds,
CPP,
DataKinds,
FlexibleContexts,
FlexibleInstances,
GADTs,
KindSignatures,
MultiParamTypeClasses,
PatternSynonyms,
RankNTypes,
ScopedTypeVariables,
TypeApplications,
TypeFamilies,
TypeOperators,
ViewPatterns #-}
module Frames.RecF (V.rappend, V.rtraverse, rdel, CanDelete,
frameCons, frameConsA, frameSnoc,
pattern (:&), pattern Nil, AllCols,
UnColumn, AsVinyl(..), mapMono, mapMethod,
runcurry, runcurry', runcurryA, runcurryA',
ShowRec, showRec, ColFun, ColumnHeaders,
columnHeaders, reifyDict) where
import Data.List (intercalate)
import Data.Proxy
import qualified Data.Vinyl as V
import Data.Vinyl (Rec(RNil), RecApplicative(rpure))
import qualified Data.Vinyl.Curry as V
import Data.Vinyl.Functor (Compose, Identity)
import Data.Vinyl.TypeLevel
import Frames.Col
import Frames.TypeLevel
import GHC.TypeLits (KnownSymbol, symbolVal)
frameCons :: Functor f => f a -> V.Rec f rs -> V.Rec f (s :-> a ': rs)
frameCons = (V.:&) . fmap Col
{-# INLINE frameCons #-}
frameConsA :: Applicative f => a -> V.Rec f rs -> V.Rec f (s :-> a ': rs)
frameConsA = (V.:&) . fmap Col . pure
{-# INLINE frameConsA #-}
frameUncons :: Functor f => V.Rec f (s :-> r ': rs) -> (f r, V.Rec f rs)
frameUncons (x V.:& xs) = (fmap getCol x, xs)
{-# INLINE frameUncons #-}
frameSnoc :: V.Rec f rs -> f r -> V.Rec f (rs ++ '[r])
frameSnoc r x = V.rappend r (x V.:& RNil)
{-# INLINE frameSnoc #-}
pattern Nil :: Rec f '[]
pattern Nil <- V.RNil where
Nil = V.RNil
pattern (:&) :: Functor f => f r -> Rec f rs -> Rec f (s :-> r ': rs)
pattern x :& xs <- (frameUncons -> (x, xs)) where
x :& xs = frameCons x xs
class ColumnHeaders (cs::[*]) where
columnHeaders :: proxy (Rec f cs) -> [String]
instance ColumnHeaders '[] where
columnHeaders _ = []
instance forall cs s c. (ColumnHeaders cs, KnownSymbol s)
=> ColumnHeaders (s :-> c ': cs) where
columnHeaders _ = symbolVal (Proxy::Proxy s) : columnHeaders (Proxy::Proxy (Rec f cs))
type family ColFun f x where
ColFun f (Rec Identity rs) = Rec f rs
type family UnColumn ts where
UnColumn '[] = '[]
UnColumn ((s :-> t) ': ts) = t ': UnColumn ts
type AllCols c ts = AllConstrained c (UnColumn ts)
class AsVinyl ts where
toVinyl :: Functor f => Rec f ts -> V.Rec f (UnColumn ts)
fromVinyl :: Functor f => V.Rec f (UnColumn ts) -> Rec f ts
instance AsVinyl '[] where
toVinyl _ = V.RNil
fromVinyl _ = V.RNil
instance AsVinyl ts => AsVinyl (s :-> t ': ts) where
toVinyl (x V.:& xs) = fmap getCol x V.:& toVinyl xs
fromVinyl (x V.:& xs) = fmap Col x V.:& fromVinyl xs
#if __GLASGOW_HASKELL__ < 800
fromVinyl _ = error "GHC coverage checker isn't great"
#endif
mapMonoV :: (Functor f, AllAre a ts)
=> (a -> b) -> V.Rec f ts -> V.Rec f (ReplaceAll b ts)
mapMonoV _ V.RNil = V.RNil
mapMonoV f (x V.:& xs) = fmap f x V.:& mapMonoV f xs
mapMono :: (AllAre a (UnColumn ts), AsVinyl ts, Functor f,
AsVinyl (ReplaceColumns b ts),
ReplaceAll b (UnColumn ts) ~ UnColumn (ReplaceColumns b ts))
=> (a -> b) -> Rec f ts -> Rec f (ReplaceColumns b ts)
mapMono f = fromVinyl . mapMonoV f . toVinyl
mapMethodV :: forall c f ts. (Functor f, AllConstrained c ts)
=> (forall a. c a => a -> a) -> V.Rec f ts -> V.Rec f ts
mapMethodV f = go
where go :: AllConstrained c ts' => V.Rec f ts' -> V.Rec f ts'
go V.RNil = V.RNil
go (x V.:& xs) = fmap f x V.:& go xs
mapMethod :: forall c f ts.
(Functor f, AllConstrained c (UnColumn ts), AsVinyl ts)
=> (forall a. c a => a -> a) -> Rec f ts -> Rec f ts
mapMethod f = fromVinyl . mapMethodV @c f . toVinyl
runcurry :: (Functor f, AsVinyl ts)
=> V.CurriedF f (UnColumn ts) a -> Rec f ts -> a
runcurry = (. toVinyl) . V.runcurry
{-# INLINABLE runcurry #-}
runcurry' :: AsVinyl ts => V.Curried (UnColumn ts) a -> Rec Identity ts -> a
runcurry' = (. toVinyl) . V.runcurry'
{-# INLINABLE runcurry' #-}
runcurryA' :: (Applicative f, AsVinyl ts)
=> V.Curried (UnColumn ts) a -> Rec f ts -> f a
runcurryA' = (. toVinyl) . V.runcurryA'
runcurryA :: (Applicative f, Functor g, AsVinyl ts)
=> V.CurriedF g (UnColumn ts) a -> Rec (Compose f g) ts -> f a
runcurryA = (. toVinyl) . V.runcurryA
type CanDelete r rs = (V.RElem r rs (RIndex r rs), RDelete r rs V.⊆ rs)
rdel :: CanDelete r rs => proxy r -> Rec f rs -> Rec f (RDelete r rs)
rdel _ = V.rcast
class Functor f => ShowRec f rs where
showRec' :: Rec f rs -> [String]
instance Functor f => ShowRec f '[] where
showRec' _ = []
instance forall s f a rs. (KnownSymbol s, Show (f (Col' s a)), ShowRec f rs)
=> ShowRec f (s :-> a ': rs) where
showRec' (x :& xs) = show (col' <$> x :: f (Col' s a)) : showRec' xs
showRec' _ = error "GHC coverage error"
showRec :: ShowRec f rs => Rec f rs -> String
showRec r = "{" ++ intercalate ", " (showRec' r) ++ "}"
reifyDict :: forall c f proxy ts. (AllConstrained c ts, RecApplicative ts)
=> proxy c -> (forall a. c a => f a) -> Rec f ts
reifyDict _ f = go (rpure Nothing)
where go :: AllConstrained c ts' => Rec Maybe ts' -> Rec f ts'
go RNil = RNil
go (_ V.:& xs) = f V.:& go xs