Fix merge conflict, dropdown-list no longer needed
This commit is contained in:
Alejandro Serrano
parent
8eeeacd58d
commit
890658f9cb
@ -18,6 +18,7 @@ module Language.Haskell.GhcMod (
|
||||
-- * Monad Types
|
||||
, GhcModT
|
||||
, IOish
|
||||
, GhcModError(..)
|
||||
-- * Monad utilities
|
||||
, runGhcModT
|
||||
, withOptions
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
@ -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
|
||||
|
||||
----------------------------------------------------------------
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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
|
||||
@ -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
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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:"
|
||||
|
||||
@ -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,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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
27
src/Utils.hs
Normal 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
|
||||
@ -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 = []})))]}]"
|
||||
|
||||
@ -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 =
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user