ZipRecord for PureScript. More notes from RowToList studies.

ZipRecord.purs

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

-- | After Tuesday's experiments, let's move onto a slightly more
-- | interesting example. Last time, I confess, I cheated a bit to
-- | avoid getting too deep into RowToList stuff. Today, I'm not
-- | going to cheat, and get riiiight into it. When we're thirty lines
-- | in, don't say you weren't warned!

import Prelude (($), discard, Unit)
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.Tuple (Tuple(..))
import Global.Unsafe (unsafeStringify)
import Type.Row
  ( class RowLacks
  , class RowToList
  , Cons, Nil
  , RLProxy(..)
  , kind RowList
  )

-- | Today's horrible challenge is this: if we have two records with
-- | the same keys, can we "zip" them into a single record with tuples
-- | at each key, holding the values from each record? Spoiler: if
-- | you're reading this, we probably can.

-- | Here's a clever little helper function. Why do we need this? We
-- | really just want to hide away the ugly RLProxy stuff from the
-- | user so they a) don't have to see it, and b) they can't get it
-- | wrong. If I get it wrong _and_ they get it wrong, well, we'll get
-- | nowhere...

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)

-- | OKAY friends, here's the meat. Just like last time, we'll throw
-- | together a big ol' class to outline our intentions. It's going to
-- | be a bit trickier this time, though!

class ZipRowList
  ( la :: RowList) -- The "list" version of `ra`.
  ( lb :: RowList) -- The "list" version of `rb`.
  ( ra :: # Type ) -- The row type of record A.
  ( rb :: # Type ) -- The row type of record B.
  (rab :: # Type ) -- The row type of the combined records!
  | la    -> ra -- If we know the list version, we can definitely...
  ,    lb -> rb -- ... work out the type of the record's row type!
  , la lb -> rab -- With _both_ lists, we can get the output type!
  where
    zipRecord :: RLProxy la
              -> RLProxy lb
              -> Record ra
              -> Record rb
              -> Record rab

-- | So, we'll flesh out the above a lot more when we come to the cons
-- | bit. For now, though, I'm sure you're used to `Nil` being the one
-- | with much less code attached. This instance will only match when
-- | we've exhausted the keys in the records, so... we're done!

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

-- | So, here's what we need to do. We need to pick a key in our row,
-- | check it exists in both, tuple its values together, then recurse.
-- | To do that, we're going to have to use a tonne of constraints!

instance zipRowListNonEmpty
    :: ( -- This is our type-level "key name". At the type level, we
         -- call strings "symbols"!
         IsSymbol k

         -- We can look at our `ra` row as being a row with an `a`
         -- type at key `k`, as well as "the rest". We don't really
         -- care about that this time, so we'll just call it x.
       , RowCons k a x ra

         -- Similarly to above, the type at `k` will be called `b`,
         -- and "the rest" of the record is unimportant, so we'll call
         -- it `y`. You can't just use underscores at the moment, so
         -- consider these names to mean "No one cares"!
       , RowCons k b y rb

         -- In our answer, the type of the value at `k` will be a
         -- tuple of `a` and `b`. We'll call the rest of our answer
         -- `rabt`, meaning, "RAB's Tail". Naming things is hard.
       , RowCons k (Tuple a b) rabt rab

         -- We need to tell the compiler that `rabt` won't contain a
         -- `k` field because the compiler needs to know that, at each
         -- point, it is making progress towards a solution to the
         -- type. It seems obvious to us, but be kind to the compiler!
       , RowLacks k rabt

         -- Having taken away the head of `rab`, the rest of the row
         -- should (recursively) pass all these checks above. If they
         -- do, then we can celebrate - we've won!
       , ZipRowList ta tb ra rb rabt
       )
    => ZipRowList (Cons k a ta) (Cons k b tb) ra rb rab
  where
    -- | Remember that the `RLProxy` values are really just here so we
    -- | can pass around their "types" - at value-level, we always
    -- | ignore them! Such a shame, right?
    zipRecord :: RLProxy (Cons k a ta)
              -> RLProxy (Cons k b tb)

              -- This is the real winner... the actual function!
              -> Record ra -> Record rb -> Record rab
    zipRecord _ _ xs ys
      = let
          -- We can now get the name of the "first key" (at the type
          -- level) by casting SProxy's phantom type to `k`. This is
          -- what gets used in `Data.Record` for the `get` and
          -- `insert` functions.
          name = SProxy :: SProxy k

          -- We can now use this key to get the values in the rows. We
          -- then just shove them in a Tuple. See? It's all much less
          -- scary when you get down to this bit!
          head = Tuple (get name xs) (get name ys)

          -- What's the tail? We simply take the `k` field out of the
          -- row types and do the same checks again! Neat, right?
          tail = zipRecord (RLProxy :: RLProxy ta)
                           (RLProxy :: RLProxy tb)
                           xs ys

        -- All that for this one line...
        in insert name head tail

main :: Eff (console :: CONSOLE) Unit
main = do
  log $ unsafeStringify $ zip {} {} :: {}
  log $ unsafeStringify $ zip { a: 1 } { a: 2 }
  log $ unsafeStringify $ zip { a: 1, b: 't' } { a: "s", b: 7.5 }

  -- Compile-time error: keys are different!
  -- log $ unsafeStringify $ zip { a: 2 } { b: "hello" }

ZipRecordWithoutComments.purs

module Main (zip, zipRecord, class ZipRowList) where

import Data.Record (get, insert)
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..))
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 zipRowListEmpty :: ZipRowList Nil Nil ra rb ()
  where
    zipRecord _ _ _ _  = {}

instance zipRowListNonEmpty
    :: ( IsSymbol k
       , RowCons k a x ra
       , RowCons k b y rb
       , RowCons k (Tuple 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 = Tuple (get name xs) (get name ys)
          tail = zipRecord (RLProxy :: RLProxy ta)
                           (RLProxy :: RLProxy tb)
                           xs ys

        in insert name head tail