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

module Data.TrieMap.MultiRec.TH where

import Data.TrieMap.MultiRec.Class
import Data.TrieMap.MultiRec.Ord
import Language.Haskell.TH
import Language.Haskell.TH.Ppr
import Control.Monad
import Debug.Trace

data Scheme = Sch {empt, nul, siz, look, lookIx, assocAt, updateAt, alter, traverse, fold, foldl, mapE, splitL, union, isect, diff, extractMi, extractMa, alterMi, alterMa, isSub, fromL, fromAL, fromDAL :: String}

htriekeyT :: Scheme
htriekeyT = Sch "emptyT" "nullT" "sizeT" "lookupT" "lookupIxT" "assocAtT" "updateAtT" "alterT" "traverseWithKeyT" "foldWithKeyT" "foldlWithKeyT"
	"mapEitherT" "splitLookupT" "unionT" "isectT" "diffT" "extractMinT" "extractMaxT" "alterMinT" "alterMaxT" "isSubmapT" 
	"fromListT" "fromAscListT" "fromDistAscListT"

htriekey :: Scheme
htriekey = Sch "emptyH" "nullH" "sizeH" "lookupH" "lookupIxH" "assocAtH" "updateAtH" "alterH" "traverseWithKeyH" "foldWithKeyH" "foldlWithKeyH"
	"mapEitherH" "splitLookupH" "unionH" "isectH" "diffH" "extractHinH" "extractHaxH" "alterHinH" "alterHaxH" "isSubmapH" 
	"fromListH" "fromAscListH" "fromDistAscListH"

{-inferNewtype :: Name -> Name -> Scheme -> Scheme -> Q [Dec] -> Q [Dec]
inferNewtype kCon mCon sch1 sch2 decl = do
	decs@(InstanceD cxt t _:_) <- decl
	let fund = FunD . mkName
	let mcon = ConE mCon
	mapV <- newName "m"
	let mapVar = VarE mapV
	let mapPat = ConP mCon [VarP mapV]
	pfV <- newName "pf"
	let pfPat = VarP pfV
	let pfVar = VarE pfV
	szV <- newName "s"
	let szPat = VarP szV
	let szVar = VarE szV
	let empty = fund (empt sch1) [pfPat] (AppE mcon (AppE (VarE (empt sch2)) pfVar))
	let null = fund (nul sch1) [pfPat, mapPat] (VarE (nul sch2) `AppE` pfVar `AppE` mapVar)
	let size = fund (siz sch1) [pfPat, szPat, mapPat] (VarE (siz sch2) `AppE` pfVar `AppE` szPat `AppE` mapVar
	return [InstanceD cxt t [empty, null, size]]-}
	

inferH :: Q [Dec] -> Q [Dec]
inferH instanceT = do
	iT@(InstanceD cxt0 (htriekeyt `AppT` phi `AppT` f `AppT` m) _:_) <- instanceT
	(InstanceD _ _ decs:_) <- [d|
	  instance (HTrieKeyT phi f m, HTrieKey phi r mm, HOrd0 phi (f r)) => HTrieKey phi (f r) (m r) where
		emptyH = emptyT
		nullH = nullT
		sizeH = sizeT
		lookupH = lookupT
		lookupIxH = lookupIxT
		assocAtH = assocAtT
-- 		updateAtH = updateAtT
		alterH = alterT
		traverseWithKeyH = traverseWithKeyT
		foldWithKeyH = foldWithKeyT
		foldlWithKeyH = foldlWithKeyT
		mapEitherH = mapEitherT
		splitLookupH = splitLookupT
		unionH = unionT
		isectH = isectT
		diffH = diffT
		extractH = extractT
-- 		alterMinH = alterMinT
-- 		alterMaxH = alterMaxT
-- 		extractMinH = extractMinT
-- 		extractMaxH = extractMaxT
		isSubmapH = isSubmapT
		fromListH = fromListT
		fromAscListH = fromAscListT
		fromDistAscListH = fromDistAscListT |]
	let r = mkName "r"
	let mm = mkName "mm"
-- 	let phiT = varT phi
	let rT = varT r
	let mmT = varT mm
-- 	let mT = varT m
	let htriekey = conT ''HTrieKey
	let hord = conT ''HOrd
	let hord0 = conT ''HOrd0
	let htriemap = conT ''HTrieMap
	ans <- instanceD (cxt (map return cxt0 ++ [htriekey `appQ` phi `appT` rT `appT` (htriemap `appQ` phi `appT` rT)]))
		(htriekey `appT` return phi `appT` (return f `appT` rT) `appT` (return m `appT` rT)) (map return decs)
	return (ans:iT)

appQ :: TypeQ -> Type -> TypeQ
t1 `appQ` t2 = t1 `appT` return t2