[Haskell-cafe] Re: Implicit newtype unwrapping

[Joachim Breitner]

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 at joachim-breitner.de
  Homepage: http://www.joachim-breitner.de
  ICQ#: 74513189
  Jabber-ID: nomeata at joachim-breitner.de
-------------- next part --------------
A non-text attachment was scrubbed...
Name: not available
Type: application/pgp-signature
Size: 198 bytes
Desc: Dies ist ein digital signierter Nachrichtenteil
Url : http://www.haskell.org/pipermail/haskell-cafe/attachments/20091203/440099e2/attachment.bin