Skip to content

Programming Languages: Principles and Paradigms Week 3b

Week 3b

Lecture slides¶

Type classes and type inference: pdf, key,

Recommended reading¶

Textbook: new Chapter 7 on type classes.

Code snippets¶

Below are the code snippets from class.

Show¶

data Tree a = Node (Tree a) (Tree a)
            | Leaf a

instance Show a => Show (Tree a) where
 show (Leaf a) = show a
 show (Node lt rt) = show lt ++ " /\\ " ++ show rt

data Color = Red | Green | Blue | Indigo | Violet
           deriving Show

Eq¶

-- Recall our tiny calculator language
data Expr = AddExpr Expr Expr
          | MulExpr Expr Expr
          | ConstExpr Int
          deriving Eq



eval :: Expr -> Int
eval (ConstExpr n) = n
eval (AddExpr e1 e2) = eval e1 + eval e2
eval (MulExpr e1 e2) = eval e1 * eval e2

instance Show Expr where
  show (ConstExpr i) = show i
  show (AddExpr e1 e2) = unwords ["(", show e1, ")", "+", "(", show e2, ")"]
  show (MulExpr e1 e2) = unwords ["(", show e1, ")", "*", "(", show e2, ")"]


ex0 :: Expr
ex0 = (AddExpr (ConstExpr 2) (MulExpr (ConstExpr 1) (ConstExpr 1)))

ex1 :: Expr
ex1 = (AddExpr (ConstExpr 1) (MulExpr (ConstExpr 1) (ConstExpr 2)))

eq = ex0 == ex1 -- A: yes, B: no?
--
-- instance Eq Expr where
--   exp1 == exp2 = eval exp1 == eval exp2

Num¶

module Intro where

-- * One type can have multiple constructors
data Point = Cartesian Double Double
           | Polar Double Double
           deriving Show

-- E.g., convert point to cartesian:
toCartesian :: Point -> Point
toCartesian point = case point of
                      Polar r theta -> Cartesian (r * cos theta)
                                                 (r * sin theta)
                      pt@(Cartesian _ _) -> pt

instance Num Point where
  (Cartesian x1 y1) + (Cartesian x2 y2) = Cartesian (x1+x2) (y1+y2)
  p1@(Polar _ _) + p2@(Polar _ _) = toCartesian p1 + toCartesian p2

  (Cartesian x1 y1) * (Cartesian x2 y2) = Cartesian (x1*x2) (y1*y2)
  p1 * p2 = toCartesian p1 * toCartesian p2

Desugaring type classes to dictionaries¶

Original code, using type classes:

module TypeClasses1 where
import qualified Prelude
import Prelude hiding (Num(..), Eq(..), Ord(..), map)

-- # Eq class examples
class Eq a where
 (==) :: a -> a -> Bool
 (==) x y = not $ x /= y
 (/=) :: a -> a -> Bool
 (/=) x y = not $ x == y

instance Eq Bool where
  (==) True  True  = True
  (==) False False = True
  (==) _     _     = False

allEqual :: Eq a => a -> a -> a -> Bool
allEqual a b c = (==) a b && (==) b c 

instance Eq a => Eq [a] where
  (==) []     []     = True
  (==) (x:xs) (y:ys) = (==) x y && (==) xs ys
                    --- ^            ^  A: yes , B: no?
  (==) _      _      = False

instance (Eq a, Eq b) => Eq (a, b) where
  (==) (x1,y1) (x2,y2) = (==) x1 x2 && (==) y1 y2

-- # Ord class

class Eq a => Ord a where
  (<)  :: a -> a -> Bool
  (<) x y = (<=) x y && (/=) x y
  (<=) :: a -> a -> Bool
  (<=) x y = (<) x y || (==) x y


compare :: Ord a => a -> a -> Ordering
compare x y = if x == y then EQ
                  else if x < y
                          then LT
                          else GT

-- # Num class

-- Our "primitives"
plusInt :: Int -> Int -> Int
plusInt = (Prelude.+)
mulInt :: Int -> Int -> Int
mulInt  = (Prelude.*)
negInt :: Int -> Int
negInt = Prelude.negate
integerToInt :: Integer -> Int
integerToInt = Prelude.fromInteger

-- Dictionary
class Num a where
   (+) :: a -> a -> a
   (*) :: a -> a -> a
   negate :: a -> a

square :: Num a => a -> a
square x = x * x

instance Num Int where
 (+) = plusInt
 (*) = mulInt
 negate = negInt

squares :: (Num a, Num b) => a -> b -> (a,b)
squares x y = (x*x, y*y)

Desugaring it to dictionaries:

module TypeClasses1 where
import qualified Prelude
import Prelude hiding (Num(..), Eq(..), Ord(..), map)

-- # Eq class with dictionaries

data Eq a = MkEqDict { 
  (==) :: a -> a -> Bool,
  (/=) :: a -> a -> Bool
  }

-- instance Eq Bool where ...
dEqBool :: Eq Bool
dEqBool = MkEqDict {
   (==) = eq,
   (/=) = nEq
 } where eq True   True  = True
         eq False  False = True
         eq _      _     = False
         nEq x y = not $ eq x y

allEqual :: Eq a -> a -> a -> a -> Bool
allEqual dict a b c = 
  (==) dict a b && (==) dict b c 

-- instance Eq a => Eq [a] where ...
dEqList :: Eq a -> Eq [a]
dEqList elDict = MkEqDict eq nEq
    where eq [] []         = True
          eq (x:xs) (y:ys) =
            (==) elDict x y && eq xs ys
          eq _ _           = False
          nEq x y          =  not $ eq x y

-- instance (Eq a, Eq b) => Eq (a, b) where ...
dEqPair :: Eq a -> Eq b -> Eq (a, b)
dEqPair aDict bDict = MkEqDict eq nEq
    where eq (x1,y1) (x2,y2) =
            (==) aDict x1 x2 &&
            (==) bDict y1 y2
          nEq x y            =  not $ eq x y

-- # Ord class

data Ord a = MkOrd { (<=) :: a -> a -> Bool,
                      eqD :: Eq a }


compare :: Ord a -> a -> a -> Ordering
compare d x y = undefined

-- # Num class

-- Our "primitives"
plusInt :: Int -> Int -> Int
plusInt = (Prelude.+)
mulInt :: Int -> Int -> Int
mulInt  = (Prelude.*)
negInt :: Int -> Int
negInt = Prelude.negate
integerToInt :: Integer -> Int
integerToInt = Prelude.fromInteger

-- Dictionary
data Num a = MkNumDict {
                (+) :: a -> a -> a,
                (*) :: a -> a -> a,
                negate :: a -> a
             }

-- square :: Num a => a -> a
square :: Num a -> a -> a
square = undefined

dNumInt :: Num Int
dNumInt = MkNumDict plusInt mulInt negInt

-- squares :: (Num a, Num b) => a -> b -> (a, b)
squares :: Num a -> Num b -> a -> b -> (a,b)
squares dx dy x y = undefined

A more complex example with type constructors¶

{-# LANGUAGE InstanceSigs #-}
module HasMap where

import Prelude hiding (map)

mapList :: (a -> b) -> [a] -> [b]
mapList f [] = []
mapList f (x:xs) = f x : mapList f xs

mapMaybe :: (a -> b) -> Maybe a -> Maybe b
mapMaybe f Nothing = Nothing
mapMaybe f (Just x) = Just (f x)

data Tree a = Leaf a
            | Node (Tree a) (Tree a)

mapTree :: (a -> b) -> Tree a -> Tree b
mapTree f (Leaf x) = Leaf (f x)
mapTree f (Node t1 t2) = Node (mapTree f t1) (mapTree f t2)

class HasMap g where
    map :: (a -> b) -> g a -> g b

instance HasMap [] where
    map :: (a -> b) -> [a] -> [b]
    map f [] = []
    map f (x:xs) = f x : map f xs


instance HasMap Maybe where
    map = mapMaybe

instance HasMap Tree where
    map = mapTree