[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