Merge pull request #17 from takano-akio/master

Non-standard package.conf support
This commit is contained in:
Kazu Yamamoto 2011-05-28 15:34:20 -07:00
commit b09a8fb2ee
7 changed files with 55 additions and 32 deletions

View File

@ -10,7 +10,7 @@ import Types
---------------------------------------------------------------- ----------------------------------------------------------------
browseModule :: Options -> String -> IO String browseModule :: Options -> String -> IO String
browseModule opt mdlName = convert opt . format <$> browse mdlName browseModule opt mdlName = convert opt . format <$> browse opt mdlName
where where
format format
| operators opt = formatOps | operators opt = formatOps
@ -22,9 +22,9 @@ browseModule opt mdlName = convert opt . format <$> browse mdlName
| otherwise = '(' : x ++ ")" | otherwise = '(' : x ++ ")"
formatOps' [] = error "formatOps'" formatOps' [] = error "formatOps'"
browse :: String -> IO [String] browse :: Options -> String -> IO [String]
browse mdlName = withGHC $ do browse opt mdlName = withGHC $ do
initSession0 initSession0 opt
maybeNamesToStrings <$> lookupModuleInfo maybeNamesToStrings <$> lookupModuleInfo
where where
lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo

View File

@ -15,12 +15,12 @@ import Types
---------------------------------------------------------------- ----------------------------------------------------------------
initializeGHC :: FilePath -> [String] -> Ghc FilePath initializeGHC :: Options -> FilePath -> [String] -> Ghc FilePath
initializeGHC fileName options = do initializeGHC opt fileName ghcOptions = do
(owdir,mdirfile) <- getDirs (owdir,mdirfile) <- getDirs
case mdirfile of case mdirfile of
Nothing -> do Nothing -> do
initSession options Nothing initSession opt ghcOptions Nothing
return fileName return fileName
Just (cdir,cfile) -> do Just (cdir,cfile) -> do
midirs <- parseCabalFile cfile midirs <- parseCabalFile cfile
@ -28,7 +28,7 @@ initializeGHC fileName options = do
let idirs = case midirs of let idirs = case midirs of
Nothing -> [cdir,owdir] Nothing -> [cdir,owdir]
Just dirs -> dirs ++ [owdir] Just dirs -> dirs ++ [owdir]
initSession options (Just idirs) initSession opt ghcOptions (Just idirs)
return (ajustFileName fileName owdir cdir) return (ajustFileName fileName owdir cdir)
---------------------------------------------------------------- ----------------------------------------------------------------

View File

@ -18,13 +18,13 @@ import Types
---------------------------------------------------------------- ----------------------------------------------------------------
checkSyntax :: Options -> String -> IO String checkSyntax :: Options -> String -> IO String
checkSyntax _ file = unlines <$> check file checkSyntax opt file = unlines <$> check opt file
---------------------------------------------------------------- ----------------------------------------------------------------
check :: String -> IO [String] check :: Options -> String -> IO [String]
check fileName = withGHC $ do check opt fileName = withGHC $ do
file <- initializeGHC fileName options file <- initializeGHC opt fileName options
setTargetFile file setTargetFile file
ref <- newRef [] ref <- newRef []
loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref
@ -69,4 +69,4 @@ showSDoc :: SDoc -> String
showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style showSDoc d = map toNull . Pretty.showDocWith PageMode $ d style
where where
toNull '\n' = '\0' toNull '\n' = '\0'
toNull x = x toNull x = x

View File

@ -40,6 +40,8 @@ defaultOptions = Options {
convert = toPlain convert = toPlain
, hlintOpts = [] , hlintOpts = []
, operators = False , operators = False
, packageConfs = []
, useUserPackageConf = True
} }
argspec :: [OptDescr (Options -> Options)] argspec :: [OptDescr (Options -> Options)]
@ -52,6 +54,12 @@ argspec = [ Option "l" ["tolisp"]
, Option "o" ["operators"] , Option "o" ["operators"]
(NoArg (\opts -> opts { operators = True })) (NoArg (\opts -> opts { operators = True }))
"print operators, too" "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]) parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])

21
Info.hs
View File

@ -21,10 +21,10 @@ type ModuleString = String
---------------------------------------------------------------- ----------------------------------------------------------------
typeExpr :: Options -> ModuleString -> Expression -> FilePath -> IO 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 :: Options -> FilePath -> ModuleString -> Expression -> IO String
typeOf fileName modstr expr = inModuleContext fileName modstr exprToType typeOf opt fileName modstr expr = inModuleContext opt fileName modstr exprToType
where where
exprToType = pretty <$> exprType expr exprToType = pretty <$> exprType expr
pretty = showSDocForUser neverQualify . pprTypeForUser False 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 :: 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 :: Options -> FilePath -> ModuleString -> FilePath -> IO String
info fileName modstr expr = inModuleContext fileName modstr exprToInfo info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo
where where
exprToInfo = infoThing expr exprToInfo = infoThing expr
@ -68,16 +68,17 @@ pprInfo pefas (thing, fixity, insts)
---------------------------------------------------------------- ----------------------------------------------------------------
inModuleContext :: FilePath -> ModuleString -> Ghc String -> IO String inModuleContext
inModuleContext fileName modstr action = withGHC valid :: Options -> FilePath -> ModuleString -> Ghc String -> IO String
inModuleContext opt fileName modstr action = withGHC valid
where where
valid = do valid = do
file <- initializeGHC fileName ["-w"] file <- initializeGHC opt fileName ["-w"]
setTargetFile file setTargetFile file
loadWithLogger (\_ -> return ()) LoadAllTargets loadWithLogger (\_ -> return ()) LoadAllTargets
mif setContextFromTarget action invalid mif setContextFromTarget action invalid
invalid = do invalid = do
initializeGHC fileName ["-w"] initializeGHC opt fileName ["-w"]
setTargetBuffer setTargetBuffer
loadWithLogger defaultWarnErrLogger LoadAllTargets loadWithLogger defaultWarnErrLogger LoadAllTargets
mif setContextFromTarget action (return errorMessage) mif setContextFromTarget action (return errorMessage)

View File

@ -10,11 +10,11 @@ import UniqFM
---------------------------------------------------------------- ----------------------------------------------------------------
listModules :: Options -> IO String listModules :: Options -> IO String
listModules opt = convert opt . nub . sort <$> list listModules opt = convert opt . nub . sort <$> list opt
list :: IO [String] list :: Options -> IO [String]
list = withGHC $ do list opt = withGHC $ do
initSession0 initSession0 opt
getExposedModules <$> getSessionDynFlags getExposedModules <$> getSessionDynFlags
where where
getExposedModules = map moduleNameString getExposedModules = map moduleNameString

View File

@ -12,6 +12,8 @@ data Options = Options {
convert :: [String] -> String convert :: [String] -> String
, hlintOpts :: [String] , hlintOpts :: [String]
, operators :: Bool , operators :: Bool
, packageConfs :: [FilePath]
, useUserPackageConf :: Bool
} }
withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a) 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 :: Options -> Ghc [PackageId]
initSession0 = getSessionDynFlags >>= setSessionDynFlags initSession0 opt = getSessionDynFlags >>=
setSessionDynFlags . setPackageConfFlags opt
initSession :: [String] -> Maybe [FilePath] -> Ghc [PackageId] initSession :: Options -> [String] -> Maybe [FilePath] -> Ghc [PackageId]
initSession cmdOpts midirs = do initSession opt cmdOpts midirs = do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
let opts = map noLoc cmdOpts let opts = map noLoc cmdOpts
(dflags',_,_) <- parseDynamicFlags dflags opts (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 :: PackageFlag
ghcPackage = ExposePackage "ghc" 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 () setTargetFile :: (GhcMonad m) => String -> m ()