{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ParallelListComp #-}
{-# LANGUAGE TemplateHaskell #-}

-- | Contains functions to help making Typeable instances from Meta instances.
--
-- Warning: The 'TypeRep' is derived from the 'Meta' instances even if they might have a Typeable instance.
-- These functions use non-qualified names to make up the 'TypeRep's, which seems to be common.
module Data.Type.Typeable
	( deriveTypeableFromMeta
	, declareTypeableFromMeta
	, convertTypeIDToTypeRep
	) where

import Data.Type.Kind
import Data.Type.Internal.Framework
import Data.Type.Internal.Body as Data.Type
import Data.Type.Internal.TH
import Data.Typeable

import Control.Monad

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

-- | Used to derive instances of the 'Typeable' classes from the 'Meta' classes.
-- Requires the ScopedTypeVariables language option.
--
-- > import Data.Type
-- > import Data.Type.Typeable
-- >
-- > data T (m :: * -> *) a = ...
-- > deriveMeta ''T
-- > deriveTypeableFromMeta ''T
-- 
-- Yields a 'Typeable' instance like:
--
-- > instance (MetaX m) => Typeable1 (T m) where
-- >   ...
--
-- The template haskell funtions in this module expect to find symbols exported from 'Data.Type' module under 'Data.Type'. Thus change:
-- 
-- > import qualified Data.Type as T
-- 
-- Into:
-- 
-- > import qualified Data.Type
-- > import qualified Data.Type as T
--
-- It would be possible to drop this requirement, but currently not without bloating the library unnecessarily.
-- 
deriveTypeableFromMeta
	:: Name   -- ^ The name of the type constructor.
	-> Q [Dec]
deriveTypeableFromMeta 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
			declareTypeableFromMeta kind name
		TyConI (NewtypeD _ _ tyvars _ _) -> do
			let kind = fromParameters $ map f tyvars
			declareTypeableFromMeta kind name
		_ -> do
			qReport True $ "Cannot derive Typeable from Meta for " ++ nameBase name ++ " (qReify not matched)."
			return []

-- | Used internally to declare instances of the 'Typeable' classes from the 'Meta' classes.
declareTypeableFromMeta
	:: Kind   -- ^ The kind of the type constructor.
	-> Name   -- ^ The name of the type constructor.
	-> Q [Dec]
declareTypeableFromMeta kind name@(Name (occString->occ) (NameG _ (pkgString->pkg) (modString->mod))) = do
	let typeables = [''Typeable,''Typeable1,''Typeable2,''Typeable3,''Typeable4,''Typeable5,''Typeable6,''Typeable7]
	let typeOfs = ['typeOf,'typeOf1,'typeOf2,'typeOf3,'typeOf4,'typeOf5,'typeOf6,'typeOf7]
	let params = toParameters kind
	let (length -> r1c, reverse -> rNs) = span (==StarK) $ reverse params
	when (length rNs == 0) . fail $ "Cannot declare Typeable from Meta for " ++ occ ++ " (the type constructor is not at least rank 2)."
	when (r1c > 7) . fail $ "Cannot declare Typeable from Meta for " ++ occ ++ " (the type constructor has more than 7 rank 1 parameters at the end)."
	when (maximum (map kindStars rNs) > kindStarLimit) . fail $ "Cannot declare Typeable from Meta for " ++ occ ++ " (the type constructor has parameters that exceed kind star limit)."
	let tid k = mkName $ "Data.Type.typeID" ++ kindName k
	let wrap k = mkName $ "Data.Type.Type" ++ kindName k
	let meta k = mkName $ "Data.Type.Meta" ++ kindName k
	rNvs <- replicateM (length rNs) . fmap varT $ newName "rN"
	let cxts = cxt [ classP (meta k) [v] | k <- rNs | v <- rNvs ]
	let hd = conT (typeables!!r1c) `appT` (foldl1 appT (conT name : rNvs))
	let rNtr k v = foldr1 appE
		[ varE 'convertTypeIDToTypeRep
		, varE (tid k)
		, sigE (conE $ wrap k) (appT (conT $ wrap k) v)
		]
	let body = foldl1 appE
		[ varE 'mkTyConApp
		, varE 'mkTyCon `appE` stringE occ
		, listE [ rNtr k v | k <- rNs | v <- rNvs ]
		]
	let funs = [ funD (typeOfs!!r1c) [clause [wildP] (normalB body) []] ]
	instanceD cxts hd funs >>= return . \x -> [x]
declareMeta _ name = do
	qReport True $ "Cannot declare Typeable from Meta for " ++ nameBase name ++ " (name not matched)."
	return []

-- | Used internally to convert 'TypeID's to 'TypeRep's.
-- Gives non-qualified names to 'mkTyCon'.
convertTypeIDToTypeRep :: TypeID -> TypeRep
convertTypeIDToTypeRep = mapTypeID (\_ _ occ -> mkTyConApp (mkTyCon occ) []) (\f p -> f `mkAppTy` p)