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

cleaning up APIs.

Browse Source
This commit is contained in:
Kazu Yamamoto 2014-04-21 14:04:58 +09:00
parent 1006cd4eec
commit b2c2d1a443
7 changed files with 57 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
Language/Haskell/GhcMod/Check.hs
View File

@ -1,6 +1,5 @@
module Language.Haskell.GhcMod.Check (checkSyntax, check) where module Language.Haskell.GhcMod.Check (checkSyntax, check) where
import Control.Applicative ((<$>))
import Control.Monad (void) import Control.Monad (void)
import CoreMonad (liftIO) import CoreMonad (liftIO)
import GHC (Ghc, LoadHowMuch(LoadAllTargets)) import GHC (Ghc, LoadHowMuch(LoadAllTargets))
@ -18,7 +17,7 @@ checkSyntax :: Options
-> [FilePath] -- ^ The target files. -> [FilePath] -- ^ The target files.
-> IO String -> IO String
checkSyntax _ _ [] = error "ghc-mod: checkSyntax: No files given" checkSyntax _ _ [] = error "ghc-mod: checkSyntax: No files given"
checkSyntax opt cradle files = convert opt <$> withGHC sessionName (check opt cradle files) checkSyntax opt cradle files = withGHC sessionName (check opt cradle files)
where where
sessionName = case files of sessionName = case files of
[file] -> file [file] -> file
@ -31,9 +30,9 @@ checkSyntax opt cradle files = convert opt <$> withGHC sessionName (check opt cr
check :: Options check :: Options
-> Cradle -> Cradle
-> [FilePath] -- ^ The target files. -> [FilePath] -- ^ The target files.
-> Ghc [String] -> Ghc String
check _ _ [] = error "ghc-mod: check: No files given" check _ _ [] = error "ghc-mod: check: No files given"
check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg opt
where where
checkIt = do checkIt = do
(readLog,_) <- initializeFlagsWithCradle opt cradle options True (readLog,_) <- initializeFlagsWithCradle opt cradle options True
@ -43,4 +42,3 @@ check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls
options options
| expandSplice opt = "-w:" : ghcOpts opt | expandSplice opt = "-w:" : ghcOpts opt
| otherwise = "-Wall" : ghcOpts opt | otherwise = "-Wall" : ghcOpts opt
ls = lineSeparator opt

27
Language/Haskell/GhcMod/ErrMsg.hs
View File

@ -17,14 +17,14 @@ import qualified GHC as G
import HscTypes (SourceError, srcErrorMessages) import HscTypes (SourceError, srcErrorMessages)
import Language.Haskell.GhcMod.Doc (showPage, getStyle) import Language.Haskell.GhcMod.Doc (showPage, getStyle)
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types (LineSeparator(..)) import Language.Haskell.GhcMod.Types (LineSeparator(..), Options(..), convert)
import Outputable (PprStyle, SDoc) import Outputable (PprStyle, SDoc)
import System.FilePath (normalise) import System.FilePath (normalise)
---------------------------------------------------------------- ----------------------------------------------------------------
-- | A means to read the log. -- | A means to read the log.
type LogReader = IO [String] type LogReader = IO String
---------------------------------------------------------------- ----------------------------------------------------------------
@ -35,11 +35,11 @@ newtype LogRef = LogRef (IORef Builder)
newLogRef :: IO LogRef newLogRef :: IO LogRef
newLogRef = LogRef <$> newIORef id newLogRef = LogRef <$> newIORef id
readAndClearLogRef :: LogRef -> IO [String] readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef (LogRef ref) = do readAndClearLogRef opt (LogRef ref) = do
b <- readIORef ref b <- readIORef ref
writeIORef ref id writeIORef ref id
return $! b [] return $! convert opt (b [])
appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
appendLogRef df ls (LogRef ref) _ sev src style msg = do appendLogRef df ls (LogRef ref) _ sev src style msg = do
@ -48,23 +48,28 @@ appendLogRef df ls (LogRef ref) _ sev src style msg = do
---------------------------------------------------------------- ----------------------------------------------------------------
setLogger :: Bool -> DynFlags -> LineSeparator -> IO (DynFlags, LogReader) setLogger :: Bool -> DynFlags -> Options -> IO (DynFlags, LogReader)
setLogger False df _ = return (newdf, undefined) setLogger False df _ = return (newdf, undefined)
where where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return () newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True df ls = do setLogger True df opt = do
logref <- newLogRef logref <- newLogRef
let newdf = Gap.setLogAction df $ appendLogRef df ls logref let newdf = Gap.setLogAction df $ appendLogRef df ls logref
return (newdf, readAndClearLogRef logref) return (newdf, readAndClearLogRef opt logref)
where
ls = lineSeparator opt
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Converting 'SourceError' to 'String'. -- | Converting 'SourceError' to 'String'.
handleErrMsg :: LineSeparator -> SourceError -> Ghc [String] handleErrMsg :: Options -> SourceError -> Ghc String
handleErrMsg ls err = do handleErrMsg opt err = do
dflag <- G.getSessionDynFlags dflag <- G.getSessionDynFlags
style <- getStyle style <- getStyle
return . errBagToStrList dflag ls style . srcErrorMessages $ err let ret = convert opt . errBagToStrList dflag ls style . srcErrorMessages $ err
return ret
where
ls = lineSeparator opt
errBagToStrList :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String] errBagToStrList :: DynFlags -> LineSeparator -> PprStyle -> Bag ErrMsg -> [String]
errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList errBagToStrList dflag ls style = map (ppErrMsg dflag ls style) . reverse . bagToList

3
Language/Haskell/GhcMod/GHCApi.hs
View File

@ -113,12 +113,11 @@ initSession build opt compOpts logging = do
cmdOpts = ghcOptions compOpts cmdOpts = ghcOptions compOpts
idirs = includeDirs compOpts idirs = includeDirs compOpts
depPkgs = depPackages compOpts depPkgs = depPackages compOpts
ls = lineSeparator opt
setupDynamicFlags df0 = do setupDynamicFlags df0 = do
df1 <- modifyFlagsWithOpts df0 cmdOpts df1 <- modifyFlagsWithOpts df0 cmdOpts
let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build
df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt
liftIO $ setLogger logging df3 ls liftIO $ setLogger logging df3 opt
---------------------------------------------------------------- ----------------------------------------------------------------

4
Language/Haskell/GhcMod/Ghc.hs
View File

@ -6,14 +6,12 @@ module Language.Haskell.GhcMod.Ghc (
, browse , browse
, check , check
, info , info
, typeOf , types
, modules , modules
, lint
) where ) where
import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.Check import Language.Haskell.GhcMod.Check
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.Info
import Language.Haskell.GhcMod.Lint
import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.List

18
Language/Haskell/GhcMod/Info.hs
View File

@ -5,7 +5,7 @@ module Language.Haskell.GhcMod.Info (
infoExpr infoExpr
, info , info
, typeExpr , typeExpr
, typeOf , types
) where ) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
@ -13,7 +13,7 @@ import Control.Monad (void)
import CoreMonad (liftIO) import CoreMonad (liftIO)
import CoreUtils (exprType) import CoreUtils (exprType)
import Data.Function (on) import Data.Function (on)
import Data.Generics hiding (typeOf) import Data.Generics
import Data.List (sortBy) import Data.List (sortBy)
import Data.Maybe (catMaybes, fromMaybe) import Data.Maybe (catMaybes, fromMaybe)
import Data.Ord as O import Data.Ord as O
@ -72,17 +72,17 @@ typeExpr :: Options
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> IO String -> IO String
typeExpr opt cradle file lineNo colNo = withGHCDummyFile $ typeExpr opt cradle file lineNo colNo = withGHCDummyFile $
inModuleContext opt cradle file (typeOf opt file lineNo colNo) errmsg inModuleContext opt cradle file (types opt file lineNo colNo) errmsg
where where
errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)]) errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])
-- | Obtaining type of a target expression. (GHCi's type:) -- | Obtaining type of a target expression. (GHCi's type:)
typeOf :: Options types :: Options
-> FilePath -- ^ A target file. -> FilePath -- ^ A target file.
-> Int -- ^ Line number. -> Int -- ^ Line number.
-> Int -- ^ Column number. -> Int -- ^ Column number.
-> Ghc String -> Ghc String
typeOf opt file lineNo colNo = do types opt file lineNo colNo = do
modSum <- Gap.setCtx file modSum <- Gap.setCtx file
(dflag, style) <- getFlagStyle (dflag, style) <- getFlagStyle
srcSpanTypes <- getSrcSpanType modSum lineNo colNo srcSpanTypes <- getSrcSpanType modSum lineNo colNo

9
Language/Haskell/GhcMod/Lint.hs
View File

@ -10,15 +10,8 @@ import Language.Haskell.HLint (hlint)
lintSyntax :: Options lintSyntax :: Options
-> FilePath -- ^ A target file. -> FilePath -- ^ A target file.
-> IO String -> IO String
lintSyntax opt file = pack <$> lint hopts file lintSyntax opt file = pack . map show <$> hlint (file : "--quiet" : hopts)
where where
LineSeparator lsep = lineSeparator opt LineSeparator lsep = lineSeparator opt
pack = convert opt . map (intercalate lsep . lines) pack = convert opt . map (intercalate lsep . lines)
hopts = hlintOpts opt hopts = hlintOpts opt
-- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned.
lint :: [String]
-> FilePath -- ^ A target file.
-> IO [String]
lint hopts file = map show <$> hlint (file : "--quiet" : hopts)

57
src/GHCModi.hs
View File

@ -56,7 +56,7 @@ import System.IO (hFlush,stdout)
---------------------------------------------------------------- ----------------------------------------------------------------
type DB = Map String [String] type DB = Map String [String]
type Logger = IO [String] type Logger = IO String
---------------------------------------------------------------- ----------------------------------------------------------------
@ -119,12 +119,11 @@ main = handle [GE.Handler cmdHandler, GE.Handler someHandler] $
cradle0 <- findCradle cradle0 <- findCradle
let rootdir = cradleRootDir cradle0 let rootdir = cradleRootDir cradle0
cradle = cradle0 { cradleCurrentDir = rootdir } cradle = cradle0 { cradleCurrentDir = rootdir }
ls = lineSeparator opt
setCurrentDirectory rootdir setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar mvar <- liftIO newEmptyMVar
mlibdir <- getSystemLibDir mlibdir <- getSystemLibDir
void $ forkIO $ setupDB cradle mlibdir opt mvar void $ forkIO $ setupDB cradle mlibdir opt mvar
run cradle mlibdir opt $ loop opt S.empty ls mvar run cradle mlibdir opt $ loop opt S.empty mvar
---------------------------------------------------------------- ----------------------------------------------------------------
@ -148,17 +147,17 @@ setupDB cradle mlibdir opt mvar = E.handle handler $ do
---------------------------------------------------------------- ----------------------------------------------------------------
loop :: Options -> Set FilePath -> LineSeparator -> MVar DB -> Logger -> Ghc () loop :: Options -> Set FilePath -> MVar DB -> Logger -> Ghc ()
loop opt set ls mvar readLog = do loop opt set mvar readLog = do
cmdArg <- liftIO getLine cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg' arg = dropWhile (== ' ') arg'
(ret,ok,set') <- case cmd of (ret,ok,set') <- case cmd of
"check" -> checkStx opt set ls readLog arg "check" -> checkStx opt set arg readLog
"find" -> findSym opt set mvar arg "find" -> findSym opt set arg mvar
"lint" -> lintStx opt set ls arg "lint" -> lintStx opt set arg
"info" -> showInfo opt set ls readLog arg "info" -> showInfo opt set arg readLog
"type" -> showType opt set ls readLog arg "type" -> showType opt set arg readLog
_ -> return ([], False, set) _ -> return ([], False, set)
let put = case outputStyle opt of let put = case outputStyle opt of
LispStyle -> putStr LispStyle -> putStr
@ -166,17 +165,16 @@ loop opt set ls mvar readLog = do
liftIO $ put ret liftIO $ put ret
liftIO $ putStrLn $ if ok then "OK" else "NG" liftIO $ putStrLn $ if ok then "OK" else "NG"
liftIO $ hFlush stdout liftIO $ hFlush stdout
when ok $ loop opt set' ls mvar readLog when ok $ loop opt set' mvar readLog
---------------------------------------------------------------- ----------------------------------------------------------------
checkStx :: Options checkStx :: Options
-> Set FilePath -> Set FilePath
-> LineSeparator
-> Logger
-> FilePath -> FilePath
-> Logger
-> Ghc (String, Bool, Set FilePath) -> Ghc (String, Bool, Set FilePath)
checkStx opt set ls readLog file = do checkStx opt set file readLog = do
let add = not $ S.member file set let add = not $ S.member file set
GE.ghandle handler $ do GE.ghandle handler $ do
mdel <- removeMainTarget mdel <- removeMainTarget
@ -192,8 +190,7 @@ checkStx opt set ls readLog file = do
where where
handler :: SourceError -> Ghc (String, Bool, Set FilePath) handler :: SourceError -> Ghc (String, Bool, Set FilePath)
handler err = do handler err = do
errmsgs <- handleErrMsg ls err ret <- handleErrMsg opt err
let ret = convert opt errmsgs
return (ret, False, set) return (ret, False, set)
removeMainTarget = do removeMainTarget = do
mx <- find isMain <$> G.getModuleGraph mx <- find isMain <$> G.getModuleGraph
@ -212,22 +209,22 @@ checkStx opt set ls readLog file = do
return $ Just mainfile return $ Just mainfile
isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main" isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
findSym :: Options -> Set FilePath -> MVar DB -> String findSym :: Options -> Set FilePath -> String -> MVar DB
-> Ghc (String, Bool, Set FilePath) -> Ghc (String, Bool, Set FilePath)
findSym opt set mvar sym = do findSym opt set sym mvar = do
db <- liftIO $ readMVar mvar db <- liftIO $ readMVar mvar
let ret = convert opt $ fromMaybe [] (M.lookup sym db) let ret = convert opt $ fromMaybe [] (M.lookup sym db)
return (ret, True, set) return (ret, True, set)
lintStx :: Options -> Set FilePath -> LineSeparator -> FilePath lintStx :: Options -> Set FilePath -> FilePath
-> Ghc (String, Bool, Set FilePath) -> Ghc (String, Bool, Set FilePath)
lintStx opt set (LineSeparator lsep) optFile = liftIO $ E.handle handler $ do lintStx opt set optFile = liftIO $ E.handle handler $ do
msgs <- map (intercalate lsep . lines) <$> lint hopts file ret <-lintSyntax opt' file
let ret = convert opt msgs
return (ret, True, set) return (ret, True, set)
where where
(opts,file) = parseLintOptions optFile (opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts hopts = if opts == "" then [] else read opts
opt' = opt { hlintOpts = hopts }
-- let's continue the session -- let's continue the session
handler (SomeException e) = do handler (SomeException e) = do
print e print e
@ -250,26 +247,24 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
showInfo :: Options showInfo :: Options
-> Set FilePath -> Set FilePath
-> LineSeparator
-> Logger
-> FilePath -> FilePath
-> Logger
-> Ghc (String, Bool, Set FilePath) -> Ghc (String, Bool, Set FilePath)
showInfo opt set ls readLog fileArg = do showInfo opt set fileArg readLog = do
let [file, expr] = words fileArg let [file, expr] = words fileArg
(_, _, set') <- checkStx opt set ls readLog file (_, _, set') <- checkStx opt set file readLog
ret <- info opt file expr ret <- info opt file expr
_ <- liftIO readLog _ <- liftIO readLog
return (ret, True, set') return (ret, True, set')
showType :: Options showType :: Options
-> Set FilePath -> Set FilePath
-> LineSeparator
-> Logger
-> FilePath -> FilePath
-> Logger
-> Ghc (String, Bool, Set FilePath) -> Ghc (String, Bool, Set FilePath)
showType opt set ls readLog fileArg = do showType opt set fileArg readLog = do
let [file, line, column] = words fileArg let [file, line, column] = words fileArg
(_, _, set') <- checkStx opt set ls readLog file (_, _, set') <- checkStx opt set file readLog
ret <- typeOf opt file (read line) (read column) ret <- types opt file (read line) (read column)
_ <- liftIO readLog _ <- liftIO readLog
return (ret, True, set') return (ret, True, set')