[Haskell-cafe] Re: Implicit newtype unwrapping

[Joachim Breitner]

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 at joachim-breitner.de | ICQ# 74513189 | GPG-Key: 4743206C
  JID: nomeata at joachim-breitner.de | http://www.joachim-breitner.de/
  Debian Developer: nomeata at debian.org
-------------- 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/20091204/68500f0d/attachment.bin