Cooking Classes with Datatype Generic Programming

Haskell Generics are a somewhat misunderstood topic but are an extremely powerful technique for writing reusable and comparable interfaces across an enormous universe of types with very little effort. They are probably my favorite example of the advantages of an expressive type system endows us with.

Source for examples code is available here.

Generics are a form of datatype-generic programming, which although the namesake has some similarity to Java Generics they are different concepts entirely. GHC’s implementation of Generics fall out of the simple observation that all datatypes in Haskell can be written as a combination of a sum of products.

A sum type, is a data structure used to hold a value that could take on several different, but fixed, types. For example:

data Pastry
  = Turnover
  | Macaroon
  | Brownie
  | Cookie

A product type, is a data structure used to hold a fixed ordered set of several types. Selecting a single field is called projection.

data Person = Person
  { firstName       :: String
  , lastName        :: String
  , age             :: Int
  , height          :: Float
  , phoneNumber     :: String
  , flavor          :: String
  }

In Haskell all datatypes can be expressed as sums of products:

data Expr
  = Add { l :: Expr, r :: Expr }
  | Mul { l :: Expr, r :: Expr }
  | Sub { l :: Expr, r :: Expr }
  | Div { l :: Expr, r :: Expr }
  | Number { val :: Int }

During compilation most of the information about the structure of the datatypes is thrown out, by design Haskell erases all type information. Prior to type-checking a phase known as elaboration expands out all record selectors into toplevel functions which extract the named fields of a product.

data Point a b = Point { x :: a, y :: b }

x :: Point a b -> a
x (Point a _) = a

y :: Point a b -> b
y (Point _ b) = b

The rest of the information about products largely gets thrown out after compilation, and the product just get expanded into pattern matching code. For sum types the only information that is kept around is the tag for each constructor of the sum type. For instance Add is assigned the tag 1, Mul is assigned 2 etc. In a case statement the only information that is available at runtime is which branch we’re scrutinizing.

So what if consider not tossing out all this information and instead exposed it to our program so that we could write generic logic that can introspect the “structure” of our datatypes.

Compiler Hooks

Since GHC 6.10 we’ve had type families which, among other things, allow us to associate data types with our typeclass. So the structure of our Generic class can have a associated Rep type which can carry information along with the typeclass.

class Generic a where
  type Rep a :: * -> *
  from :: a -> (Rep a) x
  to :: (Rep a) x -> a

To represent the structure of our datatype we need to set up several datatypes to encode, sums, products, empty branches and various metadata about the names of fields, constructors and their types. All of which have a free parameter p which is bound to the head of typeclass instance when used in the associated datatype Rep a.

data    V1        p                       -- Empty
data    U1        p = U1                  -- ()
data    (:+:) f g p = L1 (f p) | R1 (g p) -- Sum
data    (:*:) f g p = (f p) :*: (g p)     -- Product
newtype K1    i c p = K1 { unK1 :: c }    -- a container for a c
newtype M1  i t f p = M1 { unM1 :: f p }  -- metadata wrapper

Now we could write this instance by hand for all of our datatypes, and for a simple enumeration it would look like the following:

data Ingredient
  = Flour
  | Sugar

instance Generic Ingredient where
  type Rep Ingredient = M1 D (T_Ingredient ((M1 C (C_Flour U1)) :+: (M1 C (C_Sugar U1))))

  from Flour = M1 (L1 (M1 U1))
  from Sugar = M1 (R1 (M1 U1))

  to (M1 (L1 (M1 U1))) = Flour
  to (M1 (R1 (M1 U1))) = Sugar

data T_Ingredient
data C_Flour
data C_Sugar

The instance here is purely mechanical and can be derived from GHC’s internal representation of it’s syntax tree, namely the types GHC.DataCon and GHC.TypeCon. Using the -XDeriveGeneric extension we can have GHC crank this typeclass out automatically:

{-# LANGUAGE DeriveGeneric #-}

data Ingredient
  = Flour
  | Sugar
  deriving (Generic)

Lest we not handwave away the work that GHC is doing, let’s actually recreate the introspection logic that GHC uses when instantiating a Generic class from a module’s data definitions. Let’s load a module dynamically, intercept the compilation and dump out the internal structure of the it’s datatypes to see how this would be mechanically translated into a typeclass instance.

import GHC
import GHC.Paths as Paths

import Name
import TyCon
import TypeRep
import DataCon
import HscTypes

import Text.Show.Pretty

main :: IO ()
main = do

  -- Inside the GHC Monad
  rep <- runGhc (Just Paths.libdir) $ do

    -- Spin up a GHC compiler environment
    dflags <- getSessionDynFlags
    setSessionDynFlags dflags

    -- Make a dummy module to inject
    let mn = mkModuleName "Test"

    -- Make a dummy target
    addTarget Target {
      targetId = TargetModule mn
    , targetAllowObjCode = True
    , targetContents = Nothing
    }

    -- Run the GHC pipeline
    load LoadAllTargets
    modSum <- getModSummary mn
    p <- parseModule modSum
    t <- typecheckModule p

    -- Pluck out the module tycons after we're done type-checking
    DesugaredModule tcmod modguts <- desugarModule t
    let tycons = mg_tcs modguts

    -- Deconstruct all datatypes into their sums-of-products.
    return (deconstruct tycons)

  putStrLn (ppShow rep)

Now that we have access to GHC’s internal representation of the “module guts” we can write our deconstructor logic. The logic is a slim few hundred lines of mostly ADT munging.

deconstruct :: [TyCon] -> [Data]
deconstruct = fmap go
  where
    go x
      | isProduct x = M1 $ D Datatype
        { dataTypeName = getOccString (tyConName x)
        , modName      = modString x
        , isNewtype    = isNewTyCon x
        , datatype     = Product (mkProduct x)
        , recursive    = isRecursiveTyCon x
        }

      | isVoid x = M1 $ D Datatype
        { dataTypeName = getOccString (tyConName x)
        , modName      = modString x
        , isNewtype    = isNewTyCon x
        , datatype     = V1
        , recursive    = isRecursiveTyCon x
        }

      | otherwise = M1 $ D Datatype
        { dataTypeName = getOccString (tyConName x)
        , modName      = modString x
        , isNewtype    = isNewTyCon x
        , datatype     = Sum (mkProduct x)
        , recursive    = isRecursiveTyCon x
        }

mkRecord :: TyCon -> [Data]
mkRecord x = concatMap mkRProduct (tyConDataCons x)

mkProduct :: TyCon -> [Data]
mkProduct x = fmap go (tyConDataCons x)
  where
    go :: DataCon -> Data
    go x | isRecord x   = Product (mkRProduct x)
    go x | isDProduct x = Product (mkDProduct x)
    go x                = M1 (C (Constructor (conNames x)))

mkDProduct :: DataCon -> [Data]
mkDProduct xs = [K1 (showType x) | x <- dataConOrigArgTys xs]

mkRProduct :: DataCon -> [Data]
mkRProduct x = [M1 (S (Selector (getOccString fld)) ty) | (fld, ty) <- zip (fieldNames x) (mkDProduct x)]

Setting up the dummy module Test.hs to run our decompilation script:

data PlatonicSolid
  = Tetrahedron
  | Cube
  | Octahedron
  | Dodecahedron
  | Icosahedron

data Person = Person
  { firstName       :: String
  , lastName        :: String
  , age             :: Int
  , height          :: Float
  , phoneNumber     :: String
  , flavor          :: String
  } deriving (Show)

data T
  = T1 { a :: Int, b :: Float }
  | T2 { c :: Int, d :: Double }

For PlatonicSolid we get the representation:

M1
   (D Datatype
        { dataTypeName = "PlatonicSolid"
        , modName = "Test"
        , isNewtype = False
        , datatype =
            Sum
              [ M1 (C Constructor { conName = "Tetrahedron" })
              , M1 (C Constructor { conName = "Cube" })
              , M1 (C Constructor { conName = "Octahedron" })
              , M1 (C Constructor { conName = "Dodecahedron" })
              , M1 (C Constructor { conName = "Icosahedron" })
              ]
        , recursive = False
        })

For Person we get the representation:

M1
    (D Datatype
         { dataTypeName = "Person"
         , modName = "Test"
         , isNewtype = False
         , datatype =
             Product
               [ M1 (S Selector { selName = "firstName" } (K1 "String"))
               , M1 (S Selector { selName = "lastName" } (K1 "String"))
               , M1 (S Selector { selName = "age" } (K1 "Int"))
               , M1 (S Selector { selName = "height" } (K1 "Float"))
               , M1 (S Selector { selName = "phoneNumber" } (K1 "String"))
               , M1 (S Selector { selName = "flavor" } (K1 "String"))
               ]
         , recursive = False
       })

For the sum of products T we get the representation:

M1
  (D Datatype
       { dataTypeName = "T"
       , modName = "Test"
       , isNewtype = False
       , datatype =
           Sum
             [ Product
                 [ M1 (S Selector { selName = "a" } (K1 "Int"))
                 , M1 (S Selector { selName = "b" } (K1 "Float"))
                 ]
             , Product
                 [ M1 (S Selector { selName = "c" } (K1 "Int"))
                 , M1 (S Selector { selName = "d" } (K1 "Double"))
                 ]
             ]
       , recursive = False
       })

These data points are then used to generate the Rep instance in the derived Generic instances. So that’s a rough approximation of how -XDeriveGeneric works under the hood, nothing terribly complicated just book keeping.

GHC.Generics

From the internal representation we crank out several typeclass instances which store the metadata about the various constructors.

class Datatype d where
  datatypeName :: t d f a -> String
  moduleName   :: t d f a -> String
  isNewtype    :: t d f a -> Bool
  isNewtype _ = False

class Selector s where
  selName :: t s f a -> String

class Constructor c where
  conName :: t c f a -> String

  conFixity :: t c f a -> Fixity
  conFixity _ = Prefix

  conIsRecord :: t c f a -> Bool
  conIsRecord _ = False

For example, for Ingredient example from before, we’d have several constructor instances automatically generated by which we could query the names from the AST.

type Rep Ingredient = M1 D (T_Ingredient ((M1 C (C_Flour U1)) :+: (M1 C (C_Sugar U1))))

data T_Ingredient
data C_Flour
data C_Sugar

instance Datatype T_Ingredient where
  datatypeName _ = "Ingredient"
  moduleName _ = "Main"

instance Constructor C_Flour where
  conName _ = "Flour"

instance Constructor C_Sugar where
  conName _ = "Sugar"

Unlike reflection in languages like Java, Generics are not pushing type information into the runtime. Apart from a dictionary lookup for they are a effectively free abstraction that has no overhead. We’re simply making more information from the compiler manifest in the types during the type-checking phase, all of which gets erased during compilation.

Example

I tried to come up a non-contrived example for illustrating the usefulness of generics, and there are plenty of examples (serializes for JSON, Protocol Buffers, SQL Generation, traversals, command line parsers, etc) that are well-documented elsewhere on the web. So let’s consider an example based on the silly pun in the title of this article, namely cooking typeclasses.

So we have a Pie type, naturally.

data Pie = Pie
  { filling :: Filling
  , topping :: Maybe Topping
  } deriving (Show, Generic)

data Filling = Apple | Cherry | Pumpkin
  deriving (Show, Generic)

data Topping = IceCream | WhipCream
  deriving (Show, Generic)

Using generics we’d like to a generate a list of the types of pie that we can put on a menu from the structure of the Haskell types. Records will denote named variations (“filling” vs “topping”) of the menu item, while sum types denote the various options in the variations (“cherry filling” vs “apple filling”).

data Item
  = Item Text [Item]
  | Variant Text [Item]
  | Choice Text
  deriving (Show, Generic)

We implement a typeclass with a default signature which gives us the option to manually specify how a type gets converted into a menu item, or fall back on using it’s generic representation to automatically generate it.

class Menu a where
  menu :: a -> [Item]
  default menu :: (Generic a, GMenu (Rep a)) => a -> [Item]
  menu _ = gmenu (Proxy :: Proxy a)

gmenu :: forall a. (Generic a, GMenu (Rep a)) => Proxy a -> [Item]
gmenu _ = gopts (Proxy :: Proxy (Rep a))

Our generic menu operates over various GHC.Generics types to expand out the sums and products into the Item categories that correspond to the menu. The instance for GMenu (K1 R f) has a Menu constraint which allows manual override for specific datatypes. Since we’re passing around a proxy we’ll have to manually thread the dictionary around sometimes by passing an undefined cast to the type of the instance we need to resolve.

-- Generic Menu
class GMenu a where
  gopts :: Proxy a -> [Item]

-- Datatype
instance GMenu f => GMenu (M1 D x f) where
  gopts _ = gopts (Proxy :: Proxy f)

-- Constructor Metadata
instance (GMenu f, Constructor c) => GMenu (M1 C c f) where
  gopts x
    | conIsRecord (undefined :: t c f a) =
      [Item (pack (conName m)) (gopts (Proxy :: Proxy f))]

    | otherwise = [Choice (pack (conName m))]
    where m = (undefined :: t c f a)

-- Selector Metadata
instance (GMenu f, Selector c) => GMenu (M1 S c f) where
  gopts _ = [Variant (pack (selName m)) (gopts (Proxy :: Proxy f))]
    where m = (undefined :: t c f a)

-- Constructor Paramater
instance (GMenu (Rep f), Menu f) => GMenu (K1 R f) where
  gopts _ = menu (undefined :: f)

-- Sum branch
instance (GMenu a, GMenu b) => GMenu (a :+: b) where
  gopts _ = gopts (Proxy :: Proxy a) ++ gopts (Proxy :: Proxy b)

-- Product branch
instance (GMenu a, GMenu b) => GMenu (a :*: b) where
  gopts _ = gopts (Proxy :: Proxy a) ++ gopts (Proxy :: Proxy b)

-- Void branch
instance GMenu U1 where
  gopts _ = []

Specifically we’ll override the Maybe type so that it simply expands out to a choice of either “AsIs” of the variant or just the list of choices endowed by the inner parameter.

instance Menu a => Menu (Maybe a) where
  menu _ = [Choice (pack "AsIs")] ++ (menu (undefined :: a))

As an example Maybe Topping expands out into three choices.

menu (a :: Maybe Topping) ~ [Choice "AsIs", Choice "IceCream", Choice "whipCream"]

Using GHC 7.10’s new -XDeriveAnyClass extension we can actually go back and automatically derive Menu inside the deriving clause.

data Pie = Pie
  { filling :: Filling
  , topping :: Maybe Topping
  } deriving (Show, Generic, Menu)

Now synthesizing a dictionary for Pie we can get a menu

menu (undefined :: Pie)

And voila:

[ Item
    "Pie"
    [ Variant
        "filling" [ Choice "Apple" , Choice "Cherry" , Choice "Pumpkin" ]
    , Variant
        "topping"
        [ Choice "AsIs" , Choice "IceCream" , Choice "WhipCream" ]
    ]
]

Since our logic is datatype generic, any Haskell we can write down can be automatically translated to a Menu just by deriving Menu. So now we can a new Crisp desert (my favorite!) and we get everything for free!

data Crisp = Crisp
  { contents :: Filling
  , temperature :: Temperature
  } deriving (Show, Generic, Menu)

data Temperature = Warm | Cold
  deriving (Show, Generic, Menu)

-- Add an instance for a pair of menu items. That expands into multiple items.
instance (Menu a, Menu b) => Menu (a,b) where
  menu _ = menu (undefined :: a) ++ menu (undefined :: b)

And we can generate the composite menu of both deserts:

menu (undefined :: (Pie, Crisp))

[ Item
    "Pie"
    [ Variant
        "filling" [ Choice "Apple" , Choice "Cherry" , Choice "Pumpkin" ]
    , Variant
        "topping"
        [ Choice "AsIs" , Choice "IceCream" , Choice "WhipCream" ]
    ]
, Item
    "Crisp"
    [ Variant
        "contents" [ Choice "Apple" , Choice "Cherry" , Choice "Pumpkin" ]
    , Variant "temperature" [ Choice "Warm" , Choice "Cold" ]
    ]
]

So that’s generics. One of the best goto examples of how an expressive type system and a few clever compiler hooks can make programmers lives easier by cooking our boilerplate for us and giving tastier more correct code.