30 lines
752 B
Haskell
30 lines
752 B
Haskell
{-# LANGUAGE NoImplicitPrelude
|
|
, TemplateHaskell
|
|
, QuasiQuotes
|
|
, RecordWildCards
|
|
#-}
|
|
|
|
module Jobs.TH
|
|
( dispatchTH
|
|
) where
|
|
|
|
import ClassyPrelude
|
|
|
|
import Language.Haskell.TH
|
|
import Language.Haskell.TH.Datatype
|
|
|
|
import Data.List (foldl)
|
|
|
|
|
|
dispatchTH :: Name -- ^ Datatype to pattern match
|
|
-> ExpQ
|
|
dispatchTH dType = do
|
|
DatatypeInfo{..} <- reifyDatatype dType
|
|
let
|
|
matches = map mkMatch datatypeCons
|
|
mkMatch ConstructorInfo{..} = do
|
|
pats <- forM constructorFields $ \_ -> newName "x"
|
|
let fName = mkName $ "dispatch" <> nameBase constructorName
|
|
match (conP constructorName $ map varP pats) (normalB $ foldl (\e pat -> e `appE` varE pat) (varE fName) pats) []
|
|
lamCaseE matches
|