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: mail@joachim-breitner.de | ICQ# 74513189 | GPG-Key: 4743206C JID: nomeata@joachim-breitner.de | http://www.joachim-breitner.de/ Debian Developer: nomeata@debian.org