Merge branch 'release-5.6.0.0' into release

.travis.yml

@@ -1,6 +1,5 @@
 language: haskell
 ghc:
-  - 7.4
   - 7.6
   - 7.8
 

Data/Binary/Generic.hs

@@ -66,7 +66,6 @@ instance Binary a => GGBinary (K1 i a) where
 #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 @@ class GSum f where
     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

Language/Haskell/GhcMod/Boot.hs

@@ -7,12 +7,13 @@ import Language.Haskell.GhcMod.Flag
 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 = [

Language/Haskell/GhcMod/Browse.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.Browse (
     browse,
     BrowseOpts(..)
@@ -11,6 +12,7 @@ import Data.List
 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 TyCon (isAlgTyCon)
 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 @@ showExport opt minfo e = do
     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
+        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' dflag (GtA a) = Just $ formatType dflag a
 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

Language/Haskell/GhcMod/CaseSplit.hs

@@ -27,7 +27,9 @@ import Language.Haskell.GhcMod.SrcUtils
 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 @@ splits file lineNo colNo =
       style <- getStyle
       dflag <- G.getSessionDynFlags
       modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)
-      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of
+      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do
-        (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do
+          let (varName, bndLoc, (varLoc,varT))
-          let varName' = showName dflag style varName  -- Convert name to string
+                | (SplitInfo vn bl vlvt _matches) <- x
-          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $
+                = (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)
-        (TySplitInfo varName bndLoc (varLoc,varT)) -> 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)
  where
    handler (SomeException ex) = do
      gmLog GmException "splits" $
@@ -107,7 +109,11 @@ isPatternVar (L _ (G.VarPat _)) = True
 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 @@ getDataCon dflag style vName dcon | [] <- Ty.dataConFieldLabels dcon =
 -- 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 @@ genCaseSplitTextFile file info = liftIO $ do
   return $ getCaseSplitText (T.lines t) info
 
 getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String
-getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS
+getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS
-                                       , sVarSpan = sVS, sTycons = sT })  =
+                                       , sVarSpan = sVS, sTycons = sT }  =
   let bindingText = getBindingText t sBS
       difference  = srcSpanDifference sBS sVS
       replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT

Language/Haskell/GhcMod/Check.hs

@@ -33,7 +33,7 @@ check files =
     runGmlTWith
       (map Left files)
       return
-      ((fmap fst <$>) . withLogger setNoMaxRelevantBindings)
+      ((fmap fst <$>) . withLogger Gap.setNoMaxRelevantBindings)
       (return ())
 
 ----------------------------------------------------------------

Language/Haskell/GhcMod/Cradle.hs

@@ -34,24 +34,29 @@ import Control.Monad.Trans.Journal (runJournalT)
 --   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 :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle
-findCradle = findCradle' =<< liftIO getCurrentDirectory
+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory
 
-findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle
+findCradleNoLog  :: forall m. (IOish m, GmOut m) => Programs -> m Cradle
-findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))
+findCradleNoLog progs =
+    fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog))
 
-findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle
+findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
-findCradle' dir = run $
+findCradle' Programs { stackProgram, cabalProgram } dir = run $
-    msum [ stackCradle dir
+    msum [ stackCradle stackProgram dir
-         , cabalCradle 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 ::
-findSpecCradle dir = do
+    (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle
-    let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]
+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 +74,18 @@ fillTempDir crdl = do
   tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)
   return crdl { cradleTempDir = tmpDir }
 
-cabalCradle :: IOish m => FilePath -> MaybeT m Cradle
+cabalCradle ::
-cabalCradle wdir = do
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
-    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
+cabalCradle cabalProg wdir = do
+    -- If cabal doesn't exist the user probably wants to use something else
+    whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do
+      gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
+      mzero
 
+    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
     let cabalDir = takeDirectory cabalFile
 
+    gmLog GmInfo "" $ text "found Cabal project at" <+>: text cabalDir
     return Cradle {
         cradleProject    = CabalProject
       , cradleCurrentDir = wdir
@@ -84,12 +95,19 @@ cabalCradle wdir = do
       , cradleDistDir    = "dist"
       }
 
-stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradle ::
-stackCradle wdir = do
+    (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
+
+    -- If cabal doesn't exist the user probably wants to use something else
+    whenM ((==Nothing) <$> liftIO (findExecutable stackProg)) $ do
+      gmLog GmInfo "" $ text "'dist/setup-config' exists but 'cabal' executable wasn't found"
+      mzero
+
     cabalFile <- MaybeT $ liftIO $ findCabalFile wdir
 
     let cabalDir = takeDirectory cabalFile
@@ -99,11 +117,12 @@ stackCradle wdir = do
     -- 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."
+      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead"
       mzero
 
     senv <- MaybeT $ getStackEnv cabalDir
 
+    gmLog GmInfo "" $ text "found Stack project at" <+>: text cabalDir
     return Cradle {
         cradleProject    = StackProject senv
       , cradleCurrentDir = wdir
@@ -113,9 +132,10 @@ stackCradle wdir = do
       , cradleDistDir    = seDistDir senv
       }
 
-stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle
+stackCradleSpec ::
-stackCradleSpec wdir = do
+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle
-  crdl <- stackCradle wdir
+stackCradleSpec stackProg wdir = do
+  crdl <- stackCradle stackProg wdir
   case crdl of
     Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do
       b <- isGmDistDir seDistDir
@@ -126,9 +146,10 @@ stackCradleSpec wdir = do
    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 "Found sandbox project at" <+>: text sbDir
     return Cradle {
         cradleProject    = SandboxProject
       , cradleCurrentDir = wdir
@@ -138,8 +159,9 @@ sandboxCradle wdir = do
       , 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

Language/Haskell/GhcMod/Debug.hs

@@ -3,11 +3,12 @@ module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo, componentInfo) where
 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,6 +18,11 @@ import Language.Haskell.GhcMod.Pretty
 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)
 
 ----------------------------------------------------------------
 
@@ -34,14 +40,20 @@ debugInfo = do
 
     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,8 +75,23 @@ cabalDebug = do
         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
+         [ "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)
@@ -139,5 +166,7 @@ mapDoc kd ad m = vcat $
 ----------------------------------------------------------------
 
 -- | Obtaining root information.
-rootInfo :: forall m. (IOish m, GmOut m) => m String
+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String
-rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))
+rootInfo = do
+    crdl <- findCradleNoLog =<< (optPrograms <$> options)
+    return $ cradleRootDir crdl ++ "\n"

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 <http://www.gnu.org/licenses/>.
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, RankNTypes #-}
 module Language.Haskell.GhcMod.DebugLogger where
 
 -- (c) The University of Glasgow 2005
@@ -62,27 +62,27 @@ import Language.Haskell.GhcMod.Gap
 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
+      SevInfo        -> printErrs putErr msg style'
-      SevFatal       -> 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

Language/Haskell/GhcMod/Doc.hs

@@ -11,11 +11,6 @@ showPage dflag style = showDocWith dflag PageMode . withStyle dflag style
 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

Language/Haskell/GhcMod/DynFlags.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE TemplateHaskell #-}
 
 module Language.Haskell.GhcMod.DynFlags where
 
@@ -10,12 +10,13 @@ import GHC.Paths (libdir)
 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 @@ allWarningFlags = unsafePerformIO $
 
 ----------------------------------------------------------------
 
--- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".
+deferErrors :: Monad m => DynFlags -> m DynFlags
-setNoMaxRelevantBindings :: DynFlags -> DynFlags
-#if __GLASGOW_HASKELL__ >= 708
-setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }
-#else
-setNoMaxRelevantBindings = id
-#endif
-
-deferErrors :: DynFlags -> Ghc DynFlags
 deferErrors df = return $
   Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $
   Gap.setDeferTypeErrors $ setNoWarningFlags df
+
+----------------------------------------------------------------
+
+deriveEqDynFlags [d|
+  eqDynFlags :: DynFlags -> DynFlags -> Bool
+  eqDynFlags = undefined
+ |]

Language/Haskell/GhcMod/DynFlagsTH.hs

@@ -0,0 +1,126 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Daniel Gröber <dxld ÄT darkboxed DOT org>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+
+{-# 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)

Language/Haskell/GhcMod/FileMapping.hs

@@ -46,8 +46,10 @@ loadMappedFileSource :: IOish m
                      -> 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 @@ loadMappedFile' from to isTemp = do
   let to' = makeRelative (cradleRootDir crdl) to
   addMMappedFile cfn (FileMapping to' isTemp)
 
-mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>
+mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target
-            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) =>
+mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target
-                  Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target
 mkMappedTarget _ _ taoc (Just to) =
-  return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
+  mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing
-mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing
+mkMappedTarget _ tid taoc _ =
+  mkTarget tid taoc Nothing
 
 {-|
 unloads previously mapped file \'file\', so that it's no longer mapped,

Language/Haskell/GhcMod/FillSig.hs

@@ -116,7 +116,9 @@ getSignature modSum lineNo colNo = do
     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 @@ getSignature modSum lineNo colNo = do
         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,7 +153,11 @@ getSignature modSum lineNo colNo = do
                         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
@@ -269,7 +277,9 @@ class FnArgsInfo ty name | ty -> name, name -> ty where
 
 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 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
   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 @@ findVar
   -> 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 False s = s
 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 @@ getPatsForVariable tcs (lineNo, colNo) =
         _ -> (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 (Ty.ConPatOut { Ty.pat_args = d }) = getBindingsForRecPat d
 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

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 @@ module Language.Haskell.GhcMod.Find
 #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.Output
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.World
-
+import Language.Haskell.GhcMod.LightGhc
-import qualified GHC as G
-import Name
-import Module
-import Exception
 
 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 @@ isOutdated db =
 
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
 --   which will be concatenated. 'loadSymbolDb' is called internally.
-findSymbol :: IOish m => Symbol -> GhcModT m String
+findSymbol :: IOish m => String -> GhcModT m String
-findSymbol sym = loadSymbolDb >>= lookupSymbol sym
+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 :: IOish m => String -> SymbolDb -> GhcModT m String
-lookupSymbol sym db = convert' $ lookupSym sym db
+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 @@ loadSymbolDb = do
 dumpSymbol :: IOish m => GhcModT m ()
 dumpSymbol = do
   ts <- liftIO getCurrentModTime
-  st <- runGmPkgGhc getGlobalSymbolTable
+  st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession
-  liftIO . BS.putStr $ encode SymbolDb {
+  liftIO . LBS.putStr $ encode SymbolDb {
-      sdTable = M.fromAscList st
+      sdTable = st
     , sdTimestamp = ts
     }
 
@@ -108,28 +148,42 @@ isOlderThan tCache files =
   any (tCache <=) $ map tfTime files -- including equal just in case
 
 -- | Browsing all functions in all system modules.
-getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
+getGlobalSymbolTable :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))
-getGlobalSymbolTable = do
+getGlobalSymbolTable hsc_env =
-  df  <- G.getSessionDynFlags
+  foldM (extend hsc_env) M.empty $ listVisibleModules $ hsc_dflags hsc_env
-  let mods = listVisibleModules df
-  moduleInfos <- mapM G.getModuleInfo mods
-  return $ collectModules
-         $ extractBindings `concatMap` (moduleInfos `zip` mods)
 
-extractBindings :: (Maybe G.ModuleInfo, G.Module)
+extend :: HscEnv
-                -> [(Symbol, ModuleString)]
+       -> Map Symbol (Set ModuleNameBS)
-extractBindings (Nothing,  _)   = []
+       -> Module
-extractBindings (Just inf, mdl) =
+       -> IO (Map Symbol (Set ModuleNameBS))
-  map (\name -> (getOccString name, modStr)) names
+extend hsc_env mm mdl = do
-  where
+  eps <- readIORef $ hsc_EPS hsc_env
-    names  = G.modInfoExports inf
+  modinfo <- unsafeInterleaveIO $ runLightGhc hsc_env $ do
-    modStr = ModuleString $ moduleNameString $ moduleName mdl
+    G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps)
 
-collectModules :: [(Symbol, ModuleString)]
+  return $ M.unionWith S.union mm $ extractBindings modinfo mdl
-               -> [(Symbol, [ModuleString])]
+
-collectModules = map tieup . groupBy ((==) `on` fst) . sort
+extractBindings :: Maybe G.ModuleInfo
-  where
+                -> G.Module
-    tieup x = (head (map fst x), map snd x)
+                -> 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
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Flag.hs

@@ -4,10 +4,6 @@ import qualified Language.Haskell.GhcMod.Gap as Gap
 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
+flags = convert' Gap.ghcCmdOptions
-                 | option <- Gap.fOptions
-                 , prefix <- ["","no-"]
-                 ]

Language/Haskell/GhcMod/Gap.hs

@@ -9,7 +9,7 @@ module Language.Haskell.GhcMod.Gap (
   , getSrcSpan
   , getSrcFile
   , withInteractiveContext
-  , fOptions
+  , ghcCmdOptions
   , toStringBuffer
   , showSeverityCaption
   , setCabalPkg
@@ -18,12 +18,14 @@ module Language.Haskell.GhcMod.Gap (
   , setDeferTypedHoles
   , setWarnTypedHoles
   , setDumpSplices
+  , setNoMaxRelevantBindings
   , isDumpSplices
   , filterOutChildren
   , infoThing
   , pprInfo
   , HasType(..)
   , errorMsgSpan
+  , setErrorMsgSpan
   , typeForUser
   , nameForUser
   , occNameForUser
@@ -44,6 +46,7 @@ module Language.Haskell.GhcMod.Gap (
   , Language.Haskell.GhcMod.Gap.isSynTyCon
   , parseModuleHeader
   , mkErrStyle'
+  , everythingStagedWithContext
   ) where
 
 import Control.Applicative hiding (empty)
@@ -75,10 +78,14 @@ import qualified InstEnv
 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 Lexer as L
 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
 withStyle _ = withPprStyleDoc
 #endif
 
-#if __GLASGOW_HASKELL__ >= 706
+#if __GLASGOW_HASKELL__ >= 800
-type GmLogAction = LogAction
+-- 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
+#if __GLASGOW_HASKELL__ >= 800
-    df { log_action = f }
+    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,20 +217,27 @@ toStringBuffer = liftIO . stringToStringBuffer . unlines
 
 ----------------------------------------------------------------
 
-fOptions :: [String]
+ghcCmdOptions :: [String]
 #if __GLASGOW_HASKELL__ >= 710
-fOptions = [option | (FlagSpec option _ _ _) <- fFlags]
+-- this also includes -X options and all sorts of other things so the
-        ++ [option | (FlagSpec option _ _ _) <- fWarningFlags]
+ghcCmdOptions = flagsForCompletion False
-        ++ [option | (FlagSpec option _ _ _) <- fLangFlags]
+#else
-#elif __GLASGOW_HASKELL__ >= 704
+ghcCmdOptions = [ "-f" ++ prefix ++ option
-fOptions = [option | (option,_,_) <- fFlags]
+                | option <- opts
+                , prefix <- ["","no-"]
+                ]
+#  if __GLASGOW_HASKELL__ >= 704
+ where opts =
+           [option | (option,_,_) <- fFlags]
         ++ [option | (option,_,_) <- fWarningFlags]
         ++ [option | (option,_,_) <- fLangFlags]
 #  else
-fOptions = [option | (option,_,_,_) <- fFlags]
+ where opts =
+           [option | (option,_,_,_) <- fFlags]
         ++ [option | (option,_,_,_) <- fWarningFlags]
         ++ [option | (option,_,_,_) <- fLangFlags]
 #  endif
+#endif
 
 ----------------------------------------------------------------
 ----------------------------------------------------------------
@@ -312,6 +338,16 @@ setWarnTypedHoles dflag = wopt_set dflag Opt_WarnTypedHoles
 setWarnTypedHoles = id
 #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
+
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
@@ -357,28 +393,44 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F
 pprInfo m _ (thing, fixity, insts, famInsts)
     = pprTyThingInContextLoc' thing
    $$ show_fixity fixity
-   $$ InstEnv.pprInstances insts
+   $$ vcat (map pprInstance' insts)
-   $$ pprFamInsts famInsts
+   $$ 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
+    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
-                                        (char '\t' <> ptext (sLit "--") <+> loc)
+#if __GLASGOW_HASKELL__ >= 710
-                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
+    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
+    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec)
-                                    (char '\t' <> ptext (sLit "--") <+> loc)
-                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')
 #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 = errMsgSpan
 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 @@ deSugar tcm e hs_env = snd <$> deSugarExpr hs_env modu rn_env ty_env e
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 
-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,7 +535,12 @@ type GLMatchI = LMatch Id
 #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)
@@ -575,3 +648,20 @@ instance NFData ByteString where
   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<TypeChecker)                 :: PostTcType -> Bool
+#endif
+        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool
+        (r, s') = q x s0

Language/Haskell/GhcMod/HomeModuleGraph.hs

@@ -240,6 +240,7 @@ updateHomeModuleGraph' env smp0 = do
                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) =>

Language/Haskell/GhcMod/Info.hs

@@ -5,10 +5,9 @@ module Language.Haskell.GhcMod.Info (
 
 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 @@ info file expr =
 
 -- | 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 @@ types file lineNo colNo =
      gmLog GmException "types" $ showDoc ex
      return []
 
-getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]
+getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]
-getSrcSpanType modSum lineNo colNo = do
+getSrcSpanType withConstraints modSum lineNo colNo =
-  p <- G.parseModule modSum
+  G.parseModule modSum
-  tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
+  >>= G.typecheckModule
-  let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]
+  >>= flip (collectSpansTypes withConstraints) (lineNo, colNo)
-      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]

Language/Haskell/GhcMod/LightGhc.hs

@@ -42,3 +42,7 @@ runLightGhc :: HscEnv -> LightGhc a -> IO a
 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

Language/Haskell/GhcMod/Lint.hs

@@ -6,11 +6,11 @@ import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
 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 Language.Haskell.Exts.SrcLoc (SrcLoc(..))
-import Data.List (stripPrefix)
+import System.IO
 
 -- | Checking syntax of a target file using hlint.
 --   Warnings and errors are returned.
@@ -18,12 +18,17 @@ lint :: IOish m
      => LintOpts  -- ^ Configuration parameters
      -> FilePath  -- ^ A target file.
      -> GhcModT m String
-lint opt file =
+lint opt file = ghandle handler $
-  withMappedFile file $ \tempfile ->
+  withMappedFile file $ \tempfile -> do
-        liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)
+    (flags, classify, hint) <- liftIO $ argsSettings $ optLintHlintOpts opt
-    >>= mapM (replaceFileName tempfile)
+    hSrc <- liftIO $ openFile tempfile ReadMode
-    >>= ghandle handler . pack
+    liftIO $ hSetEncoding hSrc (encoding flags)
+    res <- liftIO $ parseModuleEx flags file =<< Just `fmap` hGetContents hSrc
+    case res of
+      Right m -> pack . map show $ 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]

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.Ord
 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 HscTypes
 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 @@ readAndClearLogRef (LogRef ref) = do
     writeIORef ref emptyLog
     return $ b []
 
-appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
+appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction
-appendLogRef rfm df (LogRef ref) _ sev src st msg = do
+appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do
     modifyIORef ref update
   where
-    gpe = GmPprEnv {
+    -- TODO: get rid of ppMsg and just do more or less what ghc's
-            gpeDynFlags = df
+    -- defaultLogAction does
-          , gpeMapFile = rfm
+    l = ppMsg map_file df st src sev msg
-          }
-    l = runReader (ppMsg st src sev msg) gpe
 
     update lg@(Log ls b)
       | l `elem` ls = lg
@@ -132,38 +134,51 @@ sortMsgBag bag = sortBy (compare `on` Gap.errorMsgSpan) $ bagToList bag
 
 ppErrMsg :: ErrMsg -> GmPprEnvM String
 ppErrMsg err = do
-    dflags <- asks gpeDynFlags
+    GmPprEnv {..} <- ask
     let unqual = errMsgContext err
-        st = Gap.mkErrStyle' dflags unqual
+        st = Gap.mkErrStyle' gpeDynFlags unqual
-    let ext = showPage dflags st (errMsgExtraInfo err)
+        err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)
-    m <- ppMsg st spn SevError msg
+    return $ showPage gpeDynFlags st $ pprLocErrMsg err'
-    return $ m ++ (if null ext then "" else "\n" ++ ext)
-   where
-     spn = Gap.errorMsgSpan err
-     msg = errMsgShortDoc err
 
-ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String
+mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan
-ppMsg st spn sev msg = do
+mapSrcSpanFile map_file (RealSrcSpan s)   =
-  dflags <- asks gpeDynFlags
+    RealSrcSpan $ mapRealSrcSpanFile map_file s
-  let cts  = showPage dflags st msg
+mapSrcSpanFile _ (UnhelpfulSpan s) =
-  prefix <- ppMsgPrefix spn sev cts
+    UnhelpfulSpan s
-  return $ prefix ++ cts
 
-ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String
+mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan
-ppMsgPrefix spn sev cts = do
+mapRealSrcSpanFile map_file s = let
-  dflags <- asks gpeDynFlags
+    start = mapRealSrcLocFile map_file $ realSrcSpanStart s
-  mr <- asks gpeMapFile
+    end   = mapRealSrcLocFile map_file $ realSrcSpanEnd s
-  let defaultPrefix
+  in
-        | Gap.isDumpSplices dflags = ""
+    mkRealSrcSpan start end
-        | otherwise               = checkErrorPrefix
+
-  return $ fromMaybe defaultPrefix $ do
+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 <- mr <$> normalise <$> Gap.getSrcFile spn
+      file <- map_file <$> normalise <$> Gap.getSrcFile spn
-    let severityCaption = Gap.showSeverityCaption sev
+      return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++
-        pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
+        if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)
-                          = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"
+          then ""
-              | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption
+          else Gap.showSeverityCaption sev
-    return pref0
 
 checkErrorPrefix :: String
 checkErrorPrefix = "Dummy:0:0:Error:"

Language/Haskell/GhcMod/Monad.hs

@@ -54,10 +54,16 @@ import System.IO.Unsafe
 import Prelude
 
 withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a
-withGhcModEnv = withGhcModEnv' withCradle
+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f
  where
-   withCradle dir =
+   withCradle dir' =
-       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)
+       gbracket
+         (runJournalT $ do
+            gmSetLogLevel $ ooptLogLevel $ optOutput opts
+            findCradle' (optPrograms opts) dir')
+         (liftIO . cleanupCradle . fst)
+
+
 
 cwdLock :: MVar ThreadId
 cwdLock = unsafePerformIO $ newEmptyMVar
@@ -97,7 +103,7 @@ runGmOutT opts ma = do
                   (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.

Language/Haskell/GhcMod/Monad/Newtypes.hs

@@ -124,7 +124,7 @@ instance MonadTrans GmlT where
 
 -- 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
 

Language/Haskell/GhcMod/Options/DocUtils.hs

@@ -14,7 +14,7 @@
 -- You should have received a copy of the GNU Affero General Public License
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
-module GHCMod.Options.DocUtils (
+module Language.Haskell.GhcMod.Options.DocUtils (
   ($$),
   ($$$),
   (<=>),

Language/Haskell/GhcMod/Options/Help.hs

@@ -15,7 +15,7 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 {-# LANGUAGE OverloadedStrings, FlexibleInstances, GeneralizedNewtypeDeriving #-}
 
-module GHCMod.Options.Help where
+module Language.Haskell.GhcMod.Options.Help where
 
 import Options.Applicative
 import Options.Applicative.Help.Pretty (Doc)

Language/Haskell/GhcMod/Options/Options.hs

@@ -0,0 +1,173 @@
+-- ghc-mod: Making Haskell development *more* fun
+-- Copyright (C) 2015  Nikolay Yakimov <root@livid.pp.ru>
+--
+-- 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 <http://www.gnu.org/licenses/>.
+{-# 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)

Language/Haskell/GhcMod/PathsAndFiles.hs

@@ -220,7 +220,7 @@ packageCache = "package.cache"
 
 -- | 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"

Language/Haskell/GhcMod/Pretty.hs

@@ -32,7 +32,8 @@ gmRenderDoc = renderStyle docStyle
 
 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

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 @@ module Language.Haskell.GhcMod.SrcUtils where
 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 OccName (OccName)
 import Outputable (PprStyle)
 import TcHsSyn (hsPatType)
 import Prelude
+import Control.Monad
+import Data.List (nub)
+import Control.Arrow
+import qualified Data.Map as M
 
 ----------------------------------------------------------------
 
@@ -34,6 +42,101 @@ instance HasType (LPat Id) where
 
 ----------------------------------------------------------------
 
+-- | 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
   where

Language/Haskell/GhcMod/Stack.hs

@@ -75,12 +75,12 @@ findExecutablesInStackBinPath exe StackEnv {..} =
 
 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

Language/Haskell/GhcMod/Target.hs

@@ -21,6 +21,9 @@ import Control.Arrow
 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 @@ runGmPkgGhc action = do
     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
-   putNewSession s = do
+   initDF Cradle { cradleTempDir } = do
-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)
-     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
+       getSessionDynFlags
+
+   putNewSession s = do
+     rghc <- (liftIO . newIORef =<< newSession)
+     gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc }
+
+   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 @@ runGmlT fns action = runGmlT' fns return action
 -- 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 @@ runGmlT' fns mdf action = runGmlTWith fns mdf id action
 -- 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 @@ findCandidates scns = foldl1 Set.intersection scns
 pickComponent :: Set ChComponentName -> ChComponentName
 pickComponent scn = Set.findMin scn
 
-packageGhcOptions :: (Applicative m, IOish m, Gm m)
+packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption]
-                  => m [GHCOption]
 packageGhcOptions = do
     crdl <- cradle
     case cradleProject crdl of
@@ -451,7 +465,9 @@ loadTargets opts targetStrs = do
     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,11 +493,17 @@ loadTargets opts targetStrs = do
 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) =>
    GhcModT m (Map ChComponentName (GmComponent 'GMCResolved (Set ModulePath)))

Language/Haskell/GhcMod/Types.hs

@@ -71,7 +71,7 @@ data OutputStyle = LispStyle  -- ^ S expression style.
 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 @@ data Options = Options {
     -- | 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 @@ defaultOptions = Options {
     }
   , optGhcUserOptions = []
   , optFileMappings   = []
+  , optEncoding       = "UTF-8"
   }
 
 ----------------------------------------------------------------
@@ -132,7 +134,7 @@ data Project = CabalProject
              | SandboxProject
              | PlainProject
              | StackProject StackEnv
-               deriving (Eq, Show)
+               deriving (Eq, Show, Ord)
 
 isCabalHelperProject :: Project -> Bool
 isCabalHelperProject StackProject {} = True
@@ -144,7 +146,7 @@ data StackEnv = StackEnv {
     , 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 @@ data Cradle = Cradle {
   , 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 @@ instance Binary GmModuleGraph where
         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 @@ data BrowseOpts = BrowseOpts {
         -- ^ 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

Language/Haskell/GhcMod/World.hs

@@ -19,7 +19,7 @@ data World = World {
   , 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 @@ getCurrentWorld = do
     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

NotCPP/Declarations.hs

@@ -104,21 +104,36 @@ boundNames decl =
 
       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,10 +146,19 @@ boundNames decl =
 #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]
 conNames con =
     case con of

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 @@ bestValueGuess s = do
   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 @@ bestValueGuess s = do
   err = fail . showString "NotCPP.bestValueGuess: " . unwords
 
 $(recover [d| lookupValueName = bestValueGuess |] $ do
-  VarI _ _ _ _ <- reify (mkName "lookupValueName")
+  VarI{} <- reify (mkName "lookupValueName")
   return [])

NotCPP/Utils.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP             #-}
 {-# LANGUAGE TemplateHaskell #-}
 module NotCPP.Utils where
 
@@ -24,6 +25,11 @@ recoverMaybe q = recover (return Nothing) (Just <$> q)
 -- | 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

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")
 

ghc-mod.cabal

@@ -1,5 +1,5 @@
 Name:                   ghc-mod
-Version:                5.5.0.0
+Version:                5.6.0.0
 Author:                 Kazu Yamamoto <kazu@iij.ad.jp>,
                         Daniel Gröber <dxld@darkboxed.org>,
                         Alejandro Serrano <trupill@gmail.com>,
@@ -95,6 +95,15 @@ Extra-Source-Files:     ChangeLog
                         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 @@ Library
                         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 @@ Library
                         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
+                      , time              < 1.7
-                      , transformers      < 0.5
+                      , transformers      < 0.6
                       , transformers-base < 0.5
                       , mtl               < 2.3 && >= 2.0
                       , monad-control     < 1.1 && >= 1
@@ -187,12 +201,13 @@ Library
                       , 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)
+  if impl(ghc >= 8.0)
-    -- Only used to constrain random to a version that still works with GHC 7.4
+    Build-Depends:      ghc-boot
-    Build-Depends:      random <= 1.0.1.1,
-                        ghc-prim
 
 Executable ghc-mod
   Default-Language:     Haskell2010
@@ -201,9 +216,7 @@ Executable ghc-mod
                       , 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 @@ Executable ghc-mod
                       , 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 @@ Executable ghc-modi
   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 @@ Test-Suite doctest
   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,12 +292,8 @@ Test-Suite spec
                         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
   Location:             https://github.com/kazu-yamamoto/ghc-mod.git

scripts/bump.sh

@@ -9,24 +9,32 @@ fi
 
 VERSION=$1
 
-if ! echo $VERSION | grep "^[0-9.]"; then
+if ! echo $VERSION | grep -Eq "^[0-9.]*(-.+)?$"; then
     echo "invalid version";
     exit 1
 fi
 
 cd $(dirname $0)/..
 
+git checkout release-$VERSION
+
 sed -i 's/(defconst ghc-version ".*")/(defconst ghc-version "'"$VERSION"'")/' \
     elisp/ghc.el
 
 sed -r -i 's/^(Version:[[:space:]]*)[0-9.]+/\1'"$VERSION"'/' ghc-mod.cabal
 
 git add elisp/ghc.el ghc-mod.cabal
-git commit -m "Bump version to $VERSION"
+
+git update-index -q --ignore-submodules --refresh
+# If there are uncommitted changes do the bump commit
+if ! git diff-index --cached --quiet HEAD --ignore-submodules --
+then
+    git commit -m "Bump version to $VERSION" --allow-empty
+fi
 
 git checkout release
 #git merge master
-git merge -s recursive -X theirs master
+git merge -s recursive -X theirs release-$VERSION
 
 ( tac ChangeLog; echo "\n$(date '+%Y-%m-%d') v$VERSION" ) | tac \
     > ChangeLog.tmp
@@ -38,5 +46,4 @@ emacs -q -nw ChangeLog
 git add ChangeLog
 git commit -m "ChangeLog"
 
-
 git tag "v$VERSION"

src/GHCMod.hs

@@ -34,9 +34,12 @@ handler = flip gcatches
           ]
 
 main :: IO ()
-main = do
+main =
-    hSetEncoding stdout utf8
+    parseArgs >>= \res@(globalOptions, _) -> do
-    parseArgs >>= \res@(globalOptions, _) ->
+      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 @@ getFileSourceFromStdin = do
         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 (CmdDebug) = debugInfo
 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 (CmdBrowse opts ms) = concat <$> browse opts `mapM` ms
 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

src/GHCMod/Options.hs

@@ -25,14 +25,10 @@ module GHCMod.Options (
 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 Language.Haskell.GhcMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.Options
 import GHCMod.Options.ShellParse
 
 parseArgs :: IO (Options, GhcModCommands)
@@ -74,128 +70,3 @@ helpVersion =
 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)

src/GHCMod/Options/Commands.hs

@@ -23,8 +23,8 @@ import Options.Applicative.Types
 import Options.Applicative.Builder.Internal
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Read
-import GHCMod.Options.DocUtils
+import Language.Haskell.GhcMod.Options.DocUtils
-import GHCMod.Options.Help
+import Language.Haskell.GhcMod.Options.Help
 
 type Symbol = String
 type Expr = String
@@ -51,7 +51,7 @@ data GhcModCommands =
   | 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 @@ interactiveCommandsSpec =
 strArg :: String -> Parser String
 strArg = argument str . metavar
 
-filesArgsSpec :: ([String] -> b) -> Parser b
+filesArgsSpec :: Parser ([String] -> b) -> Parser b
-filesArgsSpec x = x <$> some (strArg "FILES..")
+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")
@@ -255,23 +255,31 @@ browseArgSpec = CmdBrowse
             $$  long "detailed"
             <=> 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
+debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)
-checkArgSpec = filesArgsSpec CmdCheck
+checkArgSpec = filesArgsSpec (pure CmdCheck)
-expandArgSpec = filesArgsSpec CmdExpand
+expandArgSpec = filesArgsSpec (pure CmdExpand)
 infoArgSpec = CmdInfo
     <$> strArg "FILE"
     <*> strArg "SYMBOL"
-typeArgSpec = locArgSpec CmdType
+typeArgSpec = locArgSpec $ CmdType <$>
-autoArgSpec = locArgSpec CmdAuto
+        switch
-splitArgSpec = locArgSpec CmdSplit
+          $$  long "constraints"
-sigArgSpec = locArgSpec CmdSig
+          <=> short 'c'
-refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"
+          <=> 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 <$>

stack-8.yaml

@@ -0,0 +1,5 @@
+flags: {}
+packages:
+- '.'
+extra-deps: []
+resolver: nightly-2016-06-04

stack.yaml

@@ -1,6 +1,5 @@
 flags: {}
 packages:
 - '.'
-extra-deps:
+extra-deps: []
-- cabal-helper-0.6.2.0
+resolver: lts-5.3
-resolver: lts-3.20

test/CabalHelperSpec.hs

@@ -33,7 +33,11 @@ pkgOptions (x:y:xs) | x == "-package-id" = [name y] ++ pkgOptions xs
                     | otherwise = pkgOptions (y:xs)
  where
    stripDash s = maybe s id $ (flip drop s . (+1) <$> findIndex (=='-') s)
+#if __GLASGOW_HASKELL__ >= 800
+   name s = reverse $ stripDash $ reverse s
+#else
    name s = reverse $ stripDash $ stripDash $ reverse s
+#endif
 
 idirOpts :: [(c, [String])] -> [(c, [String])]
 idirOpts = map (second $ map (drop 2) . filter ("-i"`isPrefixOf`))
@@ -69,7 +73,7 @@ spec = do
         it "extracts build dependencies" $ do
             let tdir = "test/data/cabal-project"
             opts <- map gmcGhcOpts <$> runD' tdir getComponents
-            let ghcOpts = head opts
+            let ghcOpts:_ = opts
                 pkgs = pkgOptions ghcOpts
             pkgs `shouldBe` ["Cabal","base","template-haskell"]
 

test/CaseSplitSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 module CaseSplitSpec where
 
 import Language.Haskell.GhcMod
@@ -12,6 +13,7 @@ main = do
 spec :: Spec
 spec = do
     describe "case split" $ do
+#if __GLASGOW_HASKELL__ >= 708
         it "does not blow up on HsWithBndrs panic" $ do
             withDirectory_ "test/data/case-split" $ do
                 res <- runD $ splits "Vect.hs" 24 10
@@ -39,3 +41,41 @@ spec = do
                 res `shouldBe` "38 21 38 59"++
                         " \"mlReverse' Nil accum = _mlReverse_body\NUL"++
                         "                    mlReverse' (Cons xs'1 xs'2) accum = _mlReverse_body\"\n"
+#else
+        it "does not blow up on HsWithBndrs panic" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect706.hs" 24 10
+                res `shouldBe` "24 1 24 25"++
+                        " \"mlAppend Nil y = undefined\NUL"++
+                           "mlAppend (Cons x1 x2) y = undefined\"\n"
+
+        it "works with case expressions" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect706.hs" 28 20
+                res `shouldBe` "28 19 28 34"++
+                        " \"Nil -> undefined\NUL"++
+                        "                  (Cons x'1 x'2) -> undefined\"\n"
+
+        it "works with where clauses" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect706.hs" 34 17
+                res `shouldBe` "34 5 34 37"++
+                        " \"mlReverse' Nil accum = undefined\NUL"++
+                        "    mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"
+
+        it "works with let bindings" $ do
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Vect706.hs" 38 33
+                res `shouldBe` "38 21 38 53"++
+                        " \"mlReverse' Nil accum = undefined\NUL"++
+                        "                    mlReverse' (Cons xs'1 xs'2) accum = undefined\"\n"
+
+#endif
+        it "doesn't crash when source doesn't make sense" $
+            withDirectory_ "test/data/case-split" $ do
+                res <- runD $ splits "Crash.hs" 4 6
+#if __GLASGOW_HASKELL__ < 710
+                res `shouldBe` "4 1 4 19 \"test x = undefined\"\n"
+#else
+                res `shouldBe` ""
+#endif

test/CheckSpec.hs

@@ -58,7 +58,7 @@ spec = do
         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 @@ spec = do
         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"

test/CradleSpec.hs

@@ -37,14 +37,14 @@ spec = do
         it "returns the current directory" $ do
             withDirectory_ "/" $ do
                 curDir <- stripLastDot <$> canonicalizePath "/"
-                res <- clean_ $ runGmOutDef findCradleNoLog
+                res <- clean_ $ runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions
                 cradleCurrentDir res `shouldBe` curDir
                 cradleRootDir    res `shouldBe` curDir
                 cradleCabalFile  res `shouldBe` Nothing
 
         it "finds a cabal file and a sandbox" $ do
             withDirectory "test/data/cabal-project/subdir1/subdir2" $ \dir -> do
-                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
 
                 cradleCurrentDir res `shouldBe`
                     "test/data/cabal-project/subdir1/subdir2"
@@ -56,7 +56,7 @@ spec = do
 
         it "works even if a sandbox config file is broken" $ do
             withDirectory "test/data/broken-sandbox" $ \dir -> do
-                res <- relativeCradle dir <$> clean_ (runGmOutDef findCradleNoLog)
+                res <- relativeCradle dir <$> clean_ (runGmOutDef $ findCradleNoLog $ optPrograms defaultOptions)
                 cradleCurrentDir res `shouldBe`
                     "test" </> "data" </> "broken-sandbox"
 

test/FileMappingSpec.hs

@@ -123,24 +123,30 @@ spec = do
             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 @@ spec = do
             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 @@ spec = do
                        ,("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 @@ spec = do
                      ,("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]\""]

test/FindSpec.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
 module FindSpec where
 
 import Language.Haskell.GhcMod.Find

test/FlagSpec.hs

@@ -9,6 +9,6 @@ import Prelude
 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"]

test/InfoSpec.hs

@@ -19,17 +19,31 @@ spec = do
     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

test/LintSpec.hs

@@ -9,7 +9,7 @@ spec = do
     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

test/MonadSpec.hs

@@ -23,6 +23,8 @@ spec = do
 
           mv_ex :: MVar (Either SomeException ())
               <- newEmptyMVar
+          mv_startup_barrier :: MVar ()
+              <- newEmptyMVar
           mv_startup_barrier :: MVar () <- newEmptyMVar
 
           _t1 <- forkOS $ do
@@ -37,6 +39,19 @@ spec = do
                  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'
+
           ex <- takeMVar mv_ex
 
           isLeft ex `shouldBe` True

test/PathsAndFilesSpec.hs

@@ -16,12 +16,12 @@ spec = do
     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

test/TestUtils.hs

@@ -6,6 +6,7 @@ module TestUtils (
   , runE
   , runNullLog
   , runGmOutDef
+  , runLogDef
   , shouldReturnError
   , isPkgDbAt
   , isPkgConfDAt
@@ -43,10 +44,6 @@ extract action = do
     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,6 +56,13 @@ runGhcModTSpec' dir opt action = liftIO (canonicalizePath dir) >>= \dir' -> do
     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
@@ -88,6 +92,9 @@ runNullLog action = do
 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)
                   -> Expectation

test/data/case-split/Crash.hs

@@ -0,0 +1,4 @@
+module Crash where
+
+test :: Maybe a
+test x = undefined

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

test/data/pattern-synonyms/A.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PatternSynonyms #-}
+
 module A where
 
 data SomeType a b = SomeType (a,b)

test/data/pattern-synonyms/pattern-synonyms.cabal

@@ -23,3 +23,5 @@ library
   -- hs-source-dirs:
   default-language:    Haskell2010
   ghc-options:         -Wall
+  if impl(ghc >= 8.0.1)
+    ghc-options: -Wno-missing-pattern-synonym-signatures

test/data/stack-project/new-template.cabal

@@ -16,7 +16,7 @@ cabal-version:       >=1.10
 library
   hs-source-dirs:      src
   exposed-modules:     Lib
-  build-depends:       base >= 4.7 && < 5
+  build-depends:       base
   default-language:    Haskell2010
 
 executable new-template-exe