Template Haskell

(3 examples of how we're using it)

When to use template haskell?

  • Newtypes
  • Boilerplate functions
  • Boilerplate instances
  • When you have a class of types that all need to satisfy the same feature set

How does it work?

  • Q monad
  • Constructors
    • Upper case constructors are pure values
    • Lower case smart constructors are effects in Q
    • Constructors are suffixed with type of meta-type
      • e.g. InstanceD/instanceD are type Dec/Q Dec respectively
  • You're writing a "splice" that gets stitched in to the source code and compiled wherever it's called

How does it work?

-- TH.hs
fooQ :: Name -> Q [Dec]
fooQ name = ...

-- Types.hs
data MyName = MyName
fooQ ''MyName

-- Spec.hs
data MyThing = MyThing
fooQ ''MyThing

spec :: Spec
spec = it "if it compiles, it worked!"
  • TH splices must be defined in a separate module than the module in which they are invoked
    • It's compiled n + 1 times:
      • Once in the Q monad
      • Each time it's invoked by stitching in necessary values
  • Test the splice with compile-time checks

Example 1: Opaleye

-- lots of boilerplate
newtype MyType { unMyType :: Text }
newtype PGMyType = PGMyType { unPGMyType :: PGText }
  deriving (PGString)

makeWrapped ''MyType

instance Default Constant MyType (Column PGMyType) where
  def = dimap (view _Wrapped) (unsafeCoerceColumn :: Column PGText -> Column PGMyType) def
instance FromField MyType where
  fromField f bs = view _Unwrapped <$> fromField f bs
instance QueryRunnerColumnDefault PGMyType MyType where
  queryRunnerColumnDefault = fieldQueryRunnerColumn

Example 1: Opaleye

makeOpaleyeTextNewtypeInstances :: Name -> Q [Dec]
makeOpaleyeTextNewtypeInstances tyName =
  makeOpaleyeNewtypeInstances tyName ''PGText [''PGString]

makeOpaleyeNewtypeInstances :: Name -> Name -> [Name] -> Q [Dec]
makeOpaleyeNewtypeInstances tyName targetName derivingNames = do
  let pgName = prefixName "PG" tyName
  map mconcat . sequence $
    [ makePGType tyName targetName derivingNames
    , [d| -- this is a QuasiQuoter
        instance Default Constant $(TH.conT tyName) (Column $(TH.conT pgName)) where
          def = dimap
            (view _Wrapped)
            (unsafeCoerceColumn :: Column $(TH.conT targetName) -> Column $(TH.conT pgName))
            def
        |]
    , [d|
        instance FromField $(TH.conT tyName) where
          fromField f bs = view _Unwrapped <$> fromField f bs
        |]
    , makeQueryRunnerColumnDefault tyName pgName ]
  • QuasiQuoters

Example 1: Opaleye

-- lots of boilerplate
newtype MyType { unMyType :: Text }
newtype PGMyType = PGMyType { unPGMyType :: PGText }
  deriving (PGString)

makeWrapped ''MyType

instance Default Constant MyType (Column PGMyType) where
  def = dimap (view _Wrapped) (unsafeCoerceColumn :: Column PGText -> Column PGMyType) def
instance FromField MyType where
  fromField f bs = view _Unwrapped <$> fromField f bs
instance QueryRunnerColumnDefault PGMyType MyType where
  queryRunnerColumnDefault = fieldQueryRunnerColumn
newtype MyType { unMyType :: Text }
makeWrapped ''MyType
makeOpaleyeTextNewtypeInstances ''MyType

Example 2: Lens

-- lots of boilerplate
data Foo' bar baz bin = Foo
  { _fooBar :: bar
  , _fooBaz :: baz
  , _fooBin :: bin
  } deriving (Eq, Ord, Show)
type Foo = Foo' () Int Char

makeLenses ''Foo'

class HasFoo r
    where foo :: Lens' r Foo
instance HasFoo Foo where
    where foo = id

(Actually, it's Opaleye again)

Example 2: Lens

makeClassyAlias :: Name -> DecsQ
makeClassyAlias tySyn = do
  let extractTyName = \ case
        AppT (ConT tyName) _ -> pure tyName
        AppT x _ -> extractTyName x
  syn <- reify tySyn >>= \ case
    TyConI (TySynD _ _ s@(AppT _ _)) -> pure s
  tyName <- extractTyName syn
  let rName = mkName "r"
      tySynName = nameBase tySyn
  (className, methodName) <- case tySynName of
    x:xs -> pure (mkName $ "Has" <> tySynName, mkName (charToLower x:xs))
  let alias = ...
  mconcat <$> sequence [ makeLenses tyName, alias ]

(Actually, it's Opaleye again)

  • Using pure constructors (upper case) with reify

Example 2: Lens

(Actually, it's Opaleye again)

-- lots of boilerplate
data Foo' bar baz bin = Foo
  { _fooBar :: bar
  , _fooBaz :: baz
  , _fooBin :: bin
  } deriving (Eq, Ord, Show)
type Foo = Foo' () Int Char

makeLenses ''Foo'

class HasFoo r
    where foo :: Lens' r Foo
instance HasFoo Foo where
    where foo = id

data Foo' bar baz bin = Foo
  { _fooBar :: bar
  , _fooBaz :: baz
  , _fooBin :: bin
  } deriving (Eq, Ord, Show)
type Foo = Foo' () Int Char

makeClassyAlias ''Foo

Example 3: Enumerations

-- lots of boilerplate
data MyEnum = MyEnumFoo | MyEnumBar

instance GEnum MyEnum where
  genum = genumDefault

_MyEnum :: Prism' Text MyEnum
_MyEnum = enumPrismWithPrefix "MyEnum"

instance FromJSON MyEnum where
  parseJSON = enumFromJsonWithPrefix "MyEnum"
instance ToJSON MyEnum where
  toJSON = enumToJsonWithPrefix "MyEnum"
instance ToJSON MyEnum where
  toField = encodeUtf8 . review _MyEnum -- will encode as camel case

(Hint: still Opaleye)

Example 3: Enumerations

makeEnumInstancesUsing :: Q Exp -> Q Exp -> Q Exp -> Name -> Q [Dec]
makeEnumInstancesUsing prismExp toJsonExp fromJsonExp tyName = do
  let base = nameBase tyName
  prismName <- newName $ "_" <> base
  -- 50 more lines

-- ooo000o0o000oo00oooh camelCase
makeEnumInstances :: String -> Name -> Q [Dec]
makeEnumInstances prefix tyName =
  let base = nameBase tyName
      prismExp = [| enumPrismWithPrefix prefix |]
      toJsonExp = [| enumToJsonWithPrefix prefix |]
      fromJsonExp = [| enumFromJsonWithPrefix prefix base |]
  in makeEnumInstancesUsing prismExp toJsonExp fromJsonExp tyName

-- ooo00o0o0o0ooo0oh snake_case
makeSnakeEnumInstances :: String -> Name -> Q [Dec]
makeSnakeEnumInstances prefix tyName =
  let base = nameBase tyName
      prismExp = [| snakeEnumPrismWithPrefix prefix |]
      toJsonExp = [| snakeEnumToJsonWithPrefix prefix |]
      fromJsonExp = [| snakeEnumFromJsonWithPrefix prefix base |]
  in makeEnumInstancesUsing prismExp toJsonExp fromJsonExp tyName

(Hint: still Opaleye)

  • More QuasiQuoters

Example 3: Enumerations

data MyEnum = MyEnumFoo | MyEnumBar
makeEnumInstances "MyEnum" ''MyEnum

(Hint: still Opaleye)

-- lots of boilerplate
data MyEnum = MyEnumFoo | MyEnumBar

instance GEnum MyEnum where
  genum = genumDefault

_MyEnum :: Prism' Text MyEnum
_MyEnum = enumPrismWithPrefix "MyEnum"

instance FromJSON MyEnum where
  parseJSON = enumFromJsonWithPrefix "MyEnum"
instance ToJSON MyEnum where
  toJSON = enumToJsonWithPrefix "MyEnum"
instance ToJSON MyEnum where
  toField = encodeUtf8 . review _MyEnum -- will encode as camel case

When to use template haskell?

  • Opaleye
  • Newtypes
  • Boilerplate functions
  • Boilerplate instances
  • When you have a class of types that all need to satisfy the same feature set

Template Haskell

By dfithian

Made with Slides.com

Template Haskell

  • 363

More from dfithian