TH.hs

{-# OPTIONS_HADDOCK show-extensions #-}
-- |
-- Module     : Unbound.Generics.LocallyNameless.TH
-- Copyright  : (c) 2015, Aleksey Kliger
-- License    : BSD3 (See LICENSE)
-- Maintainer : Aleksey Kliger
-- Stability  : experimental
--
-- Template Haskell methods to construct instances of 'Alpha' for
-- datatypes that don't contain any names and don't participate in
-- 'Alpha' operations in any non-trivial way.
{-# LANGUAGE TemplateHaskell #-}
module Unbound.Generics.LocallyNameless.TH (makeClosedAlpha) where
import Language.Haskell.TH

import Control.Applicative (Applicative(..))
import Data.Monoid (Monoid(..))
import Unbound.Generics.LocallyNameless.Alpha (Alpha(..))

-- | Make a trivial @instance 'Alpha' T@ for a type @T@ that does not
-- contain any bound or free variable names
-- (or any in general any values that are themselves non-trivial
-- instances of 'Alpha').  Use this to write 'Alpha' instances for
-- types that you don't want to traverse via their @GHC.Generics.Rep@
-- representation just to find out that there aren't any names.
--
--
-- @
-- newtype T = T Int deriving (Eq, Ord, Show)
-- $(makeClosedAlpha T)
-- -- constructs
-- -- instance Alpha T where
-- --   aeq' _ = (==)
-- --   acompare' _ = compare
-- --   fvAny' _ _ = pure
-- --   close _ _ = id
-- --   open _ _ = id
-- --   isPat _ = mempty
-- --   isTerm _ = mempty
-- --   nthPatFind _ = mempty
-- --   namePatFind _ _ = mempty
-- --   swaps' _ _ = id
-- --   freshen' _ i = return (i, mempty)
-- --   lfreshen' _ i cont = cont i mempty
-- @
--
makeClosedAlpha :: Name -> DecsQ
makeClosedAlpha tyName = do
  
  let valueD vName e = valD (varP vName) (normalB e) []
      -- methods :: [Q Dec]
      methods =
             [
               valueD (mkName "aeq'")      [e| \_ctx        -> (==)               |]
             , valueD (mkName "fvAny'")    [e| \_ctx _nfn   -> pure               |]
             , valueD 'close               [e| \_ctx _b     -> id                 |]
             , valueD 'open                [e| \_ctx _b     -> id                 |]
             , valueD 'isPat               [e| \_           -> mempty             |]
             , valueD 'isTerm              [e| \_           -> mempty             |]
             , valueD 'nthPatFind          [e| \_           -> mempty             |]
             , valueD 'namePatFind         [e| \_           -> mempty             |]
             , valueD (mkName "swaps'")    [e| \_ctx _p     -> id                 |]
             , valueD (mkName "freshen'")  [e| \_ctx i      -> return (i, mempty) |]
             , valueD (mkName "lfreshen'") [e| \_ctx i cont -> cont i mempty      |]
             , valueD (mkName "acompare'") [e| \_ctx        -> compare            |]
             ]
  d <- instanceD (cxt []) (appT [t|Alpha|] (conT tyName)) methods
  return [d]