diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -1,5 +1,5 @@ name: leksah-server -version: 0.8 +version: 0.8.0.1 cabal-version: >= 1.2 build-type: Simple license: GPL diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -26,12 +26,12 @@ import Control.Monad.Trans (liftIO) import Data.Maybe (mapMaybe) import Outputable(pprHsVar,showSDoc) -import IDE.Utils.FileUtils (figureOutGhcOpts) +import IDE.Utils.FileUtils (figureOutHaddockOpts, figureOutGhcOpts) parseTheHeader :: FilePath -> IO ServerAnswer parseTheHeader filePath = do text <- readFile filePath - opts <- figureOutGhcOpts + opts <- figureOutGhcOpts -- figureOutHaddockOpts parseResult <- liftIO $ myParseHeader filePath text opts case parseResult of Left str -> return (ServerFailed str) diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -69,7 +69,7 @@ import System.Log.Logger import Control.DeepSeq (deepseq) #if MIN_VERSION_ghc(6,12,1) -import FastString(mkFastString,appendFS,nullFS) +import FastString(mkFastString,appendFS,nullFS,unpackFS) #else import GHC.Show(showSpace) #endif @@ -99,6 +99,7 @@ #endif type NSig = Located (Sig RdrName) +-- | Test collectWorkspace :: PackageIdentifier -> [(String,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace packId moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with " ++ show moduleList @@ -552,7 +553,7 @@ --} #if MIN_VERSION_ghc(6,12,1) printHsDoc :: NDoc -> String -printHsDoc d = showSDoc $ ppr_mbDoc (Just (noLoc d)) +printHsDoc (HsDocString fs) = unpackFS fs #else printHsDoc :: NDoc -> String diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -419,7 +419,9 @@ figureOutHaddockOpts = do (!output,_) <- runTool' "cabal" (["haddock","--with-haddock=leksahecho","--executables"]) Nothing let opts = concatMap (words . toolline) output - return (filterOptGhc opts) + let res = filterOptGhc opts + debugM "leksah-server" ("figureOutHaddockOpts " ++ show res) + return res where filterOptGhc [] = [] filterOptGhc (s:r) = case stripPrefix "--optghc=" s of @@ -430,12 +432,14 @@ figureOutGhcOpts = do debugM "leksah-server" "figureOutGhcOpts" (!output,_) <- runTool' "runhaskell" ["Setup","build","--with-ghc=leksahecho"] Nothing - case catMaybes $ map (findMake . toolline) output of - options:_ -> return (words options) - _ -> return [] + let res = case catMaybes $ map (findMake . toolline) output of + options:_ -> words options + _ -> [] + debugM "leksah-server" $ ("figureOutGhcOpts " ++ show res) + return res where findMake [] = Nothing findMake line@(_:xs) = - case stripPrefix " --make " line of + case stripPrefix "--make " line of Nothing -> findMake xs s -> s diff --git a/src/IDE/Utils/GHCUtils.hs b/src/IDE/Utils/GHCUtils.hs --- a/src/IDE/Utils/GHCUtils.hs +++ b/src/IDE/Utils/GHCUtils.hs @@ -18,6 +18,7 @@ , findFittingPackages , myParseModule , myParseHeader +, findAndReadIface2 ) where #if MIN_VERSION_Cabal(1,8,0) @@ -30,26 +31,35 @@ #else import qualified Distribution.InstalledPackageInfo as IPI (package) #endif -import GHC +import GHC hiding (SuccessFlag, Failed, Succeeded) import DriverPipeline(preprocess) import StringBuffer (StringBuffer(..),hGetStringBuffer) import FastString (mkFastString) import Lexer (mkPState,ParseResult(..),getMessages,unP) -import Outputable (ppr) -import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..)) +import Outputable (showSDoc, text, ppr) +import ErrUtils + (Message, dumpIfSet_dyn, printErrorsAndWarnings, mkPlainErrMsg, + showPass, ErrMsg(..)) import PackageConfig (PackageConfig) import Data.Foldable (maximumBy) import qualified Parser as P (parseModule,parseHeader) import HscStats (ppSourceStats) -import Control.Monad.Trans -import HscTypes (Ghc(..)) +import HscTypes + (mi_module, FindResult(..), ModIface(..), HscEnv(..)) import IDE.Utils.FileUtils (getSysLibDir) import DynFlags (dopt_set) import System.Log.Logger(warningM, debugM) +import qualified GHC as Module (ModuleName) +import TcRnMonad (TcRnIf) +import Finder (findHomeModule) +import System.Directory (canonicalizePath) +import LoadIface (readIface) +import Maybes (MaybeErr(..), MaybeErr) +import MonadUtils (MonadIO(..)) --- this should not be repeated here, why is it necessary? -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA +---- this should not be repeated here, why is it necessary? +--instance MonadIO Ghc where +-- liftIO ioA = Ghc $ \_ -> ioA inGhcIO :: [String] -> [DynFlag] -> (DynFlags -> Ghc a) -> IO a inGhcIO flags' udynFlags ghcAct = do @@ -118,6 +128,26 @@ in if length filtered > 1 then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] else filtered + + --------------------------------------------------------------------- +-- | Reading an interface file +findAndReadIface2 :: HscEnv -> Module.ModuleName -> Module -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) +findAndReadIface2 session modName = do + mb_found <- liftIO $ findHomeModule session modName + case mb_found of + Found loc mod' -> do + let file_path = ml_hi_file loc +-- filePath <- liftIO $ canonicalizePath file_path + read_result <- readIface mod' file_path False + case read_result of + Failed mess -> return (Failed (text $ "can't read iface " ++ + moduleNameString modName ++ " at " ++ file_path ++ " " ++ showSDoc mess)) + Succeeded iface + | mi_module iface /= mod' + -> return (Failed (text $ "read but not equal" ++ moduleNameString modName)) + | otherwise + -> return (Succeeded (iface, file_path)) + _ -> return (Failed (text $ "can't locate " ++ moduleNameString modName)) --------------------------------------------------------------------- -- | Parser function copied here, because it is not exported diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs --- a/src/IDE/Utils/Tool.hs +++ b/src/IDE/Utils/Tool.hs @@ -335,7 +335,7 @@ where findMake [] = Nothing findMake line@(_:xs) = - case stripPrefix " --make " line of + case stripPrefix "--make " line of Nothing -> findMake xs s -> s filterUnwanted [] = []