FromTuple.hs

{-# 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.Kind (Type)
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 -> Type, [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 -> Type, [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 -> Type, [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 (a ::& b ::& XRNil) = (a, b)
  xrecX (a, b) = a ::& b ::& XRNil

instance TupleXRec f '[a,b,c] where
  xrecTuple (a ::& b ::& c ::& XRNil) = (a, b, c)
  xrecX (a, b, c) = a ::& b ::& c ::& XRNil

instance TupleXRec f '[a,b,c,d] where
  xrecTuple (a ::& b ::& c ::& d ::& XRNil) = (a, b, c, d)
  xrecX (a, b, c, d) = a ::& b ::& c ::& d ::& XRNil

instance TupleXRec f '[a,b,c,d,e] where
  xrecTuple (a ::& b ::& c ::& d ::& e ::& XRNil) =
    (a, b, c, d, e)
  xrecX (a, b, c, d, e) = a ::& b ::& c ::& d ::& e ::& XRNil

instance TupleXRec f '[a,b,c,d,e,z] where
  xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& XRNil) =
    (a, b, c, d, e, z)
  xrecX (a, b, c, d, e, z) = a ::& b ::& c ::& d ::& e ::& z ::& XRNil

instance TupleXRec f '[a,b,c,d,e,z,g] where
  xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& g ::& XRNil) =
    (a, b, c, d, e, z, g)
  xrecX (a, b, c, d, e, z, g) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& XRNil

instance TupleXRec f '[a,b,c,d,e,z,g,h] where
  xrecTuple (a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil) =
    (a, b, c, d, e, z, g, h)
  xrecX (a, b, c, d, e, z, g, h) = a ::& b ::& c ::& d ::& e ::& z ::& g ::& h ::& XRNil

type family ListToHKDTuple (f :: u -> Type) (ts :: [u]) :: Type 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 = xrecTuple . 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 = fromXRec . 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 () = RNil

instance TupleRec f (f a, f b) where
  record (a,b) = a :& b :& RNil

instance TupleRec f (f a, f b, f c) where
  record (a,b,c) = a :& b :& c :& RNil

instance TupleRec f (f a, f b, f c, f d) where
  record (a,b,c,d) = a :& b :& c :& d :& RNil

instance TupleRec f (f a, f b, f c, f d, f e) where
  record (a,b,c,d,e) = a :& b :& c :& d :& e :& RNil

instance TupleRec f (f a, f b, f c, f d, f e, f z) where
  record (a,b,c,d,e,z) = a :& b :& c :& d :& e :& z :& RNil

instance TupleRec f (f a, f b, f c, f d, f e, f z, f g) where
  record (a,b,c,d,e,z,g) = a :& b :& c :& d :& e :& z :& g :& RNil

instance TupleRec f (f a, f b, f c, f d, f e, f z, f g, f h) where
  record (a,b,c,d,e,z,g,h) = a :& b :& c :& d :& e :& z :& g :& h :& RNil

-- | Build a 'FieldRec' from a tuple of 'ElField' values.
fieldRec :: TupleRec ElField t => t -> UncurriedRec (TupleToRecArgs ElField t)
fieldRec = 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 = rcast . 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 defs = fin . rtraverse getCompose . flip rfirst defs' . rdowncast
  where fin = maybe (error "Impossible: withDefaults failed") id
        defs' = rmap (Compose . Just) defs
        rfirst = rcombine (<>) (onCompose First) (onCompose getFirst)