Migrate the remaining parts of the exposed API to GhcMod a

2014-07-11 03:10:37 +02:00
parent dc5ba6d00d
commit 4b6a687bc1
27 changed files with 180 additions and 276 deletions
--- a/Language/Haskell/GhcMod/Boot.hs
+++ b/Language/Haskell/GhcMod/Boot.hs
@@ -1,27 +1,16 @@
 module Language.Haskell.GhcMod.Boot where

-import Control.Applicative ((<$>))
-import CoreMonad (liftIO, liftIO)
+import Control.Applicative
 import Language.Haskell.GhcMod.Browse
 import Language.Haskell.GhcMod.Flag
 import Language.Haskell.GhcMod.Lang
 import Language.Haskell.GhcMod.List
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Types
-
-- | Printing necessary information for front-end booting.
-bootInfo :: Options -> IO String
-bootInfo opt = runGhcMod opt $ boot

 -- | Printing necessary information for front-end booting.
 boot :: GhcMod String
-boot = do
-    opt   <- options
-    mods  <- modules
-    langs <- liftIO $ listLanguages opt
-    flags <- liftIO $ listFlags opt
-    pre   <- concat <$> mapM browse preBrowsedModules
-    return $ mods ++ langs ++ flags ++ pre
+boot =  concat <$> sequence [modules, languages, flags,
+                             concat <$> mapM browse preBrowsedModules]

 preBrowsedModules :: [String]
 preBrowsedModules = [
--- a/Language/Haskell/GhcMod/CaseSplit.hs
+++ b/Language/Haskell/GhcMod/CaseSplit.hs
@@ -1,8 +1,7 @@
 {-# LANGUAGE CPP #-}

 module Language.Haskell.GhcMod.CaseSplit (
-    splitVar
-  , splits
+  splits
  ) where

 import Data.List (find, intercalate)
@@ -11,12 +10,10 @@ import qualified Data.Text.IO as T (readFile)
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
-import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Gap (HasType(..))
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
-import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Convert
 import MonadUtils (liftIO)
 import Outputable (PprStyle)
@@ -35,17 +32,6 @@ data SplitToTextInfo = SplitToTextInfo { sVarName     :: String
                                       , sTycons      :: [String]
                                       }

-- | Splitting a variable in a equation.
-splitVar :: Options
-         -> Cradle
-         -> FilePath     -- ^ A target file.
-         -> Int          -- ^ Line number.
-         -> Int          -- ^ Column number.
-         -> IO String
-splitVar opt cradle file lineNo colNo = runGhcMod opt $ do
-    initializeFlagsWithCradle opt cradle
-    splits file lineNo colNo
-
 -- | Splitting a variable in a equation.
 splits :: FilePath     -- ^ A target file.
       -> Int          -- ^ Line number.
@@ -212,7 +198,7 @@ srcSpanDifference b v =
   in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line

 replaceVarWithTyCon :: [T.Text] -> (Int,Int,Int,Int) -> String -> String -> [T.Text]
-replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon = 
+replaceVarWithTyCon text (vsl,vsc,_,vec) varname tycon =
  let tycon'      = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
      lengthDiff  = length tycon' - length varname
      tycon''     = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon'
--- a/Language/Haskell/GhcMod/Debug.hs
+++ b/Language/Haskell/GhcMod/Debug.hs
@@ -1,55 +1,44 @@
 module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where

 import Control.Applicative ((<$>))
-import Control.Exception.IOChoice ((||>))
 import CoreMonad (liftIO)
 import Data.List (intercalate)
-import Data.Maybe (fromMaybe, isJust, fromJust)
+import Data.Maybe (isJust, fromJust)
 import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.GHCChoice ((||>))
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types

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

 -- | Obtaining debug information.
-debugInfo :: Options
-          -> Cradle
-          -> IO String
-debugInfo opt cradle = convert opt <$> do
+debugInfo :: GhcMod String
+debugInfo = cradle >>= \c -> convert' =<< do
    CompilerOptions gopts incDir pkgs <-
-        if cabal then
-            liftIO (fromCabalFile ||> return simpleCompilerOption)
+        if isJust $ cradleCabalFile c then
+            (fromCabalFile c ||> simpleCompilerOption)
          else
-            return simpleCompilerOption
-    mglibdir <- liftIO getSystemLibDir
+            simpleCompilerOption
    return [
-        "Root directory:      " ++ rootDir
-      , "Current directory:   " ++ currentDir
-      , "Cabal file:          " ++ cabalFile
+        "Root directory:      " ++ cradleRootDir c
+      , "Current directory:   " ++ cradleCurrentDir c
+      , "Cabal file:          " ++ show (cradleCabalFile c)
      , "GHC options:         " ++ unwords gopts
      , "Include directories: " ++ unwords incDir
      , "Dependent packages:  " ++ intercalate ", " (map showPkg pkgs)
-      , "System libraries:    " ++ fromMaybe "" mglibdir
+      , "System libraries:    " ++ systemLibDir
      ]
  where
-    currentDir = cradleCurrentDir cradle
-    mCabalFile = cradleCabalFile cradle
-    rootDir    = cradleRootDir cradle
-    cabal = isJust mCabalFile
-    cabalFile = fromMaybe "" mCabalFile
-    origGopts = ghcOpts opt
-    simpleCompilerOption = CompilerOptions origGopts [] []
-    fromCabalFile = do
-        pkgDesc <- parseCabalFile file
-        getCompilerOptions origGopts cradle pkgDesc
-      where
-        file = fromJust mCabalFile
+    simpleCompilerOption = options >>= \op ->
+        return $ CompilerOptions (ghcOpts op) [] []
+    fromCabalFile c = options >>= \opts -> liftIO $ do
+        pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
+        getCompilerOptions (ghcOpts opts) c pkgDesc

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

 -- | Obtaining root information.
-rootInfo :: Options
-          -> Cradle
-          -> IO String
-rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle
+rootInfo :: GhcMod String
+rootInfo = convert' =<< cradleRootDir <$> cradle
--- a/Language/Haskell/GhcMod/FillSig.hs
+++ b/Language/Haskell/GhcMod/FillSig.hs
@@ -1,8 +1,7 @@
 {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-}

 module Language.Haskell.GhcMod.FillSig (
-    fillSig
-  , sig
+    sig
  ) where

 import Data.Char (isSymbol)
@@ -10,12 +9,10 @@ import Data.List (find, intercalate)
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
 import qualified GHC as G
-import Language.Haskell.GhcMod.GHCApi
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.SrcUtils
-import Language.Haskell.GhcMod.Types
 import MonadUtils (liftIO)
 import Outputable (PprStyle)
 import qualified Type as Ty
@@ -38,18 +35,7 @@ data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
             | InstanceDecl SrcSpan G.Class

 -- Signature for fallback operation via haskell-src-exts
-data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) 
-
-- | Create a initial body from a signature.
-fillSig :: Options
-        -> Cradle
-        -> FilePath     -- ^ A target file.
-        -> Int          -- ^ Line number.
-        -> Int          -- ^ Column number.
-        -> IO String
-fillSig opt cradle file lineNo colNo = runGhcMod opt $ do
-    initializeFlagsWithCradle opt cradle
-    sig file lineNo colNo
+data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo)

 -- | Create a initial body from a signature.
 sig :: FilePath     -- ^ A target file.
@@ -67,13 +53,13 @@ sig file lineNo colNo = ghandle handler body
          InstanceDecl loc cls -> do
             ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
                                            (Ty.classMethods cls))
-            
+
    handler (SomeException _) = do
      opt <- options
      -- Code cannot be parsed by ghc module
      -- Fallback: try to get information via haskell-src-exts
      whenFound opt (getSignatureFromHE file lineNo colNo) $
-        \(HESignature loc names ty) -> 
+        \(HESignature loc names ty) ->
           ("function", fourIntsHE loc, map (initialBody undefined undefined ty) names)

 ----------------------------------------------------------------
--- a/Language/Haskell/GhcMod/Flag.hs
+++ b/Language/Haskell/GhcMod/Flag.hs
@@ -2,12 +2,12 @@ module Language.Haskell.GhcMod.Flag where

 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Convert
-import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Monad

 -- | Listing GHC flags. (e.g -fno-warn-orphans)

-listFlags :: Options -> IO String
-listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option
-                                     | option <- Gap.fOptions
-                                     , prefix <- ["","no-"]
-                                     ]
+flags :: GhcMod String
+flags = convert' [ "-f" ++ prefix ++ option
+                 | option <- Gap.fOptions
+                 , prefix <- ["","no-"]
+                 ]
--- a/Language/Haskell/GhcMod/GHCApi.hs
+++ b/Language/Haskell/GhcMod/GHCApi.hs
@@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.GHCApi (
  , initializeFlagsWithCradle
  , setTargetFiles
  , getDynamicFlags
-  , getSystemLibDir
+  , systemLibDir
  , withDynFlags
  , withCmdFlags
  , setNoWaringFlags
@@ -16,6 +16,8 @@ module Language.Haskell.GhcMod.GHCApi (
 import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.GhcPkg
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Types

 import Control.Applicative ((<$>))
 import Control.Monad (forM, void)
@@ -25,8 +27,6 @@ import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
 import qualified GHC as G
 import GhcMonad
 import GHC.Paths (libdir)
-import qualified Language.Haskell.GhcMod.Gap as Gap
-import Language.Haskell.GhcMod.Types
 import System.Exit (exitSuccess)
 import System.IO (hPutStr, hPrint, stderr)
 import System.IO.Unsafe (unsafePerformIO)
@@ -34,8 +34,8 @@ import System.IO.Unsafe (unsafePerformIO)
 ----------------------------------------------------------------

 -- | Obtaining the directory for system libraries.
-getSystemLibDir :: IO (Maybe FilePath)
-getSystemLibDir = return $ Just libdir
+systemLibDir :: FilePath
+systemLibDir = libdir

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

@@ -53,8 +53,7 @@ withGHC file body = ghandle ignore $ withGHC' body

 withGHC' :: Ghc a -> IO a
 withGHC' body = do
-    mlibdir <- getSystemLibDir
-    G.runGhc mlibdir $ do
+    G.runGhc (Just systemLibDir) $ do
        dflags <- G.getSessionDynFlags
        G.defaultCleanupHandler dflags body

@@ -161,8 +160,7 @@ setTargetFiles files = do
 -- | Return the 'DynFlags' currently in use in the GHC session.
 getDynamicFlags :: IO DynFlags
 getDynamicFlags = do
-    mlibdir <- getSystemLibDir
-    G.runGhc mlibdir G.getSessionDynFlags
+    G.runGhc (Just systemLibDir) G.getSessionDynFlags

 withDynFlags :: GhcMonad m
             => (DynFlags -> DynFlags)
@@ -197,8 +195,7 @@ setAllWaringFlags df = df { warningFlags = allWarningFlags }

 allWarningFlags :: Gap.WarnFlags
 allWarningFlags = unsafePerformIO $ do
-    mlibdir <- getSystemLibDir
-    G.runGhc mlibdir $ do
+    G.runGhc (Just systemLibDir) $ do
        df <- G.getSessionDynFlags
        df' <- addCmdOpts ["-Wall"] df
        return $ G.warningFlags df'
--- a/Language/Haskell/GhcMod/Ghc.hs
+++ b/Language/Haskell/GhcMod/Ghc.hs
@@ -2,15 +2,6 @@ module Language.Haskell.GhcMod.Ghc (
  -- * Converting the 'Ghc' monad to the 'IO' monad
    withGHC
  , withGHC'
-  -- * 'Ghc' utilities
-  , boot
-  , browse
-  , check
-  , info
-  , types
-  , splits
-  , sig
-  , modules
  -- * 'SymMdlDb'
  , Symbol
  , SymMdlDb
@@ -19,12 +10,5 @@ module Language.Haskell.GhcMod.Ghc (
  , lookupSym'
  ) where

-import Language.Haskell.GhcMod.Boot
-import Language.Haskell.GhcMod.Browse
-import Language.Haskell.GhcMod.Check
 import Language.Haskell.GhcMod.Find
 import Language.Haskell.GhcMod.GHCApi
-import Language.Haskell.GhcMod.Info
-import Language.Haskell.GhcMod.List
-import Language.Haskell.GhcMod.FillSig
-import Language.Haskell.GhcMod.CaseSplit
--- a/Language/Haskell/GhcMod/Info.hs
+++ b/Language/Haskell/GhcMod/Info.hs
@@ -1,7 +1,5 @@
 module Language.Haskell.GhcMod.Info (
-    infoExpr
-  , info
-  , typeExpr
+    info
  , types
  ) where

@@ -13,7 +11,6 @@ import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Doc (showPage)
-import Language.Haskell.GhcMod.GHCApi
 import Language.Haskell.GhcMod.Gap (HasType(..))
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Monad
@@ -23,16 +20,6 @@ import Language.Haskell.GhcMod.Convert

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

-- | Obtaining information of a target expression. (GHCi's info:)
-infoExpr :: Options
-         -> Cradle
-         -> FilePath     -- ^ A target file.
-         -> Expression   -- ^ A Haskell expression.
-         -> IO String
-infoExpr opt cradle file expr = runGhcMod opt $ do
-    initializeFlagsWithCradle opt cradle
-    info file expr
-
 -- | Obtaining information of a target expression. (GHCi's info:)
 info :: FilePath     -- ^ A target file.
     -> Expression   -- ^ A Haskell expression.
@@ -48,17 +35,6 @@ info file expr = do

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

-- | Obtaining type of a target expression. (GHCi's type:)
-typeExpr :: Options
-         -> Cradle
-         -> FilePath     -- ^ A target file.
-         -> Int          -- ^ Line number.
-         -> Int          -- ^ Column number.
-         -> IO String
-typeExpr opt cradle file lineNo colNo = runGhcMod opt $ do
-    initializeFlagsWithCradle opt cradle
-    types file lineNo colNo
-
 -- | Obtaining type of a target expression. (GHCi's type:)
 types :: FilePath     -- ^ A target file.
      -> Int          -- ^ Line number.
@@ -85,4 +61,3 @@ getSrcSpanType modSum lineNo colNo = do
    ets <- mapM (getType tcm) es
    pts <- mapM (getType tcm) ps
    return $ catMaybes $ concat [ets, bts, pts]
-
--- a/Language/Haskell/GhcMod/Internal.hs
+++ b/Language/Haskell/GhcMod/Internal.hs
@@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal (
  , cabalDependPackages
  , cabalSourceDirs
  , cabalAllTargets
+  -- * GHC.Paths
+  , systemLibDir
  -- * IO
-  , getSystemLibDir
  , getDynamicFlags
  -- * Initializing 'DynFlags'
  , initializeFlagsWithCradle
--- a/Language/Haskell/GhcMod/Lang.hs
+++ b/Language/Haskell/GhcMod/Lang.hs
@@ -1,10 +1,10 @@
 module Language.Haskell.GhcMod.Lang where

 import DynFlags (supportedLanguagesAndExtensions)
-import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Monad

 -- | Listing language extensions.

-listLanguages :: Options -> IO String
-listLanguages opt = return $ convert opt supportedLanguagesAndExtensions
+languages :: GhcMod String
+languages = convert' supportedLanguagesAndExtensions
--- a/Language/Haskell/GhcMod/Lint.hs
+++ b/Language/Haskell/GhcMod/Lint.hs
@@ -1,19 +1,21 @@
 module Language.Haskell.GhcMod.Lint where

-import Control.Applicative ((<$>))
-import Control.Exception (handle, SomeException(..))
+import Exception (ghandle)
+import Control.Exception (SomeException(..))
+import Control.Monad.Trans (liftIO)
 import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.HLint (hlint)

 -- | Checking syntax of a target file using hlint.
 --   Warnings and errors are returned.
-lintSyntax :: Options
-           -> FilePath  -- ^ A target file.
-           -> IO String
-lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts)
-  where
-    pack = convert opt . map (init . show) -- init drops the last \n.
-    hopts = hlintOpts opt
+lint :: FilePath  -- ^ A target file.
+     -> GhcMod String
+lint file = do
+  opt <- options
+  ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)
+ where
+    pack = convert' . map (init . show) -- init drops the last \n.
    handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"
--- a/Language/Haskell/GhcMod/List.hs
+++ b/Language/Haskell/GhcMod/List.hs
@@ -1,4 +1,4 @@
-module Language.Haskell.GhcMod.List (listModules, modules) where
+module Language.Haskell.GhcMod.List (modules) where

 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
@@ -12,10 +12,6 @@ import UniqFM (eltsUFM)

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

-- | Listing installed modules.
-listModules :: Options -> Cradle -> IO String
-listModules opt _ = runGhcMod opt $ modules
-
 -- | Listing installed modules.
 modules :: GhcMod String
 modules = do
--- a/Language/Haskell/GhcMod/Monad.hs
+++ b/Language/Haskell/GhcMod/Monad.hs
@@ -13,6 +13,7 @@ module Language.Haskell.GhcMod.Monad (
 , withErrorHandler
 , toGhcMod
 , options
+ , cradle
 , module Control.Monad.Reader.Class
 , module Control.Monad.Writer.Class
 , module Control.Monad.State.Class
@@ -103,11 +104,11 @@ runGhcMod' r s a = do
 newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
 newGhcModEnv opt dir = do
      session <- newIORef (error "empty session")
-      cradle <- findCradle' dir
+      c <- findCradle' dir
      return GhcModEnv {
          gmGhcSession = session
        , gmOptions = opt
-        , gmCradle = cradle
+        , gmCradle = c
        }

 runGhcMod :: Options -> GhcMod a -> IO a
@@ -142,6 +143,9 @@ toGhcMod a = do
 options :: GhcMod Options
 options = gmOptions <$> ask

+cradle :: GhcMod Cradle
+cradle = gmCradle <$> ask
+
 instance MonadBase IO GhcMod where
    liftBase = GhcMod . liftBase

--- a/Language/Haskell/GhcMod/PkgDoc.hs
+++ b/Language/Haskell/GhcMod/PkgDoc.hs
@@ -1,30 +1,26 @@
-module Language.Haskell.GhcMod.PkgDoc (packageDoc) where
+module Language.Haskell.GhcMod.PkgDoc (pkgDoc) where

+import Control.Monad.Trans (liftIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.GhcPkg
+import Language.Haskell.GhcMod.Monad

 import Control.Applicative ((<$>))
 import System.Process (readProcess)

 -- | Obtaining the package name and the doc path of a module.
-packageDoc :: Options
-           -> Cradle
-           -> ModuleString
-           -> IO String
-packageDoc _ cradle mdl = pkgDoc cradle mdl
-
-pkgDoc :: Cradle -> String -> IO String
-pkgDoc cradle mdl = do
-    pkg <- trim <$> readProcess "ghc-pkg" toModuleOpts []
+pkgDoc :: String -> GhcMod String
+pkgDoc mdl = cradle >>= \c -> liftIO $ do
+    pkg <- trim <$> readProcess "ghc-pkg" (toModuleOpts c) []
    if pkg == "" then
        return "\n"
      else do
-        htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) []
+        htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg c) []
        let ret = pkg ++ " " ++ drop 14 htmlpath
        return ret
  where
-    toModuleOpts = ["find-module", mdl, "--simple-output"]
-                   ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)
-    toDocDirOpts pkg = ["field", pkg, "haddock-html"]
-                       ++ ghcPkgDbStackOpts (cradlePkgDbStack cradle)
+    toModuleOpts c = ["find-module", mdl, "--simple-output"]
+                   ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
+    toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
+                       ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
    trim = takeWhile (`notElem` " \n")