{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, QuasiQuotes #-}

module Data.TrieMap.Rep.TH (genRepT, mkCon, conT, mkVar, appT, Type(..)) where

import Language.Haskell.TH
import Data.TrieMap.Rep
-- import Language.Haskell.TH.Ppr
-- import Debug.Trace
{-
genRepT ::  TypeQ -> Q [Dec]
genRepT ff = do
	f <- ff
	a <- newName "a"
	b <- newName "b"
	g <- newName "g"
	let reprt = ConT (mkName "ReprT")
	let repr = ConT (mkName "Repr")
	let rept = ConT (mkName "RepT")
	let rep = ConT (mkName "Rep")
	torep <- [| fmap toRep . toRepT |]
	fromrep <- [| fromRepT . fmap fromRep |]
	let toRepType = ForallT [g, b] [AppT reprt (VarT g), AppT repr (VarT b)]
		(AppT (VarT g) (VarT b) ~> AppT (AppT rept (VarT g)) (AppT rep (VarT b)))
	let fromRepType = ForallT [g, b] [AppT reprt (VarT g), AppT repr (VarT b)] 
		(AppT (AppT rept (VarT g)) (AppT rep (VarT b)) ~> AppT (VarT g) (VarT b))
	let ans = [InstanceD [AppT reprt f, AppT repr (VarT a)] (AppT repr (AppT f (VarT a)))
		[FunD (mkName "toRep") [Clause [] (NormalB ( torep )) []],
			FunD (mkName "fromRep") [Clause [] (NormalB ( fromrep )) []]]]
	return ans-}

genRepT :: Q [Dec] -> Q [Dec]
genRepT decs = do
	iT@(InstanceD cxt (reprt `AppT` f) _:_) <- decs
	let myDecs = [ValD (VarP 'toRep) (NormalB (AppE (VarE 'toRepTMap) (VarE 'toRep))) [],
		ValD (VarP 'fromRep) (NormalB (AppE (VarE 'fromRepTMap) (VarE 'fromRep))) []]
	a <- mkVar "a"
	return (InstanceD (ClassP ''Repr [a]:cxt) (ConT ''Repr `AppT` (f `AppT` a)) myDecs :iT)

(~>) :: Type -> Type -> Type
a ~> b = AppT (AppT ArrowT a) b

mkCon :: String -> TypeQ
mkCon = conT . mkName

mkVar :: String -> TypeQ
mkVar x = varT =<< newName x

-- f :: Q [Dec]
-- f = do	ans <- [d| instance (ReprT ((,) a), Repr b) => Repr (a, b) where |]
-- 	traceShow ans $ return ans