Merge pull request #17 from takano-akio/master

Non-standard package.conf support

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 :: Options -> String -> IO [String]
-browse mdlName = withGHC $ do
+browse opt mdlName = withGHC $ do
-    initSession0
+    initSession0 opt
     maybeNamesToStrings <$> lookupModuleInfo
   where
     lookupModuleInfo = findModule (mkModuleName mdlName) Nothing >>= getModuleInfo

Cabal.hs

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

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 :: Options -> String -> IO [String]
-check fileName = withGHC $ do
+check opt fileName = withGHC $ do
-    file <- initializeGHC fileName options
+    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

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

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

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 :: Options -> IO [String]
-list = withGHC $ do
+list opt = withGHC $ do
-    initSession0
+    initSession0 opt
     getExposedModules <$> getSessionDynFlags
   where
     getExposedModules = map moduleNameString

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