emgm-0.3: src/Generics/EMGM/Derive/Instance.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
-----------------------------------------------------------------------------
-- |
-- Module : Generics.EMGM.Derive
-- Copyright : (c) 2008, 2009 Universiteit Utrecht
-- License : BSD3
--
-- Maintainer : generics@haskell.org
-- Stability : experimental
-- Portability : non-portable
--
-- Summary: Code for generating the representation dispatcher class instances in
-- TH.
-----------------------------------------------------------------------------
module Generics.EMGM.Derive.Instance (
#ifndef __HADDOCK__
RepOpt(..),
RepFunNames(..),
mkRepFun,
mkRepInst,
#endif
) where
#ifndef __HADDOCK__
-----------------------------------------------------------------------------
-- Imports
-----------------------------------------------------------------------------
import Data.List (transpose)
import Language.Haskell.TH
import Generics.EMGM.Derive.Common
-----------------------------------------------------------------------------
-- Types
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- General functions
-----------------------------------------------------------------------------
repStr :: RepOpt -> String
repStr OptRep = "rep"
repStr OptFRep = "frep"
repStr OptFRep2 = "frep2"
repStr OptFRep3 = "frep3"
repStr OptBiFRep2 = "bifrep2"
-- | Handle the renaming of the functions for the built-in symbol types.
symbolMods :: Modifiers
symbolMods =
[ ("[]",ChangeTo "List")
, ("()",ChangeTo "Tuple0")
, ("(,)",ChangeTo "Tuple2")
, ("(,,)",ChangeTo "Tuple3")
, ("(,,,)",ChangeTo "Tuple4")
, ("(,,,,)",ChangeTo "Tuple5")
, ("(,,,,,)",ChangeTo "Tuple6")
, ("(,,,,,,)",ChangeTo "Tuple7")
]
toFunName :: Modifiers -> RepOpt -> Name -> Name
toFunName mods opt nm =
mkName (repStr opt ++ result)
where
str = nameBase nm
result =
case toMaybeString (lookup str (mods ++ symbolMods)) of
Nothing -> str
Just newStr -> newStr
primRepName :: Name -> RepOpt -> Maybe Name
primRepName typ opt =
case nameBase typ of
"Int" -> Just (rintN opt)
"Integer" -> Just (rintegerN opt)
"Float" -> Just (rfloatN opt)
"Double" -> Just (rdoubleN opt)
"Char" -> Just (rcharN opt)
_ -> Nothing
typSyn :: Name -> Q (Maybe Type)
typSyn typ = do
info <- reify typ
case info of
TyConI dec ->
case dec of
TySynD _ _ unSynTyp ->
return (Just unSynTyp)
_ ->
return Nothing
_ ->
return Nothing
typeUnknownError :: Int -> RepOpt -> Type -> Q a
typeUnknownError i opt t = do
error $ "Error #" ++ show i ++ ": Unsupported type for " ++ show opt ++ ": " ++ show t
-- | Produce the variable expression for the appropriate 'rep', 'frep', etc.
varRepExp :: Modifiers -> RepOpt -> DT -> Type -> Q Exp
varRepExp mods opt dt =
caseRep opt (varE (repN opt)) . go
where
typE nm = varE (toFunName mods opt nm)
appFun t = foldl appE (typE t) . map go
go t =
case t of
VarT v ->
if v `elem` tvars dt then varE v else typeUnknownError 34 opt t
ConT typ ->
case primRepName typ opt of
Just nm ->
varE nm
Nothing -> do
mts <- typSyn typ
case mts of
Just ts -> go ts
Nothing -> varE (toFunName mods opt typ)
AppT (ConT typ) a ->
appFun typ [a]
AppT (AppT (ConT typ) a1) a2 ->
appFun typ [a1,a2]
AppT (AppT (AppT (ConT typ) a1) a2) a3 ->
appFun typ [a1,a2,a3]
AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4 ->
appFun typ [a1,a2,a3,a4]
AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5 ->
appFun typ [a1,a2,a3,a4,a5]
AppT (AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5) a6 ->
appFun typ [a1,a2,a3,a4,a5,a6]
AppT (AppT (AppT (AppT (AppT (AppT (AppT (ConT typ) a1) a2) a3) a4) a5) a6) a7 ->
appFun typ [a1,a2,a3,a4,a5,a6,a7]
_ ->
typeUnknownError 50 opt t
-- | Construct the expression for the appropriate 'rtype', 'rtype2', etc.
rtypeE :: RepOpt -> Name -> Q Exp -> Q Exp
rtypeE opt epName sopE =
caseGen opt (appToSop ep1) (appToSop ep2) (appToSop ep3)
where
appToEp e = appE e (varE epName)
appToSop eps = appE eps sopE
ep1 = appToEp (varE (rtypeN opt))
ep2 = appToEp ep1
ep3 = appToEp ep2
--------------------------------------------------------------------------------
-- | Construct the sum-of-product expression for the appropriate 'rep', 'frep',
-- 'frep2', etc.
repSopE :: Modifiers -> RepOpt -> DT -> Q Exp
repSopE mods opt dt =
mkSopDT inject unit mkSum mkProd wrapProd dt
where
inject = varRepExp mods opt dt
mkSum = appE . appE (varE (rsumN opt))
mkProd = appE . appE (varE (rprodN opt))
unit = varE (runitN opt)
wrapProd ncon = appE (appE (varE (rconN opt)) (varE (cdescr ncon)))
-- | The number of generic type variables in the representation.
genTypeVars :: RepOpt -> Int
genTypeVars opt = caseGen opt 1 2 3
-- | Make the signature return type given a @g@ type variable, a type name, and
-- a list of list of parameters. The list of parameters is arranged in the order
-- for the function arguments, so it must be transposed.
mkSigReturnT :: RepOpt -> Q Type -> Name -> [[Name]] -> Q Type
mkSigReturnT opt gvar typ =
foldl appT gvar . map (mkAppliedType' typ) . fillNil . transpose
where
fillNil [] = replicate (genTypeVars opt) []
fillNil xs = xs
-- | Make the representation function signature.
mkRepFunSigT :: RepOpt -> DT -> Q Type
mkRepFunSigT opt dt = do
-- The Generic class parameter
let gname = mkName "g"
let gvar = varT gname
-- Build a list of lists of type variable names. Each sublist is the set of
-- parameters to each 'g' type in the function arguments. For 'rep', we keep
-- the original type variable list, because it's also used in the context.
let mkVarNameList _ c = map (\i -> mkName (c:show i)) [1..genTypeVars opt]
let varNameLists =
caseRep opt
(map (:[]) (tvars dt))
(zipWith mkVarNameList (tvars dt) ['a'..])
-- Type variables for this function signature
let vars = gname : concat varNameLists
-- Build a list of argument types using the variable name list of lists from
-- above.
let mkArrArgs as = appT arrowT (foldl appT gvar (map varT as))
let args = caseRep opt [] (map mkArrArgs varNameLists)
-- The return type
let retTyp = mkSigReturnT opt gvar (tname dt) varNameLists
-- Combine the return type with the argument types to get the final signature.
let typ = foldr appT retTyp args
-- Context with class constraints
let ctx = mkRepInstCxt opt gvar dt
-- Done!
forallT vars ctx typ
-- | Make the representation functions, e.g. 'repMaybe', 'frepMaybe',
-- 'frep2Maybe', 'frep3Maybe', and 'bifrep2Maybe'
mkRepFun :: Modifiers -> RepOpt -> DT -> Name -> Q (Name, [Dec])
mkRepFun mods opt dt ep = do
-- Name of function
let nm = toFunName mods opt (tname dt)
-- Signature of function
sig <- sigD nm (mkRepFunSigT opt dt)
-- Value of function
let bodyExp = rtypeE opt ep (repSopE mods opt dt)
let args = caseRep opt [] (map varP (tvars dt))
fun <- funD nm [clause args (normalB bodyExp) []]
return (nm, [sig, fun])
--return (nm, [])
-----------------------------------------------------------------------------
-- Exported Functions
-----------------------------------------------------------------------------
-- | Make the instance for a representation type class
mkRepInst :: RepOpt -> RepFunNames -> Name -> DT -> Q [Dec]
mkRepInst opt funs g dt = do
let body = varE (funName opt funs)
let dec = valD (varP (repN opt)) (normalB body) []
let gvar = varT g
let ctx = mkRepInstCxt opt gvar dt
let typ = mkRepInstT opt dt gvar
inst <- instanceD ctx typ [dec]
return [inst]
#endif