ghc-mod 5.5.0.0 → 5.6.0.0

raw patch · 57 files changed

+1383/−645 lines, 57 filesdep +ghc-bootdep +template-haskelldep −executable-pathdep −ghc-primdep −randomdep ~binarydep ~cabal-helperdep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-boot, template-haskell

Dependencies removed: executable-path, ghc-prim, random

Dependency ranges changed: binary, cabal-helper, directory, ghc, hlint, process, time, transformers

API changes (from Hackage documentation)

Files

• ChangeLog +53/−43
• Data/Binary/Generic.hs +1/−2
• Language/Haskell/GhcMod/Boot.hs +2/−1
• Language/Haskell/GhcMod/Browse.hs +18/−4
• Language/Haskell/GhcMod/CaseSplit.hs +22/−12
• Language/Haskell/GhcMod/Check.hs +1/−1
• Language/Haskell/GhcMod/Cradle.hs +64/−28
• Language/Haskell/GhcMod/Debug.hs +37/−8
• Language/Haskell/GhcMod/DebugLogger.hs +9/−9
• Language/Haskell/GhcMod/Doc.hs +0/−5
• Language/Haskell/GhcMod/DynFlags.hs +11/−11
• Language/Haskell/GhcMod/DynFlagsTH.hs +126/−0
• Language/Haskell/GhcMod/FileMapping.hs +9/−8
• Language/Haskell/GhcMod/FillSig.hs +41/−5
• Language/Haskell/GhcMod/Find.hs +94/−40
• Language/Haskell/GhcMod/Flag.hs +2/−6
• Language/Haskell/GhcMod/Gap.hs +118/−28
• Language/Haskell/GhcMod/HomeModuleGraph.hs +1/−0
• Language/Haskell/GhcMod/Info.hs +10/−16
• Language/Haskell/GhcMod/LightGhc.hs +4/−0
• Language/Haskell/GhcMod/Lint.hs +15/−10
• Language/Haskell/GhcMod/Logger.hs +53/−38
• Language/Haskell/GhcMod/Monad.hs +11/−5
• Language/Haskell/GhcMod/Monad/Newtypes.hs +1/−1
• Language/Haskell/GhcMod/Options/DocUtils.hs +48/−0
• Language/Haskell/GhcMod/Options/Help.hs +79/−0
• Language/Haskell/GhcMod/Options/Options.hs +173/−0
• Language/Haskell/GhcMod/PathsAndFiles.hs +1/−1
• Language/Haskell/GhcMod/Pretty.hs +2/−1
• Language/Haskell/GhcMod/SrcUtils.hs +106/−3
• Language/Haskell/GhcMod/Stack.hs +2/−2
• Language/Haskell/GhcMod/Target.hs +37/−15
• Language/Haskell/GhcMod/Types.hs +10/−6
• Language/Haskell/GhcMod/World.hs +3/−3
• NotCPP/Declarations.hs +27/−3
• NotCPP/LookupValueName.hs +7/−1
• NotCPP/Utils.hs +6/−0
• elisp/ghc.el +1/−1
• ghc-mod.cabal +32/−25
• src/GHCMod.hs +8/−7
• src/GHCMod/Options.hs +2/−131
• src/GHCMod/Options/Commands.hs +23/−15
• src/GHCMod/Options/DocUtils.hs +0/−48
• src/GHCMod/Options/Help.hs +0/−79
• test/CheckSpec.hs +4/−2
• test/FileMappingSpec.hs +14/−8
• test/FlagSpec.hs +2/−2
• test/InfoSpec.hs +17/−3
• test/LintSpec.hs +1/−1
• test/MonadSpec.hs +15/−0
• test/PathsAndFilesSpec.hs +2/−2
• test/TestUtils.hs +11/−4
• test/data/case-split/Crash.hs +4/−0
• test/data/case-split/Vect706.hs +39/−0
• test/data/pattern-synonyms/A.hs +1/−0
• test/data/pattern-synonyms/pattern-synonyms.cabal +2/−0
• test/data/stack-project/new-template.cabal +1/−1

@@ -1,3 +1,13 @@+2016-07-29 v5.6.0.0+	* Bump cabal-helper to 0.7, adds support for Cabal-1.24+	* Merge #737, `map-file` caching issues+	* Merge #767, Add `browse` option to show symbol "parents"+	* Merge #731, Type constraints+	* Fix #69 (via #731), Missing type constraints+	* Fix #438, Case splitting not working+	* Fix #790, Don't try to use 'cabal' or 'stack' when it's not installed+	* Add support for GHC 8.0+ 2016-01-19 v5.5.0.0 	* Fix #660, cabal-helper errors when no global GHC is installed (Stack) 	* Fix #665, Reinstate internally managed CWD (no more `ghc-mod root`@@ -29,9 +39,9 @@ 	  super slowness) 	* Expose all internal modules because API will get a major 	  redesign soon anyways-        * ghc-mod(i) executable must now be run in project directory for-          commands other than `root`-        * Add --line-prefix option for multiplexing stdout/err onto one stream+	* ghc-mod(i) executable must now be run in project directory for+	  commands other than `root`+	* Add --line-prefix option for multiplexing stdout/err onto one stream  2015-08-14 v5.3.0.0 	* Re-license majority of code under the AGPL-3@@ -39,72 +49,72 @@ 	* Remove `cabalDependPackages', `cabalAllTargets' 	* Merge #434, Fix finding sandbox config file and directory. 	* Merge #431, Re-add output line separator global option for expand-          command.+	  command. 	* Merge #470, Support for overriding the package-db stack 	* Merge #486, Fix ineffective cache invalidation for `find`  2014-12-31 v5.2.1.2 	* Merge #377, Fix `browse` erroneously thinking haskell2010 identifiers 	  are operators-        * Fix incompatibility with monad-control >= 1.0.0-        * Fix temporary directories not being removed properly-        * Merge #405, #408, a race condition in the Emacs frontend-        * Merge #403, Support unicode quotes in module regexp+	* Fix incompatibility with monad-control >= 1.0.0+	* Fix temporary directories not being removed properly+	* Merge #405, #408, a race condition in the Emacs frontend+	* Merge #403, Support unicode quotes in module regexp  2014-11-03 v5.2.1.1-        * Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.-        * Support `where` clauses, `let` bindings and `case` expressions-          in case splitting, #400+	* Fix `findCabalFiles` thinking `$HOME/.cabal` is a cabal file.+	* Support `where` clauses, `let` bindings and `case` expressions+	  in case splitting, #400  2014-11-02 v5.2.1.0-        * Fix `newTempDir` on Windows-        * GhcModT's liftIO instance now converts GhcMOdError exceptions-          into monadic failures+	* Fix `newTempDir` on Windows+	* GhcModT's liftIO instance now converts GhcMOdError exceptions+	  into monadic failures  2014-10-30 v5.2.0.0-        * Return type of `loadSymbolDb` is now in GhcModT-        * Function `dumpSymbol` now takes the path of the target directory-        * Fix #387, Pattern match failure in GhcPkg-        * Fix #386, `ghc-mod version` should not check `cabal configure`-        * Fix #391, Error on command `-g` when used before command despite-          --help output saying this is valid-        * Fix formatting of `ghc-version` constant in the elisp code.  in-          version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".+	* Return type of `loadSymbolDb` is now in GhcModT+	* Function `dumpSymbol` now takes the path of the target directory+	* Fix #387, Pattern match failure in GhcPkg+	* Fix #386, `ghc-mod version` should not check `cabal configure`+	* Fix #391, Error on command `-g` when used before command despite+	  --help output saying this is valid+	* Fix formatting of `ghc-version` constant in the elisp code.  in+	  version 5.1.1.0 the string was "v5.1.1.0" instead of "5.1.1.0".  2014-10-04 v5.1.1.0-        * Handle various consistency related issues: #222, #224, #326, #332-        * Add `isOutdated` to Language.Haskell.GhcMod+	* Handle various consistency related issues: #222, #224, #326, #332+	* Add `isOutdated` to Language.Haskell.GhcMod  2014-09-17 v5.1.0.2-        * Fix building with haskell-src-exts < 1.16.0+	* Fix building with haskell-src-exts < 1.16.0  2014-09-16 v5.1.0.1-        * Fix building with haskell-src-exts-1.16.0-        * Loosen monad-journal dependency+	* Fix building with haskell-src-exts-1.16.0+	* Loosen monad-journal dependency  2014-09-12 v5.1.0.0-        * GhcModError is now a recursive data type (`GMECabalConfigure`'s-          type changed)-        * GhcModT's MonadIO instance now converts IOError's to failures in-          the ErrorT part of GhcModT on `liftIO`.-        * Make `loadSymbolDb` polimorphic in the return types's monad.-        * Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal-        * Fix `check` command for modules using `-XPatternSynonyms`-        * Merge #364, Support cabal configuration flags+	* GhcModError is now a recursive data type (`GMECabalConfigure`'s+	  type changed)+	* GhcModT's MonadIO instance now converts IOError's to failures in+	  the ErrorT part of GhcModT on `liftIO`.+	* Make `loadSymbolDb` polimorphic in the return types's monad.+	* Add `hoistGhcModT` to Language.Haskell.GhcMod.Internal+	* Fix `check` command for modules using `-XPatternSynonyms`+	* Merge #364, Support cabal configuration flags  2014-08-29 v5.0.1.2-        * Merge #345, Try fixing duplicate errors-        * Merge #344, elisp: Use advice to check syntax on save-buffer-        * Merge #341, support `browse -d` in ghc-modi-        * Merge #352, elisp: Fix C-u accidentally getting turned into a-          prefix command+	* Merge #345, Try fixing duplicate errors+	* Merge #344, elisp: Use advice to check syntax on save-buffer+	* Merge #341, support `browse -d` in ghc-modi+	* Merge #352, elisp: Fix C-u accidentally getting turned into a+	  prefix command  2014-08-24 v5.0.1.1-        * Fix CaseSplitting faliure when using "fancy types" (see #336)-        * Print error information in "spec" test suite when using `extract`+	* Fix CaseSplitting faliure when using "fancy types" (see #336)+	* Print error information in "spec" test suite when using `extract`  2014-08-20 v5.0.1-        * Fix missing file in "Data-Files"+	* Fix missing file in "Data-Files"  2014-08-20 v5.0.0 	* ghc-mod consumes much less memory than ghc-mod-4.1.

@@ -66,7 +66,6 @@ #define GETSUM(WORD) GUARD(WORD) = (get :: Get WORD) >>= checkGetSum (fromIntegral size)  instance ( GSum     a, GSum     b-         , GGBinary a, GGBinary b          , SumSize    a, SumSize    b) => GGBinary (a :+: b) where     ggput | PUTSUM(Word8) | PUTSUM(Word16) | PUTSUM(Word32) | PUTSUM(Word64)          | otherwise = sizeError "encode" size@@ -96,7 +95,7 @@     getSum :: (Ord word, Num word, Bits word) => word -> word -> Get (f a)     putSum :: (Num w, Bits w, Binary w) => w -> w -> f a -> Put -instance (GSum a, GSum b, GGBinary a, GGBinary b) => GSum (a :+: b) where+instance (GSum a, GSum b) => GSum (a :+: b) where     getSum !code !size | code < sizeL = L1 <$> getSum code           sizeL                        | otherwise    = R1 <$> getSum (code - sizeL) sizeR         where

@@ -7,12 +7,13 @@ import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Modules+import Language.Haskell.GhcMod.Types (defaultBrowseOpts)  -- | Printing necessary information for front-end booting. boot :: IOish m => GhcModT m String boot = concat <$> sequence ms   where-    ms = [modules False, languages, flags, concat <$> mapM (browse (BrowseOpts False False False)) preBrowsedModules]+    ms = [modules False, languages, flags, concat <$> mapM (browse defaultBrowseOpts) preBrowsedModules]  preBrowsedModules :: [String] preBrowsedModules = [

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.Browse (     browse,     BrowseOpts(..)@@ -11,6 +12,7 @@ import Data.Maybe import FastString import GHC+import HscTypes import qualified GHC as G import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)@@ -24,6 +26,9 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) import Exception (ExceptionMonad, ghandle) import Prelude+#if __GLASGOW_HASKELL__ >= 800+import PatSyn (pprPatSynType)+#endif  ---------------------------------------------------------------- @@ -96,14 +101,20 @@     mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` optBrowseQualified opt     mtype :: m (Maybe String)     mtype-      | optBrowseDetailed opt = do+      | optBrowseDetailed opt || optBrowseParents opt = do         tyInfo <- G.modInfoLookupName minfo e         -- If nothing found, load dependent module and lookup global         tyResult <- maybe (inOtherModule e) (return . Just) tyInfo         dflag <- G.getSessionDynFlags-        return $ do-          typeName <- tyResult >>= showThing dflag-          (" :: " ++ typeName) `justIf` optBrowseDetailed opt+        let sig = do+                    typeName <- tyResult >>= showThing dflag+                    (" :: " ++ typeName) `justIf` optBrowseDetailed opt+        let parent = do+                    thing <- fmap getOccString $ tyResult >>= tyThingParent_maybe+                    (" -- from:" ++ thing) `justIf` optBrowseParents opt+        return $ case concat $ catMaybes [sig, parent] of+                    [] -> Nothing+                    x  -> Just x       | otherwise = return Nothing     formatOp nm       | null nm    = error "formatOp"@@ -124,6 +135,9 @@ showThing' _     (GtT t) = unwords . toList <$> tyType t   where     toList t' = t' : getOccString t : map getOccString (G.tyConTyVars t)+#if __GLASGOW_HASKELL__ >= 800+showThing' dflag (GtPatSyn p) = Just $ showSDoc dflag $ pprPatSynType p+#endif showThing' _     _       = Nothing  formatType :: DynFlags -> Type -> String

@@ -27,7 +27,9 @@ import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping)+import Control.DeepSeq  ---------------------------------------------------------------- -- CASE SPLITTING@@ -54,17 +56,17 @@       style <- getStyle       dflag <- G.getSessionDynFlags       modSum <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)-      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> case x of-        (SplitInfo varName bndLoc (varLoc,varT) _matches) -> do-          let varName' = showName dflag style varName  -- Convert name to string-          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $-                                             getTyCons dflag style varName varT)-          return (fourInts bndLoc, t)-        (TySplitInfo varName bndLoc (varLoc,varT)) -> do-          let varName' = showName dflag style varName  -- Convert name to string-          t <- genCaseSplitTextFile file (SplitToTextInfo varName' bndLoc varLoc $+      whenFound' oopts (getSrcSpanTypeForSplit modSum lineNo colNo) $ \x -> do+          let (varName, bndLoc, (varLoc,varT))+                | (SplitInfo vn bl vlvt _matches) <- x+                = (vn, bl, vlvt)+                | (TySplitInfo vn bl vlvt) <- x+                = (vn, bl, vlvt)+              varName' = showName dflag style varName  -- Convert name to string+          t <- withMappedFile file $ \file' ->+                genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $                                              getTyCons dflag style varName varT)-          return (fourInts bndLoc, t)+          return $!! (fourInts bndLoc, t)  where    handler (SomeException ex) = do      gmLog GmException "splits" $@@ -107,7 +109,11 @@ isPatternVar _                  = False  getPatternVarName :: LPat Id -> G.Name+#if __GLASGOW_HASKELL__ >= 800+getPatternVarName (L _ (G.VarPat (L _ vName))) = G.getName vName+#else getPatternVarName (L _ (G.VarPat vName)) = G.getName vName+#endif getPatternVarName _                      = error "This should never happened"  -- TODO: Information for a type family case split@@ -167,7 +173,11 @@ -- 3. Records getDataCon dflag style vName dcon =   let dName = showName dflag style $ Ty.dataConName dcon+#if __GLASGOW_HASKELL__ >= 800+      flds  = map Ty.flSelector $ Ty.dataConFieldLabels dcon+#else       flds  = Ty.dataConFieldLabels dcon+#endif   in dName ++ " { " ++ showFieldNames dflag style vName flds ++ " }"  -- Create a new variable by adjoining a number@@ -204,8 +214,8 @@   return $ getCaseSplitText (T.lines t) info  getCaseSplitText :: [T.Text] -> SplitToTextInfo -> String-getCaseSplitText t (SplitToTextInfo { sVarName = sVN, sBindingSpan = sBS-                                       , sVarSpan = sVS, sTycons = sT })  =+getCaseSplitText t SplitToTextInfo{ sVarName = sVN, sBindingSpan = sBS+                                       , sVarSpan = sVS, sTycons = sT }  =   let bindingText = getBindingText t sBS       difference  = srcSpanDifference sBS sVS       replaced    = map (replaceVarWithTyCon bindingText difference sVN) sT

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

@@ -25,6 +25,7 @@ import Data.Maybe import System.Directory import System.FilePath+import System.Environment import Prelude import Control.Monad.Trans.Journal (runJournalT) @@ -34,24 +35,29 @@ --   Find a cabal file by tracing ancestor directories. --   Find a sandbox according to a cabal sandbox config --   in a cabal directory.-findCradle :: (GmLog m, IOish m, GmOut m) => m Cradle-findCradle = findCradle' =<< liftIO getCurrentDirectory+findCradle :: (GmLog m, IOish m, GmOut m) => Programs -> m Cradle+findCradle progs = findCradle' progs =<< liftIO getCurrentDirectory -findCradleNoLog  :: forall m. (IOish m, GmOut m) => m Cradle-findCradleNoLog = fst <$> (runJournalT findCradle :: m (Cradle, GhcModLog))+findCradleNoLog  :: forall m. (IOish m, GmOut m) => Programs -> m Cradle+findCradleNoLog progs =+    fst <$> (runJournalT (findCradle progs) :: m (Cradle, GhcModLog)) -findCradle' :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle-findCradle' dir = run $-    msum [ stackCradle dir-         , cabalCradle dir+findCradle' :: (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle+findCradle' Programs { stackProgram, cabalProgram } dir = run $+    msum [ stackCradle stackProgram dir+         , cabalCradle cabalProgram dir          , sandboxCradle dir          , plainCradle dir          ]  where run a = fillTempDir =<< (fromJustNote "findCradle'" <$> runMaybeT a) -findSpecCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> m Cradle-findSpecCradle dir = do-    let cfs = [stackCradleSpec, cabalCradle, sandboxCradle]+findSpecCradle ::+    (GmLog m, IOish m, GmOut m) => Programs -> FilePath -> m Cradle+findSpecCradle Programs { stackProgram, cabalProgram } dir = do+    let cfs = [ stackCradleSpec stackProgram+              , cabalCradle cabalProgram+              , sandboxCradle+              ]     cs <- catMaybes <$> mapM (runMaybeT . ($ dir)) cfs     gcs <- filterM isNotGmCradle cs     fillTempDir =<< case gcs of@@ -69,12 +75,20 @@   tmpDir <- liftIO $ newTempDir (cradleRootDir crdl)   return crdl { cradleTempDir = tmpDir } -cabalCradle :: IOish m => FilePath -> MaybeT m Cradle-cabalCradle wdir = do+cabalCradle ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+cabalCradle cabalProg wdir = do     cabalFile <- MaybeT $ liftIO $ findCabalFile wdir-     let cabalDir = takeDirectory cabalFile +    gmLog GmInfo "" $ text "Found Cabal project at" <+>: text cabalDir++    -- If cabal doesn't exist the user probably wants to use something else+    whenM ((==Nothing) <$> liftIO (findExecutable cabalProg)) $ do+      gmLog GmInfo "" $ text "'cabal' executable wasn't found, trying next project type"+      mzero++    gmLog GmInfo "" $ text "Using Cabal project at" <+>: text cabalDir     return Cradle {         cradleProject    = CabalProject       , cradleCurrentDir = wdir@@ -84,26 +98,45 @@       , cradleDistDir    = "dist"       } -stackCradle :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle-stackCradle wdir = do+stackCradle ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+stackCradle stackProg wdir = do #if !MIN_VERSION_ghc(7,8,0)     -- GHC < 7.8 is not supported by stack     mzero #endif-    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir +    cabalFile <- MaybeT $ liftIO $ findCabalFile wdir     let cabalDir = takeDirectory cabalFile-     _stackConfigFile <- MaybeT $ liftIO $ findStackConfigFile cabalDir -    -- If dist/setup-config already exists the user probably wants to use cabal-    -- rather than stack, or maybe that's just me ;)-    whenM (liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist") $ do-      gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack and using cabal-install instead."-      mzero+    gmLog GmInfo "" $ text "Found Stack project at" <+>: text cabalDir +    stackExeSet    <- liftIO $ isJust <$> lookupEnv "STACK_EXE"+    stackExeExists <- liftIO $ isJust <$> findExecutable stackProg+    setupCfgExists <- liftIO $ doesFileExist $ cabalDir </> setupConfigPath "dist"++    case (stackExeExists, stackExeSet) of+      (False, True) -> do+        gmLog GmWarning "" $ text "'stack' executable wasn't found but STACK_EXE is set, trying next project type"+        mzero++      (False, False) -> do+        gmLog GmInfo "" $ text "'stack' executable wasn't found, trying next project type"+        mzero++      (True, True) -> do+        gmLog GmWarning "" $ text "STACK_EXE set, preferring Stack project"++      (True, False) | setupCfgExists -> do+        gmLog GmWarning "" $ text "'dist/setup-config' exists, ignoring Stack project"+        mzero++      (True, False) -> return ()+     senv <- MaybeT $ getStackEnv cabalDir +    gmLog GmInfo "" $ text "Using Stack project at" <+>: text cabalDir     return Cradle {         cradleProject    = StackProject senv       , cradleCurrentDir = wdir@@ -113,9 +146,10 @@       , cradleDistDir    = seDistDir senv       } -stackCradleSpec :: (GmLog m, IOish m, GmOut m) => FilePath -> MaybeT m Cradle-stackCradleSpec wdir = do-  crdl <- stackCradle wdir+stackCradleSpec ::+    (IOish m, GmLog m, GmOut m) => FilePath -> FilePath -> MaybeT m Cradle+stackCradleSpec stackProg wdir = do+  crdl <- stackCradle stackProg wdir   case crdl of     Cradle { cradleProject = StackProject StackEnv { seDistDir } } -> do       b <- isGmDistDir seDistDir@@ -126,9 +160,10 @@    isGmDistDir dir =        liftIO $ not <$> doesFileExist (dir </> ".." </> "ghc-mod.cabal") -sandboxCradle :: IOish m => FilePath -> MaybeT m Cradle+sandboxCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle sandboxCradle wdir = do     sbDir <- MaybeT $ liftIO $ findCabalSandboxDir wdir+    gmLog GmInfo "" $ text "Using sandbox project at" <+>: text sbDir     return Cradle {         cradleProject    = SandboxProject       , cradleCurrentDir = wdir@@ -138,8 +173,9 @@       , cradleDistDir    = "dist"       } -plainCradle :: IOish m => FilePath -> MaybeT m Cradle+plainCradle :: (IOish m, GmLog m, GmOut m) => FilePath -> MaybeT m Cradle plainCradle wdir = do+    gmLog GmInfo "" $ text "Found no other project type, falling back to plain GHC project"     return $ Cradle {         cradleProject    = PlainProject       , cradleCurrentDir = wdir

@@ -3,11 +3,12 @@ import Control.Arrow (first) import Control.Applicative import Control.Monad-import Control.Monad.Trans.Journal import qualified Data.Map as Map import qualified Data.Set as Set import Data.Char+import Data.Version import Data.List.Split+import System.Directory import Text.PrettyPrint import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types@@ -17,7 +18,12 @@ import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Stack+import Language.Haskell.GhcMod.Output +import Paths_ghc_mod (version)++import Config (cProjectVersion)+ ----------------------------------------------------------------  -- | Obtaining debug information.@@ -34,14 +40,20 @@      pkgOpts <- packageGhcOptions +    readProc <- gmReadProcess++    ghcVersion <- liftIO $+        dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] ""+     return $ unlines $-      [ "Root directory:       " ++ cradleRootDir+      [ "Version:              ghc-mod-" ++ showVersion version+      , "Library GHC Version:  " ++ cProjectVersion+      , "System GHC Version:   " ++ ghcVersion+      , "Root directory:       " ++ cradleRootDir       , "Current directory:    " ++ cradleCurrentDir       , "GHC Package flags:\n"   ++ render (nest 4 $               fsep $ map text pkgOpts)       , "GHC System libraries: " ++ ghcLibDir-      , "GHC user options:\n"    ++ render (nest 4 $-              fsep $ map text optGhcUserOptions)       ] ++ cabal  stackPaths :: IOish m => GhcModT m [String]@@ -63,9 +75,24 @@         opts        = Map.map gmcGhcOpts mcs         srcOpts     = Map.map gmcGhcSrcOpts mcs +    readProc <- gmReadProcess+    cabalExists <- liftIO $ (/=Nothing) <$> findExecutable "cabal"++    cabalInstVersion <-+        if cabalExists+          then liftIO $+            dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] ""+          else return ""++    packages <- liftIO $ readProc "ghc-pkg" ["list", "--simple-output"] ""+    let cabalPackages = filter ((== ["Cabal"]) . take 1 . splitOn "-") $ splitWhen isSpace packages+     return $-         [ "Cabal file:           " ++ show cradleCabalFile-         , "Project:   " ++ show cradleProject+         [ "cabal-install Version: "    ++ cabalInstVersion+         , "Cabal Library Versions:\n"  ++ render (nest 4 $+              fsep $ map text cabalPackages)+         , "Cabal file:            "    ++ show cradleCabalFile+         , "Project:               " ++ show cradleProject          , "Cabal entrypoints:\n"       ++ render (nest 4 $               mapDoc gmComponentNameDoc smpDoc entrypoints)          , "Cabal components:\n"        ++ render (nest 4 $@@ -139,5 +166,7 @@ ----------------------------------------------------------------  -- | Obtaining root information.-rootInfo :: forall m. (IOish m, GmOut m) => m String-rootInfo = (++"\n") . cradleRootDir <$> fst `liftM` (runJournalT findCradle :: m (Cradle, GhcModLog))+rootInfo :: forall m. (IOish m, GmOut m, GmEnv m) => m String+rootInfo = do+    crdl <- findCradleNoLog =<< (optPrograms <$> options)+    return $ cradleRootDir crdl ++ "\n"

@@ -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 Prelude  debugLogAction :: (String -> IO ()) -> GmLogAction-debugLogAction putErr dflags severity srcSpan style msg+debugLogAction putErr _reason dflags severity srcSpan style' msg     = case severity of-      SevOutput      -> printSDoc putErr msg style+      SevOutput      -> printSDoc putErr msg style'  #if __GLASGOW_HASKELL__ >= 706-      SevDump        -> printSDoc putErr (msg Outputable.$$ blankLine) style+      SevDump        -> printSDoc putErr (msg Outputable.$$ blankLine) style' #endif  #if __GLASGOW_HASKELL__ >= 708       SevInteractive -> let           putStrSDoc = debugLogActionHPutStrDoc dflags putErr        in-          putStrSDoc msg style+          putStrSDoc msg style' #endif-      SevInfo        -> printErrs putErr msg style-      SevFatal       -> printErrs putErr msg style+      SevInfo        -> printErrs putErr msg style'+      SevFatal       -> printErrs putErr msg style'       _              -> do putErr "\n" #if __GLASGOW_HASKELL__ >= 706-                           printErrs putErr (mkLocMessage severity srcSpan msg) style+                           printErrs putErr (mkLocMessage severity srcSpan msg) style' #else-                           printErrs putErr (mkLocMessage srcSpan msg) style+                           printErrs putErr (mkLocMessage srcSpan msg) style' #endif                            -- careful (#2302): printErrs prints in UTF-8,                            -- whereas converting to string first and using

@@ -11,11 +11,6 @@ showOneLine :: DynFlags -> PprStyle -> SDoc -> String showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style --- showForUser :: DynFlags -> PrintUnqualified -> SDoc -> String--- showForUser dflags unqual sdoc =---     showDocWith dflags PageMode $---       runSDoc sdoc $ initSDocContext dflags $ mkUserStyle unqual AllTheWay- getStyle :: GhcMonad m => m PprStyle getStyle = do     unqual <- getPrintUnqual

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE TemplateHaskell #-}  module Language.Haskell.GhcMod.DynFlags where @@ -10,12 +10,13 @@ import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.DebugLogger+import Language.Haskell.GhcMod.DynFlagsTH import System.IO.Unsafe (unsafePerformIO) import Prelude  setEmptyLogger :: DynFlags -> DynFlags setEmptyLogger df =-    Gap.setLogAction df $ \_ _ _ _ _ -> return ()+    Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()  setDebugLogger :: (String -> IO ()) -> DynFlags -> DynFlags setDebugLogger put df = do@@ -94,15 +95,14 @@  ---------------------------------------------------------------- --- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".-setNoMaxRelevantBindings :: DynFlags -> DynFlags-#if __GLASGOW_HASKELL__ >= 708-setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }-#else-setNoMaxRelevantBindings = id-#endif--deferErrors :: DynFlags -> Ghc DynFlags+deferErrors :: Monad m => DynFlags -> m DynFlags deferErrors df = return $   Gap.setWarnTypedHoles $ Gap.setDeferTypedHoles $   Gap.setDeferTypeErrors $ setNoWarningFlags df++----------------------------------------------------------------++deriveEqDynFlags [d|+  eqDynFlags :: DynFlags -> DynFlags -> Bool+  eqDynFlags = undefined+ |]

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

@@ -46,8 +46,10 @@                      -> GhcModT m () loadMappedFileSource from src = do   tmpdir <- cradleTempDir `fmap` cradle+  enc <- liftIO . mkTextEncoding . optEncoding =<< options   to <- liftIO $ do     (fn, h) <- openTempFile tmpdir (takeFileName from)+    hSetEncoding h enc     hPutStr h src     hClose h     return fn@@ -61,23 +63,22 @@   let to' = makeRelative (cradleRootDir crdl) to   addMMappedFile cfn (FileMapping to' isTemp) -mapFile :: (IOish m, GmState m, GhcMonad m, GmEnv m) =>-            HscEnv -> Target -> m Target+mapFile :: (IOish m, GmState m) => HscEnv -> Target -> m Target mapFile _ (Target tid@(TargetFile filePath _) taoc _) = do   mapping <- lookupMMappedFile filePath-  mkMappedTarget (Just filePath) tid taoc mapping+  return $ mkMappedTarget (Just filePath) tid taoc mapping mapFile env (Target tid@(TargetModule moduleName) taoc _) = do   (fp, mapping) <- do     filePath <- fmap (fmap mpPath) (liftIO $ findModulePath env moduleName)     mmf <- runMaybeT $ MaybeT (return filePath) >>= MaybeT . lookupMMappedFile     return (filePath, mmf)-  mkMappedTarget fp tid taoc mapping+  return $ mkMappedTarget fp tid taoc mapping -mkMappedTarget :: (IOish m, GmState m, GmEnv m, GhcMonad m) =>-                  Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> m Target+mkMappedTarget :: Maybe FilePath -> TargetId -> Bool -> Maybe FileMapping -> Target mkMappedTarget _ _ taoc (Just to) =-  return $ mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing-mkMappedTarget _ tid taoc _ = return $ mkTarget tid taoc Nothing+  mkTarget (TargetFile (fmPath to) Nothing) taoc Nothing+mkMappedTarget _ tid taoc _ =+  mkTarget tid taoc Nothing  {-| unloads previously mapped file \'file\', so that it's no longer mapped,

@@ -116,7 +116,9 @@     p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum     -- Inspect the parse tree to find the signature     case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 800+      [L loc (G.SigD (Ty.TypeSig names (G.HsIB _ (G.HsWC _ _ (L _ ty)))))] ->+#elif __GLASGOW_HASKELL__ >= 710       [L loc (G.SigD (Ty.TypeSig names (L _ ty) _))] -> #else       [L loc (G.SigD (Ty.TypeSig names (L _ ty)))] ->@@ -131,7 +133,9 @@         case Gap.getClass lst of             Just (clsName,loc) -> obtainClassInfo minfo clsName loc             _                  -> return Nothing-#if __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 800+      [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _)))] -> do+#elif __GLASGOW_HASKELL__ >= 708       [L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars) _)))] -> do #elif __GLASGOW_HASKELL__ >= 706       [L loc (G.TyClD (G.TyFamily info (L _ name) (G.HsQTvs _ vars) _))] -> do@@ -149,8 +153,12 @@                         G.DataFamily -> Data #endif -#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 800             getTyFamVarName x = case x of+                L _ (G.UserTyVar (G.L _ n))     -> n+                L _ (G.KindedTyVar (G.L _ n) _) -> n+#elif __GLASGOW_HASKELL__ >= 710+            getTyFamVarName x = case x of                 L _ (G.UserTyVar n)     -> n                 L _ (G.KindedTyVar (G.L _ n) _) -> n #elif __GLASGOW_HASKELL__ >= 706@@ -269,7 +277,9 @@  instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where   getFnName dflag style name = showOccName dflag style $ Gap.occName name-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 800+  getFnArgs (G.HsForAllTy _ (L _ iTy))+#elif __GLASGOW_HASKELL__ >= 710   getFnArgs (G.HsForAllTy _ _ _ _ (L _ iTy)) #else   getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))@@ -280,7 +290,9 @@   getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) =       (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy     where fnarg ty = case ty of-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 800+              (G.HsForAllTy _ (L _ iTy)) ->+#elif __GLASGOW_HASKELL__ >= 710               (G.HsForAllTy _ _ _ _ (L _ iTy)) -> #else               (G.HsForAllTy _ _ _ (L _ iTy)) ->@@ -381,7 +393,11 @@   -> m (Maybe (SrcSpan, String, Type, Bool)) findVar dflag style tcm tcs lineNo colNo =   case lst of+#if __GLASGOW_HASKELL__ >= 800+    e@(L _ (G.HsVar (L _ i))):others -> do+#else     e@(L _ (G.HsVar i)):others -> do+#endif       tyInfo <- Gap.getType tcm e       case tyInfo of         Just (s, typ)@@ -409,7 +425,11 @@ doParen True  s = if ' ' `elem` s then '(':s ++ ")" else s  isSearchedVar :: Id -> G.HsExpr Id -> Bool+#if __GLASGOW_HASKELL__ >= 800+isSearchedVar i (G.HsVar (L _ i2)) = i == i2+#else isSearchedVar i (G.HsVar i2) = i == i2+#endif isSearchedVar _ _ = False  @@ -512,7 +532,11 @@         _ -> (error "This should never happen", [])  getBindingsForPat :: Ty.Pat Id -> M.Map G.Name Type+#if __GLASGOW_HASKELL__ >= 800+getBindingsForPat (Ty.VarPat (L _ i)) = M.singleton (G.getName i) (Ty.varType i)+#else getBindingsForPat (Ty.VarPat i) = M.singleton (G.getName i) (Ty.varType i)+#endif getBindingsForPat (Ty.LazyPat (L _ l)) = getBindingsForPat l getBindingsForPat (Ty.BangPat (L _ b)) = getBindingsForPat b getBindingsForPat (Ty.AsPat (L _ a) (L _ i)) =@@ -537,11 +561,23 @@ getBindingsForPat _ = M.empty  getBindingsForRecPat :: Ty.HsConPatDetails Id -> M.Map G.Name Type+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.PrefixCon args) =+#else getBindingsForRecPat (Ty.PrefixCon args) =+#endif     M.unions $ map (\(L _ i) -> getBindingsForPat i) args+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.InfixCon (L _ a1) (L _ a2)) =+#else getBindingsForRecPat (Ty.InfixCon (L _ a1) (L _ a2)) =+#endif     M.union (getBindingsForPat a1) (getBindingsForPat a2)+#if __GLASGOW_HASKELL__ >= 800+getBindingsForRecPat (G.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =+#else getBindingsForRecPat (Ty.RecCon (Ty.HsRecFields { Ty.rec_flds = fields })) =+#endif     getBindingsForRecFields (map unLoc' fields)  where #if __GLASGOW_HASKELL__ >= 710

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, DeriveGeneric #-}+{-# LANGUAGE CPP, BangPatterns, TupleSections, DeriveGeneric #-}  module Language.Haskell.GhcMod.Find #ifndef SPEC@@ -18,6 +18,13 @@ #endif   where +import qualified GHC as G+import FastString+import Module+import OccName+import HscTypes+import Exception+ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Monad@@ -25,38 +32,56 @@ import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.World--import qualified GHC as G-import Name-import Module-import Exception+import Language.Haskell.GhcMod.LightGhc  import Control.Applicative+import Control.DeepSeq import Control.Monad import Control.Monad.Trans.Control import Control.Concurrent-import Control.DeepSeq-import Data.Function+ import Data.List-import qualified Data.ByteString.Lazy as BS import Data.Binary+import Data.Function+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.IORef++import System.Directory.ModTime+import System.IO.Unsafe+ import GHC.Generics (Generic)+ import Data.Map (Map) import qualified Data.Map as M-import System.Directory.ModTime+import Data.Set (Set)+import qualified Data.Set as S+import Language.Haskell.GhcMod.PathsAndFiles+import System.Directory import Prelude  ----------------------------------------------------------------  -- | Type of function and operation names.-type Symbol = String+type Symbol = BS.ByteString+type ModuleNameBS = BS.ByteString+ -- | Database from 'Symbol' to \['ModuleString'\]. data SymbolDb = SymbolDb-  { sdTable             :: Map Symbol [ModuleString]+  { sdTable             :: Map Symbol (Set ModuleNameBS)   , sdTimestamp         :: ModTime   } deriving (Generic) +#if __GLASGOW_HASKELL__ >= 708 instance Binary SymbolDb+#else+instance Binary SymbolDb where+  put (SymbolDb a b) = put a >> put b+  get = do+    a <- get+    b <- get+    return (SymbolDb a b)+#endif instance NFData SymbolDb  isOutdated :: IOish m => SymbolDb -> GhcModT m Bool@@ -67,19 +92,34 @@  -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --   which will be concatenated. 'loadSymbolDb' is called internally.-findSymbol :: IOish m => Symbol -> GhcModT m String-findSymbol sym = loadSymbolDb >>= lookupSymbol sym+findSymbol :: IOish m => String -> GhcModT m String+findSymbol sym = loadSymbolDb' >>= lookupSymbol sym  -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\] --   which will be concatenated.-lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String-lookupSymbol sym db = convert' $ lookupSym sym db+lookupSymbol :: IOish m => String -> SymbolDb -> GhcModT m String+lookupSymbol sym db = convert' $ lookupSym (fastStringToByteString $ mkFastString sym) db  lookupSym :: Symbol -> SymbolDb -> [ModuleString]-lookupSym sym db = M.findWithDefault [] sym $ sdTable db+lookupSym sym db = map (ModuleString . unpackFS . mkFastStringByteString') $ S.toList $ M.findWithDefault S.empty sym $ sdTable db  --------------------------------------------------------------- +loadSymbolDb' :: IOish m => GhcModT m SymbolDb+loadSymbolDb' = do+  cache <- symbolCache <$> cradle+  let doLoad True = do+        db <- decode <$> liftIO (LBS.readFile cache)+        outdated <- isOutdated db+        if outdated+        then doLoad False+        else return db+      doLoad False = do+        db <- loadSymbolDb+        liftIO $ LBS.writeFile cache $ encode db+        return db+  doLoad =<< liftIO (doesFileExist cache)+ -- | Loading a file and creates 'SymbolDb'. loadSymbolDb :: IOish m => GhcModT m SymbolDb loadSymbolDb = do@@ -95,9 +135,9 @@ dumpSymbol :: IOish m => GhcModT m () dumpSymbol = do   ts <- liftIO getCurrentModTime-  st <- runGmPkgGhc getGlobalSymbolTable-  liftIO . BS.putStr $ encode SymbolDb {-      sdTable = M.fromAscList st+  st <- runGmPkgGhc $ (liftIO . getGlobalSymbolTable) =<< G.getSession+  liftIO . LBS.putStr $ encode SymbolDb {+      sdTable = st     , sdTimestamp = ts     } @@ -108,28 +148,42 @@   any (tCache <=) $ map tfTime files -- including equal just in case  -- | Browsing all functions in all system modules.-getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]-getGlobalSymbolTable = do-  df  <- G.getSessionDynFlags-  let mods = listVisibleModules df-  moduleInfos <- mapM G.getModuleInfo mods-  return $ collectModules-         $ extractBindings `concatMap` (moduleInfos `zip` mods)+getGlobalSymbolTable :: HscEnv -> IO (Map Symbol (Set ModuleNameBS))+getGlobalSymbolTable hsc_env =+  foldM (extend hsc_env) M.empty $ listVisibleModules $ hsc_dflags hsc_env -extractBindings :: (Maybe G.ModuleInfo, G.Module)-                -> [(Symbol, ModuleString)]-extractBindings (Nothing,  _)   = []-extractBindings (Just inf, mdl) =-  map (\name -> (getOccString name, modStr)) names-  where-    names  = G.modInfoExports inf-    modStr = ModuleString $ moduleNameString $ moduleName mdl+extend :: HscEnv+       -> Map Symbol (Set ModuleNameBS)+       -> Module+       -> IO (Map Symbol (Set ModuleNameBS))+extend hsc_env mm mdl = do+  eps <- readIORef $ hsc_EPS hsc_env+  modinfo <- unsafeInterleaveIO $ runLightGhc hsc_env $ do+    G.getModuleInfo mdl <* liftIO (writeIORef (hsc_EPS hsc_env) eps) -collectModules :: [(Symbol, ModuleString)]-               -> [(Symbol, [ModuleString])]-collectModules = map tieup . groupBy ((==) `on` fst) . sort-  where-    tieup x = (head (map fst x), map snd x)+  return $ M.unionWith S.union mm $ extractBindings modinfo mdl++extractBindings :: Maybe G.ModuleInfo+                -> G.Module+                -> Map Symbol (Set ModuleNameBS)+extractBindings Nothing  _   = M.empty+extractBindings (Just inf) mdl = M.fromList $ do+  name <- G.modInfoExports inf+  let sym = fastStringToByteString $ occNameFS $ G.getOccName name+      mdls = S.singleton $ fastStringToByteString $ moduleNameFS $ moduleName mdl+  return (sym, mdls)++mkFastStringByteString' :: BS.ByteString -> FastString+#if !MIN_VERSION_ghc(7,8,0)+fastStringToByteString :: FastString -> BS.ByteString+fastStringToByteString = BS.pack . bytesFS++mkFastStringByteString' = mkFastStringByteList . BS.unpack+#elif __GLASGOW_HASKELL__ == 708+mkFastStringByteString' = unsafePerformIO . mkFastStringByteString+#else+mkFastStringByteString' = mkFastStringByteString+#endif  ---------------------------------------------------------------- 

@@ -4,10 +4,6 @@ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Monad --- | Listing GHC flags. (e.g -fno-warn-orphans)-+-- | Listing of GHC flags, same as @ghc@\'s @--show-options@ with @ghc >= 7.10@. flags :: IOish m => GhcModT m String-flags = convert' [ "-f" ++ prefix ++ option-                 | option <- Gap.fOptions-                 , prefix <- ["","no-"]-                 ]+flags = convert' Gap.ghcCmdOptions

@@ -9,7 +9,7 @@   , getSrcSpan   , getSrcFile   , withInteractiveContext-  , fOptions+  , ghcCmdOptions   , toStringBuffer   , showSeverityCaption   , setCabalPkg@@ -18,12 +18,14 @@   , setDeferTypedHoles   , setWarnTypedHoles   , setDumpSplices+  , setNoMaxRelevantBindings   , isDumpSplices   , filterOutChildren   , infoThing   , pprInfo   , HasType(..)   , errorMsgSpan+  , setErrorMsgSpan   , typeForUser   , nameForUser   , occNameForUser@@ -44,6 +46,7 @@   , Language.Haskell.GhcMod.Gap.isSynTyCon   , parseModuleHeader   , mkErrStyle'+  , everythingStagedWithContext   ) where  import Control.Applicative hiding (empty)@@ -75,10 +78,14 @@ import qualified Pretty import qualified StringBuffer as SB +#if __GLASGOW_HASKELL__ >= 710+import CoAxiom (coAxiomTyCon)+#endif+ #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..))-import PatSyn (patSynType)+import PatSyn #else import TcRnTypes #endif@@ -111,6 +118,8 @@ import Parser import SrcLoc import Packages+import Data.Generics (GenericQ, extQ, gmapQ)+import GHC.SYB.Utils (Stage(..))  import Language.Haskell.GhcMod.Types (Expression(..)) import Prelude@@ -141,22 +150,32 @@ withStyle _ = withPprStyleDoc #endif -#if __GLASGOW_HASKELL__ >= 706-type GmLogAction = LogAction+#if __GLASGOW_HASKELL__ >= 800+-- flip LogAction+type GmLogAction = WarnReason -> DynFlags -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()+#elif __GLASGOW_HASKELL__ >= 706+type GmLogAction = forall a. a -> LogAction #else-type GmLogAction = DynFlags -> LogAction+type GmLogAction = forall a. a -> DynFlags -> LogAction #endif +--  DynFlags -> WarnReason -> Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()+ setLogAction :: DynFlags -> GmLogAction -> DynFlags setLogAction df f =-#if __GLASGOW_HASKELL__ >= 706-    df { log_action = f }+#if __GLASGOW_HASKELL__ >= 800+    df { log_action = flip f }+#elif __GLASGOW_HASKELL__ >= 706+    df { log_action = f (error "setLogAction") } #else-    df { log_action = f df }+    df { log_action = f (error "setLogAction") df } #endif  showDocWith :: DynFlags -> Pretty.Mode -> Pretty.Doc -> String-#if __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 800+showDocWith dflags mode = Pretty.renderStyle mstyle where+    mstyle = Pretty.style { Pretty.mode = mode, Pretty.lineLength = pprCols dflags }+#elif __GLASGOW_HASKELL__ >= 708 -- Pretty.showDocWith disappeard. -- https://github.com/ghc/ghc/commit/08a3536e4246e323fbcd8040e0b80001950fe9bc showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)@@ -198,19 +217,26 @@  ---------------------------------------------------------------- -fOptions :: [String]+ghcCmdOptions :: [String] #if __GLASGOW_HASKELL__ >= 710-fOptions = [option | (FlagSpec option _ _ _) <- fFlags]-        ++ [option | (FlagSpec option _ _ _) <- fWarningFlags]-        ++ [option | (FlagSpec option _ _ _) <- fLangFlags]-#elif __GLASGOW_HASKELL__ >= 704-fOptions = [option | (option,_,_) <- fFlags]+-- this also includes -X options and all sorts of other things so the+ghcCmdOptions = flagsForCompletion False+#else+ghcCmdOptions = [ "-f" ++ prefix ++ option+                | option <- opts+                , prefix <- ["","no-"]+                ]+#  if __GLASGOW_HASKELL__ >= 704+ where opts =+           [option | (option,_,_) <- fFlags]         ++ [option | (option,_,_) <- fWarningFlags]         ++ [option | (option,_,_) <- fLangFlags]-#else-fOptions = [option | (option,_,_,_) <- fFlags]+#  else+ where opts =+           [option | (option,_,_,_) <- fFlags]         ++ [option | (option,_,_,_) <- fWarningFlags]         ++ [option | (option,_,_,_) <- fLangFlags]+#  endif #endif  ----------------------------------------------------------------@@ -313,7 +339,17 @@ #endif  ----------------------------------------------------------------++-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings".+setNoMaxRelevantBindings :: DynFlags -> DynFlags+#if __GLASGOW_HASKELL__ >= 708+setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing }+#else+setNoMaxRelevantBindings = id+#endif+ ----------------------------------------------------------------+----------------------------------------------------------------  class HasType a where     getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))@@ -357,28 +393,44 @@ pprInfo m _ (thing, fixity, insts, famInsts)     = pprTyThingInContextLoc' thing    $$ show_fixity fixity-   $$ InstEnv.pprInstances insts-   $$ pprFamInsts famInsts+   $$ vcat (map pprInstance' insts)+   $$ vcat (map pprFamInst' famInsts) #else pprInfo :: (FilePath -> FilePath) -> PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc pprInfo m pefas (thing, fixity, insts)     = pprTyThingInContextLoc' pefas thing    $$ show_fixity fixity-   $$ vcat (map pprInstance insts)+   $$ vcat (map pprInstance' insts) #endif   where     show_fixity fx       | fx == defaultFixity = Outputable.empty       | otherwise           = ppr fx <+> ppr (getName thing) #if __GLASGOW_HASKELL__ >= 708-    pprTyThingInContextLoc' thing' = hang (pprTyThingInContext thing') 2-                                        (char '\t' <> ptext (sLit "--") <+> loc)-                         where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')+    pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')+#if __GLASGOW_HASKELL__ >= 710+    pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })+      = pprTyThingInContextLoc (ATyCon rep_tc)++    pprFamInst' (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                        , fi_tys = lhs_tys, fi_rhs = rhs })+      = showWithLoc (pprDefinedAt' (getName axiom)) $+        hang (ptext (sLit "type instance") <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+           2 (equals <+> ppr rhs) #else-    pprTyThingInContextLoc' pefas' thing' = hang (pprTyThingInContext pefas' thing') 2-                                    (char '\t' <> ptext (sLit "--") <+> loc)-                               where loc = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')+    pprFamInst' ispec = showWithLoc (pprDefinedAt' (getName ispec)) (pprFamInstHdr ispec) #endif+#else+    pprTyThingInContextLoc' pefas' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext pefas' thing')+#endif+    showWithLoc loc doc+        = hang doc 2 (char '\t' <> comment <+> loc)+        -- The tab tries to make them line up a bit+      where+        comment = ptext (sLit "--")+    pprInstance' ispec = hang (pprInstanceHdr ispec)+        2 (ptext (sLit "--") <+> pprDefinedAt' (getName ispec))+    pprDefinedAt' thing' = ptext (sLit "Defined") <+> pprNameDefnLoc' (getName thing')     pprNameDefnLoc' name       = case Name.nameSrcLoc name of            RealSrcLoc s -> ptext (sLit "at") <+> ppr (subst s)@@ -400,6 +452,13 @@ errorMsgSpan = head . errMsgSpans #endif +setErrorMsgSpan :: ErrMsg -> SrcSpan -> ErrMsg+#if __GLASGOW_HASKELL__ >= 708+setErrorMsgSpan err s = err { errMsgSpan = s }+#else+setErrorMsgSpan err s = err { errMsgSpans = [s] }+#endif+ typeForUser :: Type -> SDoc #if __GLASGOW_HASKELL__ >= 708 typeForUser = pprTypeForUser@@ -429,13 +488,22 @@ ---------------------------------------------------------------- ---------------------------------------------------------------- -data GapThing = GtA Type | GtT TyCon | GtN+data GapThing = GtA Type+              | GtT TyCon+              | GtN+#if __GLASGOW_HASKELL__ >= 800+              | GtPatSyn PatSyn+#endif  fromTyThing :: TyThing -> GapThing fromTyThing (AnId i)                   = GtA $ varType i #if __GLASGOW_HASKELL__ >= 708 fromTyThing (AConLike (RealDataCon d)) = GtA $ dataConRepType d+#if __GLASGOW_HASKELL__ >= 800+fromTyThing (AConLike (PatSynCon p))   = GtPatSyn p+#else fromTyThing (AConLike (PatSynCon p))   = GtA $ patSynType p+#endif #else fromTyThing (ADataCon d)               = GtA $ dataConRepType d #endif@@ -467,8 +535,13 @@ #endif  getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)-#if __GLASGOW_HASKELL__ >= 710+#if __GLASGOW_HASKELL__ >= 800 -- Instance declarations of sort 'instance F (G a)'+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsForAllTy _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))))}))] = Just (className, loc)+-- Instance declarations of sort 'instance F G' (no variables)+getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = HsIB _ (L _ (HsAppTy (L _ (HsTyVar (L _ className))) _))}))] = Just (className, loc)+#elif __GLASGOW_HASKELL__ >= 710+-- Instance declarations of sort 'instance F (G a)' getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) -- Instance declarations of sort 'instance F G' (no variables) getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc)@@ -575,3 +648,20 @@   rnf Empty       = ()   rnf (Chunk _ b) = rnf b #endif++-- | Like 'everything', but avoid known potholes, based on the 'Stage' that+--   generated the Ast.+everythingStagedWithContext :: Stage -> s -> (r -> r -> r) -> r -> GenericQ (s -> (r, s)) -> GenericQ r+everythingStagedWithContext stage s0 f z q x+  | (const False+#if __GLASGOW_HASKELL__ <= 708+      `extQ` postTcType+#endif+      `extQ` fixity `extQ` nameSet) x = z+  | otherwise = foldl f r (gmapQ (everythingStagedWithContext stage s' f z q) x)+  where nameSet    = const (stage `elem` [Parser,TypeChecker]) :: NameSet -> Bool+#if __GLASGOW_HASKELL__ <= 708+        postTcType = const (stage<TypeChecker)                 :: PostTcType -> Bool+#endif+        fixity     = const (stage<Renamer)                     :: GHC.Fixity -> Bool+        (r, s') = q x s0

@@ -240,6 +240,7 @@                mns = map (unLoc . ideclName)                    $ filter (isNothing . ideclPkgQual)                    $ map unLoc hsmodImports+           -- TODO: handle package qualifier "this"            liftIO $ Set.fromList . catMaybes <$> mapM (findModulePath env) mns  preprocessFile :: (IOish m, GmEnv m, GmState m) =>

@@ -5,10 +5,9 @@  import Data.Function (on) import Data.List (sortBy)-import Data.Maybe (catMaybes) import System.FilePath import Exception (ghandle, SomeException(..))-import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)+import GHC (GhcMonad, SrcSpan) import Prelude import qualified GHC as G import qualified Language.Haskell.GhcMod.Gap as Gap@@ -53,17 +52,18 @@  -- | Obtaining type of a target expression. (GHCi's type:) types :: IOish m-      => FilePath     -- ^ A target file.+      => Bool         -- ^ Include constraints into type signature+      -> FilePath     -- ^ A target file.       -> Int          -- ^ Line number.       -> Int          -- ^ Column number.       -> GhcModT m String-types file lineNo colNo =+types withConstraints file lineNo colNo =   ghandle handler $     runGmlT' [Left file] deferErrors $       withInteractiveContext $ do         crdl         <- cradle         modSum       <- fileModSummaryWithMapping (cradleCurrentDir crdl </> file)-        srcSpanTypes <- getSrcSpanType modSum lineNo colNo+        srcSpanTypes <- getSrcSpanType withConstraints modSum lineNo colNo         dflag        <- G.getSessionDynFlags         st           <- getStyle         convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes@@ -72,14 +72,8 @@      gmLog GmException "types" $ showDoc ex      return [] -getSrcSpanType :: GhcMonad m => G.ModSummary -> Int -> Int -> m [(SrcSpan, Type)]-getSrcSpanType modSum lineNo colNo = do-  p <- G.parseModule modSum-  tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p-  let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]-      es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]-      ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]-  bts <- mapM (getType tcm) bs-  ets <- mapM (getType tcm) es-  pts <- mapM (getType tcm) ps-  return $ catMaybes $ concat [ets, bts, pts]+getSrcSpanType :: (GhcMonad m) => Bool -> G.ModSummary -> Int -> Int -> m [(SrcSpan, G.Type)]+getSrcSpanType withConstraints modSum lineNo colNo =+  G.parseModule modSum+  >>= G.typecheckModule+  >>= flip (collectSpansTypes withConstraints) (lineNo, colNo)

@@ -42,3 +42,7 @@ runLightGhc env action = do   renv <- newIORef env   flip runReaderT renv $ unLightGhc action++runLightGhc' :: IORef HscEnv -> LightGhc a -> IO a+runLightGhc' renv action = do+  flip runReaderT renv $ unLightGhc action

@@ -6,11 +6,11 @@ import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad-import Language.Haskell.HLint (hlint)+import Language.Haskell.HLint3  import Language.Haskell.GhcMod.Utils (withMappedFile)--import Data.List (stripPrefix)+import Language.Haskell.Exts.SrcLoc (SrcLoc(..))+import System.IO  -- | Checking syntax of a target file using hlint. --   Warnings and errors are returned.@@ -18,12 +18,17 @@      => LintOpts  -- ^ Configuration parameters      -> FilePath  -- ^ A target file.      -> GhcModT m String-lint opt file =-  withMappedFile file $ \tempfile ->-        liftIO (hlint $ tempfile : "--quiet" : optLintHlintOpts opt)-    >>= mapM (replaceFileName tempfile)-    >>= ghandle handler . pack- where+lint opt file = ghandle handler $+  withMappedFile file $ \tempfile -> do+    (flags, classify, hint) <- liftIO $ argsSettings $ optLintHlintOpts opt+    hSrc <- liftIO $ openFile tempfile ReadMode+    liftIO $ hSetEncoding hSrc (encoding flags)+    res <- liftIO $ parseModuleEx flags file =<< Just `fmap` hGetContents hSrc+    case res of+      Right m -> pack . map show $ filter ((/=Ignore) . ideaSeverity) $ applyHints classify hint [m]+      Left ParseError{parseErrorLocation=loc, parseErrorMessage=err} ->+        return $ showSrcLoc loc ++ ":Error:" ++ err ++ "\n"+  where     pack = convert' . map init -- init drops the last \n.     handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"-    replaceFileName fp s = return $ maybe (show s) (file++) $ stripPrefix fp (show s)+    showSrcLoc (SrcLoc f l c) = concat [f, ":", show l, ":", show c]

@@ -1,3 +1,5 @@+{-# LANGUAGE CPP, RankNTypes #-}+ module Language.Haskell.GhcMod.Logger (     withLogger   , withLogger'@@ -12,7 +14,7 @@ import Data.List import Data.Maybe import Data.Function-import Control.Monad.Reader (Reader, asks, runReader)+import Control.Monad.Reader (Reader, ask, runReader) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import System.FilePath (normalise) import Text.PrettyPrint@@ -23,6 +25,8 @@ import Outputable import qualified GHC as G import Bag+import SrcLoc+import FastString  import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Doc (showPage)@@ -57,15 +61,13 @@     writeIORef ref emptyLog     return $ b [] -appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()-appendLogRef rfm df (LogRef ref) _ sev src st msg = do+appendLogRef :: (FilePath -> FilePath) -> DynFlags -> LogRef -> Gap.GmLogAction+appendLogRef map_file df (LogRef ref) _reason _df sev src st msg = do     modifyIORef ref update   where-    gpe = GmPprEnv {-            gpeDynFlags = df-          , gpeMapFile = rfm-          }-    l = runReader (ppMsg st src sev msg) gpe+    -- TODO: get rid of ppMsg and just do more or less what ghc's+    -- defaultLogAction does+    l = ppMsg map_file df st src sev msg      update lg@(Log ls b)       | l `elem` ls = lg@@ -132,43 +134,56 @@  ppErrMsg :: ErrMsg -> GmPprEnvM String ppErrMsg err = do-    dflags <- asks gpeDynFlags+    GmPprEnv {..} <- ask     let unqual = errMsgContext err-        st = Gap.mkErrStyle' dflags unqual-    let ext = showPage dflags st (errMsgExtraInfo err)-    m <- ppMsg st spn SevError msg-    return $ m ++ (if null ext then "" else "\n" ++ ext)-   where-     spn = Gap.errorMsgSpan err-     msg = errMsgShortDoc err+        st = Gap.mkErrStyle' gpeDynFlags unqual+        err' = Gap.setErrorMsgSpan err $ mapSrcSpanFile gpeMapFile (Gap.errorMsgSpan err)+    return $ showPage gpeDynFlags st $ pprLocErrMsg err' -ppMsg :: PprStyle -> SrcSpan -> Severity -> SDoc -> GmPprEnvM String-ppMsg st spn sev msg = do-  dflags <- asks gpeDynFlags-  let cts  = showPage dflags st msg-  prefix <- ppMsgPrefix spn sev cts-  return $ prefix ++ cts+mapSrcSpanFile :: (FilePath -> FilePath) -> SrcSpan -> SrcSpan+mapSrcSpanFile map_file (RealSrcSpan s)   =+    RealSrcSpan $ mapRealSrcSpanFile map_file s+mapSrcSpanFile _ (UnhelpfulSpan s) =+    UnhelpfulSpan s -ppMsgPrefix :: SrcSpan -> Severity -> String -> GmPprEnvM String-ppMsgPrefix spn sev cts = do-  dflags <- asks gpeDynFlags-  mr <- asks gpeMapFile-  let defaultPrefix-        | Gap.isDumpSplices dflags = ""-        | otherwise               = checkErrorPrefix-  return $ fromMaybe defaultPrefix $ do-    (line,col,_,_) <- Gap.getSrcSpan spn-    file <- mr <$> normalise <$> Gap.getSrcFile spn-    let severityCaption = Gap.showSeverityCaption sev-        pref0 | or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)-                          = file ++ ":" ++ show line ++ ":" ++ show col ++ ":"-              | otherwise = file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption-    return pref0+mapRealSrcSpanFile :: (FilePath -> FilePath) -> RealSrcSpan -> RealSrcSpan+mapRealSrcSpanFile map_file s = let+    start = mapRealSrcLocFile map_file $ realSrcSpanStart s+    end   = mapRealSrcLocFile map_file $ realSrcSpanEnd s+  in+    mkRealSrcSpan start end +mapRealSrcLocFile :: (FilePath -> FilePath) -> RealSrcLoc -> RealSrcLoc+mapRealSrcLocFile map_file l = let+    file = mkFastString $ map_file $ unpackFS $ srcLocFile l+    line = srcLocLine l+    col  = srcLocCol l+  in+    mkRealSrcLoc file line col++ppMsg :: (FilePath -> FilePath) -> DynFlags -> PprStyle -> SrcSpan -> Severity -> SDoc -> String+ppMsg map_file df st spn sev msg = let+    cts = showPage df st msg+  in+    ppMsgPrefix map_file df spn sev cts ++ cts++ppMsgPrefix :: (FilePath -> FilePath) -> DynFlags -> SrcSpan -> Severity -> String -> String+ppMsgPrefix map_file df spn sev cts =+  let+      defaultPrefix = if Gap.isDumpSplices df then "" else checkErrorPrefix+  in+    fromMaybe defaultPrefix $ do+      (line,col,_,_) <- Gap.getSrcSpan spn+      file <- map_file <$> normalise <$> Gap.getSrcFile spn+      return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" +++        if or (map (\x -> x `isPrefixOf` cts) warningAsErrorPrefixes)+          then ""+          else Gap.showSeverityCaption sev+ checkErrorPrefix :: String checkErrorPrefix = "Dummy:0:0:Error:"  warningAsErrorPrefixes :: [String]-warningAsErrorPrefixes = ["Couldn't match expected type"+warningAsErrorPrefixes = [ "Couldn't match expected type"                          , "Couldn't match type"                          , "No instance for"]

@@ -53,12 +53,18 @@ import System.IO.Unsafe import Prelude -withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog)  -> m a) -> m a-withGhcModEnv = withGhcModEnv' withCradle+withGhcModEnv :: (IOish m, GmOut m) => FilePath -> Options -> ((GhcModEnv, GhcModLog) -> m a) -> m a+withGhcModEnv dir opts f = withGhcModEnv' withCradle dir opts f  where-   withCradle dir =-       gbracket (runJournalT $ findCradle' dir) (liftIO . cleanupCradle . fst)+   withCradle dir' =+       gbracket+         (runJournalT $ do+            gmSetLogLevel $ ooptLogLevel $ optOutput opts+            findCradle' (optPrograms opts) dir')+         (liftIO . cleanupCradle . fst) ++ cwdLock :: MVar ThreadId cwdLock = unsafePerformIO $ newEmptyMVar {-# NOINLINE cwdLock #-}@@ -97,7 +103,7 @@                   (const $ liftIO $ flushStdoutGateway gmoChan)                   action -runGmOutT' :: IOish m => GhcModOut -> GmOutT m a -> m a+runGmOutT' :: GhcModOut -> GmOutT m a -> m a runGmOutT' gmo ma = flip runReaderT gmo $ unGmOutT ma  -- | Run a @GhcModT m@ computation.

@@ -124,7 +124,7 @@  -- GmT ------------------------------------------ -instance forall r m. MonadReader r m => MonadReader r (GmT m) where+instance MonadReader r m => MonadReader r (GmT m) where     local f ma = gmLiftWithInner (\run -> local f (run ma))     ask = gmLiftInner ask 

@@ -0,0 +1,48 @@+-- 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/>.++module Language.Haskell.GhcMod.Options.DocUtils (+  ($$),+  ($$$),+  (<=>),+  (<$$>),+  (<||>)+) where++import Options.Applicative+import Data.Monoid+import Prelude++infixl 6 <||>+infixr 7 <$$>+infixr 7 $$+infixr 8 <=>+infixr 9 $$$++($$) :: (a -> b) -> a -> b+($$) = ($)++($$$) :: (a -> b) -> a -> b+($$$) = ($)++(<||>) :: Alternative a => a b -> a b -> a b+(<||>) = (<|>)++(<=>) :: Monoid m => m -> m -> m+(<=>) = (<>)++(<$$>) :: Functor f => (a -> b) -> f a -> f b+(<$$>) = (<$>)

@@ -0,0 +1,79 @@+-- 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, FlexibleInstances, GeneralizedNewtypeDeriving #-}++module Language.Haskell.GhcMod.Options.Help where++import Options.Applicative+import Options.Applicative.Help.Pretty (Doc)+import qualified Options.Applicative.Help.Pretty as PP+import Control.Monad.State+import GHC.Exts( IsString(..) )+import Data.Maybe+import Data.Monoid+import Prelude++newtype MyDocM s a = MyDoc {unwrapState :: State s a}+  deriving (Monad, Functor, Applicative, MonadState s)+type MyDoc = MyDocM (Maybe Doc) ()++instance IsString (MyDocM (Maybe Doc) a) where+    fromString = append . para++instance Monoid (MyDocM (Maybe Doc) ()) where+  mappend a b = append $ doc a <> doc b+  mempty = append PP.empty++para :: String -> Doc+para = PP.fillSep . map PP.text . words++append :: Doc -> MyDocM (Maybe Doc) a+append s = modify m >> return undefined+  where+    m :: Maybe Doc -> Maybe Doc+    m Nothing = Just s+    m (Just old) = Just $ old PP..$. s++infixr 7 \\+(\\) :: MyDoc -> MyDoc -> MyDoc+(\\) a b = append $ doc a PP.<+> doc b++doc :: MyDoc -> Doc+doc = fromMaybe PP.empty . flip execState Nothing . unwrapState++help' :: MyDoc -> Mod f a+help' = helpDoc . Just . doc++desc :: MyDoc -> InfoMod a+desc = footerDoc . Just . doc . indent 2++code :: MyDoc -> MyDoc+code x = do+  _ <- " "+  indent 4 x+  " "++progDesc' :: MyDoc -> InfoMod a+progDesc' = progDescDoc . Just . doc++indent :: Int -> MyDoc -> MyDoc+indent n = append . PP.indent n . doc++int' :: Int -> MyDoc+int' = append . PP.int++para' :: String -> MyDoc+para' = append . para

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

@@ -220,7 +220,7 @@  -- | Filename of the symbol table cache file. symbolCache :: Cradle -> FilePath-symbolCache crdl = cradleTempDir crdl </> symbolCacheFile+symbolCache crdl = cradleRootDir crdl </> cradleDistDir crdl </> symbolCacheFile  symbolCacheFile :: String symbolCacheFile = "ghc-mod.symbol-cache"

@@ -32,7 +32,8 @@  gmComponentNameDoc :: ChComponentName -> Doc gmComponentNameDoc ChSetupHsName   = text $ "Setup.hs"-gmComponentNameDoc ChLibName       = text $ "library"+gmComponentNameDoc (ChLibName "")  = text $ "library"+gmComponentNameDoc (ChLibName n)   = text $ "library:" ++ n gmComponentNameDoc (ChExeName n)   = text $ "exe:" ++ n gmComponentNameDoc (ChTestName n)  = text $ "test:" ++ n gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n

@@ -1,4 +1,5 @@-{-# LANGUAGE TupleSections, FlexibleInstances, Rank2Types #-}+-- TODO: remove CPP once Gap(ed)+{-# LANGUAGE CPP, TupleSections, FlexibleInstances, Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Haskell.GhcMod.SrcUtils where@@ -6,11 +7,14 @@ import Control.Applicative import CoreUtils (exprType) import Data.Generics-import Data.Maybe (fromMaybe)+import Data.Maybe import Data.Ord as O import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))+import Var (Var) import qualified GHC as G-import GHC.SYB.Utils (Stage(..), everythingStaged)+import qualified Var as G+import qualified Type as G+import GHC.SYB.Utils import GhcMonad import qualified Language.Haskell.Exts.Annotated as HE import Language.Haskell.GhcMod.Doc@@ -20,6 +24,10 @@ import Outputable (PprStyle) import TcHsSyn (hsPatType) import Prelude+import Control.Monad+import Data.List (nub)+import Control.Arrow+import qualified Data.Map as M  ---------------------------------------------------------------- @@ -33,6 +41,101 @@     getType _ (G.L spn pat) = return $ Just (spn, hsPatType pat)  ----------------------------------------------------------------++-- | Stores mapping from monomorphic to polymorphic types+type CstGenQS = M.Map Var Type+-- | Generic type to simplify SYB definition+type CstGenQT a = forall m. GhcMonad m => a Id -> CstGenQS -> (m [(SrcSpan, Type)], CstGenQS)++collectSpansTypes :: (GhcMonad m) => Bool -> G.TypecheckedModule -> (Int, Int) -> m [(SrcSpan, Type)]+collectSpansTypes withConstraints tcs lc =+  -- This walks AST top-down, left-to-right, while carrying CstGenQS down the tree+  -- (but not left-to-right)+  everythingStagedWithContext TypeChecker M.empty (liftM2 (++))+    (return [])+    ((return [],)+      `mkQ`  (hsBind    :: CstGenQT G.LHsBind) -- matches on binds+      `extQ` (genericCT :: CstGenQT G.LHsExpr) -- matches on expressions+      `extQ` (genericCT :: CstGenQT G.LPat) -- matches on patterns+      )+    (G.tm_typechecked_source tcs)+  where+    -- Helper function to insert mapping into CstGenQS+    insExp x = M.insert (G.abe_mono x) (G.varType $ G.abe_poly x)+    -- If there is AbsBinds here, insert mapping into CstGenQS if needed+    hsBind (L _ G.AbsBinds{abs_exports = es'}) s+      | withConstraints = (return [], foldr insExp s es')+      | otherwise       = (return [], s)+#if __GLASGOW_HASKELL__ >= 800+    -- TODO: move to Gap+    -- Note: this deals with bindings with explicit type signature, e.g.+    --    double :: Num a => a -> a+    --    double x = 2*x+    hsBind (L _ G.AbsBindsSig{abs_sig_export = poly, abs_sig_bind = bind}) s+      | withConstraints =+          let new_s =+                case bind of+                  G.L _ G.FunBind{fun_id = i} -> M.insert (G.unLoc i) (G.varType poly) s+                  _ -> s+          in (return [], new_s)+      | otherwise       = (return [], s)+#endif+    -- Otherwise, it's the same as other cases+    hsBind x s = genericCT x s+    -- Generic SYB function to get type+    genericCT x s+      | withConstraints+      = (maybe [] (uncurry $ constrainedType (collectBinders x) s) <$> getType' x, s)+      | otherwise = (maybeToList <$> getType' x, s)+    -- Collects everything with Id from LHsBind, LHsExpr, or LPat+    collectBinders :: Data a => a -> [Id]+    collectBinders = listifyStaged TypeChecker (const True)+    -- Gets monomorphic type with location+    getType' x@(L spn _)+      | G.isGoodSrcSpan spn && spn `G.spans` lc+      = getType tcs x+      | otherwise = return Nothing+    -- Gets constrained type+    constrainedType :: [Var] -- ^ Binders in expression, i.e. anything with Id+                    -> CstGenQS -- ^ Map from Id to polymorphic type+                    -> SrcSpan -- ^ extent of expression, copied to result+                    -> Type -- ^ monomorphic type+                    -> [(SrcSpan, Type)] -- ^ result+    constrainedType pids s spn genTyp =+      let+        -- runs build on every binder.+        ctys  = mapMaybe build (nub pids)+        -- Computes constrained type for x. Returns (constraints, substitutions)+        -- Substitutions are needed because type variables don't match+        -- between polymorphic and monomorphic types.+        -- E.g. poly type might be `Monad m => m ()`, while monomorphic might be `f ()`+        build x | Just cti <- x `M.lookup` s+                = let+                    (preds', ctt) = getPreds cti+                    -- list of type variables in monomorphic type+                    vts = listifyStaged TypeChecker G.isTyVar $ G.varType x+                    -- list of type variables in polymorphic type+                    tvm = listifyStaged TypeChecker G.isTyVarTy ctt+                  in Just (preds', zip vts tvm)+                | otherwise = Nothing+        -- list of constraints+        preds = concatMap fst ctys+        -- Type variable substitutions+#if __GLASGOW_HASKELL__ >= 800+ -- TODO: move to Gap+        subs  = G.mkTvSubstPrs $ concatMap snd ctys+#else+        subs  = G.mkTopTvSubst $ concatMap snd ctys+#endif+        -- Constrained type+        ty    = G.substTy subs $ G.mkFunTys preds genTyp+      in [(spn, ty)]+    -- Splits a given type into list of constraints and simple type. Drops foralls.+    getPreds :: Type -> ([Type], Type)+    getPreds x | G.isForAllTy x = getPreds $ G.dropForAlls x+               | Just (c, t) <- G.splitFunTy_maybe x+               , G.isPredTy c = first (c:) $ getPreds t+               | otherwise = ([], x)  listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a] listifySpans tcs lc = listifyStaged TypeChecker p tcs

@@ -75,12 +75,12 @@  findExecutablesInDirectories' :: [FilePath] -> String -> IO [FilePath] findExecutablesInDirectories' path binary =-    U.findFilesWith' isExecutable path (binary <.> exeExtension)+    U.findFilesWith' isExecutable path (binary <.> exeExtension')    where isExecutable file = do              perms <- getPermissions file              return $ executable perms -         exeExtension = if isWindows then "exe" else ""+         exeExtension' = if isWindows then "exe" else ""  readStack :: (IOish m, GmOut m, GmLog m) => [String] -> MaybeT m String readStack args = do

@@ -21,6 +21,9 @@ import Control.Applicative import Control.Category ((.)) import GHC+#if __GLASGOW_HASKELL__ >= 800+import GHC.LanguageExtensions+#endif import GHC.Paths (libdir) import SysTools import DynFlags@@ -66,29 +69,41 @@     withLightHscEnv pkgOpts $ \env -> liftIO $ runLightGhc env action  initSession :: IOish m-            => [GHCOption] -> (DynFlags -> Ghc DynFlags) -> GhcModT m ()+            => [GHCOption] -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags) -> GhcModT m () initSession opts mdf = do    s <- gmsGet    case gmGhcSession s of-     Just GmGhcSession {..} | gmgsOptions /= opts-> do-         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"-         putNewSession s-     Just _ -> return ()      Nothing -> do          gmLog GmDebug "initSession" $ text "Session not initialized, creating new one"          putNewSession s+     Just GmGhcSession {..} -> do+         gmLog GmDebug "initSession" $ text "Flags changed, creating new session"+         crdl <- cradle+         changed <- liftIO $ runLightGhc' gmgsSession $ do+           df <- getSessionDynFlags+           ndf <- initDF crdl+           return $ ndf `eqDynFlags` df +         if changed+            then putNewSession s+            else return ()  where+   initDF Cradle { cradleTempDir } = do+       let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)+       _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags+       getSessionDynFlags+    putNewSession s = do-     rghc <- (liftIO . newIORef =<< newSession =<< cradle)+     rghc <- (liftIO . newIORef =<< newSession)      gmsPut s { gmGhcSession = Just $ GmGhcSession opts rghc } -   newSession Cradle { cradleTempDir } = liftIO $ do-     runGhc (Just libdir) $ do-       let setDf df = setTmpDir cradleTempDir <$> (mdf =<< addCmdOpts opts df)-       _ <- setSessionDynFlags =<< setDf =<< getSessionDynFlags+   newSession = do+     crdl <- cradle+     liftIO $ runGhc (Just libdir) $ do+       _ <- initDF crdl        getSession + -- | Drop the currently active GHC session, the next that requires a GHC session -- will initialize a new one. dropSession :: IOish m => GhcModT m ()@@ -114,7 +129,7 @@ -- of certain files or modules, with updated GHC flags runGmlT' :: IOish m               => [Either FilePath ModuleName]-              -> (DynFlags -> Ghc DynFlags)+              -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)               -> GmlT m a               -> GhcModT m a runGmlT' fns mdf action = runGmlTWith fns mdf id action@@ -124,7 +139,7 @@ -- transformation runGmlTWith :: IOish m                  => [Either FilePath ModuleName]-                 -> (DynFlags -> Ghc DynFlags)+                 -> (forall gm. GhcMonad gm => DynFlags -> gm DynFlags)                  -> (GmlT m a -> GmlT m b)                  -> GmlT m a                  -> GhcModT m b@@ -275,8 +290,7 @@ pickComponent :: Set ChComponentName -> ChComponentName pickComponent scn = Set.findMin scn -packageGhcOptions :: (Applicative m, IOish m, Gm m)-                  => m [GHCOption]+packageGhcOptions :: (IOish m, Applicative m, Gm m) => m [GHCOption] packageGhcOptions = do     crdl <- cradle     case cradleProject crdl of@@ -451,7 +465,9 @@     case target' of       HscNothing -> do         void $ load LoadAllTargets-        mapM_ (parseModule >=> typecheckModule >=> desugarModule) mg+        forM_ mg $+          handleSourceError (gmLog GmDebug "loadTargets" . text . show)+          . void . (parseModule >=> typecheckModule >=> desugarModule)       HscInterpreted -> do         void $ load LoadAllTargets       _ -> error ("loadTargets: unsupported hscTarget")@@ -477,10 +493,16 @@ needsHscInterpreted :: ModuleGraph -> Bool needsHscInterpreted = any $ \ms ->                 let df = ms_hspp_opts ms in+#if __GLASGOW_HASKELL__ >= 800+                   TemplateHaskell `xopt` df+                || QuasiQuotes     `xopt` df+                || PatternSynonyms `xopt` df+#else                    Opt_TemplateHaskell `xopt` df                 || Opt_QuasiQuotes     `xopt` df #if __GLASGOW_HASKELL__ >= 708                 || (Opt_PatternSynonyms `xopt` df)+#endif #endif  cabalResolvedComponents :: (IOish m) =>

@@ -71,7 +71,7 @@ newtype LineSeparator = LineSeparator String deriving (Show)  data FileMapping =  FileMapping {fmPath :: FilePath, fmTemp :: Bool}-                  deriving Show+                  deriving (Eq, Show)  type FileMappingMap = Map FilePath FileMapping @@ -105,6 +105,7 @@     -- | GHC command line options set on the @ghc-mod@ command line   , optGhcUserOptions :: [GHCOption]   , optFileMappings   :: [(FilePath, Maybe FilePath)]+  , optEncoding       :: String   } deriving (Show)  -- | A default 'Options'.@@ -124,6 +125,7 @@     }   , optGhcUserOptions = []   , optFileMappings   = []+  , optEncoding       = "UTF-8"   }  ----------------------------------------------------------------@@ -132,7 +134,7 @@              | SandboxProject              | PlainProject              | StackProject StackEnv-               deriving (Eq, Show)+               deriving (Eq, Show, Ord)  isCabalHelperProject :: Project -> Bool isCabalHelperProject StackProject {} = True@@ -144,7 +146,7 @@     , seBinPath       :: [FilePath]     , seSnapshotPkgDb :: FilePath     , seLocalPkgDb    :: FilePath-    } deriving (Eq, Show)+    } deriving (Eq, Show, Ord)  -- | The environment where this library is used. data Cradle = Cradle {@@ -159,7 +161,7 @@   , cradleCabalFile  :: Maybe FilePath   -- | The build info directory.   , cradleDistDir    :: FilePath-  } deriving (Eq, Show)+  } deriving (Eq, Show, Ord)  data GmStream = GmOutStream | GmErrStream                 deriving (Show)@@ -269,7 +271,7 @@         mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph     return $ GmModuleGraph mpGraph     where-      swapMap :: (Ord k, Ord v) => Map k v -> Map v k+      swapMap :: Ord v => Map k v -> Map v k       swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList  instance Monoid GmModuleGraph where@@ -386,13 +388,15 @@         -- ^ If 'True', "browseWith" also returns operators.       , optBrowseDetailed       :: Bool         -- ^ If 'True', "browseWith" also returns types.+      , optBrowseParents        :: Bool+        -- ^ If 'True', "browseWith" also returns parents.       , optBrowseQualified      :: Bool         -- ^ If 'True', "browseWith" will return fully qualified name     } deriving (Show)  -- | Default "BrowseOpts" instance defaultBrowseOpts :: BrowseOpts-defaultBrowseOpts = BrowseOpts False False False+defaultBrowseOpts = BrowseOpts False False False False  mkLabel ''GhcModCaches mkLabel ''GhcModState

@@ -19,7 +19,7 @@   , worldCabalFile     :: Maybe TimedFile   , worldCabalConfig   :: Maybe TimedFile   , worldCabalSandboxConfig :: Maybe TimedFile-  , worldSymbolCache   :: Maybe TimedFile+  , worldMappedFiles   :: FileMappingMap   } deriving (Eq)  timedPackageCaches :: IOish m => GhcModT m [TimedFile]@@ -35,14 +35,14 @@     mCabalFile   <- liftIO $ timeFile `traverse` cradleCabalFile crdl     mCabalConfig <- liftIO $ timeMaybe (setupConfigFile crdl)     mCabalSandboxConfig <- liftIO $ timeMaybe (sandboxConfigFile crdl)-    mSymbolCache <- liftIO $ timeMaybe (symbolCache crdl)+    mFileMap     <- getMMappedFiles      return World {         worldPackageCaches = pkgCaches       , worldCabalFile     = mCabalFile       , worldCabalConfig   = mCabalConfig       , worldCabalSandboxConfig = mCabalSandboxConfig-      , worldSymbolCache   = mSymbolCache+      , worldMappedFiles   = mFileMap       }  didWorldChange :: IOish m => World -> GhcModT m Bool

@@ -104,21 +104,36 @@        TySynD n _ _ -> [(TcClsName, n)]       ClassD _ n _ _ _ -> [(TcClsName, n)]-      FamilyD _ n _ _ -> [(TcClsName, n)] +#if __GLASGOW_HASKELL__ >= 800+      DataD _ n _ _ ctors _ ->+#else       DataD _ n _ ctors _ ->+#endif           [(TcClsName, n)] ++ map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800+      NewtypeD _ n _ _ ctor _ ->+#else       NewtypeD _ n _ ctor _ ->+#endif           [(TcClsName, n)] ++ map ((,) TcClsName) (conNames ctor) +#if __GLASGOW_HASKELL__ >= 800+      DataInstD _ _n _ _ ctors _ ->+#else       DataInstD _ _n _ ctors _ ->+#endif           map ((,) TcClsName) (conNames `concatMap` ctors) +#if __GLASGOW_HASKELL__ >= 800+      NewtypeInstD _ _n _ _ ctor _ ->+#else       NewtypeInstD _ _n _ ctor _ ->+#endif           map ((,) TcClsName) (conNames ctor) -      InstanceD _ _ty _ ->+      InstanceD {}  -> -- _ _ty _           error "notcpp: Instance declarations are not supported yet"       ForeignD _ ->           error "notcpp: Foreign declarations are not supported yet"@@ -131,8 +146,17 @@ #endif  #if __GLASGOW_HASKELL__ >= 708-      ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]       RoleAnnotD _n _ -> error "notcpp: RoleAnnotD not supported yet"+#endif++#if __GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 800+      FamilyD _ n _ _ -> [(TcClsName, n)]+#elif __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 800+      ClosedTypeFamilyD n _ _ _ -> [(TcClsName, n)]+#else+      OpenTypeFamilyD (TypeFamilyHead n _ _ _) -> [(TcClsName, n)]+      ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _ -> [(TcClsName, n)]+ #endif  conNames :: Con -> [Name]

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-} -- | This module uses scope lookup techniques to either export -- 'lookupValueName' from @Language.Haskell.TH@, or define@@ -25,8 +26,13 @@   case mi of     Nothing -> no     Just i -> case i of+#if __GLASGOW_HASKELL__ >= 800+      VarI n _ _ -> yes n+      DataConI n _ _ -> yes n+#else       VarI n _ _ _ -> yes n       DataConI n _ _ _ -> yes n+#endif       _ -> err ["unexpected info:", show i]  where   no = return Nothing@@ -34,5 +40,5 @@   err = fail . showString "NotCPP.bestValueGuess: " . unwords  $(recover [d| lookupValueName = bestValueGuess |] $ do-  VarI _ _ _ _ <- reify (mkName "lookupValueName")+  VarI{} <- reify (mkName "lookupValueName")   return [])

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP             #-} {-# LANGUAGE TemplateHaskell #-} module NotCPP.Utils where @@ -24,6 +25,11 @@ -- | Returns @'Just' ('VarE' n)@ if the info relates to a value called -- @n@, or 'Nothing' if it relates to a different sort of thing. infoToExp :: Info -> Maybe Exp+#if __GLASGOW_HASKELL__ >= 800+infoToExp (VarI n _ _) = Just (VarE n)+infoToExp (DataConI n _ _) = Just (ConE n)+#else infoToExp (VarI n _ _ _) = Just (VarE n) infoToExp (DataConI n _ _ _) = Just (ConE n)+#endif infoToExp _ = Nothing

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

@@ -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 @@                         test/data/stack-project/src/*.hs                         test/data/stack-project/test/*.hs +Custom-Setup+  Setup-Depends:         base+                       , Cabal < 1.25+                       , containers+                       , filepath+                       , process+                       , template-haskell+                       , transformers+ Library   Default-Language:     Haskell2010   GHC-Options:          -Wall -fno-warn-deprecations@@ -117,6 +126,7 @@                         Language.Haskell.GhcMod.DebugLogger                         Language.Haskell.GhcMod.Doc                         Language.Haskell.GhcMod.DynFlags+                        Language.Haskell.GhcMod.DynFlagsTH                         Language.Haskell.GhcMod.Error                         Language.Haskell.GhcMod.FileMapping                         Language.Haskell.GhcMod.FillSig@@ -152,30 +162,34 @@                         Language.Haskell.GhcMod.Types                         Language.Haskell.GhcMod.Utils                         Language.Haskell.GhcMod.World++                        Language.Haskell.GhcMod.Options.Options+                        Language.Haskell.GhcMod.Options.DocUtils+                        Language.Haskell.GhcMod.Options.Help   Other-Modules:        Paths_ghc_mod                         Utils                         Data.Binary.Generic                         System.Directory.ModTime   Build-Depends:        base              < 5 && >= 4.0                       , bytestring        < 0.11-                      , binary            < 0.8 && >= 0.5.1.0+                      , binary            < 0.9 && >= 0.5.1.0                       , containers        < 0.6-                      , cabal-helper      < 0.7 && >= 0.6.3.0+                      , cabal-helper      < 0.8 && >= 0.7.1.0                       , deepseq           < 1.5                       , directory         < 1.3                       , filepath          < 1.5-                      , ghc               < 7.11+                      , ghc               < 8.2 && >= 7.6                       , ghc-paths         < 0.2                       , ghc-syb-utils     < 0.3-                      , hlint             < 1.10 && >= 1.8.61+                      , hlint             < 1.10 && >= 1.9.27                       , monad-journal     < 0.8 && >= 0.4                       , old-time          < 1.2                       , pretty            < 1.2-                      , process           < 1.3+                      , process           < 1.5                       , syb               < 0.7                       , temporary         < 1.3-                      , time              < 1.6-                      , transformers      < 0.5+                      , time              < 1.7+                      , transformers      < 0.6                       , transformers-base < 0.5                       , mtl               < 2.3 && >= 2.0                       , monad-control     < 1.1 && >= 1@@ -187,12 +201,13 @@                       , extra             == 1.4.*                       , pipes             == 4.1.*                       , safe              < 0.4 && >= 0.3.9+                      , optparse-applicative >=0.11.0 && <0.13.0+                      , template-haskell+                      , syb   if impl(ghc < 7.8)     Build-Depends:      convertible-  if impl(ghc < 7.5)-    -- Only used to constrain random to a version that still works with GHC 7.4-    Build-Depends:      random <= 1.0.1.1,-                        ghc-prim+  if impl(ghc >= 8.0)+    Build-Depends:      ghc-boot  Executable ghc-mod   Default-Language:     Haskell2010@@ -201,9 +216,7 @@                       , GHCMod.Options                       , GHCMod.Options.Commands                       , GHCMod.Version-                      , GHCMod.Options.DocUtils                       , GHCMod.Options.ShellParse-                      , GHCMod.Options.Help   GHC-Options:          -Wall -fno-warn-deprecations -threaded   Default-Extensions:   ConstraintKinds, FlexibleContexts   HS-Source-Dirs:       src@@ -211,10 +224,10 @@                       , directory < 1.3                       , filepath  < 1.5                       , pretty    < 1.2-                      , process   < 1.3+                      , process   < 1.5                       , split     < 0.3                       , mtl       < 2.3 && >= 2.0-                      , ghc       < 7.11+                      , ghc       < 8.1                       , monad-control ==1.0.*                       , fclabels  ==2.0.*                       , optparse-applicative >=0.11.0 && <0.13.0@@ -231,13 +244,13 @@   Default-Extensions:   ConstraintKinds, FlexibleContexts   HS-Source-Dirs:       src, .   Build-Depends:        base      < 5 && >= 4.0-                      , binary    < 0.8 && >= 0.5.1.0+                      , binary    < 0.9 && >= 0.5.1.0                       , deepseq   < 1.5                       , directory < 1.3                       , filepath  < 1.5-                      , process   < 1.3+                      , process   < 1.5                       , old-time  < 1.2-                      , time      < 1.6+                      , time      < 1.7                       , ghc-mod  Test-Suite doctest@@ -247,8 +260,6 @@   Ghc-Options:          -Wall   Default-Extensions:   ConstraintKinds, FlexibleContexts   Main-Is:              doctests.hs-  if impl(ghc == 7.4.*)-    Buildable:          False   Build-Depends:        base                       , doctest >= 0.9.3 @@ -281,11 +292,7 @@                         ShellParseSpec    Build-Depends:        hspec >= 2.0.0-  if impl(ghc == 7.4.*)-    Build-Depends:     executable-path   X-Build-Depends-Like: CLibName--  Source-Repository head   Type:                 git

@@ -34,9 +34,12 @@           ]  main :: IO ()-main = do-    hSetEncoding stdout utf8-    parseArgs >>= \res@(globalOptions, _) ->+main =+    parseArgs >>= \res@(globalOptions, _) -> do+      enc <- mkTextEncoding $ optEncoding globalOptions+      hSetEncoding stdout enc+      hSetEncoding stderr enc+      hSetEncoding stdin enc       catches (progMain res) [               Handler $ \(e :: GhcModError) ->                 runGmOutT globalOptions $ exitError $ renderStyle ghcModStyle (gmeDoc e)@@ -107,9 +110,7 @@         then fmap (x:) readStdin'         else return [] --- Someone please already rewrite the cmdline parsing code *weep* :'( wrapGhcCommands :: (IOish m, GmOut m) => Options -> GhcModCommands -> m ()-wrapGhcCommands _opts CmdRoot = gmPutStr =<< rootInfo wrapGhcCommands opts cmd =     handleGmError $ runGhcModT opts $ handler $ do       forM_ (reverse $ optFileMappings opts) $@@ -139,7 +140,7 @@ ghcCommands (CmdDebugComponent ts) = componentInfo ts ghcCommands (CmdBoot) = boot -- ghcCommands (CmdNukeCaches) = nukeCaches >> return ""--- ghcCommands (CmdRoot) = undefined -- handled in wrapGhcCommands+ghcCommands (CmdRoot) = rootInfo ghcCommands (CmdLegacyInteractive) = legacyInteractive >> return "" ghcCommands (CmdModules detail) = modules detail ghcCommands (CmdDumpSym) = dumpSymbol >> return ""@@ -150,7 +151,7 @@ ghcCommands (CmdCheck files) = checkSyntax files ghcCommands (CmdExpand files) = expandTemplate files ghcCommands (CmdInfo file symb) = info file $ Expression symb-ghcCommands (CmdType file (line, col)) = types file line col+ghcCommands (CmdType wCon file (line, col)) = types wCon file line col ghcCommands (CmdSplit file (line, col)) = splits file line col ghcCommands (CmdSig file (line, col)) = sig file line col ghcCommands (CmdAuto file (line, col)) = auto file line col

@@ -25,14 +25,10 @@ import Options.Applicative import Options.Applicative.Types import Language.Haskell.GhcMod.Types-import Control.Arrow-import Data.Char (toUpper, toLower)-import Data.List (intercalate)-import Language.Haskell.GhcMod.Read import GHCMod.Options.Commands import GHCMod.Version-import GHCMod.Options.DocUtils-import GHCMod.Options.Help+import Language.Haskell.GhcMod.Options.DocUtils+import Language.Haskell.GhcMod.Options.Options import GHCMod.Options.ShellParse  parseArgs :: IO (Options, GhcModCommands)@@ -74,128 +70,3 @@ argAndCmdSpec :: Parser (Options, GhcModCommands) argAndCmdSpec = (,) <$> globalArgSpec <*> commandsSpec -splitOn :: Eq a => a -> [a] -> ([a], [a])-splitOn c = second (drop 1) . break (==c)--logLevelParser :: Parser GmLogLevel-logLevelParser =-    logLevelSwitch <*>-           logLevelOption-      <||> silentSwitch-  where-    logLevelOption =-      option parseLL-        $$  long "verbose"-        <=> metavar "LEVEL"-        <=> value GmWarning-        <=> showDefaultWith showLL-        <=> help' $$$ do-          "Set log level ("-            <> int' (fromEnum (minBound :: GmLogLevel))-            <> "-"-            <> int' (fromEnum (maxBound :: GmLogLevel))-            <> ")"-          "You can also use strings (case-insensitive):"-          para'-            $ intercalate ", "-            $ map showLL ([minBound..maxBound] :: [GmLogLevel])-    logLevelSwitch =-      repeatAp succ' . length <$> many $$ flag' ()-        $$  short 'v'-        <=> help "Increase log level"-    silentSwitch = flag' GmSilent-        $$  long "silent"-        <=> short 's'-        <=> help "Be silent, set log level to 'silent'"-    showLL = drop 2 . map toLower . show-    repeatAp f n = foldr (.) id (replicate n f)-    succ' x | x == maxBound = x-            | otherwise     = succ x-    parseLL = do-      v <- readerAsk-      let-        il'= toEnum . min maxBound <$> readMaybe v-        ll' = readMaybe ("Gm" ++ capFirst v)-      maybe (readerError $ "Not a log level \"" ++ v ++ "\"") return $ ll' <|> il'-    capFirst (h:t) = toUpper h : map toLower t-    capFirst [] = []--outputOptsSpec :: Parser OutputOpts-outputOptsSpec = OutputOpts-      <$> logLevelParser-      <*> flag PlainStyle LispStyle-          $$  long "tolisp"-          <=> short 'l'-          <=> help "Format output as an S-Expression"-      <*> LineSeparator <$$> strOption-          $$  long "boundary"-          <=> long "line-separator"-          <=> short 'b'-          <=> metavar "SEP"-          <=> value "\0"-          <=> showDefault-          <=> help "Output line separator"-      <*> optional $$ splitOn ',' <$$> strOption-          $$  long "line-prefix"-          <=> metavar "OUT,ERR"-          <=> help "Output prefixes"--programsArgSpec :: Parser Programs-programsArgSpec = Programs-      <$> strOption-          $$  long "with-ghc"-          <=> value "ghc"-          <=> showDefault-          <=> help "GHC executable to use"-      <*> strOption-          $$  long "with-ghc-pkg"-          <=> value "ghc-pkg"-          <=> showDefault-          <=> help "ghc-pkg executable to use (only needed when guessing from GHC path fails)"-      <*> strOption-          $$  long "with-cabal"-          <=> value "cabal"-          <=> showDefault-          <=> help "cabal-install executable to use"-      <*> strOption-          $$  long "with-stack"-          <=> value "stack"-          <=> showDefault-          <=> help "stack executable to use"--globalArgSpec :: Parser Options-globalArgSpec = Options-      <$> outputOptsSpec-      <*> programsArgSpec-      <*> many $$ strOption-          $$  long "ghcOpt"-          <=> long "ghc-option"-          <=> short 'g'-          <=> metavar "OPT"-          <=> help "Option to be passed to GHC"-      <*> many fileMappingSpec-  where-    fileMappingSpec =-      getFileMapping . splitOn '=' <$> strOption-        $$  long "map-file"-        <=> metavar "MAPPING"-        <=> fileMappingHelp-    fileMappingHelp = help' $ do-        "Redirect one file to another"-        "--map-file \"file1.hs=file2.hs\""-        indent 4 $ do-          "can be used to tell ghc-mod"-            \\ "that it should take source code"-            \\ "for `file1.hs` from `file2.hs`."-          "`file1.hs` can be either full path,"-            \\ "or path relative to project root."-          "`file2.hs` has to be either relative to project root,"-            \\  "or full path (preferred)"-        "--map-file \"file.hs\""-        indent 4 $ do-          "can be used to tell ghc-mod that it should take"-            \\ "source code for `file.hs` from stdin. File end"-            \\ "marker is `\\n\\EOT\\n`, i.e. `\\x0A\\x04\\x0A`."-            \\ "`file.hs` may or may not exist, and should be"-            \\ "either full path, or relative to project root."-    getFileMapping = second (\i -> if null i then Nothing else Just i)

@@ -23,8 +23,8 @@ import Options.Applicative.Builder.Internal import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Read-import GHCMod.Options.DocUtils-import GHCMod.Options.Help+import Language.Haskell.GhcMod.Options.DocUtils+import Language.Haskell.GhcMod.Options.Help  type Symbol = String type Expr = String@@ -51,7 +51,7 @@   | CmdCheck [FilePath]   | CmdExpand [FilePath]   | CmdInfo FilePath Symbol-  | CmdType FilePath Point+  | CmdType Bool FilePath Point   | CmdSplit FilePath Point   | CmdSig FilePath Point   | CmdAuto FilePath Point@@ -215,12 +215,12 @@ strArg :: String -> Parser String strArg = argument str . metavar -filesArgsSpec :: ([String] -> b) -> Parser b-filesArgsSpec x = x <$> some (strArg "FILES..")+filesArgsSpec :: Parser ([String] -> b) -> Parser b+filesArgsSpec x = x <*> some (strArg "FILES..") -locArgSpec :: (String -> (Int, Int) -> b) -> Parser b+locArgSpec :: Parser (String -> (Int, Int) -> b) -> Parser b locArgSpec x = x-  <$> strArg "FILE"+  <*> strArg "FILE"   <*> ( (,)         <$> argument int (metavar "LINE")         <*> argument int (metavar "COL")@@ -256,22 +256,30 @@             <=> short 'd'             <=> help "Print symbols with accompanying signature"         <*> switch+            $$  long "parents"+            <=> short 'p'+            <=> help "Print symbols parents"+        <*> switch             $$  long "qualified"             <=> short 'q'             <=> help "Qualify symbols"       )   <*> some (strArg "MODULE")-debugComponentArgSpec = filesArgsSpec CmdDebugComponent-checkArgSpec = filesArgsSpec CmdCheck-expandArgSpec = filesArgsSpec CmdExpand+debugComponentArgSpec = filesArgsSpec (pure CmdDebugComponent)+checkArgSpec = filesArgsSpec (pure CmdCheck)+expandArgSpec = filesArgsSpec (pure CmdExpand) infoArgSpec = CmdInfo     <$> strArg "FILE"     <*> strArg "SYMBOL"-typeArgSpec = locArgSpec CmdType-autoArgSpec = locArgSpec CmdAuto-splitArgSpec = locArgSpec CmdSplit-sigArgSpec = locArgSpec CmdSig-refineArgSpec = locArgSpec CmdRefine <*> strArg "SYMBOL"+typeArgSpec = locArgSpec $ CmdType <$>+        switch+          $$  long "constraints"+          <=> short 'c'+          <=> help "Include constraints into type signature"+autoArgSpec = locArgSpec (pure CmdAuto)+splitArgSpec = locArgSpec (pure CmdSplit)+sigArgSpec = locArgSpec (pure CmdSig)+refineArgSpec = locArgSpec (pure CmdRefine) <*> strArg "SYMBOL" mapArgSpec = CmdMapFile <$> strArg "FILE" unmapArgSpec = CmdUnmapFile <$> strArg "FILE" legacyInteractiveArgSpec = const CmdLegacyInteractive <$>

@@ -1,48 +0,0 @@--- 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/>.--module GHCMod.Options.DocUtils (-  ($$),-  ($$$),-  (<=>),-  (<$$>),-  (<||>)-) where--import Options.Applicative-import Data.Monoid-import Prelude--infixl 6 <||>-infixr 7 <$$>-infixr 7 $$-infixr 8 <=>-infixr 9 $$$--($$) :: (a -> b) -> a -> b-($$) = ($)--($$$) :: (a -> b) -> a -> b-($$$) = ($)--(<||>) :: Alternative a => a b -> a b -> a b-(<||>) = (<|>)--(<=>) :: Monoid m => m -> m -> m-(<=>) = (<>)--(<$$>) :: Functor f => (a -> b) -> f a -> f b-(<$$>) = (<$>)

@@ -1,79 +0,0 @@--- 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, FlexibleInstances, GeneralizedNewtypeDeriving #-}--module GHCMod.Options.Help where--import Options.Applicative-import Options.Applicative.Help.Pretty (Doc)-import qualified Options.Applicative.Help.Pretty as PP-import Control.Monad.State-import GHC.Exts( IsString(..) )-import Data.Maybe-import Data.Monoid-import Prelude--newtype MyDocM s a = MyDoc {unwrapState :: State s a}-  deriving (Monad, Functor, Applicative, MonadState s)-type MyDoc = MyDocM (Maybe Doc) ()--instance IsString (MyDocM (Maybe Doc) a) where-    fromString = append . para--instance Monoid (MyDocM (Maybe Doc) ()) where-  mappend a b = append $ doc a <> doc b-  mempty = append PP.empty--para :: String -> Doc-para = PP.fillSep . map PP.text . words--append :: Doc -> MyDocM (Maybe Doc) a-append s = modify m >> return undefined-  where-    m :: Maybe Doc -> Maybe Doc-    m Nothing = Just s-    m (Just old) = Just $ old PP..$. s--infixr 7 \\-(\\) :: MyDoc -> MyDoc -> MyDoc-(\\) a b = append $ doc a PP.<+> doc b--doc :: MyDoc -> Doc-doc = fromMaybe PP.empty . flip execState Nothing . unwrapState--help' :: MyDoc -> Mod f a-help' = helpDoc . Just . doc--desc :: MyDoc -> InfoMod a-desc = footerDoc . Just . doc . indent 2--code :: MyDoc -> MyDoc-code x = do-  _ <- " "-  indent 4 x-  " "--progDesc' :: MyDoc -> InfoMod a-progDesc' = progDescDoc . Just . doc--indent :: Int -> MyDoc -> MyDoc-indent n = append . PP.indent n . doc--int' :: Int -> MyDoc-int' = append . PP.int--para' :: String -> MyDoc-para' = append . para

@@ -58,7 +58,7 @@         it "emits warnings generated in GHC's desugar stage" $ do             withDirectory_ "test/data/check-missing-warnings" $ do                 res <- runD $ checkSyntax ["DesugarWarnings.hs"]-                res `shouldBe` "DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched: _ : _\n"+                res `shouldSatisfy` ("DesugarWarnings.hs:4:9:Warning: Pattern match(es) are non-exhaustive\NULIn a case alternative: Patterns not matched:" `isPrefixOf`) #endif          it "works with cabal builtin preprocessors" $ do@@ -71,7 +71,9 @@         it "Uses the right qualification style" $ do             withDirectory_ "test/data/nice-qualification" $ do                 res <- runD $ checkSyntax ["NiceQualification.hs"]-#if __GLASGOW_HASKELL__ >= 708+#if __GLASGOW_HASKELL__ >= 800+                res `shouldBe` "NiceQualification.hs:4:8:\8226 Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NUL\8226 In the expression: \"wrong type\"\NUL  In an equation for \8216main\8217: main = \"wrong type\"\n"+#elif __GLASGOW_HASKELL__ >= 708                 res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type \8216IO ()\8217 with actual type \8216[Char]\8217\NULIn the expression: \"wrong type\"\NULIn an equation for \8216main\8217: main = \"wrong type\"\n" #else                 res `shouldBe` "NiceQualification.hs:4:8:Couldn't match expected type `IO ()' with actual type `[Char]'\NULIn the expression: \"wrong type\"\NULIn an equation for `main': main = \"wrong type\"\n"

@@ -123,24 +123,30 @@             res <- runD $ do               loadMappedFile "File.hs" "File_Redir_Lint.hs"               lint defaultLintOpts "File.hs"-            res `shouldBe` "File.hs:4:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+            res `shouldBe` "File.hs:4:1: Warning: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"         it "lints in-memory file if one is specified and outputs original filename" $ do           withDirectory_ "test/data/file-mapping" $ do             res <- runD $ do               loadMappedFileSource "File.hs" "func a b = (++) a b\n"               lint defaultLintOpts "File.hs"-            res `shouldBe` "File.hs:1:1: Error: Eta reduce\NULFound:\NUL  func a b = (++) a b\NULWhy not:\NUL  func = (++)\n"+            res `shouldBe` "File.hs:1:1: Warning: Eta reduce\NULFound:\NUL  func a b = (++) a b\NULWhy not:\NUL  func = (++)\n"         it "shows types of the expression for redirected files" $ do             let tdir = "test/data/file-mapping"             res <- runD' tdir $ do               loadMappedFile "File.hs" "File_Redir_Lint.hs"-              types "File.hs" 4 12+              types False "File.hs" 4 12             res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"a -> a -> a\"\n"+        it "shows types of the expression with constraints for redirected files" $ do --+            let tdir = "test/data/file-mapping"+            res <- runD' tdir $ do+              loadMappedFile "File.hs" "File_Redir_Lint.hs"+              types True "File.hs" 4 12+            res `shouldBe` "4 12 4 15 \"a -> a -> a\"\n4 12 4 17 \"a -> a\"\n4 12 4 19 \"a\"\n4 1 4 19 \"Num a => a -> a -> a\"\n"         it "shows types of the expression for in-memory files" $ do             let tdir = "test/data/file-mapping"             res <- runD' tdir $ do               loadMappedFileSource "File.hs" "main = putStrLn \"Hello!\""-              types "File.hs" 1 14+              types False "File.hs" 1 14             res `shouldBe` "1 8 1 16 \"String -> IO ()\"\n1 8 1 25 \"IO ()\"\n1 1 1 25 \"IO ()\"\n"         it "shows info for the expression for redirected files" $ do             let tdir = "test/data/file-mapping"@@ -184,14 +190,14 @@             res <- runD $ do               loadMappedFile "File.hs" "File_Redir_Lint.hs"               lint defaultLintOpts "File.hs"-            res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+            res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"         it "lints in-memory file if one is specified and outputs original filename" $ do           withDirectory_ "test/data/file-mapping/preprocessor" $ do             src <- readFile "File_Redir_Lint.hs"             res <- runD $ do               loadMappedFileSource "File.hs" src               lint defaultLintOpts "File.hs"-            res `shouldBe` "File.hs:6:1: Error: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"+            res `shouldBe` "File.hs:6:1: Warning: Eta reduce\NULFound:\NUL  func a b = (*) a b\NULWhy not:\NUL  func = (*)\n"       describe "literate haskell tests" $ do         it "checks redirected file if one is specified and outputs original filename" $ do           withDirectory_ "test/data/file-mapping/lhs" $ do@@ -234,7 +240,7 @@                        ,("Bar.hs", tmpdir </> "Bar_Redir.hs")]               res <- run defaultOptions $ do                 mapM_ (uncurry loadMappedFile) fm-                types "Bar.hs" 5 1+                types False "Bar.hs" 5 1               res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]         it "works with a memory module using TemplateHaskell" $ do           srcFoo <- readFile "test/data/template-haskell/Foo.hs"@@ -244,5 +250,5 @@                      ,("Bar.hs", srcBar)]             res <- run defaultOptions $ do               mapM_ (uncurry loadMappedFileSource) fm-              types "Bar.hs" 5 1+              types False "Bar.hs" 5 1             res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]

@@ -9,6 +9,6 @@ spec :: Spec spec = do     describe "flags" $ do-        it "contains at least `-fno-warn-orphans'" $ do+        it "contains at least `-fprint-explicit-foralls" $ do             f <- runD $ lines <$> flags-            f `shouldContain` ["-fno-warn-orphans"]+            f `shouldContain` ["-fprint-explicit-foralls"]

@@ -19,17 +19,31 @@     describe "types" $ do         it "shows types of the expression and its outers" $ do             let tdir = "test/data/ghc-mod-check"-            res <- runD' tdir $ types "lib/Data/Foo.hs" 9 5+            res <- runD' tdir $ types False "lib/Data/Foo.hs" 9 5+#if __GLASGOW_HASKELL__ >= 800+            res `shouldBe` "9 5 11 40 \"Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+#else             res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+#endif ++        it "shows types of the expression with constraints and its outers" $ do+            let tdir = "test/data/ghc-mod-check"+            res <- runD' tdir $ types True "lib/Data/Foo.hs" 9 5+#if __GLASGOW_HASKELL__ >= 800+            res `shouldBe` "9 5 11 40 \"Num t => Int -> t -> t -> t\"\n7 1 11 40 \"Int -> Integer\"\n"+#else+            res `shouldBe` "9 5 11 40 \"Num a => Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"+#endif+         it "works with a module using TemplateHaskell" $ do             let tdir = "test/data/template-haskell"-            res <- runD' tdir $ types "Bar.hs" 5 1+            res <- runD' tdir $ types False "Bar.hs" 5 1             res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]          it "works with a module that imports another module using TemplateHaskell" $ do             let tdir = "test/data/template-haskell"-            res <- runD' tdir $ types "ImportsTH.hs" 3 8+            res <- runD' tdir $ types False "ImportsTH.hs" 3 8             res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]      describe "info" $ do

@@ -9,7 +9,7 @@     describe "lint" $ do         it "can detect a redundant import" $ do             res <- runD $ lint defaultLintOpts "test/data/hlint/hlint.hs"-            res `shouldBe` "test/data/hlint/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"+            res `shouldBe` "test/data/hlint/hlint.hs:4:8: Warning: Redundant do\NULFound:\NUL  do putStrLn \"Hello, world!\"\NULWhy not:\NUL  putStrLn \"Hello, world!\"\n"          context "when no suggestions are given" $ do             it "doesn't output an empty line" $ do

@@ -23,6 +23,8 @@            mv_ex :: MVar (Either SomeException ())               <- newEmptyMVar+          mv_startup_barrier :: MVar ()+              <- newEmptyMVar           mv_startup_barrier :: MVar () <- newEmptyMVar            _t1 <- forkOS $ do@@ -33,6 +35,19 @@            _t2 <- forkOS $ do                  readMVar mv_startup_barrier -- wait for t1 to start up+                 res <- try $ runD $ return ()+                 res' <- evaluate res+                 putMVar mv_ex res'++          _t1 <- forkOS $ do+                 -- wait (inside GhcModT) for t2 to receive the exception+                 _ <- runD $ liftIO $ do+                            putMVar mv_startup_barrier ()+                            readMVar mv_ex+                 return ()++          _t2 <- forkOS $ do+                 readMVar mv_startup_barrier -- wait for t1 to be in GhcModT                  res <- try $ runD $ return ()                  res' <- evaluate res                  putMVar mv_ex res'

@@ -16,12 +16,12 @@     describe "getSandboxDb" $ do         it "can parse a config file and extract the sandbox package-db" $ do             cwd <- getCurrentDirectory-            Just crdl <- runMaybeT $ plainCradle "test/data/cabal-project"+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/cabal-project"             Just db <- getSandboxDb crdl             db `shouldSatisfy` isPkgDbAt (cwd </> "test/data/cabal-project/.cabal-sandbox")          it "returns Nothing if the sandbox config file is broken" $ do-            Just crdl <- runMaybeT $ plainCradle "test/data/broken-sandbox"+            Just crdl <- runLogDef $ runMaybeT $ plainCradle "test/data/broken-sandbox"             getSandboxDb crdl  `shouldReturn` Nothing      describe "findCabalFile" $ do

@@ -6,6 +6,7 @@   , runE   , runNullLog   , runGmOutDef+  , runLogDef   , shouldReturnError   , isPkgDbAt   , isPkgConfDAt@@ -43,10 +44,6 @@     Right a ->  return a     Left e -> error $ show e -withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a-withSpecCradle cradledir f = do-    gbracket (runJournalT $ findSpecCradle cradledir) (liftIO . cleanupCradle . fst) f- runGhcModTSpec :: Options -> GhcModT IO a -> IO (Either GhcModError a, GhcModLog) runGhcModTSpec opt action = do   dir <- getCurrentDirectory@@ -59,7 +56,14 @@     withGhcModEnv' withSpecCradle dir' opt $ \(env,_) -> do       first (fst <$>) <$> runGhcModT' env defaultGhcModState         (gmSetLogLevel (ooptLogLevel $ optOutput opt) >> action)+ where+   withSpecCradle :: (IOish m, GmOut m) => FilePath -> ((Cradle, GhcModLog) -> m a) -> m a+   withSpecCradle cradledir f =+     gbracket+       (runJournalT $ findSpecCradle (optPrograms opt) cradledir)+       (liftIO . cleanupCradle . fst) f + -- | Run GhcMod run :: Options -> GhcModT IO a -> IO a run opt a = extract $ runGhcModTSpec opt a@@ -87,6 +91,9 @@  runGmOutDef :: IOish m => GmOutT m a -> m a runGmOutDef = runGmOutT defaultOptions++runLogDef :: IOish m => GmOutT (JournalT GhcModLog m) a -> m a+runLogDef = fmap fst . runJournalT . runGmOutDef  shouldReturnError :: Show a                   => IO (Either GhcModError a, GhcModLog)

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

@@ -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

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

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

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