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

using force just in case.

This commit is contained in:
Kazu Yamamoto 2014-04-22 13:32:33 +09:00
parent b8a151421d
commit bd34db1b07
2 changed files with 5 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ghc-mod.cabal
View File

@ -108,6 +108,7 @@ Executable ghc-modi
HS-Source-Dirs: src HS-Source-Dirs: src
Build-Depends: base >= 4.0 && < 5 Build-Depends: base >= 4.0 && < 5
, containers , containers
, deepseq
, directory , directory
, filepath , filepath
, ghc , ghc

7
src/GHCModi.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
-- Commands: -- Commands:
@ -25,6 +25,7 @@ module Main where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar) import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)
import Control.Exception (SomeException(..)) import Control.Exception (SomeException(..))
import Control.DeepSeq (force)
import qualified Control.Exception as E import qualified Control.Exception as E
import Control.Monad (when, void) import Control.Monad (when, void)
import CoreMonad (liftIO) import CoreMonad (liftIO)
@ -142,8 +143,8 @@ run cradle mlibdir opt body = G.runGhc mlibdir $ do
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 $ \_ -> G.getSessionDynFlags >>= browseAll sm <- run cradle mlibdir opt $ \_ -> G.getSessionDynFlags >>= browseAll
let sms = map tieup $ groupBy ((==) `on` fst) $ sort sm let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm
m = M.fromList sms !m = force $ 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)