A record append operation that smushes together duplicate fields using a monoid instance

SquishyAppend.purs

module SquishyAppend where

import Prelude

import Data.Functor.Variant (SProxy(..))
import Data.Monoid (class Monoid, class Semigroup, mempty, (<>))
import Data.Tuple (Tuple(..))
import Prim.RowList (Cons, Nil, kind RowList)
import Record as Record
import Type.Data.Boolean (True, False, kind Boolean)
import Type.Data.Symbol (class Equals)
import Type.Prelude (class ListToRow, class RowToList)
import Type.Row as Row
import Unsafe.Coerce (unsafeCoerce)

class Lacks (k :: Symbol) (r :: RowList) (b :: Boolean) | k r -> b

instance lacksNil ::
  Lacks k Nil True

class LacksCase (b :: Boolean) (k :: Symbol) (l :: Symbol) (v :: Type) (r :: RowList) (o :: Boolean) | b k l v r -> o

instance lacksCase1 ::
  LacksCase True k l v r False

instance lacksCase2 ::
  Lacks k r b =>
  LacksCase False k l v r b

instance lacksCons ::
  (Equals k l b, LacksCase b k l v r o) =>
  Lacks k (Cons l v r) o

class Values (k :: Symbol) (r :: RowList) (s :: RowList) | k r -> s

instance valuesNil ::
  Values k Nil Nil

class ValuesCase (b :: Boolean) (k :: Symbol) (l :: Symbol) (v :: Type) (r :: RowList) (s :: RowList) | b k l v r -> s

instance valuesCase1 ::
  Values k r s =>
  ValuesCase False k l v r s

instance valuesCase2 ::
  Values k r s =>
  ValuesCase True k l v r (Cons l v s)

instance valuesCons ::
  (Equals k l b, ValuesCase b k l v r s) =>
  Values k (Cons l v r) s

values ::
  forall k r s r' s'.
  RowToList r r' =>
  Values k r' s' =>
  ListToRow s' s =>
  SProxy k -> { | r } -> { | s }
values = unsafeCoerce

get ::
  forall k r v r'.
  RowToList r r' =>
  Values k r' (Cons k v Nil) =>
  SProxy k -> { | r } -> v
get = unsafeCoerce

a :: String
a = get (SProxy :: _ "bar") { foo: 1, bar: "test", baz: "xyz" }

class Remove (k :: Symbol) (r :: RowList) (s :: RowList) | k r -> s

instance removeNil ::
  Remove k Nil Nil

class RemoveCase (b :: Boolean) (k :: Symbol) (l :: Symbol) (v :: Type) (r :: RowList) (s :: RowList) | b l k v r -> s

instance removeCase1 ::
  Remove k r s =>
  RemoveCase False k l v r (Cons l v s)

instance removeCase2 ::
  Remove k r s =>
  RemoveCase True k l v r s

instance removeCons ::
  (Equals k l b, RemoveCase b k l v r s) =>
  Remove k (Cons l v r) s

remove ::
  forall k r s r' s'.
  RowToList r r' =>
  Remove k r' s' =>
  ListToRow s' s =>
  SProxy k -> { | r } -> { | s }
remove = unsafeCoerce

b :: { baz :: Int }
b = remove (SProxy :: _ "foo") { foo: "bar", baz: 1 }

class Homogeneous (v :: Type) (vs :: RowList)

instance homogeneousNil ::
  Homogeneous v Nil

instance homogeneousCons ::
  Homogeneous v r =>
  Homogeneous v (Cons k v r)

toArray ::
  forall r v r'.
  RowToList r r' =>
  Homogeneous v r' =>
  { | r } -> Array v
toArray = unsafeCoerce

c :: Array Int
c = toArray { foo: 1, bar: 2, baz: 3 }

class Append (r :: RowList) (s :: RowList) (t :: RowList) | r s -> t

instance appendNil ::
  Append Nil r r

class AppendCase (b :: Boolean) (k :: Symbol) (v :: Type) (r :: RowList) (s :: RowList) (t :: RowList) | b k v r s -> t

instance appendCase1 ::
  Append r s t =>
  AppendCase True k v r s (Cons k v t)

instance appendCase2 ::
  ( Monoid v
  , Values k r vr
  , Values k s vs
  , Homogeneous v vr
  , Homogeneous v vs
  , Remove k r r'
  , Remove k s s'
  , Append r' s' t
  ) =>
  AppendCase False k v r s (Cons k v t)

instance appendCons ::
  (Lacks k s b, AppendCase b k v r s t) =>
  Append (Cons k v r) s t

append ::
  forall r s t r' s' t'.
  RowToList r r' =>
  RowToList s s' =>
  Append r' s' t' =>
  ListToRow t' t =>
  { | r } -> { | s } -> { | t }
append = unsafeCoerce

d :: { foo :: String, bar :: Int }
d = append { foo: "Hello" } { bar: 1, foo: ", World" }

e ::
  forall t' s' t s b.
  RowToList s s' =>
  Lacks "bar" s' b =>
  AppendCase b "bar" String (Cons "foo" String Nil) s' t' =>
  ListToRow t' t =>
  Record s -> Record t
e = append { foo: "foo", bar: "bar" }

-- @monoidmusician's suggestion
-- This almost works, but unfortunately it demands `Monoid Int` when trying to `appendOverlap { foo: "Hello" } { bar: 1, foo: ", World" }`
-- appendOverlap ::
--   forall a b ab c ca cb.
--   Row.Union a b ab     => -- union fields
--   Row.Nub ab c         => -- remove duplicates/overlap
--   Row.Union a ca c     => -- calculate fields missing from a (note that it must have no duplicates)
--   Row.Union b cb c     => -- calculate fields missing from b (note that it must have no duplicates)
--   Monoid (Record ca)   => -- fill with mempties
--   Monoid (Record cb)   => -- fill with mempties
--   Semigroup (Record c) => -- append all fields together
--   Record a -> Record b -> Record c
-- appendOverlap a b =
--   let
--     ac = Record.union a (mempty :: Record ca) :: Record c
--     bc = Record.union b (mempty :: Record cb) :: Record c
--   in ac <> bc

-- @monoidmusician suggestion number 2
-- split :: forall first second both. Row.Union second first both => Row.Nub both both => Record both -> Tuple (Record first) (Record second)
-- split = Tuple <$> unsafeCoerce <*> unsafeCoerce -- YOLO
--
-- appendOverlapPt2 ::
--   forall left leftUniq right rightUniq both nubbed duped.
--     Row.Nub left left =>
--     Row.Nub right right =>
--     Row.Union left right both =>
--     Row.Nub both nubbed =>
--     Row.Nub nubbed nubbed => -- TODO: Can this be inferred? it's redundant
--     Row.Union duped nubbed both =>
--     Row.Union duped leftUniq left =>
--     Row.Union duped rightUniq right =>
--     Row.Union left rightUniq nubbed =>
--     Semigroup (Record duped) =>
--   Record left -> Record right -> Record nubbed
-- appendOverlapPt2 left right =
--   let
--     Tuple (leftUniq :: Record leftUniq) dupedL = split left
--     Tuple (rightUniq :: Record rightUniq) dupedR = split right
--     duped = (dupedL <> dupedR) :: Record duped
--     (merge1 :: Record left) = Record.disjointUnion duped leftUniq
--     (merge2 :: Record nubbed) = Record.disjointUnion merge1 rightUniq
--   in merge2
--
-- test :: { foo :: Int, bar :: String }
-- test = { foo: 1, bar: "Hello" } `appendOverlapPt2` { bar: ", World" }