[Haskell-cafe] How can I generalize my innerJoinOnId function to innerJoin with Vinyl?

[Cody Goodman]

Hello all! I'll get right to it.

As a first step I'd like to generalize innerJoinOnId's type signature to something like:

innerJoinOnId :: (Id ∈ fields, Id ∈ fields2, Id ∈ fields2) => [Rec Attr fields] -> [Rec Attr fields2] -> [Rec Attr fields3]

Or if possible:

innerJoinOnId :: (Id ∈ fields) => [Rec Attr fields] -> [Rec Attr fields] -> [Rec Attr fields]

As a next step I'd like to create an innerJoin function with type:

innerJoinOn :: (a ∈ fields) => [Rec Attr fields] -> [Rec Attr fields] -> [Rec Attr fields]

Where a is supplied and that constraint is carried on to the other inputs. Is this possible in Haskell?

Here is both a link and the text of my (working, compilable) code thus far.

Link: https://github.com/codygman/vinyl-experiments/blob/master/src/Main.hs

Source code:

{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction, GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-}

module Main where

import Data.Vinyl
import Control.Lens hiding (Identity)
import Data.Singletons.TH
import Data.Maybe
import Control.Monad
import Data.Vinyl.TypeLevel (RIndex)

data Fields = Id | Name | Age | ActivityName deriving Show

type Person = ['Id, 'Name, 'Age]
type Activity = ['Id, 'ActivityName]

type family ElF (f :: Fields) :: * where
  ElF 'Id = Int
  ElF 'Name = String
  ElF 'Age = Int
  ElF 'ActivityName = String

newtype Attr f = Attr { _unAttr :: ElF f }
makeLenses ''Attr
genSingletons [ ''Fields ]
instance Show (Attr 'Id) where show (Attr x) = "id: " ++ show x
instance Show (Attr 'Name) where show (Attr x) = "name: " ++ show x
instance Show (Attr 'Age) where show (Attr x) = "age: " ++ show x
instance Show (Attr 'ActivityName) where show (Attr x) = "activity: " ++ x

(=::) :: sing f -> ElF f -> Attr f
_ =:: x = Attr x

joy :: Rec Attr ['Id, 'Name, 'Age]
joy = (SId =:: 1)
   :& (SName =:: "Joy")
   :& (SAge =:: 28)
   :& RNil
jon :: Rec Attr ['Id, 'Name, 'Age]
jon = (SId =:: 0)
   :& (SName =:: "Jon")
   :& (SAge =:: 23)
   :& RNil

karen :: Rec Attr ['Id, 'Name, 'Age]
karen = (SId =:: 2)
   :& (SName =:: "Karen")
   :& (SAge =:: 15)
   :& RNil

jonFootball :: Rec Attr ['Id, 'ActivityName]
jonFootball = (SId =:: 0)
           :& (SActivityName =:: "football")
           :& RNil

jonDancing :: Rec Attr ['Id, 'ActivityName]
jonDancing = (SId =:: 0)
           :& (SActivityName =:: "dancing")
           :& RNil

joyRacing :: Rec Attr ['Id, 'ActivityName]
joyRacing = (SId =:: 1)
           :& (SActivityName =:: "racing")
           :& RNil

peopleRows :: [Rec Attr ['Id, 'Name, 'Age]]
peopleRows = [joy, jon, karen]

activitieRows :: [Rec Attr ['Id, 'ActivityName]]
activitieRows = [jonFootball, jonDancing, joyRacing]

printActvy :: ('ActivityName ∈ fields) => Rec Attr fields -> IO ()
printActvy r = print (r ^. rlens SActivityName)

isInPplIdx :: ('Id ∈ fields) => [Int] -> Rec Attr fields -> Bool
isInPplIdx peopleIdx actvyRow =  any (== True) . map (== actvyIdInt) $ peopleIdx
  where actvyIdInt = actvyRow ^. rlens SId . unAttr


mkJoinedRow :: (Eq (ElF r1),
                                RElem
                                  r1
                                  ['Id, 'Name, 'Age]
                                  (RIndex r1 ['Id, 'Name, 'Age]),
                                RElem
                                  r1
                                  ['Id, 'ActivityName]
                                  (RIndex r1 ['Id, 'ActivityName]),
                                ElF r1 ~ Int) => sing1 r1 -> [Rec Attr ['Id, 'ActivityName]] -> Rec Attr ['Id, 'Name, 'Age] ->  [Rec Attr ['Id, 'Name, 'Age, 'ActivityName]]
-- mkJoinedRow :: _ -> [Rec Attr ['Id, 'ActivityName]] -> Rec Attr ['Id, 'Name, 'Age] ->  [Rec Attr ['Id, 'Name, 'Age, 'ActivityName]]
mkJoinedRow field activities person = do
  let name = person ^. rlens SName . unAttr
      age = person ^. rlens SAge . unAttr

  let filteredActivities = filter (\r -> r ^. rlens field . unAttr == person ^. rlens field . unAttr) activities
  case listToMaybe filteredActivities of
    Just _ -> do
      let activityId actvy = actvy ^. rlens field . unAttr
          activityName actvy = actvy ^. rlens SActivityName . unAttr
      (\actvy -> (SId =:: activityId actvy) :& (SName =:: name) :& (SAge =:: age) :& (SActivityName =:: activityName actvy) :& RNil) <$> filteredActivities
    Nothing -> []

innerJoinOnId :: [Rec Attr ['Id, 'Name, 'Age]] -> [Rec Attr ['Id, 'ActivityName]] -> [Rec Attr ['Id, 'Name, 'Age, 'ActivityName]]
innerJoinOnId people activities = do
  let peopleIdx =(\r -> r ^. rlens SId . unAttr) <$> people
  let filteredActivites = filter (isInPplIdx peopleIdx) activities
  join $ map (\p -> mkJoinedRow SId filteredActivites p) people

main :: IO ()
main = mapM_ print $ innerJoinOnId peopleRows activitieRows

-- example of main running:
-- λ> peopleRows
-- [{id: 1, name: "Joy", age: 28},{id: 0, name: "Jon", age: 23},{id: 2, name: "Karen", age: 15}]
-- λ> activitieRows
-- [{id: 0, activity: football},{id: 0, activity: dancing},{id: 1, activity: racing}]
-- λ> main
-- {id: 1, name: "Joy", age: 28, activity: racing}
-- {id: 0, name: "Jon", age: 23, activity: football}
-- {id: 0, name: "Jon", age: 23, activity: dancing}

-- Code I wish worked:

-- λ> mapM_ print $ innerJoinOn SId peopleRows activitieRows
-- λ> mapM_ print $ innerJoinOn SName peopleRows activitieRows -- this line would give a compiler error about activitiesRows not containing 'Name

[Cody Goodman]

I've since generalized a good bit, though I'm not sure what approach to take with mkJoinedRow.

Link: https://github.com/codygman/vinyl-experiments/blob/master/src/Main.hs

code:

{-# LANGUAGE ConstraintKinds, PartialTypeSignatures #-}
{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, FlexibleContexts, FlexibleInstances#-}
{-# LANGUAGE NoMonomorphismRestriction, GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-}
{-# LANGUAGE TypeOperators, ScopedTypeVariables, DeriveDataTypeable, KindSignatures #-}

module Main where

import Data.Vinyl
import Control.Lens hiding (Identity)
import Data.Singletons.TH
import Data.Maybe
import Control.Monad
import Data.Vinyl.TypeLevel (RIndex)

import Data.Typeable
import GHC.Exts (Constraint)

-- TODO might end up going this route
-- type JoinOn a fields = (a ∈ fields)

-- TODO leave these as Attr's to compare so compariso works in the general case
isInIdx field leftIdx rightRow =  any (== True) . map (== unAttrRightRow) $ leftIdx
  where unAttrRightRow = rightRow ^. rlens field . unAttr

-- TODO generalize mkJoinedRow if possible or require a typeclass instance of mkJoinedRow
-- TODO maybe we can just append fields or something

mkJoinedRow field activities person = do
  let name = person ^. rlens SName . unAttr
      age = person ^. rlens SAge . unAttr

  let filteredActivities = filter (\r -> r ^. rlens field . unAttr == person ^. rlens field . unAttr) activities
  case listToMaybe filteredActivities of
    Just _ -> do
      let activityId actvy = actvy ^. rlens field . unAttr
          activityName actvy = actvy ^. rlens SActivityName . unAttr
      (\actvy -> (SId =:: activityId actvy) :& (SName =:: name) :& (SAge =:: age) :& (SActivityName =:: activityName actvy) :& RNil) <$> filteredActivities
    Nothing -> []

innerJoinOn field people activities = do
  let peopleIdx =(\r -> r ^. rlens field . unAttr) <$> people
  let filteredActivites = filter (isInIdx field peopleIdx) activities
  join $ map (\p -> mkJoinedRow field filteredActivites p) people

main :: IO ()
main = mapM_ print $ innerJoinOn SId peopleRows activitieRows

-- example of main running:
-- λ> peopleRows
-- [{id: 1, name: "Joy", age: 28},{id: 0, name: "Jon", age: 23},{id: 2, name: "Karen", age: 15}]
-- λ> activitieRows
-- [{id: 0, activity: football},{id: 0, activity: dancing},{id: 1, activity: racing}]

-- λ> mapM_ print $ innerJoinOn SId peopleRows activitieRows

-- {id: 1, name: "Joy", age: 28, activity: racing}
-- {id: 0, name: "Jon", age: 23, activity: football}
-- {id: 0, name: "Jon", age: 23, activity: dancing}