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

Cody Goodman codygman.consulting at gmail.com
Sun Aug 21 19:56:21 UTC 2016


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)

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)

-- 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}


On Sun, Aug 21, 2016 at 2:16 PM, Cody Goodman <codygman.consulting at gmail.com
> wrote:

> 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
>
>
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/haskell-cafe/attachments/20160821/7a759936/attachment.html>


More information about the Haskell-Cafe mailing list