content: {-# 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)
  