Hi, Am Donnerstag, den 03.12.2009, 22:39 +0100 schrieb Joachim Breitner:
Nice, and close. It seems it does not handle the datatype in arbitrary positions in the type (as in Foo -> ( a -> Either Foo ())) -> (Foo, ())). But thanks for the pointer. Maybe I should give it a shot.
I started to write a module. My (incomplete!) code looks like this: ===================================================== {-# LANGUAGE PatternGuards #-} module OpenNewtype (openNewType) where import Debug.Trace import Language.Haskell.TH import Data.Monoid import qualified Data.Map as M openNewtype typeName declsQ = do info <- reify typeName decls <- declsQ tmpName1 <- newName "x" tmpName2 <- newName "x" -- Check if the given type is really a simple newtype case info of TyConI (NewtypeD _ _ _ (NormalC constr [(NotStrict,ConT realType)]) _) -> let types = getTypeMap decls in return $ map (go constr tmpName2 tmpName2 realType types) decls _ -> error $ "openNewType can only handle siple newtype defined types\nArgument was: " ++ pprint info where go constr tmpName1 tmpName2 realType 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]] _ -> d where wrap name types | Just t <- M.lookup name types = wrapCo (VarE name) t | otherwise = (VarE name) wrapCo exp (ConT t) | t == typeName = inject exp | otherwise = 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) wrapCon exp (ConT t) | t == typeName = unwrap exp | otherwise = 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 ===================================================== And the intended usage would be ===================================================== {-# LANGUAGE TemplateHaskell #-} import OpenNewtype newtype Foo = Foo Int deriving Show $(openNewtype ''Foo [d| 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 |] ) main = do print (succFoo (Foo 1)) ===================================================== And indeed, it works for null, succFoo, addFoo. The generated code looks like this, for example for succfoo: succFoo :: Main.Foo -> Main.Foo succFoo = \ x[a28u] -> Main.Foo (succFoo (let Main.Foo x[a28v] = x[a28u] in x[a28v])) where succFoo = GHC.Enum.succ But when I uncommented the definition of toFoo and fromfoo, I got: Demo.hs:11:9: Couldn't match expected type `Foo' against inferred type `Int' In the expression: id In the definition of `toFoo': toFoo = id In the second argument of `openNewtype', namely `[d| nullFoo :: Foo nullFoo = 0 toFoo :: Int -> Foo toFoo = id .... |]' 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? Greetings, Joachim -- Joachim Breitner e-Mail: mail@joachim-breitner.de Homepage: http://www.joachim-breitner.de ICQ#: 74513189 Jabber-ID: nomeata@joachim-breitner.de