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

Fix merge conflict, dropdown-list no longer needed

This commit is contained in:
Alejandro Serrano 2014-08-14 18:02:58 +02:00
parent 8eeeacd58d
commit 890658f9cb
26 changed files with 219 additions and 110 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
Language/Haskell/GhcMod.hs
View File

@ -18,6 +18,7 @@ module Language.Haskell.GhcMod (
-- * Monad Types
, GhcModT
, IOish
, GhcModError(..)
-- * Monad utilities
, runGhcModT
, withOptions

24
Language/Haskell/GhcMod/CabalApi.hs
View File

@ -11,14 +11,16 @@ module Language.Haskell.GhcMod.CabalApi (
) where
import Language.Haskell.GhcMod.CabalConfig
import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, toModuleString)
import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets,
toModuleString)
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Types
import MonadUtils (MonadIO, liftIO)
import Control.Applicative ((<$>))
import qualified Control.Exception as E
import Control.Monad (filterM)
import CoreMonad (liftIO)
import Control.Monad.Error.Class (Error, MonadError(..))
import Data.Maybe (maybeToList)
import Data.Set (fromList, toList)
import Distribution.Package (Dependency(Dependency)
@ -69,19 +71,21 @@ includeDirectories cdir wdir dirs = uniqueAndSort (extdirs ++ [cdir,wdir])
----------------------------------------------------------------
-- | Parsing a cabal file and returns 'PackageDescription'.
-- 'IOException' is thrown if parsing fails.
parseCabalFile :: FilePath -> IO PackageDescription
-- | Parse a cabal file and return a 'PackageDescription'.
parseCabalFile :: (MonadIO m, Error e, MonadError e m)
=> FilePath
-> m PackageDescription
parseCabalFile file = do
cid <- getGHCId
epgd <- readPackageDescription silent file
cid <- liftIO getGHCId
epgd <- liftIO $ readPackageDescription silent file
case toPkgDesc cid epgd of
Left deps -> E.throwIO $ userError $ show deps ++ " are not installed"
Left deps -> fail $ show deps ++ " are not installed"
Right (pd,_) -> if nullPkg pd
then E.throwIO $ userError $ file ++ " is broken"
then fail $ file ++ " is broken"
else return pd
where
toPkgDesc cid = finalizePackageDescription [] (const True) buildPlatform cid []
toPkgDesc cid =
finalizePackageDescription [] (const True) buildPlatform cid []
nullPkg pd = name == ""
where
PackageName name = C.pkgName (P.package pd)

1
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -4,7 +4,6 @@ module Language.Haskell.GhcMod.CaseSplit (
splits
) where
import CoreMonad (liftIO)
import Data.List (find, intercalate)
import Data.Maybe (isJust)
import qualified Data.Text as T

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

@ -8,8 +8,10 @@ module Language.Haskell.GhcMod.Check (
import Control.Applicative ((<$>))
import Language.Haskell.GhcMod.DynFlags
import qualified Language.Haskell.GhcMod.Gap as Gap
import qualified GHC as G
import Language.Haskell.GhcMod.Logger
import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler)
import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler
, overrideGhcUserOptions)
import Language.Haskell.GhcMod.Target (setTargetFiles)
----------------------------------------------------------------
@ -34,8 +36,9 @@ checkSyntax files = withErrorHandler sessionName $
check :: IOish m
=> [FilePath] -- ^ The target files.
-> GhcModT m (Either String String)
check fileNames =
withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
check fileNames = overrideGhcUserOptions $ \ghcOpts ->
withLogger (setAllWaringFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
_ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
setTargetFiles fileNames
----------------------------------------------------------------

7
Language/Haskell/GhcMod/Debug.hs
View File

@ -1,7 +1,6 @@
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
import Control.Applicative ((<$>))
import CoreMonad (liftIO)
import Data.List (intercalate)
import Data.Maybe (isJust, fromJust)
import Language.Haskell.GhcMod.Convert
@ -30,10 +29,10 @@ debugInfo = cradle >>= \c -> convert' =<< do
]
where
simpleCompilerOption = options >>= \op ->
return $ CompilerOptions (ghcOpts op) [] []
fromCabalFile c = options >>= \opts -> liftIO $ do
return $ CompilerOptions (ghcUserOptions op) [] []
fromCabalFile c = options >>= \opts -> do
pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
getCompilerOptions (ghcOpts opts) c pkgDesc
liftIO $ getCompilerOptions (ghcUserOptions opts) c pkgDesc
----------------------------------------------------------------

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

@ -88,8 +88,8 @@ withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a
withCmdFlags flags body = G.gbracket setup teardown (\_ -> body)
where
setup = do
dflags <- G.getSessionDynFlags >>= addCmdOpts flags
void $ G.setSessionDynFlags dflags
dflags <- G.getSessionDynFlags
void $ G.setSessionDynFlags =<< addCmdOpts flags dflags
return dflags
teardown = void . G.setSessionDynFlags

29
Language/Haskell/GhcMod/FillSig.hs
View File

@ -20,7 +20,6 @@ import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import CoreMonad (liftIO)
import Outputable (PprStyle)
import qualified Type as Ty
import qualified HsBinds as Ty
@ -119,13 +118,13 @@ getSignature modSum lineNo colNo = do
G.DataFamily -> Data
#endif
#if __GLASGOW_HASKELL__ >= 706
getTyFamVarName = \x -> case x of
L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar n _) -> n
getTyFamVarName x = case x of
L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar n _) -> n
#else
getTyFamVarName = \x -> case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg
L _ (G.UserTyVar n _) -> n
L _ (G.KindedTyVar n _ _) -> n
getTyFamVarName x = case x of -- In GHC 7.4, HsTyVarBndr's have an extra arg
L _ (G.UserTyVar n _) -> n
L _ (G.KindedTyVar n _ _) -> n
#endif
in return $ Just (TyFamDecl loc name flavour $ map getTyFamVarName vars)
_ -> return Nothing
@ -143,7 +142,7 @@ getSignatureFromHE file lineNo colNo = do
return $ case presult of
HE.ParseOk (HE.Module _ _ _ _ mdecls) -> do
decl <- find (typeSigInRangeHE lineNo colNo) mdecls
case decl of
case decl of
HE.TypeSig (HE.SrcSpanInfo s _) names ty -> return $ HESignature s names ty
HE.TypeFamDecl (HE.SrcSpanInfo s _) (HE.DHead _ name tys) _ ->
return $ HEFamSignature s Open name (map cleanTyVarBind tys)
@ -170,7 +169,7 @@ initialBody' fname args = initialHead fname args ++ " = "
initialFamBody :: FnArgsInfo ty name => DynFlags -> PprStyle -> name -> [name] -> String
initialFamBody dflag style name args = initialHead (getFnName dflag style name)
(map (\arg -> FnExplicitName (getFnName dflag style arg)) args)
(map (FnExplicitName . getFnName dflag style) args)
++ " = ()"
initialHead :: String -> [FnArg] -> String
@ -282,7 +281,7 @@ refine file lineNo colNo expr = ghandle handler body
iArgs = take diffArgs eArgs
text = initialHead1 expr iArgs (infinitePrefixSupply name)
in (fourInts loc, doParen paren text)
handler (SomeException _) = emptyResult =<< options
-- Look for the variable in the specified position
@ -299,7 +298,7 @@ findVar dflag style tcm tcs lineNo colNo =
then let Just (s,t) = tyInfo
b = case others of -- If inside an App, we need parenthesis
[] -> False
(L _ (G.HsApp (L _ a1) (L _ a2))):_ ->
L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
isSearchedVar i a1 || isSearchedVar i a2
_ -> False
in return $ Just (s, name, t, b)
@ -340,9 +339,9 @@ auto file lineNo colNo = ghandle handler body
topLevel <- getEverythingInTopLevel minfo
let (f,pats) = getPatsForVariable tcs (lineNo,colNo)
-- Remove self function to prevent recursion, and id to trim cases
filterFn = (\(n,_) -> let funName = G.getOccString n
recName = G.getOccString (G.getName f)
in not $ funName `elem` recName:notWantedFuns)
filterFn (n,_) = let funName = G.getOccString n
recName = G.getOccString (G.getName f)
in funName `notElem` recName:notWantedFuns
-- Find without using other functions in top-level
localBnds = M.unions $ map (\(L _ pat) -> getBindingsForPat pat) pats
lbn = filter filterFn (M.toList localBnds)
@ -352,7 +351,7 @@ auto file lineNo colNo = ghandle handler body
env = filter filterFn almostEnv
djinns <- djinn True (Just minfo) env rty (Max 10) 100000
return (fourInts loc, map (doParen paren) $ nub (djinnsEmpty ++ djinns))
handler (SomeException _) = emptyResult =<< options
-- Functions we do not want in completions

16
Language/Haskell/GhcMod/Find.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE CPP, BangPatterns #-}
{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
@ -19,7 +19,6 @@ import Control.Applicative ((<$>))
import Control.Exception (handle, SomeException(..))
import Control.Monad (when, void)
import Control.Monad.Error.Class
import CoreMonad (liftIO)
import Data.Function (on)
import Data.List (groupBy, sort)
import Data.List.Split (splitOn)
@ -59,8 +58,14 @@ newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
----------------------------------------------------------------
-- | When introducing incompatible changes to the 'symbolCache' file format
-- increment this version number.
symbolCacheVersion :: Integer
symbolCacheVersion = 0
-- | Filename of the symbol table cache file.
symbolCache :: String
symbolCache = "ghc-mod.cache"
symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
packageCache :: String
packageCache = "package.cache"
@ -89,6 +94,8 @@ lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
loadSymbolDb :: IO SymbolDb
loadSymbolDb = SymbolDb <$> readSymbolDb
-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
-- this is a guess but >=7.6 uses 'getExecutablePath'.
ghcModExecutable :: IO FilePath
#ifndef SPEC
ghcModExecutable = do
@ -130,7 +137,6 @@ getSymbolCachePath = do
-- if the file does not exist or is invalid.
-- The file name is printed.
-- TODO: Before releaseing add a version number to the name of the cache file
dumpSymbol :: IOish m => GhcModT m String
dumpSymbol = do
dir <- getSymbolCachePath
@ -144,7 +150,7 @@ dumpSymbol = do
writeSymbolCache :: FilePath
-> [(Symbol,[ModuleString])]
-> IO ()
writeSymbolCache cache sm = do
writeSymbolCache cache sm =
void . withFile cache WriteMode $ \hdl ->
mapM (hPrint hdl) sm

7
Language/Haskell/GhcMod/GHCChoice.hs
View File

@ -21,10 +21,3 @@ goNext = liftIO . GE.throwIO $ userError "goNext"
-- | Run any one 'Ghc' monad.
runAnyOne :: GhcMonad m => [m a] -> m a
runAnyOne = foldr (||>) goNext
----------------------------------------------------------------
-- | Try the left 'GhcMonad' action. If 'IOException' occurs, try
-- the right 'GhcMonad' action.
(|||>) :: GhcMonad m => m a -> m a -> m a
x |||> y = x `GE.gcatch` (\(_ :: IOException) -> y)

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

@ -44,12 +44,10 @@ module Language.Haskell.GhcMod.Internal (
, getCompilerMode
, setCompilerMode
, withOptions
-- * 'Ghc' Choice
-- * 'GhcMonad' Choice
, (||>)
, goNext
, runAnyOne
-- * 'GhcMonad' Choice
, (|||>)
) where
import GHC.Paths (libdir)

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

@ -2,7 +2,6 @@ module Language.Haskell.GhcMod.Lint where
import Exception (ghandle)
import Control.Exception (SomeException(..))
import CoreMonad (liftIO)
import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad

13
Language/Haskell/GhcMod/Logger.hs
View File

@ -7,7 +7,6 @@ module Language.Haskell.GhcMod.Logger (
import Bag (Bag, bagToList)
import Control.Applicative ((<$>))
import CoreMonad (liftIO)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe)
@ -64,7 +63,7 @@ withLogger :: IOish m
-> GhcModT m (Either String String)
withLogger setDF body = ghandle sourceError $ do
logref <- liftIO newLogRef
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcUserOptions <$> options
withDynFlags (setLogger logref . setDF) $
withCmdFlags wflags $ do
body
@ -106,7 +105,15 @@ ppMsg spn sev dflag style msg = prefix ++ cts
(line,col,_,_) <- Gap.getSrcSpan spn
file <- normalise <$> Gap.getSrcFile spn
let severityCaption = Gap.showSeverityCaption sev
return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
pref0
| typeWarning1 `isPrefixOf` cts ||
typeWarning2 `isPrefixOf` cts = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
| otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
return pref0
-- DeferTypeErrors turns a type error to a warning.
-- So, let's turns it the error again.
typeWarning1 = "Couldn't match expected type"
typeWarning2 = "Couldn't match type"
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"

89
Language/Haskell/GhcMod/Monad.hs
View File

@ -1,7 +1,6 @@
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-}
{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.Monad (
@ -23,15 +22,18 @@ module Language.Haskell.GhcMod.Monad (
-- ** Conversion
, toGhcModT
-- ** Accessing 'GhcModEnv' and 'GhcModState'
, gmsGet
, gmsPut
, options
, cradle
, getCompilerMode
, setCompilerMode
, withOptions
-- ** Exporting convenient modules
, withTempSession
, overrideGhcUserOptions
-- ** Re-exporting convenient stuff
, liftIO
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
, module Control.Monad.Journal.Class
) where
@ -57,7 +59,7 @@ import Exception
import GHC
import qualified GHC as G
import GHC.Paths (libdir)
import GhcMonad
import GhcMonad hiding (withTempSession)
#if __GLASGOW_HASKELL__ <= 702
import HscTypes
#endif
@ -85,15 +87,16 @@ import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith,
import Control.Monad.Trans.Class
import Control.Monad.Reader.Class
import Control.Monad.Writer.Class
import Control.Monad.State.Class
import Control.Monad.Writer.Class (MonadWriter)
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Error (Error(..), MonadError, ErrorT, runErrorT)
import Control.Monad.Error (MonadError, ErrorT, runErrorT)
import Control.Monad.Reader (ReaderT, runReaderT)
import Control.Monad.State.Strict (StateT, runStateT)
import Control.Monad.Trans.Journal (JournalT, runJournalT)
#ifdef MONADIO_INSTANCES
import Control.Monad.Trans.Maybe (MaybeT)
import Control.Monad.Error (Error(..))
#endif
import Control.Monad.Journal.Class
@ -122,16 +125,6 @@ data CompilerMode = Simple | Intelligent deriving (Eq,Show,Read)
defaultState :: GhcModState
defaultState = GhcModState Simple
data GhcModError = GMENoMsg
| GMEString String
| GMECabal
| GMEGhc
deriving (Eq,Show,Read)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
----------------------------------------------------------------
-- | A constraint alias (-XConstraintKinds) to make functions dealing with
@ -163,15 +156,21 @@ newtype GhcModT m a = GhcModT {
#if DIFFERENT_MONADIO
, Control.Monad.IO.Class.MonadIO
#endif
, MonadReader GhcModEnv
, MonadReader GhcModEnv -- TODO: make MonadReader instance
-- pass-through like MonadState
, MonadWriter w
, MonadState GhcModState
, MonadError GhcModError
)
instance MonadTrans GhcModT where
lift = GhcModT . lift . lift . lift . lift
instance MonadState s m => MonadState s (GhcModT m) where
get = GhcModT $ lift $ lift $ lift get
put = GhcModT . lift . lift . lift . put
state = GhcModT . lift . lift . lift . state
#if MONADIO_INSTANCES
instance MonadIO m => MonadIO (StateT s m) where
liftIO = lift . liftIO
@ -194,7 +193,7 @@ instance MonadIO m => MonadIO (MaybeT m) where
-- | Initialize the 'DynFlags' relating to the compilation of a single
-- file or GHC session according to the 'Cradle' and 'Options'
-- provided.
initializeFlagsWithCradle :: GhcMonad m
initializeFlagsWithCradle :: (GhcMonad m, MonadError GhcModError m)
=> Options
-> Cradle
-> m ()
@ -204,9 +203,9 @@ initializeFlagsWithCradle opt c
where
mCradleFile = cradleCabalFile c
cabal = isJust mCradleFile
ghcopts = ghcOpts opt
ghcopts = ghcUserOptions opt
withCabal = do
pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile
pkgDesc <- parseCabalFile $ fromJust mCradleFile
compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc
initSession CabalPkg opt compOpts
withSandbox = initSession SingleFile opt compOpts
@ -253,7 +252,7 @@ runGhcModT :: IOish m
-> m (Either GhcModError a, GhcModLog)
runGhcModT opt action = do
env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory
first (fmap fst) <$> (runGhcModT' env defaultState $ do
first (fst <$>) <$> (runGhcModT' env defaultState $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
initializeFlagsWithCradle opt (gmCradle env)
@ -271,9 +270,9 @@ runGhcModT' :: IOish m
-> m (Either GhcModError (a, GhcModState), GhcModLog)
runGhcModT' r s a = do
(res, w') <-
flip runReaderT r $ runJournalT $ runErrorT $ flip runStateT s
$ (unGhcModT $ initGhcMonad (Just libdir) >> a)
return $ (res, w')
flip runReaderT r $ runJournalT $ runErrorT $
runStateT (unGhcModT $ initGhcMonad (Just libdir) >> a) s
return (res, w')
----------------------------------------------------------------
withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a
@ -285,6 +284,28 @@ withErrorHandler label = ghandle ignore
hPrint stderr e
exitSuccess
-- | Make a copy of the 'gmGhcSession' IORef, run the action and restore the
-- original 'HscEnv'.
withTempSession :: IOish m => GhcModT m a -> GhcModT m a
withTempSession action = do
session <- gmGhcSession <$> ask
savedHscEnv <- liftIO $ readIORef session
a <- action
liftIO $ writeIORef session savedHscEnv
return a
-- | This is a very ugly workaround don't use it.
overrideGhcUserOptions :: IOish m => ([GHCOption] -> GhcModT m b) -> GhcModT m b
overrideGhcUserOptions action = withTempSession $ do
env <- ask
opt <- options
let ghcOpts = ghcUserOptions opt
opt' = opt { ghcUserOptions = [] }
initializeFlagsWithCradle opt' (gmCradle env)
action ghcOpts
-- | This is only a transitional mechanism don't use it for new code.
toGhcModT :: IOish m => Ghc a -> GhcModT m a
toGhcModT a = do
@ -293,17 +314,23 @@ toGhcModT a = do
----------------------------------------------------------------
gmsGet :: IOish m => GhcModT m GhcModState
gmsGet = GhcModT get
gmsPut :: IOish m => GhcModState -> GhcModT m ()
gmsPut = GhcModT . put
options :: IOish m => GhcModT m Options
options = gmOptions <$> ask
cradle :: IOish m => GhcModT m Cradle
cradle = gmCradle <$> ask
getCompilerMode :: (Functor m, MonadState GhcModState m) => m CompilerMode
getCompilerMode = gmCompilerMode <$> get
getCompilerMode :: IOish m => GhcModT m CompilerMode
getCompilerMode = gmCompilerMode <$> gmsGet
setCompilerMode :: MonadState GhcModState m => CompilerMode -> m ()
setCompilerMode mode = (\s -> put s { gmCompilerMode = mode } ) =<< get
setCompilerMode :: IOish m => CompilerMode -> GhcModT m ()
setCompilerMode mode = (\s -> gmsPut s { gmCompilerMode = mode } ) =<< gmsGet
----------------------------------------------------------------

1
Language/Haskell/GhcMod/PkgDoc.hs
View File

@ -1,6 +1,5 @@
module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where
import CoreMonad (liftIO)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad

2
Language/Haskell/GhcMod/Target.hs
View File

@ -15,7 +15,7 @@ setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
setTargetFiles files = do
targets <- forM files $ \file -> G.guessTarget file Nothing
G.setTargets targets
mode <- gmCompilerMode <$> get
mode <- getCompilerMode
if mode == Intelligent then
loadTargets Intelligent
else do

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

@ -2,9 +2,22 @@ module Language.Haskell.GhcMod.Types where
import Data.List (intercalate)
import qualified Data.Map as M
import Control.Monad.Error (Error(..))
import PackageConfig (PackageConfig)
-- |
data GhcModError = GMENoMsg
-- ^ Unknown error
| GMEString String
-- ^ Some Error with a message. These are produced mostly by
-- 'fail' calls on GhcModT.
deriving (Eq,Show,Read)
instance Error GhcModError where
noMsg = GMENoMsg
strMsg = GMEString
-- | Output style.
data OutputStyle = LispStyle -- ^ S expression style.
| PlainStyle -- ^ Plain textstyle.
@ -15,7 +28,8 @@ newtype LineSeparator = LineSeparator String
data Options = Options {
outputStyle :: OutputStyle
, hlintOpts :: [String]
, ghcOpts :: [GHCOption]
-- | GHC command line options set on the @ghc-mod@ command line
, ghcUserOptions:: [GHCOption]
-- | If 'True', 'browse' also returns operators.
, operators :: Bool
-- | If 'True', 'browse' also returns types.
@ -31,7 +45,7 @@ defaultOptions :: Options
defaultOptions = Options {
outputStyle = PlainStyle
, hlintOpts = []
, ghcOpts = []
, ghcUserOptions= []
, operators = False
, detailed = False
, qualified = False

2
elisp/ghc-check.el
View File

@ -247,7 +247,7 @@ nil does not display errors/warnings.
(line (string-to-number (match-string 2 text)))
(coln (string-to-number (match-string 3 text)))
(buf (find-file file)))
(with-current-buffer buf
(with-current-buffer buf
(let* ((this-line (line-number-at-pos))
(diff (- line this-line)))
(beginning-of-line)

4
elisp/ghc-func.el
View File

@ -159,7 +159,7 @@
;; (turn-off-haskell-font-lock)
;; (haskell-font-lock-defaults-create)
;; (turn-on-haskell-font-lock)))
;; (display-buffer buf
;; (display-buffer buf
;; '((display-buffer-reuse-window
;; display-buffer-pop-up-window))))))
@ -174,7 +174,7 @@
(turn-off-haskell-font-lock)
(haskell-font-lock-defaults-create)
(turn-on-haskell-font-lock)))
(display-buffer buf
(display-buffer buf
'((display-buffer-reuse-window
display-buffer-pop-up-window))))))

1
ghc-mod.cabal
View File

@ -133,6 +133,7 @@ Executable ghc-modi
Default-Language: Haskell2010
Main-Is: GHCModi.hs
Other-Modules: Paths_ghc_mod
Utils
GHC-Options: -Wall -threaded
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src

8
src/GHCMod.hs
View File

@ -63,8 +63,11 @@ argspec = [ Option "l" ["tolisp"]
(ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")
"hlint options"
, Option "g" ["ghcOpt"]
(ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")
(ReqArg (\g opts -> opts { ghcUserOptions = g : ghcUserOptions opts }) "ghcOpt")
"GHC options"
, Option "v" ["verbose"]
(NoArg (\opts -> opts { ghcUserOptions = "-v" : ghcUserOptions opts }))
"verbose"
, Option "o" ["operators"]
(NoArg (\opts -> opts { operators = True }))
"print operators, too"
@ -138,7 +141,8 @@ main = flip E.catches handlers $ do
cmd -> E.throw (NoSuchCommand cmd)
case res of
Right s -> putStr s
Left e -> error $ show e
Left (GMENoMsg) -> hPutStrLn stderr "Unknown error"
Left (GMEString msg) -> hPutStrLn stderr msg
where
handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
handleThenExit handler e = handler e >> exitFailure

16
src/GHCModi.hs
View File

@ -39,6 +39,8 @@ import System.Directory (setCurrentDirectory)
import System.Environment (getArgs)
import System.IO (hFlush,stdout)
import Utils
----------------------------------------------------------------
type Logger = IO String
@ -56,7 +58,7 @@ argspec = [ Option "b" ["boundary"]
(NoArg (\opts -> opts { outputStyle = LispStyle }))
"print as a list of Lisp"
, Option "g" []
(ReqArg (\s opts -> opts { ghcOpts = s : ghcOpts opts }) "flag") "specify a ghc flag"
(ReqArg (\s opts -> opts { ghcUserOptions = s : ghcUserOptions opts }) "flag") "specify a ghc flag"
]
usage :: String
@ -231,7 +233,7 @@ showInfo :: IOish m
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
showInfo set fileArg = do
let [file, expr] = words fileArg
let [file, expr] = splitN 2 fileArg
set' <- newFileSet set file
ret <- info file expr
return (ret, True, set')
@ -241,7 +243,7 @@ showType :: IOish m
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
showType set fileArg = do
let [file, line, column] = words fileArg
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- types file (read line) (read column)
return (ret, True, set')
@ -251,7 +253,7 @@ doSplit :: IOish m
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doSplit set fileArg = do
let [file, line, column] = words fileArg
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- splits file (read line) (read column)
return (ret, True, set')
@ -261,7 +263,7 @@ doSig :: IOish m
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doSig set fileArg = do
let [file, line, column] = words fileArg
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- sig file (read line) (read column)
return (ret, True, set')
@ -271,7 +273,7 @@ doRefine :: IOish m
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doRefine set fileArg = do
let [file, line, column, expr] = words fileArg
let [file, line, column, expr] = splitN 4 fileArg
set' <- newFileSet set file
ret <- refine file (read line) (read column) expr
return (ret, True, set')
@ -281,7 +283,7 @@ doAuto :: IOish m
-> FilePath
-> GhcModT m (String, Bool, Set FilePath)
doAuto set fileArg = do
let [file, line, column] = words fileArg
let [file, line, column] = splitN 3 fileArg
set' <- newFileSet set file
ret <- auto file (read line) (read column)
return (ret, True, set')

27
src/Utils.hs Normal file
View File

@ -0,0 +1,27 @@
module Utils where
-- |
--
-- >>> split "foo bar baz"
-- ["foo","bar baz"]
-- >>> split "foo bar baz"
-- ["foo","bar baz"]
split :: String -> [String]
split xs = [ys, dropWhile isSpace zs]
where
isSpace = (== ' ')
(ys,zs) = break isSpace xs
-- |
--
-- >>> splitN 0 "foo bar baz"
-- ["foo","bar baz"]
-- >>> splitN 2 "foo bar baz"
-- ["foo","bar baz"]
-- >>> splitN 3 "foo bar baz"
-- ["foo","bar","baz"]
splitN :: Int -> String -> [String]
splitN n xs
| n <= 2 = split xs
| otherwise = let [ys,zs] = split xs
in ys : splitN (n - 1) zs

15
test/CabalApiSpec.hs
View File

@ -13,6 +13,7 @@ import System.Directory
import System.FilePath
import Dir
import TestUtils
import Config (cProjectVersionInt) -- ghc version
@ -23,14 +24,16 @@ spec :: Spec
spec = do
describe "parseCabalFile" $ do
it "throws an exception if the cabal file is broken" $ do
parseCabalFile "test/data/broken-cabal/broken.cabal" `shouldThrow` (\(_::IOException) -> True)
shouldReturnError $
runD' $ parseCabalFile "test/data/broken-cabal/broken.cabal"
describe "getCompilerOptions" $ do
it "gets necessary CompilerOptions" $ do
cwd <- getCurrentDirectory
withDirectory "test/data/subdir1/subdir2" $ \dir -> do
cradle <- findCradle
pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile cradle
pkgDesc <- runD $ parseCabalFile $ fromJust $ cradleCabalFile cradle
res <- getCompilerOptions [] cradle pkgDesc
let res' = res {
ghcOptions = ghcOptions res
@ -45,18 +48,18 @@ spec = do
describe "cabalDependPackages" $ do
it "extracts dependent packages" $ do
pkgs <- cabalDependPackages . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
pkgs <- cabalDependPackages . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
pkgs `shouldBe` ["Cabal","base","template-haskell"]
describe "cabalSourceDirs" $ do
it "extracts all hs-source-dirs" $ do
dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal"
dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/check-test-subdir/check-test-subdir.cabal")
dirs `shouldBe` ["src", "test"]
it "extracts all hs-source-dirs including \".\"" $ do
dirs <- cabalSourceDirs . cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
dirs <- cabalSourceDirs . cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
dirs `shouldBe` [".", "test"]
describe "cabalAllBuildInfo" $ do
it "extracts build info" $ do
info <- cabalAllBuildInfo <$> parseCabalFile "test/data/cabalapi.cabal"
info <- cabalAllBuildInfo <$> runD (parseCabalFile "test/data/cabalapi.cabal")
show info `shouldBe` "[BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\".\"], otherModules = [ModuleName [\"Browse\"],ModuleName [\"CabalApi\"],ModuleName [\"Cabal\"],ModuleName [\"CabalDev\"],ModuleName [\"Check\"],ModuleName [\"ErrMsg\"],ModuleName [\"Flag\"],ModuleName [\"GHCApi\"],ModuleName [\"GHCChoice\"],ModuleName [\"Gap\"],ModuleName [\"Info\"],ModuleName [\"Lang\"],ModuleName [\"Lint\"],ModuleName [\"List\"],ModuleName [\"Paths_ghc_mod\"],ModuleName [\"Types\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [(GHC,[\"-Wall\"])], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []}))),Dependency (PackageName \"template-haskell\") AnyVersion]},BuildInfo {buildable = True, buildTools = [], cppOptions = [], ccOptions = [], ldOptions = [], pkgconfigDepends = [], frameworks = [], cSources = [], hsSourceDirs = [\"test\",\".\"], otherModules = [ModuleName [\"Expectation\"],ModuleName [\"BrowseSpec\"],ModuleName [\"CabalApiSpec\"],ModuleName [\"FlagSpec\"],ModuleName [\"LangSpec\"],ModuleName [\"LintSpec\"],ModuleName [\"ListSpec\"]], defaultLanguage = Nothing, otherLanguages = [], defaultExtensions = [], otherExtensions = [], oldExtensions = [], extraLibs = [], extraLibDirs = [], includeDirs = [], includes = [], installIncludes = [], options = [], ghcProfOptions = [], ghcSharedOptions = [], customFieldsBI = [], targetBuildDepends = [Dependency (PackageName \"Cabal\") (UnionVersionRanges (ThisVersion (Version {versionBranch = [1,10], versionTags = []})) (LaterVersion (Version {versionBranch = [1,10], versionTags = []}))),Dependency (PackageName \"base\") (IntersectVersionRanges (UnionVersionRanges (ThisVersion (Version {versionBranch = [4,0], versionTags = []})) (LaterVersion (Version {versionBranch = [4,0], versionTags = []}))) (EarlierVersion (Version {versionBranch = [5], versionTags = []})))]}]"

4
test/Main.hs
View File

@ -11,7 +11,9 @@ import TestUtils
main = do
let sandboxes = [ "test/data", "test/data/check-packageid"
, "test/data/duplicate-pkgver/" ]
, "test/data/duplicate-pkgver/"
, "test/data/broken-cabal/"
]
genSandboxCfg dir = withDirectory dir $ \cwd -> do
system ("sed 's|@CWD@|" ++ cwd ++ "|g' cabal.sandbox.config.in > cabal.sandbox.config")
pkgDirs =

9
test/MonadSpec.hs
View File

@ -3,6 +3,7 @@ module MonadSpec where
import Test.Hspec
import Dir
import TestUtils
import Control.Applicative
import Control.Monad.Error.Class
import Language.Haskell.GhcMod.Types
@ -23,5 +24,9 @@ spec = do
describe "runGhcModT" $
it "complains if the cabal file fails to parse while a sandbox is present" $ withDirectory_ "test/data/broken-cabal" $ do
(a,_) <- runGhcModT defaultOptions (gmCradle <$> ask)
a `shouldSatisfy` (\(Left _) -> True)
shouldReturnError $ runD' (gmCradle <$> ask)
describe "gmsGet/Put" $
it "work" $ do
(runD $ gmsPut (GhcModState Intelligent) >> gmsGet)
`shouldReturn` (GhcModState Intelligent)

17
test/TestUtils.hs
View File

@ -1,10 +1,12 @@
module TestUtils (
run
, runD
, runD'
, runI
, runID
, runIsolatedGhcMod
, isolateCradle
, shouldReturnError
, module Language.Haskell.GhcMod.Monad
, module Language.Haskell.GhcMod.Types
) where
@ -12,6 +14,8 @@ module TestUtils (
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
import Test.Hspec
isolateCradle :: IOish m => GhcModT m a -> GhcModT m a
isolateCradle action =
local modifyEnv $ action
@ -42,3 +46,16 @@ run opt a = extract $ runGhcModT opt a
-- | Run GhcMod with default options
runD :: GhcModT IO a -> IO a
runD = extract . runGhcModT defaultOptions
runD' :: GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runD' = runGhcModT defaultOptions
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
-> Expectation
shouldReturnError action = do
(a,_) <- action
a `shouldSatisfy` isLeft
where
isLeft (Left _) = True
isLeft _ = False