Zipping records with mismatched keys.

ZipDisjointRecord.purs

module Main (main, zip, zipRecord, class ZipRowList) where

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Data.Record (get, insert)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.These (These(..))
import Global.Unsafe (unsafeStringify)
import Prelude (Unit, discard)
import Type.Row
  ( class RowLacks
  , class RowToList
  , Cons, Nil
  , RLProxy(..)
  , kind RowList
  )

-- | SO, yesterday, we looked at "zipping" records by creating tuples
-- | from the values on both sides. There was one arbitrary constraint
-- | that we didn't discuss, though: the keys in the records must be
-- | the same! This isn't always what we want, so let's try to do
-- | better. We'll repeat the same experiment, but, this time, we will
-- | use `Data.These` to express the pairings of values.

-- | Most of this is the same, so I won't write any comments on the
-- | old stuff. This should help to see the "diff" of the two ideas,
-- | and help show what I've actually updated :D

zip :: forall xs ys zs lxs lys lzs.
       RowToList xs lxs
    => RowToList ys lys
    => RowToList zs lzs
    => ZipRowList lxs lys xs ys zs
    => Record xs -> Record ys -> Record zs
zip = zipRecord (RLProxy :: RLProxy lxs)
                (RLProxy :: RLProxy lys)

class ZipRowList
  ( la :: RowList)
  ( lb :: RowList)
  ( ra :: # Type )
  ( rb :: # Type )
  (rab :: # Type )
  | la    -> ra
  ,    lb -> rb
  , la lb -> rab
  where
    zipRecord :: RLProxy la
              -> RLProxy lb
              -> Record ra
              -> Record rb
              -> Record rab

-- | The name of this has changed from `zipRowListNonEmpty`. Why? We
-- | have two cases that we'll see later who would both match any
-- | valid match for this class. So, we want to check this _first_.
-- | How? We put it first in the alphabet! Can anyone else just _not
-- | wait_ for instance chains? Anyway, the only update beyond that
-- | here is the use of `These`, so there's not much to see here. If
-- | you're not familiar with `These`, it's like an `Either` that
-- | could also store both items. `This`, `That`, or `Both`.

instance zipRowListEverything
    :: ( IsSymbol k
       , RowCons k a x ra
       , RowCons k b y rb
       , RowCons k (These a b) rabt rab
       , RowLacks k rabt
       , ZipRowList ta tb ra rb rabt
       )
    => ZipRowList (Cons k a ta) (Cons k b tb) ra rb rab
  where
    zipRecord :: RLProxy (Cons k a ta)
              -> RLProxy (Cons k b tb)
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      = let
          name = SProxy :: SProxy k
          head = Both (get name xs) (get name ys)
          tail = zipRecord (RLProxy :: RLProxy ta)
                           (RLProxy :: RLProxy tb)
                           xs ys

        in insert name head tail

instance zipRowListEmpty :: ZipRowList Nil Nil ra rb ()
  where zipRecord _ _ _ _ = {}

-- | OK, here's the new and exciting bit. With the above, we can only
-- | deal with objects that are both empty OR both have the same keys.
-- | If we want to be able to deal with more cases, we just need to
-- | add some new instances! In our particular case, we have two new
-- | things to consider: a key appears on the left but not the right,
-- | and vice versa.

instance zipRowListLeftCons
  :: ( -- Guess what: we still need k to be a symbol...
       IsSymbol k

       -- Aaaand it still needs to be a key in `ra`...
     , RowCons k a x ra

       -- BUT it can't appear in `rb`! New and shiny!
     , RowLacks k rb

       -- So, our new head type uses Unit instead of b. Here's where we
       -- define how we'll actually _deal_ with this problem, rather
       -- than panicking our beloved compiler.
     , RowCons k (These a b) rabt rab

       -- For the sake of `insert`, we have to say, *explicitly*, that
       -- this tail definitely doesn't contain a `k`. It can't, because
       -- we're adding it in here, but we still have to be explicit!
     , RowLacks k rabt

       -- Finally, we check the tail. The difference here is that we
       -- don't touch the right-hand (`lb`) list at all - we know it
       -- didn't have a `k` entry, so there's nothing to delete!
     , ZipRowList ta lb ra rb rabt
     )
  => ZipRowList (Cons k a ta) lb ra rb rab
  where

    -- So, just as we did above, we carry our proxies (remember, only
    -- the left one loses its head!)
    zipRecord :: RLProxy (Cons k a ta)
              -> RLProxy lb
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      =
        let
          name = SProxy :: SProxy k

          -- We're wrapping up the "left" value here.
          head = This (get name xs)
          tail = zipRecord (RLProxy :: RLProxy ta)
                           (RLProxy :: RLProxy lb)
                           xs ys

        in insert name head tail

-- | Work through this one, and make sure it all makes sense. It's
-- | really exactly the same as `zipRowListLeftCons`, but with the
-- | relevant bits swapped around. Remember, if you ever have any
-- | issues with this stuff, find me on Twitter at @am_i_tom!
instance zipRowListRightCons
    :: ( IsSymbol k
       , RowLacks k ra
       , RowCons k b x rb
       , RowCons k (These a b) rabt rab
       , RowLacks k rabt
       , ZipRowList la tb ra rb rabt
       )
    => ZipRowList la (Cons k b tb) ra rb rab
  where
    zipRecord :: RLProxy la
              -> RLProxy (Cons k b tb)
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      =
        let
          name = SProxy :: SProxy k

          head = That (get name ys)
          tail = zipRecord (RLProxy :: RLProxy la)
                           (RLProxy :: RLProxy tb)
                           xs ys

        in insert name head tail

-- | WELL, now we're past all that, let's have a show-and-tell! As per
-- | usual, we'll just dump out the values. That's all, folks!
main :: Eff (console :: CONSOLE) Unit
main
  = do
    -- {}
    log (unsafeStringify (zip {} {}))

    -- { a: This 5, b: That "Hello" }
    log (unsafeStringify (zip { a: 5, b: 3.5 } { b: "Hello", c: 10.5 }))

    -- { a: This false, b: These "test" 4, c: That 3.5 }
    log (unsafeStringify (zip { a: false, b: "test" } { b: 4, c: 3.5 }))

ZipDisjointRecordsWithoutComments.purs

module Main (zip, zipRecord, class ZipRowList) where

import Data.Record (get, insert)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.These (These(..))
import Type.Row
  ( class RowLacks
  , class RowToList
  , Cons, Nil
  , RLProxy(..)
  , kind RowList
  )

zip :: forall xs ys zs lxs lys lzs.
       RowToList xs lxs
    => RowToList ys lys
    => RowToList zs lzs
    => ZipRowList lxs lys xs ys zs
    => Record xs -> Record ys -> Record zs
zip = zipRecord (RLProxy :: RLProxy lxs)
                (RLProxy :: RLProxy lys)

class ZipRowList
  ( la :: RowList)
  ( lb :: RowList)
  ( ra :: # Type )
  ( rb :: # Type )
  (rab :: # Type )
  | la    -> ra
  ,    lb -> rb
  , la lb -> rab
  where
    zipRecord :: RLProxy la
              -> RLProxy lb
              -> Record ra
              -> Record rb
              -> Record rab

instance zipRowListEverything
    :: ( IsSymbol k
       , RowCons k a x ra
       , RowCons k b y rb
       , RowCons k (These a b) rabt rab
       , RowLacks k rabt
       , ZipRowList ta tb ra rb rabt
       )
    => ZipRowList (Cons k a ta) (Cons k b tb) ra rb rab
  where
    zipRecord :: RLProxy (Cons k a ta)
              -> RLProxy (Cons k b tb)
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      = let
          name = SProxy :: SProxy k
          head = Both (get name xs) (get name ys)
          tail = zipRecord (RLProxy :: RLProxy ta)
                           (RLProxy :: RLProxy tb)
                           xs ys

        in insert name head tail

instance zipRowListEmpty :: ZipRowList Nil Nil ra rb ()
  where zipRecord _ _ _ _ = {}

instance zipRowListLeftCons
  :: ( IsSymbol k
     , RowCons k a x ra
     , RowLacks k rb
     , RowCons k (These a b) rabt rab
     , RowLacks k rabt
     , ZipRowList ta lb ra rb rabt
     )
  => ZipRowList (Cons k a ta) lb ra rb rab
  where
    zipRecord :: RLProxy (Cons k a ta)
              -> RLProxy lb
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      =
        let
          name = SProxy :: SProxy k
          head = This (get name xs)
          tail = zipRecord (RLProxy :: RLProxy ta)
                           (RLProxy :: RLProxy lb)
                           xs ys

        in insert name head tail

instance zipRowListRightCons
    :: ( IsSymbol k
       , RowLacks k ra
       , RowCons k b x rb
       , RowCons k (These a b) rabt rab
       , RowLacks k rabt
       , ZipRowList la tb ra rb rabt
       )
    => ZipRowList la (Cons k b tb) ra rb rab
  where
    zipRecord :: RLProxy la
              -> RLProxy (Cons k b tb)
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      =
        let
          name = SProxy :: SProxy k

          head = That (get name ys)
          tail = zipRecord (RLProxy :: RLProxy la)
                           (RLProxy :: RLProxy tb)
                           xs ys

        in insert name head tail