{-# 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 :: Name -> DecsQ
makeClosedAlpha Name
tyName = do
  
  let valueD :: Name -> m Exp -> m Dec
valueD Name
vName m Exp
e = m Pat -> m Body -> [m Dec] -> m Dec
forall (m :: * -> *).
Quote m =>
m Pat -> m Body -> [m Dec] -> m Dec
valD (Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
vName) (m Exp -> m Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB m Exp
e) []
      -- methods :: [Q Dec]
      methods :: [Q Dec]
methods =
             [
               Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD (String -> Name
mkName String
"aeq'")      [e| \_ctx        -> (==)               |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD (String -> Name
mkName String
"fvAny'")    [e| \_ctx _nfn   -> pure               |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD 'close               [e| \_ctx _b     -> id                 |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD 'open                [e| \_ctx _b     -> id                 |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD 'isPat               [e| \_           -> mempty             |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD 'isTerm              [e| \_           -> mempty             |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD 'nthPatFind          [e| \_           -> mempty             |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD 'namePatFind         [e| \_           -> mempty             |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD (String -> Name
mkName String
"swaps'")    [e| \_ctx _p     -> id                 |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD (String -> Name
mkName String
"freshen'")  [e| \_ctx i      -> return (i, mempty) |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD (String -> Name
mkName String
"lfreshen'") [e| \_ctx i cont -> cont i mempty      |]
             , Name -> Q Exp -> Q Dec
forall {m :: * -> *}. Quote m => Name -> m Exp -> m Dec
valueD (String -> Name
mkName String
"acompare'") [e| \_ctx        -> compare            |]
             ]
  Dec
d <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt []) (Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT [t|Alpha|] (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tyName)) [Q Dec]
methods
  [Dec] -> DecsQ
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
d]