From 9eb446e24bc734d1c84af9b4cbe2325028ee9832 Mon Sep 17 00:00:00 2001
From: Daniil Frumin <difrumin@gmail.com>
Date: Tue, 2 Jul 2013 12:48:44 +0400
Subject: [PATCH] Moving all CPP stuff (that depends on GHC version) to Gap

- Moved some functions from Language.Haskell.GhcMod.Doc to Gap
- Moved HasType typeclass and some functions from Info to Gap
- Adjusted all the other modules to use necessary functions from Gap
  instead of the functions from modified modules
---
 Language/Haskell/GhcMod/Browse.hs |   3 +-
 Language/Haskell/GhcMod/Doc.hs    |   8 +-
 Language/Haskell/GhcMod/ErrMsg.hs |   2 +-
 Language/Haskell/GhcMod/GHCApi.hs |  25 +-----
 Language/Haskell/GhcMod/Gap.hs    | 121 +++++++++++++++++++++++++++++-
 Language/Haskell/GhcMod/Info.hs   |  69 +----------------
 6 files changed, 128 insertions(+), 100 deletions(-)

diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs
index 3347da3..f569810 100644
--- 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
diff --git a/Language/Haskell/GhcMod/Doc.hs b/Language/Haskell/GhcMod/Doc.hs
index 08be9f5..d502623 100644
--- 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
 
diff --git a/Language/Haskell/GhcMod/ErrMsg.hs b/Language/Haskell/GhcMod/ErrMsg.hs
index 91714c7..ae96f77 100644
--- 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
diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs
index 6026777..a96c2d6 100644
--- a/Language/Haskell/GhcMod/GHCApi.hs
+++ b/Language/Haskell/GhcMod/GHCApi.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE CPP #-}
 
 module Language.Haskell.GhcMod.GHCApi (
     withGHC
@@ -26,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
 
@@ -108,32 +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
-#if __GLASGOW_HASKELL__ >= 707
-setCabalPkg dflag = gopt_set dflag Opt_BuildingCabalPackage
-#else
-setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage
-#endif
-
 setSplice :: DynFlags -> DynFlags
 setSplice dflag = dopt_set dflag Opt_D_dump_splices
 
-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
-      }
-
 ----------------------------------------------------------------
 
 setFastOrNot :: DynFlags -> CheckSpeed -> DynFlags
diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs
index 495816b..033d86d 100644
--- 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,27 @@ 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 GHC hiding (ClsInst)
 import Language.Haskell.GhcMod.GHCChoice
+import Language.Haskell.GhcMod.Types
 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__ >= 702
 import CoreMonad (liftIO)
@@ -42,6 +59,7 @@ import HscTypes (liftIO)
 import Pretty
 #endif
 
+
 #if __GLASGOW_HASKELL__ < 706
 import Control.Arrow
 import Data.Convertible
@@ -94,6 +112,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 +208,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
diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs
index a1587ef..b6354d4 100644
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@@ -1,5 +1,5 @@
 {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-}
-{-# LANGUAGE Rank2Types, CPP #-}
+{-# LANGUAGE Rank2Types #-}
 
 module Language.Haskell.GhcMod.Info (
     infoExpr
@@ -18,26 +18,19 @@ import Data.Maybe
 import Data.Ord as O
 import Data.Time.Clock
 import Desugar
-#if __GLASGOW_HASKELL__ >= 707
-import FamInstEnv
-#endif  
 import GHC
 import GHC.SYB.Utils
 import HscTypes
-#if __GLASGOW_HASKELL__ >= 707  
-import InstEnv
-#endif  
 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)
 import TcRnTypes
-import TcType
 
 ----------------------------------------------------------------
 
@@ -64,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
@@ -81,15 +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
-#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
-
 instance HasType (LPat Id) where
     getType _ (L spn pat) = return $ Just (spn, hsPatType pat)
 
@@ -154,50 +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
-#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)
-
-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)]
-
-#if __GLASGOW_HASKELL__ >= 707
-pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [ClsInst], [FamInst]) -> SDoc
-pprInfo pefas (thing, fixity, insts, famInsts)
-    = pprTyThingInContextLoc pefas thing
-   $$ show_fixity fixity
-   $$ pprInstances insts
-   $$ pprFamInsts famInsts
-  where
-    show_fixity fx
-      | fx == defaultFixity = Outputable.empty
-      | otherwise           = ppr fx <+> ppr (getName thing)
-#else    
-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)
-#endif
 ----------------------------------------------------------------
 
 inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String