.Class Import Magic.md

Class import magic

Demonstrate how to get things to magically happen when you import instances of a class.

First.hs

{-# Language TemplateHaskell #-}

module First () where

import Test

testCase "First" [| putStrLn "First" |]

Main.hs

{-# LANGUAGE TemplateHaskell, TypeApplications #-}

module Main where

import Test
import First
import Second
import Data.Foldable

import qualified Data.Map as M

table :: M.Map String (IO ())
table = $(makeTestableTable)

main :: IO ()
main = do
    for_ (M.assocs table) $ \(key, action) -> do
        putStrLn $ key ++ ":"
        action
        putStrLn ""

Second.hs

{-# LANGUAGE TemplateHaskell #-}

module Second () where

import Test

testCase "Second" [| putStrLn "Second" |]

testCase "Alt" [| do putStrLn "Type something then hit enter"
                     msg <- getLine
                     putStrLn $ "Oh no!! You weren't supposed to type " ++ msg
                |]

Test.hs

{-# LANGUAGE TemplateHaskell, TypeApplications, LambdaCase, AllowAmbiguousTypes #-}

module Test where

import Language.Haskell.TH
import Data.Traversable
import qualified Data.Map as M

class Testable a where
    test :: IO ()

makeTestableTable :: Q Exp
makeTestableTable = do
    insts <- reifyInstances ''Testable ([VarT (mkName "a")])
    let exprs = flip map insts $ \case
            InstanceD _ _ ty _ -> do
                let AppT _ t = ty
                    ConT n = t
                [| ( $(stringE $ show n), test @($(pure t))) |]
            x -> fail $ show x ++ " wasn't expected in makeTestableTable"

    [| M.fromList $(listE exprs) |]

-- The String passed in must be a valid, available type name within the module.
-- This is not handled with an explicit error message from a check in this
-- function because I was being lazy with a proof of concept.
testCase :: String -> Q Exp -> Q [Dec]
testCase nameS exp = do
    let name = mkName nameS
        tyDec = DataD [] name [] Nothing [NormalC name []] []
    (tyDec :) <$> [d| instance Testable $(conT name) where test = $(exp) |]

~session.txt

$ ghc Main.hs
[1 of 4] Compiling Test             ( Test.hs, Test.o )
[2 of 4] Compiling Second           ( Second.hs, Second.o )
[3 of 4] Compiling First            ( First.hs, First.o )
[4 of 4] Compiling Main             ( Main.hs, Main.o )
Linking Main ...
$ ./Main
First.First:
First

Second.Alt:
Type something then hit enter
hdf
Oh no!! You weren't supposed to type hdf

Second.Second:
Second