TH.hs

{-# OPTIONS_HADDOCK show-extensions #-}

{-# LANGUAGE TemplateHaskell #-}

{-|
Module      : Graphics.QML.DataModel.Vinyl.TH
Copyright   : (c) Marcin Mrotek, 2015
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com
Stability   : experimental

-}

module Graphics.QML.DataModel.Vinyl.TH 
  ( module Graphics.QML.DataModel.Vinyl.TH
  , module Graphics.QML.DataModel.Vinyl
  ) 
  where

import Graphics.QML.DataModel.Vinyl()

import Control.Monad
import Language.Haskell.TH
import Type.Showtype

showTypes :: TypeQ -> DecsQ
-- |Declare 'Showtype' instances for all labels in a given type-level list. Only works for explicit literals, unfortunately type synonyms and families aren't expanded.
showTypes types = return.concat =<< mapM inst =<< unwrapTypeList =<< types
  where 
    inst t = [d| instance Showtype $(return t) where showtype _ = $(name t) |]
    name (PromotedT n) = stringE $ nameBase n
    name n = fail $ show n ++ " is not a promoted name."

unwrapTypeList :: Type -> Q [Type]
-- |Unwraps a type-level list into a TH list of types.
unwrapTypeList (AppT PromotedConsT a) = return [a]
unwrapTypeList (AppT a b) = (++) <$> unwrapTypeList a <*> unwrapTypeList b
unwrapTypeList PromotedNilT = return []
unwrapTypeList a = fail $ "not a type list: " ++ show a