hasufell/ghc-mod
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge pull request #281 from DanielG/dev-monad

Browse Source 
Migrate the remaining parts of the exposed API to `GhcMod a`
This commit is contained in:
Kazu Yamamoto 2014-07-11 10:53:06 +09:00
commit a1d9194239
28 changed files with 196 additions and 282 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
Language/Haskell/GhcMod.hs
View File

@ -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

17
Language/Haskell/GhcMod/Boot.hs
View File

@ -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 = [

18
Language/Haskell/GhcMod/CaseSplit.hs
View File

@ -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'

7
Language/Haskell/GhcMod/Cradle.hs
View File

@ -1,5 +1,6 @@
module Language.Haskell.GhcMod.Cradle (
findCradle
, findCradle'
, findCradleWithoutSandbox
) where
@ -22,8 +23,10 @@ import System.FilePath ((</>), takeDirectory)
-- in a cabal directory.
findCradle :: IO Cradle
findCradle = do
wdir <- getCurrentDirectory
cabalCradle wdir ||> sandboxCradle wdir ||> plainCradle wdir
findCradle' =<< getCurrentDirectory
findCradle' :: FilePath -> IO Cradle
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do

49
Language/Haskell/GhcMod/Debug.hs
View File

@ -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

22
Language/Haskell/GhcMod/FillSig.hs
View File

@ -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)
----------------------------------------------------------------

12
Language/Haskell/GhcMod/Flag.hs
View File

@ -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-"]
]

19
Language/Haskell/GhcMod/GHCApi.hs
View File

@ -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'

16
Language/Haskell/GhcMod/Ghc.hs
View File

@ -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

27
Language/Haskell/GhcMod/Info.hs
View File

@ -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]

3
Language/Haskell/GhcMod/Internal.hs
View File

@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal (
, cabalDependPackages
, cabalSourceDirs
, cabalAllTargets
-- * GHC.Paths
, systemLibDir
-- * IO
, getSystemLibDir
, getDynamicFlags
-- * Initializing 'DynFlags'
, initializeFlagsWithCradle

6
Language/Haskell/GhcMod/Lang.hs
View File

@ -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

20
Language/Haskell/GhcMod/Lint.hs
View File

@ -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"

6
Language/Haskell/GhcMod/List.hs
View File

@ -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

23
Language/Haskell/GhcMod/Monad.hs
View File

@ -9,9 +9,11 @@ module Language.Haskell.GhcMod.Monad (
, GhcModState(..)
, runGhcMod'
, runGhcMod
, newGhcModEnv
, withErrorHandler
, toGhcMod
, options
, cradle
, module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class
, module Control.Monad.State.Class
@ -53,6 +55,7 @@ import Control.Monad.Writer.Class
import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr)
import System.Directory (getCurrentDirectory)
----------------------------------------------------------------
@ -98,18 +101,23 @@ runGhcMod' r s a = do
(a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w))
newGhcModEnv :: Options -> FilePath -> IO GhcModEnv
newGhcModEnv opt dir = do
session <- newIORef (error "empty session")
c <- findCradle' dir
return GhcModEnv {
gmGhcSession = session
, gmOptions = opt
, gmCradle = c
}
runGhcMod :: Options -> GhcMod a -> IO a
runGhcMod opt action = do
session <- newIORef (error "empty session")
cradle <- findCradle
let env = GhcModEnv { gmGhcSession = session
, gmOptions = opt
, gmCradle = cradle }
env <- liftIO $ newGhcModEnv opt =<< getCurrentDirectory
(a,(_,_)) <- runGhcMod' env defaultState $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do
toGhcMod $ initializeFlagsWithCradle opt cradle
toGhcMod $ initializeFlagsWithCradle opt (gmCradle env)
action
return a
@ -135,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

26
Language/Haskell/GhcMod/PkgDoc.hs
View File

@ -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")

1
ghc-mod.cabal
View File

@ -120,6 +120,7 @@ Executable ghc-mod
Build-Depends: base >= 4.0 && < 5
, directory
, filepath
, mtl >= 2.0
, ghc
, ghc-mod

39
src/GHCMod.hs
View File

@ -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)

51
src/GHCModi.hs
View File

@ -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"

14
test/BrowseSpec.hs
View File

@ -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"]

12
test/CheckSpec.hs
View File

@ -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` ""

9
test/FlagSpec.hs
View File

@ -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"]

4
test/GhcPkgSpec.hs
View File

@ -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

18
test/InfoSpec.hs
View File

@ -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

7
test/LangSpec.hs
View File

@ -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"]

13
test/LintSpec.hs
View File

@ -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` ""

8
test/ListSpec.hs
View File

@ -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"]

3
test/Main.hs
View File

@ -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