emgm-0.3: src/Generics/EMGM/Derive/Internal.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
-----------------------------------------------------------------------------
-- |
-- Module : Generics.EMGM.Derive.Internal
-- Copyright : (c) 2008, 2009 Universiteit Utrecht
-- License : BSD3
--
-- Maintainer : generics@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- Summary: Internal module with implementation of deriving code. Other EMGM
-- modules should import this instead of the higher-level Derive modules.
-----------------------------------------------------------------------------
module Generics.EMGM.Derive.Internal (
derive,
deriveWith,
Modifier(..),
Modifiers,
deriveMono,
deriveMonoWith,
declareConDescrs,
declareConDescrsWith,
declareEP,
declareEPWith,
declareRepValues,
declareRepValuesWith,
declareMonoRep,
declareMonoRepWith,
deriveRep,
deriveRepWith,
deriveFRep,
deriveFRepWith,
deriveBiFRep,
deriveBiFRepWith,
deriveCollect,
deriveEverywhere,
deriveEverywhere',
module Generics.EMGM.Common,
module Generics.EMGM.Functions.Collect,
module Generics.EMGM.Functions.Everywhere,
) where
-----------------------------------------------------------------------------
-- Imports
-----------------------------------------------------------------------------
import Prelude
import Language.Haskell.TH
import Data.Maybe (catMaybes)
import Generics.EMGM.Derive.Common
import Generics.EMGM.Derive.Functions
-- We ignore these imports for Haddock, because Haddock does not like Template
-- Haskell expressions in many places.
--
-- See http://code.google.com/p/emgm/issues/detail?id=21
--
#ifndef __HADDOCK__
import Generics.EMGM.Derive.ConDescr (mkConDescr)
import Generics.EMGM.Derive.EP (mkEP)
import Generics.EMGM.Derive.Instance
#endif
import Generics.EMGM.Common
import Generics.EMGM.Functions.Collect
import Generics.EMGM.Functions.Everywhere
-----------------------------------------------------------------------------
-- General functions
-----------------------------------------------------------------------------
#ifndef __HADDOCK__
-- | Make the DT and constructor descriptions
declareConDescrsBase :: Modifiers -> Name -> Q (DT, [Dec])
declareConDescrsBase mods typeName = do
info <- reify typeName
case info of
TyConI d ->
case d of
DataD _ name vars cons _ -> mkDT name vars cons
NewtypeD _ name vars con _ -> mkDT name vars [con]
_ -> err
_ -> err
where
mkDT name vars cons =
do pairs <- mapM (normalizeCon mods) cons
let (ncons', cdDecs) = unzip pairs
return (DT name vars cons ncons', concat . catMaybes $ cdDecs)
err = reportError $ showString "Unsupported name \""
. shows typeName
$ "\". Must be data or newtype."
-- | Normalize constructor variants
normalizeCon :: Modifiers -> Con -> Q (NCon, Maybe [Dec])
normalizeCon mods c =
case c of
NormalC name args -> mkNCon name (map snd args)
RecC name args -> mkNCon name (map $(sel 2 3) args)
InfixC argL name argR -> mkNCon name [snd argL, snd argR]
ForallC _ _ con ->
-- It appears that this ForallC may never be reached, because non-Haskell-98
-- constructors can't be reified according to an error received when trying.
do (NCon name _ _ _, _) <- normalizeCon mods con
reportError $ showString "Existential data constructors such as \""
. showString (nameBase name)
$ "\" are not supported."
where
mkNCon name args =
do let maybeCdMod = lookup (nameBase name) mods
(cdName, cdDecs) <- mkConDescr maybeCdMod c
let names = newVarNames args
return (NCon name cdName args names, cdDecs)
-- | For each element in a list, make a new variable name using the character
-- 'v' (arbitrary) and a number.
newVarNames :: [a] -> [Name]
newVarNames = map newVarName . zipWith const [1..]
where
newVarName :: Int -> Name
newVarName = mkName . (:) 'v' . show
--------------------------------------------------------------------------------
declareEPBase :: Modifiers -> DT -> Q (Name, [Dec])
declareEPBase mods dt = do
fromName <- newName "from"
toName <- newName "to"
return (mkEP mods dt fromName toName)
declareRepFunsBase :: Modifiers -> DT -> Name -> Q (RepFunNames, [Dec])
declareRepFunsBase mods dt ep = do
(repFunName, repFunDecs) <- mkRepFun mods OptRep dt ep
(frepFunName, frepFunDecs) <- mkRepFun mods OptFRep dt ep
(frep2FunName, frep2FunDecs) <- mkRepFun mods OptFRep2 dt ep
(frep3FunName, frep3FunDecs) <- mkRepFun mods OptFRep3 dt ep
(bifrep2FunName, bifrep2FunDecs) <- mkRepFun mods OptBiFRep2 dt ep
return
( RepFunNames repFunName frepFunName frep2FunName frep3FunName bifrep2FunName
, repFunDecs ++ frepFunDecs ++ frep2FunDecs ++ frep3FunDecs ++ bifrep2FunDecs
)
deriveRepBase :: DT -> RepFunNames -> Name -> Q [Dec]
deriveRepBase dt funs g =
mkRepInst OptRep funs g dt
deriveFRepBase :: DT -> RepFunNames -> Name -> Q [Dec]
deriveFRepBase dt funs g = do
frepInstDec <- mkRepInst OptFRep funs g dt
frep2InstDec <- mkRepInst OptFRep2 funs g dt
frep3InstDec <- mkRepInst OptFRep3 funs g dt
return (frepInstDec ++ frep2InstDec ++ frep3InstDec)
deriveBiFRepBase :: DT -> RepFunNames -> Name -> Q [Dec]
deriveBiFRepBase dt funs g =
mkRepInst OptBiFRep2 funs g dt
#endif
-----------------------------------------------------------------------------
-- Exported functions
-----------------------------------------------------------------------------
-- | Same as 'derive' except that you can pass a list of name modifications to
-- the deriving mechanism.
--
-- Use @deriveWith@ if:
--
-- (1) You want to use the generated constructor descriptions or
-- embedding-projection pairs /and/ one of your constructors or types is an
-- infix symbol. In other words, if you have a constructor @:*@, you cannot
-- refer to the (invalid) generated name for its description, @con:*@. It
-- appears that GHC has no problem with that name internally, so this is only
-- if you want access to it.
--
-- (2) You want to define your own constructor description. This allows you to
-- give a precise implementation different from the one generated for you.
--
-- For option 1, use 'ChangeTo' as in this example:
--
-- @
-- data U = Int :* Char
-- $(deriveWith [(\":*\", ChangeTo \"Star\")] ''U)
-- x = ... conStar ...
-- @
--
-- For option 2, use 'DefinedAs' as in this example:
--
-- @
-- data V = (:=) { i :: Int, j :: Char }
-- $(deriveWith [(\":=\", DefinedAs \"Equals\")] ''V)
-- conEquals = 'ConDescr' \":=\" 2 [] ('Infix' 4)
-- @
--
-- Using the example for option 2 with "Generics.EMGM.Functions.Show" will print
-- values of @V@ as infix instead of the default record syntax.
--
-- Note that only the first pair with its first field matching the type or
-- constructor name in the 'Modifiers' list will be used. Any other matches will
-- be ignored.
deriveWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
deriveWith mods typeName = do
(dt, conDescrDecs) <- declareConDescrsBase mods typeName
(epName, epDecs) <- declareEPBase mods dt
(funNames, funDecs) <- declareRepFunsBase mods dt epName
g <- newName "g"
repInstDecs <- deriveRepBase dt funNames g
higherOrderRepInstDecs <-
case length (tvars dt) of
1 -> deriveFRepBase dt funNames g
2 -> deriveBiFRepBase dt funNames g
_ -> return []
collectInstDec <- mkRepCollectInst dt
everywhereInstDec <- mkRepEverywhereInst dt
everywhereInstDec' <- mkRepEverywhereInst' dt
return $
conDescrDecs ++
epDecs ++
funDecs ++
repInstDecs ++
higherOrderRepInstDecs ++
[collectInstDec
,everywhereInstDec
,everywhereInstDec'
]
#else
deriveWith = undefined
#endif
-- | Derive all appropriate instances for using EMGM with a datatype.
--
-- Here is an example module that shows how to use @derive@:
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > {-# LANGUAGE MultiParamTypeClasses #-}
-- > {-# LANGUAGE FlexibleContexts #-}
-- > {-# LANGUAGE FlexibleInstances #-}
-- > {-# LANGUAGE OverlappingInstances #-}
-- > {-# LANGUAGE UndecidableInstances #-}
--
-- @
-- module Example where
-- import "Generics.EMGM.Derive"
-- data T a = C a 'Int'
-- @
--
-- @
-- $(derive ''T)
-- @
--
-- The Template Haskell @derive@ declaration in the above example generates the
-- following (annotated) code:
--
-- @
-- -- (1) Constructor description declarations
-- @
--
-- @
-- conC :: 'ConDescr'
-- conC = 'ConDescr' \"C\" 2 [] 'Nonfix'
-- @
--
-- @
-- -- (2) Embedding-projection pair declaration
-- @
--
-- @
-- epT :: 'EP' (T a) (a :*: 'Int')
-- epT = 'EP' fromT toT
-- where fromT (C v1 v2) = v1 :*: v2
-- toT (v1 :*: v2) = C v1 v2
-- @
--
-- @
-- -- (3) Representation values
-- @
--
-- @
-- repT :: ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => g (T a)
-- repT = 'rtype' epT ('rcon' conC ('rprod' 'rep' 'rep'))
-- @
--
-- @
-- frepT :: ('Generic' g) => g a1 -> g (T a1)
-- frepT a = 'rtype' epT ('rcon' conC ('rprod' a 'rint'))
-- @
--
-- @
-- frep2T :: ('Generic2' g) => g a1 a2 -> g (T a1) (T a2)
-- frep2T a = 'rtype2' epT epT ('rcon2' conC ('rprod2' a 'rint2'))
-- @
--
-- @
-- frep3T :: ('Generic3' g) => g a1 a2 a3 -> g (T a1) (T a2) (T a3)
-- frep3T a = 'rtype3' epT epT epT ('rcon3' conC ('rprod3' a 'rint3'))
-- @
--
-- @
-- bifrep2T :: ('Generic2' g) => g a1 a2 -> g (T a1) (T a2)
-- bifrep2T a = 'rtype2' epT epT ('rcon2' conC ('rprod2' a 'rint2'))
-- @
--
-- @
-- -- (4) Representation instances
-- @
--
-- @
-- instance ('Generic' g, 'Rep' g a, 'Rep' g 'Int') => 'Rep' g (T a) where
-- 'rep' = repT
-- @
--
-- @
-- instance ('Generic' g) => 'FRep' g T where
-- 'frep' = frepT
-- @
--
-- @
-- instance ('Generic2' g) => 'FRep2' g T where
-- 'frep2' = frep2T
-- @
--
-- @
-- instance ('Generic3' g) => 'FRep3' g T where
-- 'frep3' = frep3T
-- @
--
-- @
-- -- In this case, no instances for 'BiFRep2' is generated, because T is not
-- -- a bifunctor type; however, the bifrep2T value is always generated in
-- -- case T is used in a bifunctor type.
-- @
--
-- @
-- -- (5) Generic function-specific instances
-- @
--
-- @
-- instance 'Rep' ('Collect' (T a)) (T a) where
-- 'rep' = 'Collect' (\\x -> [x])
-- @
--
-- @
-- instance ('Rep' ('Everywhere' (T a)) a, 'Rep' ('Everywhere' (T a)) 'Int')
-- => 'Rep' ('Everywhere' (T a)) (T a) where
-- 'rep' = 'Everywhere' (\\f x ->
-- case x of
-- C v1 v2 -> f (C ('selEverywhere' 'rep' f v1) ('selEverywhere' 'rep' f v2))
-- @
--
-- @
-- instance 'Rep' ('Everywhere'' (T a)) (T a) where
-- 'rep' = 'Everywhere'' (\\f x -> f x)
-- @
--
-- Note that all the values are top-level. This allows them to be shared between
-- multiple instances. For example, if you have two mutually recursive functor
-- datatypes, you may need to have each other's derived code in scope.
derive :: Name -> Q [Dec]
derive = deriveWith []
--------------------------------------------------------------------------------
-- | Same as 'declareConDescrs' except that you can pass a list of name
-- modifications to the deriving mechanism. See 'deriveWith' for an example.
declareConDescrsWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
declareConDescrsWith mods typeName = do
(_, conDescrDecs) <- declareConDescrsBase mods typeName
return conDescrDecs
#else
declareConDescrsWith = undefined
#endif
-- | Generate declarations of 'ConDescr' values for all constructors in a type.
-- See 'derive' for an example.
declareConDescrs :: Name -> Q [Dec]
declareConDescrs = declareConDescrsWith []
--------------------------------------------------------------------------------
-- | Same as 'declareEP' except that you can pass a list of name modifications
-- to the deriving mechanism. See 'deriveWith' for an example.
declareEPWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
declareEPWith mods typeName = do
(dt, _) <- declareConDescrsBase mods typeName
(_, epDecs) <- declareEPBase mods dt
return epDecs
#else
declareEPWith = undefined
#endif
-- | Generate declarations of 'EP' values for a type. See 'derive' for an
-- example.
declareEP :: Name -> Q [Dec]
declareEP = declareEPWith []
--------------------------------------------------------------------------------
-- | Same as 'declareMonoRep' except that you can pass a list of name
-- modifications to the deriving mechanism. See 'deriveWith' for an example.
declareMonoRepWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
declareMonoRepWith mods typeName = do
(dt, _) <- declareConDescrsBase mods typeName
(ep, _) <- declareEPBase mods dt
(_, repFunDecs) <- mkRepFun mods OptRep dt ep
return repFunDecs
#else
declareMonoRepWith = undefined
#endif
-- | Generate the declaration of a monomorphic representation value for a type.
-- This is the value used for 'rep' in an instance of 'Rep'. The difference with
-- 'declareRepValues' is that 'declareRepValues' generates generates all
-- representation values (including 'frep', 'frep2', etc.). See 'derive' for an
-- example.
declareMonoRep :: Name -> Q [Dec]
declareMonoRep = declareMonoRepWith []
--------------------------------------------------------------------------------
-- | Same as 'declareRepValues' except that you can pass a list of name
-- modifications to the deriving mechanism. See 'deriveWith' for an example.
declareRepValuesWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
declareRepValuesWith mods typeName = do
(dt, _) <- declareConDescrsBase mods typeName
(ep, _) <- declareEPBase mods dt
(_, funDecs) <- declareRepFunsBase mods dt ep
return funDecs
#else
declareRepValuesWith = undefined
#endif
-- | Generate declarations of all representation values for a type. These
-- functions are used in 'rep', 'frep', ..., 'bifrep2'.
declareRepValues :: Name -> Q [Dec]
declareRepValues = declareRepValuesWith []
--------------------------------------------------------------------------------
-- | Same as 'deriveRep' except that you can pass a list of name modifications
-- to the deriving mechanism. See 'deriveWith' for an example.
deriveRepWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
deriveRepWith mods typeName = do
(dt, _) <- declareConDescrsBase mods typeName
(ep, _) <- declareEPBase mods dt
(funNames, _) <- declareRepFunsBase mods dt ep
g <- newName "g"
repInstDecs <- deriveRepBase dt funNames g
return repInstDecs
#else
deriveRepWith = undefined
#endif
-- | Generate 'Rep' instance declarations for a type. See 'derive' for an
-- example.
deriveRep :: Name -> Q [Dec]
deriveRep = deriveRepWith []
--------------------------------------------------------------------------------
-- | Same as 'deriveMono' except that you can pass a list of name
-- modifications to the deriving mechanism. See 'deriveWith' for an example.
deriveMonoWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
deriveMonoWith mods typeName = do
(dt, conDescrDecs) <- declareConDescrsBase mods typeName
(epName, epDecs) <- declareEPBase mods dt
(repFunName, repFunDecs) <- mkRepFun mods OptRep dt epName
let funNames = RepFunNames repFunName undefined undefined undefined undefined
g <- newName "g"
repInstDecs <- deriveRepBase dt funNames g
collectInstDec <- mkRepCollectInst dt
return $
conDescrDecs ++
epDecs ++
repFunDecs ++
repInstDecs ++
[collectInstDec]
#else
deriveMonoWith = undefined
#endif
-- | Same as 'derive' except that only the monomorphic 'Rep' representation
-- value and instance are generated. This is a convenience function that can be
-- used instead of the following declarations:
--
-- @
-- $(declareConDescrs ''T)
-- $(declareEP ''T)
-- $(declareMonoRep ''T)
-- $(deriveRep ''T)
-- $(deriveFRep ''T)
-- $(deriveCollect ''T)
-- @
deriveMono :: Name -> Q [Dec]
deriveMono = deriveMonoWith []
--------------------------------------------------------------------------------
-- | Same as 'deriveFRep' except that you can pass a list of name modifications
-- to the deriving mechanism. See 'deriveWith' for an example.
deriveFRepWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
deriveFRepWith mods typeName = do
(dt, _) <- declareConDescrsBase mods typeName
(epName, _) <- declareEPBase mods dt
(funNames, _) <- declareRepFunsBase mods dt epName
g <- newName "g"
frepInstDecs <- deriveFRepBase dt funNames g
return frepInstDecs
#else
deriveFRepWith = undefined
#endif
-- | Generate 'FRep', 'FRep2', and 'FRep3' instance declarations for a type. See
-- 'derive' for an example.
deriveFRep :: Name -> Q [Dec]
deriveFRep = deriveFRepWith []
--------------------------------------------------------------------------------
-- | Same as 'deriveBiFRep' except that you can pass a list of name
-- modifications to the deriving mechanism. See 'deriveWith' for an example.
deriveBiFRepWith :: Modifiers -> Name -> Q [Dec]
#ifndef __HADDOCK__
deriveBiFRepWith mods typeName = do
(dt, _) <- declareConDescrsBase mods typeName
(epName, _) <- declareEPBase mods dt
(funNames, _) <- declareRepFunsBase mods dt epName
g <- newName "g"
bifrepInstDecs <- deriveBiFRepBase dt funNames g
return bifrepInstDecs
#else
deriveBiFRepWith = undefined
#endif
-- | Generate 'BiFRep2' instance declarations for a type. See 'derive' for an
-- example.
deriveBiFRep :: Name -> Q [Dec]
deriveBiFRep = deriveBiFRepWith []
--------------------------------------------------------------------------------
-- | Generate a @'Rep' 'Collect' T@ instance declaration for a type @T@. See
-- 'derive' for an example.
deriveCollect :: Name -> Q [Dec]
#ifndef __HADDOCK__
deriveCollect typeName = do
(dt, _) <- declareConDescrsBase [] typeName
collectInstDec <- mkRepCollectInst dt
return [collectInstDec]
#else
deriveCollect = undefined
#endif
--------------------------------------------------------------------------------
-- | Generate a @'Rep' 'Everywhere' T@ instance declaration for a type @T@. See
-- 'derive' for an example.
deriveEverywhere :: Name -> Q [Dec]
#ifndef __HADDOCK__
deriveEverywhere typeName = do
(dt, _) <- declareConDescrsBase [] typeName
everywhereInstDec <- mkRepEverywhereInst dt
return [everywhereInstDec]
#else
deriveEverywhere = undefined
#endif
-- | Generate a @'Rep' 'Everywhere'' T@ instance declaration for a type @T@. See
-- 'derive' for an example.
deriveEverywhere' :: Name -> Q [Dec]
#ifndef __HADDOCK__
deriveEverywhere' typeName = do
(dt, _) <- declareConDescrsBase [] typeName
everywhereInstDec' <- mkRepEverywhereInst' dt
return [everywhereInstDec']
#else
deriveEverywhere' = undefined
#endif