TH.hs

{-# LANGUAGE TemplateHaskell #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Newtype.TH
-- Copyright   :  Michael Sloan 2011
--
-- Maintainer  :  Michael Sloan (mgsloan@gmail.com)
-- Portability :  unportable
--
-- 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 Language.Haskell.TH
import Language.Haskell.Meta.Utils (conName, conTypes)

import Control.Newtype (Newtype(pack, unpack))

-- | Derive instances of Newtype, specified as a list of references to newtypes.
mkNewTypes :: [Name] -> Q [Dec]
mkNewTypes = mapM mkInst
  where
    mkInst name = fmap (mkInstH name) $ reify name
    mkInstH name (TyConI (NewtypeD context _ vs con _)) =
      -- Construct the instance declaration
      -- "instance Newtype (<newtype> a ...) (<field type> a ...) where"
      InstanceD context
        (foldl1 AppT [ConT ''Newtype, bndrsToType (ConT name) vs, head $ conTypes con])
        (defs (conName con))
    mkInstH name _ = error $ show name ++ " is not a Newtype"
    defs cname =
      [ FunD 'unpack [Clause [ConP cname [VarP xname]] (NormalB $ VarE xname) []]
      , FunD 'pack   [Clause [] (NormalB (ConE cname)) []]
      ]
    xname = mkName "x"

-- 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 unnecessary, but we might as well.
bndrToType :: TyVarBndr -> Type
bndrToType (PlainTV x) = VarT x
bndrToType (KindedTV x k) = SigT (VarT x) k