{-# LANGUAGE TemplateHaskell #-}

module Data.Type.Internal.TH where

import Data.Type.Kind
import Data.Type.Internal.Framework
import Data.Type.Internal.Derive

import Control.Monad
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

kinds :: [Kind]
kinds = generateKinds kindStarLimit

tupleKinds = take (kindStarLimit-2) . drop 2 $ iterate succKind StarK

declareTypeDatas :: Q [Dec]
declareTypeDatas = sequence $ map dec kinds
	where
	dec :: Kind -> Q Dec
	dec k = do
		let wrap = mkName $ "Type" ++ kindName k
		let t = mkName "t"
		let cxt = return []
		let tyvar = [KindedTV t k]
		let con = [normalC wrap []]
		let deriv = [mkName "Show"]
		dataD cxt wrap tyvar con deriv

{-
declareTypeWrapperInstances :: Q [Dec]
declareTypeWrapperInstances = sequence $ map dec kinds
	where
	dec :: Kind -> Q Dec
	dec k = do
		let wrap = mkName $ "Type" ++ kindName k
		let t = mkName "t"
		let cxt = return []
		let hd = conT ''TypeWrapper `appT` (conT wrap `appT` varT t)
		let funs =
			[ funD 'type_ [clause [] (normalB $ conE wrap) []]
			, funD 'kindOf [clause [wildP] (normalB $ lift k) []]
			]
		instanceD cxt hd funs
-}

declareMetaClasses :: Q [Dec]
declareMetaClasses = sequence $ map dec kinds
	where
	dec :: Kind -> Q Dec
	dec k = do
		let tid = mkName $ "typeID" ++ kindName k
		let wrap = mkName $ "Type" ++ kindName k
		let t = mkName "t"
		let meta = mkName $ "Meta" ++ kindName k
		let cxt = return []
		let tyvar = [KindedTV t k]
		let sigs =
			[ sigD tid (foldl1 appT [arrowT,conT wrap `appT` varT t,conT ''TypeID])
			]
		classD cxt meta tyvar [] sigs

declareMetaInstances :: Q [Dec]
declareMetaInstances = sequence $ map dec (tail kinds)
	where
	dec f@(ArrowK p r) = do
		let tid k = mkName $ "typeID" ++ kindName k
		let wrap k = mkName $ "Type" ++ kindName k
		let meta k = mkName $ "Meta" ++ kindName k
		let fn = mkName "f"
		let pn = mkName "p"
		let cxts = cxt [ classP (meta f) [varT fn], classP (meta p) [varT pn] ]
		let hd = conT (meta r) `appT` (varT fn `appT` varT pn)
		let typ k kn = sigE (conE $ wrap k) (conT (wrap k) `appT` varT kn)
		let body = foldl1 appE
			[ varE 'applyTypeID
			, appE (varE $ tid f) (typ f fn)
			, appE (varE $ tid p) (typ p pn)
			]
		let funs = [ funD (tid r) [clause [wildP] (normalB body) []] ]
		instanceD cxts hd funs

declareTupleInstances :: Q [Dec]
declareTupleInstances = fmap concat . sequence $ map (uncurry declareMeta) $ zip tupleKinds [ tupleTypeName c | c <- [2..kindStarLimit-1]]