-- | The 'Expanded' class helps keep track of which 'Type' values have
-- been fully expanded to a canonical form.  This lets us use the 'Eq'
-- and 'Ord' relationships on 'Type' and 'Pred' values when reasoning
-- about instance context.  What the 'expandType' function does is use
-- the function from @th-desugar@ to replace occurrences of @ConT name@
-- with the associated 'Type' if @name@ is a declared type synonym
-- @TySynD name _ typ@.  For convenience, a wrapper type 'E' is
-- provided, along with the 'Expanded' instances @E Type@ and @E
-- Pred@.  Now the 'expandType' and 'expandPred' functions can be used
-- to return values of type @E Type@ and @E Pred@ respectively.
--
-- Instances @Expanded Type Type@ and @Expanded Pred Pred@ are
-- provided in "Language.Haskell.TH.Context.Unsafe", for when less
-- type safety is required.

{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

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)

-- | This class lets us use the same expand* functions to work with
-- specially marked expanded types or with the original types.
class Expanded un ex | ex -> un where
    markExpanded :: un -> ex -- ^ Unsafely mark a value as expanded
    runExpanded' :: ex -> un -- ^ Strip mark off an expanded value

-- | Apply the th-desugar expand function to a 'Type' and mark it as expanded.
expandType :: (DsMonad m, Expanded Type e)  => Type -> m e
expandType typ = markExpanded <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)

-- | Apply the th-desugar expand function to a 'Pred' and mark it as expanded.
-- Note that the definition of 'Pred' changed in template-haskell-2.10.0.0.
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

-- | Expand a list of 'Type' and build an expanded 'ClassP' 'Pred'.
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'

-- | A concrete type for which Expanded instances are declared below.
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))|]