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
import Control.Applicative ((<$>))
import Control.Monad (void)
import CoreMonad (liftIO)
import GHC (Ghc, LoadHowMuch(LoadAllTargets))
@ -18,7 +17,7 @@ checkSyntax :: Options
-> [FilePath] -- ^ The target files.
-> IO String
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
sessionName = case files of
[file] -> file
@ -31,9 +30,9 @@ checkSyntax opt cradle files = convert opt <$> withGHC sessionName (check opt cr
check :: Options
-> Cradle
-> [FilePath] -- ^ The target files.
-> Ghc [String]
-> Ghc String
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
checkIt = do
(readLog,_) <- initializeFlagsWithCradle opt cradle options True
@ -43,4 +42,3 @@ check opt cradle fileNames = checkIt `G.gcatch` handleErrMsg ls
options
| expandSplice opt = "-w:" : 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 Language.Haskell.GhcMod.Doc (showPage, getStyle)
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 System.FilePath (normalise)
----------------------------------------------------------------
-- | 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 = LogRef <$> newIORef id
readAndClearLogRef :: LogRef -> IO [String]
readAndClearLogRef (LogRef ref) = do
readAndClearLogRef :: Options -> LogRef -> IO String
readAndClearLogRef opt (LogRef ref) = do
b <- readIORef ref
writeIORef ref id
return $! b []
return $! convert opt (b [])
appendLogRef :: DynFlags -> LineSeparator -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
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)
where
newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()
setLogger True df ls = do
setLogger True df opt = do
logref <- newLogRef
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'.
handleErrMsg :: LineSeparator -> SourceError -> Ghc [String]
handleErrMsg ls err = do
handleErrMsg :: Options -> SourceError -> Ghc String
handleErrMsg opt err = do
dflag <- G.getSessionDynFlags
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 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
idirs = includeDirs compOpts
depPkgs = depPackages compOpts
ls = lineSeparator opt
setupDynamicFlags df0 = do
df1 <- modifyFlagsWithOpts df0 cmdOpts
let df2 = modifyFlags df1 idirs depPkgs (expandSplice opt) build
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
, check
, info
, typeOf
, types
, modules
, lint
) where
import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.Check
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Info
import Language.Haskell.GhcMod.Lint
import Language.Haskell.GhcMod.List

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

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

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

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