module Language.Haskell.TH.Module.Magic
(
names
, moduleNames
, declarations
, moduleDeclarations
) where
import Language.Haskell.TH as TH
import Data.Maybe
import GHC
import Module
import GHC.Paths ( libdir )
import DynFlags
import Name as Name
import RdrName
import MonadUtils
import HsDecls as HsDecls
import SrcLoc
import Bag
import Control.Monad
import Data.Monoid
names :: Q [TH.Name]
names = moduleNames . loc_filename =<< location
moduleNames :: String -> Q [TH.Name]
moduleNames target = runIO $
defaultErrorHandler
defaultFatalMessager
defaultFlushOut
$ do
runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
setSessionDynFlags dflags
lookupModuleNames target
nameToMaybeDec :: TH.Name -> Q (Maybe Dec)
nameToMaybeDec name = do
info <- reify name
return $ case info of
TyConI dec -> Just dec
_ -> Nothing
declarations :: Q [Dec]
declarations = mapMaybeM nameToMaybeDec =<< names
moduleDeclarations :: String -> Q [Dec]
moduleDeclarations = mapMaybeM nameToMaybeDec <=< moduleNames
lookupModuleNames :: GhcMonad m => String -> m [TH.Name]
lookupModuleNames mName = do
target <- targetId <$> guessTarget mName Nothing
case target of
TargetModule moduleName -> getExistingModuleNames
=<< lookupModule moduleName Nothing
TargetFile filePath _ -> parseFile filePath
errString :: Show a => Bag a -> String
errString = unlines
. map show
. foldBag (<>) (:[]) []
parseFile :: GhcMonad m => FilePath -> m [TH.Name]
parseFile filePath = do
dflags <- getDynFlags
src <- liftIO $ readFile filePath
let (warns, L _ hsModule) =
either (error . errString) id
$ parser src dflags filePath
names = mapMaybe getNameMaybe $ hsmodDecls hsModule
return $ map rdrNameToName names
showModuleName :: Module -> String
showModuleName = moduleNameString . moduleName
getExistingModuleNames :: GhcMonad m => Module -> m [TH.Name]
getExistingModuleNames modl = do
moduleInfo <- getModuleInfo modl
case moduleInfo of
Nothing -> error $ "modulespection: Failed to find module info for "
<> showModuleName modl
<> " in getExistingModuleNames"
Just mod_info -> fmap (map (occNameToName . nameOccName . getName))
. mapMaybeM lookupName
$ modInfoExports mod_info
class GetNameMaybe a where
getNameMaybe :: a -> Maybe RdrName
instance GetNameMaybe (HsDecl RdrName) where
getNameMaybe = \case
TyClD x -> getNameMaybe x
HsDecls.ValD x -> getNameMaybe x
_ -> Nothing
instance GetNameMaybe (TyClDecl RdrName) where
getNameMaybe = \case
ForeignType x _ -> getNameMaybe x
x@(TyFamily {}) -> getNameMaybe $ tcdLName x
TyDecl x _ _ _ -> getNameMaybe x
x@(ClassDecl {}) -> getNameMaybe $ tcdLName x
instance GetNameMaybe (HsBindLR RdrName RdrName) where
getNameMaybe = \case
x@(FunBind {}) -> getNameMaybe $ fun_id x
_ -> Nothing
instance GetNameMaybe a => GetNameMaybe (GenLocated SrcSpan a) where
getNameMaybe (L _ x) = getNameMaybe x
instance GetNameMaybe RdrName where
getNameMaybe = Just
occNameToName :: OccName -> TH.Name
occNameToName = mkName . occNameString
rdrNameToName :: RdrName -> TH.Name
rdrNameToName = \case
RdrName.Unqual x -> occNameToName x
RdrName.Qual _ x -> occNameToName x
RdrName.Orig _ x -> occNameToName x
RdrName.Exact x -> occNameToName $ nameOccName x