TH.hs

{-# LANGUAGE TemplateHaskell #-}
{- |
This module provides a template Haskell based mechanism for deriving
instances of the Newtype class, defined in Control.Newtype.  Example usage:

> newtype CartesianList a = CartesianList [a]
> $(mkNewTypes [''CartesianList])
>
> instance Monoid (CartesianList a) where
>   mempty = pack [[]]
>   a `mappend` b = pack [x ++ y | x <- unpack a, y <- unpack b]

> *Main> print $ underF CartesianList (\xs -> [fold xs]) ([[[4],[5],[6]], [[1],[2]], [[0]]])
> [[[4,1,0],[4,2,0],[5,1,0],[5,2,0],[6,1,0],[6,2,0]]]
-}
module Control.Newtype.TH (mkNewTypes) where

import Control.Monad (liftM)

import Language.Haskell.TH
import Language.Haskell.Meta.Utils (conName, conTypes)

-- | Derive instances of Newtype, specified as a list of references to newtypes.
mkNewTypes :: [Name] -> Q [Dec]
mkNewTypes = liftM concat . mapM (\n -> reify n >>= return . mkInst)
  where mkInst (TyConI (NewtypeD context name vs con _)) =
          [InstanceD context
          -- Construct the class declaration
          -- "class Newtype (<newtype> a ...) (<field type> a ...) where"
          (AppT (AppT (ConT $ mkName "Control.Newtype.Newtype")
                $ bndrsToType (ConT name) vs)
          . head $ conTypes con)
          (defs (mkName "x") (conName con))]
        mkInst _ = []
        defs xnam cnam =
          [ FunD (mkName "unpack")
             [Clause [ConP cnam [VarP xnam]] (NormalB $ VarE xnam) []]
          , FunD (mkName "pack")
             [Clause [] (NormalB $ (ConE cnam)) []]
          ]

-- Given a root type and a list of type variables, converts for use as
-- parameters to the newtype's type in the instance head.
bndrsToType :: Type -> [TyVarBndr] -> Type
bndrsToType = foldl (\x y -> AppT x $ bndrToType y)

-- This converts a type variable binding to a type.  Preserving kind
-- signatures is probably unecessary, but we might as well.
bndrToType :: TyVarBndr -> Type
bndrToType (PlainTV x) = VarT x
bndrToType (KindedTV x k) = SigT (VarT x) k