Wrestling with exponential compile times in GHC

For a recent project I found the need to partition a list of errors into user and server errors... on the type level. This would allow me to properly define a servant definition that is transparent about which errors are returned along with the 400 HTTP status code, and which would be send as a 500. This information can then be utilized to automatically generate OpenAPI documentation, which is turning out to be an incredibly powerful tool. It allows developers to easily and quickly test an endpoint, reviewers to spot any breaking changes in the API, and other teams to do their thing without requiring much assistance.

Here is an impression of how the errors are defined:

{-# LANGUAGE DerivingStrategies #-}

class IsError err where
  type IsUserError err :: Bool

newtype UserError x = UserError x
instance IsError (UserError x) where
  type IsUserError (UserError x) = True

newtype ServerError x = ServerError x
instance IsError (ServerError x) where
  type IsError (ServerError x) = True

data InvalidParameter = InvalidTimestamp | InvalidSortKey
  deriving IsError via UserError InvalidParameter

data DatabaseError = UnparsableStoredObject | UnkownDbError
  deriving IsError via ServerError DatabaseError

With that we can create a special servant http verb that can be transparent about the errors it can throw. Moreover, by employing a type family we can distinquish between user and server errors and choose a more appropriate http return code.

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}

import qualified Servant.API as Servant

type family FilterUserErrors (errs :: [Type]) :: [Type] where
  FilterUserErrors '[] = '[]
  FilterUserErrors (e ': es) = If (IsUserError e) (e ': FilterUserErrors es) (FilterUserErrors es)

type family FilterServerErrors (errs :: [Type]) :: [Type] where
  FilterServerErrors '[] = '[]
  FilterServerErrors (e ': es) = If (IsUserError e) (FilterServerErrors es) (e ': FilterServerErrors es)

type VerbWithErrors method contentTypes errs res =
  UVerb
    method
    contentTypes
    '[ WithStatus 200 res
     , WithStatus 400 (Servant.Union (FilterUserErrors errs))
     , WithStatus 500 (Servant.Union (FilterServerErrors errs))
     ]

And this worked splendidly! Or at least for a while. Because as the application grew, we very abruptly ran in the problem of unreasonably slow compile time after going from 11 to 13 errors. The server module now took 3 minutes to compile!

You might expect that the type checker would be given a lot of extra work with this approach and would be the reason for the slowdown, but this is actually not case. With the help of time-ghc-modules I was able to identify GHC's simplifier as the source of the slowdown. Not really expecting to learn much from it, I compiled with the -ddump-simpl flag to be able to inspect the Core representation at each stage of the simplifier. But without even looking at it, I could see something was off: the pretty printed Core was gigabytes in size! All the while the server module was only a couple hundred lines of code. Glancing at the Core identified the suspect: A LOT of typelevel occurances of the If constructor.

The issue is that If is just a constructor and is not actually being reduced by the compiler. As a result, both recursive calls to the filter are expanded and an exponential size type level term is created! To be precise, \(2 ^ n\). To resolve this, we need to reformulate the type family to only have 1 recursive call. It might seem obvious when I give you the answer, but I can assure you that I would not have been able to crack the case without the help of Andres Löh at Zurihac 2024.

type family FilterUserErrors (xs :: [Type]) :: [Type] where
  FilterUserErrors '[] = '[]
  FilterUserErrors (x ': xs) = ConditionalCons (IsUserError x) x (FilterUserErrors xs)

type family FilterServerErrors (xs :: [Type]) :: [Type] where
  FilterServerErrors '[] = '[]
  FilterServerErrors (x ': xs) = ConditionalCons (Not (IsUserError x)) x (FilterServerErrors xs)

type family ConditionalCons (b :: Bool) (x :: Type) (xs :: [Type]) where
  ConditionalCons True x xs = x : xs
  ConditionalCons False _ xs = xs