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 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

View File

@ -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)
----------------------------------------------------------------

View File

@ -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
toNull x = x

View File

@ -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])

21
Info.hs
View File

@ -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)

View File

@ -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

View File

@ -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 ()