From ad55168265383c2bd0fa2a91dd33da6768eb2b4f Mon Sep 17 00:00:00 2001 From: Takano Akio Date: Sat, 28 May 2011 05:43:52 +0900 Subject: [PATCH] adding options: --package-conf and --no-user-package-conf These command line options work just like the similar-named GHC flags. They are useful when working with non-standard package databases. --- Browse.hs | 8 ++++---- Cabal.hs | 8 ++++---- Check.hs | 10 +++++----- GHCMod.hs | 8 ++++++++ Info.hs | 21 +++++++++++---------- List.hs | 8 ++++---- Types.hs | 24 +++++++++++++++++++----- 7 files changed, 55 insertions(+), 32 deletions(-) diff --git a/Browse.hs b/Browse.hs index fce16e2..8860ec1 100644 --- a/Browse.hs +++ b/Browse.hs @@ -10,7 +10,7 @@ import Types ---------------------------------------------------------------- browseModule :: Options -> String -> IO String -browseModule opt mdlName = convert opt . format <$> browse mdlName +browseModule opt mdlName = convert opt . format <$> browse opt mdlName where format | operators opt = formatOps @@ -22,9 +22,9 @@ browseModule opt mdlName = convert opt . format <$> browse mdlName | otherwise = '(' : x ++ ")" formatOps' [] = error "formatOps'" -browse :: String -> IO [String] -browse mdlName = withGHC $ do - initSession0 +browse :: Options -> String -> IO [String] +browse opt mdlName = withGHC $ do + initSession0 opt maybeNamesToStrings <$> lookupModuleInfo where lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo diff --git a/Cabal.hs b/Cabal.hs index 38def92..4404099 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -15,12 +15,12 @@ import Types ---------------------------------------------------------------- -initializeGHC :: FilePath -> [String] -> Ghc FilePath -initializeGHC fileName options = do +initializeGHC :: Options -> FilePath -> [String] -> Ghc FilePath +initializeGHC opt fileName ghcOptions = do (owdir,mdirfile) <- getDirs case mdirfile of Nothing -> do - initSession options Nothing + initSession opt ghcOptions Nothing return fileName Just (cdir,cfile) -> do midirs <- parseCabalFile cfile @@ -28,7 +28,7 @@ initializeGHC fileName options = do let idirs = case midirs of Nothing -> [cdir,owdir] Just dirs -> dirs ++ [owdir] - initSession options (Just idirs) + initSession opt ghcOptions (Just idirs) return (ajustFileName fileName owdir cdir) ---------------------------------------------------------------- diff --git a/Check.hs b/Check.hs index 7cb2107..d3af95c 100644 --- a/Check.hs +++ b/Check.hs @@ -18,13 +18,13 @@ import Types ---------------------------------------------------------------- checkSyntax :: Options -> String -> IO String -checkSyntax _ file = unlines <$> check file +checkSyntax opt file = unlines <$> check opt file ---------------------------------------------------------------- -check :: String -> IO [String] -check fileName = withGHC $ do - file <- initializeGHC fileName options +check :: Options -> String -> IO [String] +check opt fileName = withGHC $ do + file <- initializeGHC opt fileName options setTargetFile file ref <- newRef [] loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref @@ -69,4 +69,4 @@ showSDoc :: SDoc -> String showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style where toNull '\n' = '\0' - toNull x = x \ No newline at end of file + toNull x = x diff --git a/GHCMod.hs b/GHCMod.hs index 3fbb068..92b644a 100644 --- a/GHCMod.hs +++ b/GHCMod.hs @@ -40,6 +40,8 @@ defaultOptions = Options { convert = toPlain , hlintOpts = [] , operators = False + , packageConfs = [] + , useUserPackageConf = True } argspec :: [OptDescr (Options -> Options)] @@ -52,6 +54,12 @@ argspec = [ Option "l" ["tolisp"] , Option "o" ["operators"] (NoArg (\opts -> opts { operators = True })) "print operators, too" + , Option "" ["package-conf"] + (ReqArg (\p opts -> opts { packageConfs = p : packageConfs opts }) "path") + "additional package database" + , Option "" ["no-user-package-conf"] + (NoArg (\opts -> opts{ useUserPackageConf = False })) + "do not read the user package database" ] parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String]) diff --git a/Info.hs b/Info.hs index babd918..5b652da 100644 --- a/Info.hs +++ b/Info.hs @@ -21,10 +21,10 @@ type ModuleString = String ---------------------------------------------------------------- typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -typeExpr _ modstr expr file = (++ "\n") <$> typeOf file modstr expr +typeExpr opt modstr expr file = (++ "\n") <$> typeOf opt file modstr expr -typeOf :: FilePath -> ModuleString -> Expression -> IO String -typeOf fileName modstr expr = inModuleContext fileName modstr exprToType +typeOf :: Options -> FilePath -> ModuleString -> Expression -> IO String +typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType where exprToType = pretty <$> exprType expr pretty = showSDocForUser neverQualify . pprTypeForUser False @@ -32,10 +32,10 @@ typeOf fileName modstr expr = inModuleContext fileName modstr exprToType ---------------------------------------------------------------- infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String -infoExpr _ modstr expr file = (++ "\n") <$> info file modstr expr +infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr -info :: FilePath -> ModuleString -> FilePath -> IO String -info fileName modstr expr = inModuleContext fileName modstr exprToInfo +info :: Options -> FilePath -> ModuleString -> FilePath -> IO String +info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo where exprToInfo = infoThing expr @@ -68,16 +68,17 @@ pprInfo pefas (thing, fixity, insts) ---------------------------------------------------------------- -inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String -inModuleContext fileName modstr action = withGHC valid +inModuleContext + :: Options -> FilePath -> ModuleString -> Ghc String -> IO String +inModuleContext opt fileName modstr action = withGHC valid where valid = do - file <- initializeGHC fileName ["-w"] + file <- initializeGHC opt fileName ["-w"] setTargetFile file loadWithLogger (\_ -> return ()) LoadAllTargets mif setContextFromTarget action invalid invalid = do - initializeGHC fileName ["-w"] + initializeGHC opt fileName ["-w"] setTargetBuffer loadWithLogger defaultWarnErrLogger LoadAllTargets mif setContextFromTarget action (return errorMessage) diff --git a/List.hs b/List.hs index 0b4c894..5bba190 100644 --- a/List.hs +++ b/List.hs @@ -10,11 +10,11 @@ import UniqFM ---------------------------------------------------------------- listModules :: Options -> IO String -listModules opt = convert opt . nub . sort <$> list +listModules opt = convert opt . nub . sort <$> list opt -list :: IO [String] -list = withGHC $ do - initSession0 +list :: Options -> IO [String] +list opt = withGHC $ do + initSession0 opt getExposedModules <$> getSessionDynFlags where getExposedModules = map moduleNameString diff --git a/Types.hs b/Types.hs index 22a3c1b..e5a3a2f 100644 --- a/Types.hs +++ b/Types.hs @@ -12,6 +12,8 @@ data Options = Options { convert :: [String] -> String , hlintOpts :: [String] , operators :: Bool + , packageConfs :: [FilePath] + , useUserPackageConf :: Bool } withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) @@ -22,15 +24,16 @@ withGHC body = ghandle ignore $ runGhc (Just libdir) body ---------------------------------------------------------------- -initSession0 :: Ghc [PackageId] -initSession0 = getSessionDynFlags >>= setSessionDynFlags +initSession0 :: Options -> Ghc [PackageId] +initSession0 opt = getSessionDynFlags >>= + setSessionDynFlags . setPackageConfFlags opt -initSession :: [String] -> Maybe [FilePath] -> Ghc [PackageId] -initSession cmdOpts midirs = do +initSession :: Options -> [String] -> Maybe [FilePath] -> Ghc [PackageId] +initSession opt cmdOpts midirs = do dflags <- getSessionDynFlags let opts = map noLoc cmdOpts (dflags',_,_) <- parseDynamicFlags dflags opts - setSessionDynFlags $ setFlags dflags' midirs + setSessionDynFlags $ setPackageConfFlags opt $ setFlags dflags' midirs ---------------------------------------------------------------- @@ -46,6 +49,17 @@ setFlags d midirs = maybe d' (\x -> d' { importPaths = x }) midirs ghcPackage :: PackageFlag ghcPackage = ExposePackage "ghc" +setPackageConfFlags :: Options -> DynFlags -> DynFlags +setPackageConfFlags + Options { packageConfs = confs, useUserPackageConf = useUser } + flagset@DynFlags { extraPkgConfs = extra, flags = origFlags } + = flagset { extraPkgConfs = extra', flags = flags' } + where + extra' = confs ++ extra + flags' = if useUser + then origFlags + else filter (/=Opt_ReadUserPackageConf) origFlags + ---------------------------------------------------------------- setTargetFile :: (GhcMonad m) => String -> m ()