Merge pull request #129 from co-dan/ghc77

Porting ghc-mod to GHC 7.7
2013-07-05 00:03:57 -07:00 · 2013-07-05 00:03:57 -07:00 · 7bd3510dc8
commit 7bd3510dc8
parent 1811f11a07 dd03fc4c2c
6 changed files with 132 additions and 61 deletions
--- a/Language/Haskell/GhcMod/Browse.hs
+++ b/Language/Haskell/GhcMod/Browse.hs
@ -7,6 +7,7 @@ import Data.Maybe (fromMaybe)
 import DataCon (dataConRepType)
 import GHC
 import Language.Haskell.GhcMod.Doc
+import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Types
 import Name
@ -102,4 +103,4 @@ removeForAlls' ty (Just (pre, ftype))
    | otherwise           = ty

 showOutputable :: Outputable a => DynFlags -> a -> String
-showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr
+showOutputable dflag = unwords . lines . Gap.showUnqualifiedPage dflag . ppr
--- a/Language/Haskell/GhcMod/Doc.hs
+++ b/Language/Haskell/GhcMod/Doc.hs
@ -1,22 +1,16 @@
 module Language.Haskell.GhcMod.Doc where

 import DynFlags (DynFlags)
-import Language.Haskell.GhcMod.Gap (withStyle)
+import Language.Haskell.GhcMod.Gap (withStyle, styleUnqualified)
 import Outputable
 import Pretty

 styleQualified :: PprStyle
 styleQualified = mkUserStyle alwaysQualify AllTheWay

-styleUnqualified :: PprStyle
-styleUnqualified = mkUserStyle neverQualify AllTheWay
-
 showQualifiedPage :: DynFlags -> SDoc -> String
 showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified

-showUnqualifiedPage :: DynFlags -> SDoc -> String
-showUnqualifiedPage dflag = showDocWith PageMode . withStyle dflag styleUnqualified
-
 showQualifiedOneLine :: DynFlags -> SDoc -> String
 showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified

--- a/Language/Haskell/GhcMod/ErrMsg.hs
+++ b/Language/Haskell/GhcMod/ErrMsg.hs
@ -73,7 +73,7 @@ ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"
 ----------------------------------------------------------------

 showMsg :: DynFlags -> SDoc -> String
-showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc
+showMsg dflag sdoc = map toNull $ Gap.showUnqualifiedPage dflag sdoc
  where
    toNull '\n' = '\0'
    toNull x = x
--- a/Language/Haskell/GhcMod/GHCApi.hs
+++ b/Language/Haskell/GhcMod/GHCApi.hs
@ -25,6 +25,7 @@ import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.ErrMsg
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Types
+import qualified Language.Haskell.GhcMod.Gap as Gap
 import System.Exit
 import System.IO

@ -107,24 +108,13 @@ modifyFlags d0 idirs mDepPkgs splice build
  where
    d1 = d0 { importPaths = idirs }
    d2 = setFastOrNot d1 Fast
-    d3 = maybe d2 (addDevPkgs d2) mDepPkgs
-    d4 | build == CabalPkg = setCabalPkg d3
+    d3 = maybe d2 (Gap.addDevPkgs d2) mDepPkgs
+    d4 | build == CabalPkg = Gap.setCabalPkg d3
       | otherwise         = d3

-setCabalPkg :: DynFlags -> DynFlags
-setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
-
 setSplice :: DynFlags -> DynFlags
 setSplice dflag = dopt_set dflag Opt_D_dump_splices

-addDevPkgs :: DynFlags -> [Package] -> DynFlags
-addDevPkgs df pkgs = df''
-  where
-    df' = dopt_set df Opt_HideAllPackages
-    df'' = df' {
-        packageFlags = map ExposePackage pkgs ++ packageFlags df
-      }
-
 ----------------------------------------------------------------

 setFastOrNot :: DynFlags -> CheckSpeed -> DynFlags
--- a/Language/Haskell/GhcMod/Gap.hs
+++ b/Language/Haskell/GhcMod/Gap.hs
@ -1,9 +1,11 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}

 module Language.Haskell.GhcMod.Gap (
    Language.Haskell.GhcMod.Gap.ClsInst
  , mkTarget
  , withStyle
+  , styleUnqualified
+  , showUnqualifiedPage
  , setLogAction
  , supportedExtensions
  , getSrcSpan
@ -13,6 +15,12 @@ module Language.Haskell.GhcMod.Gap (
  , toStringBuffer
  , liftIO
  , showSeverityCaption
+  , setCabalPkg
+  , addDevPkgs
+  , filterOutChildren
+  , infoThing
+  , pprInfo
+  , HasType(..)
 #if __GLASGOW_HASKELL__ >= 702
 #else
  , module Pretty
@ -22,18 +30,32 @@ module Language.Haskell.GhcMod.Gap (
 import Control.Applicative hiding (empty)
 import Control.Monad
 import Data.Time.Clock
+import Data.List
+import Data.Maybe
 import DynFlags
 import ErrUtils
 import FastString
-import GHC
 import Language.Haskell.GhcMod.GHCChoice
+import Language.Haskell.GhcMod.Types hiding (convert)
 import Outputable
 import StringBuffer
+import TcType
+import NameSet
+import HscTypes
+import PprTyThing

 import qualified InstEnv
 import qualified Pretty
 import qualified StringBuffer as SB
+#if __GLASGOW_HASKELL__ >= 707
+import FamInstEnv
+#endif

+#if __GLASGOW_HASKELL__ >= 706
+import GHC hiding (ClsInst)
+#else
+import GHC hiding (Instance)
+#endif

 #if __GLASGOW_HASKELL__ >= 702
 import CoreMonad (liftIO)
@ -42,8 +64,9 @@ import HscTypes (liftIO)
 import Pretty
 #endif

+
 #if __GLASGOW_HASKELL__ < 706
-import Control.Arrow
+import Control.Arrow hiding ((<+>))
 import Data.Convertible
 #endif

@ -94,6 +117,16 @@ setLogAction df f =
 ----------------------------------------------------------------
 ----------------------------------------------------------------

+showUnqualifiedPage :: DynFlags -> SDoc -> String
+showUnqualifiedPage dflag = Pretty.showDocWith Pretty.PageMode
+                          . withStyle dflag styleUnqualified
+
+styleUnqualified :: PprStyle
+styleUnqualified = mkUserStyle neverQualify AllTheWay
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
 supportedExtensions :: [String]
 #if __GLASGOW_HASKELL__ >= 700
 supportedExtensions = supportedLanguagesAndExtensions
@ -180,3 +213,90 @@ showSeverityCaption _          = ""
 #else
 showSeverityCaption = const ""
 #endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+setCabalPkg :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 707
+setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage
+#else
+setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
+#endif
+
+----------------------------------------------------------------
+
+addDevPkgs :: DynFlags -> [Package] -> DynFlags
+addDevPkgs df pkgs = df''
+  where
+#if __GLASGOW_HASKELL__ >= 707
+    df' = gopt_set df Opt_HideAllPackages
+#else    
+    df' = dopt_set df Opt_HideAllPackages
+#endif          
+    df'' = df' {
+        packageFlags = map ExposePackage pkgs ++ packageFlags df
+      }
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+class HasType a where
+    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
+
+
+instance HasType (LHsBind Id) where
+#if __GLASGOW_HASKELL__ >= 707
+    getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ)
+      where typ = mkFunTys in_tys out_typ
+#else    
+    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
+#endif                                                                
+    getType _ _ = return Nothing
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+-- from ghc/InteractiveUI.hs
+
+filterOutChildren :: (a -> TyThing) -> [a] -> [a]
+filterOutChildren get_thing xs
+    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
+  where
+    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
+
+
+infoThing :: String -> Ghc String
+infoThing str = do
+    names <- parseName str
+#if __GLASGOW_HASKELL__ >= 707
+    mb_stuffs <- mapM (getInfo False) names
+    let filtered = filterOutChildren (\(t,_f,_i,_fam) -> t) (catMaybes mb_stuffs)
+#else    
+    mb_stuffs <- mapM getInfo names
+    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
+#endif
+    dflag <- getSessionDynFlags
+    return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
+
+#if __GLASGOW_HASKELL__ >= 707
+pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
+pprInfo pefas (thing, fixity, insts, famInsts)
+    = pprTyThingInContextLoc pefas thing
+   $$ show_fixity fixity
+   $$ InstEnv.pprInstances insts
+   $$ pprFamInsts famInsts
+  where
+    show_fixity fx
+      | fx == defaultFixity = Outputable.empty
+      | otherwise           = ppr fx <+> ppr (getName thing)
+#else    
+pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst]) -> SDoc
+pprInfo pefas (thing, fixity, insts)
+    = pprTyThingInContextLoc pefas thing
+   $$ show_fixity fixity
+   $$ vcat (map pprInstance insts)
+  where
+    show_fixity fx
+      | fx == defaultFixity = Outputable.empty
+      | otherwise           = ppr fx <+> ppr (getName thing)
+#endif
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@ -25,8 +25,8 @@ import Language.Haskell.GhcMod.Doc
 import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.GHCChoice
 import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Gap (HasType(..))
 import Language.Haskell.GhcMod.Types
-import NameSet
 import Outputable
 import PprTyThing
 import TcHsSyn (hsPatType)
@ -57,13 +57,10 @@ info :: Options
 info opt cradle file modstr expr =
    inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info"
  where
-    exprToInfo = infoThing expr
+    exprToInfo = Gap.infoThing expr

 ----------------------------------------------------------------

-class HasType a where
-    getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
-
 instance HasType (LHsExpr Id) where
    getType tcm e = do
        hs_env <- getSession
@ -74,10 +71,6 @@ instance HasType (LHsExpr Id) where
        rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm
        ty_env = tcg_type_env $ fst $ tm_internals_ tcm

-instance HasType (LHsBind Id) where
-    getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)
-    getType _ _ = return Nothing
-
 instance HasType (LPat Id) where
    getType _ (L spn pat) = return $ Just (spn, hsPatType pat)

@ -142,33 +135,6 @@ listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))
 pretty :: DynFlags -> Type -> String
 pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False

----------------------------------------------------------------
-- from ghc/InteractiveUI.hs
-
-infoThing :: String -> Ghc String
-infoThing str = do
-    names <- parseName str
-    mb_stuffs <- mapM getInfo names
-    let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
-    dflag <- getSessionDynFlags
-    return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)
-
-filterOutChildren :: (a -> TyThing) -> [a] -> [a]
-filterOutChildren get_thing xs
-    = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
-  where
-    implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
-
-pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc
-pprInfo pefas (thing, fixity, insts)
-    = pprTyThingInContextLoc pefas thing
-   $$ show_fixity fixity
-   $$ vcat (map pprInstance insts)
-  where
-    show_fixity fx
-      | fx == defaultFixity = Outputable.empty
-      | otherwise           = ppr fx <+> ppr (getName thing)
-
 ----------------------------------------------------------------

 inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String