{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}

module Data.Type.Internal.Derive
	( deriveMeta
	, declareMeta
	)
	where

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

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

-- | Used to derive instances of the 'Meta' classes.
--
-- > data T ...
-- > deriveMeta ''T
deriveMeta
	:: Name   -- ^ The name of the type constructor.
	-> Q [Dec]
deriveMeta name = do
	info <- qReify name
	let
		f :: TyVarBndr -> Kind
		f (PlainTV _)    = StarK
		f (KindedTV _ k) = k
	case info of
		TyConI (DataD _ _ tyvars _ _) -> do
			let kind = fromParameters $ map f tyvars
			declareMeta kind name
		TyConI (NewtypeD _ _ tyvars _ _) -> do
			let kind = fromParameters $ map f tyvars
			declareMeta kind name
		_ -> do
			qReport True $ "Cannot derive Meta for " ++ nameBase name ++ " (qReify not matched)."
			return []

-- | Used internally to declare instances of the 'Meta' classes for some primitives.
declareMeta
	:: Kind   -- ^ The kind of the type constructor.
	-> Name   -- ^ The name of the type constructor.
	-> Q [Dec]
declareMeta k name@(Name (occString->occ) (NameG _ (pkgString->pkg) (modString->mod))) = do
	when (kindStars k > kindStarLimit) . fail $ "Cannot declare Meta for " ++ nameBase name ++ " (kind star limit exceeded)."
	let tid = mkName $ "typeID" ++ kindName k
	let wrap = mkName $ "Data.Type.Type" ++ kindName k
	let meta = mkName $ "Data.Type.Meta" ++ kindName k
	let cxts = cxt []
	let hd = conT meta `appT` (conT name)
	let body = foldl1 appE
		[ varE 'makeTypeID
		, stringE pkg
		, stringE mod
		, stringE occ
		]
	let funs = [ funD tid [clause [wildP] (normalB body) []] ]
	instanceD cxts hd funs >>= return . \x -> [x]
declareMeta _ name = do
	qReport True $ "Cannot declare Meta for " ++ nameBase name ++ " (name not matched)."
	return []