{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ConstraintKinds,
             DataKinds,
             EmptyCase,
             FlexibleContexts,
             FlexibleInstances,
             FunctionalDependencies,
             KindSignatures,
             GADTs,
             MultiParamTypeClasses,
             PatternSynonyms,
             PolyKinds,
             ScopedTypeVariables,
             TypeFamilies,
             TypeOperators,
             UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Frames.Rec where
import Data.Vinyl hiding (rget)
import qualified Data.Vinyl as V
import Data.Vinyl.Functor (Const(..), Compose(..), (:.))
import Data.Vinyl.Class.Method (PayloadType)
import Frames.Col
import GHC.TypeLits (KnownSymbol)

-- | A record with unadorned values. This is @Vinyl@'s 'Rec'
-- 'ElField'. We give this type a name as it is used pervasively for
-- records in 'Frames'.
type Record = FieldRec

-- | A @cons@ function for building 'Record' values.
(&:) :: KnownSymbol s => a -> Record rs -> Record (s :-> a ': rs)
a
x &: :: a -> Record rs -> Record ((s :-> a) : rs)
&: Record rs
xs = a -> ElField (s :-> a)
forall (s :: Symbol) t. KnownSymbol s => t -> ElField '(s, t)
Field a
x ElField (s :-> a) -> Record rs -> Record ((s :-> a) : rs)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Record rs
xs
infixr 5 &:

type family RecordColumns t where
  RecordColumns (Record ts) = ts

-- | Separate the first element of a 'Record' from the rest of the row.
recUncons :: Record (s :-> a ': rs) -> (a, Record rs)
recUncons :: Record ((s :-> a) : rs) -> (a, Record rs)
recUncons (Field t
x :& Rec ElField rs
xs) = (a
t
x, Record rs
Rec ElField rs
xs)
-- recUncons x = case x of _ -> error "recUncons impossible case"

-- | Undistribute 'Maybe' from a 'Rec' 'Maybe'. This is just a
-- specific usage of 'rtraverse', but it is quite common.
recMaybe :: Rec (Maybe :. ElField) cs -> Maybe (Record cs)
recMaybe :: Rec (Maybe :. ElField) cs -> Maybe (Record cs)
recMaybe = (forall (x :: (Symbol, *)).
 (:.) Maybe ElField x -> Maybe (ElField x))
-> Rec (Maybe :. ElField) cs -> Maybe (Record cs)
forall u (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse forall l (f :: l -> *) k (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
forall (x :: (Symbol, *)).
(:.) Maybe ElField x -> Maybe (ElField x)
getCompose
{-# INLINE recMaybe #-}

-- | Show each field of a 'Record' /without/ its column name.
showFields :: (RecMapMethod Show ElField ts, RecordToList ts)
           => Record ts -> [String]
showFields :: Record ts -> [String]
showFields = Rec (Const String) ts -> [String]
forall u (rs :: [u]) a. RecordToList rs => Rec (Const a) rs -> [a]
recordToList (Rec (Const String) ts -> [String])
-> (Record ts -> Rec (Const String) ts) -> Record ts -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (a :: (Symbol, *)).
 Show (PayloadType ElField a) =>
 ElField a -> Const String a)
-> Record ts -> Rec (Const String) ts
forall u (c :: * -> Constraint) (f :: u -> *) (ts :: [u])
       (g :: u -> *).
RecMapMethod c f ts =>
(forall (a :: u). c (PayloadType f a) => f a -> g a)
-> Rec f ts -> Rec g ts
rmapMethod @Show forall (a :: (Symbol, *)).
Show (PayloadType ElField a) =>
ElField a -> Const String a
aux
  where aux :: (Show (PayloadType ElField a)) => ElField a -> Const String a
        aux :: ElField a -> Const String a
aux (Field t
x) = String -> Const String a
forall k a (b :: k). a -> Const a b
Const (t -> String
forall a. Show a => a -> String
show t
x)
{-# INLINABLE showFields #-}

-- | Get the value of a field of a 'Record'. This is intended for use
-- with @TypeApplications@, as compared to 'rgetv' that is intended
-- for use with @OverloadedLabels@.
rgetField :: forall t s a rs. (t ~ '(s,a), t ∈ rs) => Record rs -> a
rgetField :: Record rs -> a
rgetField = ElField '(s, a) -> a
forall (s :: Symbol) t. ElField '(s, t) -> t
getField (ElField '(s, a) -> a)
-> (Record rs -> ElField '(s, a)) -> Record rs -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (rs :: [(Symbol, *)]) (f :: (Symbol, *) -> *)
       (record :: ((Symbol, *) -> *) -> [(Symbol, *)] -> *).
(RecElem record t t rs rs (RIndex t rs), RecElemFCtx record f) =>
record f rs -> f t
forall k (r :: k) (rs :: [k]) (f :: k -> *)
       (record :: (k -> *) -> [k] -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
record f rs -> f r
V.rget @t
{-# INLINE rgetField #-}

-- | Replace the value of a field of a 'Record'. This is intended for
-- use with @TypeApplications@, as compared to 'rputf' that is
-- intended for use with @OverloadedLabels@.
rputField :: forall t s a rs. (t ~ '(s,a), t ∈ rs, KnownSymbol s)
          => a -> Record rs -> Record rs
rputField :: a -> Record rs -> Record rs
rputField = forall (rs :: [(Symbol, *)])
       (record :: ((Symbol, *) -> *) -> [(Symbol, *)] -> *)
       (f :: (Symbol, *) -> *).
(RecElem record t t rs rs (RIndex t rs), RecElemFCtx record f) =>
f t -> record f rs -> record f rs
forall k (r :: k) (rs :: [k]) (record :: (k -> *) -> [k] -> *)
       (f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
V.rput @_ @t (ElField t -> Record rs -> Record rs)
-> (a -> ElField t) -> a -> Record rs -> Record rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ElField t
forall (s :: Symbol) t. KnownSymbol s => t -> ElField '(s, t)
Field
{-# INLINE rputField #-}