module Language.Haskell.TH.TypeGraph.Expand
( Expanded(markExpanded, runExpanded')
, runExpanded
, expandType
, expandPred
, expandClassP
, E(E)
) where
#if __GLASGOW_HASKELL__ < 709
import Control.Applicative
#endif
import Language.Haskell.Exts.Syntax ()
import Language.Haskell.TH
import Language.Haskell.TH.Desugar as DS (DsMonad, dsType, expand, typeToTH)
import Language.Haskell.TH.Instances ()
import Language.Haskell.TH.Syntax (Lift(lift))
import Prelude hiding (pred)
class Expanded un ex | ex -> un where
markExpanded :: un -> ex
runExpanded' :: ex -> un
expandType :: (DsMonad m, Expanded Type e) => Type -> m e
expandType typ = markExpanded <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)
expandPred :: (DsMonad m, Expanded Pred e) => Pred -> m e
#if __GLASGOW_HASKELL__ >= 709
expandPred = expandType
#else
expandPred (ClassP className typeParameters) = expandClassP className typeParameters
expandPred (EqualP type1 type2) = markExpanded <$> (EqualP <$> (runExpanded <$> expandType type1) <*> (runExpanded <$> expandType type2))
#endif
expandClassP :: forall m e. (DsMonad m, Expanded Pred e) => Name -> [Type] -> m e
expandClassP className typeParameters =
#if __GLASGOW_HASKELL__ >= 709
(expandType $ foldl AppT (ConT className) typeParameters) :: m e
#else
(markExpanded . ClassP className . map runExpanded) <$> mapM expandType typeParameters
#endif
runExpanded :: Expanded a (E a) => E a -> a
runExpanded = runExpanded'
newtype E a = E a deriving (Eq, Ord, Show)
instance Expanded Type (E Type) where
markExpanded = E
runExpanded' (E x) = x
#if __GLASGOW_HASKELL__ < 709
instance Expanded Pred (E Pred) where
markExpanded = E
runExpanded' (E x) = x
#endif
instance Ppr a => Ppr (E a) where
ppr (E x) = ppr x
instance Lift (E Type) where
lift etype = [|markExpanded $(lift (runExpanded etype))|]