Hi, Am Freitag, den 04.12.2009, 01:00 +0100 schrieb Joachim Breitner: > And just now, after writing half the code, I find out that $( fun > [d|...|] ) runs the type checker on the declarations before passing them > to fun, which of course kills my whole approach here, as only having the > declarations pass through openNewType will make them type check. > > Is there any way to pass declarations to a TH function so that their > names are resolved, but their type is not checked (or, alternatively, > type errors are ignored). > > If not, what would be a sane work-around?
I found one. openNewType now expects a type synonym declaration as the
very first declaration. It will then replace the type synonym by the
given type name in every type signature (which is simple, thanks to
Data.Generics), and change the function definition to wrap and unwarp
the types as needed. So the following actually works now:
$(openNewtype ''Foo [d|
type Foo' = Int
nullFoo :: Foo'
nullFoo = 0
toFoo :: Int -> Foo'
toFoo = id
fromFoo :: Foo' -> Int
fromFoo = id
succFoo :: Foo' -> Foo'
succFoo = succ
addFoo :: Foo' -> Foo' -> Foo'
addFoo a b = a + b
|] )
Given this OpenNewType module:
====================================
{-# LANGUAGE PatternGuards #-}
module OpenNewtype where
import Debug.Trace
import Language.Haskell.TH
import Data.Monoid
import qualified Data.Map as M
import Data.Generics.Schemes
import Data.Generics.Aliases
openNewtype newTypeName declsQ = do
info <- reify newTypeName
(taDecl:decls) <- declsQ
tmpName1 <- newName "x"
tmpName2 <- newName "x"
-- Check if the given type is really a simple newtype
typeAlias <- case taDecl of
TySynD typeAlias [] concreteType -- Could check concrete Type
against newtype
-> return typeAlias
_ -> error $ "openNewType needs a type synosym
declaration as the first declaration\nFirst declaration was: " ++ pprint taDecl
case info of
TyConI (NewtypeD _ _ _ (NormalC constr [(NotStrict,ConT _)]) _)
-> let types = getTypeMap decls
in return $ map
(go constr tmpName1 tmpName2 typeAlias types)
decls
_ -> error $ "openNewType can only handle siple newtype
defined types\nArgument was: " ++ pprint info
where go constr tmpName1 tmpName2 typeAlias types d = case d of
(ValD (VarP name) _ _) -> FunD name [Clause [] (NormalB (wrap
name types)) [d]]
(FunD name _) -> FunD name [Clause [] (NormalB (wrap
name types)) [d]]
(SigD _ _) -> everywhere (mkT (\tn ->
if tn == typeAlias
then newTypeName
else tn)) d
_ -> d
where wrap name types | Just t <- M.lookup name types = wrapCo (VarE
name) t
| otherwise = (VarE name)
-- Short-Circuit if type to be replaced does not occur
wrapCo exp t | not (doesTypeNameOccur typeAlias t)
= exp
wrapCo exp (ConT t)
= inject exp
wrapCo exp (ForallT _ _ t)
= wrapCo exp t
wrapCo exp (VarT _)
= exp
wrapCo exp (TupleT _)
= exp
wrapCo exp (ArrowT)
= exp
wrapCo exp (ListT)
= exp
wrapCo exp (AppT (AppT ArrowT t1) t2)
= LamE [VarP tmpName1] (wrapCo (AppE exp (wrapCon (VarE
tmpName1) t1)) t2)
-- Short-Circuit if type to be replaced does not occur
wrapCon exp t | not (doesTypeNameOccur typeAlias t)
= exp
wrapCon exp (ConT t)
= unwrap exp
wrapCon exp (ForallT _ _ t)
= wrapCo exp t
wrapCon exp (VarT _)
= exp
wrapCon exp (TupleT _)
= exp
wrapCon exp (ArrowT)
= exp
wrapCon exp (ListT)
= exp
wrapCon exp (AppT (AppT ArrowT t1) t2)
= LamE [VarP tmpName1] (wrapCon (AppE exp (wrapCo (VarE
tmpName1) t1)) t2)
inject :: Exp -> Exp
inject e = AppE (ConE constr) e
unwrap :: Exp -> Exp
unwrap e = LetE [ValD (ConP constr [VarP tmpName2]) (NormalB e)
[]] (VarE tmpName2)
getTypeMap :: [Dec] -> M.Map Name Type
getTypeMap = mconcat . map go
where go (SigD name t) = M.singleton name t
go _ = mempty
doesTypeNameOccur tn t = gcount (mkQ False (== tn)) t > 0
====================================
It is missing the functionality to handle occurrences of Foo' in tuples
or lists, and of course it will be hard to handle occurrences of Foo' in
arbitrary data types (Maybe, Data.Map, user defined data types). One
could use "fmap" in these cases and hope that the data type actually is
a Functor (or a Cofunctor in some cases? how to tell?), but this
approach will probably never work for all cases.
One could just use unsafeCoerce, after checking that Foo' and Foo really
refer to the same type (one as a type synonym and one as a newtype).
Would that work? It would at least break if somewhere in the modified
code a type class method is called, where the instances for Foo and Int
differ.
Greetings,
Joachim
--
Joachim "nomeata" Breitner
mail: [email protected] | ICQ# 74513189 | GPG-Key: 4743206C
JID: [email protected] | http://www.joachim-breitner.de/
Debian Developer: [email protected]
signature.asc
Description: Dies ist ein digital signierter Nachrichtenteil
_______________________________________________ Haskell-Cafe mailing list [email protected] http://www.haskell.org/mailman/listinfo/haskell-cafe
