hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

closed import.

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-03-27 14:55:24 +09:00
parent 856310e0fe
commit 07ec988251
1 changed files with 20 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
src/GHCModi.hs
View File

@ -12,10 +12,11 @@
module Main where module Main where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Concurrent import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)
import qualified Control.Exception as E (handle, SomeException(..)) import Control.Exception (SomeException(..))
import qualified Control.Exception as E
import Control.Monad (when, void) import Control.Monad (when, void)
import Data.Function import Data.Function (on)
import Data.List (intercalate, groupBy, sort, find) import Data.List (intercalate, groupBy, sort, find)
#if MIN_VERSION_containers(0,5,0) #if MIN_VERSION_containers(0,5,0)
import Data.Map.Strict (Map) import Data.Map.Strict (Map)
@ -26,9 +27,10 @@ import qualified Data.Map as M
#endif #endif
import Data.Set (Set) import Data.Set (Set)
import qualified Data.Set as S import qualified Data.Set as S
import qualified Exception as G (ghandle) import qualified Exception as GE
import GHC import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile))
import GhcMonad import qualified GHC as G
import GhcMonad (liftIO)
import HscTypes (SourceError) import HscTypes (SourceError)
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal import Language.Haskell.GhcMod.Internal
@ -55,7 +57,7 @@ main = E.handle handler $ do
opt = defaultOptions opt = defaultOptions
ls = lineSeparator opt ls = lineSeparator opt
LineSeparator lsc = ls LineSeparator lsc = ls
handler (E.SomeException e) = do handler (SomeException e) = do
putStr "ghc-modi:0:0:" putStr "ghc-modi:0:0:"
let x = intercalate lsc $ lines $ show e let x = intercalate lsc $ lines $ show e
putStrLn x putStrLn x
@ -64,22 +66,22 @@ main = E.handle handler $ do
---------------------------------------------------------------- ----------------------------------------------------------------
run :: Cradle -> Maybe FilePath -> Options -> (Logger -> Ghc a) -> IO a run :: Cradle -> Maybe FilePath -> Options -> (Logger -> Ghc a) -> IO a
run cradle mlibdir opt body = runGhc mlibdir $ do run cradle mlibdir opt body = G.runGhc mlibdir $ do
(readLog,_) <- initializeFlagsWithCradle opt cradle ["-Wall"] True (readLog,_) <- initializeFlagsWithCradle opt cradle ["-Wall"] True
dflags <- getSessionDynFlags dflags <- G.getSessionDynFlags
defaultCleanupHandler dflags $ body readLog G.defaultCleanupHandler dflags $ body readLog
---------------------------------------------------------------- ----------------------------------------------------------------
setupDB :: Cradle -> Maybe FilePath -> Options -> MVar DB -> IO () setupDB :: Cradle -> Maybe FilePath -> Options -> MVar DB -> IO ()
setupDB cradle mlibdir opt mvar = E.handle handler $ do setupDB cradle mlibdir opt mvar = E.handle handler $ do
sm <- run cradle mlibdir opt $ \_ -> getSessionDynFlags >>= browseAll sm <- run cradle mlibdir opt $ \_ -> G.getSessionDynFlags >>= browseAll
let sms = map tieup $ groupBy ((==) `on` fst) $ sort sm let sms = map tieup $ groupBy ((==) `on` fst) $ sort sm
m = M.fromList sms m = M.fromList sms
putMVar mvar m putMVar mvar m
where where
tieup x = (head (map fst x), map snd x) tieup x = (head (map fst x), map snd x)
handler (E.SomeException _) = return () handler (SomeException _) = return ()
---------------------------------------------------------------- ----------------------------------------------------------------
@ -107,10 +109,10 @@ checkStx :: Set FilePath
-> Ghc ([String], Bool, Set FilePath) -> Ghc ([String], Bool, Set FilePath)
checkStx set ls readLog file = do checkStx set ls readLog file = do
let add = not $ S.member file set let add = not $ S.member file set
G.ghandle handler $ do GE.ghandle handler $ do
mdel <- removeMainTarget mdel <- removeMainTarget
when add $ addTargetFiles [file] when add $ addTargetFiles [file]
void $ load LoadAllTargets void $ G.load LoadAllTargets
msgs <- liftIO $ readLog msgs <- liftIO $ readLog
let set1 = if add then S.insert file set else set let set1 = if add then S.insert file set else set
set2 = case mdel of set2 = case mdel of
@ -123,18 +125,18 @@ checkStx set ls readLog file = do
errmsgs <- handleErrMsg ls err errmsgs <- handleErrMsg ls err
return (errmsgs, False, set) return (errmsgs, False, set)
removeMainTarget = do removeMainTarget = do
mx <- find isMain <$> getModuleGraph mx <- find isMain <$> G.getModuleGraph
case mx of case mx of
Nothing -> return Nothing Nothing -> return Nothing
Just x -> do Just x -> do
let mainfile = ms_hspp_file x let mainfile = G.ms_hspp_file x
if mainfile == file then if mainfile == file then
return Nothing return Nothing
else do else do
let target = TargetFile mainfile Nothing let target = TargetFile mainfile Nothing
removeTarget target G.removeTarget target
return $ Just mainfile return $ Just mainfile
isMain m = moduleNameString (moduleName (ms_mod m)) == "Main" isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
findSym :: Set FilePath -> MVar DB -> String findSym :: Set FilePath -> MVar DB -> String
-> Ghc ([String], Bool, Set FilePath) -> Ghc ([String], Bool, Set FilePath)