diff --git a/ChangeLog b/ChangeLog
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2016-07-29 v5.6.0.0
+ * Bump cabal-helper to 0.7, adds support for Cabal-1.24
+ * Merge #737, `map-file` caching issues
+ * Merge #767, Add `browse` option to show symbol "parents"
+ * Merge #731, Type constraints
+ * Fix #69 (via #731), Missing type constraints
+ * Fix #438, Case splitting not working
+ * Fix #790, Don't try to use 'cabal' or 'stack' when it's not installed
+ * Add support for GHC 8.0
+
2016-01-19 v5.5.0.0
* Fix #660, cabal-helper errors when no global GHC is installed (Stack)
* Fix #665, Reinstate internally managed CWD (no more `ghc-mod root`
@@ -29,9 +39,9 @@
super slowness)
* Expose all internal modules because API will get a major
redesign soon anyways
- * ghc-mod(i) executable must now be run in project directory for
- commands other than `root`
- * Add --line-prefix option for multiplexing stdout/err onto one stream
+ * ghc-mod(i) executable must now be run in project directory for
+ commands other than `root`
+ * Add --line-prefix option for multiplexing stdout/err onto one stream
2015-08-14 v5.3.0.0
* Re-license majority of code under the AGPL-3
@@ -39,72 +49,72 @@
* Remove `cabalDependPackages', `cabalAllTargets'
* Merge #434, Fix finding sandbox config file and directory.
* Merge #431, Re-add output line separator global option for expand
- command.
+ command.
* Merge #470, Support for overriding the package-db stack
* Merge #486, Fix ineffective cache invalidation for `find`
2014-12-31 v5.2.1.2
* Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers
are operators
- * Fix incompatibility with monad-control >= 1.0.0
- * Fix temporary directories not being removed properly
- * Merge #405, #408, a race condition in the Emacs frontend
- * Merge #403, Support unicode quotes in module regexp
+ * Fix incompatibility with monad-control >= 1.0.0
+ * Fix temporary directories not being removed properly
+ * Merge #405, #408, a race condition in the Emacs frontend
+ * Merge #403, Support unicode quotes in module regexp
2014-11-03 v5.2.1.1
- * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.
- * Support `where` clauses, `let` bindings and `case` expressions
- in case splitting, #400
+ * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.
+ * Support `where` clauses, `let` bindings and `case` expressions
+ in case splitting, #400
2014-11-02 v5.2.1.0
- * Fix `newTempDir` on Windows
- * GhcModT's liftIO instance now converts GhcMOdError exceptions
- into monadic failures
+ * Fix `newTempDir` on Windows
+ * GhcModT's liftIO instance now converts GhcMOdError exceptions
+ into monadic failures
2014-10-30 v5.2.0.0
- * Return type of `loadSymbolDb` is now in GhcModT
- * Function `dumpSymbol` now takes the path of the target directory
- * Fix #387, Pattern match failure in GhcPkg
- * Fix #386, `ghc-mod version` should not check `cabal configure`
- * Fix #391, Error on command `-g` when used before command despite
- --help output saying this is valid
- * Fix formatting of `ghc-version` constant in the elisp code. in
- version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".
+ * Return type of `loadSymbolDb` is now in GhcModT
+ * Function `dumpSymbol` now takes the path of the target directory
+ * Fix #387, Pattern match failure in GhcPkg
+ * Fix #386, `ghc-mod version` should not check `cabal configure`
+ * Fix #391, Error on command `-g` when used before command despite
+ --help output saying this is valid
+ * Fix formatting of `ghc-version` constant in the elisp code. in
+ version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".
2014-10-04 v5.1.1.0
- * Handle various consistency related issues: #222, #224, #326, #332
- * Add `isOutdated` to Language.Haskell.GhcMod
+ * Handle various consistency related issues: #222, #224, #326, #332
+ * Add `isOutdated` to Language.Haskell.GhcMod
2014-09-17 v5.1.0.2
- * Fix building with haskell-src-exts < 1.16.0
+ * Fix building with haskell-src-exts < 1.16.0
2014-09-16 v5.1.0.1
- * Fix building with haskell-src-exts-1.16.0
- * Loosen monad-journal dependency
+ * Fix building with haskell-src-exts-1.16.0
+ * Loosen monad-journal dependency
2014-09-12 v5.1.0.0
- * GhcModError is now a recursive data type (`GMECabalConfigure`'s
- type changed)
- * GhcModT's MonadIO instance now converts IOError's to failures in
- the ErrorT part of GhcModT on `liftIO`.
- * Make `loadSymbolDb` polimorphic in the return types's monad.
- * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal
- * Fix `check` command for modules using `-XPatternSynonyms`
- * Merge #364, Support cabal configuration flags
+ * GhcModError is now a recursive data type (`GMECabalConfigure`'s
+ type changed)
+ * GhcModT's MonadIO instance now converts IOError's to failures in
+ the ErrorT part of GhcModT on `liftIO`.
+ * Make `loadSymbolDb` polimorphic in the return types's monad.
+ * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal
+ * Fix `check` command for modules using `-XPatternSynonyms`
+ * Merge #364, Support cabal configuration flags
2014-08-29 v5.0.1.2
- * Merge #345, Try fixing duplicate errors
- * Merge #344, elisp: Use advice to check syntax on save-buffer
- * Merge #341, support `browse -d` in ghc-modi
- * Merge #352, elisp: Fix C-u accidentally getting turned into a
- prefix command
+ * Merge #345, Try fixing duplicate errors
+ * Merge #344, elisp: Use advice to check syntax on save-buffer
+ * Merge #341, support `browse -d` in ghc-modi
+ * Merge #352, elisp: Fix C-u accidentally getting turned into a
+ prefix command
2014-08-24 v5.0.1.1
- * Fix CaseSplitting faliure when using "fancy types" (see #336)
- * Print error information in "spec" test suite when using `extract`
+ * Fix CaseSplitting faliure when using "fancy types" (see #336)
+ * Print error information in "spec" test suite when using `extract`
2014-08-20 v5.0.1
- * Fix missing file in "Data-Files"
+ * Fix missing file in "Data-Files"
2014-08-20 v5.0.0
* ghc-mod consumes much less memory than ghc-mod-4.1.
diff --git a/Data/Binary/Generic.hs b/Data/Binary/Generic.hs
--- a/Data/Binary/Generic.hs
+++ b/Data/Binary/Generic.hs
@@ -66,7 +66,6 @@
#define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)
instance ( GSum a, GSum b
- , GGBinary a, GGBinary b
, SumSize a, SumSize b) => GGBinary (a :+: b) where
ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)
| otherwise = sizeError "encode" size
@@ -96,7 +95,7 @@
getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)
putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put
-instance (GSum a, GSum b, GGBinary a, GGBinary b) => GSum (a :+: b) where
+instance (GSum a, GSum b) => GSum (a :+: b) where
getSum !code !size | code < sizeL = L1 <$> getSum code sizeL
| otherwise = R1 <$> getSum (code - sizeL) sizeR
where
diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs
--- a/Language/Haskell/GhcMod/Boot.hs
+++ b/Language/Haskell/GhcMod/Boot.hs
@@ -7,12 +7,13 @@
import Language.Haskell.GhcMod.Lang
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Modules
+import Language.Haskell.GhcMod.Types (defaultBrowseOpts)
-- | Printing necessary information for front-end booting.
boot :: IOish m => GhcModT m String
boot = concat <$> sequence ms
where
- ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]
+ ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules]
preBrowsedModules :: [String]
preBrowsedModules = [
diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs
--- a/Language/Haskell/GhcMod/Browse.hs
+++ b/Language/Haskell/GhcMod/Browse.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.Browse (
browse,
BrowseOpts(..)
@@ -11,6 +12,7 @@
import Data.Maybe
import FastString
import GHC
+import HscTypes
import qualified GHC as G
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
@@ -24,6 +26,9 @@
import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy)
import Exception (ExceptionMonad, ghandle)
import Prelude
+#if __GLASGOW_HASKELL__ >= 800
+import PatSyn (pprPatSynType)
+#endif
----------------------------------------------------------------
@@ -96,14 +101,20 @@
mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt
mtype :: m (Maybe String)
mtype
- | optBrowseDetailed opt = do
+ | optBrowseDetailed opt || optBrowseParents opt = do
tyInfo <- G.modInfoLookupName minfo e
-- If nothing found, load dependent module and lookup global
tyResult <- maybe (inOtherModule e) (return . Just) tyInfo
dflag <- G.getSessionDynFlags
- return $ do
- typeName <- tyResult >>= showThing dflag
- (" :: " ++ typeName) `justIf` optBrowseDetailed opt
+ let sig = do
+ typeName <- tyResult >>= showThing dflag
+ (" :: " ++ typeName) `justIf` optBrowseDetailed opt
+ let parent = do
+ thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe
+ (" -- from:" ++ thing) `justIf` optBrowseParents opt
+ return $ case concat $ catMaybes [sig, parent] of
+ [] -> Nothing
+ x -> Just x
| otherwise = return Nothing
formatOp nm
| null nm = error "formatOp"
@@ -124,6 +135,9 @@
showThing' _ (GtT t) = unwords . toList <$> tyType t
where
toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)
+#if __GLASGOW_HASKELL__ >= 800
+showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p
+#endif
showThing' _ _ = Nothing
formatType :: DynFlags -> Type -> String
diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs
--- a/Language/Haskell/GhcMod/CaseSplit.hs
+++ b/Language/Haskell/GhcMod/CaseSplit.hs
@@ -27,7 +27,9 @@
import Language.Haskell.GhcMod.Doc
import Language.Haskell.GhcMod.Logging
import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils (withMappedFile)
import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)
+import Control.DeepSeq
----------------------------------------------------------------
-- CASE SPLITTING
@@ -54,17 +56,17 @@
style <- getStyle
dflag <- G.getSessionDynFlags
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file)
- whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
- (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
- let varName' = showName dflag style varName -- Convert name to string
- t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
- getTyCons dflag style varName varT)
- return (fourInts bndLoc, t)
- (TySplitInfo varName bndLoc (varLoc,varT)) -> do
- let varName' = showName dflag style varName -- Convert name to string
- t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+ whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do
+ let (varName, bndLoc, (varLoc,varT))
+ | (SplitInfo vn bl vlvt _matches) <- x
+ = (vn, bl, vlvt)
+ | (TySplitInfo vn bl vlvt) <- x
+ = (vn, bl, vlvt)
+ varName' = showName dflag style varName -- Convert name to string
+ t <- withMappedFile file $ \file' ->
+ genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $
getTyCons dflag style varName varT)
- return (fourInts bndLoc, t)
+ return $!! (fourInts bndLoc, t)
where
handler (SomeException ex) = do
gmLog GmException "splits" $
@@ -107,7 +109,11 @@
isPatternVar _ = False
getPatternVarName :: LPat Id -> G.Name
+#if __GLASGOW_HASKELL__ >= 800
+getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName
+#else
getPatternVarName (L _ (G.VarPat vName)) = G.getName vName
+#endif
getPatternVarName _ = error "This should never happened"
-- TODO: Information for a type family case split
@@ -167,7 +173,11 @@
-- 3. Records
getDataCon dflag style vName dcon =
let dName = showName dflag style $ Ty.dataConName dcon
+#if __GLASGOW_HASKELL__ >= 800
+ flds = map Ty.flSelector $ Ty.dataConFieldLabels dcon
+#else
flds = Ty.dataConFieldLabels dcon
+#endif
in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"
-- Create a new variable by adjoining a number
@@ -204,8 +214,8 @@
return $ getCaseSplitText (T.lines t) info
getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
-getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
- , sVarSpan = sVS, sTycons = sT }) =
+getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
+ , sVarSpan = sVS, sTycons = sT } =
let bindingText = getBindingText t sBS
difference = srcSpanDifference sBS sVS
replaced = map (replaceVarWithTyCon bindingText difference sVN) sT
diff --git a/Language/Haskell/GhcMod/Check.hs b/Language/Haskell/GhcMod/Check.hs
--- a/Language/Haskell/GhcMod/Check.hs
+++ b/Language/Haskell/GhcMod/Check.hs
@@ -33,7 +33,7 @@
runGmlTWith
(map Left files)
return
- ((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
+ ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
(return ())
----------------------------------------------------------------
diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs
--- a/Language/Haskell/GhcMod/Cradle.hs
+++ b/Language/Haskell/GhcMod/Cradle.hs
@@ -25,6 +25,7 @@
import Data.Maybe
import System.Directory
import System.FilePath
+import System.Environment
import Prelude
import Control.Monad.Trans.Journal (runJournalT)
@@ -34,24 +35,29 @@
-- Find a cabal file by tracing ancestor directories.
-- Find a sandbox according to a cabal sandbox config
-- in a cabal directory.
-findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle
-findCradle = findCradle' =<< liftIO getCurrentDirectory
+findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
-findCradleNoLog :: forall m. (IOish m, GmOut m) => m Cradle
-findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
+findCradleNoLog :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
+findCradleNoLog progs =
+ fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
-findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
-findCradle' dir = run $
- msum [ stackCradle dir
- , cabalCradle dir
+findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
+findCradle' Programs { stackProgram, cabalProgram } dir = run $
+ msum [ stackCradle stackProgram dir
+ , cabalCradle cabalProgram dir
, sandboxCradle dir
, plainCradle dir
]
where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a)
-findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
-findSpecCradle dir = do
- let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
+findSpecCradle ::
+ (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
+findSpecCradle Programs { stackProgram, cabalProgram } dir = do
+ let cfs = [ stackCradleSpec stackProgram
+ , cabalCradle cabalProgram
+ , sandboxCradle
+ ]
cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs
gcs <- filterM isNotGmCradle cs
fillTempDir =<< case gcs of
@@ -69,12 +75,20 @@
tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
return crdl { cradleTempDir = tmpDir }
-cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
-cabalCradle wdir = do
+cabalCradle ::
+ (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
+cabalCradle cabalProg wdir = do
cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
-
let cabalDir = takeDirectory cabalFile
+ gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir
+
+ -- If cabal doesn't exist the user probably wants to use something else
+ whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
+ gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type"
+ mzero
+
+ gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir
return Cradle {
cradleProject = CabalProject
, cradleCurrentDir = wdir
@@ -84,26 +98,45 @@
, cradleDistDir = "dist"
}
-stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
-stackCradle wdir = do
+stackCradle ::
+ (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
+stackCradle stackProg wdir = do
#if !MIN_VERSION_ghc(7,8,0)
-- GHC < 7.8 is not supported by stack
mzero
#endif
- cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
+ cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
let cabalDir = takeDirectory cabalFile
-
_stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir
- -- If dist/setup-config already exists the user probably wants to use cabal
- -- rather than stack, or maybe that's just me ;)
- whenM (liftIO $ doesFileExist $ cabalDir setupConfigPath "dist") $ do
- gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."
- mzero
+ gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir
+ stackExeSet <- liftIO $ isJust <$> lookupEnv "STACK_EXE"
+ stackExeExists <- liftIO $ isJust <$> findExecutable stackProg
+ setupCfgExists <- liftIO $ doesFileExist $ cabalDir setupConfigPath "dist"
+
+ case (stackExeExists, stackExeSet) of
+ (False, True) -> do
+ gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type"
+ mzero
+
+ (False, False) -> do
+ gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type"
+ mzero
+
+ (True, True) -> do
+ gmLog GmWarning "" $ text "STACK_EXE set, preferring Stack project"
+
+ (True, False) | setupCfgExists -> do
+ gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project"
+ mzero
+
+ (True, False) -> return ()
+
senv <- MaybeT $ getStackEnv cabalDir
+ gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir
return Cradle {
cradleProject = StackProject senv
, cradleCurrentDir = wdir
@@ -113,9 +146,10 @@
, cradleDistDir = seDistDir senv
}
-stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
-stackCradleSpec wdir = do
- crdl <- stackCradle wdir
+stackCradleSpec ::
+ (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
+stackCradleSpec stackProg wdir = do
+ crdl <- stackCradle stackProg wdir
case crdl of
Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
b <- isGmDistDir seDistDir
@@ -126,9 +160,10 @@
isGmDistDir dir =
liftIO $ not <$> doesFileExist (dir ".." "ghc-mod.cabal")
-sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle
+sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
sandboxCradle wdir = do
sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir
+ gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir
return Cradle {
cradleProject = SandboxProject
, cradleCurrentDir = wdir
@@ -138,8 +173,9 @@
, cradleDistDir = "dist"
}
-plainCradle :: IOish m => FilePath -> MaybeT m Cradle
+plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle
plainCradle wdir = do
+ gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"
return $ Cradle {
cradleProject = PlainProject
, cradleCurrentDir = wdir
diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs
--- a/Language/Haskell/GhcMod/Debug.hs
+++ b/Language/Haskell/GhcMod/Debug.hs
@@ -3,11 +3,12 @@
import Control.Arrow (first)
import Control.Applicative
import Control.Monad
-import Control.Monad.Trans.Journal
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Char
+import Data.Version
import Data.List.Split
+import System.Directory
import Text.PrettyPrint
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types
@@ -17,7 +18,12 @@
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.Cradle
import Language.Haskell.GhcMod.Stack
+import Language.Haskell.GhcMod.Output
+import Paths_ghc_mod (version)
+
+import Config (cProjectVersion)
+
----------------------------------------------------------------
-- | Obtaining debug information.
@@ -34,14 +40,20 @@
pkgOpts <- packageGhcOptions
+ readProc <- gmReadProcess
+
+ ghcVersion <- liftIO $
+ dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] ""
+
return $ unlines $
- [ "Root directory: " ++ cradleRootDir
+ [ "Version: ghc-mod-" ++ showVersion version
+ , "Library GHC Version: " ++ cProjectVersion
+ , "System GHC Version: " ++ ghcVersion
+ , "Root directory: " ++ cradleRootDir
, "Current directory: " ++ cradleCurrentDir
, "GHC Package flags:\n" ++ render (nest 4 $
fsep $ map text pkgOpts)
, "GHC System libraries: " ++ ghcLibDir
- , "GHC user options:\n" ++ render (nest 4 $
- fsep $ map text optGhcUserOptions)
] ++ cabal
stackPaths :: IOish m => GhcModT m [String]
@@ -63,9 +75,24 @@
opts = Map.map gmcGhcOpts mcs
srcOpts = Map.map gmcGhcSrcOpts mcs
+ readProc <- gmReadProcess
+ cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"
+
+ cabalInstVersion <-
+ if cabalExists
+ then liftIO $
+ dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""
+ else return ""
+
+ packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] ""
+ let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages
+
return $
- [ "Cabal file: " ++ show cradleCabalFile
- , "Project: " ++ show cradleProject
+ [ "cabal-install Version: " ++ cabalInstVersion
+ , "Cabal Library Versions:\n" ++ render (nest 4 $
+ fsep $ map text cabalPackages)
+ , "Cabal file: " ++ show cradleCabalFile
+ , "Project: " ++ show cradleProject
, "Cabal entrypoints:\n" ++ render (nest 4 $
mapDoc gmComponentNameDoc smpDoc entrypoints)
, "Cabal components:\n" ++ render (nest 4 $
@@ -139,5 +166,7 @@
----------------------------------------------------------------
-- | Obtaining root information.
-rootInfo :: forall m. (IOish m, GmOut m) => m String
-rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
+rootInfo = do
+ crdl <- findCradleNoLog =<< (optPrograms <$> options)
+ return $ cradleRootDir crdl ++ "\n"
diff --git a/Language/Haskell/GhcMod/DebugLogger.hs b/Language/Haskell/GhcMod/DebugLogger.hs
--- a/Language/Haskell/GhcMod/DebugLogger.hs
+++ b/Language/Haskell/GhcMod/DebugLogger.hs
@@ -13,7 +13,7 @@
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program. If not, see .
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, RankNTypes #-}
module Language.Haskell.GhcMod.DebugLogger where
-- (c) The University of Glasgow 2005
@@ -62,27 +62,27 @@
import Prelude
debugLogAction :: (String -> IO ()) -> GmLogAction
-debugLogAction putErr dflags severity srcSpan style msg
+debugLogAction putErr _reason dflags severity srcSpan style' msg
= case severity of
- SevOutput -> printSDoc putErr msg style
+ SevOutput -> printSDoc putErr msg style'
#if __GLASGOW_HASKELL__ >= 706
- SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style
+ SevDump -> printSDoc putErr (msg Outputable.$$ blankLine) style'
#endif
#if __GLASGOW_HASKELL__ >= 708
SevInteractive -> let
putStrSDoc = debugLogActionHPutStrDoc dflags putErr
in
- putStrSDoc msg style
+ putStrSDoc msg style'
#endif
- SevInfo -> printErrs putErr msg style
- SevFatal -> printErrs putErr msg style
+ SevInfo -> printErrs putErr msg style'
+ SevFatal -> printErrs putErr msg style'
_ -> do putErr "\n"
#if __GLASGOW_HASKELL__ >= 706
- printErrs putErr (mkLocMessage severity srcSpan msg) style
+ printErrs putErr (mkLocMessage severity srcSpan msg) style'
#else
- printErrs putErr (mkLocMessage srcSpan msg) style
+ printErrs putErr (mkLocMessage srcSpan msg) style'
#endif
-- careful (#2302): printErrs prints in UTF-8,
-- whereas converting to string first and using
diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs
--- a/Language/Haskell/GhcMod/Doc.hs
+++ b/Language/Haskell/GhcMod/Doc.hs
@@ -11,11 +11,6 @@
showOneLine :: DynFlags -> PprStyle -> SDoc -> String
showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
--- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
--- showForUser dflags unqual sdoc =
--- showDocWith dflags PageMode $
--- runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay
-
getStyle :: GhcMonad m => m PprStyle
getStyle = do
unqual <- getPrintUnqual
diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs
--- a/Language/Haskell/GhcMod/DynFlags.hs
+++ b/Language/Haskell/GhcMod/DynFlags.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
module Language.Haskell.GhcMod.DynFlags where
@@ -10,12 +10,13 @@
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.DebugLogger
+import Language.Haskell.GhcMod.DynFlagsTH
import System.IO.Unsafe (unsafePerformIO)
import Prelude
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df =
- Gap.setLogAction df $ \_ _ _ _ _ -> return ()
+ Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags
setDebugLogger put df = do
@@ -94,15 +95,14 @@
----------------------------------------------------------------
--- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
-setNoMaxRelevantBindings :: DynFlags -> DynFlags
-#if __GLASGOW_HASKELL__ >= 708
-setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
-#else
-setNoMaxRelevantBindings = id
-#endif
-
-deferErrors :: DynFlags -> Ghc DynFlags
+deferErrors :: Monad m => DynFlags -> m DynFlags
deferErrors df = return $
Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
Gap.setDeferTypeErrors $ setNoWarningFlags df
+
+----------------------------------------------------------------
+
+deriveEqDynFlags [d|
+ eqDynFlags :: DynFlags -> DynFlags -> Bool
+ eqDynFlags = undefined
+ |]
diff --git a/Language/Haskell/GhcMod/DynFlagsTH.hs b/Language/Haskell/GhcMod/DynFlagsTH.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/GhcMod/DynFlagsTH.hs
@@ -0,0 +1,126 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015 Daniel Gröber
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program. If not, see .
+
+{-# LANGUAGE CPP, TemplateHaskell #-}
+module Language.Haskell.GhcMod.DynFlagsTH where
+
+import Language.Haskell.TH.Syntax
+import Control.Applicative
+import Data.Maybe
+import Data.Generics.Aliases
+import Data.Generics.Schemes
+import DynFlags
+import Prelude
+
+deriveEqDynFlags :: Q [Dec] -> Q [Dec]
+deriveEqDynFlags qds = do
+#if __GLASGOW_HASKELL__ <= 710
+ ~(TyConI (DataD [] _ [] [ctor] _ ))
+#else
+ ~(TyConI (DataD [] _ [] _ [ctor] _ ))
+#endif
+ <- reify ''DynFlags
+ let ~(RecC _ fs) = ctor
+
+ a <- newName "a"
+ b <- newName "b"
+
+ e <- AppE (VarE 'and) . ListE <$> sequence (catMaybes $ map (eq a b) fs)
+
+ tysig@(SigD n _) :_ <- qds
+
+ return $ [tysig, FunD n [Clause [VarP a, VarP b] (NormalB e) []]]
+
+ where
+ eq :: Name -> Name -> (Name, Strict, Type) -> Maybe (Q Exp)
+ eq a b (fn@(Name (OccName fon) _), _, ft)
+ | not (isUneqable || isIgnored) = Just expr
+ | otherwise = Nothing
+ where
+ isUneqable = everything (||) (mkQ False hasUnEqable) ft
+
+ hasUnEqable ArrowT = True
+ hasUnEqable (ConT (Name (OccName on) _))
+ | any (==on) ignoredTypeNames = True
+ | any (==on) ignoredTypeOccNames = True
+ hasUnEqable _ = False
+
+ isIgnored = fon `elem` ignoredNames
+
+ ignoredNames = [ "pkgDatabase" -- 7.8
+#if __GLASGOW_HASKELL__ <= 706
+ , "ways" -- 'Ways' is not exported :/
+#endif
+ ]
+ ignoredTypeNames =
+ [ "LogAction"
+ , "PackageState"
+ , "Hooks"
+ , "FlushOut"
+ , "FlushErr"
+ , "Settings" -- I think these can't cange at runtime
+ ]
+ ignoredTypeOccNames = [ "OnOff" ]
+
+ fa = AppE (VarE fn) (VarE a)
+ fb = AppE (VarE fn) (VarE b)
+ expr =
+ case fon of
+ "rtsOptsEnabled" -> do
+ eqfn <- [| let eqfn RtsOptsNone RtsOptsNone = True
+ eqfn RtsOptsSafeOnly RtsOptsSafeOnly = True
+ eqfn RtsOptsAll RtsOptsAll = True
+ eqfn _ _ = False
+ in eqfn
+ |]
+ return $ AppE (AppE eqfn fa) fb
+
+#if __GLASGOW_HASKELL__ >= 710 && __GLASGOW_HASKELL__ < 800
+ "sigOf" -> do
+ eqfn <- [| let eqfn NotSigOf NotSigOf = True
+ eqfn (SigOf a') (SigOf b') = a' == b'
+ eqfn (SigOfMap a') (SigOfMap b') = a' == b'
+ eqfn _ _ = False
+ in eqfn
+ |]
+ return $ AppE (AppE eqfn fa) fb
+#endif
+
+#if __GLASGOW_HASKELL <= 706
+ "profAuto" -> do
+ eqfn <- [| let eqfn NoProfAuto NoProfAuto = True
+ eqfn ProfAutoAll ProfAutoAll = True
+ eqfn ProfAutoTop ProfAutoTop = True
+ eqfn ProfAutoExports ProfAutoExports = True
+ eqfn ProfAutoCalls ProfAutoCalls = True
+ eqfn _ _ = False
+ in eqfn
+ |]
+ return $ AppE (AppE eqfn fa) fb
+#endif
+
+#if __GLASGOW_HASKELL__ >= 706
+ "language" -> do
+ eqfn <- [| let eqfn (Just Haskell98) (Just Haskell98) = True
+ eqfn (Just Haskell2010) (Just Haskell2010) = True
+ eqfn _ _ = False
+ in eqfn
+ |]
+ return $ AppE (AppE eqfn fa) fb
+#endif
+
+ _ ->
+ return $ InfixE (Just fa) (VarE '(==)) (Just fb)
diff --git a/Language/Haskell/GhcMod/FileMapping.hs b/Language/Haskell/GhcMod/FileMapping.hs
--- a/Language/Haskell/GhcMod/FileMapping.hs
+++ b/Language/Haskell/GhcMod/FileMapping.hs
@@ -46,8 +46,10 @@
-> GhcModT m ()
loadMappedFileSource from src = do
tmpdir <- cradleTempDir `fmap` cradle
+ enc <- liftIO . mkTextEncoding . optEncoding =<< options
to <- liftIO $ do
(fn, h) <- openTempFile tmpdir (takeFileName from)
+ hSetEncoding h enc
hPutStr h src
hClose h
return fn
@@ -61,23 +63,22 @@
let to' = makeRelative (cradleRootDir crdl) to
addMMappedFile cfn (FileMapping to' isTemp)
-mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
- HscEnv -> Target -> m Target
+mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target
mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do
mapping <- lookupMMappedFile filePath
- mkMappedTarget (Just filePath) tid taoc mapping
+ return $ mkMappedTarget (Just filePath) tid taoc mapping
mapFile env (Target tid@(TargetModule moduleName) taoc _) = do
(fp, mapping) <- do
filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)
mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile
return (filePath, mmf)
- mkMappedTarget fp tid taoc mapping
+ return $ mkMappedTarget fp tid taoc mapping
-mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) =>
- Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target
+mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target
mkMappedTarget _ _ taoc (Just to) =
- return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
-mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing
+ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
+mkMappedTarget _ tid taoc _ =
+ mkTarget tid taoc Nothing
{-|
unloads previously mapped file \'file\', so that it's no longer mapped,
diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs
--- a/Language/Haskell/GhcMod/FillSig.hs
+++ b/Language/Haskell/GhcMod/FillSig.hs
@@ -116,7 +116,9 @@
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Inspect the parse tree to find the signature
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
-#if __GLASGOW_HASKELL__ >= 710
+#if __GLASGOW_HASKELL__ >= 800
+ [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->
+#elif __GLASGOW_HASKELL__ >= 710
[L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] ->
#else
[L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->
@@ -131,7 +133,9 @@
case Gap.getClass lst of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
_ -> return Nothing
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 800
+ [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do
+#elif __GLASGOW_HASKELL__ >= 708
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do
#elif __GLASGOW_HASKELL__ >= 706
[L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do
@@ -149,8 +153,12 @@
G.DataFamily -> Data
#endif
-#if __GLASGOW_HASKELL__ >= 710
+#if __GLASGOW_HASKELL__ >= 800
getTyFamVarName x = case x of
+ L _ (G.UserTyVar (G.L _ n)) -> n
+ L _ (G.KindedTyVar (G.L _ n) _) -> n
+#elif __GLASGOW_HASKELL__ >= 710
+ getTyFamVarName x = case x of
L _ (G.UserTyVar n) -> n
L _ (G.KindedTyVar (G.L _ n) _) -> n
#elif __GLASGOW_HASKELL__ >= 706
@@ -269,7 +277,9 @@
instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
getFnName dflag style name = showOccName dflag style $ Gap.occName name
-#if __GLASGOW_HASKELL__ >= 710
+#if __GLASGOW_HASKELL__ >= 800
+ getFnArgs (G.HsForAllTy _ (L _ iTy))
+#elif __GLASGOW_HASKELL__ >= 710
getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy))
#else
getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))
@@ -280,7 +290,9 @@
getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =
(if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
where fnarg ty = case ty of
-#if __GLASGOW_HASKELL__ >= 710
+#if __GLASGOW_HASKELL__ >= 800
+ (G.HsForAllTy _ (L _ iTy)) ->
+#elif __GLASGOW_HASKELL__ >= 710
(G.HsForAllTy _ _ _ _ (L _ iTy)) ->
#else
(G.HsForAllTy _ _ _ (L _ iTy)) ->
@@ -381,7 +393,11 @@
-> m (Maybe (SrcSpan, String, Type, Bool))
findVar dflag style tcm tcs lineNo colNo =
case lst of
+#if __GLASGOW_HASKELL__ >= 800
+ e@(L _ (G.HsVar (L _ i))):others -> do
+#else
e@(L _ (G.HsVar i)):others -> do
+#endif
tyInfo <- Gap.getType tcm e
case tyInfo of
Just (s, typ)
@@ -409,7 +425,11 @@
doParen True s = if ' ' `elem` s then '(':s ++ ")" else s
isSearchedVar :: Id -> G.HsExpr Id -> Bool
+#if __GLASGOW_HASKELL__ >= 800
+isSearchedVar i (G.HsVar (L _ i2)) = i == i2
+#else
isSearchedVar i (G.HsVar i2) = i == i2
+#endif
isSearchedVar _ _ = False
@@ -512,7 +532,11 @@
_ -> (error "This should never happen", [])
getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type
+#if __GLASGOW_HASKELL__ >= 800
+getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)
+#else
getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)
+#endif
getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l
getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b
getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =
@@ -537,11 +561,23 @@
getBindingsForPat _ = M.empty
getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type
+#if __GLASGOW_HASKELL__ >= 800
+getBindingsForRecPat (G.PrefixCon args) =
+#else
getBindingsForRecPat (Ty.PrefixCon args) =
+#endif
M.unions $ map (\(L _ i) -> getBindingsForPat i) args
+#if __GLASGOW_HASKELL__ >= 800
+getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) =
+#else
getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =
+#endif
M.union (getBindingsForPat a1) (getBindingsForPat a2)
+#if __GLASGOW_HASKELL__ >= 800
+getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
+#else
getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =
+#endif
getBindingsForRecFields (map unLoc' fields)
where
#if __GLASGOW_HASKELL__ >= 710
diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs
--- a/Language/Haskell/GhcMod/Find.hs
+++ b/Language/Haskell/GhcMod/Find.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DeriveGeneric #-}
+{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}
module Language.Haskell.GhcMod.Find
#ifndef SPEC
@@ -18,6 +18,13 @@
#endif
where
+import qualified GHC as G
+import FastString
+import Module
+import OccName
+import HscTypes
+import Exception
+
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Gap
import Language.Haskell.GhcMod.Monad
@@ -25,38 +32,56 @@
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Utils
import Language.Haskell.GhcMod.World
-
-import qualified GHC as G
-import Name
-import Module
-import Exception
+import Language.Haskell.GhcMod.LightGhc
import Control.Applicative
+import Control.DeepSeq
import Control.Monad
import Control.Monad.Trans.Control
import Control.Concurrent
-import Control.DeepSeq
-import Data.Function
+
import Data.List
-import qualified Data.ByteString.Lazy as BS
import Data.Binary
+import Data.Function
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy as LBS
+import Data.IORef
+
+import System.Directory.ModTime
+import System.IO.Unsafe
+
import GHC.Generics (Generic)
+
import Data.Map (Map)
import qualified Data.Map as M
-import System.Directory.ModTime
+import Data.Set (Set)
+import qualified Data.Set as S
+import Language.Haskell.GhcMod.PathsAndFiles
+import System.Directory
import Prelude
----------------------------------------------------------------
-- | Type of function and operation names.
-type Symbol = String
+type Symbol = BS.ByteString
+type ModuleNameBS = BS.ByteString
+
-- | Database from 'Symbol' to \['ModuleString'\].
data SymbolDb = SymbolDb
- { sdTable :: Map Symbol [ModuleString]
+ { sdTable :: Map Symbol (Set ModuleNameBS)
, sdTimestamp :: ModTime
} deriving (Generic)
+#if __GLASGOW_HASKELL__ >= 708
instance Binary SymbolDb
+#else
+instance Binary SymbolDb where
+ put (SymbolDb a b) = put a >> put b
+ get = do
+ a <- get
+ b <- get
+ return (SymbolDb a b)
+#endif
instance NFData SymbolDb
isOutdated :: IOish m => SymbolDb -> GhcModT m Bool
@@ -67,19 +92,34 @@
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated. 'loadSymbolDb' is called internally.
-findSymbol :: IOish m => Symbol -> GhcModT m String
-findSymbol sym = loadSymbolDb >>= lookupSymbol sym
+findSymbol :: IOish m => String -> GhcModT m String
+findSymbol sym = loadSymbolDb' >>= lookupSymbol sym
-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-- which will be concatenated.
-lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
-lookupSymbol sym db = convert' $ lookupSym sym db
+lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String
+lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db
lookupSym :: Symbol -> SymbolDb -> [ModuleString]
-lookupSym sym db = M.findWithDefault [] sym $ sdTable db
+lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db
---------------------------------------------------------------
+loadSymbolDb' :: IOish m => GhcModT m SymbolDb
+loadSymbolDb' = do
+ cache <- symbolCache <$> cradle
+ let doLoad True = do
+ db <- decode <$> liftIO (LBS.readFile cache)
+ outdated <- isOutdated db
+ if outdated
+ then doLoad False
+ else return db
+ doLoad False = do
+ db <- loadSymbolDb
+ liftIO $ LBS.writeFile cache $ encode db
+ return db
+ doLoad =<< liftIO (doesFileExist cache)
+
-- | Loading a file and creates 'SymbolDb'.
loadSymbolDb :: IOish m => GhcModT m SymbolDb
loadSymbolDb = do
@@ -95,9 +135,9 @@
dumpSymbol :: IOish m => GhcModT m ()
dumpSymbol = do
ts <- liftIO getCurrentModTime
- st <- runGmPkgGhc getGlobalSymbolTable
- liftIO . BS.putStr $ encode SymbolDb {
- sdTable = M.fromAscList st
+ st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
+ liftIO . LBS.putStr $ encode SymbolDb {
+ sdTable = st
, sdTimestamp = ts
}
@@ -108,28 +148,42 @@
any (tCache <=) $ map tfTime files -- including equal just in case
-- | Browsing all functions in all system modules.
-getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
-getGlobalSymbolTable = do
- df <- G.getSessionDynFlags
- let mods = listVisibleModules df
- moduleInfos <- mapM G.getModuleInfo mods
- return $ collectModules
- $ extractBindings `concatMap` (moduleInfos `zip` mods)
+getGlobalSymbolTable :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))
+getGlobalSymbolTable hsc_env =
+ foldM (extend hsc_env) M.empty $ listVisibleModules $ hsc_dflags hsc_env
-extractBindings :: (Maybe G.ModuleInfo, G.Module)
- -> [(Symbol, ModuleString)]
-extractBindings (Nothing, _) = []
-extractBindings (Just inf, mdl) =
- map (\name -> (getOccString name, modStr)) names
- where
- names = G.modInfoExports inf
- modStr = ModuleString $ moduleNameString $ moduleName mdl
+extend :: HscEnv
+ -> Map Symbol (Set ModuleNameBS)
+ -> Module
+ -> IO (Map Symbol (Set ModuleNameBS))
+extend hsc_env mm mdl = do
+ eps <- readIORef $ hsc_EPS hsc_env
+ modinfo <- unsafeInterleaveIO $ runLightGhc hsc_env $ do
+ G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)
-collectModules :: [(Symbol, ModuleString)]
- -> [(Symbol, [ModuleString])]
-collectModules = map tieup . groupBy ((==) `on` fst) . sort
- where
- tieup x = (head (map fst x), map snd x)
+ return $ M.unionWith S.union mm $ extractBindings modinfo mdl
+
+extractBindings :: Maybe G.ModuleInfo
+ -> G.Module
+ -> Map Symbol (Set ModuleNameBS)
+extractBindings Nothing _ = M.empty
+extractBindings (Just inf) mdl = M.fromList $ do
+ name <- G.modInfoExports inf
+ let sym = fastStringToByteString $ occNameFS $ G.getOccName name
+ mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl
+ return (sym, mdls)
+
+mkFastStringByteString' :: BS.ByteString -> FastString
+#if !MIN_VERSION_ghc(7,8,0)
+fastStringToByteString :: FastString -> BS.ByteString
+fastStringToByteString = BS.pack . bytesFS
+
+mkFastStringByteString' = mkFastStringByteList . BS.unpack
+#elif __GLASGOW_HASKELL__ == 708
+mkFastStringByteString' = unsafePerformIO . mkFastStringByteString
+#else
+mkFastStringByteString' = mkFastStringByteString
+#endif
----------------------------------------------------------------
diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs
--- a/Language/Haskell/GhcMod/Flag.hs
+++ b/Language/Haskell/GhcMod/Flag.hs
@@ -4,10 +4,6 @@
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
--- | Listing GHC flags. (e.g -fno-warn-orphans)
-
+-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@.
flags :: IOish m => GhcModT m String
-flags = convert' [ "-f" ++ prefix ++ option
- | option <- Gap.fOptions
- , prefix <- ["","no-"]
- ]
+flags = convert' Gap.ghcCmdOptions
diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs
--- a/Language/Haskell/GhcMod/Gap.hs
+++ b/Language/Haskell/GhcMod/Gap.hs
@@ -9,7 +9,7 @@
, getSrcSpan
, getSrcFile
, withInteractiveContext
- , fOptions
+ , ghcCmdOptions
, toStringBuffer
, showSeverityCaption
, setCabalPkg
@@ -18,12 +18,14 @@
, setDeferTypedHoles
, setWarnTypedHoles
, setDumpSplices
+ , setNoMaxRelevantBindings
, isDumpSplices
, filterOutChildren
, infoThing
, pprInfo
, HasType(..)
, errorMsgSpan
+ , setErrorMsgSpan
, typeForUser
, nameForUser
, occNameForUser
@@ -44,6 +46,7 @@
, Language.Haskell.GhcMod.Gap.isSynTyCon
, parseModuleHeader
, mkErrStyle'
+ , everythingStagedWithContext
) where
import Control.Applicative hiding (empty)
@@ -75,10 +78,14 @@
import qualified Pretty
import qualified StringBuffer as SB
+#if __GLASGOW_HASKELL__ >= 710
+import CoAxiom (coAxiomTyCon)
+#endif
+
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
import ConLike (ConLike(..))
-import PatSyn (patSynType)
+import PatSyn
#else
import TcRnTypes
#endif
@@ -111,6 +118,8 @@
import Parser
import SrcLoc
import Packages
+import Data.Generics (GenericQ, extQ, gmapQ)
+import GHC.SYB.Utils (Stage(..))
import Language.Haskell.GhcMod.Types (Expression(..))
import Prelude
@@ -141,22 +150,32 @@
withStyle _ = withPprStyleDoc
#endif
-#if __GLASGOW_HASKELL__ >= 706
-type GmLogAction = LogAction
+#if __GLASGOW_HASKELL__ >= 800
+-- flip LogAction
+type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+#elif __GLASGOW_HASKELL__ >= 706
+type GmLogAction = forall a. a -> LogAction
#else
-type GmLogAction = DynFlags -> LogAction
+type GmLogAction = forall a. a -> DynFlags -> LogAction
#endif
+-- DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
+
setLogAction :: DynFlags -> GmLogAction -> DynFlags
setLogAction df f =
-#if __GLASGOW_HASKELL__ >= 706
- df { log_action = f }
+#if __GLASGOW_HASKELL__ >= 800
+ df { log_action = flip f }
+#elif __GLASGOW_HASKELL__ >= 706
+ df { log_action = f (error "setLogAction") }
#else
- df { log_action = f df }
+ df { log_action = f (error "setLogAction") df }
#endif
showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 800
+showDocWith dflags mode = Pretty.renderStyle mstyle where
+ mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags }
+#elif __GLASGOW_HASKELL__ >= 708
-- Pretty.showDocWith disappeard.
-- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc
showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)
@@ -198,19 +217,26 @@
----------------------------------------------------------------
-fOptions :: [String]
+ghcCmdOptions :: [String]
#if __GLASGOW_HASKELL__ >= 710
-fOptions = [option | (FlagSpec option _ _ _) <- fFlags]
- ++ [option | (FlagSpec option _ _ _) <- fWarningFlags]
- ++ [option | (FlagSpec option _ _ _) <- fLangFlags]
-#elif __GLASGOW_HASKELL__ >= 704
-fOptions = [option | (option,_,_) <- fFlags]
+-- this also includes -X options and all sorts of other things so the
+ghcCmdOptions = flagsForCompletion False
+#else
+ghcCmdOptions = [ "-f" ++ prefix ++ option
+ | option <- opts
+ , prefix <- ["","no-"]
+ ]
+# if __GLASGOW_HASKELL__ >= 704
+ where opts =
+ [option | (option,_,_) <- fFlags]
++ [option | (option,_,_) <- fWarningFlags]
++ [option | (option,_,_) <- fLangFlags]
-#else
-fOptions = [option | (option,_,_,_) <- fFlags]
+# else
+ where opts =
+ [option | (option,_,_,_) <- fFlags]
++ [option | (option,_,_,_) <- fWarningFlags]
++ [option | (option,_,_,_) <- fLangFlags]
+# endif
#endif
----------------------------------------------------------------
@@ -313,7 +339,17 @@
#endif
----------------------------------------------------------------
+
+-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
+setNoMaxRelevantBindings :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 708
+setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
+#else
+setNoMaxRelevantBindings = id
+#endif
+
----------------------------------------------------------------
+----------------------------------------------------------------
class HasType a where
getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
@@ -357,28 +393,44 @@
pprInfo m _ (thing, fixity, insts, famInsts)
= pprTyThingInContextLoc' thing
$$ show_fixity fixity
- $$ InstEnv.pprInstances insts
- $$ pprFamInsts famInsts
+ $$ vcat (map pprInstance' insts)
+ $$ vcat (map pprFamInst' famInsts)
#else
pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
pprInfo m pefas (thing, fixity, insts)
= pprTyThingInContextLoc' pefas thing
$$ show_fixity fixity
- $$ vcat (map pprInstance insts)
+ $$ vcat (map pprInstance' insts)
#endif
where
show_fixity fx
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
#if __GLASGOW_HASKELL__ >= 708
- pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2
- (char '\t' <> ptext (sLit "--") <+> loc)
- where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+ pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
+#if __GLASGOW_HASKELL__ >= 710
+ pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
+ = pprTyThingInContextLoc (ATyCon rep_tc)
+
+ pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom
+ , fi_tys = lhs_tys, fi_rhs = rhs })
+ = showWithLoc (pprDefinedAt' (getName axiom)) $
+ hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)
+ 2 (equals <+> ppr rhs)
#else
- pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2
- (char '\t' <> ptext (sLit "--") <+> loc)
- where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+ pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
#endif
+#else
+ pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')
+#endif
+ showWithLoc loc doc
+ = hang doc 2 (char '\t' <> comment <+> loc)
+ -- The tab tries to make them line up a bit
+ where
+ comment = ptext (sLit "--")
+ pprInstance' ispec = hang (pprInstanceHdr ispec)
+ 2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))
+ pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
pprNameDefnLoc' name
= case Name.nameSrcLoc name of
RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)
@@ -400,6 +452,13 @@
errorMsgSpan = head . errMsgSpans
#endif
+setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg
+#if __GLASGOW_HASKELL__ >= 708
+setErrorMsgSpan err s = err { errMsgSpan = s }
+#else
+setErrorMsgSpan err s = err { errMsgSpans = [s] }
+#endif
+
typeForUser :: Type -> SDoc
#if __GLASGOW_HASKELL__ >= 708
typeForUser = pprTypeForUser
@@ -429,13 +488,22 @@
----------------------------------------------------------------
----------------------------------------------------------------
-data GapThing = GtA Type | GtT TyCon | GtN
+data GapThing = GtA Type
+ | GtT TyCon
+ | GtN
+#if __GLASGOW_HASKELL__ >= 800
+ | GtPatSyn PatSyn
+#endif
fromTyThing :: TyThing -> GapThing
fromTyThing (AnId i) = GtA $ varType i
#if __GLASGOW_HASKELL__ >= 708
fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d
+#if __GLASGOW_HASKELL__ >= 800
+fromTyThing (AConLike (PatSynCon p)) = GtPatSyn p
+#else
fromTyThing (AConLike (PatSynCon p)) = GtA $ patSynType p
+#endif
#else
fromTyThing (ADataCon d) = GtA $ dataConRepType d
#endif
@@ -467,8 +535,13 @@
#endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
-#if __GLASGOW_HASKELL__ >= 710
+#if __GLASGOW_HASKELL__ >= 800
-- Instance declarations of sort 'instance F (G a)'
+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc)
+-- Instance declarations of sort 'instance F G' (no variables)
+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc)
+#elif __GLASGOW_HASKELL__ >= 710
+-- Instance declarations of sort 'instance F (G a)'
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc)
-- Instance declarations of sort 'instance F G' (no variables)
getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)
@@ -575,3 +648,20 @@
rnf Empty = ()
rnf (Chunk _ b) = rnf b
#endif
+
+-- | Like 'everything', but avoid known potholes, based on the 'Stage' that
+-- generated the Ast.
+everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r
+everythingStagedWithContext stage s0 f z q x
+ | (const False
+#if __GLASGOW_HASKELL__ <= 708
+ `extQ` postTcType
+#endif
+ `extQ` fixity `extQ` nameSet) x = z
+ | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x)
+ where nameSet = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool
+#if __GLASGOW_HASKELL__ <= 708
+ postTcType = const (stage Bool
+#endif
+ fixity = const (stage Bool
+ (r, s') = q x s0
diff --git a/Language/Haskell/GhcMod/HomeModuleGraph.hs b/Language/Haskell/GhcMod/HomeModuleGraph.hs
--- a/Language/Haskell/GhcMod/HomeModuleGraph.hs
+++ b/Language/Haskell/GhcMod/HomeModuleGraph.hs
@@ -240,6 +240,7 @@
mns = map (unLoc . ideclName)
$ filter (isNothing . ideclPkgQual)
$ map unLoc hsmodImports
+ -- TODO: handle package qualifier "this"
liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns
preprocessFile :: (IOish m, GmEnv m, GmState m) =>
diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@@ -5,10 +5,9 @@
import Data.Function (on)
import Data.List (sortBy)
-import Data.Maybe (catMaybes)
import System.FilePath
import Exception (ghandle, SomeException(..))
-import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
+import GHC (GhcMonad, SrcSpan)
import Prelude
import qualified GHC as G
import qualified Language.Haskell.GhcMod.Gap as Gap
@@ -53,17 +52,18 @@
-- | Obtaining type of a target expression. (GHCi's type:)
types :: IOish m
- => FilePath -- ^ A target file.
+ => Bool -- ^ Include constraints into type signature
+ -> FilePath -- ^ A target file.
-> Int -- ^ Line number.
-> Int -- ^ Column number.
-> GhcModT m String
-types file lineNo colNo =
+types withConstraints file lineNo colNo =
ghandle handler $
runGmlT' [Left file] deferErrors $
withInteractiveContext $ do
crdl <- cradle
modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl file)
- srcSpanTypes <- getSrcSpanType modSum lineNo colNo
+ srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo
dflag <- G.getSessionDynFlags
st <- getStyle
convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
@@ -72,14 +72,8 @@
gmLog GmException "types" $ showDoc ex
return []
-getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
-getSrcSpanType modSum lineNo colNo = do
- p <- G.parseModule modSum
- tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
- let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
- es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]
- ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]
- bts <- mapM (getType tcm) bs
- ets <- mapM (getType tcm) es
- pts <- mapM (getType tcm) ps
- return $ catMaybes $ concat [ets, bts, pts]
+getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]
+getSrcSpanType withConstraints modSum lineNo colNo =
+ G.parseModule modSum
+ >>= G.typecheckModule
+ >>= flip (collectSpansTypes withConstraints) (lineNo, colNo)
diff --git a/Language/Haskell/GhcMod/LightGhc.hs b/Language/Haskell/GhcMod/LightGhc.hs
--- a/Language/Haskell/GhcMod/LightGhc.hs
+++ b/Language/Haskell/GhcMod/LightGhc.hs
@@ -42,3 +42,7 @@
runLightGhc env action = do
renv <- newIORef env
flip runReaderT renv $ unLightGhc action
+
+runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a
+runLightGhc' renv action = do
+ flip runReaderT renv $ unLightGhc action
diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs
--- a/Language/Haskell/GhcMod/Lint.hs
+++ b/Language/Haskell/GhcMod/Lint.hs
@@ -6,11 +6,11 @@
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Monad
-import Language.Haskell.HLint (hlint)
+import Language.Haskell.HLint3
import Language.Haskell.GhcMod.Utils (withMappedFile)
-
-import Data.List (stripPrefix)
+import Language.Haskell.Exts.SrcLoc (SrcLoc(..))
+import System.IO
-- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned.
@@ -18,12 +18,17 @@
=> LintOpts -- ^ Configuration parameters
-> FilePath -- ^ A target file.
-> GhcModT m String
-lint opt file =
- withMappedFile file $ \tempfile ->
- liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)
- >>= mapM (replaceFileName tempfile)
- >>= ghandle handler . pack
- where
+lint opt file = ghandle handler $
+ withMappedFile file $ \tempfile -> do
+ (flags, classify, hint) <- liftIO $ argsSettings $ optLintHlintOpts opt
+ hSrc <- liftIO $ openFile tempfile ReadMode
+ liftIO $ hSetEncoding hSrc (encoding flags)
+ res <- liftIO $ parseModuleEx flags file =<< Just `fmap` hGetContents hSrc
+ case res of
+ Right m -> pack . map show $ filter ((/=Ignore) . ideaSeverity) $ applyHints classify hint [m]
+ Left ParseError{parseErrorLocation=loc, parseErrorMessage=err} ->
+ return $ showSrcLoc loc ++ ":Error:" ++ err ++ "\n"
+ where
pack = convert' . map init -- init drops the last \n.
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
- replaceFileName fp s = return $ maybe (show s) (file++) $ stripPrefix fp (show s)
+ showSrcLoc (SrcLoc f l c) = concat [f, ":", show l, ":", show c]
diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs
--- a/Language/Haskell/GhcMod/Logger.hs
+++ b/Language/Haskell/GhcMod/Logger.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP, RankNTypes #-}
+
module Language.Haskell.GhcMod.Logger (
withLogger
, withLogger'
@@ -12,7 +14,7 @@
import Data.List
import Data.Maybe
import Data.Function
-import Control.Monad.Reader (Reader, asks, runReader)
+import Control.Monad.Reader (Reader, ask, runReader)
import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef)
import System.FilePath (normalise)
import Text.PrettyPrint
@@ -23,6 +25,8 @@
import Outputable
import qualified GHC as G
import Bag
+import SrcLoc
+import FastString
import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Doc (showPage)
@@ -57,15 +61,13 @@
writeIORef ref emptyLog
return $ b []
-appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
-appendLogRef rfm df (LogRef ref) _ sev src st msg = do
+appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
+appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
modifyIORef ref update
where
- gpe = GmPprEnv {
- gpeDynFlags = df
- , gpeMapFile = rfm
- }
- l = runReader (ppMsg st src sev msg) gpe
+ -- TODO: get rid of ppMsg and just do more or less what ghc's
+ -- defaultLogAction does
+ l = ppMsg map_file df st src sev msg
update lg@(Log ls b)
| l `elem` ls = lg
@@ -132,43 +134,56 @@
ppErrMsg :: ErrMsg -> GmPprEnvM String
ppErrMsg err = do
- dflags <- asks gpeDynFlags
+ GmPprEnv {..} <- ask
let unqual = errMsgContext err
- st = Gap.mkErrStyle' dflags unqual
- let ext = showPage dflags st (errMsgExtraInfo err)
- m <- ppMsg st spn SevError msg
- return $ m ++ (if null ext then "" else "\n" ++ ext)
- where
- spn = Gap.errorMsgSpan err
- msg = errMsgShortDoc err
+ st = Gap.mkErrStyle' gpeDynFlags unqual
+ err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
+ return $ showPage gpeDynFlags st $ pprLocErrMsg err'
-ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String
-ppMsg st spn sev msg = do
- dflags <- asks gpeDynFlags
- let cts = showPage dflags st msg
- prefix <- ppMsgPrefix spn sev cts
- return $ prefix ++ cts
+mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
+mapSrcSpanFile map_file (RealSrcSpan s) =
+ RealSrcSpan $ mapRealSrcSpanFile map_file s
+mapSrcSpanFile _ (UnhelpfulSpan s) =
+ UnhelpfulSpan s
-ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String
-ppMsgPrefix spn sev cts = do
- dflags <- asks gpeDynFlags
- mr <- asks gpeMapFile
- let defaultPrefix
- | Gap.isDumpSplices dflags = ""
- | otherwise = checkErrorPrefix
- return $ fromMaybe defaultPrefix $ do
- (line,col,_,_) <- Gap.getSrcSpan spn
- file <- mr <$> normalise <$> Gap.getSrcFile spn
- let severityCaption = Gap.showSeverityCaption sev
- pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
- = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
- | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
- return pref0
+mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan
+mapRealSrcSpanFile map_file s = let
+ start = mapRealSrcLocFile map_file $ realSrcSpanStart s
+ end = mapRealSrcLocFile map_file $ realSrcSpanEnd s
+ in
+ mkRealSrcSpan start end
+mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc
+mapRealSrcLocFile map_file l = let
+ file = mkFastString $ map_file $ unpackFS $ srcLocFile l
+ line = srcLocLine l
+ col = srcLocCol l
+ in
+ mkRealSrcLoc file line col
+
+ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String
+ppMsg map_file df st spn sev msg = let
+ cts = showPage df st msg
+ in
+ ppMsgPrefix map_file df spn sev cts ++ cts
+
+ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String
+ppMsgPrefix map_file df spn sev cts =
+ let
+ defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix
+ in
+ fromMaybe defaultPrefix $ do
+ (line,col,_,_) <- Gap.getSrcSpan spn
+ file <- map_file <$> normalise <$> Gap.getSrcFile spn
+ return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++
+ if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
+ then ""
+ else Gap.showSeverityCaption sev
+
checkErrorPrefix :: String
checkErrorPrefix = "Dummy:0:0:Error:"
warningAsErrorPrefixes :: [String]
-warningAsErrorPrefixes = ["Couldn't match expected type"
+warningAsErrorPrefixes = [ "Couldn't match expected type"
, "Couldn't match type"
, "No instance for"]
diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs
--- a/Language/Haskell/GhcMod/Monad.hs
+++ b/Language/Haskell/GhcMod/Monad.hs
@@ -53,12 +53,18 @@
import System.IO.Unsafe
import Prelude
-withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
-withGhcModEnv = withGhcModEnv' withCradle
+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
where
- withCradle dir =
- gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
+ withCradle dir' =
+ gbracket
+ (runJournalT $ do
+ gmSetLogLevel $ ooptLogLevel $ optOutput opts
+ findCradle' (optPrograms opts) dir')
+ (liftIO . cleanupCradle . fst)
+
+
cwdLock :: MVar ThreadId
cwdLock = unsafePerformIO $ newEmptyMVar
{-# NOINLINE cwdLock #-}
@@ -97,7 +103,7 @@
(const $ liftIO $ flushStdoutGateway gmoChan)
action
-runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a
+runGmOutT' :: GhcModOut -> GmOutT m a -> m a
runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma
-- | Run a @GhcModT m@ computation.
diff --git a/Language/Haskell/GhcMod/Monad/Newtypes.hs b/Language/Haskell/GhcMod/Monad/Newtypes.hs
--- a/Language/Haskell/GhcMod/Monad/Newtypes.hs
+++ b/Language/Haskell/GhcMod/Monad/Newtypes.hs
@@ -124,7 +124,7 @@
-- GmT ------------------------------------------
-instance forall r m. MonadReader r m => MonadReader r (GmT m) where
+instance MonadReader r m => MonadReader r (GmT m) where
local f ma = gmLiftWithInner (\run -> local f (run ma))
ask = gmLiftInner ask
diff --git a/Language/Haskell/GhcMod/Options/DocUtils.hs b/Language/Haskell/GhcMod/Options/DocUtils.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/GhcMod/Options/DocUtils.hs
@@ -0,0 +1,48 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015 Nikolay Yakimov
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program. If not, see .
+
+module Language.Haskell.GhcMod.Options.DocUtils (
+ ($$),
+ ($$$),
+ (<=>),
+ (<$$>),
+ (<||>)
+) where
+
+import Options.Applicative
+import Data.Monoid
+import Prelude
+
+infixl 6 <||>
+infixr 7 <$$>
+infixr 7 $$
+infixr 8 <=>
+infixr 9 $$$
+
+($$) :: (a -> b) -> a -> b
+($$) = ($)
+
+($$$) :: (a -> b) -> a -> b
+($$$) = ($)
+
+(<||>) :: Alternative a => a b -> a b -> a b
+(<||>) = (<|>)
+
+(<=>) :: Monoid m => m -> m -> m
+(<=>) = (<>)
+
+(<$$>) :: Functor f => (a -> b) -> f a -> f b
+(<$$>) = (<$>)
diff --git a/Language/Haskell/GhcMod/Options/Help.hs b/Language/Haskell/GhcMod/Options/Help.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/GhcMod/Options/Help.hs
@@ -0,0 +1,79 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015 Nikolay Yakimov
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program. If not, see .
+{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
+
+module Language.Haskell.GhcMod.Options.Help where
+
+import Options.Applicative
+import Options.Applicative.Help.Pretty (Doc)
+import qualified Options.Applicative.Help.Pretty as PP
+import Control.Monad.State
+import GHC.Exts( IsString(..) )
+import Data.Maybe
+import Data.Monoid
+import Prelude
+
+newtype MyDocM s a = MyDoc {unwrapState :: State s a}
+ deriving (Monad, Functor, Applicative, MonadState s)
+type MyDoc = MyDocM (Maybe Doc) ()
+
+instance IsString (MyDocM (Maybe Doc) a) where
+ fromString = append . para
+
+instance Monoid (MyDocM (Maybe Doc) ()) where
+ mappend a b = append $ doc a <> doc b
+ mempty = append PP.empty
+
+para :: String -> Doc
+para = PP.fillSep . map PP.text . words
+
+append :: Doc -> MyDocM (Maybe Doc) a
+append s = modify m >> return undefined
+ where
+ m :: Maybe Doc -> Maybe Doc
+ m Nothing = Just s
+ m (Just old) = Just $ old PP..$. s
+
+infixr 7 \\
+(\\) :: MyDoc -> MyDoc -> MyDoc
+(\\) a b = append $ doc a PP.<+> doc b
+
+doc :: MyDoc -> Doc
+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState
+
+help' :: MyDoc -> Mod f a
+help' = helpDoc . Just . doc
+
+desc :: MyDoc -> InfoMod a
+desc = footerDoc . Just . doc . indent 2
+
+code :: MyDoc -> MyDoc
+code x = do
+ _ <- " "
+ indent 4 x
+ " "
+
+progDesc' :: MyDoc -> InfoMod a
+progDesc' = progDescDoc . Just . doc
+
+indent :: Int -> MyDoc -> MyDoc
+indent n = append . PP.indent n . doc
+
+int' :: Int -> MyDoc
+int' = append . PP.int
+
+para' :: String -> MyDoc
+para' = append . para
diff --git a/Language/Haskell/GhcMod/Options/Options.hs b/Language/Haskell/GhcMod/Options/Options.hs
new file mode 100644
--- /dev/null
+++ b/Language/Haskell/GhcMod/Options/Options.hs
@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015 Nikolay Yakimov
+--
+-- This program is free software: you can redistribute it and/or modify
+-- it under the terms of the GNU Affero General Public License as published by
+-- the Free Software Foundation, either version 3 of the License, or
+-- (at your option) any later version.
+--
+-- This program is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+-- GNU Affero General Public License for more details.
+--
+-- You should have received a copy of the GNU Affero General Public License
+-- along with this program. If not, see .
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module Language.Haskell.GhcMod.Options.Options (
+ globalArgSpec
+ , parseCmdLineOptions
+) where
+
+import Options.Applicative
+import Options.Applicative.Types
+import Language.Haskell.GhcMod.Types
+import Control.Arrow
+import Data.Char (toUpper, toLower)
+import Data.List (intercalate)
+import Language.Haskell.GhcMod.Read
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
+import Data.Monoid
+import Prelude
+
+-- | Parse a set of arguments according to the ghc-mod CLI flag spec, producing
+-- @Options@ set accordingly.
+parseCmdLineOptions :: [String] -> Maybe Options
+parseCmdLineOptions = getParseResult . execParserPure (prefs mempty) (info globalArgSpec mempty)
+
+splitOn :: Eq a => a -> [a] -> ([a], [a])
+splitOn c = second (drop 1) . break (==c)
+
+logLevelParser :: Parser GmLogLevel
+logLevelParser =
+ logLevelSwitch <*>
+ logLevelOption
+ <||> silentSwitch
+ where
+ logLevelOption =
+ option parseLL
+ $$ long "verbose"
+ <=> metavar "LEVEL"
+ <=> value GmWarning
+ <=> showDefaultWith showLL
+ <=> help' $$$ do
+ "Set log level ("
+ <> int' (fromEnum (minBound :: GmLogLevel))
+ <> "-"
+ <> int' (fromEnum (maxBound :: GmLogLevel))
+ <> ")"
+ "You can also use strings (case-insensitive):"
+ para'
+ $ intercalate ", "
+ $ map showLL ([minBound..maxBound] :: [GmLogLevel])
+ logLevelSwitch =
+ repeatAp succ' . length <$> many $$ flag' ()
+ $$ short 'v'
+ <=> help "Increase log level"
+ silentSwitch = flag' GmSilent
+ $$ long "silent"
+ <=> short 's'
+ <=> help "Be silent, set log level to 'silent'"
+ showLL = drop 2 . map toLower . show
+ repeatAp f n = foldr (.) id (replicate n f)
+ succ' x | x == maxBound = x
+ | otherwise = succ x
+ parseLL = do
+ v <- readerAsk
+ let
+ il'= toEnum . min maxBound <$> readMaybe v
+ ll' = readMaybe ("Gm" ++ capFirst v)
+ maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
+ capFirst (h:t) = toUpper h : map toLower t
+ capFirst [] = []
+
+outputOptsSpec :: Parser OutputOpts
+outputOptsSpec = OutputOpts
+ <$> logLevelParser
+ <*> flag PlainStyle LispStyle
+ $$ long "tolisp"
+ <=> short 'l'
+ <=> help "Format output as an S-Expression"
+ <*> LineSeparator <$$> strOption
+ $$ long "boundary"
+ <=> long "line-separator"
+ <=> short 'b'
+ <=> metavar "SEP"
+ <=> value "\0"
+ <=> showDefault
+ <=> help "Output line separator"
+ <*> optional $$ splitOn ',' <$$> strOption
+ $$ long "line-prefix"
+ <=> metavar "OUT,ERR"
+ <=> help "Output prefixes"
+
+programsArgSpec :: Parser Programs
+programsArgSpec = Programs
+ <$> strOption
+ $$ long "with-ghc"
+ <=> value "ghc"
+ <=> showDefault
+ <=> help "GHC executable to use"
+ <*> strOption
+ $$ long "with-ghc-pkg"
+ <=> value "ghc-pkg"
+ <=> showDefault
+ <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
+ <*> strOption
+ $$ long "with-cabal"
+ <=> value "cabal"
+ <=> showDefault
+ <=> help "cabal-install executable to use"
+ <*> strOption
+ $$ long "with-stack"
+ <=> value "stack"
+ <=> showDefault
+ <=> help "stack executable to use"
+
+-- | An optparse-applicative @Parser@ sepcification for @Options@ so that
+-- applications making use of the ghc-mod API can have a consistent way of
+-- parsing global options.
+globalArgSpec :: Parser Options
+globalArgSpec = Options
+ <$> outputOptsSpec
+ <*> programsArgSpec
+ <*> many $$ strOption
+ $$ long "ghcOpt"
+ <=> long "ghc-option"
+ <=> short 'g'
+ <=> metavar "OPT"
+ <=> help "Option to be passed to GHC"
+ <*> many fileMappingSpec
+ <*> strOption
+ $$ long "encoding"
+ <=> value "UTF-8"
+ <=> showDefault
+ <=> help "I/O encoding"
+ where
+ fileMappingSpec =
+ getFileMapping . splitOn '=' <$> strOption
+ $$ long "map-file"
+ <=> metavar "MAPPING"
+ <=> fileMappingHelp
+ fileMappingHelp = help' $ do
+ "Redirect one file to another"
+ "--map-file \"file1.hs=file2.hs\""
+ indent 4 $ do
+ "can be used to tell ghc-mod"
+ \\ "that it should take source code"
+ \\ "for `file1.hs` from `file2.hs`."
+ "`file1.hs` can be either full path,"
+ \\ "or path relative to project root."
+ "`file2.hs` has to be either relative to project root,"
+ \\ "or full path (preferred)"
+ "--map-file \"file.hs\""
+ indent 4 $ do
+ "can be used to tell ghc-mod that it should take"
+ \\ "source code for `file.hs` from stdin. File end"
+ \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
+ \\ "`file.hs` may or may not exist, and should be"
+ \\ "either full path, or relative to project root."
+ getFileMapping = second (\i -> if null i then Nothing else Just i)
diff --git a/Language/Haskell/GhcMod/PathsAndFiles.hs b/Language/Haskell/GhcMod/PathsAndFiles.hs
--- a/Language/Haskell/GhcMod/PathsAndFiles.hs
+++ b/Language/Haskell/GhcMod/PathsAndFiles.hs
@@ -220,7 +220,7 @@
-- | Filename of the symbol table cache file.
symbolCache :: Cradle -> FilePath
-symbolCache crdl = cradleTempDir crdl symbolCacheFile
+symbolCache crdl = cradleRootDir crdl cradleDistDir crdl symbolCacheFile
symbolCacheFile :: String
symbolCacheFile = "ghc-mod.symbol-cache"
diff --git a/Language/Haskell/GhcMod/Pretty.hs b/Language/Haskell/GhcMod/Pretty.hs
--- a/Language/Haskell/GhcMod/Pretty.hs
+++ b/Language/Haskell/GhcMod/Pretty.hs
@@ -32,7 +32,8 @@
gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
-gmComponentNameDoc ChLibName = text $ "library"
+gmComponentNameDoc (ChLibName "") = text $ "library"
+gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n
diff --git a/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs
--- a/Language/Haskell/GhcMod/SrcUtils.hs
+++ b/Language/Haskell/GhcMod/SrcUtils.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}
+-- TODO: remove CPP once Gap(ed)
+{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Language.Haskell.GhcMod.SrcUtils where
@@ -6,11 +7,14 @@
import Control.Applicative
import CoreUtils (exprType)
import Data.Generics
-import Data.Maybe (fromMaybe)
+import Data.Maybe
import Data.Ord as O
import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
+import Var (Var)
import qualified GHC as G
-import GHC.SYB.Utils (Stage(..), everythingStaged)
+import qualified Var as G
+import qualified Type as G
+import GHC.SYB.Utils
import GhcMonad
import qualified Language.Haskell.Exts.Annotated as HE
import Language.Haskell.GhcMod.Doc
@@ -20,6 +24,10 @@
import Outputable (PprStyle)
import TcHsSyn (hsPatType)
import Prelude
+import Control.Monad
+import Data.List (nub)
+import Control.Arrow
+import qualified Data.Map as M
----------------------------------------------------------------
@@ -33,6 +41,101 @@
getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)
----------------------------------------------------------------
+
+-- | Stores mapping from monomorphic to polymorphic types
+type CstGenQS = M.Map Var Type
+-- | Generic type to simplify SYB definition
+type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)
+
+collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]
+collectSpansTypes withConstraints tcs lc =
+ -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree
+ -- (but not left-to-right)
+ everythingStagedWithContext TypeChecker M.empty (liftM2 (++))
+ (return [])
+ ((return [],)
+ `mkQ` (hsBind :: CstGenQT G.LHsBind) -- matches on binds
+ `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions
+ `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns
+ )
+ (G.tm_typechecked_source tcs)
+ where
+ -- Helper function to insert mapping into CstGenQS
+ insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)
+ -- If there is AbsBinds here, insert mapping into CstGenQS if needed
+ hsBind (L _ G.AbsBinds{abs_exports = es'}) s
+ | withConstraints = (return [], foldr insExp s es')
+ | otherwise = (return [], s)
+#if __GLASGOW_HASKELL__ >= 800
+ -- TODO: move to Gap
+ -- Note: this deals with bindings with explicit type signature, e.g.
+ -- double :: Num a => a -> a
+ -- double x = 2*x
+ hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s
+ | withConstraints =
+ let new_s =
+ case bind of
+ G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s
+ _ -> s
+ in (return [], new_s)
+ | otherwise = (return [], s)
+#endif
+ -- Otherwise, it's the same as other cases
+ hsBind x s = genericCT x s
+ -- Generic SYB function to get type
+ genericCT x s
+ | withConstraints
+ = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s)
+ | otherwise = (maybeToList <$> getType' x, s)
+ -- Collects everything with Id from LHsBind, LHsExpr, or LPat
+ collectBinders :: Data a => a -> [Id]
+ collectBinders = listifyStaged TypeChecker (const True)
+ -- Gets monomorphic type with location
+ getType' x@(L spn _)
+ | G.isGoodSrcSpan spn && spn `G.spans` lc
+ = getType tcs x
+ | otherwise = return Nothing
+ -- Gets constrained type
+ constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id
+ -> CstGenQS -- ^ Map from Id to polymorphic type
+ -> SrcSpan -- ^ extent of expression, copied to result
+ -> Type -- ^ monomorphic type
+ -> [(SrcSpan, Type)] -- ^ result
+ constrainedType pids s spn genTyp =
+ let
+ -- runs build on every binder.
+ ctys = mapMaybe build (nub pids)
+ -- Computes constrained type for x. Returns (constraints, substitutions)
+ -- Substitutions are needed because type variables don't match
+ -- between polymorphic and monomorphic types.
+ -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()`
+ build x | Just cti <- x `M.lookup` s
+ = let
+ (preds', ctt) = getPreds cti
+ -- list of type variables in monomorphic type
+ vts = listifyStaged TypeChecker G.isTyVar $ G.varType x
+ -- list of type variables in polymorphic type
+ tvm = listifyStaged TypeChecker G.isTyVarTy ctt
+ in Just (preds', zip vts tvm)
+ | otherwise = Nothing
+ -- list of constraints
+ preds = concatMap fst ctys
+ -- Type variable substitutions
+#if __GLASGOW_HASKELL__ >= 800
+ -- TODO: move to Gap
+ subs = G.mkTvSubstPrs $ concatMap snd ctys
+#else
+ subs = G.mkTopTvSubst $ concatMap snd ctys
+#endif
+ -- Constrained type
+ ty = G.substTy subs $ G.mkFunTys preds genTyp
+ in [(spn, ty)]
+ -- Splits a given type into list of constraints and simple type. Drops foralls.
+ getPreds :: Type -> ([Type], Type)
+ getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x
+ | Just (c, t) <- G.splitFunTy_maybe x
+ , G.isPredTy c = first (c:) $ getPreds t
+ | otherwise = ([], x)
listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]
listifySpans tcs lc = listifyStaged TypeChecker p tcs
diff --git a/Language/Haskell/GhcMod/Stack.hs b/Language/Haskell/GhcMod/Stack.hs
--- a/Language/Haskell/GhcMod/Stack.hs
+++ b/Language/Haskell/GhcMod/Stack.hs
@@ -75,12 +75,12 @@
findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath]
findExecutablesInDirectories' path binary =
- U.findFilesWith' isExecutable path (binary <.> exeExtension)
+ U.findFilesWith' isExecutable path (binary <.> exeExtension')
where isExecutable file = do
perms <- getPermissions file
return $ executable perms
- exeExtension = if isWindows then "exe" else ""
+ exeExtension' = if isWindows then "exe" else ""
readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String
readStack args = do
diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs
--- a/Language/Haskell/GhcMod/Target.hs
+++ b/Language/Haskell/GhcMod/Target.hs
@@ -21,6 +21,9 @@
import Control.Applicative
import Control.Category ((.))
import GHC
+#if __GLASGOW_HASKELL__ >= 800
+import GHC.LanguageExtensions
+#endif
import GHC.Paths (libdir)
import SysTools
import DynFlags
@@ -66,29 +69,41 @@
withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action
initSession :: IOish m
- => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()
+ => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m ()
initSession opts mdf = do
s <- gmsGet
case gmGhcSession s of
- Just GmGhcSession {..} | gmgsOptions /= opts-> do
- gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
- putNewSession s
- Just _ -> return ()
Nothing -> do
gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"
putNewSession s
+ Just GmGhcSession {..} -> do
+ gmLog GmDebug "initSession" $ text "Flags changed, creating new session"
+ crdl <- cradle
+ changed <- liftIO $ runLightGhc' gmgsSession $ do
+ df <- getSessionDynFlags
+ ndf <- initDF crdl
+ return $ ndf `eqDynFlags` df
+ if changed
+ then putNewSession s
+ else return ()
where
+ initDF Cradle { cradleTempDir } = do
+ let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
+ _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
+ getSessionDynFlags
+
putNewSession s = do
- rghc <- (liftIO . newIORef =<< newSession =<< cradle)
+ rghc <- (liftIO . newIORef =<< newSession)
gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
- newSession Cradle { cradleTempDir } = liftIO $ do
- runGhc (Just libdir) $ do
- let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)
- _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags
+ newSession = do
+ crdl <- cradle
+ liftIO $ runGhc (Just libdir) $ do
+ _ <- initDF crdl
getSession
+
-- | Drop the currently active GHC session, the next that requires a GHC session
-- will initialize a new one.
dropSession :: IOish m => GhcModT m ()
@@ -114,7 +129,7 @@
-- of certain files or modules, with updated GHC flags
runGmlT' :: IOish m
=> [Either FilePath ModuleName]
- -> (DynFlags -> Ghc DynFlags)
+ -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> GmlT m a
-> GhcModT m a
runGmlT' fns mdf action = runGmlTWith fns mdf id action
@@ -124,7 +139,7 @@
-- transformation
runGmlTWith :: IOish m
=> [Either FilePath ModuleName]
- -> (DynFlags -> Ghc DynFlags)
+ -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)
-> (GmlT m a -> GmlT m b)
-> GmlT m a
-> GhcModT m b
@@ -275,8 +290,7 @@
pickComponent :: Set ChComponentName -> ChComponentName
pickComponent scn = Set.findMin scn
-packageGhcOptions :: (Applicative m, IOish m, Gm m)
- => m [GHCOption]
+packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption]
packageGhcOptions = do
crdl <- cradle
case cradleProject crdl of
@@ -451,7 +465,9 @@
case target' of
HscNothing -> do
void $ load LoadAllTargets
- mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg
+ forM_ mg $
+ handleSourceError (gmLog GmDebug "loadTargets" . text . show)
+ . void . (parseModule >=> typecheckModule >=> desugarModule)
HscInterpreted -> do
void $ load LoadAllTargets
_ -> error ("loadTargets: unsupported hscTarget")
@@ -477,10 +493,16 @@
needsHscInterpreted :: ModuleGraph -> Bool
needsHscInterpreted = any $ \ms ->
let df = ms_hspp_opts ms in
+#if __GLASGOW_HASKELL__ >= 800
+ TemplateHaskell `xopt` df
+ || QuasiQuotes `xopt` df
+ || PatternSynonyms `xopt` df
+#else
Opt_TemplateHaskell `xopt` df
|| Opt_QuasiQuotes `xopt` df
#if __GLASGOW_HASKELL__ >= 708
|| (Opt_PatternSynonyms `xopt` df)
+#endif
#endif
cabalResolvedComponents :: (IOish m) =>
diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs
--- a/Language/Haskell/GhcMod/Types.hs
+++ b/Language/Haskell/GhcMod/Types.hs
@@ -71,7 +71,7 @@
newtype LineSeparator = LineSeparator String deriving (Show)
data FileMapping = FileMapping {fmPath :: FilePath, fmTemp :: Bool}
- deriving Show
+ deriving (Eq, Show)
type FileMappingMap = Map FilePath FileMapping
@@ -105,6 +105,7 @@
-- | GHC command line options set on the @ghc-mod@ command line
, optGhcUserOptions :: [GHCOption]
, optFileMappings :: [(FilePath, Maybe FilePath)]
+ , optEncoding :: String
} deriving (Show)
-- | A default 'Options'.
@@ -124,6 +125,7 @@
}
, optGhcUserOptions = []
, optFileMappings = []
+ , optEncoding = "UTF-8"
}
----------------------------------------------------------------
@@ -132,7 +134,7 @@
| SandboxProject
| PlainProject
| StackProject StackEnv
- deriving (Eq, Show)
+ deriving (Eq, Show, Ord)
isCabalHelperProject :: Project -> Bool
isCabalHelperProject StackProject {} = True
@@ -144,7 +146,7 @@
, seBinPath :: [FilePath]
, seSnapshotPkgDb :: FilePath
, seLocalPkgDb :: FilePath
- } deriving (Eq, Show)
+ } deriving (Eq, Show, Ord)
-- | The environment where this library is used.
data Cradle = Cradle {
@@ -159,7 +161,7 @@
, cradleCabalFile :: Maybe FilePath
-- | The build info directory.
, cradleDistDir :: FilePath
- } deriving (Eq, Show)
+ } deriving (Eq, Show, Ord)
data GmStream = GmOutStream | GmErrStream
deriving (Show)
@@ -269,7 +271,7 @@
mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
return $ GmModuleGraph mpGraph
where
- swapMap :: (Ord k, Ord v) => Map k v -> Map v k
+ swapMap :: Ord v => Map k v -> Map v k
swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
instance Monoid GmModuleGraph where
@@ -386,13 +388,15 @@
-- ^ If 'True', "browseWith" also returns operators.
, optBrowseDetailed :: Bool
-- ^ If 'True', "browseWith" also returns types.
+ , optBrowseParents :: Bool
+ -- ^ If 'True', "browseWith" also returns parents.
, optBrowseQualified :: Bool
-- ^ If 'True', "browseWith" will return fully qualified name
} deriving (Show)
-- | Default "BrowseOpts" instance
defaultBrowseOpts :: BrowseOpts
-defaultBrowseOpts = BrowseOpts False False False
+defaultBrowseOpts = BrowseOpts False False False False
mkLabel ''GhcModCaches
mkLabel ''GhcModState
diff --git a/Language/Haskell/GhcMod/World.hs b/Language/Haskell/GhcMod/World.hs
--- a/Language/Haskell/GhcMod/World.hs
+++ b/Language/Haskell/GhcMod/World.hs
@@ -19,7 +19,7 @@
, worldCabalFile :: Maybe TimedFile
, worldCabalConfig :: Maybe TimedFile
, worldCabalSandboxConfig :: Maybe TimedFile
- , worldSymbolCache :: Maybe TimedFile
+ , worldMappedFiles :: FileMappingMap
} deriving (Eq)
timedPackageCaches :: IOish m => GhcModT m [TimedFile]
@@ -35,14 +35,14 @@
mCabalFile <- liftIO $ timeFile `traverse` cradleCabalFile crdl
mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)
mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)
- mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)
+ mFileMap <- getMMappedFiles
return World {
worldPackageCaches = pkgCaches
, worldCabalFile = mCabalFile
, worldCabalConfig = mCabalConfig
, worldCabalSandboxConfig = mCabalSandboxConfig
- , worldSymbolCache = mSymbolCache
+ , worldMappedFiles = mFileMap
}
didWorldChange :: IOish m => World -> GhcModT m Bool
diff --git a/NotCPP/Declarations.hs b/NotCPP/Declarations.hs
--- a/NotCPP/Declarations.hs
+++ b/NotCPP/Declarations.hs
@@ -104,21 +104,36 @@
TySynD n _ _ -> [(TcClsName, n)]
ClassD _ n _ _ _ -> [(TcClsName, n)]
- FamilyD _ n _ _ -> [(TcClsName, n)]
+#if __GLASGOW_HASKELL__ >= 800
+ DataD _ n _ _ ctors _ ->
+#else
DataD _ n _ ctors _ ->
+#endif
[(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors)
+#if __GLASGOW_HASKELL__ >= 800
+ NewtypeD _ n _ _ ctor _ ->
+#else
NewtypeD _ n _ ctor _ ->
+#endif
[(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor)
+#if __GLASGOW_HASKELL__ >= 800
+ DataInstD _ _n _ _ ctors _ ->
+#else
DataInstD _ _n _ ctors _ ->
+#endif
map ((,) TcClsName) (conNames `concatMap` ctors)
+#if __GLASGOW_HASKELL__ >= 800
+ NewtypeInstD _ _n _ _ ctor _ ->
+#else
NewtypeInstD _ _n _ ctor _ ->
+#endif
map ((,) TcClsName) (conNames ctor)
- InstanceD _ _ty _ ->
+ InstanceD {} -> -- _ _ty _
error "notcpp: Instance declarations are not supported yet"
ForeignD _ ->
error "notcpp: Foreign declarations are not supported yet"
@@ -131,8 +146,17 @@
#endif
#if __GLASGOW_HASKELL__ >= 708
- ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]
RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet"
+#endif
+
+#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 800
+ FamilyD _ n _ _ -> [(TcClsName, n)]
+#elif __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 800
+ ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]
+#else
+ OpenTypeFamilyD (TypeFamilyHead n _ _ _) -> [(TcClsName, n)]
+ ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _ -> [(TcClsName, n)]
+
#endif
conNames :: Con -> [Name]
diff --git a/NotCPP/LookupValueName.hs b/NotCPP/LookupValueName.hs
--- a/NotCPP/LookupValueName.hs
+++ b/NotCPP/LookupValueName.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
-- | This module uses scope lookup techniques to either export
-- 'lookupValueName' from @Language.Haskell.TH@, or define
@@ -25,8 +26,13 @@
case mi of
Nothing -> no
Just i -> case i of
+#if __GLASGOW_HASKELL__ >= 800
+ VarI n _ _ -> yes n
+ DataConI n _ _ -> yes n
+#else
VarI n _ _ _ -> yes n
DataConI n _ _ _ -> yes n
+#endif
_ -> err ["unexpected info:", show i]
where
no = return Nothing
@@ -34,5 +40,5 @@
err = fail . showString "NotCPP.bestValueGuess: " . unwords
$(recover [d| lookupValueName = bestValueGuess |] $ do
- VarI _ _ _ _ <- reify (mkName "lookupValueName")
+ VarI{} <- reify (mkName "lookupValueName")
return [])
diff --git a/NotCPP/Utils.hs b/NotCPP/Utils.hs
--- a/NotCPP/Utils.hs
+++ b/NotCPP/Utils.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module NotCPP.Utils where
@@ -24,6 +25,11 @@
-- | Returns @'Just' ('VarE' n)@ if the info relates to a value called
-- @n@, or 'Nothing' if it relates to a different sort of thing.
infoToExp :: Info -> Maybe Exp
+#if __GLASGOW_HASKELL__ >= 800
+infoToExp (VarI n _ _) = Just (VarE n)
+infoToExp (DataConI n _ _) = Just (ConE n)
+#else
infoToExp (VarI n _ _ _) = Just (VarE n)
infoToExp (DataConI n _ _ _) = Just (ConE n)
+#endif
infoToExp _ = Nothing
diff --git a/elisp/ghc.el b/elisp/ghc.el
--- a/elisp/ghc.el
+++ b/elisp/ghc.el
@@ -28,7 +28,7 @@
(< emacs-minor-version minor)))
(error "ghc-mod requires at least Emacs %d.%d" major minor)))
-(defconst ghc-version "5.5.0.0")
+(defconst ghc-version "5.6.0.0")
(defgroup ghc-mod '() "ghc-mod customization")
diff --git a/ghc-mod.cabal b/ghc-mod.cabal
--- a/ghc-mod.cabal
+++ b/ghc-mod.cabal
@@ -1,5 +1,5 @@
Name: ghc-mod
-Version: 5.5.0.0
+Version: 5.6.0.0
Author: Kazu Yamamoto ,
Daniel Gröber ,
Alejandro Serrano ,
@@ -95,6 +95,15 @@
test/data/stack-project/src/*.hs
test/data/stack-project/test/*.hs
+Custom-Setup
+ Setup-Depends: base
+ , Cabal < 1.25
+ , containers
+ , filepath
+ , process
+ , template-haskell
+ , transformers
+
Library
Default-Language: Haskell2010
GHC-Options: -Wall -fno-warn-deprecations
@@ -117,6 +126,7 @@
Language.Haskell.GhcMod.DebugLogger
Language.Haskell.GhcMod.Doc
Language.Haskell.GhcMod.DynFlags
+ Language.Haskell.GhcMod.DynFlagsTH
Language.Haskell.GhcMod.Error
Language.Haskell.GhcMod.FileMapping
Language.Haskell.GhcMod.FillSig
@@ -152,30 +162,34 @@
Language.Haskell.GhcMod.Types
Language.Haskell.GhcMod.Utils
Language.Haskell.GhcMod.World
+
+ Language.Haskell.GhcMod.Options.Options
+ Language.Haskell.GhcMod.Options.DocUtils
+ Language.Haskell.GhcMod.Options.Help
Other-Modules: Paths_ghc_mod
Utils
Data.Binary.Generic
System.Directory.ModTime
Build-Depends: base < 5 && >= 4.0
, bytestring < 0.11
- , binary < 0.8 && >= 0.5.1.0
+ , binary < 0.9 && >= 0.5.1.0
, containers < 0.6
- , cabal-helper < 0.7 && >= 0.6.3.0
+ , cabal-helper < 0.8 && >= 0.7.1.0
, deepseq < 1.5
, directory < 1.3
, filepath < 1.5
- , ghc < 7.11
+ , ghc < 8.2 && >= 7.6
, ghc-paths < 0.2
, ghc-syb-utils < 0.3
- , hlint < 1.10 && >= 1.8.61
+ , hlint < 1.10 && >= 1.9.27
, monad-journal < 0.8 && >= 0.4
, old-time < 1.2
, pretty < 1.2
- , process < 1.3
+ , process < 1.5
, syb < 0.7
, temporary < 1.3
- , time < 1.6
- , transformers < 0.5
+ , time < 1.7
+ , transformers < 0.6
, transformers-base < 0.5
, mtl < 2.3 && >= 2.0
, monad-control < 1.1 && >= 1
@@ -187,12 +201,13 @@
, extra == 1.4.*
, pipes == 4.1.*
, safe < 0.4 && >= 0.3.9
+ , optparse-applicative >=0.11.0 && <0.13.0
+ , template-haskell
+ , syb
if impl(ghc < 7.8)
Build-Depends: convertible
- if impl(ghc < 7.5)
- -- Only used to constrain random to a version that still works with GHC 7.4
- Build-Depends: random <= 1.0.1.1,
- ghc-prim
+ if impl(ghc >= 8.0)
+ Build-Depends: ghc-boot
Executable ghc-mod
Default-Language: Haskell2010
@@ -201,9 +216,7 @@
, GHCMod.Options
, GHCMod.Options.Commands
, GHCMod.Version
- , GHCMod.Options.DocUtils
, GHCMod.Options.ShellParse
- , GHCMod.Options.Help
GHC-Options: -Wall -fno-warn-deprecations -threaded
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src
@@ -211,10 +224,10 @@
, directory < 1.3
, filepath < 1.5
, pretty < 1.2
- , process < 1.3
+ , process < 1.5
, split < 0.3
, mtl < 2.3 && >= 2.0
- , ghc < 7.11
+ , ghc < 8.1
, monad-control ==1.0.*
, fclabels ==2.0.*
, optparse-applicative >=0.11.0 && <0.13.0
@@ -231,13 +244,13 @@
Default-Extensions: ConstraintKinds, FlexibleContexts
HS-Source-Dirs: src, .
Build-Depends: base < 5 && >= 4.0
- , binary < 0.8 && >= 0.5.1.0
+ , binary < 0.9 && >= 0.5.1.0
, deepseq < 1.5
, directory < 1.3
, filepath < 1.5
- , process < 1.3
+ , process < 1.5
, old-time < 1.2
- , time < 1.6
+ , time < 1.7
, ghc-mod
Test-Suite doctest
@@ -247,8 +260,6 @@
Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs
- if impl(ghc == 7.4.*)
- Buildable: False
Build-Depends: base
, doctest >= 0.9.3
@@ -281,11 +292,7 @@
ShellParseSpec
Build-Depends: hspec >= 2.0.0
- if impl(ghc == 7.4.*)
- Build-Depends: executable-path
X-Build-Depends-Like: CLibName
-
-
Source-Repository head
Type: git
diff --git a/src/GHCMod.hs b/src/GHCMod.hs
--- a/src/GHCMod.hs
+++ b/src/GHCMod.hs
@@ -34,9 +34,12 @@
]
main :: IO ()
-main = do
- hSetEncoding stdout utf8
- parseArgs >>= \res@(globalOptions, _) ->
+main =
+ parseArgs >>= \res@(globalOptions, _) -> do
+ enc <- mkTextEncoding $ optEncoding globalOptions
+ hSetEncoding stdout enc
+ hSetEncoding stderr enc
+ hSetEncoding stdin enc
catches (progMain res) [
Handler $ \(e :: GhcModError) ->
runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)
@@ -107,9 +110,7 @@
then fmap (x:) readStdin'
else return []
--- Someone please already rewrite the cmdline parsing code *weep* :'(
wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()
-wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo
wrapGhcCommands opts cmd =
handleGmError $ runGhcModT opts $ handler $ do
forM_ (reverse $ optFileMappings opts) $
@@ -139,7 +140,7 @@
ghcCommands (CmdDebugComponent ts) = componentInfo ts
ghcCommands (CmdBoot) = boot
-- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""
--- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands
+ghcCommands (CmdRoot) = rootInfo
ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return ""
ghcCommands (CmdModules detail) = modules detail
ghcCommands (CmdDumpSym) = dumpSymbol >> return ""
@@ -150,7 +151,7 @@
ghcCommands (CmdCheck files) = checkSyntax files
ghcCommands (CmdExpand files) = expandTemplate files
ghcCommands (CmdInfo file symb) = info file $ Expression symb
-ghcCommands (CmdType file (line, col)) = types file line col
+ghcCommands (CmdType wCon file (line, col)) = types wCon file line col
ghcCommands (CmdSplit file (line, col)) = splits file line col
ghcCommands (CmdSig file (line, col)) = sig file line col
ghcCommands (CmdAuto file (line, col)) = auto file line col
diff --git a/src/GHCMod/Options.hs b/src/GHCMod/Options.hs
--- a/src/GHCMod/Options.hs
+++ b/src/GHCMod/Options.hs
@@ -25,14 +25,10 @@
import Options.Applicative
import Options.Applicative.Types
import Language.Haskell.GhcMod.Types
-import Control.Arrow
-import Data.Char (toUpper, toLower)
-import Data.List (intercalate)
-import Language.Haskell.GhcMod.Read
import GHCMod.Options.Commands
import GHCMod.Version
-import GHCMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Options
import GHCMod.Options.ShellParse
parseArgs :: IO (Options, GhcModCommands)
@@ -74,128 +70,3 @@
argAndCmdSpec :: Parser (Options, GhcModCommands)
argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec
-splitOn :: Eq a => a -> [a] -> ([a], [a])
-splitOn c = second (drop 1) . break (==c)
-
-logLevelParser :: Parser GmLogLevel
-logLevelParser =
- logLevelSwitch <*>
- logLevelOption
- <||> silentSwitch
- where
- logLevelOption =
- option parseLL
- $$ long "verbose"
- <=> metavar "LEVEL"
- <=> value GmWarning
- <=> showDefaultWith showLL
- <=> help' $$$ do
- "Set log level ("
- <> int' (fromEnum (minBound :: GmLogLevel))
- <> "-"
- <> int' (fromEnum (maxBound :: GmLogLevel))
- <> ")"
- "You can also use strings (case-insensitive):"
- para'
- $ intercalate ", "
- $ map showLL ([minBound..maxBound] :: [GmLogLevel])
- logLevelSwitch =
- repeatAp succ' . length <$> many $$ flag' ()
- $$ short 'v'
- <=> help "Increase log level"
- silentSwitch = flag' GmSilent
- $$ long "silent"
- <=> short 's'
- <=> help "Be silent, set log level to 'silent'"
- showLL = drop 2 . map toLower . show
- repeatAp f n = foldr (.) id (replicate n f)
- succ' x | x == maxBound = x
- | otherwise = succ x
- parseLL = do
- v <- readerAsk
- let
- il'= toEnum . min maxBound <$> readMaybe v
- ll' = readMaybe ("Gm" ++ capFirst v)
- maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'
- capFirst (h:t) = toUpper h : map toLower t
- capFirst [] = []
-
-outputOptsSpec :: Parser OutputOpts
-outputOptsSpec = OutputOpts
- <$> logLevelParser
- <*> flag PlainStyle LispStyle
- $$ long "tolisp"
- <=> short 'l'
- <=> help "Format output as an S-Expression"
- <*> LineSeparator <$$> strOption
- $$ long "boundary"
- <=> long "line-separator"
- <=> short 'b'
- <=> metavar "SEP"
- <=> value "\0"
- <=> showDefault
- <=> help "Output line separator"
- <*> optional $$ splitOn ',' <$$> strOption
- $$ long "line-prefix"
- <=> metavar "OUT,ERR"
- <=> help "Output prefixes"
-
-programsArgSpec :: Parser Programs
-programsArgSpec = Programs
- <$> strOption
- $$ long "with-ghc"
- <=> value "ghc"
- <=> showDefault
- <=> help "GHC executable to use"
- <*> strOption
- $$ long "with-ghc-pkg"
- <=> value "ghc-pkg"
- <=> showDefault
- <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"
- <*> strOption
- $$ long "with-cabal"
- <=> value "cabal"
- <=> showDefault
- <=> help "cabal-install executable to use"
- <*> strOption
- $$ long "with-stack"
- <=> value "stack"
- <=> showDefault
- <=> help "stack executable to use"
-
-globalArgSpec :: Parser Options
-globalArgSpec = Options
- <$> outputOptsSpec
- <*> programsArgSpec
- <*> many $$ strOption
- $$ long "ghcOpt"
- <=> long "ghc-option"
- <=> short 'g'
- <=> metavar "OPT"
- <=> help "Option to be passed to GHC"
- <*> many fileMappingSpec
- where
- fileMappingSpec =
- getFileMapping . splitOn '=' <$> strOption
- $$ long "map-file"
- <=> metavar "MAPPING"
- <=> fileMappingHelp
- fileMappingHelp = help' $ do
- "Redirect one file to another"
- "--map-file \"file1.hs=file2.hs\""
- indent 4 $ do
- "can be used to tell ghc-mod"
- \\ "that it should take source code"
- \\ "for `file1.hs` from `file2.hs`."
- "`file1.hs` can be either full path,"
- \\ "or path relative to project root."
- "`file2.hs` has to be either relative to project root,"
- \\ "or full path (preferred)"
- "--map-file \"file.hs\""
- indent 4 $ do
- "can be used to tell ghc-mod that it should take"
- \\ "source code for `file.hs` from stdin. File end"
- \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."
- \\ "`file.hs` may or may not exist, and should be"
- \\ "either full path, or relative to project root."
- getFileMapping = second (\i -> if null i then Nothing else Just i)
diff --git a/src/GHCMod/Options/Commands.hs b/src/GHCMod/Options/Commands.hs
--- a/src/GHCMod/Options/Commands.hs
+++ b/src/GHCMod/Options/Commands.hs
@@ -23,8 +23,8 @@
import Options.Applicative.Builder.Internal
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Read
-import GHCMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.Help
type Symbol = String
type Expr = String
@@ -51,7 +51,7 @@
| CmdCheck [FilePath]
| CmdExpand [FilePath]
| CmdInfo FilePath Symbol
- | CmdType FilePath Point
+ | CmdType Bool FilePath Point
| CmdSplit FilePath Point
| CmdSig FilePath Point
| CmdAuto FilePath Point
@@ -215,12 +215,12 @@
strArg :: String -> Parser String
strArg = argument str . metavar
-filesArgsSpec :: ([String] -> b) -> Parser b
-filesArgsSpec x = x <$> some (strArg "FILES..")
+filesArgsSpec :: Parser ([String] -> b) -> Parser b
+filesArgsSpec x = x <*> some (strArg "FILES..")
-locArgSpec :: (String -> (Int, Int) -> b) -> Parser b
+locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b
locArgSpec x = x
- <$> strArg "FILE"
+ <*> strArg "FILE"
<*> ( (,)
<$> argument int (metavar "LINE")
<*> argument int (metavar "COL")
@@ -256,22 +256,30 @@
<=> short 'd'
<=> help "Print symbols with accompanying signature"
<*> switch
+ $$ long "parents"
+ <=> short 'p'
+ <=> help "Print symbols parents"
+ <*> switch
$$ long "qualified"
<=> short 'q'
<=> help "Qualify symbols"
)
<*> some (strArg "MODULE")
-debugComponentArgSpec = filesArgsSpec CmdDebugComponent
-checkArgSpec = filesArgsSpec CmdCheck
-expandArgSpec = filesArgsSpec CmdExpand
+debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)
+checkArgSpec = filesArgsSpec (pure CmdCheck)
+expandArgSpec = filesArgsSpec (pure CmdExpand)
infoArgSpec = CmdInfo
<$> strArg "FILE"
<*> strArg "SYMBOL"
-typeArgSpec = locArgSpec CmdType
-autoArgSpec = locArgSpec CmdAuto
-splitArgSpec = locArgSpec CmdSplit
-sigArgSpec = locArgSpec CmdSig
-refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"
+typeArgSpec = locArgSpec $ CmdType <$>
+ switch
+ $$ long "constraints"
+ <=> short 'c'
+ <=> help "Include constraints into type signature"
+autoArgSpec = locArgSpec (pure CmdAuto)
+splitArgSpec = locArgSpec (pure CmdSplit)
+sigArgSpec = locArgSpec (pure CmdSig)
+refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL"
mapArgSpec = CmdMapFile <$> strArg "FILE"
unmapArgSpec = CmdUnmapFile <$> strArg "FILE"
legacyInteractiveArgSpec = const CmdLegacyInteractive <$>
diff --git a/src/GHCMod/Options/DocUtils.hs b/src/GHCMod/Options/DocUtils.hs
deleted file mode 100644
--- a/src/GHCMod/Options/DocUtils.hs
+++ /dev/null
@@ -1,48 +0,0 @@
--- ghc-mod: Making Haskell development *more* fun
--- Copyright (C) 2015 Nikolay Yakimov
---
--- This program is free software: you can redistribute it and/or modify
--- it under the terms of the GNU Affero General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- This program is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU Affero General Public License for more details.
---
--- You should have received a copy of the GNU Affero General Public License
--- along with this program. If not, see .
-
-module GHCMod.Options.DocUtils (
- ($$),
- ($$$),
- (<=>),
- (<$$>),
- (<||>)
-) where
-
-import Options.Applicative
-import Data.Monoid
-import Prelude
-
-infixl 6 <||>
-infixr 7 <$$>
-infixr 7 $$
-infixr 8 <=>
-infixr 9 $$$
-
-($$) :: (a -> b) -> a -> b
-($$) = ($)
-
-($$$) :: (a -> b) -> a -> b
-($$$) = ($)
-
-(<||>) :: Alternative a => a b -> a b -> a b
-(<||>) = (<|>)
-
-(<=>) :: Monoid m => m -> m -> m
-(<=>) = (<>)
-
-(<$$>) :: Functor f => (a -> b) -> f a -> f b
-(<$$>) = (<$>)
diff --git a/src/GHCMod/Options/Help.hs b/src/GHCMod/Options/Help.hs
deleted file mode 100644
--- a/src/GHCMod/Options/Help.hs
+++ /dev/null
@@ -1,79 +0,0 @@
--- ghc-mod: Making Haskell development *more* fun
--- Copyright (C) 2015 Nikolay Yakimov
---
--- This program is free software: you can redistribute it and/or modify
--- it under the terms of the GNU Affero General Public License as published by
--- the Free Software Foundation, either version 3 of the License, or
--- (at your option) any later version.
---
--- This program is distributed in the hope that it will be useful,
--- but WITHOUT ANY WARRANTY; without even the implied warranty of
--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
--- GNU Affero General Public License for more details.
---
--- You should have received a copy of the GNU Affero General Public License
--- along with this program. If not, see .
-{-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
-
-module GHCMod.Options.Help where
-
-import Options.Applicative
-import Options.Applicative.Help.Pretty (Doc)
-import qualified Options.Applicative.Help.Pretty as PP
-import Control.Monad.State
-import GHC.Exts( IsString(..) )
-import Data.Maybe
-import Data.Monoid
-import Prelude
-
-newtype MyDocM s a = MyDoc {unwrapState :: State s a}
- deriving (Monad, Functor, Applicative, MonadState s)
-type MyDoc = MyDocM (Maybe Doc) ()
-
-instance IsString (MyDocM (Maybe Doc) a) where
- fromString = append . para
-
-instance Monoid (MyDocM (Maybe Doc) ()) where
- mappend a b = append $ doc a <> doc b
- mempty = append PP.empty
-
-para :: String -> Doc
-para = PP.fillSep . map PP.text . words
-
-append :: Doc -> MyDocM (Maybe Doc) a
-append s = modify m >> return undefined
- where
- m :: Maybe Doc -> Maybe Doc
- m Nothing = Just s
- m (Just old) = Just $ old PP..$. s
-
-infixr 7 \\
-(\\) :: MyDoc -> MyDoc -> MyDoc
-(\\) a b = append $ doc a PP.<+> doc b
-
-doc :: MyDoc -> Doc
-doc = fromMaybe PP.empty . flip execState Nothing . unwrapState
-
-help' :: MyDoc -> Mod f a
-help' = helpDoc . Just . doc
-
-desc :: MyDoc -> InfoMod a
-desc = footerDoc . Just . doc . indent 2
-
-code :: MyDoc -> MyDoc
-code x = do
- _ <- " "
- indent 4 x
- " "
-
-progDesc' :: MyDoc -> InfoMod a
-progDesc' = progDescDoc . Just . doc
-
-indent :: Int -> MyDoc -> MyDoc
-indent n = append . PP.indent n . doc
-
-int' :: Int -> MyDoc
-int' = append . PP.int
-
-para' :: String -> MyDoc
-para' = append . para
diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs
--- a/test/CheckSpec.hs
+++ b/test/CheckSpec.hs
@@ -58,7 +58,7 @@
it "emits warnings generated in GHC's desugar stage" $ do
withDirectory_ "test/data/check-missing-warnings" $ do
res <- runD $ checkSyntax ["DesugarWarnings.hs"]
- res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n"
+ res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`)
#endif
it "works with cabal builtin preprocessors" $ do
@@ -71,7 +71,9 @@
it "Uses the right qualification style" $ do
withDirectory_ "test/data/nice-qualification" $ do
res <- runD $ checkSyntax ["NiceQualification.hs"]
-#if __GLASGOW_HASKELL__ >= 708
+#if __GLASGOW_HASKELL__ >= 800
+ res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL In an equation for \8216main\8217: main = \"wrong type\"\n"
+#elif __GLASGOW_HASKELL__ >= 708
res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n"
#else
res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"
diff --git a/test/FileMappingSpec.hs b/test/FileMappingSpec.hs
--- a/test/FileMappingSpec.hs
+++ b/test/FileMappingSpec.hs
@@ -123,24 +123,30 @@
res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.hs"
- res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
+ res `shouldBe` "File.hs:4:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
it "lints in-memory file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping" $ do
res <- runD $ do
loadMappedFileSource "File.hs" "func a b = (++) a b\n"
lint defaultLintOpts "File.hs"
- res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n"
+ res `shouldBe` "File.hs:1:1: Warning: Eta reduce\NULFound:\NUL func a b = (++) a b\NULWhy not:\NUL func = (++)\n"
it "shows types of the expression for redirected files" $ do
let tdir = "test/data/file-mapping"
res <- runD' tdir $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
- types "File.hs" 4 12
+ types False "File.hs" 4 12
res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n"
+ it "shows types of the expression with constraints for redirected files" $ do --
+ let tdir = "test/data/file-mapping"
+ res <- runD' tdir $ do
+ loadMappedFile "File.hs" "File_Redir_Lint.hs"
+ types True "File.hs" 4 12
+ res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n"
it "shows types of the expression for in-memory files" $ do
let tdir = "test/data/file-mapping"
res <- runD' tdir $ do
loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\""
- types "File.hs" 1 14
+ types False "File.hs" 1 14
res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n"
it "shows info for the expression for redirected files" $ do
let tdir = "test/data/file-mapping"
@@ -184,14 +190,14 @@
res <- runD $ do
loadMappedFile "File.hs" "File_Redir_Lint.hs"
lint defaultLintOpts "File.hs"
- res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
+ res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
it "lints in-memory file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping/preprocessor" $ do
src <- readFile "File_Redir_Lint.hs"
res <- runD $ do
loadMappedFileSource "File.hs" src
lint defaultLintOpts "File.hs"
- res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
+ res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL func a b = (*) a b\NULWhy not:\NUL func = (*)\n"
describe "literate haskell tests" $ do
it "checks redirected file if one is specified and outputs original filename" $ do
withDirectory_ "test/data/file-mapping/lhs" $ do
@@ -234,7 +240,7 @@
,("Bar.hs", tmpdir "Bar_Redir.hs")]
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFile) fm
- types "Bar.hs" 5 1
+ types False "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a memory module using TemplateHaskell" $ do
srcFoo <- readFile "test/data/template-haskell/Foo.hs"
@@ -244,5 +250,5 @@
,("Bar.hs", srcBar)]
res <- run defaultOptions $ do
mapM_ (uncurry loadMappedFileSource) fm
- types "Bar.hs" 5 1
+ types False "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
diff --git a/test/FlagSpec.hs b/test/FlagSpec.hs
--- a/test/FlagSpec.hs
+++ b/test/FlagSpec.hs
@@ -9,6 +9,6 @@
spec :: Spec
spec = do
describe "flags" $ do
- it "contains at least `-fno-warn-orphans'" $ do
+ it "contains at least `-fprint-explicit-foralls" $ do
f <- runD $ lines <$> flags
- f `shouldContain` ["-fno-warn-orphans"]
+ f `shouldContain` ["-fprint-explicit-foralls"]
diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs
--- a/test/InfoSpec.hs
+++ b/test/InfoSpec.hs
@@ -19,17 +19,31 @@
describe "types" $ do
it "shows types of the expression and its outers" $ do
let tdir = "test/data/ghc-mod-check"
- res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5
+ res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5
+#if __GLASGOW_HASKELL__ >= 800
+ res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"
+#else
res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
+#endif
+
+ it "shows types of the expression with constraints and its outers" $ do
+ let tdir = "test/data/ghc-mod-check"
+ res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5
+#if __GLASGOW_HASKELL__ >= 800
+ res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"
+#else
+ res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
+#endif
+
it "works with a module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell"
- res <- runD' tdir $ types "Bar.hs" 5 1
+ res <- runD' tdir $ types False "Bar.hs" 5 1
res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a module that imports another module using TemplateHaskell" $ do
let tdir = "test/data/template-haskell"
- res <- runD' tdir $ types "ImportsTH.hs" 3 8
+ res <- runD' tdir $ types False "ImportsTH.hs" 3 8
res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
describe "info" $ do
diff --git a/test/LintSpec.hs b/test/LintSpec.hs
--- a/test/LintSpec.hs
+++ b/test/LintSpec.hs
@@ -9,7 +9,7 @@
describe "lint" $ do
it "can detect a redundant import" $ do
res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs"
- res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
+ res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n"
context "when no suggestions are given" $ do
it "doesn't output an empty line" $ do
diff --git a/test/MonadSpec.hs b/test/MonadSpec.hs
--- a/test/MonadSpec.hs
+++ b/test/MonadSpec.hs
@@ -23,6 +23,8 @@
mv_ex :: MVar (Either SomeException ())
<- newEmptyMVar
+ mv_startup_barrier :: MVar ()
+ <- newEmptyMVar
mv_startup_barrier :: MVar () <- newEmptyMVar
_t1 <- forkOS $ do
@@ -33,6 +35,19 @@
_t2 <- forkOS $ do
readMVar mv_startup_barrier -- wait for t1 to start up
+ res <- try $ runD $ return ()
+ res' <- evaluate res
+ putMVar mv_ex res'
+
+ _t1 <- forkOS $ do
+ -- wait (inside GhcModT) for t2 to receive the exception
+ _ <- runD $ liftIO $ do
+ putMVar mv_startup_barrier ()
+ readMVar mv_ex
+ return ()
+
+ _t2 <- forkOS $ do
+ readMVar mv_startup_barrier -- wait for t1 to be in GhcModT
res <- try $ runD $ return ()
res' <- evaluate res
putMVar mv_ex res'
diff --git a/test/PathsAndFilesSpec.hs b/test/PathsAndFilesSpec.hs
--- a/test/PathsAndFilesSpec.hs
+++ b/test/PathsAndFilesSpec.hs
@@ -16,12 +16,12 @@
describe "getSandboxDb" $ do
it "can parse a config file and extract the sandbox package-db" $ do
cwd <- getCurrentDirectory
- Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"
+ Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"
Just db <- getSandboxDb crdl
db `shouldSatisfy` isPkgDbAt (cwd "test/data/cabal-project/.cabal-sandbox")
it "returns Nothing if the sandbox config file is broken" $ do
- Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"
+ Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"
getSandboxDb crdl `shouldReturn` Nothing
describe "findCabalFile" $ do
diff --git a/test/TestUtils.hs b/test/TestUtils.hs
--- a/test/TestUtils.hs
+++ b/test/TestUtils.hs
@@ -6,6 +6,7 @@
, runE
, runNullLog
, runGmOutDef
+ , runLogDef
, shouldReturnError
, isPkgDbAt
, isPkgConfDAt
@@ -43,10 +44,6 @@
Right a -> return a
Left e -> error $ show e
-withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
-withSpecCradle cradledir f = do
- gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f
-
runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog)
runGhcModTSpec opt action = do
dir <- getCurrentDirectory
@@ -59,7 +56,14 @@
withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do
first (fst <$>) <$> runGhcModT' env defaultGhcModState
(gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)
+ where
+ withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a
+ withSpecCradle cradledir f =
+ gbracket
+ (runJournalT $ findSpecCradle (optPrograms opt) cradledir)
+ (liftIO . cleanupCradle . fst) f
+
-- | Run GhcMod
run :: Options -> GhcModT IO a -> IO a
run opt a = extract $ runGhcModTSpec opt a
@@ -87,6 +91,9 @@
runGmOutDef :: IOish m => GmOutT m a -> m a
runGmOutDef = runGmOutT defaultOptions
+
+runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a
+runLogDef = fmap fst . runJournalT . runGmOutDef
shouldReturnError :: Show a
=> IO (Either GhcModError a, GhcModLog)
diff --git a/test/data/case-split/Crash.hs b/test/data/case-split/Crash.hs
new file mode 100644
--- /dev/null
+++ b/test/data/case-split/Crash.hs
@@ -0,0 +1,4 @@
+module Crash where
+
+test :: Maybe a
+test x = undefined
diff --git a/test/data/case-split/Vect706.hs b/test/data/case-split/Vect706.hs
new file mode 100644
--- /dev/null
+++ b/test/data/case-split/Vect706.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE DataKinds, TypeFamilies, TypeOperators, GADTs, KindSignatures #-}
+
+module Vect706 where
+
+data Nat = Z | S Nat
+
+type family (n :: Nat) :+ (m :: Nat) :: Nat
+type instance Z :+ m = m
+type instance S n :+ m = S (n :+ m)
+
+data Vect :: Nat -> * -> * where
+ VNil :: Vect Z a
+ (:::) :: a -> Vect n a -> Vect (S n) a
+
+vAppend :: Vect n a -> Vect m a -> Vect (n :+ m) a
+vAppend x y = undefined
+
+lAppend :: [a] -> [a] -> [a]
+lAppend x y = undefined
+
+data MyList a = Nil | Cons a (MyList a)
+
+mlAppend :: MyList a -> MyList a -> MyList a
+mlAppend x y = undefined
+
+mlAppend2 :: MyList a -> MyList a -> MyList a
+mlAppend2 x y = case x of
+ x' -> undefined
+
+mlReverse :: MyList a -> MyList a
+mlReverse xs = mlReverse' xs Nil
+ where
+ mlReverse' :: MyList a -> MyList a -> MyList a
+ mlReverse' xs' accum = undefined
+
+mlReverse2 :: MyList a -> MyList a
+mlReverse2 xs = let mlReverse' :: MyList a -> MyList a -> MyList a
+ mlReverse' xs' accum = undefined
+ in mlReverse' xs Nil
diff --git a/test/data/pattern-synonyms/A.hs b/test/data/pattern-synonyms/A.hs
--- a/test/data/pattern-synonyms/A.hs
+++ b/test/data/pattern-synonyms/A.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE PatternSynonyms #-}
+
module A where
data SomeType a b = SomeType (a,b)
diff --git a/test/data/pattern-synonyms/pattern-synonyms.cabal b/test/data/pattern-synonyms/pattern-synonyms.cabal
--- a/test/data/pattern-synonyms/pattern-synonyms.cabal
+++ b/test/data/pattern-synonyms/pattern-synonyms.cabal
@@ -23,3 +23,5 @@
-- hs-source-dirs:
default-language: Haskell2010
ghc-options: -Wall
+ if impl(ghc >= 8.0.1)
+ ghc-options: -Wno-missing-pattern-synonym-signatures
diff --git a/test/data/stack-project/new-template.cabal b/test/data/stack-project/new-template.cabal
--- a/test/data/stack-project/new-template.cabal
+++ b/test/data/stack-project/new-template.cabal
@@ -16,7 +16,7 @@
library
hs-source-dirs: src
exposed-modules: Lib
- build-depends: base >= 4.7 && < 5
+ build-depends: base
default-language: Haskell2010
executable new-template-exe