diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 4f081db..01c0e04 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -12,23 +12,25 @@ module Language.Haskell.GhcMod ( -- * Types , ModuleString , Expression - -- * 'IO' utilities - , bootInfo + , GhcPkgDb + -- * 'GhcMod' utilities + , boot , browse + , check , checkSyntax - , lintSyntax - , expandTemplate - , infoExpr - , typeExpr - , fillSig - , listModules - , listLanguages - , listFlags , debugInfo - , rootInfo - , packageDoc + , expandTemplate , findSymbol - , splitVar + , info + , lint + , pkgDoc + , rootInfo + , types + , splits + , sig + , modules + , languages + , flags ) where import Language.Haskell.GhcMod.Boot diff --git a/Language/Haskell/GhcMod/Boot.hs b/Language/Haskell/GhcMod/Boot.hs index 8cdfeb1..fd9345c 100644 --- 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 = [ diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 3399a3c..5067d5e 100644 --- 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' diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 8de00dc..b3ce715 100644 --- 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 diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 8e3566f..88a83c7 100644 --- 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) ---------------------------------------------------------------- diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs index ff00fde..74319e8 100644 --- 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-"] + ] diff --git a/Language/Haskell/GhcMod/GHCApi.hs b/Language/Haskell/GhcMod/GHCApi.hs index d48b2e7..2cd0886 100644 --- 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' diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 112dfd1..b2259db 100644 --- 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 diff --git a/Language/Haskell/GhcMod/Info.hs b/Language/Haskell/GhcMod/Info.hs index 4394f9f..8b4afec 100644 --- 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] - diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 2c5e910..99566e6 100644 --- 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 diff --git a/Language/Haskell/GhcMod/Lang.hs b/Language/Haskell/GhcMod/Lang.hs index 1ddc59a..071e178 100644 --- 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 diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 23515be..b88ca5f 100644 --- 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" diff --git a/Language/Haskell/GhcMod/List.hs b/Language/Haskell/GhcMod/List.hs index 5fcf32a..be0b4c7 100644 --- 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 diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 34f362a..5204130 100644 --- 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 diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index f8dd9d4..2f829ab 100644 --- 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") diff --git a/ghc-mod.cabal b/ghc-mod.cabal index 14e9d55..1cfb162 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -120,6 +120,7 @@ Executable ghc-mod Build-Depends: base >= 4.0 && < 5 , directory , filepath + , mtl >= 2.0 , ghc , ghc-mod diff --git a/src/GHCMod.hs b/src/GHCMod.hs index a2958e6..e2e2a4f 100644 --- a/src/GHCMod.hs +++ b/src/GHCMod.hs @@ -5,6 +5,7 @@ module Main where import Config (cProjectVersion) import Control.Applicative ((<$>)) import Control.Exception (Exception, Handler(..), ErrorCall(..)) +import Control.Monad.Trans (liftIO) import qualified Control.Exception as E import Data.Typeable (Typeable) import Data.Version (showVersion) @@ -102,7 +103,6 @@ main = flip E.catches handlers $ do -- #endif args <- getArgs let (opt,cmdArg) = parseArgs argspec args - cradle <- findCradle let cmdArg0 = cmdArg !. 0 cmdArg1 = cmdArg !. 1 cmdArg3 = cmdArg !. 3 @@ -111,23 +111,23 @@ main = flip E.catches handlers $ do nArgs n f = if length remainingArgs == n then f else E.throw (ArgumentsMismatch cmdArg0) - res <- case cmdArg0 of - "list" -> listModules opt cradle - "lang" -> listLanguages opt - "flag" -> listFlags opt - "browse" -> runGhcMod opt $ concat <$> mapM browse remainingArgs - "check" -> runGhcMod opt $ checkSyntax remainingArgs - "expand" -> runGhcMod opt $ expandTemplate remainingArgs - "debug" -> debugInfo opt cradle - "info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3 - "type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) - "split" -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) - "sig" -> nArgs 4 $ fillSig opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) - "find" -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1 - "lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 - "root" -> rootInfo opt cradle - "doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1 - "boot" -> bootInfo opt + res <- runGhcMod opt $ case cmdArg0 of + "list" -> modules + "lang" -> languages + "flag" -> flags + "browse" -> concat <$> mapM browse remainingArgs + "check" -> checkSyntax remainingArgs + "expand" -> expandTemplate remainingArgs + "debug" -> debugInfo + "info" -> nArgs 3 info cmdArg1 cmdArg3 + "type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4) + "split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4) + "sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4) + "find" -> nArgs 1 $ findSymbol cmdArg1 + "lint" -> nArgs 1 $ withFile lint cmdArg1 + "root" -> rootInfo + "doc" -> nArgs 1 $ pkgDoc cmdArg1 + "boot" -> boot "version" -> return progVersion "help" -> return $ O.usageInfo usage argspec cmd -> E.throw (NoSuchCommand cmd) @@ -152,8 +152,9 @@ main = flip E.catches handlers $ do hPutStrLn stderr $ "\"" ++ file ++ "\" not found" printUsage printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec + withFile :: (FilePath -> GhcMod a) -> FilePath -> GhcMod a withFile cmd file = do - exist <- doesFileExist file + exist <- liftIO $ doesFileExist file if exist then cmd file else E.throw (FileNotExist file) diff --git a/src/GHCModi.hs b/src/GHCModi.hs index 0baf43c..39449b4 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -31,12 +31,12 @@ import Data.Set (Set) import qualified Data.Set as S import Data.Typeable (Typeable) import Data.Version (showVersion) +import Exception (ghandle) import GHC (GhcMonad) import qualified GHC as G import Language.Haskell.GhcMod import Language.Haskell.GhcMod.Ghc import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Internal import Paths_ghc_mod import System.Console.GetOpt import System.Directory (setCurrentDirectory) @@ -98,12 +98,11 @@ main = E.handle cmdHandler $ go (opt,_) = E.handle someHandler $ do cradle0 <- findCradle let rootdir = cradleRootDir cradle0 - cradle = cradle0 { cradleCurrentDir = rootdir } +-- c = cradle0 { cradleCurrentDir = rootdir } TODO: ????? setCurrentDirectory rootdir mvar <- liftIO newEmptyMVar - mlibdir <- getSystemLibDir - void $ forkIO $ setupDB cradle mlibdir opt mvar - run cradle mlibdir opt $ loop opt S.empty mvar + void $ forkIO $ runGhcMod opt $ setupDB mvar + runGhcMod opt $ loop S.empty mvar where -- this is just in case. -- If an error is caught here, it is a bug of GhcMod library. @@ -117,31 +116,23 @@ replace (x:xs) = x : replace xs ---------------------------------------------------------------- -run :: Cradle -> Maybe FilePath -> Options -> GhcMod a -> IO a -run _ _ opt body = runGhcMod opt $ do - dflags <- G.getSessionDynFlags - G.defaultCleanupHandler dflags body - ----------------------------------------------------------------- - -setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO () -setupDB cradle mlibdir opt mvar = E.handle handler $ do - db <- run cradle mlibdir opt getSymMdlDb - putMVar mvar db +setupDB :: MVar SymMdlDb -> GhcMod () +setupDB mvar = ghandle handler $ do + liftIO . putMVar mvar =<< getSymMdlDb where handler (SomeException _) = return () -- fixme: put emptyDb? ---------------------------------------------------------------- -loop :: Options -> Set FilePath -> MVar SymMdlDb -> GhcMod () -loop opt set mvar = do +loop :: Set FilePath -> MVar SymMdlDb -> GhcMod () +loop set mvar = do cmdArg <- liftIO getLine let (cmd,arg') = break (== ' ') cmdArg arg = dropWhile (== ' ') arg' (ret,ok,set') <- case cmd of - "check" -> checkStx opt set arg + "check" -> checkStx set arg "find" -> findSym set arg mvar - "lint" -> toGhcMod $ lintStx opt set arg + "lint" -> lintStx set arg "info" -> showInfo set arg "type" -> showType set arg "split" -> doSplit set arg @@ -157,15 +148,14 @@ loop opt set mvar = do else do liftIO $ putStrLn $ "NG " ++ replace ret liftIO $ hFlush stdout - when ok $ loop opt set' mvar + when ok $ loop set' mvar ---------------------------------------------------------------- -checkStx :: Options - -> Set FilePath +checkStx :: Set FilePath -> FilePath -> GhcMod (String, Bool, Set FilePath) -checkStx _ set file = do +checkStx set file = do set' <- toGhcMod $ newFileSet set file let files = S.toList set' eret <- check files @@ -209,16 +199,17 @@ findSym set sym mvar = do let ret = lookupSym' opt sym db return (ret, True, set) -lintStx :: GhcMonad m - => Options -> Set FilePath -> FilePath - -> m (String, Bool, Set FilePath) -lintStx opt set optFile = liftIO $ do - ret <-lintSyntax opt' file +lintStx :: Set FilePath + -> FilePath + -> GhcMod (String, Bool, Set FilePath) +lintStx set optFile = do + ret <- local env' $ lint file return (ret, True, set) where (opts,file) = parseLintOptions optFile hopts = if opts == "" then [] else read opts - opt' = opt { hlintOpts = hopts } + env' e = e { gmOptions = opt' $ gmOptions e } + opt' o = o { hlintOpts = hopts } -- | -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name" diff --git a/test/BrowseSpec.hs b/test/BrowseSpec.hs index 9a0d87d..6ead51f 100644 --- a/test/BrowseSpec.hs +++ b/test/BrowseSpec.hs @@ -10,25 +10,25 @@ import Dir spec :: Spec spec = do - describe "browse" $ do - it "lists up symbols in the module" $ do + describe "browse Data.Map" $ do + it "contains at least `differenceWithKey'" $ do syms <- runD $ lines <$> browse "Data.Map" syms `shouldContain` ["differenceWithKey"] - describe "browse -d" $ do - it "lists up symbols with type info in the module" $ do + describe "browse -d Data.Either" $ do + it "contains functions (e.g. `either') including their type signature" $ do syms <- run defaultOptions { detailed = True } $ lines <$> browse "Data.Either" syms `shouldContain` ["either :: (a -> c) -> (b -> c) -> Either a b -> c"] - it "lists up data constructors with type info in the module" $ do + it "contains type constructors (e.g. `Left') including their type signature" $ do cradle <- findCradle syms <- run defaultOptions { detailed = True} $ lines <$> browse "Data.Either" syms `shouldContain` ["Left :: a -> Either a b"] - describe "browse local" $ do - it "lists symbols in a local module" $ do + describe "`browse' in a project directory" $ do + it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do withDirectory_ "test/data" $ do syms <- runID $ lines <$> browse "Baz" syms `shouldContain` ["baz"] diff --git a/test/CheckSpec.hs b/test/CheckSpec.hs index 71709c8..8b9334e 100644 --- a/test/CheckSpec.hs +++ b/test/CheckSpec.hs @@ -12,28 +12,28 @@ import Dir spec :: Spec spec = do describe "checkSyntax" $ do - it "can check even if an executable depends on its library" $ do + it "works even if an executable depends on the library defined in the same cabal file" $ do withDirectory_ "test/data/ghc-mod-check" $ do res <- runID $ checkSyntax ["main.hs"] res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" - it "can check even if a test module imports another test module located at different directory" $ do + it "works even if a module imports another module from a different directory" $ do withDirectory_ "test/data/check-test-subdir" $ do res <- runID $ checkSyntax ["test/Bar/Baz.hs"] res `shouldSatisfy` (("test" "Foo.hs:3:1:Warning: Top-level binding with no type signature: foo :: [Char]\n") `isSuffixOf`) - it "can detect mutually imported modules" $ do + it "detects cyclic imports" $ do withDirectory_ "test/data" $ do res <- runID $ checkSyntax ["Mutual1.hs"] res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) - it "can check a module using QuasiQuotes" $ do + it "works with modules using QuasiQuotes" $ do withDirectory_ "test/data" $ do res <- runID $ checkSyntax ["Baz.hs"] res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) - context "without errors" $ do - it "doesn't output empty line" $ do + context "when no errors are found" $ do + it "doesn't output an empty line" $ do withDirectory_ "test/data/ghc-mod-check/Data" $ do res <- runID $ checkSyntax ["Foo.hs"] res `shouldBe` "" diff --git a/test/FlagSpec.hs b/test/FlagSpec.hs index bfdf9ff..80fc893 100644 --- a/test/FlagSpec.hs +++ b/test/FlagSpec.hs @@ -3,10 +3,11 @@ module FlagSpec where import Control.Applicative import Language.Haskell.GhcMod import Test.Hspec +import TestUtils spec :: Spec spec = do - describe "listFlags" $ do - it "lists up GHC flags" $ do - flags <- lines <$> listFlags defaultOptions - flags `shouldContain` ["-fno-warn-orphans"] + describe "flags" $ do + it "contains at least `-fno-warn-orphans'" $ do + f <- runD $ lines <$> flags + f `shouldContain` ["-fno-warn-orphans"] diff --git a/test/GhcPkgSpec.hs b/test/GhcPkgSpec.hs index af39235..8560715 100644 --- a/test/GhcPkgSpec.hs +++ b/test/GhcPkgSpec.hs @@ -18,10 +18,10 @@ spec = do getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"] #endif - it "parses a config file and extracts sandbox package db" $ do + it "can parse a config file and extract the sandbox package-db" $ do cwd <- getCurrentDirectory pkgDb <- getSandboxDb "test/data/" pkgDb `shouldBe` (cwd "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") - it "throws an error if a config file is broken" $ do + it "throws an error if the sandbox config file is broken" $ do getSandboxDb "test/data/broken-sandbox" `shouldThrow` anyException diff --git a/test/InfoSpec.hs b/test/InfoSpec.hs index 4ff7809..caba4da 100644 --- a/test/InfoSpec.hs +++ b/test/InfoSpec.hs @@ -14,47 +14,47 @@ import System.Exit import System.FilePath import System.Process import Test.Hspec - +import TestUtils import Dir spec :: Spec spec = do - describe "typeExpr" $ do + describe "types" $ do it "shows types of the expression and its outers" $ do withDirectory_ "test/data/ghc-mod-check" $ do cradle <- findCradleWithoutSandbox - res <- typeExpr defaultOptions cradle "Data/Foo.hs" 9 5 + res <- runD $ types "Data/Foo.hs" 9 5 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n" it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox - res <- typeExpr defaultOptions cradle "Bar.hs" 5 1 + res <- runD $ types "Bar.hs" 5 1 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""] it "works with a module that imports another module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox - res <- typeExpr defaultOptions cradle "Main.hs" 3 8 + res <- runD $ types "Main.hs" 3 8 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] - describe "infoExpr" $ do + describe "info" $ do it "works for non-export functions" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox - res <- infoExpr defaultOptions cradle "Info.hs" "fib" + res <- runD $ info "Info.hs" "fib" res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox - res <- infoExpr defaultOptions cradle "Bar.hs" "foo" + res <- runD $ info "Bar.hs" "foo" res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) it "works with a module that imports another module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- findCradleWithoutSandbox - res <- infoExpr defaultOptions cradle "Main.hs" "bar" + res <- runD $ info "Main.hs" "bar" res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) it "doesn't fail on unicode output" $ do diff --git a/test/LangSpec.hs b/test/LangSpec.hs index 9f65b4c..7c624cc 100644 --- a/test/LangSpec.hs +++ b/test/LangSpec.hs @@ -3,10 +3,11 @@ module LangSpec where import Control.Applicative import Language.Haskell.GhcMod import Test.Hspec +import TestUtils spec :: Spec spec = do - describe "listLanguages" $ do - it "lists up language extensions" $ do - exts <- lines <$> listLanguages defaultOptions + describe "languages" $ do + it "contains at lest `OverloadedStrings'" $ do + exts <- runD $ lines <$> languages exts `shouldContain` ["OverloadedStrings"] diff --git a/test/LintSpec.hs b/test/LintSpec.hs index 1812de3..26ca952 100644 --- a/test/LintSpec.hs +++ b/test/LintSpec.hs @@ -2,15 +2,16 @@ module LintSpec where import Language.Haskell.GhcMod import Test.Hspec +import TestUtils spec :: Spec spec = do - describe "lintSyntax" $ do - it "check syntax with HLint" $ do - res <- lintSyntax defaultOptions "test/data/hlint.hs" + describe "lint" $ do + it "can detect a redundant import" $ do + res <- runD $ lint "test/data/hlint.hs" res `shouldBe` "test/data/hlint.hs:4:8: Error: Redundant do\NULFound:\NUL do putStrLn \"Hello, world!\"\NULWhy not:\NUL putStrLn \"Hello, world!\"\n" - context "without suggestions" $ do - it "doesn't output empty line" $ do - res <- lintSyntax defaultOptions "test/data/ghc-mod-check/Data/Foo.hs" + context "when no suggestions are given" $ do + it "doesn't output an empty line" $ do + res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs" res `shouldBe` "" diff --git a/test/ListSpec.hs b/test/ListSpec.hs index 98ca0ef..1ec4dfd 100644 --- a/test/ListSpec.hs +++ b/test/ListSpec.hs @@ -3,11 +3,11 @@ module ListSpec where import Control.Applicative import Language.Haskell.GhcMod import Test.Hspec +import TestUtils spec :: Spec spec = do - describe "listModules" $ do - it "lists up module names" $ do - cradle <- findCradle - modules <- lines <$> listModules defaultOptions cradle + describe "modules" $ do + it "contains at least `Data.Map'" $ do + modules <- runD $ lines <$> modules modules `shouldContain` ["Data.Map"] diff --git a/test/Main.hs b/test/Main.hs index f7a0820..4e92804 100644 --- a/test/Main.hs +++ b/test/Main.hs @@ -7,6 +7,7 @@ import System.Process import Language.Haskell.GhcMod (debugInfo, defaultOptions, findCradle) import Control.Exception as E +import TestUtils main = do let sandboxes = [ "test/data", "test/data/check-packageid" @@ -25,7 +26,7 @@ main = do putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal system "ghc --version" - (putStrLn =<< debugInfo defaultOptions =<< findCradle) + (putStrLn =<< runD debugInfo) `E.catch` (\(_ :: E.SomeException) -> return () ) hspec spec