ghc-mod 2.0.3 → 2.1.0

raw patch · 20 files changed

+207/−112 lines, 20 filesdep ~hspecPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hspec

API changes (from Hackage documentation)

Files

• Language/Haskell/GhcMod/Browse.hs +1/−1
• Language/Haskell/GhcMod/Doc.hs +20/−1
• Language/Haskell/GhcMod/ErrMsg.hs +2/−1
• Language/Haskell/GhcMod/Flag.hs +0/−2
• Language/Haskell/GhcMod/GHCApi.hs +17/−22
• Language/Haskell/GhcMod/GHCChoice.hs +3/−0
• Language/Haskell/GhcMod/Gap.hs +109/−11
• Language/Haskell/GhcMod/Info.hs +6/−36
• Language/Haskell/GhcMod/Internal.hs +16/−0
• Language/Haskell/GhcMod/Types.hs +2/−0
• ghc-mod.cabal +4/−4
• test/BrowseSpec.hs +3/−4
• test/CheckSpec.hs +2/−1
• test/DebugSpec.hs +3/−2
• test/Dir.hs +14/−0
• test/Expectation.hs +0/−20
• test/FlagSpec.hs +1/−2
• test/InfoSpec.hs +2/−1
• test/LangSpec.hs +1/−2
• test/ListSpec.hs +1/−2

@@ -6,7 +6,7 @@ import Data.Maybe (fromMaybe) import DataCon (dataConRepType) import GHC-import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.Doc (showUnqualifiedPage) import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Types import Name

@@ -5,20 +5,39 @@ import Outputable import Pretty +----------------------------------------------------------------++{-+pretty :: Outputable a => a -> String+pretty = showSDocForUser neverQualify . ppr++debug :: Outputable a => a -> b -> b+debug x v = trace (pretty x) v+-}++----------------------------------------------------------------+ styleQualified :: PprStyle styleQualified = mkUserStyle alwaysQualify AllTheWay  styleUnqualified :: PprStyle styleUnqualified = mkUserStyle neverQualify AllTheWay +----------------------------------------------------------------++-- For "ghc-mod type" showQualifiedPage :: DynFlags -> SDoc -> String showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified +-- For "ghc-mod browse" and show GHC's error messages. showUnqualifiedPage :: DynFlags -> SDoc -> String-showUnqualifiedPage dflag = showDocWith PageMode . withStyle dflag styleUnqualified+showUnqualifiedPage dflag = Pretty.showDocWith Pretty.PageMode+                          . withStyle dflag styleUnqualified +-- Not used showQualifiedOneLine :: DynFlags -> SDoc -> String showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified +-- To write Haskell code in a buffer showUnqualifiedOneLine :: DynFlags -> SDoc -> String showUnqualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleUnqualified

@@ -14,13 +14,14 @@ import ErrUtils import GHC import HscTypes-import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.Doc (showUnqualifiedPage) import qualified Language.Haskell.GhcMod.Gap as Gap import Outputable import System.FilePath (normalise)  ---------------------------------------------------------------- +-- | A means to read the log type LogReader = IO [String]  ----------------------------------------------------------------

@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Language.Haskell.GhcMod.Flag where  import qualified Language.Haskell.GhcMod.Gap as Gap

@@ -25,6 +25,7 @@ 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 @@ -56,9 +57,12 @@  data Build = CabalPkg | SingleFile deriving Eq -initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader+-- | Initialize the 'DynFlags' relating to the compilation of a single+-- file or GHC session according to the 'Cradle' and 'Options'+-- provided.+initializeFlagsWithCradle :: GhcMonad m =>  Options -> Cradle -> [GHCOption] -> Bool -> m LogReader initializeFlagsWithCradle opt cradle ghcOptions logging-  | cabal     = withCabal ||> withoutCabal+  | cabal     = withCabal |||> withoutCabal   | otherwise = withoutCabal   where     cabal = isJust $ cradleCabalFile cradle@@ -70,13 +74,13 @@  ---------------------------------------------------------------- -initSession :: Build+initSession :: GhcMonad m => Build             -> Options             -> [GHCOption]             -> [IncludeDir]             -> Maybe [Package]             -> Bool-            -> Ghc LogReader+            -> m LogReader initSession build opt cmdOpts idirs mDepPkgs logging = do     dflags0 <- getSessionDynFlags     (dflags1,readLog) <- setupDynamicFlags dflags0@@ -91,7 +95,7 @@  ---------------------------------------------------------------- -initializeFlags :: Options -> Ghc ()+initializeFlags :: GhcMonad m => Options -> m () initializeFlags opt = do     dflags0 <- getSessionDynFlags     dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt@@ -107,24 +111,13 @@   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@@ -137,22 +130,22 @@   , hscTarget = HscNothing   } -setSlowDynFlags :: Ghc ()+setSlowDynFlags :: GhcMonad m => m () setSlowDynFlags = (flip setFastOrNot Slow <$> getSessionDynFlags)                   >>= void . setSessionDynFlags --- To check TH, a session module graph is necessary.+-- | To check TH, a session module graph is necessary. -- "load" sets a session module graph using "depanal". -- But we have to set "-fno-code" to DynFlags before "load". -- So, this is necessary redundancy.-checkSlowAndSet :: Ghc ()+checkSlowAndSet :: GhcMonad m => m () checkSlowAndSet = do     fast <- canCheckFast <$> depanal [] False     unless fast setSlowDynFlags  ---------------------------------------------------------------- -modifyFlagsWithOpts :: DynFlags -> [String] -> Ghc DynFlags+modifyFlagsWithOpts :: GhcMonad m => DynFlags -> [String] -> m DynFlags modifyFlagsWithOpts dflags cmdOpts =     tfst <$> parseDynamicFlags dflags (map noLoc cmdOpts)   where@@ -160,6 +153,7 @@  ---------------------------------------------------------------- +-- | Set the file that GHC will load / compile setTargetFile :: (GhcMonad m) => String -> m () setTargetFile file = do     target <- guessTarget file Nothing@@ -167,6 +161,7 @@  ---------------------------------------------------------------- +-- | Return the 'DynFlags' currently in use in the GHC session getDynamicFlags :: IO DynFlags getDynamicFlags = runGhc (Just libdir) getSessionDynFlags 

@@ -12,6 +12,9 @@ (||>) :: Ghc a -> Ghc a -> Ghc a x ||> y = x `gcatch` (\(_ :: IOException) -> y) +(|||>) :: GhcMonad m => m a -> m a -> m a+x |||> y = x `gcatch` (\(_ :: IOException) -> y)+ ----------------------------------------------------------------  {-| Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.

@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}  module Language.Haskell.GhcMod.Gap (     Language.Haskell.GhcMod.Gap.ClsInst@@ -13,6 +13,12 @@   , toStringBuffer   , liftIO   , showSeverityCaption+  , setCabalPkg+  , addDevPkgs+  , filterOutChildren+  , infoThing+  , pprInfo+  , HasType(..) #if __GLASGOW_HASKELL__ >= 702 #else   , module Pretty@@ -21,19 +27,33 @@  import Control.Applicative hiding (empty) import Control.Monad+import Data.List+import Data.Maybe import Data.Time.Clock import DynFlags import ErrUtils import FastString-import GHC+import HscTypes import Language.Haskell.GhcMod.GHCChoice+import Language.Haskell.GhcMod.Types hiding (convert)+import NameSet import Outputable+import PprTyThing import StringBuffer+import TcType  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,19 +62,12 @@ import Pretty #endif + #if __GLASGOW_HASKELL__ < 706-import Control.Arrow+import Control.Arrow hiding ((<+>)) import Data.Convertible #endif -{--pretty :: Outputable a => a -> String-pretty = showSDocForUser neverQualify . ppr--debug :: Outputable a => a -> b -> b-debug x v = trace (pretty x) v--}- ---------------------------------------------------------------- ---------------------------------------------------------------- --@@ -179,4 +192,89 @@ 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 SDoc+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+    return $ 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

@@ -1,5 +1,6 @@ {-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-} {-# LANGUAGE Rank2Types #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Language.Haskell.GhcMod.Info (     infoExpr@@ -25,8 +26,8 @@ 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 +58,13 @@ info opt cradle file modstr expr =     inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info"   where-    exprToInfo = infoThing expr+    exprToInfo = do+        dflag <- getSessionDynFlags+        sdoc <- Gap.infoThing expr+        return $ showUnqualifiedPage dflag sdoc  ---------------------------------------------------------------- -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 +75,6 @@         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) @@ -141,33 +138,6 @@  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)  ---------------------------------------------------------------- 

@@ -0,0 +1,16 @@+-- | Low level access to the ghc-mod library.++module Language.Haskell.GhcMod.Internal (+  -- * Low level access+    LogReader+  , GHCOption+  , initializeFlagsWithCradle+  , setTargetFile+  , checkSlowAndSet+  , getDynamicFlags+  ) where++import Language.Haskell.GhcMod.ErrMsg+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Types+

@@ -84,7 +84,9 @@  ---------------------------------------------------------------- +-- | A single GHC option, as it would appear on the command line type GHCOption  = String+ type IncludeDir = FilePath type Package    = String 

@@ -1,5 +1,5 @@ Name:                   ghc-mod-Version:                2.0.3+Version:                2.1.0 Author:                 Kazu Yamamoto <kazu@iij.ad.jp> Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp> License:                BSD3@@ -40,6 +40,7 @@   Default-Language:     Haskell2010   GHC-Options:          -Wall   Exposed-Modules:      Language.Haskell.GhcMod+                        Language.Haskell.GhcMod.Internal   Other-Modules:        Language.Haskell.GhcMod.Browse                         Language.Haskell.GhcMod.CabalApi                         Language.Haskell.GhcMod.Check@@ -59,7 +60,6 @@   Build-Depends:        base >= 4.0 && < 5                       , Cabal >= 1.10                       , containers-                      , convertible                       , directory                       , filepath                       , ghc@@ -90,7 +90,7 @@   Main-Is:              Spec.hs   Hs-Source-Dirs:       test, .   Type:                 exitcode-stdio-1.0-  Other-Modules:        Expectation+  Other-Modules:        Dir                         BrowseSpec                         CabalApiSpec                         CheckSpec@@ -116,7 +116,7 @@                       , syb                       , time                       , transformers-                      , hspec+                      , hspec >= 1.7.1  Source-Repository head   Type:                 git

@@ -1,7 +1,6 @@ module BrowseSpec where  import Control.Applicative-import Expectation import Language.Haskell.GhcMod import Test.Hspec @@ -10,13 +9,13 @@     describe "browseModule" $ do         it "lists up symbols in the module" $ do             syms <- lines <$> browseModule defaultOptions "Data.Map"-            syms `shouldContain` "differenceWithKey"+            syms `shouldContain` ["differenceWithKey"]      describe "browseModule -d" $ do         it "lists up symbols with type info in the module" $ do             syms <- lines <$> browseModule defaultOptions { detailed = True } "Data.Either"-            syms `shouldContain` "either :: (a -> c) -> (b -> c) -> Either a b -> c"+            syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"]          it "lists up data constructors with type info in the module" $ do             syms <- lines <$> browseModule defaultOptions { detailed = True} "Data.Either"-            syms `shouldContain` "Left :: a -> Either a b"+            syms `shouldContain` ["Left :: a -> Either a b"]

@@ -1,10 +1,11 @@ module CheckSpec where  import Data.List (isSuffixOf, isInfixOf, isPrefixOf)-import Expectation import Language.Haskell.GhcMod import System.FilePath import Test.Hspec++import Dir  spec :: Spec spec = do

@@ -1,15 +1,16 @@ module DebugSpec where -import Expectation import Language.Haskell.GhcMod import Test.Hspec +import Dir+ checkFast :: String -> String -> IO () checkFast file ans = withDirectory_ "test/data" $ do     (strVer,_) <- getGHCVersion     cradle <- findCradle Nothing strVer     res <- debugInfo defaultOptions cradle strVer file-    lines res `shouldContain` ans+    lines res `shouldContain` [ans]  spec :: Spec spec = do

@@ -0,0 +1,14 @@+module Dir where++import System.Directory+import Control.Exception as E++withDirectory_ :: FilePath -> IO a -> IO a+withDirectory_ dir action = bracket getCurrentDirectory+                                    setCurrentDirectory+                                    (\_ -> setCurrentDirectory dir >> action)++withDirectory :: FilePath -> (FilePath -> IO a) -> IO a+withDirectory dir action = bracket getCurrentDirectory+                                   setCurrentDirectory+                                   (\d -> setCurrentDirectory dir >> action d)

@@ -1,20 +0,0 @@-module Expectation where--import Test.Hspec-import System.Directory-import Control.Exception as E--shouldContain :: Eq a => [a] -> a -> Expectation-shouldContain containers element = do-    let res = element `elem` containers-    res `shouldBe` True--withDirectory_ :: FilePath -> IO a -> IO a-withDirectory_ dir action = bracket getCurrentDirectory-                                    setCurrentDirectory-                                    (\_ -> setCurrentDirectory dir >> action)--withDirectory :: FilePath -> (FilePath -> IO a) -> IO a-withDirectory dir action = bracket getCurrentDirectory-                                   setCurrentDirectory-                                   (\d -> setCurrentDirectory dir >> action d)

@@ -1,7 +1,6 @@ module FlagSpec where  import Control.Applicative-import Expectation import Language.Haskell.GhcMod import Test.Hspec @@ -10,4 +9,4 @@     describe "listFlags" $ do         it "lists up GHC flags" $ do             flags <- lines <$> listFlags defaultOptions-            flags `shouldContain` "-fno-warn-orphans"+            flags `shouldContain` ["-fno-warn-orphans"]

@@ -1,11 +1,12 @@ module InfoSpec where  import Data.List (isPrefixOf)-import Expectation import Language.Haskell.GhcMod import System.Exit import System.Process import Test.Hspec++import Dir  spec :: Spec spec = do

@@ -1,7 +1,6 @@ module LangSpec where  import Control.Applicative-import Expectation import Language.Haskell.GhcMod import Test.Hspec @@ -10,4 +9,4 @@     describe "listLanguages" $ do         it "lists up language extensions" $ do             exts <- lines <$> listLanguages defaultOptions-            exts `shouldContain` "OverloadedStrings"+            exts `shouldContain` ["OverloadedStrings"]

@@ -1,7 +1,6 @@ module ListSpec where  import Control.Applicative-import Expectation import Language.Haskell.GhcMod import Test.Hspec @@ -10,4 +9,4 @@     describe "listModules" $ do         it "lists up module names" $ do             modules <- lines <$> listModules defaultOptions-            modules `shouldContain` "Data.Map"+            modules `shouldContain` ["Data.Map"]