GHC.Generics API for TH
The snippet can be accessed without any authentication.
Authored by
Sebastian Graf
This is the begin of an early prototype for a Generics-inspired library for TH
{-# LANGUAGE LambdaCase #-}
module Language.Haskell.TH.Generics where
import Language.Haskell.TH
import Data.Maybe
import Control.Monad.Trans.Maybe
import Control.Applicative ( Alternative(empty) )
import Control.Monad.Trans.Class
import Data.List (findIndex)
data Meta
= MetaData { meta_name :: Name, meta_newtype :: Bool }
| MetaCons { meta_name :: Name, meta_fixity :: Maybe Fixity {- Nothing <=> not declared infix -}, meta_record_sels :: Bool }
| MetaSel -- TODO
deriving (Eq, Show)
data Rep
= Meta Meta Rep
| Unit
| Void
| Par Int
| Const Type
| Rep :+: Rep
| Rep :*: Rep
deriving (Eq, Show)
sumRep :: [Rep] -> Rep
sumRep [] = Void
sumRep reps = foldr1 (:+:) reps
productRep :: [Rep] -> Rep
productRep [] = Unit
productRep reps = foldr1 (:*:) reps
reifyRep :: Name -> Q (Maybe Rep)
reifyRep name = reify name >>= runMaybeT . \case
TyConI (DataD _ctx name bndrs _mb_ki cons _derivs) -> do
reps <- traverse (conRep name bndrs) cons
pure (Meta (MetaData name False) (sumRep reps))
TyConI (NewtypeD _ctx name bndrs _mb_ki con _derivs) -> do
rep <- conRep name bndrs con
pure (Meta (MetaData name True) rep)
-- (PrimTyConI dec) = _
-- (FamilyI dec) = _
_ -> empty
conRep :: Name -> [TyVarBndr vis] -> Con -> MaybeT Q Rep
conRep tc_name bndrs con = case con of
NormalC dc_name fields -> do
reps <- traverse (anonFieldRep tc_name bndrs) fields
pure (Meta (MetaCons dc_name Nothing False)
(productRep reps))
RecC dc_name fields -> do
reps <- traverse (recordFieldRep tc_name bndrs) fields
pure (Meta (MetaCons dc_name Nothing True)
(productRep reps))
InfixC l dc_name r -> do
rep_l <- anonFieldRep tc_name bndrs l
mb_fixity <- lift $ reifyFixity dc_name
rep_r <- anonFieldRep tc_name bndrs r
pure (Meta (MetaCons dc_name (Just (fromMaybe defaultFixity mb_fixity)) False)
(productRep [rep_l, rep_r]))
GadtC{} -> empty
RecGadtC{} -> empty
ForallC{} -> empty
recordFieldRep :: Name -> [TyVarBndr vis] -> VarBangType -> MaybeT Q Rep
recordFieldRep tc_name bndrs (sel, bang, ty) = Meta MetaSel <$> fieldRep tc_name bndrs ty
anonFieldRep :: Name -> [TyVarBndr vis] -> BangType -> MaybeT Q Rep
anonFieldRep tc_name bndrs (bang, ty) = Meta MetaSel <$> fieldRep tc_name bndrs ty
binds :: Name -> TyVarBndr flag -> Bool
binds v (PlainTV n _) = n == v
binds v (KindedTV n _ _) = n == v
fieldRep :: Name -> [TyVarBndr vis] -> Type -> MaybeT Q Rep
fieldRep tc_name bndrs (VarT v) | Just n <- findIndex (binds v) bndrs = pure (Par n) -- TODO wrong for Rep0
fieldRep tc_name bndrs ty = pure (Const ty)
{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.TH.Test where
import Language.Haskell.TH
import Language.Haskell.TH.Generics
bar :: String
bar = $(do info <- reifyRep ''Maybe; litE (StringL (show info)))
-- bar = "Just (Meta (MetaData {meta_name = GHC.Maybe.Maybe, meta_newtype = False}) (Meta (MetaCons {meta_name = GHC.Maybe.Nothing, meta_fixity = Nothing, meta_record_sels = False}) Unit :+: Meta (MetaCons {meta_name = GHC.Maybe.Just, meta_fixity = Nothing, meta_record_sels = False}) (Meta MetaSel (Par 0))))"
Please register or sign in to comment