module Language.Haskell.TH.Expand
( E(E, _unE), unE
, ExpandMap
, expandType
, expandPred
, expandClassP
, pprint1
) where
import Control.Lens (makeLenses)
import Control.Monad.States (MonadStates(getPoly), modifyPoly)
import Data.Data (Data)
import Data.Generics (Data, everywhere, mkT)
import Data.Map as Map (Map, lookup, insert)
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.PprLib (to_HPJ_Doc)
import Language.Haskell.TH.Syntax
import Prelude hiding (pred)
import qualified Text.PrettyPrint as HPJ
newtype E a = E {_unE :: a} deriving (Eq, Ord, Show, Data)
instance Ppr a => Ppr (E a) where
ppr (E x) = ppr x
instance Lift (E Type) where
lift etype = [|E $(lift (_unE etype))|]
$(makeLenses ''E)
type ExpandMap = Map Type (E Type)
expandType :: (DsMonad m, MonadStates ExpandMap m) => Type -> m (E Type)
expandType typ = do
getPoly >>= maybe expandType' return . Map.lookup typ
where
expandType' =
do e <- E <$> DS.typeToTH <$> (DS.dsType typ >>= DS.expand)
modifyPoly (Map.insert typ e)
return e
expandPred :: (DsMonad m, MonadStates ExpandMap m) => Type -> m (E Type)
expandPred = expandType
expandClassP :: forall m. (DsMonad m, MonadStates ExpandMap m) => Name -> [Type] -> m (E Type)
expandClassP className typeParameters = (expandType $ foldl AppT (ConT className) typeParameters) :: m (E Type)
pprint1 :: (Ppr a, Data a) => a -> [Char]
pprint1 = pprintStyle (HPJ.style {HPJ.mode = HPJ.OneLineMode}) . friendlyNames
pprintStyle :: (Ppr a, Data a) => HPJ.Style -> a -> String
pprintStyle style = HPJ.renderStyle style . to_HPJ_Doc . ppr
friendlyNames :: Data a => a -> a
friendlyNames =
everywhere (mkT friendlyName)
where
friendlyName (Name x _) = Name x NameS