TH.hs

{-# LANGUAGE TemplateHaskell #-}

{- |

Module      :  Type.Spine.TH
Copyright   :  (c) The University of Kansas 2011
License     :  BSD3

Maintainer  :  nicolas.frisby@gmail.com
Stability   :  experimental
Portability :  see LANGUAGE pragmas (... GHC)

Template Haskell in support of the spine-view on types.

-}
module Type.Spine.TH where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax



-- | A TemplateHaskell-lifter for 'NameG's.
liftNameG :: Name -> Q Exp
liftNameG n = do
  TyConI (DataD _ (Name occ (NameG _ pkg mod)) _ _ _) <- reify n
  [| mkNameG_tc $(stringE $ pkgString pkg) $(stringE $ modString mod) $(stringE $ occString occ) |]


-- | Returns the kinds of a type constructor's type paratemers and range.
tyConSignature :: Name -> Q ([Kind], Kind)
tyConSignature n = do
  let bad = fail "Type.Spine.TH.tyConSignature expects the name of a data/newtype/data family"
  i <- reify n
  case i of
    TyConI dec -> case dec of
      DataD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarK)
      NewtypeD _ _ tvbs _ _ -> return (map tvb_kind tvbs, StarK)
      FamilyD DataFam _ tvbs mk -> return (map tvb_kind tvbs, maybe StarK (peel tvbs) mk)
        where peel [] k = k
              peel (_ : l) (ArrowK _ r) = peel l r
              peel _ _ = error "Type.Spine.TH: bad FamilyD kind"
      _ -> bad
    PrimTyConI _ i _ -> return (replicate i StarK, StarK)
    _ -> bad

tvb_kind :: TyVarBndr -> Kind
tvb_kind (PlainTV _) = StarK
tvb_kind (KindedTV _ k) = k