adopting hlint's suggestions.
This commit is contained in:
parent
05f45f1d36
commit
cffa7463eb
@ -14,6 +14,10 @@ import Language.Haskell.GhcMod.Types
|
|||||||
import qualified Language.Haskell.GhcMod.Cabal16 as C16
|
import qualified Language.Haskell.GhcMod.Cabal16 as C16
|
||||||
import qualified Language.Haskell.GhcMod.Cabal18 as C18
|
import qualified Language.Haskell.GhcMod.Cabal18 as C18
|
||||||
|
|
||||||
|
#ifndef MIN_VERSION_mtl
|
||||||
|
#define MIN_VERSION_mtl(x,y,z) 1
|
||||||
|
#endif
|
||||||
|
|
||||||
import qualified Control.Exception as E
|
import qualified Control.Exception as E
|
||||||
import Control.Applicative ((<$>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Monad (mplus)
|
import Control.Monad (mplus)
|
||||||
@ -59,7 +63,7 @@ configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
|
|||||||
configDependencies thisPkg config = map fromInstalledPackageId deps
|
configDependencies thisPkg config = map fromInstalledPackageId deps
|
||||||
where
|
where
|
||||||
deps :: [InstalledPackageId]
|
deps :: [InstalledPackageId]
|
||||||
deps = case (deps18 `mplus` deps16) of
|
deps = case deps18 `mplus` deps16 of
|
||||||
Right ps -> ps
|
Right ps -> ps
|
||||||
Left msg -> error msg
|
Left msg -> error msg
|
||||||
|
|
||||||
|
@ -184,7 +184,7 @@ getBindingText text srcSpan =
|
|||||||
[T.drop (sc - 1) $ T.take ec $ head lines_]
|
[T.drop (sc - 1) $ T.take ec $ head lines_]
|
||||||
else -- several lines
|
else -- several lines
|
||||||
let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)
|
let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)
|
||||||
in (T.drop (sc - 1) first) : rest ++ [T.take ec last_]
|
in T.drop (sc - 1) first : rest ++ [T.take ec last_]
|
||||||
|
|
||||||
srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)
|
srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)
|
||||||
srcSpanDifference b v =
|
srcSpanDifference b v =
|
||||||
|
@ -19,7 +19,7 @@ checkSyntax :: IOish m
|
|||||||
=> [FilePath] -- ^ The target files.
|
=> [FilePath] -- ^ The target files.
|
||||||
-> GhcModT m String
|
-> GhcModT m String
|
||||||
checkSyntax [] = return ""
|
checkSyntax [] = return ""
|
||||||
checkSyntax files = withErrorHandler sessionName $ do
|
checkSyntax files = withErrorHandler sessionName $
|
||||||
either id id <$> check files
|
either id id <$> check files
|
||||||
where
|
where
|
||||||
sessionName = case files of
|
sessionName = case files of
|
||||||
@ -33,8 +33,7 @@ checkSyntax files = withErrorHandler sessionName $ do
|
|||||||
check :: IOish m
|
check :: IOish m
|
||||||
=> [FilePath] -- ^ The target files.
|
=> [FilePath] -- ^ The target files.
|
||||||
-> GhcModT m (Either String String)
|
-> GhcModT m (Either String String)
|
||||||
check fileNames = do
|
check fileNames = withLogger setAllWaringFlags $ setTargetFiles fileNames
|
||||||
withLogger setAllWaringFlags $ setTargetFiles fileNames
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
----------------------------------------------------------------
|
||||||
|
|
||||||
@ -43,7 +42,7 @@ expandTemplate :: IOish m
|
|||||||
=> [FilePath] -- ^ The target files.
|
=> [FilePath] -- ^ The target files.
|
||||||
-> GhcModT m String
|
-> GhcModT m String
|
||||||
expandTemplate [] = return ""
|
expandTemplate [] = return ""
|
||||||
expandTemplate files = withErrorHandler sessionName $ do
|
expandTemplate files = withErrorHandler sessionName $
|
||||||
either id id <$> expand files
|
either id id <$> expand files
|
||||||
where
|
where
|
||||||
sessionName = case files of
|
sessionName = case files of
|
||||||
|
@ -81,14 +81,14 @@ instance ToString ((Int,Int,Int,Int),String) where
|
|||||||
toPlain opt x = tupToString opt x
|
toPlain opt x = tupToString opt x
|
||||||
|
|
||||||
instance ToString (String, (Int,Int,Int,Int),[String]) where
|
instance ToString (String, (Int,Int,Int,Int),[String]) where
|
||||||
toLisp opt (s,x,y) = toSexp2 $ [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
toLisp opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
|
||||||
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
|
||||||
|
|
||||||
toSexp1 :: Options -> [String] -> Builder
|
toSexp1 :: Options -> [String] -> Builder
|
||||||
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
|
||||||
|
|
||||||
toSexp2 :: [Builder] -> Builder
|
toSexp2 :: [Builder] -> Builder
|
||||||
toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :)
|
toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
|
||||||
|
|
||||||
fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
|
fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
|
||||||
fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)
|
fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)
|
||||||
|
@ -22,8 +22,7 @@ import System.FilePath ((</>), takeDirectory)
|
|||||||
-- Find a sandbox according to a cabal sandbox config
|
-- Find a sandbox according to a cabal sandbox config
|
||||||
-- in a cabal directory.
|
-- in a cabal directory.
|
||||||
findCradle :: IO Cradle
|
findCradle :: IO Cradle
|
||||||
findCradle = do
|
findCradle = findCradle' =<< getCurrentDirectory
|
||||||
findCradle' =<< getCurrentDirectory
|
|
||||||
|
|
||||||
findCradle' :: FilePath -> IO Cradle
|
findCradle' :: FilePath -> IO Cradle
|
||||||
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
|
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
|
||||||
|
@ -16,7 +16,7 @@ debugInfo :: IOish m => GhcModT m String
|
|||||||
debugInfo = cradle >>= \c -> convert' =<< do
|
debugInfo = cradle >>= \c -> convert' =<< do
|
||||||
CompilerOptions gopts incDir pkgs <-
|
CompilerOptions gopts incDir pkgs <-
|
||||||
if isJust $ cradleCabalFile c then
|
if isJust $ cradleCabalFile c then
|
||||||
(fromCabalFile c ||> simpleCompilerOption)
|
fromCabalFile c ||> simpleCompilerOption
|
||||||
else
|
else
|
||||||
simpleCompilerOption
|
simpleCompilerOption
|
||||||
return [
|
return [
|
||||||
|
@ -101,8 +101,7 @@ needsFallback = any (hasTHorQQ . G.ms_hspp_opts)
|
|||||||
|
|
||||||
-- | Return the 'DynFlags' currently in use in the GHC session.
|
-- | Return the 'DynFlags' currently in use in the GHC session.
|
||||||
getDynamicFlags :: IO DynFlags
|
getDynamicFlags :: IO DynFlags
|
||||||
getDynamicFlags = do
|
getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags
|
||||||
G.runGhc (Just libdir) G.getSessionDynFlags
|
|
||||||
|
|
||||||
withDynFlags :: GhcMonad m
|
withDynFlags :: GhcMonad m
|
||||||
=> (DynFlags -> DynFlags)
|
=> (DynFlags -> DynFlags)
|
||||||
@ -136,7 +135,7 @@ setAllWaringFlags :: DynFlags -> DynFlags
|
|||||||
setAllWaringFlags df = df { warningFlags = allWarningFlags }
|
setAllWaringFlags df = df { warningFlags = allWarningFlags }
|
||||||
|
|
||||||
allWarningFlags :: Gap.WarnFlags
|
allWarningFlags :: Gap.WarnFlags
|
||||||
allWarningFlags = unsafePerformIO $ do
|
allWarningFlags = unsafePerformIO $
|
||||||
G.runGhc (Just libdir) $ do
|
G.runGhc (Just libdir) $ do
|
||||||
df <- G.getSessionDynFlags
|
df <- G.getSessionDynFlags
|
||||||
df' <- addCmdOpts ["-Wall"] df
|
df' <- addCmdOpts ["-Wall"] df
|
||||||
|
@ -5,7 +5,7 @@ module Language.Haskell.GhcMod.FillSig (
|
|||||||
) where
|
) where
|
||||||
|
|
||||||
import Data.Char (isSymbol)
|
import Data.Char (isSymbol)
|
||||||
import Data.List (find, intercalate)
|
import Data.List (find)
|
||||||
import Exception (ghandle, SomeException(..))
|
import Exception (ghandle, SomeException(..))
|
||||||
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
|
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
|
||||||
import qualified GHC as G
|
import qualified GHC as G
|
||||||
@ -45,7 +45,7 @@ sig file lineNo colNo = ghandle handler body
|
|||||||
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
|
whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
|
||||||
Signature loc names ty ->
|
Signature loc names ty ->
|
||||||
("function", fourInts loc, map (initialBody dflag style ty) names)
|
("function", fourInts loc, map (initialBody dflag style ty) names)
|
||||||
InstanceDecl loc cls -> do
|
InstanceDecl loc cls ->
|
||||||
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
|
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
|
||||||
(Ty.classMethods cls))
|
(Ty.classMethods cls))
|
||||||
|
|
||||||
@ -109,8 +109,8 @@ initialBody' fname args =
|
|||||||
case initialBodyArgs args infiniteVars infiniteFns of
|
case initialBodyArgs args infiniteVars infiniteFns of
|
||||||
[] -> fname
|
[] -> fname
|
||||||
arglist -> if isSymbolName fname
|
arglist -> if isSymbolName fname
|
||||||
then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist))
|
then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
|
||||||
else fname ++ " " ++ (intercalate " " arglist)
|
else fname ++ " " ++ unwords arglist
|
||||||
++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
|
++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
|
||||||
|
|
||||||
initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
|
initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
|
||||||
@ -133,11 +133,11 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
|
|||||||
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy
|
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy
|
||||||
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
|
getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy
|
||||||
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
|
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
|
||||||
where fnarg = \ty -> case ty of
|
where fnarg ty = case ty of
|
||||||
(G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
|
(G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
|
||||||
(G.HsParTy (L _ iTy)) -> fnarg iTy
|
(G.HsParTy (L _ iTy)) -> fnarg iTy
|
||||||
(G.HsFunTy _ _) -> True
|
(G.HsFunTy _ _) -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
getFnArgs _ = []
|
getFnArgs _ = []
|
||||||
|
|
||||||
instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
|
instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
|
||||||
@ -146,11 +146,11 @@ instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
|
|||||||
getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
|
getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
|
||||||
getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy
|
getFnArgs (HE.TyParen _ iTy) = getFnArgs iTy
|
||||||
getFnArgs (HE.TyFun _ lTy rTy) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
|
getFnArgs (HE.TyFun _ lTy rTy) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
|
||||||
where fnarg = \ty -> case ty of
|
where fnarg ty = case ty of
|
||||||
(HE.TyForall _ _ _ iTy) -> fnarg iTy
|
(HE.TyForall _ _ _ iTy) -> fnarg iTy
|
||||||
(HE.TyParen _ iTy) -> fnarg iTy
|
(HE.TyParen _ iTy) -> fnarg iTy
|
||||||
(HE.TyFun _ _ _) -> True
|
(HE.TyFun _ _ _) -> True
|
||||||
_ -> False
|
_ -> False
|
||||||
getFnArgs _ = []
|
getFnArgs _ = []
|
||||||
|
|
||||||
instance FnArgsInfo Type Id where
|
instance FnArgsInfo Type Id where
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE CPP, BangPatterns #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.Find (
|
module Language.Haskell.GhcMod.Find (
|
||||||
Symbol
|
Symbol
|
||||||
@ -118,7 +118,7 @@ dumpSymbol = do
|
|||||||
when create $ do
|
when create $ do
|
||||||
sm <- getSymbol
|
sm <- getSymbol
|
||||||
void . liftIO $ withFile cache WriteMode $ \hdl ->
|
void . liftIO $ withFile cache WriteMode $ \hdl ->
|
||||||
mapM (hPutStrLn hdl . show) sm
|
mapM (hPrint hdl) sm
|
||||||
return cache
|
return cache
|
||||||
return $ ret ++ "\n"
|
return $ ret ++ "\n"
|
||||||
|
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-}
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.GHCApi (
|
module Language.Haskell.GhcMod.GHCApi (
|
||||||
ghcPkgDb
|
ghcPkgDb
|
||||||
@ -42,8 +42,7 @@ modules :: G.PackageConfig -> [ModuleString]
|
|||||||
modules = map G.moduleNameString . G.exposedModules
|
modules = map G.moduleNameString . G.exposedModules
|
||||||
|
|
||||||
findModule :: ModuleString -> PkgDb -> [Package]
|
findModule :: ModuleString -> PkgDb -> [Package]
|
||||||
findModule m db = do
|
findModule m db = M.elems $ package `M.map` (containsModule `M.filter` db)
|
||||||
M.elems $ package `M.map` (containsModule `M.filter` db)
|
|
||||||
where
|
where
|
||||||
containsModule :: G.PackageConfig -> Bool
|
containsModule :: G.PackageConfig -> Bool
|
||||||
containsModule pkgConf =
|
containsModule pkgConf =
|
||||||
@ -83,5 +82,4 @@ localModuleInfo :: GhcMonad m => ModuleString -> m (Maybe G.ModuleInfo)
|
|||||||
localModuleInfo mdl = moduleInfo Nothing mdl
|
localModuleInfo mdl = moduleInfo Nothing mdl
|
||||||
|
|
||||||
bindings :: G.ModuleInfo -> [Binding]
|
bindings :: G.ModuleInfo -> [Binding]
|
||||||
bindings minfo = do
|
bindings minfo = map (G.occNameString . G.getOccName) $ G.modInfoExports minfo
|
||||||
map (G.occNameString . G.getOccName) $ G.modInfoExports minfo
|
|
||||||
|
@ -16,7 +16,7 @@ lint :: IOish m
|
|||||||
-> GhcModT m String
|
-> GhcModT m String
|
||||||
lint file = do
|
lint file = do
|
||||||
opt <- options
|
opt <- options
|
||||||
ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)
|
ghandle handler . pack =<< liftIO (hlint $ file : "--quiet" : hlintOpts opt)
|
||||||
where
|
where
|
||||||
pack = convert' . map (init . show) -- init drops the last \n.
|
pack = convert' . map (init . show) -- init drops the last \n.
|
||||||
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
|
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
|
||||||
|
@ -16,7 +16,7 @@ import UniqFM (eltsUFM)
|
|||||||
modules :: IOish m => GhcModT m String
|
modules :: IOish m => GhcModT m String
|
||||||
modules = do
|
modules = do
|
||||||
opt <- options
|
opt <- options
|
||||||
convert opt . (arrange opt) <$> (getModules `G.gcatch` handler)
|
convert opt . arrange opt <$> (getModules `G.gcatch` handler)
|
||||||
where
|
where
|
||||||
getModules = getExposedModules <$> G.getSessionDynFlags
|
getModules = getExposedModules <$> G.getSessionDynFlags
|
||||||
getExposedModules = concatMap exposedModules'
|
getExposedModules = concatMap exposedModules'
|
||||||
|
@ -1,4 +1,4 @@
|
|||||||
{-# LANGUAGE BangPatterns, CPP #-}
|
{-# LANGUAGE CPP #-}
|
||||||
|
|
||||||
module Language.Haskell.GhcMod.Logger (
|
module Language.Haskell.GhcMod.Logger (
|
||||||
withLogger
|
withLogger
|
||||||
@ -63,9 +63,9 @@ withLogger :: IOish m
|
|||||||
-> GhcModT m ()
|
-> GhcModT m ()
|
||||||
-> GhcModT m (Either String String)
|
-> GhcModT m (Either String String)
|
||||||
withLogger setDF body = ghandle sourceError $ do
|
withLogger setDF body = ghandle sourceError $ do
|
||||||
logref <- liftIO $ newLogRef
|
logref <- liftIO newLogRef
|
||||||
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
|
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
|
||||||
withDynFlags (setLogger logref . setDF) $ do
|
withDynFlags (setLogger logref . setDF) $
|
||||||
withCmdFlags wflags $ do
|
withCmdFlags wflags $ do
|
||||||
body
|
body
|
||||||
Right <$> readAndClearLogRef logref
|
Right <$> readAndClearLogRef logref
|
||||||
@ -80,7 +80,7 @@ sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
|
|||||||
sourceError err = do
|
sourceError err = do
|
||||||
dflags <- G.getSessionDynFlags
|
dflags <- G.getSessionDynFlags
|
||||||
style <- toGhcMod getStyle
|
style <- toGhcMod getStyle
|
||||||
ret <- convert' $ (errBagToStrList dflags style . srcErrorMessages $ err)
|
ret <- convert' (errBagToStrList dflags style . srcErrorMessages $ err)
|
||||||
return $ Left ret
|
return $ Left ret
|
||||||
|
|
||||||
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]
|
||||||
|
@ -188,8 +188,8 @@ initSession :: GhcMonad m
|
|||||||
-> m ()
|
-> m ()
|
||||||
initSession build Options {..} CompilerOptions {..} = do
|
initSession build Options {..} CompilerOptions {..} = do
|
||||||
df <- G.getSessionDynFlags
|
df <- G.getSessionDynFlags
|
||||||
void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
|
void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions
|
||||||
$ setModeSimple
|
( setModeSimple
|
||||||
$ setIncludeDirs includeDirs
|
$ setIncludeDirs includeDirs
|
||||||
$ setBuildEnv build
|
$ setBuildEnv build
|
||||||
$ setEmptyLogger
|
$ setEmptyLogger
|
||||||
|
@ -18,7 +18,7 @@ extractParens str = extractParens' str 0
|
|||||||
extractParens' (s:ss) level
|
extractParens' (s:ss) level
|
||||||
| s `elem` "([{" = s : extractParens' ss (level+1)
|
| s `elem` "([{" = s : extractParens' ss (level+1)
|
||||||
| level == 0 = extractParens' ss 0
|
| level == 0 = extractParens' ss 0
|
||||||
| s `elem` "}])" && level == 1 = s:[]
|
| s `elem` "}])" && level == 1 = [s]
|
||||||
| s `elem` "}])" = s : extractParens' ss (level-1)
|
| s `elem` "}])" = s : extractParens' ss (level-1)
|
||||||
| otherwise = s : extractParens' ss level
|
| otherwise = s : extractParens' ss level
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user