type check.

This commit is contained in:
Kazu Yamamoto 2010-11-12 16:27:50 +09:00
parent 0fd39e9b56
commit 9467a5d22e
5 changed files with 74 additions and 38 deletions

View File

@ -3,7 +3,6 @@ module Check (checkSyntax) where
import Bag import Bag
import Control.Applicative import Control.Applicative
import Data.IORef import Data.IORef
import DynFlags
import ErrUtils import ErrUtils
import Exception import Exception
import FastString import FastString
@ -23,28 +22,18 @@ checkSyntax _ file = unlines <$> check file
check :: String -> IO [String] check :: String -> IO [String]
check fileName = withGHC $ do check fileName = withGHC $ do
ref <- liftIO $ newIORef [] ref <- newRef []
initSession initSession ["-Wall","-fno-warn-unused-do-bind"]
setTargetFile fileName setTargetFile fileName
loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref loadWithLogger (refLogger ref) LoadAllTargets `gcatch` handleParseError ref
clearWarnings clearWarnings
liftIO $ readIORef ref readRef ref
where where
-- I don't know why, but parseDynamicFlags must be used.
initSession = do
dflags <- getSessionDynFlags
(dflags',_,_) <- parseDynamicFlags dflags cmdOptions
setSessionDynFlags $ setFlags dflags'
setTargetFile file = do
target <- guessTarget file Nothing
setTargets [target]
handleParseError ref e = do handleParseError ref e = do
liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e liftIO . writeIORef ref $ errBagToStrList . srcErrorMessages $ e
return Succeeded return Succeeded
newRef = liftIO . newIORef
-- I don't know why, but parseDynamicFlags must be used. readRef = liftIO . readIORef
cmdOptions :: [Located String]
cmdOptions = map noLoc ["-Wall","-fno-warn-unused-do-bind"]
---------------------------------------------------------------- ----------------------------------------------------------------
@ -59,24 +48,6 @@ errBagToStrList = map showErrMsg . reverse . bagToList
---------------------------------------------------------------- ----------------------------------------------------------------
setFlags :: DynFlags -> DynFlags
setFlags d = d {
importPaths = importPaths d ++ importDirs
, packageFlags = ghcPackage : packageFlags d
, ghcLink = NoLink
-- GHC.desugarModule does not produces the pattern warnings, why?
-- , hscTarget = HscNothing
, hscTarget = HscInterpreted
}
importDirs :: [String]
importDirs = ["..","../..","../../..","../../../../.."]
ghcPackage :: PackageFlag
ghcPackage = ExposePackage "ghc"
----------------------------------------------------------------
showErrMsg :: ErrMsg -> String showErrMsg :: ErrMsg -> String
showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext showErrMsg err = file ++ ":" ++ line ++ ":" ++ col ++ ":" ++ msg ++ "\0" ++ ext
where where

View File

@ -7,6 +7,7 @@ import Check
import Control.Applicative import Control.Applicative
import Control.Exception import Control.Exception
import Data.Typeable import Data.Typeable
import Info
import Lang import Lang
import Lint import Lint
import List import List
@ -26,6 +27,7 @@ usage = "ghc-mod version 0.4.4\n"
++ "\t ghc-mod [-l] lang\n" ++ "\t ghc-mod [-l] lang\n"
++ "\t ghc-mod [-l] browse <module> [<module> ...]\n" ++ "\t ghc-mod [-l] browse <module> [<module> ...]\n"
++ "\t ghc-mod check <HaskellFile>\n" ++ "\t ghc-mod check <HaskellFile>\n"
++ "\t ghc-mod info <HaskellFile> <expression>\n"
++ "\t ghc-mod [-h opt] lint <HaskellFile>\n" ++ "\t ghc-mod [-h opt] lint <HaskellFile>\n"
++ "\t ghc-mod boot\n" ++ "\t ghc-mod boot\n"
++ "\t ghc-mod help\n" ++ "\t ghc-mod help\n"
@ -72,6 +74,7 @@ main = flip catches handlers $ do
"browse" -> concat <$> mapM (browseModule opt) (tail cmdArg) "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)
"list" -> listModules opt "list" -> listModules opt
"check" -> withFile (checkSyntax opt) (safelist cmdArg 1) "check" -> withFile (checkSyntax opt) (safelist cmdArg 1)
"info" -> withFile (infoExpr opt (safelist cmdArg 2)) (safelist cmdArg 1)
"lint" -> withFile (lintSyntax opt) (safelist cmdArg 1) "lint" -> withFile (lintSyntax opt) (safelist cmdArg 1)
"lang" -> listLanguages opt "lang" -> listLanguages opt
"boot" -> do "boot" -> do

24
Info.hs Normal file
View File

@ -0,0 +1,24 @@
module Info where
import Control.Applicative
import GHC
import Outputable
import PprTyThing
import Types
infoExpr :: Options -> String -> String -> IO String
infoExpr _ expr file = (++ "\n") <$> info file expr
info :: String -> String -> IO String
info fileName expr = withGHC $ do
initSession []
setTargetFile fileName
load LoadAllTargets
setContextFromTarget
pretty <$> exprType expr
where
setContextFromTarget = do
[mdlsum,_] <- depanal [] False
mdl <- findModule (ms_mod_name mdlsum) Nothing
setContext [mdl] []
pretty = showSDocForUser neverQualify . pprTypeForUser False

View File

@ -1,19 +1,57 @@
module Types where module Types where
import Control.Monad
import DynFlags
import Exception import Exception
import GHC import GHC
import GHC.Paths (libdir) import GHC.Paths (libdir)
----------------------------------------------------------------
data Options = Options { data Options = Options {
convert :: [String] -> String convert :: [String] -> String
, hlintOpts :: [String] , hlintOpts :: [String]
} }
withGHC :: Ghc [String] -> IO [String] withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a)
withGHC body = ghandle ignore $ runGhc (Just libdir) body withGHC body = ghandle ignore $ runGhc (Just libdir) body
where where
ignore :: SomeException -> IO [String] ignore :: (MonadPlus m) => SomeException -> IO (m a)
ignore _ = return [] ignore _ = return mzero
----------------------------------------------------------------
initSession0 :: Ghc [PackageId] initSession0 :: Ghc [PackageId]
initSession0 = getSessionDynFlags >>= setSessionDynFlags initSession0 = getSessionDynFlags >>= setSessionDynFlags
initSession :: [String] -> Ghc [PackageId]
initSession cmdOpts = do
dflags <- getSessionDynFlags
let opts = map noLoc cmdOpts
(dflags',_,_) <- parseDynamicFlags dflags opts
setSessionDynFlags $ setFlags dflags'
----------------------------------------------------------------
setFlags :: DynFlags -> DynFlags
setFlags d = d {
importPaths = importPaths d ++ importDirs
, packageFlags = ghcPackage : packageFlags d
, ghcLink = NoLink
-- GHC.desugarModule does not produces the pattern warnings, why?
-- , hscTarget = HscNothing
, hscTarget = HscInterpreted
}
importDirs :: [String]
importDirs = ["..","../..","../../..","../../../../.."]
ghcPackage :: PackageFlag
ghcPackage = ExposePackage "ghc"
----------------------------------------------------------------
setTargetFile :: (GhcMonad m) => String -> m ()
setTargetFile file = do
target <- guessTarget file Nothing
setTargets [target]

View File

@ -23,7 +23,7 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
ghc-flymake.el ghc-command.el ghc-flymake.el ghc-command.el
Executable ghc-mod Executable ghc-mod
Main-Is: GHCMod.hs Main-Is: GHCMod.hs
Other-Modules: List Browse Check Lang Lint Types Other-Modules: List Browse Check Info Lang Lint Types
if impl(ghc >= 6.12) if impl(ghc >= 6.12)
GHC-Options: -Wall -fno-warn-unused-do-bind GHC-Options: -Wall -fno-warn-unused-do-bind
else else