<div dir="ltr"><div><div>I've since generalized a good bit, though I'm not sure what approach to take with mkJoinedRow.<br><br></div>Link: <a href="https://github.com/codygman/vinyl-experiments/blob/master/src/Main.hs">https://github.com/codygman/vinyl-experiments/blob/master/src/Main.hs</a><br><br></div>code: <br><br>{-# LANGUAGE ConstraintKinds, PartialTypeSignatures #-}<br>{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, FlexibleContexts, FlexibleInstances#-}<br>{-# LANGUAGE NoMonomorphismRestriction, GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-}<br>{-# LANGUAGE TypeOperators, ScopedTypeVariables, DeriveDataTypeable, KindSignatures #-}<br>module Main where<br><br>import Data.Vinyl<br>import Control.Lens hiding (Identity)<br>import <a href="http://Data.Singletons.TH">Data.Singletons.TH</a><br>import Data.Maybe<br>import Control.Monad<br>import Data.Vinyl.TypeLevel (RIndex)<br>import Data.Typeable<br>import GHC.Exts (Constraint)<br><br>-- TODO might end up going this route<br>-- type JoinOn a fields = (a ∈ fields)<br><br>data Fields = Id | Name | Age | ActivityName deriving Show<br><br>type Person = ['Id, 'Name, 'Age]<br>type Activity = ['Id, 'ActivityName]<br><br>type family ElF (f :: Fields) :: * where<br>  ElF 'Id = Int<br>  ElF 'Name = String<br>  ElF 'Age = Int<br>  ElF 'ActivityName = String<br><br>newtype Attr f = Attr { _unAttr :: ElF f }<br>makeLenses ''Attr<br>genSingletons [ ''Fields ]<br>instance Show (Attr 'Id) where show (Attr x) = "id: " ++ show x<br>instance Show (Attr 'Name) where show (Attr x) = "name: " ++ show x<br>instance Show (Attr 'Age) where show (Attr x) = "age: " ++ show x<br>instance Show (Attr 'ActivityName) where show (Attr x) = "activity: " ++ x<br><br>(=::) :: sing f -> ElF f -> Attr f<br>_ =:: x = Attr x<br><br>joy :: Rec Attr ['Id, 'Name, 'Age]<br>joy = (SId =:: 1)<br>   :& (SName =:: "Joy")<br>   :& (SAge =:: 28)<br>   :& RNil<br>jon :: Rec Attr ['Id, 'Name, 'Age]<br>jon = (SId =:: 0)<br>   :& (SName =:: "Jon")<br>   :& (SAge =:: 23)<br>   :& RNil<br><br>karen :: Rec Attr ['Id, 'Name, 'Age]<br>karen = (SId =:: 2)<br>   :& (SName =:: "Karen")<br>   :& (SAge =:: 15)<br>   :& RNil<br><br>jonFootball :: Rec Attr ['Id, 'ActivityName]<br>jonFootball = (SId =:: 0)<br>           :& (SActivityName =:: "football")<br>           :& RNil<br><br>jonDancing :: Rec Attr ['Id, 'ActivityName]<br>jonDancing = (SId =:: 0)<br>           :& (SActivityName =:: "dancing")<br>           :& RNil<br><br>joyRacing :: Rec Attr ['Id, 'ActivityName]<br>joyRacing = (SId =:: 1)<br>           :& (SActivityName =:: "racing")<br>           :& RNil<br><br>peopleRows :: [Rec Attr ['Id, 'Name, 'Age]]<br>peopleRows = [joy, jon, karen]<br><br>activitieRows :: [Rec Attr ['Id, 'ActivityName]]<br>activitieRows = [jonFootball, jonDancing, joyRacing]<br><br>printActvy :: ('ActivityName ∈ fields) => Rec Attr fields -> IO ()<br>printActvy r = print (r ^. rlens SActivityName)<br><br>-- TODO leave these as Attr's to compare so compariso works in the general case<br>isInIdx field leftIdx rightRow =  any (== True) . map (== unAttrRightRow) $ leftIdx<br>  where unAttrRightRow = rightRow ^. rlens field . unAttr<br><br>-- TODO generalize mkJoinedRow if possible or require a typeclass instance of mkJoinedRow<br>-- TODO maybe we can just append fields or something<br>mkJoinedRow field activities person = do<br>  let name = person ^. rlens SName . unAttr<br>      age = person ^. rlens SAge . unAttr<br><br>  let filteredActivities = filter (\r -> r ^. rlens field . unAttr == person ^. rlens field . unAttr) activities<br>  case listToMaybe filteredActivities of<br>    Just _ -> do<br>      let activityId actvy = actvy ^. rlens field . unAttr<br>          activityName actvy = actvy ^. rlens SActivityName . unAttr<br>      (\actvy -> (SId =:: activityId actvy) :& (SName =:: name) :& (SAge =:: age) :& (SActivityName =:: activityName actvy) :& RNil) <$> filteredActivities<br>    Nothing -> []<br><br>innerJoinOn field people activities = do<br>  let peopleIdx =(\r -> r ^. rlens field . unAttr) <$> people<br>  let filteredActivites = filter (isInIdx field peopleIdx) activities<br>  join $ map (\p -> mkJoinedRow field filteredActivites p) people<br><br>main :: IO ()<br>main = mapM_ print $ innerJoinOn SId peopleRows activitieRows<br><br>-- example of main running:<br>-- λ> peopleRows<br>-- [{id: 1, name: "Joy", age: 28},{id: 0, name: "Jon", age: 23},{id: 2, name: "Karen", age: 15}]<br>-- λ> activitieRows<br>-- [{id: 0, activity: football},{id: 0, activity: dancing},{id: 1, activity: racing}]<br>-- λ> mapM_ print $ innerJoinOn SId peopleRows activitieRows<br>-- {id: 1, name: "Joy", age: 28, activity: racing}<br>-- {id: 0, name: "Jon", age: 23, activity: football}<br>-- {id: 0, name: "Jon", age: 23, activity: dancing}<br><br></div><div class="gmail_extra"><br><div class="gmail_quote">On Sun, Aug 21, 2016 at 2:16 PM, Cody Goodman <span dir="ltr"><<a href="mailto:codygman.consulting@gmail.com" target="_blank">codygman.consulting@gmail.com</a>></span> wrote:<br><blockquote class="gmail_quote" style="margin:0 0 0 .8ex;border-left:1px #ccc solid;padding-left:1ex"><div dir="ltr">Hello all! I'll get right to it.<br><br>As a first step I'd like to generalize innerJoinOnId's type signature to something like:<br><br>innerJoinOnId :: (Id ∈ fields, Id ∈ fields2, Id ∈ fields2) => [Rec Attr fields] -> [Rec Attr fields2] -> [Rec Attr fields3]<br><br>Or if possible:<br><br>innerJoinOnId :: (Id ∈ fields) => [Rec Attr fields] -> [Rec Attr fields] -> [Rec Attr fields]<br><br>As a next step I'd like to create an innerJoin function with type:<br><br>innerJoinOn :: (a ∈ fields) => [Rec Attr fields] -> [Rec Attr fields] -> [Rec Attr fields]<br><br>Where a is supplied and that constraint is carried on to the other inputs. Is this possible in Haskell?<br><br>Here is both a link and the text of my (working, compilable) code thus far.<br><br>Link: <a href="https://github.com/codygman/vinyl-experiments/blob/master/src/Main.hs" target="_blank">https://github.com/codygman/<wbr>vinyl-experiments/blob/master/<wbr>src/Main.hs</a><br><br>Source code:<br><br>{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies, FlexibleContexts, FlexibleInstances, NoMonomorphismRestriction, GADTs, TypeSynonymInstances, TemplateHaskell, StandaloneDeriving #-}<br><br>module Main where<br><br>import Data.Vinyl<br>import Control.Lens hiding (Identity)<br>import <a href="http://Data.Singletons.TH" target="_blank">Data.Singletons.TH</a><br>import Data.Maybe<br>import Control.Monad<br>import Data.Vinyl.TypeLevel (RIndex)<br><br>data Fields = Id | Name | Age | ActivityName deriving Show<br><br>type Person = ['Id, 'Name, 'Age]<br>type Activity = ['Id, 'ActivityName]<br><br>type family ElF (f :: Fields) :: * where<br>  ElF 'Id = Int<br>  ElF 'Name = String<br>  ElF 'Age = Int<br>  ElF 'ActivityName = String<br><br>newtype Attr f = Attr { _unAttr :: ElF f }<br>makeLenses ''Attr<br>genSingletons [ ''Fields ]<br>instance Show (Attr 'Id) where show (Attr x) = "id: " ++ show x<br>instance Show (Attr 'Name) where show (Attr x) = "name: " ++ show x<br>instance Show (Attr 'Age) where show (Attr x) = "age: " ++ show x<br>instance Show (Attr 'ActivityName) where show (Attr x) = "activity: " ++ x<br><br>(=::) :: sing f -> ElF f -> Attr f<br>_ =:: x = Attr x<br><br>joy :: Rec Attr ['Id, 'Name, 'Age]<br>joy = (SId =:: 1)<br>   :& (SName =:: "Joy")<br>   :& (SAge =:: 28)<br>   :& RNil<br>jon :: Rec Attr ['Id, 'Name, 'Age]<br>jon = (SId =:: 0)<br>   :& (SName =:: "Jon")<br>   :& (SAge =:: 23)<br>   :& RNil<br><br>karen :: Rec Attr ['Id, 'Name, 'Age]<br>karen = (SId =:: 2)<br>   :& (SName =:: "Karen")<br>   :& (SAge =:: 15)<br>   :& RNil<br><br>jonFootball :: Rec Attr ['Id, 'ActivityName]<br>jonFootball = (SId =:: 0)<br>           :& (SActivityName =:: "football")<br>           :& RNil<br><br>jonDancing :: Rec Attr ['Id, 'ActivityName]<br>jonDancing = (SId =:: 0)<br>           :& (SActivityName =:: "dancing")<br>           :& RNil<br><br>joyRacing :: Rec Attr ['Id, 'ActivityName]<br>joyRacing = (SId =:: 1)<br>           :& (SActivityName =:: "racing")<br>           :& RNil<br><br>peopleRows :: [Rec Attr ['Id, 'Name, 'Age]]<br>peopleRows = [joy, jon, karen]<br><br>activitieRows :: [Rec Attr ['Id, 'ActivityName]]<br>activitieRows = [jonFootball, jonDancing, joyRacing]<br><br>printActvy :: ('ActivityName ∈ fields) => Rec Attr fields -> IO ()<br>printActvy r = print (r ^. rlens SActivityName)<br><br>isInPplIdx :: ('Id ∈ fields) => [Int] -> Rec Attr fields -> Bool<br>isInPplIdx peopleIdx actvyRow =  any (== True) . map (== actvyIdInt) $ peopleIdx<br>  where actvyIdInt = actvyRow ^. rlens SId . unAttr<br><br><br>mkJoinedRow :: (Eq (ElF r1),<br>                              <wbr>  RElem<br>                              <wbr>    r1<br>                              <wbr>    ['Id, 'Name, 'Age]<br>                              <wbr>    (RIndex r1 ['Id, 'Name, 'Age]),<br>                              <wbr>  RElem<br>                              <wbr>    r1<br>                              <wbr>    ['Id, 'ActivityName]<br>                              <wbr>    (RIndex r1 ['Id, 'ActivityName]),<br>                              <wbr>  ElF r1 ~ Int) => sing1 r1 -> [Rec Attr ['Id, 'ActivityName]] -> Rec Attr ['Id, 'Name, 'Age] ->  [Rec Attr ['Id, 'Name, 'Age, 'ActivityName]]<br>-- mkJoinedRow :: _ -> [Rec Attr ['Id, 'ActivityName]] -> Rec Attr ['Id, 'Name, 'Age] ->  [Rec Attr ['Id, 'Name, 'Age, 'ActivityName]]<br>mkJoinedRow field activities person = do<br>  let name = person ^. rlens SName . unAttr<br>      age = person ^. rlens SAge . unAttr<br><br>  let filteredActivities = filter (\r -> r ^. rlens field . unAttr == person ^. rlens field . unAttr) activities<br>  case listToMaybe filteredActivities of<br>    Just _ -> do<br>      let activityId actvy = actvy ^. rlens field . unAttr<br>          activityName actvy = actvy ^. rlens SActivityName . unAttr<br>      (\actvy -> (SId =:: activityId actvy) :& (SName =:: name) :& (SAge =:: age) :& (SActivityName =:: activityName actvy) :& RNil) <$> filteredActivities<br>    Nothing -> []<br><br>innerJoinOnId :: [Rec Attr ['Id, 'Name, 'Age]] -> [Rec Attr ['Id, 'ActivityName]] -> [Rec Attr ['Id, 'Name, 'Age, 'ActivityName]]<br>innerJoinOnId people activities = do<br>  let peopleIdx =(\r -> r ^. rlens SId . unAttr) <$> people<br>  let filteredActivites = filter (isInPplIdx peopleIdx) activities<br>  join $ map (\p -> mkJoinedRow SId filteredActivites p) people<br><br>main :: IO ()<br>main = mapM_ print $ innerJoinOnId peopleRows activitieRows<br><br>-- example of main running:<br>-- λ> peopleRows<br>-- [{id: 1, name: "Joy", age: 28},{id: 0, name: "Jon", age: 23},{id: 2, name: "Karen", age: 15}]<br>-- λ> activitieRows<br>-- [{id: 0, activity: football},{id: 0, activity: dancing},{id: 1, activity: racing}]<br>-- λ> main<br>-- {id: 1, name: "Joy", age: 28, activity: racing}<br>-- {id: 0, name: "Jon", age: 23, activity: football}<br>-- {id: 0, name: "Jon", age: 23, activity: dancing}<br><br>-- Code I wish worked:<br><br>-- λ> mapM_ print $ innerJoinOn SId peopleRows activitieRows<br>-- λ> mapM_ print $ innerJoinOn SName peopleRows activitieRows -- this line would give a compiler error about activitiesRows not containing 'Name<br><br></div>
</blockquote></div><br></div>