From 2f82d5cdf433754f06fb36f7a8e5bac8b674d574 Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Thu, 3 Mar 2016 23:01:20 +0300 Subject: [PATCH 1/5] Change loadTargets stderr loglevel to Debug Closes #763 --- Language/Haskell/GhcMod/Target.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Language/Haskell/GhcMod/Target.hs b/Language/Haskell/GhcMod/Target.hs index 536842b..67fa140 100644 --- a/Language/Haskell/GhcMod/Target.hs +++ b/Language/Haskell/GhcMod/Target.hs @@ -464,7 +464,7 @@ loadTargets opts targetStrs = do HscNothing -> do void $ load LoadAllTargets forM_ mg $ - handleSourceError (gmLog GmWarning "loadTargets" . text . show) + handleSourceError (gmLog GmDebug "loadTargets" . text . show) . void . (parseModule >=> typecheckModule >=> desugarModule) HscInterpreted -> do void $ load LoadAllTargets From dbe1c83a2cefdce015be3aae0ff9715aa29610c3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 2 Mar 2016 00:38:40 +0100 Subject: [PATCH 2/5] Bump lower bound on hlint The Error -> Warning changes in older versions of hlint break the tests otherwise --- ghc-mod.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index c7b1f9f..f583ca5 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -172,7 +172,7 @@ Library , ghc < 8.2 && >= 7.6 , ghc-paths < 0.2 , ghc-syb-utils < 0.3 - , hlint < 1.10 && >= 1.9.26 + , hlint < 1.10 && >= 1.9.27 , monad-journal < 0.8 && >= 0.4 , old-time < 1.2 , pretty < 1.2 From 59ade0d447b34931bb5813ddec10e9c313531556 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Gr=C3=B6ber?= Date: Wed, 9 Mar 2016 21:43:19 +0100 Subject: [PATCH 3/5] Add more version information to debug command --- Language/Haskell/GhcMod/Debug.hs | 31 ++++++++++++++++++++++++++----- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 2fd7bb0..48f7137 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -7,6 +7,7 @@ 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 Text.PrettyPrint import Language.Haskell.GhcMod.Monad @@ -17,6 +18,11 @@ import Language.Haskell.GhcMod.Pretty import Language.Haskell.GhcMod.Utils import Language.Haskell.GhcMod.Cradle import Language.Haskell.GhcMod.Stack +import Language.Haskell.GhcMod.Output + +import Paths_ghc_mod (version) + +import Config (cProjectVersion) ---------------------------------------------------------------- @@ -34,14 +40,20 @@ debugInfo = do pkgOpts <- packageGhcOptions + readProc <- gmReadProcess + + ghcVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc "ghc" ["--numeric-version"] "" + return $ unlines $ - [ "Root directory: " ++ cradleRootDir + [ "Version: ghc-mod-" ++ showVersion version + , "Library GHC Version: " ++ cProjectVersion + , "System GHC Version: " ++ ghcVersion + , "Root directory: " ++ cradleRootDir , "Current directory: " ++ cradleCurrentDir , "GHC Package flags:\n" ++ render (nest 4 $ fsep $ map text pkgOpts) , "GHC System libraries: " ++ ghcLibDir - , "GHC user options:\n" ++ render (nest 4 $ - fsep $ map text optGhcUserOptions) ] ++ cabal stackPaths :: IOish m => GhcModT m [String] @@ -63,9 +75,18 @@ cabalDebug = do opts = Map.map gmcGhcOpts mcs srcOpts = Map.map gmcGhcSrcOpts mcs + readProc <- gmReadProcess + cabalInstVersion <- liftIO $ + dropWhileEnd isSpace <$> readProc "cabal" ["--numeric-version"] "" + 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 $ From dcaf95b4e3fe8f62c504a0ba8cffbb5f3210299a Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Tue, 15 Mar 2016 21:43:27 +0300 Subject: [PATCH 4/5] Fix file-map for case-split --- Language/Haskell/GhcMod/CaseSplit.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 7c98f6e..7bcd3fa 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -27,6 +27,7 @@ import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.Doc import Language.Haskell.GhcMod.Logging import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Utils (withMappedFile) import Language.Haskell.GhcMod.FileMapping (fileModSummaryWithMapping) ---------------------------------------------------------------- @@ -57,12 +58,14 @@ splits file lineNo colNo = 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 $ + t <- withMappedFile file $ \file' -> + 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 $ + t <- withMappedFile file $ \file' -> + genCaseSplitTextFile file' (SplitToTextInfo varName' bndLoc varLoc $ getTyCons dflag style varName varT) return (fourInts bndLoc, t) where From 11a1ad2cf3e75fc6b7604cdbb60d573421ec7d5a Mon Sep 17 00:00:00 2001 From: Nikolay Yakimov Date: Fri, 29 Jan 2016 01:51:40 +0300 Subject: [PATCH 5/5] Fix mapping subst in info for insts add type fams --- Language/Haskell/GhcMod/Gap.hs | 38 ++++++++++++++++++++++++++-------- 1 file changed, 29 insertions(+), 9 deletions(-) diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 48337e0..bf38e1c 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -75,6 +75,10 @@ import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB +#if __GLASGOW_HASKELL__ >= 710 +import CoAxiom (coAxiomTyCon) +#endif + #if __GLASGOW_HASKELL__ >= 708 import FamInstEnv import ConLike (ConLike(..)) @@ -357,28 +361,44 @@ pprInfo :: (FilePath -> FilePath) -> Bool -> (TyThing, GHC.Fixity, [ClsInst], [F 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)