leksah-server 0.8 → 0.8.0.1

raw patch · 6 files changed

+54/−19 lines, 6 files

Files

• leksah-server.cabal +1/−1
• src/IDE/HeaderParser.hs +2/−2
• src/IDE/Metainfo/WorkspaceCollector.hs +3/−2
• src/IDE/Utils/FileUtils.hs +9/−5
• src/IDE/Utils/GHCUtils.hs +38/−8
• src/IDE/Utils/Tool.hs +1/−1

@@ -1,5 +1,5 @@ name: leksah-server-version: 0.8+version: 0.8.0.1 cabal-version: >= 1.2 build-type: Simple license: GPL

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

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

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

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

@@ -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 [] = []