{-# LANGUAGE AllowAmbiguousTypes    #-}
{-# LANGUAGE CPP                    #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE PatternSynonyms        #-}
{-# LANGUAGE PolyKinds              #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}
-- | Concise vinyl record construction from tuples up to size 8. An
-- example record construction using 'ElField' for named fields:
-- @fieldRec (#x =: True, #y =: 'b') :: FieldRec '[ '("x", Bool), '("y", Char) ]@
module Data.Vinyl.FromTuple where
import Data.Monoid (First(..))
#if __GLASGOW_HASKELL__ < 804
import Data.Semigroup (Semigroup(..))
#endif
import Data.Vinyl.Core (RApply, RMap, RecApplicative, rcombine, rmap, rtraverse, Rec(..))
import Data.Vinyl.Functor (onCompose, Compose(..), getCompose, ElField)
import Data.Vinyl.Lens (RecSubset, RecSubsetFCtx, rcast, rdowncast, type (⊆))
import Data.Vinyl.TypeLevel (RImage, Snd)
import Data.Vinyl.XRec (XRec, pattern (::&), pattern XRNil, IsoXRec(..), HKD)
import GHC.TypeLits (TypeError, ErrorMessage(Text))

-- | Convert a tuple of types formed by the application of a common
-- type constructor to a tuple of the common type constructor and a
-- list of the types to which it is applied in the original
-- tuple. E.g. @TupleToRecArgs f (f a, f b) ~ (f, [a,b])@.
type family TupleToRecArgs f t = (r :: (u -> *, [u])) | r -> t where
  TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g, f h) =
    '(f, [a,b,c,d,e,z,g,h])
  TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g) = '(f, [a,b,c,d,e,z,g])
  TupleToRecArgs f (f a, f b, f c, f d, f e, f z) = '(f, [a,b,c,d,e,z])
  TupleToRecArgs f (f a, f b, f c, f d, f e) = '(f, [a,b,c,d,e])
  TupleToRecArgs f (f a, f b, f c, f d) = '(f, [a,b,c,d])
  TupleToRecArgs f (f a, f b, f c) = '(f, [a,b,c])
  TupleToRecArgs f (f a, f b) = '(f, [a,b])
  TupleToRecArgs f () = '(f , '[])

-- | Apply the 'Rec' type constructor to a type-level tuple of its
-- arguments.
type family UncurriedRec (t :: (u -> *, [u])) = r | r -> t where
  UncurriedRec '(f, ts) = Rec f ts

-- | Apply the 'XRec' type constructor to a type-level tuple of its
-- arguments.
type family UncurriedXRec (t :: (u -> *, [u])) = r | r -> t where
  UncurriedXRec '(f, ts) = XRec f ts

-- | Convert between an 'XRec' and an isomorphic tuple.
class TupleXRec f t where
  -- | Convert an 'XRec' to a tuple. Useful for pattern matching on an
  -- entire record.
  xrecTuple :: XRec f t -> ListToHKDTuple f t
  -- | Build an 'XRec' from a tuple.
  xrecX :: ListToHKDTuple f t -> XRec f t

instance TupleXRec f '[a,b] where
  xrecTuple :: XRec f '[a, b] -> ListToHKDTuple f '[a, b]
xrecTuple (HKD f a
a ::& HKD f b
b ::& XRec f '[]
XRNil) = (HKD f a
a, HKD f b
b)
  xrecX :: ListToHKDTuple f '[a, b] -> XRec f '[a, b]
xrecX (a, b) = HKD f a
a HKD f a -> XRec f '[b] -> XRec f '[a, b]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b -> XRec f '[] -> XRec f '[b]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

instance TupleXRec f '[a,b,c] where
  xrecTuple :: XRec f '[a, b, c] -> ListToHKDTuple f '[a, b, c]
xrecTuple (HKD f a
a ::& HKD f b
b ::& HKD f c
c ::& XRec f '[]
XRNil) = (HKD f a
a, HKD f b
b, HKD f c
c)
  xrecX :: ListToHKDTuple f '[a, b, c] -> XRec f '[a, b, c]
xrecX (a, b, c) = HKD f a
a HKD f a -> XRec f '[b, c] -> XRec f '[a, b, c]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b -> XRec f '[c] -> XRec f '[b, c]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f c
c HKD f c -> XRec f '[] -> XRec f '[c]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

instance TupleXRec f '[a,b,c,d] where
  xrecTuple :: XRec f '[a, b, c, d] -> ListToHKDTuple f '[a, b, c, d]
xrecTuple (HKD f a
a ::& HKD f b
b ::& HKD f c
c ::& HKD f d
d ::& XRec f '[]
XRNil) = (HKD f a
a, HKD f b
b, HKD f c
c, HKD f d
d)
  xrecX :: ListToHKDTuple f '[a, b, c, d] -> XRec f '[a, b, c, d]
xrecX (a, b, c, d) = HKD f a
a HKD f a -> XRec f '[b, c, d] -> XRec f '[a, b, c, d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b -> XRec f '[c, d] -> XRec f '[b, c, d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f c
c HKD f c -> XRec f '[d] -> XRec f '[c, d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f d
d HKD f d -> XRec f '[] -> XRec f '[d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

instance TupleXRec f '[a,b,c,d,e] where
  xrecTuple :: XRec f '[a, b, c, d, e] -> ListToHKDTuple f '[a, b, c, d, e]
xrecTuple (HKD f a
a ::& HKD f b
b ::& HKD f c
c ::& HKD f d
d ::& HKD f e
e ::& XRec f '[]
XRNil) =
    (HKD f a
a, HKD f b
b, HKD f c
c, HKD f d
d, HKD f e
e)
  xrecX :: ListToHKDTuple f '[a, b, c, d, e] -> XRec f '[a, b, c, d, e]
xrecX (a, b, c, d, e) = HKD f a
a HKD f a -> XRec f '[b, c, d, e] -> XRec f '[a, b, c, d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b -> XRec f '[c, d, e] -> XRec f '[b, c, d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f c
c HKD f c -> XRec f '[d, e] -> XRec f '[c, d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f d
d HKD f d -> XRec f '[e] -> XRec f '[d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f e
e HKD f e -> XRec f '[] -> XRec f '[e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

instance TupleXRec f '[a,b,c,d,e,z] where
  xrecTuple :: XRec f '[a, b, c, d, e, z] -> ListToHKDTuple f '[a, b, c, d, e, z]
xrecTuple (HKD f a
a ::& HKD f b
b ::& HKD f c
c ::& HKD f d
d ::& HKD f e
e ::& HKD f z
z ::& XRec f '[]
XRNil) =
    (HKD f a
a, HKD f b
b, HKD f c
c, HKD f d
d, HKD f e
e, HKD f z
z)
  xrecX :: ListToHKDTuple f '[a, b, c, d, e, z] -> XRec f '[a, b, c, d, e, z]
xrecX (a, b, c, d, e, z) = HKD f a
a HKD f a -> XRec f '[b, c, d, e, z] -> XRec f '[a, b, c, d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b -> XRec f '[c, d, e, z] -> XRec f '[b, c, d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f c
c HKD f c -> XRec f '[d, e, z] -> XRec f '[c, d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f d
d HKD f d -> XRec f '[e, z] -> XRec f '[d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f e
e HKD f e -> XRec f '[z] -> XRec f '[e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f z
z HKD f z -> XRec f '[] -> XRec f '[z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

instance TupleXRec f '[a,b,c,d,e,z,g] where
  xrecTuple :: XRec f '[a, b, c, d, e, z, g]
-> ListToHKDTuple f '[a, b, c, d, e, z, g]
xrecTuple (HKD f a
a ::& HKD f b
b ::& HKD f c
c ::& HKD f d
d ::& HKD f e
e ::& HKD f z
z ::& HKD f g
g ::& XRec f '[]
XRNil) =
    (HKD f a
a, HKD f b
b, HKD f c
c, HKD f d
d, HKD f e
e, HKD f z
z, HKD f g
g)
  xrecX :: ListToHKDTuple f '[a, b, c, d, e, z, g]
-> XRec f '[a, b, c, d, e, z, g]
xrecX (a, b, c, d, e, z, g) = HKD f a
a HKD f a
-> XRec f '[b, c, d, e, z, g] -> XRec f '[a, b, c, d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b -> XRec f '[c, d, e, z, g] -> XRec f '[b, c, d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f c
c HKD f c -> XRec f '[d, e, z, g] -> XRec f '[c, d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f d
d HKD f d -> XRec f '[e, z, g] -> XRec f '[d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f e
e HKD f e -> XRec f '[z, g] -> XRec f '[e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f z
z HKD f z -> XRec f '[g] -> XRec f '[z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f g
g HKD f g -> XRec f '[] -> XRec f '[g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

instance TupleXRec f '[a,b,c,d,e,z,g,h] where
  xrecTuple :: XRec f '[a, b, c, d, e, z, g, h]
-> ListToHKDTuple f '[a, b, c, d, e, z, g, h]
xrecTuple (HKD f a
a ::& HKD f b
b ::& HKD f c
c ::& HKD f d
d ::& HKD f e
e ::& HKD f z
z ::& HKD f g
g ::& HKD f h
h ::& XRec f '[]
XRNil) =
    (HKD f a
a, HKD f b
b, HKD f c
c, HKD f d
d, HKD f e
e, HKD f z
z, HKD f g
g, HKD f h
h)
  xrecX :: ListToHKDTuple f '[a, b, c, d, e, z, g, h]
-> XRec f '[a, b, c, d, e, z, g, h]
xrecX (a, b, c, d, e, z, g, h) = HKD f a
a HKD f a
-> XRec f '[b, c, d, e, z, g, h]
-> XRec f '[a, b, c, d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f b
b HKD f b
-> XRec f '[c, d, e, z, g, h] -> XRec f '[b, c, d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f c
c HKD f c -> XRec f '[d, e, z, g, h] -> XRec f '[c, d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f d
d HKD f d -> XRec f '[e, z, g, h] -> XRec f '[d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f e
e HKD f e -> XRec f '[z, g, h] -> XRec f '[e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f z
z HKD f z -> XRec f '[g, h] -> XRec f '[z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f g
g HKD f g -> XRec f '[h] -> XRec f '[g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& HKD f h
h HKD f h -> XRec f '[] -> XRec f '[h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
HKD f r -> XRec f rs -> XRec f (r : rs)
::& XRec f '[]
forall u (f :: u -> *). XRec f '[]
XRNil

type family ListToHKDTuple (f :: u -> *) (ts :: [u]) :: * where
  ListToHKDTuple f '[] = HKD f ()
  ListToHKDTuple f '[a,b] = (HKD f a, HKD f b)
  ListToHKDTuple f '[a,b,c] = (HKD f  a, HKD f b, HKD f c)
  ListToHKDTuple f '[a,b,c,d] = (HKD f a, HKD f b, HKD f c, HKD f d)
  ListToHKDTuple f '[a,b,c,d,e] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e)
  ListToHKDTuple f '[a,b,c,d,e,z] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z)
  ListToHKDTuple f '[a,b,c,d,e,z,g] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z, HKD f g)
  ListToHKDTuple f '[a,b,c,d,e,z,g,h] = (HKD f a, HKD f b, HKD f c, HKD f d, HKD f e, HKD f z, HKD f g, HKD f h)
  ListToHKDTuple f x = TypeError ('Text "Tuples are only supported up to size 8")

-- | Convert a 'Rec' to a tuple going through 'HKD' to reduce
-- syntactic noise. Useful for pattern matching on an entire 'Rec'.
ruple :: (IsoXRec f ts, TupleXRec f ts)
      => Rec f ts -> ListToHKDTuple f ts
ruple :: Rec f ts -> ListToHKDTuple f ts
ruple = XRec f ts -> ListToHKDTuple f ts
forall u (f :: u -> *) (t :: [u]).
TupleXRec f t =>
XRec f t -> ListToHKDTuple f t
xrecTuple (XRec f ts -> ListToHKDTuple f ts)
-> (Rec f ts -> XRec f ts) -> Rec f ts -> ListToHKDTuple f ts
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec f ts -> XRec f ts
forall u (f :: u -> *) (ts :: [u]).
IsoXRec f ts =>
Rec f ts -> XRec f ts
toXRec

-- | Build a 'Rec' from a tuple passing through 'XRec'. This admits
-- the most concise syntax for building a 'Rec'. For example, @xrec
-- ("joe", 23) :: Rec Identity '[String, Int]@.
xrec :: (IsoXRec f t, TupleXRec f t) => ListToHKDTuple f t -> Rec f t
xrec :: ListToHKDTuple f t -> Rec f t
xrec = XRec f t -> Rec f t
forall u (f :: u -> *) (ts :: [u]).
IsoXRec f ts =>
XRec f ts -> Rec f ts
fromXRec (XRec f t -> Rec f t)
-> (ListToHKDTuple f t -> XRec f t)
-> ListToHKDTuple f t
-> Rec f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ListToHKDTuple f t -> XRec f t
forall u (f :: u -> *) (t :: [u]).
TupleXRec f t =>
ListToHKDTuple f t -> XRec f t
xrecX

-- | Build a 'Rec' from a tuple. An example would be building a value
-- of type @Rec f '[a,b]@ from a tuple of values with type @'(f a, f
-- b)@.
class TupleRec f t where
  record :: t -> UncurriedRec (TupleToRecArgs f t)

instance TupleRec f () where
  record :: () -> UncurriedRec (TupleToRecArgs f ())
record () = UncurriedRec (TupleToRecArgs f ())
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b) where
  record :: (f a, f b) -> UncurriedRec (TupleToRecArgs f (f a, f b))
record (f a
a,f b
b) = f a
a f a -> Rec f '[b] -> Rec f '[a, b]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[] -> Rec f '[b]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b, f c) where
  record :: (f a, f b, f c) -> UncurriedRec (TupleToRecArgs f (f a, f b, f c))
record (f a
a,f b
b,f c
c) = f a
a f a -> Rec f '[b, c] -> Rec f '[a, b, c]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[c] -> Rec f '[b, c]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f c
c f c -> Rec f '[] -> Rec f '[c]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b, f c, f d) where
  record :: (f a, f b, f c, f d)
-> UncurriedRec (TupleToRecArgs f (f a, f b, f c, f d))
record (f a
a,f b
b,f c
c,f d
d) = f a
a f a -> Rec f '[b, c, d] -> Rec f '[a, b, c, d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[c, d] -> Rec f '[b, c, d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f c
c f c -> Rec f '[d] -> Rec f '[c, d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f d
d f d -> Rec f '[] -> Rec f '[d]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b, f c, f d, f e) where
  record :: (f a, f b, f c, f d, f e)
-> UncurriedRec (TupleToRecArgs f (f a, f b, f c, f d, f e))
record (f a
a,f b
b,f c
c,f d
d,f e
e) = f a
a f a -> Rec f '[b, c, d, e] -> Rec f '[a, b, c, d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[c, d, e] -> Rec f '[b, c, d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f c
c f c -> Rec f '[d, e] -> Rec f '[c, d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f d
d f d -> Rec f '[e] -> Rec f '[d, e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f e
e f e -> Rec f '[] -> Rec f '[e]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b, f c, f d, f e, f z) where
  record :: (f a, f b, f c, f d, f e, f z)
-> UncurriedRec (TupleToRecArgs f (f a, f b, f c, f d, f e, f z))
record (f a
a,f b
b,f c
c,f d
d,f e
e,f z
z) = f a
a f a -> Rec f '[b, c, d, e, z] -> Rec f '[a, b, c, d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[c, d, e, z] -> Rec f '[b, c, d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f c
c f c -> Rec f '[d, e, z] -> Rec f '[c, d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f d
d f d -> Rec f '[e, z] -> Rec f '[d, e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f e
e f e -> Rec f '[z] -> Rec f '[e, z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f z
z f z -> Rec f '[] -> Rec f '[z]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b, f c, f d, f e, f z, f g) where
  record :: (f a, f b, f c, f d, f e, f z, f g)
-> UncurriedRec
     (TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g))
record (f a
a,f b
b,f c
c,f d
d,f e
e,f z
z,f g
g) = f a
a f a -> Rec f '[b, c, d, e, z, g] -> Rec f '[a, b, c, d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[c, d, e, z, g] -> Rec f '[b, c, d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f c
c f c -> Rec f '[d, e, z, g] -> Rec f '[c, d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f d
d f d -> Rec f '[e, z, g] -> Rec f '[d, e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f e
e f e -> Rec f '[z, g] -> Rec f '[e, z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f z
z f z -> Rec f '[g] -> Rec f '[z, g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f g
g f g -> Rec f '[] -> Rec f '[g]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

instance TupleRec f (f a, f b, f c, f d, f e, f z, f g, f h) where
  record :: (f a, f b, f c, f d, f e, f z, f g, f h)
-> UncurriedRec
     (TupleToRecArgs f (f a, f b, f c, f d, f e, f z, f g, f h))
record (f a
a,f b
b,f c
c,f d
d,f e
e,f z
z,f g
g,f h
h) = f a
a f a
-> Rec f '[b, c, d, e, z, g, h] -> Rec f '[a, b, c, d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f b
b f b -> Rec f '[c, d, e, z, g, h] -> Rec f '[b, c, d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f c
c f c -> Rec f '[d, e, z, g, h] -> Rec f '[c, d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f d
d f d -> Rec f '[e, z, g, h] -> Rec f '[d, e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f e
e f e -> Rec f '[z, g, h] -> Rec f '[e, z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f z
z f z -> Rec f '[g, h] -> Rec f '[z, g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f g
g f g -> Rec f '[h] -> Rec f '[g, h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& f h
h f h -> Rec f '[] -> Rec f '[h]
forall a (f :: a -> *) (r :: a) (rs :: [a]).
f r -> Rec f rs -> Rec f (r : rs)
:& Rec f '[]
forall u (f :: u -> *). Rec f '[]
RNil

-- | Build a 'FieldRec' from a tuple of 'ElField' values.
fieldRec :: TupleRec ElField t => t -> UncurriedRec (TupleToRecArgs ElField t)
fieldRec :: t -> UncurriedRec (TupleToRecArgs ElField t)
fieldRec = forall t.
TupleRec ElField t =>
t -> UncurriedRec (TupleToRecArgs ElField t)
forall u (f :: u -> *) t.
TupleRec f t =>
t -> UncurriedRec (TupleToRecArgs f t)
record @ElField

-- | Build a 'FieldRec' from a tuple and 'rcast' it to another record
-- type that is a subset of the constructed record. This is useful for
-- re-ordering fields. For example, @namedArgs (#name =: "joe", #age
-- =: 23)@ can supply arguments for a function expecting a record of
-- arguments with its fields in the opposite order.
namedArgs :: (TupleRec ElField t,
              ss ~ Snd (TupleToRecArgs ElField t),
              RecSubset Rec rs (Snd (TupleToRecArgs ElField t)) (RImage rs ss),
              UncurriedRec (TupleToRecArgs ElField t) ~ Rec ElField ss,
              RecSubsetFCtx Rec ElField)
          => t -> Rec ElField rs
namedArgs :: t -> Rec ElField rs
namedArgs = Rec ElField ss -> Rec ElField rs
forall k1 k2 (rs :: [k1]) (ss :: [k1]) (f :: k2 -> *)
       (record :: (k2 -> *) -> [k1] -> *) (is :: [Nat]).
(RecSubset record rs ss is, RecSubsetFCtx record f) =>
record f ss -> record f rs
rcast (Rec ElField ss -> Rec ElField rs)
-> (t -> Rec ElField ss) -> t -> Rec ElField rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Rec ElField ss
forall t.
TupleRec ElField t =>
t -> UncurriedRec (TupleToRecArgs ElField t)
fieldRec

-- | Override a record with fields from a possibly narrower record. A
-- typical use is to supply default values as the first argument, and
-- overrides for those defaults as the second.
withDefaults :: (RMap rs, RApply rs, ss ⊆ rs, RMap ss, RecApplicative rs)
             => Rec f rs -> Rec f ss -> Rec f rs
withDefaults :: Rec f rs -> Rec f ss -> Rec f rs
withDefaults Rec f rs
defs = Maybe (Rec f rs) -> Rec f rs
forall b. Maybe b -> b
fin (Maybe (Rec f rs) -> Rec f rs)
-> (Rec f ss -> Maybe (Rec f rs)) -> Rec f ss -> Rec f rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall (x :: u). Compose Maybe f x -> Maybe (f x))
-> Rec (Compose Maybe f) rs -> Maybe (Rec f rs)
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 (x :: u). Compose Maybe f x -> Maybe (f x)
forall l (f :: l -> *) k (g :: k -> l) (x :: k).
Compose f g x -> f (g x)
getCompose (Rec (Compose Maybe f) rs -> Maybe (Rec f rs))
-> (Rec f ss -> Rec (Compose Maybe f) rs)
-> Rec f ss
-> Maybe (Rec f rs)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rec (Compose Maybe f) rs
 -> Rec (Compose Maybe f) rs -> Rec (Compose Maybe f) rs)
-> Rec (Compose Maybe f) rs
-> Rec (Compose Maybe f) rs
-> Rec (Compose Maybe f) rs
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rec (Compose Maybe f) rs
-> Rec (Compose Maybe f) rs -> Rec (Compose Maybe f) rs
forall (k2 :: u -> *).
Rec (Compose Maybe k2) rs
-> Rec (Compose Maybe k2) rs -> Rec (Compose Maybe k2) rs
rfirst Rec (Compose Maybe f) rs
defs' (Rec (Compose Maybe f) rs -> Rec (Compose Maybe f) rs)
-> (Rec f ss -> Rec (Compose Maybe f) rs)
-> Rec f ss
-> Rec (Compose Maybe f) rs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec f ss -> Rec (Compose Maybe f) rs
forall u (ss :: [u]) (rs :: [u]) (f :: u -> *).
(RecApplicative ss, RMap rs, rs ⊆ ss) =>
Rec f rs -> Rec (Maybe :. f) ss
rdowncast
  where fin :: Maybe b -> b
fin = b -> (b -> b) -> Maybe b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> b
forall a. HasCallStack => [Char] -> a
error [Char]
"Impossible: withDefaults failed") b -> b
forall a. a -> a
id
        defs' :: Rec (Compose Maybe f) rs
defs' = (forall (x :: u). f x -> Compose Maybe f x)
-> Rec f rs -> Rec (Compose Maybe f) rs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
rmap (Maybe (f x) -> Compose Maybe f x
forall l k (f :: l -> *) (g :: k -> l) (x :: k).
f (g x) -> Compose f g x
Compose (Maybe (f x) -> Compose Maybe f x)
-> (f x -> Maybe (f x)) -> f x -> Compose Maybe f x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> Maybe (f x)
forall a. a -> Maybe a
Just) Rec f rs
defs
        rfirst :: Rec (Compose Maybe k2) rs
-> Rec (Compose Maybe k2) rs -> Rec (Compose Maybe k2) rs
rfirst = (forall (a :: u).
 Compose First k2 a -> Compose First k2 a -> Compose First k2 a)
-> (forall (a :: u). Compose Maybe k2 a -> Compose First k2 a)
-> (forall (a :: u). Compose First k2 a -> Compose Maybe k2 a)
-> Rec (Compose Maybe k2) rs
-> Rec (Compose Maybe k2) rs
-> Rec (Compose Maybe k2) rs
forall u (rs :: [u]) (m :: u -> *) (f :: u -> *) (g :: u -> *).
(RMap rs, RApply rs) =>
(forall (a :: u). m a -> m a -> m a)
-> (forall (a :: u). f a -> m a)
-> (forall (a :: u). m a -> g a)
-> Rec f rs
-> Rec f rs
-> Rec g rs
rcombine forall (a :: u).
Compose First k2 a -> Compose First k2 a -> Compose First k2 a
forall a. Semigroup a => a -> a -> a
(<>) ((Maybe (k2 a) -> First (k2 a))
-> (:.) Maybe k2 a -> (:.) First k2 a
forall l1 k1 l2 (f :: l1 -> *) (g :: k1 -> l1) (a :: k1)
       (h :: l2 -> *) (k2 :: k1 -> l2).
(f (g a) -> h (k2 a)) -> (:.) f g a -> (:.) h k2 a
onCompose Maybe (k2 a) -> First (k2 a)
forall a. Maybe a -> First a
First) ((First (k2 a) -> Maybe (k2 a))
-> (:.) First k2 a -> (:.) Maybe k2 a
forall l1 k1 l2 (f :: l1 -> *) (g :: k1 -> l1) (a :: k1)
       (h :: l2 -> *) (k2 :: k1 -> l2).
(f (g a) -> h (k2 a)) -> (:.) f g a -> (:.) h k2 a
onCompose First (k2 a) -> Maybe (k2 a)
forall a. First a -> Maybe a
getFirst)