{-# LANGUAGE TemplateHaskell #-}
-- {-# OPTIONS_HADDOCK hide #-}

module Data.Type.TH
	( deriveTyped
	, deriveTyped_
	, deriveTyped__
	)
	where

import Data.Type.Kind
import Data.Type.Framework
import Data.Type.Generated

import Language.Haskell.TH hiding (Type)
import qualified Language.Haskell.TH as TH

-- | Used to derive instances of typed.
--
-- > data T1 = T1
-- > $(deriveTyped ''T1 "")
--
-- > data T2 p0 = T2
-- > $(deriveTyped ''T2 "X")
--
-- > data T3 ( p0 :: * -> * ) = T3
-- > $(deriveTyped ''T2 "BXXE")
--
-- > data T4 p0 p1 = T4
-- > $(deriveTyped ''T2 "XX")
--
-- > data T5 ( p0 :: ((* -> *) -> *) -> * ) ( p1 :: * -> * ) = T5
-- > $(deriveTyped ''T2 "BBBXXEXEXEBXXE")
deriveTyped
	:: Name   -- ^ The name of the type constructor.
	-> String -- ^ String describing the kind of the type constructors parameters.
	-> Q [Dec]
deriveTyped n k = deriveTyped_ n $ readKindName k

-- | Same as 'deriveTyped' but uses 'Kind'.
deriveTyped_ :: Name -> Kind -> Q [Dec]
deriveTyped_ n k = do
	l <- location
	let p = loc_package l
	deriveTyped__ p n $ typeConstructorName k

-- | Same as 'deriveTyped' but package name and type wrapper name is given explicitly.
deriveTyped__
	:: String -- ^ The package name.
	-> Name   -- ^ The type wrapper name.
	-> Name   -- ^ The type whose instance is being derived.
	-> Q [Dec]
deriveTyped__ p n t = do
	let i = show n
	return
		[InstanceD
			[]
			(AppT
				(ConT ''Typed)
				(AppT
					(ConT t)
					(ConT n)
				)
			)
			[ FunD
				(mkName "typeID")
				[Clause
					[WildP]
					(NormalB
						(AppE
							(AppE
								(VarE 'makeTypeID)
								(LitE $ StringL p)
							)
							(LitE $ StringL i)
						)
					)
					[]
				]
			]
		]