diff --git a/.travis.yml b/.travis.yml index d6da67d..10905cb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,33 +1,25 @@ -env: - - GHCVER=7.4.2 - - GHCVER=7.6.3 - - GHCVER=7.8.2 - -before_install: - - sudo add-apt-repository -y ppa:hvr/ghc - - sudo apt-get update - - sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy-1.19.3 - - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/1.18/bin:/opt/happy/1.19.3/bin:$PATH +language: haskell +ghc: + - 7.4 + - 7.6 + - 7.8 install: - cabal update - - cabal install --only-dependencies --enable-tests + - cabal install happy --constraint 'transformers <= 0.3.0.0' + - happy --version + - cabal install -j --only-dependencies --enable-tests script: + - cabal check + - cabal sdist + - export SRC_TGZ="$PWD/dist/$(cabal info . | awk '{print $2 ".tar.gz";exit}')" + - rm -rf /tmp/test && mkdir -p /tmp/test + - cd /tmp/test + - tar -xf $SRC_TGZ && cd ghc-mod*/ - cabal configure --enable-tests - cabal build - cabal test - - cabal check - - cabal sdist - # The following scriptlet checks that the resulting source distribution can be built & installed - - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}'); - cd dist/; - if [ -f "$SRC_TGZ" ]; then - cabal install --enable-tests "$SRC_TGZ"; - else - echo "expected '$SRC_TGZ' not found"; - exit 1; - fi matrix: allow_failures: diff --git a/Language/Haskell/GhcMod.hs b/Language/Haskell/GhcMod.hs index 1f68ddf..01c0e04 100644 --- a/Language/Haskell/GhcMod.hs +++ b/Language/Haskell/GhcMod.hs @@ -12,24 +12,25 @@ module Language.Haskell.GhcMod ( -- * Types , ModuleString , Expression - -- * 'IO' utilities - , bootInfo + , GhcPkgDb + -- * 'GhcMod' utilities + , boot , browse + , check , checkSyntax - , lintSyntax - , expandTemplate - , infoExpr - , typeExpr - , fillSig - , refineVar - , 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..a95429c 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 :: IOish m => GhcModT m String +boot = concat <$> sequence [modules, languages, flags, + concat <$> mapM browse preBrowsedModules] preBrowsedModules :: [String] preBrowsedModules = [ diff --git a/Language/Haskell/GhcMod/Browse.hs b/Language/Haskell/GhcMod/Browse.hs index 49798db..aa0d1df 100644 --- a/Language/Haskell/GhcMod/Browse.hs +++ b/Language/Haskell/GhcMod/Browse.hs @@ -10,10 +10,10 @@ import Data.List (sort) import Data.Maybe (catMaybes) import Exception (ghandle) import FastString (mkFastString) -import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon, Module) +import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon) import qualified GHC as G import Language.Haskell.GhcMod.Doc (showPage, showOneLine, styleUnqualified) -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Gap import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Convert @@ -28,8 +28,9 @@ import Type (dropForAlls, splitFunTy_maybe, mkFunTy, isPredTy) -- | Getting functions, classes, etc from a module. -- If 'detailed' is 'True', their types are also obtained. -- If 'operators' is 'True', operators are also returned. -browse :: ModuleString -- ^ A module name. (e.g. \"Data.List\") - -> GhcMod String +browse :: IOish m + => ModuleString -- ^ A module name. (e.g. \"Data.List\") + -> GhcModT m String browse pkgmdl = convert' . sort =<< (listExports =<< getModule) where (mpkg,mdl) = splitPkgMdl pkgmdl @@ -61,7 +62,7 @@ splitPkgMdl pkgmdl = case break (==':') pkgmdl of (mdl,"") -> (Nothing,mdl) (pkg,_:mdl) -> (Just pkg,mdl) -processExports :: ModuleInfo -> GhcMod [String] +processExports :: IOish m => ModuleInfo -> GhcModT m [String] processExports minfo = do opt <- options let @@ -70,13 +71,13 @@ processExports minfo = do | otherwise = filter (isAlpha . head . getOccString) mapM (showExport opt minfo) $ removeOps $ G.modInfoExports minfo -showExport :: Options -> ModuleInfo -> Name -> GhcMod String +showExport :: IOish m => Options -> ModuleInfo -> Name -> GhcModT m String showExport opt minfo e = do mtype' <- mtype return $ concat $ catMaybes [mqualified, Just $ formatOp $ getOccString e, mtype'] where mqualified = (G.moduleNameString (G.moduleName $ G.nameModule e) ++ ".") `justIf` qualified opt - mtype :: GhcMod (Maybe String) + mtype :: IOish m => GhcModT m (Maybe String) mtype | detailed opt = do tyInfo <- G.modInfoLookupName minfo e @@ -91,7 +92,7 @@ showExport opt minfo e = do | isAlpha n = nm | otherwise = "(" ++ nm ++ ")" formatOp "" = error "formatOp" - inOtherModule :: Name -> GhcMod (Maybe TyThing) + inOtherModule :: IOish m => Name -> GhcModT m (Maybe TyThing) inOtherModule nm = G.getModuleInfo (G.nameModule nm) >> G.lookupGlobalName nm justIf :: a -> Bool -> Maybe a justIf x True = Just x @@ -138,13 +139,13 @@ showOutputable dflag = unwords . lines . showPage dflag styleUnqualified . ppr ---------------------------------------------------------------- -- | Browsing all functions in all system/user modules. -browseAll :: DynFlags -> GhcMod [(String,String)] +browseAll :: IOish m => DynFlags -> GhcModT m [(String,String)] browseAll dflag = do ms <- G.packageDbModules True is <- mapM G.getModuleInfo ms return $ concatMap (toNameModule dflag) (zip ms is) -toNameModule :: DynFlags -> (Module, Maybe ModuleInfo) -> [(String,String)] +toNameModule :: DynFlags -> (G.Module, Maybe ModuleInfo) -> [(String,String)] toNameModule _ (_,Nothing) = [] toNameModule dflag (m,Just inf) = map (\name -> (toStr name, mdl)) names where diff --git a/Language/Haskell/GhcMod/CabalApi.hs b/Language/Haskell/GhcMod/CabalApi.hs index b052c4d..e312488 100644 --- a/Language/Haskell/GhcMod/CabalApi.hs +++ b/Language/Haskell/GhcMod/CabalApi.hs @@ -10,9 +10,10 @@ module Language.Haskell.GhcMod.CabalApi ( , cabalConfigDependencies ) where -import Language.Haskell.GhcMod.Types -import Language.Haskell.GhcMod.GhcPkg import Language.Haskell.GhcMod.CabalConfig +import Language.Haskell.GhcMod.Gap (benchmarkBuildInfo, benchmarkTargets, toModuleString) +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) import qualified Control.Exception as E @@ -20,7 +21,6 @@ import Control.Monad (filterM) import CoreMonad (liftIO) import Data.Maybe (maybeToList) import Data.Set (fromList, toList) -import Distribution.ModuleName (ModuleName,toFilePath) import Distribution.Package (Dependency(Dependency) , PackageName(PackageName)) import qualified Distribution.Package as C @@ -119,11 +119,7 @@ cabalAllBuildInfo pd = libBI ++ execBI ++ testBI ++ benchBI libBI = map P.libBuildInfo $ maybeToList $ P.library pd execBI = map P.buildInfo $ P.executables pd testBI = map P.testBuildInfo $ P.testSuites pd -#if __GLASGOW_HASKELL__ >= 704 - benchBI = map P.benchmarkBuildInfo $ P.benchmarks pd -#else - benchBI = [] -#endif + benchBI = benchmarkBuildInfo pd ---------------------------------------------------------------- @@ -172,16 +168,7 @@ cabalAllTargets pd = do Just l -> P.libModules l libTargets = map toModuleString lib -#if __GLASGOW_HASKELL__ >= 704 - benchTargets = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd -#else - benchTargets = [] -#endif - toModuleString :: ModuleName -> String - toModuleString mn = fromFilePath $ toFilePath mn - - fromFilePath :: FilePath -> String - fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp + benchTargets = benchmarkTargets pd getTestTarget :: TestSuite -> IO [String] getTestTarget ts = diff --git a/Language/Haskell/GhcMod/CaseSplit.hs b/Language/Haskell/GhcMod/CaseSplit.hs index 3399a3c..01fe777 100644 --- a/Language/Haskell/GhcMod/CaseSplit.hs +++ b/Language/Haskell/GhcMod/CaseSplit.hs @@ -1,28 +1,24 @@ {-# LANGUAGE CPP #-} module Language.Haskell.GhcMod.CaseSplit ( - splitVar - , splits + splits ) where +import CoreMonad (liftIO) import Data.List (find, intercalate) import qualified Data.Text as T import qualified Data.Text.IO as T (readFile) +import qualified DataCon as Ty import Exception (ghandle, SomeException(..)) -import GHC (GhcMonad, LHsBind, LHsExpr, LPat, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L)) +import GHC (GhcMonad, LHsBind, 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 Language.Haskell.GhcMod.Convert 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) -import qualified Type as Ty import qualified TyCon as Ty -import qualified DataCon as Ty +import qualified Type as Ty ---------------------------------------------------------------- -- CASE SPLITTING @@ -36,21 +32,11 @@ data SplitToTextInfo = SplitToTextInfo { sVarName :: 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. +splits :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> GhcMod String + -> GhcModT m String splits file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do @@ -73,17 +59,12 @@ getSrcSpanTypeForSplit modSum lineNo colNo = do tcm@TypecheckedModule{tm_typechecked_source = tcs} <- G.typecheckModule p let bs:_ = listifySpans tcs (lineNo, colNo) :: [LHsBind Id] varPat = find isPatternVar $ listifySpans tcs (lineNo, colNo) :: Maybe (LPat Id) - match:_ = listifyParsedSpans pms (lineNo, colNo) -#if __GLASGOW_HASKELL__ < 708 - :: [G.LMatch G.RdrName] -#else - :: [G.LMatch G.RdrName (LHsExpr G.RdrName)] -#endif + match:_ = listifyParsedSpans pms (lineNo, colNo) :: [Gap.GLMatch] case varPat of Nothing -> return Nothing Just varPat' -> do - varT <- getType tcm varPat' -- Finally we get the type of the var - bsT <- getType tcm bs + varT <- Gap.getType tcm varPat' -- Finally we get the type of the var + bsT <- Gap.getType tcm bs case (varT, bsT) of (Just varT', Just (_,bsT')) -> let (L matchL (G.Match _ _ (G.GRHSs rhsLs _))) = match @@ -212,7 +193,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/Check.hs b/Language/Haskell/GhcMod/Check.hs index 4c2af9a..b4fe7fd 100644 --- a/Language/Haskell/GhcMod/Check.hs +++ b/Language/Haskell/GhcMod/Check.hs @@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.Check ( ) where import Control.Applicative ((<$>)) -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.DynFlags import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Monad @@ -15,8 +15,9 @@ import Language.Haskell.GhcMod.Monad -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned. -checkSyntax :: [FilePath] -- ^ The target files. - -> GhcMod String +checkSyntax :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String checkSyntax [] = return "" checkSyntax files = withErrorHandler sessionName $ do either id id <$> check files @@ -29,17 +30,19 @@ checkSyntax files = withErrorHandler sessionName $ do -- | Checking syntax of a target file using GHC. -- Warnings and errors are returned. -check :: [FilePath] -- ^ The target files. - -> GhcMod (Either String String) +check :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m (Either String String) check fileNames = do - withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $ do + withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $ setTargetFiles fileNames ---------------------------------------------------------------- -- | Expanding Haskell Template. -expandTemplate :: [FilePath] -- ^ The target files. - -> GhcMod String +expandTemplate :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m String expandTemplate [] = return "" expandTemplate files = withErrorHandler sessionName $ do either id id <$> expand files @@ -51,7 +54,8 @@ expandTemplate files = withErrorHandler sessionName $ do ---------------------------------------------------------------- -- | Expanding Haskell Template. -expand :: [FilePath] -- ^ The target files. - -> GhcMod (Either String String) +expand :: IOish m + => [FilePath] -- ^ The target files. + -> GhcModT m (Either String String) expand fileNames = withLogger (Gap.setDumpSplices . setNoWaringFlags) $ setTargetFiles fileNames diff --git a/Language/Haskell/GhcMod/Convert.hs b/Language/Haskell/GhcMod/Convert.hs index e348eca..ee1398b 100644 --- a/Language/Haskell/GhcMod/Convert.hs +++ b/Language/Haskell/GhcMod/Convert.hs @@ -23,7 +23,7 @@ inter :: Char -> [Builder] -> Builder inter _ [] = id inter c bs = foldr1 (\x y -> x . (c:) . y) bs -convert' :: ToString a => a -> GhcMod String +convert' :: (ToString a, IOish m) => a -> GhcModT m String convert' x = flip convert x <$> options convert :: ToString a => Options -> a -> String diff --git a/Language/Haskell/GhcMod/Cradle.hs b/Language/Haskell/GhcMod/Cradle.hs index 1e6e594..ecfc1c8 100644 --- a/Language/Haskell/GhcMod/Cradle.hs +++ b/Language/Haskell/GhcMod/Cradle.hs @@ -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 diff --git a/Language/Haskell/GhcMod/Debug.hs b/Language/Haskell/GhcMod/Debug.hs index 8de00dc..994411d 100644 --- a/Language/Haskell/GhcMod/Debug.hs +++ b/Language/Haskell/GhcMod/Debug.hs @@ -1,55 +1,42 @@ 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 Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.GHCApi +import Data.Maybe (isJust, fromJust) import Language.Haskell.GhcMod.Convert +import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Internal ---------------------------------------------------------------- -- | Obtaining debug information. -debugInfo :: Options - -> Cradle - -> IO String -debugInfo opt cradle = convert opt <$> do +debugInfo :: IOish m => GhcModT m 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: " ++ ghcLibDir ] 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 :: IOish m => GhcModT m String +rootInfo = convert' =<< cradleRootDir <$> cradle diff --git a/Language/Haskell/GhcMod/DynFlags.hs b/Language/Haskell/GhcMod/DynFlags.hs new file mode 100644 index 0000000..82096e3 --- /dev/null +++ b/Language/Haskell/GhcMod/DynFlags.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE CPP #-} + +module Language.Haskell.GhcMod.DynFlags where + +import qualified Language.Haskell.GhcMod.Gap as Gap +import Language.Haskell.GhcMod.Types + +import Control.Applicative ((<$>)) +import Control.Monad (forM, void, (>=>)) +import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) +import qualified GHC as G +import GhcMonad +import GHC.Paths (libdir) +import DynFlags (ExtensionFlag(..), xopt) + +import System.IO.Unsafe (unsafePerformIO) + +data Build = CabalPkg | SingleFile deriving Eq + +setEmptyLogger :: DynFlags -> DynFlags +setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () + +-- Fast +-- Friendly to foreign export +-- Not friendly to Template Haskell +-- Uses small memory +setModeSimple :: DynFlags -> DynFlags +setModeSimple df = df { + ghcMode = CompManager + , ghcLink = NoLink + , hscTarget = HscNothing + , optLevel = 0 + } + +-- Slow +-- Not friendly to foreign export +-- Friendly to Template Haskell +-- Uses large memory +setModeIntelligent :: DynFlags -> DynFlags +setModeIntelligent df = df { + ghcMode = CompManager + , ghcLink = LinkInMemory + , hscTarget = HscInterpreted + , optLevel = 0 + } + +setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags +setIncludeDirs idirs df = df { importPaths = idirs } + +setBuildEnv :: Build -> DynFlags -> DynFlags +setBuildEnv build = setHideAllPackages build . setCabalPackage build + +-- At the moment with this option set ghc only prints different error messages, +-- suggesting the user to add a hidden package to the build-depends in his cabal +-- file for example +setCabalPackage :: Build -> DynFlags -> DynFlags +setCabalPackage CabalPkg df = Gap.setCabalPkg df +setCabalPackage _ df = df + +-- | Enable hiding of all package not explicitly exposed (like Cabal does) +setHideAllPackages :: Build -> DynFlags -> DynFlags +setHideAllPackages CabalPkg df = Gap.setHideAllPackages df +setHideAllPackages _ df = df + +-- | Parse command line ghc options and add them to the 'DynFlags' passed +addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags +addCmdOpts cmdOpts df = + tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) + where + tfst (a,_,_) = a + +---------------------------------------------------------------- + +-- | Set the files as targets and load them. +setTargetFiles :: (GhcMonad m) => [FilePath] -> m () +setTargetFiles files = do + targets <- forM files $ \file -> G.guessTarget file Nothing + G.setTargets targets + xs <- G.depanal [] False + -- FIXME, checking state + loadTargets $ needsFallback xs + where + loadTargets False = do + -- Reporting error A and error B + void $ G.load LoadAllTargets + mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph + -- Reporting error B and error C + mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss + -- Error B duplicates. But we cannot ignore both error reportings, + -- sigh. So, the logger makes log messages unique by itself. + loadTargets True = do + df <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setModeIntelligent df) + void $ G.load LoadAllTargets + +needsFallback :: G.ModuleGraph -> Bool +needsFallback = any (hasTHorQQ . G.ms_hspp_opts) + where + hasTHorQQ :: DynFlags -> Bool + hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes] + +---------------------------------------------------------------- + +-- | Return the 'DynFlags' currently in use in the GHC session. +getDynamicFlags :: IO DynFlags +getDynamicFlags = do + G.runGhc (Just libdir) G.getSessionDynFlags + +withDynFlags :: GhcMonad m + => (DynFlags -> DynFlags) + -> m a + -> m a +withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflags <- G.getSessionDynFlags + void $ G.setSessionDynFlags (setFlags dflags) + return dflags + teardown = void . G.setSessionDynFlags + +withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a +withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) + where + setup = do + dflags <- G.getSessionDynFlags >>= addCmdOpts flags + void $ G.setSessionDynFlags dflags + return dflags + teardown = void . G.setSessionDynFlags + +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-w:". +setNoWaringFlags :: DynFlags -> DynFlags +setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags} + +-- | Set 'DynFlags' equivalent to "-Wall". +setAllWaringFlags :: DynFlags -> DynFlags +setAllWaringFlags df = df { warningFlags = allWarningFlags } + +allWarningFlags :: Gap.WarnFlags +allWarningFlags = unsafePerformIO $ do + G.runGhc (Just libdir) $ do + df <- G.getSessionDynFlags + df' <- addCmdOpts ["-Wall"] df + return $ G.warningFlags df' + +---------------------------------------------------------------- + +-- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". +setNoMaxRelevantBindings :: DynFlags -> DynFlags +#if __GLASGOW_HASKELL__ >= 708 +setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } +#else +setNoMaxRelevantBindings = id +#endif diff --git a/Language/Haskell/GhcMod/FillSig.hs b/Language/Haskell/GhcMod/FillSig.hs index 52c6430..2fcc543 100644 --- a/Language/Haskell/GhcMod/FillSig.hs +++ b/Language/Haskell/GhcMod/FillSig.hs @@ -1,10 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances, CPP #-} module Language.Haskell.GhcMod.FillSig ( - fillSig - , sig - , refineVar - , refine + sig ) where import Data.Char (isSymbol) @@ -12,23 +9,16 @@ 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 CoreMonad (liftIO) import Outputable (PprStyle) import qualified Type as Ty import qualified HsBinds as Ty import qualified Class as Ty -#if __GLASGOW_HASKELL__ >= 706 -import OccName (occName) -#else -import OccName (OccName) -import RdrName (rdrNameOcc) -#endif import qualified Language.Haskell.Exts.Annotated as HE ---------------------------------------------------------------- @@ -40,24 +30,14 @@ 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) +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. -sig :: FilePath -- ^ A target file. +sig :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> GhcMod String + -> GhcModT m String sig file lineNo colNo = ghandle handler body where body = inModuleContext file $ \dflag style -> do @@ -69,13 +49,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) ---------------------------------------------------------------- @@ -94,32 +74,9 @@ getSignature modSum lineNo colNo = do -- We found an instance declaration TypecheckedModule{tm_renamed_source = Just tcs ,tm_checked_module_info = minfo} <- G.typecheckModule p - case listifyRenamedSpans tcs (lineNo, colNo) :: [G.LInstDecl G.Name] of - -- Instance declarations of sort 'instance F (G a)' -#if __GLASGOW_HASKELL__ >= 708 - [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = - (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))))}))] -> -#elif __GLASGOW_HASKELL__ >= 706 - [L loc (G.ClsInstD - (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] -> -#else - [L loc (G.InstDecl - (L _ (G.HsForAllTy _ _ _ (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)))) _ _ _)] -> -#endif - obtainClassInfo minfo clsName loc - -- Instance declarations of sort 'instance F G' (no variables) -#if __GLASGOW_HASKELL__ >= 708 - [L loc (G.ClsInstD (G.ClsInstDecl {G.cid_poly_ty = - (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _))}))] -> -#elif __GLASGOW_HASKELL__ >= 706 - [L loc (G.ClsInstD - (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] -> -#else - [L loc (G.InstDecl - (L _ (G.HsAppTy (L _ (G.HsTyVar clsName)) _)) _ _ _)] -> -#endif - obtainClassInfo minfo clsName loc - _ -> return Nothing + case Gap.getClass $ listifyRenamedSpans tcs (lineNo, colNo) of + Just (clsName,loc) -> obtainClassInfo minfo clsName loc + Nothing -> return Nothing _ -> return Nothing where obtainClassInfo :: GhcMonad m => G.ModuleInfo -> G.Name -> SrcSpan -> m (Maybe SigInfo) obtainClassInfo minfo clsName loc = do @@ -173,7 +130,7 @@ class FnArgsInfo ty name | ty -> name, name -> ty where getFnArgs :: ty -> [FnArg] instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where - getFnName dflag style name = showOccName dflag style $ occName name + getFnName dflag style name = showOccName dflag style $ Gap.occName name getFnArgs (G.HsForAllTy _ _ _ (L _ iTy)) = getFnArgs iTy getFnArgs (G.HsParTy (L _ iTy)) = getFnArgs iTy getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy @@ -184,11 +141,6 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where _ -> False getFnArgs _ = [] -#if __GLASGOW_HASKELL__ < 706 -occName :: G.RdrName -> OccName -occName = rdrNameOcc -#endif - instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where getFnName _ _ (HE.Ident _ s) = s getFnName _ _ (HE.Symbol _ s) = s @@ -229,23 +181,13 @@ isSymbolName [] = error "This should never happen" -- REWRITE A HOLE / UNDEFINED VIA A FUNCTION ---------------------------------------------------------------- --- | Create a initial body from a signature. -refineVar :: Options - -> Cradle - -> FilePath -- ^ A target file. - -> Int -- ^ Line number. - -> Int -- ^ Column number. - -> Expression -- ^ A Haskell expression. - -> IO String -refineVar opt cradle file lineNo colNo e = runGhcMod opt $ do - initializeFlagsWithCradle opt cradle - refine file lineNo colNo e - -refine :: FilePath -- ^ A target file. +{- +refine :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. -> Expression -- ^ A Haskell expression. - -> GhcMod String + -> GhcModT m String refine file lineNo colNo expr = ghandle handler body where body = inModuleContext file $ \dflag style -> do @@ -273,3 +215,4 @@ findVar modSum lineNo colNo = do case listifyParsedSpans ps (lineNo, colNo) :: [G.LHsExpr G.RdrName] of (L loc (G.HsVar _)):_ -> return $ Just loc _ -> return Nothing +-} diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs index 850d5df..d414e40 100644 --- a/Language/Haskell/GhcMod/Find.hs +++ b/Language/Haskell/GhcMod/Find.hs @@ -31,11 +31,11 @@ type Symbol = String newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString]) -- | Finding modules to which the symbol belong. -findSymbol :: Symbol -> GhcMod String +findSymbol :: IOish m => Symbol -> GhcModT m String findSymbol sym = convert' =<< lookupSym sym <$> getSymMdlDb -- | Creating 'SymMdlDb'. -getSymMdlDb :: GhcMod SymMdlDb +getSymMdlDb :: IOish m => GhcModT m SymMdlDb getSymMdlDb = do sm <- G.getSessionDynFlags >>= browseAll #if MIN_VERSION_containers(0,5,0) diff --git a/Language/Haskell/GhcMod/Flag.hs b/Language/Haskell/GhcMod/Flag.hs index ff00fde..5fc3e2b 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 :: IOish m => GhcModT m 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 e8a7f5e..0d1f863 100644 --- a/Language/Haskell/GhcMod/GHCApi.hs +++ b/Language/Haskell/GhcMod/GHCApi.hs @@ -1,214 +1,87 @@ {-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-} module Language.Haskell.GhcMod.GHCApi ( - withGHC - , withGHC' - , initializeFlagsWithCradle - , setTargetFiles - , getDynamicFlags - , getSystemLibDir - , withDynFlags - , withCmdFlags - , setNoWaringFlags - , setAllWaringFlags - , setNoMaxRelevantBindings + ghcPkgDb + , package + , modules + , findModule + , moduleInfo + , localModuleInfo + , bindings ) where -import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.Types import Control.Applicative ((<$>)) -import Control.Monad (forM, void) -import Data.Maybe (isJust, fromJust) -import Exception (ghandle, SomeException(..)) -import GHC (DynFlags(..), GhcLink(..), HscTarget(..), LoadHowMuch(..)) +import Distribution.Package (InstalledPackageId(..)) +import qualified Data.Map as M +import GHC (DynFlags(..)) 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) +import qualified Packages as G +import qualified Module as G +import qualified OccName as G ---------------------------------------------------------------- +-- get Packages,Modules,Bindings --- | Obtaining the directory for system libraries. -getSystemLibDir :: IO (Maybe FilePath) -getSystemLibDir = return $ Just libdir +ghcPkgDb :: GhcMonad m => m PkgDb +ghcPkgDb = M.fromList <$> + maybe [] (map toKv . filterInternal) <$> pkgDatabase <$> G.getSessionDynFlags + where + toKv pkg = (fromInstalledPackageId $ G.installedPackageId pkg, pkg) + filterInternal = + filter ((/= InstalledPackageId "builtin_rts") . G.installedPackageId) ----------------------------------------------------------------- +package :: G.PackageConfig -> Package +package = fromInstalledPackageId . G.installedPackageId --- | Converting the 'Ghc' monad to the 'IO' monad. -withGHC :: FilePath -- ^ A target file displayed in an error message. - -> Ghc a -- ^ 'Ghc' actions created by the Ghc utilities. - -> IO a -withGHC file body = ghandle ignore $ withGHC' body - where - ignore :: SomeException -> IO a - ignore e = do - hPutStr stderr $ file ++ ":0:0:Error:" - hPrint stderr e - exitSuccess +modules :: G.PackageConfig -> [ModuleString] +modules = map G.moduleNameString . G.exposedModules -withGHC' :: Ghc a -> IO a -withGHC' body = do - mlibdir <- getSystemLibDir - G.runGhc mlibdir $ do - dflags <- G.getSessionDynFlags - G.defaultCleanupHandler dflags body - ----------------------------------------------------------------- - -importDirs :: [IncludeDir] -importDirs = [".","..","../..","../../..","../../../..","../../../../.."] - -data Build = CabalPkg | SingleFile deriving Eq - --- | Initialize the 'DynFlags' relating to the compilation of a single --- file or GHC session according to the 'Cradle' and 'Options' --- provided. -initializeFlagsWithCradle :: GhcMonad m - => Options - -> Cradle - -> m () -initializeFlagsWithCradle opt cradle - | cabal = withCabal |||> withSandbox - | otherwise = withSandbox - where - mCradleFile = cradleCabalFile cradle - cabal = isJust mCradleFile - ghcopts = ghcOpts opt - withCabal = do - pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile - compOpts <- liftIO $ getCompilerOptions ghcopts cradle pkgDesc - initSession CabalPkg opt compOpts - withSandbox = initSession SingleFile opt compOpts - where - pkgOpts = ghcDbStackOpts $ cradlePkgDbStack cradle - compOpts - | null pkgOpts = CompilerOptions ghcopts importDirs [] - | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] [] - wdir = cradleCurrentDir cradle - rdir = cradleRootDir cradle - ----------------------------------------------------------------- - -initSession :: GhcMonad m - => Build - -> Options - -> CompilerOptions - -> m () -initSession build Options {..} CompilerOptions {..} = do - df <- G.getSessionDynFlags - void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions - $ setLinkerOptions - $ setIncludeDirs includeDirs - $ setBuildEnv build - $ setEmptyLogger - $ Gap.addPackageFlags depPackages df) - -setEmptyLogger :: DynFlags -> DynFlags -setEmptyLogger df = Gap.setLogAction df $ \_ _ _ _ _ -> return () - ----------------------------------------------------------------- - --- we don't want to generate object code so we compile to bytecode --- (HscInterpreted) which implies LinkInMemory --- HscInterpreted -setLinkerOptions :: DynFlags -> DynFlags -setLinkerOptions df = df { - ghcLink = LinkInMemory - , hscTarget = HscInterpreted - } - -setIncludeDirs :: [IncludeDir] -> DynFlags -> DynFlags -setIncludeDirs idirs df = df { importPaths = idirs } - -setBuildEnv :: Build -> DynFlags -> DynFlags -setBuildEnv build = setHideAllPackages build . setCabalPackage build - --- At the moment with this option set ghc only prints different error messages, --- suggesting the user to add a hidden package to the build-depends in his cabal --- file for example -setCabalPackage :: Build -> DynFlags -> DynFlags -setCabalPackage CabalPkg df = Gap.setCabalPkg df -setCabalPackage _ df = df - --- | Enable hiding of all package not explicitly exposed (like Cabal does) -setHideAllPackages :: Build -> DynFlags -> DynFlags -setHideAllPackages CabalPkg df = Gap.setHideAllPackages df -setHideAllPackages _ df = df - --- | Parse command line ghc options and add them to the 'DynFlags' passed -addCmdOpts :: GhcMonad m => [GHCOption] -> DynFlags -> m DynFlags -addCmdOpts cmdOpts df = - tfst <$> G.parseDynamicFlags df (map G.noLoc cmdOpts) - where - tfst (a,_,_) = a - ----------------------------------------------------------------- - --- | Set the files as targets and load them. -setTargetFiles :: (GhcMonad m) => [FilePath] -> m () -setTargetFiles files = do - targets <- forM files $ \file -> G.guessTarget file Nothing - G.setTargets targets - void $ G.load LoadAllTargets - ----------------------------------------------------------------- - --- | Return the 'DynFlags' currently in use in the GHC session. -getDynamicFlags :: IO DynFlags -getDynamicFlags = do - mlibdir <- getSystemLibDir - G.runGhc mlibdir G.getSessionDynFlags - -withDynFlags :: GhcMonad m - => (DynFlags -> DynFlags) - -> m a - -> m a -withDynFlags setFlags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflags <- G.getSessionDynFlags - void $ G.setSessionDynFlags (setFlags dflags) - return dflags - teardown = void . G.setSessionDynFlags - -withCmdFlags :: GhcMonad m => [GHCOption] -> m a -> m a -withCmdFlags flags body = G.gbracket setup teardown (\_ -> body) - where - setup = do - dflags <- G.getSessionDynFlags >>= addCmdOpts flags - void $ G.setSessionDynFlags dflags - return dflags - teardown = void . G.setSessionDynFlags - ----------------------------------------------------------------- - --- | Set 'DynFlags' equivalent to "-w:". -setNoWaringFlags :: DynFlags -> DynFlags -setNoWaringFlags df = df { warningFlags = Gap.emptyWarnFlags} - --- | Set 'DynFlags' equivalent to "-Wall". -setAllWaringFlags :: DynFlags -> DynFlags -setAllWaringFlags df = df { warningFlags = allWarningFlags } - --- | Set 'DynFlags' equivalent to "-fno-max-relevant-bindings". -setNoMaxRelevantBindings :: DynFlags -> DynFlags -#if __GLASGOW_HASKELL__ >= 708 -setNoMaxRelevantBindings df = df { maxRelevantBinds = Nothing } -#else -setNoMaxRelevantBindings = id -#endif +findModule :: ModuleString -> PkgDb -> [Package] +findModule m db = do + M.elems $ package `M.map` (containsModule `M.filter` db) + where + containsModule :: G.PackageConfig -> Bool + containsModule pkgConf = + G.mkModuleName m `elem` G.exposedModules pkgConf -allWarningFlags :: Gap.WarnFlags -allWarningFlags = unsafePerformIO $ do - mlibdir <- getSystemLibDir - G.runGhc mlibdir $ do - df <- G.getSessionDynFlags - df' <- addCmdOpts ["-Wall"] df - return $ G.warningFlags df' +ghcPkgId :: Package -> G.PackageId +ghcPkgId (name,_,_) = + -- TODO: Adding the package version too breaks 'findModule' for some reason + -- this isn't a big deal since in the common case where we're in a cabal + -- project we just use cabal's view of package dependencies anyways so we're + -- guaranteed to only have one version of each package exposed. However when + -- we're operating without a cabal project this will probaly cause trouble. + G.stringToPackageId name + +type Binding = String + +-- | @moduleInfo mpkg module@. @mpkg@ should be 'Nothing' iff. moduleInfo +-- should look for @module@ in the working directory. +-- +-- To map a 'ModuleString' to a package see 'findModule' +moduleInfo :: GhcMonad m + => Maybe Package + -> ModuleString + -> m (Maybe G.ModuleInfo) +moduleInfo mpkg mdl = do + let mdlName = G.mkModuleName mdl + mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg + loadLocalModule + G.findModule mdlName mfsPkgId >>= G.getModuleInfo + where + loadLocalModule = case mpkg of + Just _ -> return () + Nothing -> setTargetFiles [mdl] + +localModuleInfo :: GhcMonad m => ModuleString -> m (Maybe G.ModuleInfo) +localModuleInfo mdl = moduleInfo Nothing mdl + +bindings :: G.ModuleInfo -> [Binding] +bindings minfo = do + map (G.occNameString . G.getOccName) $ G.modInfoExports minfo diff --git a/Language/Haskell/GhcMod/Gap.hs b/Language/Haskell/GhcMod/Gap.hs index 062538b..7bc9181 100644 --- a/Language/Haskell/GhcMod/Gap.hs +++ b/Language/Haskell/GhcMod/Gap.hs @@ -33,6 +33,12 @@ module Language.Haskell.GhcMod.Gap ( , fileModSummary , WarnFlags , emptyWarnFlags + , benchmarkBuildInfo + , benchmarkTargets + , toModuleString + , GLMatch + , getClass + , occName ) where import Control.Applicative hiding (empty) @@ -58,6 +64,7 @@ import StringBuffer import TcType import Var (varType) +import qualified Distribution.PackageDescription as P import qualified InstEnv import qualified Pretty import qualified StringBuffer as SB @@ -76,10 +83,12 @@ import GHC hiding (ClsInst) import GHC hiding (Instance) import Control.Arrow hiding ((<+>)) import Data.Convertible +import RdrName (rdrNameOcc) #endif #if __GLASGOW_HASKELL__ >= 704 import qualified Data.IntSet as I (IntSet, empty) +import qualified Distribution.ModuleName as M (ModuleName,toFilePath) #endif ---------------------------------------------------------------- @@ -280,8 +289,10 @@ class HasType a where instance HasType (LHsBind Id) where #if __GLASGOW_HASKELL__ >= 708 - getType _ (L spn FunBind{fun_matches = MG _ in_tys out_typ}) = return $ Just (spn, typ) - where typ = mkFunTys in_tys out_typ + getType _ (L spn FunBind{fun_matches = m}) = return $ Just (spn, typ) + where in_tys = mg_arg_tys m + out_typ = mg_res_ty m + typ = mkFunTys in_tys out_typ #else getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ) #endif @@ -396,3 +407,55 @@ type WarnFlags = [WarningFlag] emptyWarnFlags :: WarnFlags emptyWarnFlags = [] #endif + +---------------------------------------------------------------- +---------------------------------------------------------------- + +benchmarkBuildInfo :: P.PackageDescription -> [P.BuildInfo] +#if __GLASGOW_HASKELL__ >= 704 +benchmarkBuildInfo pd = map P.benchmarkBuildInfo $ P.benchmarks pd +#else +benchmarkBuildInfo pd = [] +#endif + +benchmarkTargets :: P.PackageDescription -> [String] +#if __GLASGOW_HASKELL__ >= 704 +benchmarkTargets pd = map toModuleString $ concatMap P.benchmarkModules $ P.benchmarks pd +#else +benchmarkTargets = [] +#endif + +toModuleString :: M.ModuleName -> String +toModuleString mn = fromFilePath $ M.toFilePath mn + where + fromFilePath :: FilePath -> String + fromFilePath fp = map (\c -> if c=='/' then '.' else c) fp + +---------------------------------------------------------------- +---------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 708 +type GLMatch = LMatch RdrName (LHsExpr RdrName) +#else +type GLMatch = LMatch RdrName +#endif + +getClass :: [LInstDecl Name] -> Maybe (Name, SrcSpan) +#if __GLASGOW_HASKELL__ >= 708 +-- Instance declarations of sort 'instance F (G a)' +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _))))}))] = Just (className, loc) +-- Instance declarations of sort 'instance F G' (no variables) +getClass [L loc (ClsInstD (ClsInstDecl {cid_poly_ty = (L _ (HsAppTy (L _ (HsTyVar className)) _))}))] = Just (className, loc) +#elif __GLASGOW_HASKELL__ >= 706 +getClass [L loc (ClsInstD (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) +getClass[L loc (ClsInstD (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) +#else +getClass [L loc (InstDecl (L _ (HsForAllTy _ _ _ (L _ (HsAppTy (L _ (HsTyVar className)) _)))) _ _ _)] = Just (className, loc) +getClass [L loc (InstDecl (L _ (HsAppTy (L _ (HsTyVar className)) _)) _ _ _)] = Just (className, loc) +#endif +getClass _ = Nothing + +#if __GLASGOW_HASKELL__ < 706 +occName :: RdrName -> OccName +occName = rdrNameOcc +#endif diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index 1c70e1e..074a218 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -1,31 +1,10 @@ module Language.Haskell.GhcMod.Ghc ( - -- * Converting the 'Ghc' monad to the 'IO' monad - withGHC - , withGHC' - -- * 'Ghc' utilities - , boot - , browse - , check - , info - , types - , splits - , sig - , refine - , modules -- * 'SymMdlDb' - , Symbol + Symbol , SymMdlDb , getSymMdlDb , lookupSym , 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..b58b53f 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 @@ -24,19 +21,10 @@ 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. +info :: IOish m + => FilePath -- ^ A target file. -> Expression -- ^ A Haskell expression. - -> GhcMod String + -> GhcModT m String info file expr = do opt <- options convert opt <$> ghandle handler body @@ -49,21 +37,11 @@ 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. +types :: IOish m + => FilePath -- ^ A target file. -> Int -- ^ Line number. -> Int -- ^ Column number. - -> GhcMod String + -> GhcModT m String types file lineNo colNo = do opt <- options convert opt <$> ghandle handler body @@ -85,4 +63,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..a405ff5 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -16,11 +16,10 @@ module Language.Haskell.GhcMod.Internal ( , cabalDependPackages , cabalSourceDirs , cabalAllTargets + -- * GHC.Paths + , ghcLibDir -- * IO - , getSystemLibDir , getDynamicFlags - -- * Initializing 'DynFlags' - , initializeFlagsWithCradle -- * Targets , setTargetFiles -- * Logging @@ -35,8 +34,14 @@ module Language.Haskell.GhcMod.Internal ( , (|||>) ) where +import GHC.Paths (libdir) + import Language.Haskell.GhcMod.CabalApi -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.GHCChoice import Language.Haskell.GhcMod.Logger import Language.Haskell.GhcMod.Types + +-- | Obtaining the directory for ghc system libraries. +ghcLibDir :: FilePath +ghcLibDir = libdir diff --git a/Language/Haskell/GhcMod/Lang.hs b/Language/Haskell/GhcMod/Lang.hs index 1ddc59a..badecbd 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 :: IOish m => GhcModT m String +languages = convert' supportedLanguagesAndExtensions diff --git a/Language/Haskell/GhcMod/Lint.hs b/Language/Haskell/GhcMod/Lint.hs index 23515be..934f6d4 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 CoreMonad (liftIO) import Language.Haskell.GhcMod.Logger (checkErrorPrefix) import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Monad 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 :: IOish m + => FilePath -- ^ A target file. + -> GhcModT m 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..675e21d 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(..)) @@ -6,18 +6,13 @@ import Data.List (nub, sort) import qualified GHC as G import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Convert -import Language.Haskell.GhcMod.Types import Packages (pkgIdMap, exposedModules, sourcePackageId, display) import UniqFM (eltsUFM) ---------------------------------------------------------------- -- | Listing installed modules. -listModules :: Options -> Cradle -> IO String -listModules opt _ = runGhcMod opt $ modules - --- | Listing installed modules. -modules :: GhcMod String +modules :: IOish m => GhcModT m String modules = do opt <- options convert opt . (arrange opt) <$> (getModules `G.gcatch` handler) diff --git a/Language/Haskell/GhcMod/Logger.hs b/Language/Haskell/GhcMod/Logger.hs index dfe0363..6f9ce6c 100644 --- a/Language/Haskell/GhcMod/Logger.hs +++ b/Language/Haskell/GhcMod/Logger.hs @@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.Logger ( ) where import Bag (Bag, bagToList) -import Control.Applicative ((<$>),(*>)) +import Control.Applicative ((<$>)) import CoreMonad (liftIO) import Data.IORef (IORef, newIORef, readIORef, writeIORef, modifyIORef) import Data.List (isPrefixOf) @@ -17,11 +17,10 @@ import GHC (DynFlags, SrcSpan, Severity(SevError)) import qualified GHC as G import HscTypes (SourceError, srcErrorMessages) import Language.Haskell.GhcMod.Doc (showPage, getStyle) -import Language.Haskell.GhcMod.GHCApi (withDynFlags, withCmdFlags) +import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags) import qualified Language.Haskell.GhcMod.Gap as Gap import Language.Haskell.GhcMod.Convert (convert') import Language.Haskell.GhcMod.Monad -import Language.Haskell.GhcMod.Types (Options(..)) import Outputable (PprStyle, SDoc) import System.FilePath (normalise) @@ -29,35 +28,46 @@ import System.FilePath (normalise) type Builder = [String] -> [String] -newtype LogRef = LogRef (IORef Builder) +data Log = Log [String] Builder + +newtype LogRef = LogRef (IORef Log) + +emptyLog :: Log +emptyLog = Log [] id newLogRef :: IO LogRef -newLogRef = LogRef <$> newIORef id +newLogRef = LogRef <$> newIORef emptyLog -readAndClearLogRef :: LogRef -> GhcMod String +readAndClearLogRef :: IOish m => LogRef -> GhcModT m String readAndClearLogRef (LogRef ref) = do - b <- liftIO $ readIORef ref - liftIO $ writeIORef ref id + Log _ b <- liftIO $ readIORef ref + liftIO $ writeIORef ref emptyLog convert' (b []) appendLogRef :: DynFlags -> LogRef -> DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO () -appendLogRef df (LogRef ref) _ sev src style msg = do - let !l = ppMsg src sev df style msg - modifyIORef ref (\b -> b . (l:)) +appendLogRef df (LogRef ref) _ sev src style msg = modifyIORef ref update + where + l = ppMsg src sev df style msg + update lg@(Log ls b) + | l `elem` ls = lg + | otherwise = Log (l:ls) (b . (l:)) ---------------------------------------------------------------- -- | Set the session flag (e.g. "-Wall" or "-w:") then -- executes a body. Logged messages are returned as 'String'. -- Right is success and Left is failure. -withLogger :: (DynFlags -> DynFlags) - -> GhcMod () - -> GhcMod (Either String String) +withLogger :: IOish m + => (DynFlags -> DynFlags) + -> GhcModT m () + -> GhcModT m (Either String String) withLogger setDF body = ghandle sourceError $ do logref <- liftIO $ newLogRef wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options withDynFlags (setLogger logref . setDF) $ do - withCmdFlags wflags $ do body *> (Right <$> readAndClearLogRef logref) + withCmdFlags wflags $ do + body + Right <$> readAndClearLogRef logref where setLogger logref df = Gap.setLogAction df $ appendLogRef df logref @@ -65,7 +75,7 @@ withLogger setDF body = ghandle sourceError $ do ---------------------------------------------------------------- -- | Converting 'SourceError' to 'String'. -sourceError :: SourceError -> GhcMod (Either String String) +sourceError :: IOish m => SourceError -> GhcModT m (Either String String) sourceError err = do dflags <- G.getSessionDynFlags style <- toGhcMod getStyle diff --git a/Language/Haskell/GhcMod/Monad.hs b/Language/Haskell/GhcMod/Monad.hs index 7457d72..02e9df4 100644 --- a/Language/Haskell/GhcMod/Monad.hs +++ b/Language/Haskell/GhcMod/Monad.hs @@ -1,29 +1,54 @@ {-# LANGUAGE CPP, GeneralizedNewtypeDeriving, FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses, RankNTypes, TypeFamilies #-} +{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses, RankNTypes #-} +{-# LANGUAGE TypeFamilies, UndecidableInstances, RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Language.Haskell.GhcMod.Monad ( GhcMod + , runGhcMod + , liftGhcMod + , GhcModT + , IOish , GhcModEnv(..) , GhcModWriter , GhcModState(..) - , runGhcMod' - , runGhcMod + , runGhcModT' + , runGhcModT + , newGhcModEnv , withErrorHandler , toGhcMod , options + , cradle + , Options(..) + , defaultOptions , module Control.Monad.Reader.Class , module Control.Monad.Writer.Class , module Control.Monad.State.Class ) where -import Language.Haskell.GhcMod.Cradle -import Language.Haskell.GhcMod.GHCApi +#if __GLASGOW_HASKELL__ < 708 +-- 'CoreMonad.MonadIO' and 'Control.Monad.IO.Class.MonadIO' are different +-- classes before ghc 7.8 +#define DIFFERENT_MONADIO 1 + +-- RWST doen't have a MonadIO instance before ghc 7.8 +#define MONADIO_INSTANCES 1 +#endif + + import Language.Haskell.GhcMod.Types +import Language.Haskell.GhcMod.Cradle +import Language.Haskell.GhcMod.DynFlags +import Language.Haskell.GhcMod.GhcPkg +import Language.Haskell.GhcMod.GHCChoice +import Language.Haskell.GhcMod.CabalApi +import qualified Language.Haskell.GhcMod.Gap as Gap import DynFlags import Exception import GHC +import qualified GHC as G import GHC.Paths (libdir) import GhcMonad #if __GLASGOW_HASKELL__ <= 702 @@ -36,23 +61,33 @@ import HscTypes -- So, RWST automatically becomes an instance of MonadIO. import MonadUtils -#if __GLASGOW_HASKELL__ < 708 --- To make RWST an instance of MonadIO. +#if DIFFERENT_MONADIO import Control.Monad.Trans.Class (lift) +import qualified Control.Monad.IO.Class import Data.Monoid (Monoid) #endif -import Control.Monad (liftM) -import Control.Monad.Base (MonadBase,liftBase) +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus, liftM, void) +import Control.Monad.Base (MonadBase, liftBase) + import Control.Monad.Reader.Class import Control.Monad.State.Class -import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, control, liftBaseOp, liftBaseOp_) -import Control.Monad.Trans.RWS.Lazy (RWST(..),runRWST) +import Control.Monad.Trans.Class +#if __GLASGOW_HASKELL__ < 708 +import Control.Monad.Trans.Maybe +#endif +import Control.Monad.Trans.Control (MonadBaseControl(..), StM, liftBaseWith, + control, liftBaseOp, liftBaseOp_) +import Control.Monad.Trans.RWS.Lazy (RWST(..), runRWST) import Control.Monad.Writer.Class +import Control.Monad.Error (Error(..), ErrorT(..), MonadError) +import Data.Maybe (fromJust, isJust) import Data.IORef (IORef, readIORef, writeIORef, newIORef) import System.Exit (exitSuccess) import System.IO (hPutStr, hPrint, stderr) +import System.Directory (getCurrentDirectory) ---------------------------------------------------------------- @@ -62,102 +97,268 @@ data GhcModEnv = GhcModEnv { , gmCradle :: Cradle } -data GhcModState = GhcModState +data GhcModState = GhcModState deriving (Eq,Show,Read) defaultState :: GhcModState defaultState = GhcModState type GhcModWriter = () +data GhcModError = GMENoMsg + | GMEString String + | GMECabal + | GMEGhc + deriving (Eq,Show,Read) + +instance Error GhcModError where + noMsg = GMENoMsg + strMsg = GMEString + ---------------------------------------------------------------- -newtype GhcMod a = GhcMod { - unGhcMod :: RWST GhcModEnv GhcModWriter GhcModState IO a +type IOish m = (Functor m, MonadIO m, MonadBaseControl IO m) + +type GhcMod a = GhcModT (ErrorT GhcModError IO) a + +newtype GhcModT m a = GhcModT { + unGhcModT :: RWST GhcModEnv GhcModWriter GhcModState m a } deriving (Functor - ,Applicative - ,Monad - ,MonadIO - ,MonadReader GhcModEnv - ,MonadWriter GhcModWriter - ,MonadState GhcModState + , Applicative + , Alternative + , Monad + , MonadPlus + , MonadIO +#if DIFFERENT_MONADIO + , Control.Monad.IO.Class.MonadIO +#endif + , MonadReader GhcModEnv + , MonadWriter GhcModWriter + , MonadState GhcModState + , MonadTrans ) -#if __GLASGOW_HASKELL__ < 708 +deriving instance MonadError GhcModError m => MonadError GhcModError (GhcModT m) + +#if MONADIO_INSTANCES instance (Monoid w, MonadIO m) => MonadIO (RWST r w s m) where --- liftIO :: MonadIO m => IO a -> m a liftIO = lift . liftIO + +instance (Error e, MonadIO m) => MonadIO (ErrorT e m) where + liftIO = lift . liftIO + +instance (MonadIO m) => MonadIO (MaybeT m) where + liftIO = lift . liftIO + #endif ---------------------------------------------------------------- -runGhcMod' :: GhcModEnv - -> GhcModState - -> GhcMod a - -> IO (a,(GhcModState, GhcModWriter)) -runGhcMod' r s a = do - (a', s',w) <- runRWST (unGhcMod $ initGhcMonad (Just libdir) >> a) r s - return (a',(s',w)) +-- | Initialize the 'DynFlags' relating to the compilation of a single +-- file or GHC session according to the 'Cradle' and 'Options' +-- provided. +initializeFlagsWithCradle :: GhcMonad m + => Options + -> Cradle + -> m () +initializeFlagsWithCradle opt c + | cabal = withCabal |||> withSandbox + | otherwise = withSandbox + where + mCradleFile = cradleCabalFile c + cabal = isJust mCradleFile + ghcopts = ghcOpts opt + withCabal = do + pkgDesc <- liftIO $ parseCabalFile $ fromJust mCradleFile + compOpts <- liftIO $ getCompilerOptions ghcopts c pkgDesc + initSession CabalPkg opt compOpts + withSandbox = initSession SingleFile opt compOpts + where + importDirs = [".","..","../..","../../..","../../../..","../../../../.."] + pkgOpts = ghcDbStackOpts $ cradlePkgDbStack c + compOpts + | null pkgOpts = CompilerOptions ghcopts importDirs [] + | otherwise = CompilerOptions (ghcopts ++ pkgOpts) [wdir,rdir] [] + wdir = cradleCurrentDir c + rdir = cradleRootDir 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 } - (a,(_,_)) <- runGhcMod' env defaultState $ do - dflags <- getSessionDynFlags - defaultCleanupHandler dflags $ do - toGhcMod $ initializeFlagsWithCradle opt cradle - action - return a +initSession :: GhcMonad m + => Build + -> Options + -> CompilerOptions + -> m () +initSession build Options {..} CompilerOptions {..} = do + df <- G.getSessionDynFlags + void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions + $ setModeSimple + $ setIncludeDirs includeDirs + $ setBuildEnv build + $ setEmptyLogger + $ Gap.addPackageFlags depPackages df) ---------------------------------------------------------------- -withErrorHandler :: String -> GhcMod a -> GhcMod a +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 + } + +-- | Run a @GhcModT m@ computation, i.e. one with a custom underlying monad. +-- +-- You probably don't want this, look at 'runGhcMod' instead. +runGhcModT :: IOish m => Options -> GhcModT m a -> m a +runGhcModT opt action = do + env <- liftBase $ newGhcModEnv opt =<< getCurrentDirectory + (a,(_,_)) <- runGhcModT' env defaultState $ do + dflags <- getSessionDynFlags + defaultCleanupHandler dflags $ do + initializeFlagsWithCradle opt (gmCradle env) + action + return a + +-- | Run a computation inside @GhcModT@ providing the RWST environment and +-- initial state. This is a low level function, use it only if you know what to +-- do with 'GhcModEnv' and 'GhcModState'. +-- +-- You should probably look at 'runGhcModT' instead. +runGhcModT' :: IOish m + => GhcModEnv + -> GhcModState + -> GhcModT m a + -> m (a,(GhcModState, GhcModWriter)) +runGhcModT' r s a = do + (a',s',w) <- runRWST (unGhcModT $ initGhcMonad (Just libdir) >> a) r s + return (a',(s',w)) + +-- | Run a 'GhcMod' computation. If you want an underlying monad other than +-- 'ErrorT e IO' you should look at 'runGhcModT' +runGhcMod :: Options + -> GhcMod a + -> IO (Either GhcModError a) +runGhcMod o a = + runErrorT $ runGhcModT o a + +liftErrorT :: IOish m => GhcModT m a -> GhcModT (ErrorT GhcModError m) a +liftErrorT action = + GhcModT $ RWST $ \e s -> ErrorT $ Right <$> (runRWST $ unGhcModT action) e s + +-- | Lift @(GhcModT IO)@ into @GhcMod@, which is an alias for @GhcModT (ErrorT +-- GhcModError IO)@. +liftGhcMod :: GhcModT IO a -> GhcMod a +liftGhcMod = liftErrorT + +---------------------------------------------------------------- + +withErrorHandler :: IOish m => String -> GhcModT m a -> GhcModT m a withErrorHandler label = ghandle ignore where - ignore :: SomeException -> GhcMod a + ignore :: IOish m => SomeException -> GhcModT m a ignore e = liftIO $ do hPutStr stderr $ label ++ ":0:0:Error:" hPrint stderr e exitSuccess -toGhcMod :: Ghc a -> GhcMod a +-- | This is only a transitional mechanism don't use it for new code. +toGhcMod :: IOish m => Ghc a -> GhcModT m a toGhcMod a = do s <- gmGhcSession <$> ask liftIO $ unGhc a $ Session s ---------------------------------------------------------------- -options :: GhcMod Options +options :: IOish m => GhcModT m Options options = gmOptions <$> ask -instance MonadBase IO GhcMod where - liftBase = GhcMod . liftBase +cradle :: IOish m => GhcModT m Cradle +cradle = gmCradle <$> ask -instance MonadBaseControl IO GhcMod where - newtype StM GhcMod a = StGhcMod { - unStGhcMod :: StM (RWST GhcModEnv () GhcModState IO) a } +instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where + liftBase = GhcModT . liftBase - liftBaseWith f = GhcMod . liftBaseWith $ \runInBase -> - f $ liftM StGhcMod . runInBase . unGhcMod +instance (MonadBaseControl IO m) => MonadBaseControl IO (GhcModT m) where + newtype StM (GhcModT m) a = StGhcMod { + unStGhcMod :: StM (RWST GhcModEnv GhcModWriter GhcModState m) a } - restoreM = GhcMod . restoreM . unStGhcMod + liftBaseWith f = GhcModT . liftBaseWith $ \runInBase -> + f $ liftM StGhcMod . runInBase . unGhcModT + + restoreM = GhcModT . restoreM . unStGhcMod {-# INLINE liftBaseWith #-} {-# INLINE restoreM #-} -instance GhcMonad GhcMod where - getSession = liftIO . readIORef . gmGhcSession =<< ask - setSession a = liftIO . flip writeIORef a . gmGhcSession =<< ask +-- GHC cannot prove the following instances to be decidable automatically using +-- the FlexibleContexts extension as they violate the second Paterson Condition, +-- namely that: The assertion has fewer constructors and variables (taken +-- together and counting repetitions) than the head. Specifically the +-- @MonadBaseControl IO m@ constraint is causing this violation. +-- +-- Proof of termination: +-- +-- Assuming all constraints containing the variable `m' exist and are decidable +-- we show termination by manually replacing the current set of constraints with +-- their own set of constraints and show that this, after a finite number of +-- steps, results in the empty set, i.e. not having to check any more +-- constraints. +-- +-- We start by setting the constraints to be those immediate constraints of the +-- instance declaration which cannot be proven decidable automatically for the +-- type under consideration. +-- +-- @ +-- { MonadBaseControl IO m } +-- @ +-- +-- Classes used: +-- +-- * @class MonadBase b m => MonadBaseControl b m@ +-- +-- @ +-- { MonadBase IO m } +-- @ +-- +-- Classes used: +-- +-- * @class (Applicative b, Applicative m, Monad b, Monad m) => MonadBase b m@ +-- +-- @ +-- { Applicative IO, Applicative m, Monad IO, Monad m } +-- @ +-- +-- Classes used: +-- +-- * @class Monad m@ +-- * @class Applicative f => Functor f@ +-- +-- @ +-- { Functor m } +-- @ +-- +-- Classes used: +-- +-- * @class Functor f@ +-- +-- @ +-- { } +-- @ +-- ∎ + +instance (Functor m, MonadIO m, MonadBaseControl IO m) + => GhcMonad (GhcModT m) where + getSession = (liftIO . readIORef) . gmGhcSession =<< ask + setSession a = (liftIO . flip writeIORef a) . gmGhcSession =<< ask #if __GLASGOW_HASKELL__ >= 706 -instance HasDynFlags GhcMod where +instance (Functor m, MonadIO m, MonadBaseControl IO m) + => HasDynFlags (GhcModT m) where getDynFlags = getSessionDynFlags #endif -instance ExceptionMonad GhcMod where +instance (MonadIO m, MonadBaseControl IO m) + => ExceptionMonad (GhcModT m) where gcatch act handler = control $ \run -> run act `gcatch` (run . handler) diff --git a/Language/Haskell/GhcMod/PkgDoc.hs b/Language/Haskell/GhcMod/PkgDoc.hs index f8dd9d4..b29e172 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 CoreMonad (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 :: IOish m => String -> GhcModT m 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/Language/Haskell/GhcMod/SrcUtils.hs b/Language/Haskell/GhcMod/SrcUtils.hs index c5438a2..059bcad 100644 --- a/Language/Haskell/GhcMod/SrcUtils.hs +++ b/Language/Haskell/GhcMod/SrcUtils.hs @@ -13,7 +13,7 @@ import GhcMonad import qualified GHC as G import GHC.SYB.Utils (Stage(..), everythingStaged) import Language.Haskell.GhcMod.Doc (showOneLine, getStyle) -import Language.Haskell.GhcMod.GHCApi +import Language.Haskell.GhcMod.DynFlags import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors) import qualified Language.Haskell.GhcMod.Gap as Gap import Outputable (PprStyle) diff --git a/Language/Haskell/GhcMod/Types.hs b/Language/Haskell/GhcMod/Types.hs index b8bb908..b42b018 100644 --- a/Language/Haskell/GhcMod/Types.hs +++ b/Language/Haskell/GhcMod/Types.hs @@ -1,6 +1,9 @@ module Language.Haskell.GhcMod.Types where import Data.List (intercalate) +import qualified Data.Map as M + +import PackageConfig (PackageConfig) -- | Output style. data OutputStyle = LispStyle -- ^ S expression style. @@ -87,12 +90,18 @@ showPkg (n,v,_) = intercalate "-" [n,v] showPkgId :: Package -> String showPkgId (n,v,i) = intercalate "-" [n,v,i] +-- | Collection of packages +type PkgDb = (M.Map Package PackageConfig) + -- | Haskell expression. type Expression = String -- | Module name. type ModuleString = String +-- | A Module +type Module = [String] + -- | Option information for GHC data CompilerOptions = CompilerOptions { ghcOptions :: [GHCOption] -- ^ Command line options diff --git a/elisp/ghc-comp.el b/elisp/ghc-comp.el index 0967e62..dd40cf7 100644 --- a/elisp/ghc-comp.el +++ b/elisp/ghc-comp.el @@ -168,7 +168,7 @@ unloaded modules are loaded") (ghc-reset-window-configuration) (ghc-save-window-configuration) (with-output-to-temp-buffer ghc-completion-buffer-name - (display-completion-list list pattern)))))))) + (display-completion-list list)))))))) (defun ghc-save-window-configuration () (unless (get-buffer-window ghc-completion-buffer-name) diff --git a/elisp/ghc.el b/elisp/ghc.el index 5640dad..7678cb3 100644 --- a/elisp/ghc.el +++ b/elisp/ghc.el @@ -28,7 +28,7 @@ (< emacs-minor-version minor))) (error "ghc-mod requires at least Emacs %d.%d" major minor))) -(defconst ghc-version "4.1.0") +(defconst ghc-version "5.0.0") ;; (eval-when-compile ;; (require 'haskell-mode)) @@ -121,13 +121,14 @@ (defun ghc-debug () (interactive) (let ((el-path (locate-file "ghc.el" load-path)) - (ghc-path (executable-find "ghc")) + (ghc-path (executable-find "ghc")) ;; FIXME (ghc-mod-path (executable-find ghc-module-command)) (ghc-modi-path (executable-find ghc-interactive-command)) (el-ver ghc-version) (ghc-ver (ghc-run-ghc-mod '("--version") "ghc")) (ghc-mod-ver (ghc-run-ghc-mod '("version"))) - (ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command))) + (ghc-modi-ver (ghc-run-ghc-mod '("version") ghc-interactive-command)) + (path (getenv "PATH"))) (switch-to-buffer (get-buffer-create "**GHC Debug**")) (erase-buffer) (insert "Path: check if you are using intended programs.\n") @@ -139,6 +140,8 @@ (insert (format "\t ghc.el version %s\n" el-ver)) (insert (format "\t %s\n" ghc-mod-ver)) (insert (format "\t%s\n" ghc-modi-ver)) - (insert (format "\t%s\n" ghc-ver)))) + (insert (format "\t%s\n" ghc-ver)) + (insert "\nEnvironment variables:\n") + (insert (format "\tPATH=%s\n" path)))) (provide 'ghc) diff --git a/ghc-mod.cabal b/ghc-mod.cabal index ec9b820..9623b77 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -1,5 +1,5 @@ Name: ghc-mod -Version: 4.1.0 +Version: 5.0.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -51,6 +51,7 @@ Extra-Source-Files: ChangeLog Library Default-Language: Haskell2010 GHC-Options: -Wall + Default-Extensions: ConstraintKinds, FlexibleContexts Exposed-Modules: Language.Haskell.GhcMod Language.Haskell.GhcMod.Ghc Language.Haskell.GhcMod.Monad @@ -67,6 +68,7 @@ Library Language.Haskell.GhcMod.Convert Language.Haskell.GhcMod.Debug Language.Haskell.GhcMod.Doc + Language.Haskell.GhcMod.DynFlags Language.Haskell.GhcMod.FillSig Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.Flag @@ -100,7 +102,7 @@ Library , time , transformers , transformers-base - , mtl + , mtl >= 2.0 , monad-control , split , haskell-src-exts @@ -116,10 +118,12 @@ Executable ghc-mod Main-Is: GHCMod.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall + Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , directory , filepath + , mtl >= 2.0 , ghc , ghc-mod @@ -128,6 +132,7 @@ Executable ghc-modi Main-Is: GHCModi.hs Other-Modules: Paths_ghc_mod GHC-Options: -Wall + Default-Extensions: ConstraintKinds, FlexibleContexts HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , containers @@ -140,13 +145,15 @@ Test-Suite doctest Type: exitcode-stdio-1.0 Default-Language: Haskell2010 HS-Source-Dirs: test - Ghc-Options: -threaded -Wall + Ghc-Options: -Wall + Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: doctests.hs Build-Depends: base , doctest >= 0.9.3 Test-Suite spec Default-Language: Haskell2010 + Default-Extensions: ConstraintKinds, FlexibleContexts Main-Is: Main.hs Hs-Source-Dirs: test, . Type: exitcode-stdio-1.0 @@ -178,7 +185,7 @@ Test-Suite spec , time , transformers , transformers-base - , mtl + , mtl >= 2.0 , monad-control , hspec >= 1.8.2 , split diff --git a/src/GHCMod.hs b/src/GHCMod.hs index af0be01..6629d05 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 CoreMonad (liftIO) import qualified Control.Exception as E import Data.Typeable (Typeable) import Data.Version (showVersion) @@ -103,7 +104,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 @@ -113,24 +113,24 @@ 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) - "refine" -> nArgs 5 $ refineVar opt cradle cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5 - "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 <- runGhcModT 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) + --"refine" -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5 + "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) @@ -155,8 +155,9 @@ main = flip E.catches handlers $ do hPutStrLn stderr $ "\"" ++ file ++ "\" not found" printUsage printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec + withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m 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 ce615b8..5fd17ac 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 $ runGhcModT opt $ setupDB mvar + runGhcModT 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,36 +116,28 @@ 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 :: IOish m => MVar SymMdlDb -> GhcModT m () +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 :: IOish m => Set FilePath -> MVar SymMdlDb -> GhcModT m () +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 "sig" -> doSig set arg - "refine" -> doRefine set arg + -- "refine" -> doRefine set arg "boot" -> bootIt set "browse" -> browseIt set arg "quit" -> return ("quit", False, set) @@ -158,15 +149,15 @@ 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 :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) -checkStx _ set file = do + -> GhcModT m (String, Bool, Set FilePath) +checkStx set file = do set' <- toGhcMod $ newFileSet set file let files = S.toList set' eret <- check files @@ -202,24 +193,25 @@ isSameMainFile file (Just x) ---------------------------------------------------------------- -findSym :: Set FilePath -> String -> MVar SymMdlDb - -> GhcMod (String, Bool, Set FilePath) +findSym :: IOish m => Set FilePath -> String -> MVar SymMdlDb + -> GhcModT m (String, Bool, Set FilePath) findSym set sym mvar = do db <- liftIO $ readMVar mvar opt <- options 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 :: IOish m => Set FilePath + -> FilePath + -> GhcModT m (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" @@ -238,42 +230,47 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of ---------------------------------------------------------------- -showInfo :: Set FilePath +showInfo :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) showInfo set fileArg = do let [file, expr] = words fileArg set' <- newFileSet set file ret <- info file expr return (ret, True, set') -showType :: Set FilePath +showType :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) showType set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file ret <- types file (read line) (read column) return (ret, True, set') -doSplit :: Set FilePath +doSplit :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) doSplit set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file ret <- splits file (read line) (read column) return (ret, True, set') -doSig :: Set FilePath +doSig :: IOish m + => Set FilePath -> FilePath - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) doSig set fileArg = do let [file, line, column] = words fileArg set' <- newFileSet set file ret <- sig file (read line) (read column) return (ret, True, set') +{- doRefine :: Set FilePath -> FilePath -> GhcMod (String, Bool, Set FilePath) @@ -282,18 +279,21 @@ doRefine set fileArg = do set' <- newFileSet set file ret <- rewrite file (read line) (read column) expr return (ret, True, set') +-} ---------------------------------------------------------------- -bootIt :: Set FilePath - -> GhcMod (String, Bool, Set FilePath) +bootIt :: IOish m + => Set FilePath + -> GhcModT m (String, Bool, Set FilePath) bootIt set = do ret <- boot return (ret, True, set) -browseIt :: Set FilePath +browseIt :: IOish m + => Set FilePath -> ModuleString - -> GhcMod (String, Bool, Set FilePath) + -> GhcModT m (String, Bool, Set FilePath) browseIt set mdl = do ret <- browse mdl return (ret, True, set) 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/GhcApiSpec.hs b/test/GhcApiSpec.hs new file mode 100644 index 0000000..71d2c27 --- /dev/null +++ b/test/GhcApiSpec.hs @@ -0,0 +1,31 @@ +module GhcApiSpec where + +import Control.Applicative +import Control.Monad +import Data.List (sort) +import Language.Haskell.GhcMod.GHCApi +import Test.Hspec +import TestUtils +import CoreMonad (liftIO) + +import Dir + +spec :: Spec +spec = do + describe "findModule" $ do + it "finds Data.List in `base' and `haskell2010'" + $ withDirectory_ "test/data" $ runD $ do + pkgs <- findModule "Data.List" <$> ghcPkgDb + let pkgNames = pkgName `map` pkgs + liftIO $ pkgNames `shouldContain` ["base", "haskell2010"] + + describe "moduleInfo" $ do + it "works for modules from global packages (e.g. base:Data.List)" + $ withDirectory_ "test/data" $ runD $ do + Just info <- moduleInfo (Just ("base","","")) "Data.List" + liftIO $ sort (bindings info) `shouldContain` ["++"] + + it "works for local modules" + $ withDirectory_ "test/data" $ runD $ do + Just info <- moduleInfo Nothing "Baz" + liftIO $ bindings info `shouldContain` ["baz"] 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 diff --git a/test/TestUtils.hs b/test/TestUtils.hs index acb6e21..c9ed00f 100644 --- a/test/TestUtils.hs +++ b/test/TestUtils.hs @@ -12,14 +12,14 @@ module TestUtils ( import Language.Haskell.GhcMod.Monad import Language.Haskell.GhcMod.Types -isolateCradle :: GhcMod a -> GhcMod a +isolateCradle :: IOish m => GhcModT m a -> GhcModT m a isolateCradle action = local modifyEnv $ action where modifyEnv e = e { gmCradle = (gmCradle e) { cradlePkgDbStack = [GlobalDb] } } -runIsolatedGhcMod :: Options -> GhcMod a -> IO a -runIsolatedGhcMod opt action = runGhcMod opt $ isolateCradle action +runIsolatedGhcMod :: Options -> GhcModT IO a -> IO a +runIsolatedGhcMod opt action = runGhcModT opt $ isolateCradle action -- | Run GhcMod in isolated cradle with default options runID = runIsolatedGhcMod defaultOptions @@ -28,7 +28,9 @@ runID = runIsolatedGhcMod defaultOptions runI = runIsolatedGhcMod -- | Run GhcMod -run = runGhcMod +run :: Options -> GhcModT IO a -> IO a +run = runGhcModT -- | Run GhcMod with default options -runD = runGhcMod defaultOptions +runD :: GhcModT IO a -> IO a +runD = runGhcModT defaultOptions diff --git a/test/data/Info.hs b/test/data/Info.hs index 7370abc..4228f64 100644 --- a/test/data/Info.hs +++ b/test/data/Info.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + module Info () where fib :: Int -> Int diff --git a/test/data/Mutual1.hs b/test/data/Mutual1.hs index ef23310..1b73625 100644 --- a/test/data/Mutual1.hs +++ b/test/data/Mutual1.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} -- for HscInterpreted + module Mutual1 where import Mutual2 diff --git a/test/doctests.hs b/test/doctests.hs index 8bf21ed..b860d45 100644 --- a/test/doctests.hs +++ b/test/doctests.hs @@ -6,6 +6,7 @@ main :: IO () main = doctest [ "-package" , "ghc" + , "-XConstraintKinds", "-XFlexibleContexts" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h"