{-# LANGUAGE TemplateHaskell #-} module M where import Control.Monad (forM) import Control.Monad.IO.Class import Data.Proxy import Language.Haskell.TH class ExplExists m c where explExists :: Proxy c -> Int -> m Bool class ExplGet m c where explGet :: Int -> m c data A = A Int data B = B Word data Foo = FooA A | FooB B instance ExplExists IO Foo where explExists _ety = undefined instance ExplGet IO Foo where explGet _ety = undefined $(do let tyname = ''Foo info <- reify tyname cons <- case info of TyConI (DataD [] _name [] Nothing cons []) -> return cons fieldname <- newName "x" fmap concat . forM cons $ \con -> case con of NormalC conname [(_, ty)] -> [d| instance ExplExists IO $(pure ty) where explExists _ ety = do val <- explGet ety :: IO $(pure (ConT tyname)) pure $(caseE [| val |] [pure $ Match (ConP conname [] [WildP]) (NormalB (ConE 'True)) [] ,pure $ Match WildP (NormalB (ConE 'False)) []]) instance ExplGet IO $(pure ty) where explGet ety = do val <- explGet ety :: IO $(pure (ConT tyname)) pure $(caseE [| val |] [pure $ Match (ConP conname [] [VarP fieldname]) (NormalB (VarE fieldname)) [] ,pure $ Match WildP (NormalB (AppE (VarE 'error) (LitE (StringL "accessing non-existent component")))) []]) |]) -- Running this locally with -ddump-splices shows that it generates -- the following instances: -- instance ExplExists IO A where -- explExists _ ety_a2WZ -- = do val_a2X0 <- explGet ety_a2WZ :: IO Foo -- pure -- (case val_a2X0 of -- FooA _ -> True -- _ -> False) -- instance ExplGet IO A where -- explGet ety_a2X1 -- = do val_a2X2 <- explGet ety_a2X1 :: IO Foo -- pure -- (case val_a2X2 of -- FooA x_a2WY -> x_a2WY -- _ -> error "accessing non-existent component") -- instance ExplExists IO B where -- explExists _ ety_a2X3 -- = do val_a2X4 <- explGet ety_a2X3 :: IO Foo -- pure -- (case val_a2X4 of -- FooB _ -> True -- _ -> False) -- instance ExplGet IO B where -- explGet ety_a2X5 -- = do val_a2X6 <- explGet ety_a2X5 :: IO Foo -- pure -- (case val_a2X6 of -- FooB x_a2WY -> x_a2WY -- _ -> error "accessing non-existent component")