hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of https://github.com/bgamari/ghc-mod

Browse Source
This commit is contained in:
Daniel Gröber 2017-08-28 10:14:11 +02:00
commit 2af1a9b777
10 changed files with 102 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
GhcMod/Exe/Browse.hs
View File

@ -166,4 +166,5 @@ removeForAlls' ty (Just (pre, ftype))
| otherwise = ty
showOutputable :: Outputable a => DynFlags -> a -> String
showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr
showOutputable dflag =
unwords . lines . showPage dflag (styleUnqualified dflag) . ppr

12
GhcMod/Exe/FillSig.hs
View File

@ -116,7 +116,9 @@ getSignature modSum lineNo colNo = do
p@ParsedModule{pm_parsed_source = ps} <- G.parseModule modSum
-- Inspect the parse tree to find the signature
case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsDecl G.RdrName] of
#if __GLASGOW_HASKELL__ >= 800
#if __GLASGOW_HASKELL__ >= 802
[L loc (G.SigD (Ty.TypeSig names (G.HsWC _ (G.HsIB _ (L _ ty) _))))] ->
#elif __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) _))] ->
@ -133,7 +135,9 @@ getSignature modSum lineNo colNo = do
case Gap.getClass lst of
Just (clsName,loc) -> obtainClassInfo minfo clsName loc
_ -> return Nothing
#if __GLASGOW_HASKELL__ >= 800
#if __GLASGOW_HASKELL__ >= 802
[L loc (G.TyClD (G.FamDecl (G.FamilyDecl info (L _ name) (G.HsQTvs _ vars _) _ _ _)))] -> do
#elif __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
@ -365,7 +369,11 @@ refine file lineNo colNo (Expression expr) =
modSum <- fileModSummaryWithMapping file
p <- G.parseModule modSum
tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p
#if __GLASGOW_HASKELL__ >= 802
ety <- G.exprType G.TM_Inst expr
#else
ety <- G.exprType expr
#endif
whenFound oopts (findVar dflag style tcm tcs lineNo colNo) $
\(loc, name, rty, paren) ->
let eArgs = getFnArgs ety

12
GhcMod/Exe/Test.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module GhcMod.Exe.Test where
import Control.Applicative
@ -36,6 +38,15 @@ test f = runGmlT' [Left f] (fmap setHscInterpreted . deferErrors) $ do
return ""
#if __GLASGOW_HASKELL__ >= 802
runTest :: GhcMonad m => String -> m (Maybe SomeException)
runTest fn = do
res <- execStmt ("quickCheck " ++ fn) execOptions
return $ case res of
ExecComplete (Right _) _ -> Nothing
ExecComplete (Left se) _ -> Just se
_ -> error "runTest"
#else
runTest :: GhcMonad m => String -> m (Maybe SomeException)
runTest fn = do
res <- runStmt ("quickCheck " ++ fn) RunToCompletion
@ -43,3 +54,4 @@ runTest fn = do
RunOk [] -> Nothing
RunException se -> Just se
_ -> error "runTest"
#endif

19
core/GhcMod/Doc.hs
View File

@ -1,8 +1,13 @@
{-# LANGUAGE CPP #-}
module GhcMod.Doc where
import GHC
import GhcMod.Gap (withStyle, showDocWith)
import Outputable
#if __GLASGOW_HASKELL__ >= 802
import DynFlags
#endif
import Pretty (Mode(..))
showPage :: DynFlags -> PprStyle -> SDoc -> String
@ -14,7 +19,17 @@ showOneLine dflag style = showDocWith dflag OneLineMode . withStyle dflag style
getStyle :: GhcMonad m => m PprStyle
getStyle = do
unqual <- getPrintUnqual
#if __GLASGOW_HASKELL__ >= 802
dflags <- getDynFlags
return $ mkUserStyle dflags unqual AllTheWay
#else
return $ mkUserStyle unqual AllTheWay
#endif
styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay
styleUnqualified :: DynFlags -> PprStyle
styleUnqualified dflags =
#if __GLASGOW_HASKELL__ >= 802
mkUserStyle dflags neverQualify AllTheWay
#else
mkUserStyle neverQualify AllTheWay
#endif

14
core/GhcMod/DynFlags.hs
View File

@ -1,4 +1,6 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE CPP #-}
module GhcMod.DynFlags where
@ -14,6 +16,12 @@ import GhcMod.DynFlagsTH
import System.IO.Unsafe (unsafePerformIO)
import Prelude
-- For orphans
#if __GLASGOW_HASKELL__ == 802
import Util (OverridingBool(..))
import PprColour
#endif
setEmptyLogger :: DynFlags -> DynFlags
setEmptyLogger df =
Gap.setLogAction df $ \_ _ _ _ _ _ -> return ()
@ -102,6 +110,12 @@ deferErrors df = return $
----------------------------------------------------------------
#if __GLASGOW_HASKELL__ == 802
deriving instance Eq OverridingBool
deriving instance Eq PprColour.Scheme
deriving instance Eq PprColour.PprColour
#endif
deriveEqDynFlags [d|
eqDynFlags :: DynFlags -> DynFlags -> [[(Bool, String)]]
eqDynFlags = undefined

2
core/GhcMod/DynFlagsTH.hs
View File

@ -76,7 +76,9 @@ deriveEqDynFlags qds = do
]
ignoredTypeNames =
[ "LogAction"
, "LogFinaliser"
, "PackageState"
, "IO"
, "Hooks"
, "FlushOut"
, "FlushErr"

20
core/GhcMod/Gap.hs
View File

@ -5,7 +5,7 @@ module GhcMod.Gap (
, mkTarget
, withStyle
, GmLogAction
, setLogAction
, GhcMod.Gap.setLogAction
, getSrcSpan
, getSrcFile
, withInteractiveContext
@ -87,6 +87,9 @@ import qualified StringBuffer as SB
#if __GLASGOW_HASKELL__ >= 710
import CoAxiom (coAxiomTyCon)
#endif
#if __GLASGOW_HASKELL__ >= 802
import IfaceSyn (showToIface)
#endif
#if __GLASGOW_HASKELL__ >= 708
import FamInstEnv
@ -442,7 +445,11 @@ pprInfo m pefas (thing, fixity, insts)
| fx == defaultFixity = Outputable.empty
| otherwise = ppr fx <+> ppr (getName thing)
#if __GLASGOW_HASKELL__ >= 708
#if __GLASGOW_HASKELL__ >= 802
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext showToIface thing')
#else
pprTyThingInContextLoc' thing' = showWithLoc (pprDefinedAt' thing') (pprTyThingInContext thing')
#endif
#if __GLASGOW_HASKELL__ >= 710
pprFamInst' (FamInst { fi_flavor = DataFamilyInst rep_tc })
= pprTyThingInContextLoc (ATyCon rep_tc)
@ -570,7 +577,12 @@ type GLMatchI = LMatch Id
#endif
getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan)
#if __GLASGOW_HASKELL__ >= 800
#if __GLASGOW_HASKELL__ >= 802
-- 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__ >= 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)
@ -668,7 +680,11 @@ parseModuleHeader str dflags filename =
#endif
POk pst rdr_module ->
#if __GLASGOW_HASKELL__ >= 802
let (warns,_) = getMessages pst dflags in
#else
let (warns,_) = getMessages pst in
#endif
Right (warns, rdr_module)
mkErrStyle' :: DynFlags -> PrintUnqualified -> PprStyle

9
core/GhcMod/LightGhc.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE CPP #-}
module GhcMod.LightGhc where
import Control.Monad
@ -6,7 +8,9 @@ import Data.IORef
import GHC
import GHC.Paths (libdir)
#if __GLASGOW_HASKELL__ < 802
import StaticFlags
#endif
import SysTools
import DynFlags
import HscMain
@ -17,6 +21,11 @@ import GhcMod.Monad.Types
import GhcMod.DynFlags
import qualified GhcMod.Gap as Gap
#if __GLASGOW_HASKELL__ >= 802
initStaticOpts :: Monad m => m ()
initStaticOpts = return ()
#endif
-- We have to be more careful about tearing down 'HscEnv's since GHC 8 added an
-- out of process GHCI server which has to be shutdown.
newLightEnv :: IOish m => (DynFlags -> LightGhc DynFlags) -> m HscEnv

8
core/GhcMod/Pretty.hs
View File

@ -14,6 +14,8 @@
-- 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 #-}
module GhcMod.Pretty
( renderGm
, renderSDoc
@ -47,8 +49,14 @@ renderSDoc sdoc = do
gmComponentNameDoc :: ChComponentName -> Doc
gmComponentNameDoc ChSetupHsName = text $ "Setup.hs"
#if MIN_VERSION_cabal_helper(0,8,0)
gmComponentNameDoc ChLibName = text $ "library"
gmComponentNameDoc (ChSubLibName _)= text $ "library"
gmComponentNameDoc (ChFLibName _) = text $ "flibrary"
#else
gmComponentNameDoc (ChLibName "") = text $ "library"
gmComponentNameDoc (ChLibName n) = text $ "library:" ++ n
#endif
gmComponentNameDoc (ChExeName n) = text $ "exe:" ++ n
gmComponentNameDoc (ChTestName n) = text $ "test:" ++ n
gmComponentNameDoc (ChBenchName n) = text $ "bench:" ++ n

20
ghc-mod.cabal
View File

@ -183,7 +183,7 @@ Library
, time
, transformers
, base < 4.10 && >= 4.6.0.1
, base < 4.11 && >= 4.6.0.1
, djinn-ghc < 0.1 && >= 0.0.2.2
, extra < 1.6 && >= 1.4
, fclabels < 2.1 && >= 2.0
@ -204,7 +204,7 @@ Library
, transformers-base < 0.5 && >= 0.4.4
, cabal-helper < 0.8 && >= 0.7.3.0
, ghc < 8.2 && >= 7.6
, ghc < 8.4 && >= 7.6
if impl(ghc >= 8.0)
Build-Depends: ghc-boot
@ -230,14 +230,14 @@ Executable ghc-mod
, mtl
, process
, base < 4.10 && >= 4.6.0.1
, base < 4.11 && >= 4.6.0.1
, fclabels < 2.1 && >= 2.0
, monad-control < 1.1 && >= 1
, optparse-applicative < 0.14 && >= 0.13.0.0
, semigroups < 0.19 && >= 0.10.0
, split < 0.3 && >= 0.2.2
, ghc < 8.2 && >= 7.6
, ghc < 8.4 && >= 7.6
, ghc-mod
@ -262,7 +262,7 @@ Executable ghc-modi
, process
, time
, base < 4.10 && >= 4.6.0.1
, base < 4.11 && >= 4.6.0.1
, ghc-mod
@ -274,7 +274,7 @@ Test-Suite doctest
Ghc-Options: -Wall
Default-Extensions: ConstraintKinds, FlexibleContexts
Main-Is: doctests.hs
Build-Depends: base < 4.10 && >= 4.6.0.1
Build-Depends: base < 4.11 && >= 4.6.0.1
, doctest < 0.12 && >= 0.9.3
@ -321,7 +321,7 @@ Test-Suite spec
, process
, transformers
, base < 4.10 && >= 4.6.0.1
, base < 4.11 && >= 4.6.0.1
, fclabels < 2.1 && >= 2.0
, hspec < 2.4 && >= 2.0.0
, monad-journal < 0.8 && >= 0.4
@ -336,7 +336,7 @@ Test-Suite spec
Build-Depends:
cabal-helper < 0.8 && >= 0.7.1.0
, ghc < 8.2 && >= 7.6
, ghc < 8.4 && >= 7.6
, ghc-mod
@ -346,7 +346,7 @@ Test-Suite shelltest
Hs-Source-Dirs: shelltest
Type: exitcode-stdio-1.0
Build-Tools: shelltest
Build-Depends: base < 4.10 && >= 4.6.0.1
Build-Depends: base < 4.11 && >= 4.6.0.1
, process < 1.5
-- , shelltestrunner >= 1.3.5
if !flag(shelltest)
@ -366,7 +366,7 @@ Benchmark criterion
directory
, filepath
, base < 4.10 && >= 4.6.0.1
, base < 4.11 && >= 4.6.0.1
, criterion < 1.2 && >= 1.1.1.0
, temporary < 1.3 && >= 1.2.0.3