PureScript: pick subrecords from a record.

Main.purs

module Main where

import Prelude
import Data.Foldable (fold, elem)
import TryPureScript
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Type.Proxy (Proxy(..))
import Type.Data.Symbol (class IsSymbol, reflectSymbol)
import Data.Array (cons)
import Data.Monoid (mempty)
import Data.Symbol (SProxy(..))
import Data.StrMap (StrMap, fold, insert) as StrMap
import Unsafe.Coerce (unsafeCoerce)

class SubRow (r :: # Type) (s :: # Type)
instance subrow :: Union r t s => SubRow  r s

class GetKeys (l :: RowList) where
  keys
    :: forall r
     . RowToList r l
    => ListToRow l r
    => Proxy (Record r)
    -> Array String

instance getKeysNil :: GetKeys Nil where
  keys _ = []

instance getKeysCons
  :: ( IsSymbol name
     , GetKeys tail
     , ListToRow tail row
     , RowToList row tail
     )
  => GetKeys (Cons name ty tail) where
  keys _ = cons (reflectSymbol (SProxy :: SProxy name)) (keys (Proxy :: Proxy (Record row)))

pick
  :: forall r s l
   . SubRow r s
  => RowToList r l
  => ListToRow l r
  => GetKeys l
  => Proxy (Record r)
  -> Record s
  -> Record r
pick p s = unsafeCoerce (StrMap.fold fmap) (mempty :: StrMap.StrMap Unit) m
  where
    ks :: Array String
    ks = keys p

    m :: StrMap.StrMap Unit
    m = unsafeCoerce s

    fmap d name val =
      if name `elem` ks
        then StrMap.insert name val d
        else d

r = {a: 0, b: 'a', c: "" }

s :: { a :: Int, b :: Char}
s = pick (Proxy :: Proxy {a :: Int, b :: Char}) r

main =
    render $ fold
      [ h1 (text "Subrecords using RowList")
      , p (code $ text """
pick (Proxy :: Proxy {a :: Int, b :: Char}) {a: 0, b: 'a', c: ""} == {a: 0, b: 'a'}
      
""")
      ]