Skip to content
Snippets Groups Projects

GHC.Generics API for TH

  • Clone with SSH
  • Clone with HTTPS
  • Embed
  • Share
    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

    Edited
    Language.Haskell.TH.Generics.hs 2.58 KiB
    {-# 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.Haskell.TH.Test.hs 527 B
    {-# 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))))"
    0% Loading or .
    You are about to add 0 people to the discussion. Proceed with caution.
    Finish editing this message first!
    Please register or to comment