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 -- * Types
, ModuleString , ModuleString
, Expression , Expression
-- * 'IO' utilities , GhcPkgDb
, bootInfo -- * 'GhcMod' utilities
, boot
, browse , browse
, check
, checkSyntax , checkSyntax
, lintSyntax
, expandTemplate
, infoExpr
, typeExpr
, fillSig
, listModules
, listLanguages
, listFlags
, debugInfo , debugInfo
, rootInfo , expandTemplate
, packageDoc
, findSymbol , findSymbol
, splitVar , info
, lint
, pkgDoc
, rootInfo
, types
, splits
, sig
, modules
, languages
, flags
) where ) where
import Language.Haskell.GhcMod.Boot import Language.Haskell.GhcMod.Boot

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

@ -1,27 +1,16 @@
module Language.Haskell.GhcMod.Boot where module Language.Haskell.GhcMod.Boot where
import Control.Applicative ((<$>)) import Control.Applicative
import CoreMonad (liftIO, liftIO)
import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Browse
import Language.Haskell.GhcMod.Flag import Language.Haskell.GhcMod.Flag
import Language.Haskell.GhcMod.Lang import Language.Haskell.GhcMod.Lang
import Language.Haskell.GhcMod.List import Language.Haskell.GhcMod.List
import Language.Haskell.GhcMod.Monad 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. -- | Printing necessary information for front-end booting.
boot :: GhcMod String boot :: GhcMod String
boot = do boot = concat <$> sequence [modules, languages, flags,
opt <- options concat <$> mapM browse preBrowsedModules]
mods <- modules
langs <- liftIO $ listLanguages opt
flags <- liftIO $ listFlags opt
pre <- concat <$> mapM browse preBrowsedModules
return $ mods ++ langs ++ flags ++ pre
preBrowsedModules :: [String] preBrowsedModules :: [String]
preBrowsedModules = [ preBrowsedModules = [

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

@ -1,8 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
module Language.Haskell.GhcMod.CaseSplit ( module Language.Haskell.GhcMod.CaseSplit (
splitVar splits
, splits
) where ) where
import Data.List (find, intercalate) import Data.List (find, intercalate)
@ -11,12 +10,10 @@ import qualified Data.Text.IO as T (readFile)
import Exception (ghandle, SomeException(..)) import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..)) import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import MonadUtils (liftIO) import MonadUtils (liftIO)
import Outputable (PprStyle) import Outputable (PprStyle)
@ -35,17 +32,6 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: String
, sTycons :: [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. -- | Splitting a variable in a equation.
splits :: FilePath -- ^ A target file. splits :: FilePath -- ^ A target file.
-> Int -- ^ Line number. -> Int -- ^ Line number.
@ -212,7 +198,7 @@ srcSpanDifference b v =
in (vsl - bsl, vsc - bsc, vel - bsl, vec - bsc) -- assume variable in one line 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 :: [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 let tycon' = if ' ' `elem` tycon || ':' `elem` tycon then "(" ++ tycon ++ ")" else tycon
lengthDiff = length tycon' - length varname lengthDiff = length tycon' - length varname
tycon'' = T.pack $ if lengthDiff < 0 then tycon' ++ replicate (-lengthDiff) ' ' else tycon' 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 ( module Language.Haskell.GhcMod.Cradle (
findCradle findCradle
, findCradle'
, findCradleWithoutSandbox , findCradleWithoutSandbox
) where ) where
@ -22,8 +23,10 @@ import System.FilePath ((</>), takeDirectory)
-- in a cabal directory. -- in a cabal directory.
findCradle :: IO Cradle findCradle :: IO Cradle
findCradle = do findCradle = do
wdir <- getCurrentDirectory findCradle' =<< getCurrentDirectory
cabalCradle wdir ||> sandboxCradle wdir ||> plainCradle wdir
findCradle' :: FilePath -> IO Cradle
findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir
cabalCradle :: FilePath -> IO Cradle cabalCradle :: FilePath -> IO Cradle
cabalCradle wdir = do cabalCradle wdir = do

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

@ -1,55 +1,44 @@
module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where module Language.Haskell.GhcMod.Debug (debugInfo, rootInfo) where
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception.IOChoice ((||>))
import CoreMonad (liftIO) import CoreMonad (liftIO)
import Data.List (intercalate) import Data.List (intercalate)
import Data.Maybe (fromMaybe, isJust, fromJust) import Data.Maybe (isJust, fromJust)
import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.GHCChoice ((||>))
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Obtaining debug information. -- | Obtaining debug information.
debugInfo :: Options debugInfo :: GhcMod String
-> Cradle debugInfo = cradle >>= \c -> convert' =<< do
-> IO String
debugInfo opt cradle = convert opt <$> do
CompilerOptions gopts incDir pkgs <- CompilerOptions gopts incDir pkgs <-
if cabal then if isJust $ cradleCabalFile c then
liftIO (fromCabalFile ||> return simpleCompilerOption) (fromCabalFile c ||> simpleCompilerOption)
else else
return simpleCompilerOption simpleCompilerOption
mglibdir <- liftIO getSystemLibDir
return [ return [
"Root directory: " ++ rootDir "Root directory: " ++ cradleRootDir c
, "Current directory: " ++ currentDir , "Current directory: " ++ cradleCurrentDir c
, "Cabal file: " ++ cabalFile , "Cabal file: " ++ show (cradleCabalFile c)
, "GHC options: " ++ unwords gopts , "GHC options: " ++ unwords gopts
, "Include directories: " ++ unwords incDir , "Include directories: " ++ unwords incDir
, "Dependent packages: " ++ intercalate ", " (map showPkg pkgs) , "Dependent packages: " ++ intercalate ", " (map showPkg pkgs)
, "System libraries: " ++ fromMaybe "" mglibdir , "System libraries: " ++ systemLibDir
] ]
where where
currentDir = cradleCurrentDir cradle simpleCompilerOption = options >>= \op ->
mCabalFile = cradleCabalFile cradle return $ CompilerOptions (ghcOpts op) [] []
rootDir = cradleRootDir cradle fromCabalFile c = options >>= \opts -> liftIO $ do
cabal = isJust mCabalFile pkgDesc <- parseCabalFile $ fromJust $ cradleCabalFile c
cabalFile = fromMaybe "" mCabalFile getCompilerOptions (ghcOpts opts) c pkgDesc
origGopts = ghcOpts opt
simpleCompilerOption = CompilerOptions origGopts [] []
fromCabalFile = do
pkgDesc <- parseCabalFile file
getCompilerOptions origGopts cradle pkgDesc
where
file = fromJust mCabalFile
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Obtaining root information. -- | Obtaining root information.
rootInfo :: Options rootInfo :: GhcMod String
-> Cradle rootInfo = convert' =<< cradleRootDir <$> cradle
-> IO String
rootInfo opt cradle = return $ convert opt $ cradleRootDir cradle

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

@ -1,8 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-} {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-}
module Language.Haskell.GhcMod.FillSig ( module Language.Haskell.GhcMod.FillSig (
fillSig sig
, sig
) where ) where
import Data.Char (isSymbol) import Data.Char (isSymbol)
@ -10,12 +9,10 @@ import Data.List (find, intercalate)
import Exception (ghandle, SomeException(..)) import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.GHCApi
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.SrcUtils import Language.Haskell.GhcMod.SrcUtils
import Language.Haskell.GhcMod.Types
import MonadUtils (liftIO) import MonadUtils (liftIO)
import Outputable (PprStyle) import Outputable (PprStyle)
import qualified Type as Ty import qualified Type as Ty
@ -38,18 +35,7 @@ data SigInfo = Signature SrcSpan [G.RdrName] (G.HsType G.RdrName)
| InstanceDecl SrcSpan G.Class | InstanceDecl SrcSpan G.Class
-- Signature for fallback operation via haskell-src-exts -- Signature for fallback operation via haskell-src-exts
data HESigInfo = HESignature HE.SrcSpan [HE.Name HE.SrcSpanInfo] (HE.Type HE.SrcSpanInfo) 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
-- | Create a initial body from a signature. -- | Create a initial body from a signature.
sig :: FilePath -- ^ A target file. sig :: FilePath -- ^ A target file.
@ -67,13 +53,13 @@ sig file lineNo colNo = ghandle handler body
InstanceDecl loc cls -> do InstanceDecl loc cls -> do
("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x) ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
(Ty.classMethods cls)) (Ty.classMethods cls))
handler (SomeException _) = do handler (SomeException _) = do
opt <- options opt <- options
-- Code cannot be parsed by ghc module -- Code cannot be parsed by ghc module
-- Fallback: try to get information via haskell-src-exts -- Fallback: try to get information via haskell-src-exts
whenFound opt (getSignatureFromHE file lineNo colNo) $ whenFound opt (getSignatureFromHE file lineNo colNo) $
\(HESignature loc names ty) -> \(HESignature loc names ty) ->
("function", fourIntsHE loc, map (initialBody undefined undefined ty) names) ("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 qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Monad
-- | Listing GHC flags. (e.g -fno-warn-orphans) -- | Listing GHC flags. (e.g -fno-warn-orphans)
listFlags :: Options -> IO String flags :: GhcMod String
listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option flags = convert' [ "-f" ++ prefix ++ option
| option <- Gap.fOptions | option <- Gap.fOptions
, prefix <- ["","no-"] , prefix <- ["","no-"]
] ]

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

@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.GHCApi (
, initializeFlagsWithCradle , initializeFlagsWithCradle
, setTargetFiles , setTargetFiles
, getDynamicFlags , getDynamicFlags
, getSystemLibDir , systemLibDir
, withDynFlags , withDynFlags
, withCmdFlags , withCmdFlags
, setNoWaringFlags , setNoWaringFlags
@ -16,6 +16,8 @@ module Language.Haskell.GhcMod.GHCApi (
import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.CabalApi
import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GHCChoice
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Monad (forM, void) import Control.Monad (forM, void)
@ -25,8 +27,6 @@ import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
import qualified GHC as G import qualified GHC as G
import GhcMonad import GhcMonad
import GHC.Paths (libdir) import GHC.Paths (libdir)
import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Types
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr) import System.IO (hPutStr, hPrint, stderr)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
@ -34,8 +34,8 @@ import System.IO.Unsafe (unsafePerformIO)
---------------------------------------------------------------- ----------------------------------------------------------------
-- | Obtaining the directory for system libraries. -- | Obtaining the directory for system libraries.
getSystemLibDir :: IO (Maybe FilePath) systemLibDir :: FilePath
getSystemLibDir = return $ Just libdir systemLibDir = libdir
---------------------------------------------------------------- ----------------------------------------------------------------
@ -53,8 +53,7 @@ withGHC file body = ghandle ignore $ withGHC' body
withGHC' :: Ghc a -> IO a withGHC' :: Ghc a -> IO a
withGHC' body = do withGHC' body = do
mlibdir <- getSystemLibDir G.runGhc (Just systemLibDir) $ do
G.runGhc mlibdir $ do
dflags <- G.getSessionDynFlags dflags <- G.getSessionDynFlags
G.defaultCleanupHandler dflags body G.defaultCleanupHandler dflags body
@ -161,8 +160,7 @@ setTargetFiles files = do
-- | Return the 'DynFlags' currently in use in the GHC session. -- | Return the 'DynFlags' currently in use in the GHC session.
getDynamicFlags :: IO DynFlags getDynamicFlags :: IO DynFlags
getDynamicFlags = do getDynamicFlags = do
mlibdir <- getSystemLibDir G.runGhc (Just systemLibDir) G.getSessionDynFlags
G.runGhc mlibdir G.getSessionDynFlags
withDynFlags :: GhcMonad m withDynFlags :: GhcMonad m
=> (DynFlags -> DynFlags) => (DynFlags -> DynFlags)
@ -197,8 +195,7 @@ setAllWaringFlags df = df { warningFlags = allWarningFlags }
allWarningFlags :: Gap.WarnFlags allWarningFlags :: Gap.WarnFlags
allWarningFlags = unsafePerformIO $ do allWarningFlags = unsafePerformIO $ do
mlibdir <- getSystemLibDir G.runGhc (Just systemLibDir) $ do
G.runGhc mlibdir $ do
df <- G.getSessionDynFlags df <- G.getSessionDynFlags
df' <- addCmdOpts ["-Wall"] df df' <- addCmdOpts ["-Wall"] df
return $ G.warningFlags 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 -- * Converting the 'Ghc' monad to the 'IO' monad
withGHC withGHC
, withGHC' , withGHC'
-- * 'Ghc' utilities
, boot
, browse
, check
, info
, types
, splits
, sig
, modules
-- * 'SymMdlDb' -- * 'SymMdlDb'
, Symbol , Symbol
, SymMdlDb , SymMdlDb
@ -19,12 +10,5 @@ module Language.Haskell.GhcMod.Ghc (
, lookupSym' , lookupSym'
) where ) 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.Find
import Language.Haskell.GhcMod.GHCApi 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 ( module Language.Haskell.GhcMod.Info (
infoExpr info
, info
, typeExpr
, types , types
) where ) where
@ -13,7 +11,6 @@ import Exception (ghandle, SomeException(..))
import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type) import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, TypecheckedModule(..), SrcSpan, Type)
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod.Doc (showPage) import Language.Haskell.GhcMod.Doc (showPage)
import Language.Haskell.GhcMod.GHCApi
import Language.Haskell.GhcMod.Gap (HasType(..)) import Language.Haskell.GhcMod.Gap (HasType(..))
import qualified Language.Haskell.GhcMod.Gap as Gap import qualified Language.Haskell.GhcMod.Gap as Gap
import Language.Haskell.GhcMod.Monad 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:) -- | Obtaining information of a target expression. (GHCi's info:)
info :: FilePath -- ^ A target file. info :: FilePath -- ^ A target file.
-> Expression -- ^ A Haskell expression. -> 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:) -- | Obtaining type of a target expression. (GHCi's type:)
types :: FilePath -- ^ A target file. types :: FilePath -- ^ A target file.
-> Int -- ^ Line number. -> Int -- ^ Line number.
@ -85,4 +61,3 @@ getSrcSpanType modSum lineNo colNo = do
ets <- mapM (getType tcm) es ets <- mapM (getType tcm) es
pts <- mapM (getType tcm) ps pts <- mapM (getType tcm) ps
return $ catMaybes $ concat [ets, bts, pts] return $ catMaybes $ concat [ets, bts, pts]

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

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

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

@ -1,10 +1,10 @@
module Language.Haskell.GhcMod.Lang where module Language.Haskell.GhcMod.Lang where
import DynFlags (supportedLanguagesAndExtensions) import DynFlags (supportedLanguagesAndExtensions)
import Language.Haskell.GhcMod.Types
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
-- | Listing language extensions. -- | Listing language extensions.
listLanguages :: Options -> IO String languages :: GhcMod String
listLanguages opt = return $ convert opt supportedLanguagesAndExtensions languages = convert' supportedLanguagesAndExtensions

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

@ -1,19 +1,21 @@
module Language.Haskell.GhcMod.Lint where module Language.Haskell.GhcMod.Lint where
import Control.Applicative ((<$>)) import Exception (ghandle)
import Control.Exception (handle, SomeException(..)) import Control.Exception (SomeException(..))
import Control.Monad.Trans (liftIO)
import Language.Haskell.GhcMod.Logger (checkErrorPrefix) import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
import Language.Haskell.GhcMod.Convert import Language.Haskell.GhcMod.Convert
import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Types import Language.Haskell.GhcMod.Types
import Language.Haskell.HLint (hlint) import Language.Haskell.HLint (hlint)
-- | Checking syntax of a target file using hlint. -- | Checking syntax of a target file using hlint.
-- Warnings and errors are returned. -- Warnings and errors are returned.
lintSyntax :: Options lint :: FilePath -- ^ A target file.
-> FilePath -- ^ A target file. -> GhcMod String
-> IO String lint file = do
lintSyntax opt file = handle handler $ pack <$> hlint (file : "--quiet" : hopts) opt <- options
where ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)
pack = convert opt . map (init . show) -- init drops the last \n. where
hopts = hlintOpts opt pack = convert' . map (init . show) -- init drops the last \n.
handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\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.Applicative ((<$>))
import Control.Exception (SomeException(..)) 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. -- | Listing installed modules.
modules :: GhcMod String modules :: GhcMod String
modules = do modules = do

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

@ -9,9 +9,11 @@ module Language.Haskell.GhcMod.Monad (
, GhcModState(..) , GhcModState(..)
, runGhcMod' , runGhcMod'
, runGhcMod , runGhcMod
, newGhcModEnv
, withErrorHandler , withErrorHandler
, toGhcMod , toGhcMod
, options , options
, cradle
, module Control.Monad.Reader.Class , module Control.Monad.Reader.Class
, module Control.Monad.Writer.Class , module Control.Monad.Writer.Class
, module Control.Monad.State.Class , module Control.Monad.State.Class
@ -53,6 +55,7 @@ import Control.Monad.Writer.Class
import Data.IORef (IORef, readIORef, writeIORef, newIORef) import Data.IORef (IORef, readIORef, writeIORef, newIORef)
import System.Exit (exitSuccess) import System.Exit (exitSuccess)
import System.IO (hPutStr, hPrint, stderr) 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 (a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s
return (a',(s',w)) 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 :: Options -> GhcMod a -> IO a
runGhcMod opt action = do runGhcMod opt action = do
session <- newIORef (error "empty session") env <- liftIO $ newGhcModEnv opt =<< getCurrentDirectory
cradle <- findCradle
let env = GhcModEnv { gmGhcSession = session
, gmOptions = opt
, gmCradle = cradle }
(a,(_,_)) <- runGhcMod' env defaultState $ do (a,(_,_)) <- runGhcMod' env defaultState $ do
dflags <- getSessionDynFlags dflags <- getSessionDynFlags
defaultCleanupHandler dflags $ do defaultCleanupHandler dflags $ do
toGhcMod $ initializeFlagsWithCradle opt cradle toGhcMod $ initializeFlagsWithCradle opt (gmCradle env)
action action
return a return a
@ -135,6 +143,9 @@ toGhcMod a = do
options :: GhcMod Options options :: GhcMod Options
options = gmOptions <$> ask options = gmOptions <$> ask
cradle :: GhcMod Cradle
cradle = gmCradle <$> ask
instance MonadBase IO GhcMod where instance MonadBase IO GhcMod where
liftBase = GhcMod . liftBase 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.Types
import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.GhcPkg
import Language.Haskell.GhcMod.Monad
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import System.Process (readProcess) import System.Process (readProcess)
-- | Obtaining the package name and the doc path of a module. -- | Obtaining the package name and the doc path of a module.
packageDoc :: Options pkgDoc :: String -> GhcMod String
-> Cradle pkgDoc mdl = cradle >>= \c -> liftIO $ do
-> ModuleString pkg <- trim <$> readProcess "ghc-pkg" (toModuleOpts c) []
-> IO String
packageDoc _ cradle mdl = pkgDoc cradle mdl
pkgDoc :: Cradle -> String -> IO String
pkgDoc cradle mdl = do
pkg <- trim <$> readProcess "ghc-pkg" toModuleOpts []
if pkg == "" then if pkg == "" then
return "\n" return "\n"
else do else do
htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg) [] htmlpath <- readProcess "ghc-pkg" (toDocDirOpts pkg c) []
let ret = pkg ++ " " ++ drop 14 htmlpath let ret = pkg ++ " " ++ drop 14 htmlpath
return ret return ret
where where
toModuleOpts = ["find-module", mdl, "--simple-output"] toModuleOpts c = ["find-module", mdl, "--simple-output"]
++ ghcPkgDbStackOpts (cradlePkgDbStack cradle) ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
toDocDirOpts pkg = ["field", pkg, "haddock-html"] toDocDirOpts pkg c = ["field", pkg, "haddock-html"]
++ ghcPkgDbStackOpts (cradlePkgDbStack cradle) ++ ghcPkgDbStackOpts (cradlePkgDbStack c)
trim = takeWhile (`notElem` " \n") trim = takeWhile (`notElem` " \n")

1
ghc-mod.cabal
View File

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

39
src/GHCMod.hs
View File

@ -5,6 +5,7 @@ module Main where
import Config (cProjectVersion) import Config (cProjectVersion)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Exception (Exception, Handler(..), ErrorCall(..)) import Control.Exception (Exception, Handler(..), ErrorCall(..))
import Control.Monad.Trans (liftIO)
import qualified Control.Exception as E import qualified Control.Exception as E
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
@ -102,7 +103,6 @@ main = flip E.catches handlers $ do
-- #endif -- #endif
args <- getArgs args <- getArgs
let (opt,cmdArg) = parseArgs argspec args let (opt,cmdArg) = parseArgs argspec args
cradle <- findCradle
let cmdArg0 = cmdArg !. 0 let cmdArg0 = cmdArg !. 0
cmdArg1 = cmdArg !. 1 cmdArg1 = cmdArg !. 1
cmdArg3 = cmdArg !. 3 cmdArg3 = cmdArg !. 3
@ -111,23 +111,23 @@ main = flip E.catches handlers $ do
nArgs n f = if length remainingArgs == n nArgs n f = if length remainingArgs == n
then f then f
else E.throw (ArgumentsMismatch cmdArg0) else E.throw (ArgumentsMismatch cmdArg0)
res <- case cmdArg0 of res <- runGhcMod opt $ case cmdArg0 of
"list" -> listModules opt cradle "list" -> modules
"lang" -> listLanguages opt "lang" -> languages
"flag" -> listFlags opt "flag" -> flags
"browse" -> runGhcMod opt $ concat <$> mapM browse remainingArgs "browse" -> concat <$> mapM browse remainingArgs
"check" -> runGhcMod opt $ checkSyntax remainingArgs "check" -> checkSyntax remainingArgs
"expand" -> runGhcMod opt $ expandTemplate remainingArgs "expand" -> expandTemplate remainingArgs
"debug" -> debugInfo opt cradle "debug" -> debugInfo
"info" -> nArgs 3 infoExpr opt cradle cmdArg1 cmdArg3 "info" -> nArgs 3 info cmdArg1 cmdArg3
"type" -> nArgs 4 $ typeExpr opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) "type" -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
"split" -> nArgs 4 $ splitVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) "split" -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
"sig" -> nArgs 4 $ fillSig opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) "sig" -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
"find" -> runGhcMod opt $ nArgs 1 $ findSymbol cmdArg1 "find" -> nArgs 1 $ findSymbol cmdArg1
"lint" -> nArgs 1 withFile (lintSyntax opt) cmdArg1 "lint" -> nArgs 1 $ withFile lint cmdArg1
"root" -> rootInfo opt cradle "root" -> rootInfo
"doc" -> nArgs 1 $ packageDoc opt cradle cmdArg1 "doc" -> nArgs 1 $ pkgDoc cmdArg1
"boot" -> bootInfo opt "boot" -> boot
"version" -> return progVersion "version" -> return progVersion
"help" -> return $ O.usageInfo usage argspec "help" -> return $ O.usageInfo usage argspec
cmd -> E.throw (NoSuchCommand cmd) cmd -> E.throw (NoSuchCommand cmd)
@ -152,8 +152,9 @@ main = flip E.catches handlers $ do
hPutStrLn stderr $ "\"" ++ file ++ "\" not found" hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
printUsage printUsage
printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
withFile :: (FilePath -> GhcMod a) -> FilePath -> GhcMod a
withFile cmd file = do withFile cmd file = do
exist <- doesFileExist file exist <- liftIO $ doesFileExist file
if exist if exist
then cmd file then cmd file
else E.throw (FileNotExist 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 qualified Data.Set as S
import Data.Typeable (Typeable) import Data.Typeable (Typeable)
import Data.Version (showVersion) import Data.Version (showVersion)
import Exception (ghandle)
import GHC (GhcMonad) import GHC (GhcMonad)
import qualified GHC as G import qualified GHC as G
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Language.Haskell.GhcMod.Ghc import Language.Haskell.GhcMod.Ghc
import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Monad
import Language.Haskell.GhcMod.Internal
import Paths_ghc_mod import Paths_ghc_mod
import System.Console.GetOpt import System.Console.GetOpt
import System.Directory (setCurrentDirectory) import System.Directory (setCurrentDirectory)
@ -98,12 +98,11 @@ main = E.handle cmdHandler $
go (opt,_) = E.handle someHandler $ do go (opt,_) = E.handle someHandler $ do
cradle0 <- findCradle cradle0 <- findCradle
let rootdir = cradleRootDir cradle0 let rootdir = cradleRootDir cradle0
cradle = cradle0 { cradleCurrentDir = rootdir } -- c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
setCurrentDirectory rootdir setCurrentDirectory rootdir
mvar <- liftIO newEmptyMVar mvar <- liftIO newEmptyMVar
mlibdir <- getSystemLibDir void $ forkIO $ runGhcMod opt $ setupDB mvar
void $ forkIO $ setupDB cradle mlibdir opt mvar runGhcMod opt $ loop S.empty mvar
run cradle mlibdir opt $ loop opt S.empty mvar
where where
-- this is just in case. -- this is just in case.
-- If an error is caught here, it is a bug of GhcMod library. -- 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 setupDB :: MVar SymMdlDb -> GhcMod ()
run _ _ opt body = runGhcMod opt $ do setupDB mvar = ghandle handler $ do
dflags <- G.getSessionDynFlags liftIO . putMVar mvar =<< getSymMdlDb
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
where where
handler (SomeException _) = return () -- fixme: put emptyDb? handler (SomeException _) = return () -- fixme: put emptyDb?
---------------------------------------------------------------- ----------------------------------------------------------------
loop :: Options -> Set FilePath -> MVar SymMdlDb -> GhcMod () loop :: Set FilePath -> MVar SymMdlDb -> GhcMod ()
loop opt set mvar = do loop set mvar = do
cmdArg <- liftIO getLine cmdArg <- liftIO getLine
let (cmd,arg') = break (== ' ') cmdArg let (cmd,arg') = break (== ' ') cmdArg
arg = dropWhile (== ' ') arg' arg = dropWhile (== ' ') arg'
(ret,ok,set') <- case cmd of (ret,ok,set') <- case cmd of
"check" -> checkStx opt set arg "check" -> checkStx set arg
"find" -> findSym set arg mvar "find" -> findSym set arg mvar
"lint" -> toGhcMod $ lintStx opt set arg "lint" -> lintStx set arg
"info" -> showInfo set arg "info" -> showInfo set arg
"type" -> showType set arg "type" -> showType set arg
"split" -> doSplit set arg "split" -> doSplit set arg
@ -157,15 +148,14 @@ loop opt set mvar = do
else do else do
liftIO $ putStrLn $ "NG " ++ replace ret liftIO $ putStrLn $ "NG " ++ replace ret
liftIO $ hFlush stdout liftIO $ hFlush stdout
when ok $ loop opt set' mvar when ok $ loop set' mvar
---------------------------------------------------------------- ----------------------------------------------------------------
checkStx :: Options checkStx :: Set FilePath
-> Set FilePath
-> FilePath -> FilePath
-> GhcMod (String, Bool, Set FilePath) -> GhcMod (String, Bool, Set FilePath)
checkStx _ set file = do checkStx set file = do
set' <- toGhcMod $ newFileSet set file set' <- toGhcMod $ newFileSet set file
let files = S.toList set' let files = S.toList set'
eret <- check files eret <- check files
@ -209,16 +199,17 @@ findSym set sym mvar = do
let ret = lookupSym' opt sym db let ret = lookupSym' opt sym db
return (ret, True, set) return (ret, True, set)
lintStx :: GhcMonad m lintStx :: Set FilePath
=> Options -> Set FilePath -> FilePath -> FilePath
-> m (String, Bool, Set FilePath) -> GhcMod (String, Bool, Set FilePath)
lintStx opt set optFile = liftIO $ do lintStx set optFile = do
ret <-lintSyntax opt' file ret <- local env' $ lint file
return (ret, True, set) return (ret, True, set)
where where
(opts,file) = parseLintOptions optFile (opts,file) = parseLintOptions optFile
hopts = if opts == "" then [] else read opts 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" -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"

14
test/BrowseSpec.hs
View File

@ -10,25 +10,25 @@ import Dir
spec :: Spec spec :: Spec
spec = do spec = do
describe "browse" $ do describe "browse Data.Map" $ do
it "lists up symbols in the module" $ do it "contains at least `differenceWithKey'" $ do
syms <- runD $ lines <$> browse "Data.Map" syms <- runD $ lines <$> browse "Data.Map"
syms `shouldContain` ["differenceWithKey"] syms `shouldContain` ["differenceWithKey"]
describe "browse -d" $ do describe "browse -d Data.Either" $ do
it "lists up symbols with type info in the module" $ do it "contains functions (e.g. `either') including their type signature" $ do
syms <- run defaultOptions { detailed = True } syms <- run defaultOptions { detailed = True }
$ lines <$> browse "Data.Either" $ lines <$> browse "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 it "contains type constructors (e.g. `Left') including their type signature" $ do
cradle <- findCradle cradle <- findCradle
syms <- run defaultOptions { detailed = True} syms <- run defaultOptions { detailed = True}
$ lines <$> browse "Data.Either" $ lines <$> browse "Data.Either"
syms `shouldContain` ["Left :: a -> Either a b"] syms `shouldContain` ["Left :: a -> Either a b"]
describe "browse local" $ do describe "`browse' in a project directory" $ do
it "lists symbols in a local module" $ do it "lists symbols defined in a a local module (e.g. `Baz.baz)" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data" $ do
syms <- runID $ lines <$> browse "Baz" syms <- runID $ lines <$> browse "Baz"
syms `shouldContain` ["baz"] syms `shouldContain` ["baz"]

12
test/CheckSpec.hs
View File

@ -12,28 +12,28 @@ import Dir
spec :: Spec spec :: Spec
spec = do spec = do
describe "checkSyntax" $ 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 withDirectory_ "test/data/ghc-mod-check" $ do
res <- runID $ checkSyntax ["main.hs"] res <- runID $ checkSyntax ["main.hs"]
res `shouldBe` "main.hs:5:1:Warning: Top-level binding with no type signature: main :: IO ()\n" 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 withDirectory_ "test/data/check-test-subdir" $ do
res <- runID $ checkSyntax ["test/Bar/Baz.hs"] 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`) 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 withDirectory_ "test/data" $ do
res <- runID $ checkSyntax ["Mutual1.hs"] res <- runID $ checkSyntax ["Mutual1.hs"]
res `shouldSatisfy` ("Module imports form a cycle" `isInfixOf`) 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 withDirectory_ "test/data" $ do
res <- runID $ checkSyntax ["Baz.hs"] res <- runID $ checkSyntax ["Baz.hs"]
res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`) res `shouldSatisfy` ("Baz.hs:5:1:Warning:" `isPrefixOf`)
context "without errors" $ do context "when no errors are found" $ do
it "doesn't output empty line" $ do it "doesn't output an empty line" $ do
withDirectory_ "test/data/ghc-mod-check/Data" $ do withDirectory_ "test/data/ghc-mod-check/Data" $ do
res <- runID $ checkSyntax ["Foo.hs"] res <- runID $ checkSyntax ["Foo.hs"]
res `shouldBe` "" res `shouldBe` ""

9
test/FlagSpec.hs
View File

@ -3,10 +3,11 @@ module FlagSpec where
import Control.Applicative import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils
spec :: Spec spec :: Spec
spec = do spec = do
describe "listFlags" $ do describe "flags" $ do
it "lists up GHC flags" $ do it "contains at least `-fno-warn-orphans'" $ do
flags <- lines <$> listFlags defaultOptions f <- runD $ lines <$> flags
flags `shouldContain` ["-fno-warn-orphans"] 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"] getPackageDbStack "test/data/" `shouldReturn` [GlobalDb, PackageDb $ cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d"]
#endif #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 cwd <- getCurrentDirectory
pkgDb <- getSandboxDb "test/data/" pkgDb <- getSandboxDb "test/data/"
pkgDb `shouldBe` (cwd </> "test/data/.cabal-sandbox/i386-osx-ghc-7.6.3-packages.conf.d") 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 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.FilePath
import System.Process import System.Process
import Test.Hspec import Test.Hspec
import TestUtils
import Dir import Dir
spec :: Spec spec :: Spec
spec = do spec = do
describe "typeExpr" $ do describe "types" $ do
it "shows types of the expression and its outers" $ do it "shows types of the expression and its outers" $ do
withDirectory_ "test/data/ghc-mod-check" $ do withDirectory_ "test/data/ghc-mod-check" $ do
cradle <- findCradleWithoutSandbox 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" 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 it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox 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]\""] res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
it "works with a module that imports another module using TemplateHaskell" $ do it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox 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 ()\""] 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 it "works for non-export functions" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Info.hs" "fib" res <- runD $ info "Info.hs" "fib"
res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
it "works with a module using TemplateHaskell" $ do it "works with a module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Bar.hs" "foo" res <- runD $ info "Bar.hs" "foo"
res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
it "works with a module that imports another module using TemplateHaskell" $ do it "works with a module that imports another module using TemplateHaskell" $ do
withDirectory_ "test/data" $ do withDirectory_ "test/data" $ do
cradle <- findCradleWithoutSandbox cradle <- findCradleWithoutSandbox
res <- infoExpr defaultOptions cradle "Main.hs" "bar" res <- runD $ info "Main.hs" "bar"
res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
it "doesn't fail on unicode output" $ do 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 Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils
spec :: Spec spec :: Spec
spec = do spec = do
describe "listLanguages" $ do describe "languages" $ do
it "lists up language extensions" $ do it "contains at lest `OverloadedStrings'" $ do
exts <- lines <$> listLanguages defaultOptions exts <- runD $ lines <$> languages
exts `shouldContain` ["OverloadedStrings"] exts `shouldContain` ["OverloadedStrings"]

13
test/LintSpec.hs
View File

@ -2,15 +2,16 @@ module LintSpec where
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils
spec :: Spec spec :: Spec
spec = do spec = do
describe "lintSyntax" $ do describe "lint" $ do
it "check syntax with HLint" $ do it "can detect a redundant import" $ do
res <- lintSyntax defaultOptions "test/data/hlint.hs" 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" 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 context "when no suggestions are given" $ do
it "doesn't output empty line" $ do it "doesn't output an empty line" $ do
res <- lintSyntax defaultOptions "test/data/ghc-mod-check/Data/Foo.hs" res <- runD $ lint "test/data/ghc-mod-check/Data/Foo.hs"
res `shouldBe` "" res `shouldBe` ""

8
test/ListSpec.hs
View File

@ -3,11 +3,11 @@ module ListSpec where
import Control.Applicative import Control.Applicative
import Language.Haskell.GhcMod import Language.Haskell.GhcMod
import Test.Hspec import Test.Hspec
import TestUtils
spec :: Spec spec :: Spec
spec = do spec = do
describe "listModules" $ do describe "modules" $ do
it "lists up module names" $ do it "contains at least `Data.Map'" $ do
cradle <- findCradle modules <- runD $ lines <$> modules
modules <- lines <$> listModules defaultOptions cradle
modules `shouldContain` ["Data.Map"] 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 Language.Haskell.GhcMod (debugInfo, defaultOptions, findCradle)
import Control.Exception as E import Control.Exception as E
import TestUtils
main = do main = do
let sandboxes = [ "test/data", "test/data/check-packageid" let sandboxes = [ "test/data", "test/data/check-packageid"
@ -25,7 +26,7 @@ main = do
putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal putStrLn $ "ghc-mod was built with Cabal version " ++ VERSION_Cabal
system "ghc --version" system "ghc --version"
(putStrLn =<< debugInfo defaultOptions =<< findCradle) (putStrLn =<< runD debugInfo)
`E.catch` (\(_ :: E.SomeException) -> return () ) `E.catch` (\(_ :: E.SomeException) -> return () )
hspec spec hspec spec