haskellcategory-abstractions

How to define an instance of Control.Functor.Constrained?


I'm trying to define an instance of Functor.Constrained, after successfully defining an instance of Category.Constrained. However the type of Functor.Constrained fmap is complex and the attempt I made led to an error that I can't explain. How do you define all the objects required by the fmap type?

Control.Functor.Constrained
fmap :: (Object r a, Object t (f a), Object r b, Object t (f b)) => r a b -> t (f a) (f b)

http://hackage.haskell.org/package/constrained-categories-0.3.1.1

{-# LANGUAGE GADTs, TypeFamilies, ConstraintKinds #-}

module Question1 where

import Control.Category.Constrained
import Control.Functor.Constrained as FC 
import Data.Map as M
import Data.Set as S

data RelationMS a b where
  IdRMS :: RelationMS a a
  RMS :: Map a (Set b) -> RelationMS a b 

instance Category RelationMS where
    type Object RelationMS o = Ord o
    id = IdRMS
    (.) = compRMS

compRMS :: (Ord a, Ord k, Ord b) => RelationMS k b -> RelationMS a k -> RelationMS a b 
RMS mp2 `compRMS` RMS mp1
  | M.null mp2 || M.null mp1 = RMS M.empty
  | otherwise = RMS $ M.foldrWithKey 
        (\k s acc -> M.insert k (S.foldr (\x acc2 -> case M.lookup x mp2 of
                                                    Nothing -> acc2
                                                    Just s2 -> S.union s2 acc2
                                         ) S.empty s
                                ) acc
        ) M.empty mp1

pseudoFmap :: Ord c =>  (b -> c) -> RelationMS a b -> RelationMS a c
pseudoFmap f (RMS r) = RMS $ M.map (S.map f) r

instance FC.Functor RelationMS where
    -- error: ‘Object’ is not a (visible) associated type of class ‘Functor’
    type Object RelationMS o = Ord o
    fmap f (RMS r) = pseudoFmap f (RMS r)

----------- TO CHECK THE PROPOSED SOLUTION ---------

instance (Show a, Show b) => Show (RelationMS a b) where
        show (IdRMS) = "IdRMS"
        show (RMS r) = show r


> FC.fmap (+1) (RMS $ M.fromList [(1,S.fromList [10,20]), (2,S.fromList [30,40])])
> fromList [(1,fromList [11,21]),(2,fromList [31,41])]

Solution

  • {-# LANGUAGE GADTs, TypeFamilies, ConstraintKinds, FlexibleInstances
      , MultiParamTypeClasses, StandaloneDeriving #-}
    
    module Question1 where
    
    import Prelude hiding (($))
    
    import Control.Category.Constrained
    import Control.Functor.Constrained as FC 
    import Control.Arrow.Constrained (($))
    import Data.Map as M
    import Data.Set as S
    import Data.Constraint.Trivial
    
    
    main :: IO ()
    main = print $ FC.fmap f
             $ RMS (M.fromList [(1,S.fromList [11,21]),(2,S.fromList [31,41])])
     where f :: ConstrainedCategory (->) Ord Int Int
           f = constrained (+1)
    
    
    data RelationMS a b where
      IdRMS :: RelationMS a a
      RMS :: Map a (Set b) -> RelationMS a b 
    deriving instance (Show a, Show b) => Show (RelationMS a b)
    
    instance Category RelationMS where
        type Object RelationMS o = Ord o
        id = IdRMS
        (.) = compRMS
    
    compRMS :: (Ord a, Ord k, Ord b) => RelationMS k b -> RelationMS a k -> RelationMS a b 
    RMS mp2 `compRMS` RMS mp1
      | M.null mp2 || M.null mp1 = RMS M.empty
      | otherwise = RMS $ M.foldrWithKey 
            (\k s acc -> M.insert k (S.foldr (\x acc2 -> case M.lookup x mp2 of
                                                        Nothing -> acc2
                                                        Just s2 -> S.union s2 acc2
                                             ) S.empty s
                                    ) acc
            ) M.empty mp1
    
    pseudoFmap :: Ord c =>  (b -> c) -> RelationMS a b -> RelationMS a c
    pseudoFmap f (RMS r) = RMS $ M.map (S.map f) r
    
    instance FC.Functor (RelationMS a)
                        (ConstrainedCategory (->) Ord)
                        (ConstrainedCategory (->) Unconstrained) where
        fmap (ConstrainedMorphism f) = ConstrainedMorphism $
                \(RMS r) -> pseudoFmap f (RMS r)
    
    RMS (fromList [(1,fromList [12,22]),(2,fromList [32,42])])

    BTW, you can make the definitions of those maps and sets easier to type/read with a syntactic extension:

    {-# LANGUAGE OverloadedLists #-}
    main :: IO ()
    main = print $ FC.fmap f $ RMS [(1, [11,21]),(2, [31,41])]
     where f :: ConstrainedCategory (->) Ord Int Int
           f = constrained (+1)
    

    Talking about syntactic sugar: with constrained-categories>=0.4, you can also shorten the type signature

    {-# LANGUAGE TypeOperators #-}
    main = print $ FC.fmap f
             $ RMS (M.fromList [(1,S.fromList [11,21]),(2,S.fromList [31,41])])
     where f :: (Ord⊢(->)) Int Int
           f = constrained (+1)
    

    or even omit it entirely and instead specify the constraint with a type application on constrained:

    {-# LANGUAGE TypeApplications, OverloadedLists #-}
    main :: IO ()
    main = print $ FC.fmap (constrained @Ord (+1))
                  $ RMS ([(1,[11,21]),(2,[31,41])])
    

    Also, there's now the synonym Hask for the oxymoronic-looking ConstrainedCategory (->) Unconstrained, so you can simplify the instance head to

    instance FC.Functor (RelationMS a) (ConstrainedCategory (->) Ord) Hask