ghc-mod/src/GHCModi.hs

185 lines
6.1 KiB
Haskell
Raw Normal View History

2014-03-27 07:28:27 +00:00
{-# LANGUAGE CPP #-}
2014-03-25 02:14:25 +00:00
2014-03-27 01:34:43 +00:00
-- Commands:
-- check <file>
-- find <symbol>
2014-03-28 04:44:44 +00:00
-- lint [hlint options] <file>
-- the format of hlint options is [String] because they may contain
-- spaces and aslo <file> may contain spaces.
2014-03-27 01:34:43 +00:00
--
-- Session separators:
-- OK -- success
-- NG -- failure
2014-03-19 01:23:47 +00:00
module Main where
2014-03-27 07:28:27 +00:00
#ifndef MIN_VERSION_containers
#define MIN_VERSION_containers 1
#endif
2014-03-25 03:28:39 +00:00
import Control.Applicative ((<$>))
2014-03-27 05:55:24 +00:00
import Control.Concurrent (forkIO, MVar, newEmptyMVar, putMVar, readMVar)
import Control.Exception (SomeException(..))
import qualified Control.Exception as E
2014-03-24 08:32:06 +00:00
import Control.Monad (when, void)
2014-03-27 06:08:07 +00:00
import CoreMonad (liftIO)
2014-03-27 05:55:24 +00:00
import Data.Function (on)
2014-03-25 03:28:39 +00:00
import Data.List (intercalate, groupBy, sort, find)
#if MIN_VERSION_containers(0,5,0)
2014-03-25 02:14:25 +00:00
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
#else
import Data.Map (Map)
import qualified Data.Map as M
#endif
2014-03-28 04:53:58 +00:00
import Data.Maybe (fromMaybe)
2014-03-25 02:14:25 +00:00
import Data.Set (Set)
import qualified Data.Set as S
2014-03-27 05:55:24 +00:00
import qualified Exception as GE
import GHC (Ghc, LoadHowMuch(LoadAllTargets), TargetId(TargetFile))
import qualified GHC as G
2014-03-25 02:34:58 +00:00
import HscTypes (SourceError)
2014-03-19 01:23:47 +00:00
import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Internal
2014-03-24 08:32:06 +00:00
import System.IO (hFlush,stdout)
2014-03-19 01:23:47 +00:00
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
type DB = Map String [String]
type Logger = IO [String]
----------------------------------------------------------------
2014-03-25 02:34:58 +00:00
-- Running two GHC monad threads disables the handling of
-- C-c since installSignalHandlers is called twice, sigh.
2014-03-19 01:23:47 +00:00
main :: IO ()
2014-03-25 02:14:25 +00:00
main = E.handle handler $ do
2014-03-19 01:23:47 +00:00
cradle <- findCradle
2014-03-25 02:14:25 +00:00
mvar <- liftIO newEmptyMVar
mlibdir <- getSystemLibDir
void $ forkIO $ setupDB cradle mlibdir opt mvar
run cradle mlibdir opt $ loop S.empty ls mvar
2014-03-19 01:23:47 +00:00
where
opt = defaultOptions
ls = lineSeparator opt
2014-03-25 02:14:25 +00:00
LineSeparator lsc = ls
2014-03-27 05:55:24 +00:00
handler (SomeException e) = do
putStr "ghc-modi:0:0:"
2014-03-25 02:14:25 +00:00
let x = intercalate lsc $ lines $ show e
2014-03-20 08:40:06 +00:00
putStrLn x
putStrLn "NG"
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
run :: Cradle -> Maybe FilePath -> Options -> (Logger -> Ghc a) -> IO a
2014-03-27 05:55:24 +00:00
run cradle mlibdir opt body = G.runGhc mlibdir $ do
2014-03-25 02:14:25 +00:00
(readLog,_) <- initializeFlagsWithCradle opt cradle ["-Wall"] True
2014-03-27 05:55:24 +00:00
dflags <- G.getSessionDynFlags
G.defaultCleanupHandler dflags $ body readLog
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
setupDB :: Cradle -> Maybe FilePath -> Options -> MVar DB -> IO ()
setupDB cradle mlibdir opt mvar = E.handle handler $ do
2014-03-27 05:55:24 +00:00
sm <- run cradle mlibdir opt $ \_ -> G.getSessionDynFlags >>= browseAll
2014-03-25 02:14:25 +00:00
let sms = map tieup $ groupBy ((==) `on` fst) $ sort sm
m = M.fromList sms
putMVar mvar m
where
tieup x = (head (map fst x), map snd x)
2014-03-27 05:55:24 +00:00
handler (SomeException _) = return ()
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
loop :: Set FilePath -> LineSeparator -> MVar DB -> Logger -> Ghc ()
loop set ls mvar readLog = do
2014-03-28 04:53:58 +00:00
cmdArg <- liftIO getLine
2014-03-24 08:32:06 +00:00
let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg'
(msgs,ok,set') <- case cmd of
2014-03-25 02:14:25 +00:00
"check" -> checkStx set ls readLog arg
"find" -> findSym set mvar arg
2014-03-27 01:34:43 +00:00
"lint" -> lintStx set ls arg
2014-03-24 08:32:06 +00:00
_ -> return ([], False, set)
mapM_ (liftIO . putStrLn) msgs
liftIO $ putStrLn $ if ok then "OK" else "NG"
liftIO $ hFlush stdout
2014-03-25 02:14:25 +00:00
when ok $ loop set' ls mvar readLog
2014-03-24 08:32:06 +00:00
2014-03-25 02:14:25 +00:00
----------------------------------------------------------------
checkStx :: Set FilePath
2014-03-24 08:32:06 +00:00
-> LineSeparator
2014-03-25 02:14:25 +00:00
-> Logger
2014-03-24 08:32:06 +00:00
-> FilePath
-> Ghc ([String], Bool, Set FilePath)
2014-03-25 02:14:25 +00:00
checkStx set ls readLog file = do
2014-03-19 01:23:47 +00:00
let add = not $ S.member file set
2014-03-27 05:55:24 +00:00
GE.ghandle handler $ do
2014-03-25 03:28:39 +00:00
mdel <- removeMainTarget
2014-03-19 01:23:47 +00:00
when add $ addTargetFiles [file]
2014-03-27 05:55:24 +00:00
void $ G.load LoadAllTargets
2014-03-28 04:53:58 +00:00
msgs <- liftIO readLog
2014-03-25 03:28:39 +00:00
let set1 = if add then S.insert file set else set
set2 = case mdel of
Nothing -> set1
Just delfl -> S.delete delfl set1
return (msgs, True, set2)
2014-03-19 01:23:47 +00:00
where
2014-03-25 02:14:25 +00:00
handler :: SourceError -> Ghc ([String], Bool, Set FilePath)
2014-03-19 01:23:47 +00:00
handler err = do
errmsgs <- handleErrMsg ls err
2014-03-24 08:32:06 +00:00
return (errmsgs, False, set)
2014-03-25 03:28:39 +00:00
removeMainTarget = do
2014-03-27 05:55:24 +00:00
mx <- find isMain <$> G.getModuleGraph
2014-03-25 03:28:39 +00:00
case mx of
Nothing -> return Nothing
Just x -> do
let mmainfile = G.ml_hs_file (G.ms_location x)
-- G.ms_hspp_file x is a temporary file with CPP.
-- this is a just fake.
mainfile = fromMaybe (G.ms_hspp_file x) mmainfile
2014-03-25 03:28:39 +00:00
if mainfile == file then
return Nothing
else do
let target = TargetFile mainfile Nothing
2014-03-27 05:55:24 +00:00
G.removeTarget target
2014-03-25 03:28:39 +00:00
return $ Just mainfile
2014-03-27 05:55:24 +00:00
isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
2014-03-25 02:14:25 +00:00
findSym :: Set FilePath -> MVar DB -> String
-> Ghc ([String], Bool, Set FilePath)
findSym set mvar sym = do
db <- liftIO $ readMVar mvar
2014-03-28 04:53:58 +00:00
let ret = fromMaybe [] (M.lookup sym db)
2014-03-25 02:14:25 +00:00
return (ret, True, set)
2014-03-27 01:34:43 +00:00
lintStx :: Set FilePath -> LineSeparator -> FilePath
-> Ghc ([String], Bool, Set FilePath)
2014-03-28 05:41:01 +00:00
lintStx set (LineSeparator lsep) optFile = liftIO $ E.handle handler $ do
2014-03-27 01:34:43 +00:00
msgs <- map (intercalate lsep . lines) <$> lint hopts file
2014-03-28 04:51:47 +00:00
return (msgs, True, set)
2014-03-27 01:34:43 +00:00
where
2014-03-28 05:41:01 +00:00
(opt,file) = parseLintOptions optFile
2014-03-28 06:03:41 +00:00
hopts = if opt == "" then [] else read opt
2014-03-28 04:51:47 +00:00
-- let's continue the session
2014-03-28 06:03:41 +00:00
handler (SomeException e) = do
print e
return ([], True, set)
2014-03-28 05:41:01 +00:00
-- |
-- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"
-- (["--ignore=Use camelCase", "--ignore=Eta reduce"], "file name")
-- >>> parseLintOptions "file name"
-- ([], "file name")
parseLintOptions :: String -> (String, String)
parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
("","") -> ([], optFile)
2014-03-28 06:03:41 +00:00
(opt',file') -> (opt', dropWhile (== ' ') file')
2014-03-28 05:41:01 +00:00
where
brk _ [] = ([],[])
brk p (x:xs')
| p x = ([x],xs')
| otherwise = let (ys,zs) = brk p xs' in (x:ys,zs)