module Language.Haskell.TH.Module.Magic
(
names
, moduleNames
, declarations
, moduleDeclarations
) where
#include "ghcplatform.h"
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
import System.IO.Temp
import HeaderInfo
import DriverPipeline
import SysTools
import Packages
import Config
import qualified Control.Monad.IO.Class as MTL
import Control.Monad.Catch
import Exception (throwIO)
import GhcMonad
import GHC.IO.Handle
import System.FilePath.Posix (takeBaseName)
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
#if __GLASGOW_HASKELL__ < 707
instance MTL.MonadIO Ghc where
liftIO = MonadUtils.liftIO
#endif
instance MonadThrow Ghc where
throwM = liftIO . throwIO
instance MonadCatch Ghc where
catch = gcatch
instance MonadMask Ghc where
mask f =
Ghc $ \s -> mask $ \io_restore ->
let
g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
in
unGhc (f g_restore) s
uninterruptibleMask = error "uninterruptibleMask"
lookupModuleNames :: (MTL.MonadIO m, MonadCatch m, MonadMask m, 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 _ -> do
dflags <- getSessionDynFlags
opts <- liftIO $ getOptionsFromFile dflags filePath
(newDFlags, unhandledFlags, _) <-
liftIO $ parseDynamicFilePragma dflags opts
liftIO $ checkProcessArgsResult newDFlags unhandledFlags
if (xopt Opt_Cpp newDFlags) then do
withSystemTempFile (takeBaseName filePath <> ".cpp") $ \cppFilePath handle -> do
liftIO $ hClose handle
liftIO $ doCpp newDFlags True False filePath cppFilePath
srcOpts <- liftIO $ getOptionsFromFile newDFlags cppFilePath
(newestDFlags, unhandled_flags, warns)
<- liftIO $ parseDynamicFilePragma newDFlags srcOpts
liftIO $ checkProcessArgsResult newestDFlags unhandled_flags
parseFile newestDFlags cppFilePath
else
parseFile newDFlags filePath
errString :: Show a => Bag a -> String
errString = unlines
. map show
. foldBag (<>) (:[]) []
parseFile :: GhcMonad m => DynFlags -> FilePath -> m [TH.Name]
parseFile dflags filePath = do
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
#if __GLASGOW_HASKELL__ < 710
ForeignType x _ -> getNameMaybe x
#endif
#if __GLASGOW_HASKELL__ >= 707
FamDecl x -> getNameMaybe $ fdLName x
SynDecl { tcdLName } -> getNameMaybe tcdLName
DataDecl { tcdLName } -> getNameMaybe tcdLName
#else
x@(TyFamily {}) -> getNameMaybe $ tcdLName x
TyDecl x _ _ _ -> getNameMaybe x
#endif
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
doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
doCpp dflags raw include_cc_opts input_fn output_fn = do
let hscpp_opts = getOpts dflags opt_P
let cmdline_include_paths = includePaths dflags
pkg_include_dirs <- getPackageIncludePath dflags []
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
let verbFlags = getVerbFlags dflags
let cc_opts
| include_cc_opts = getOpts dflags opt_c
| otherwise = []
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
let target_defs =
[ "-D" ++ HOST_OS ++ "_BUILD_OS=1",
"-D" ++ HOST_ARCH ++ "_BUILD_ARCH=1",
"-D" ++ TARGET_OS ++ "_HOST_OS=1",
"-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
cpp_prog ( map SysTools.Option verbFlags
++ map SysTools.Option include_paths
++ map SysTools.Option hsSourceCppOpts
++ map SysTools.Option target_defs
++ map SysTools.Option hscpp_opts
++ map SysTools.Option cc_opts
++ [ SysTools.Option "-x"
, SysTools.Option "c"
, SysTools.Option input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
])
hsSourceCppOpts :: [String]
hsSourceCppOpts =
[ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]