ghc-mod 1.12.5 → 2.0.0
raw patch · 49 files changed
+1569/−1415 lines, 49 filesdep +ghc-mod
Dependencies added: ghc-mod
Files
- Browse.hs +0/−97
- CabalApi.hs +0/−143
- ChangeLog +6/−0
- Check.hs +0/−31
- Cradle.hs +0/−73
- Debug.hs +0/−42
- Doc.hs +0/−24
- ErrMsg.hs +0/−79
- Flag.hs +0/−12
- GHCApi.hs +0/−172
- GHCChoice.hs +0/−25
- GHCMod.hs +0/−172
- Gap.hs +0/−182
- Info.hs +0/−177
- Lang.hs +0/−7
- Language/Haskell/GhcMod.hs +48/−0
- Language/Haskell/GhcMod/Browse.hs +105/−0
- Language/Haskell/GhcMod/CabalApi.hs +144/−0
- Language/Haskell/GhcMod/Check.hs +41/−0
- Language/Haskell/GhcMod/Cradle.hs +76/−0
- Language/Haskell/GhcMod/Debug.hs +53/−0
- Language/Haskell/GhcMod/Doc.hs +24/−0
- Language/Haskell/GhcMod/ErrMsg.hs +79/−0
- Language/Haskell/GhcMod/Flag.hs +14/−0
- Language/Haskell/GhcMod/GHCApi.hs +177/−0
- Language/Haskell/GhcMod/GHCChoice.hs +25/−0
- Language/Haskell/GhcMod/Gap.hs +182/−0
- Language/Haskell/GhcMod/Info.hs +207/−0
- Language/Haskell/GhcMod/Lang.hs +9/−0
- Language/Haskell/GhcMod/Lint.hs +20/−0
- Language/Haskell/GhcMod/List.hs +25/−0
- Language/Haskell/GhcMod/Types.hs +100/−0
- Lint.hs +0/−14
- List.hs +0/−23
- Types.hs +0/−80
- elisp/Makefile +8/−0
- elisp/ghc-doc.el +7/−3
- elisp/ghc.el +1/−1
- ghc-mod.cabal +32/−20
- src/GHCMod.hs +162/−0
- test/BrowseSpec.hs +2/−3
- test/CabalApiSpec.hs +1/−1
- test/CheckSpec.hs +2/−5
- test/DebugSpec.hs +3/−6
- test/FlagSpec.hs +2/−3
- test/InfoSpec.hs +9/−12
- test/LangSpec.hs +2/−3
- test/LintSpec.hs +1/−2
- test/ListSpec.hs +2/−3
− Browse.hs
@@ -1,97 +0,0 @@-module Browse (browseModule) where--import Control.Applicative-import Data.Char-import Data.List-import Data.Maybe (fromMaybe)-import DataCon (dataConRepType)-import Doc-import GHC-import GHCApi-import Name-import Outputable-import TyCon-import Type-import Types-import Var--------------------------------------------------------------------browseModule :: Options -> String -> IO String-browseModule opt mdlName = convert opt . format <$> browse opt mdlName- where- format- | operators opt = formatOps- | otherwise = removeOps- removeOps = sort . filter (isAlpha.head)- formatOps = sort . map formatOps'- formatOps' x@(s:_)- | isAlpha s = x- | otherwise = "(" ++ name ++ ")" ++ tail_- where- (name, tail_) = break isSpace x- formatOps' [] = error "formatOps'"--browse :: Options -> String -> IO [String]-browse opt mdlName = withGHCDummyFile $ do- initializeFlags opt- getModule >>= getModuleInfo >>= listExports- where- getModule = findModule (mkModuleName mdlName) Nothing- listExports Nothing = return []- listExports (Just mdinfo)- | detailed opt = processModule mdinfo- | otherwise = return (processExports mdinfo)--processExports :: ModuleInfo -> [String]-processExports = map getOccString . modInfoExports--processModule :: ModuleInfo -> Ghc [String]-processModule minfo = mapM processName names- where- names = modInfoExports minfo- processName :: Name -> Ghc String- processName nm = do- tyInfo <- modInfoLookupName minfo nm- -- If nothing found, load dependent module and lookup global- tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo- dflag <- getSessionDynFlags- return $ fromMaybe (getOccString nm) (tyResult >>= showThing dflag)- inOtherModule :: Name -> Ghc (Maybe TyThing)- inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm--showThing :: DynFlags -> TyThing -> Maybe String-showThing dflag (AnId i) = Just $ formatType dflag varType i-showThing dflag (ADataCon d) = Just $ formatType dflag dataConRepType d-showThing _ (ATyCon t) = unwords . toList <$> tyType t- where- toList t' = t' : getOccString t : map getOccString (tyConTyVars t)-showThing _ _ = Nothing--formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String-formatType dflag f x = getOccString x ++ " :: " ++ showOutputable dflag (removeForAlls $ f x)--tyType :: TyCon -> Maybe String-tyType typ- | isAlgTyCon typ- && not (isNewTyCon typ)- && not (isClassTyCon typ) = Just "data"- | isNewTyCon typ = Just "newtype"- | isClassTyCon typ = Just "class"- | isSynTyCon typ = Just "type"- | otherwise = Nothing--removeForAlls :: Type -> Type-removeForAlls ty = removeForAlls' ty' tty'- where- ty' = dropForAlls ty- tty' = splitFunTy_maybe ty'--removeForAlls' :: Type -> Maybe (Type, Type) -> Type-removeForAlls' ty Nothing = ty-removeForAlls' ty (Just (pre, ftype))- | isPredTy pre = mkFunTy pre (dropForAlls ftype)- | otherwise = ty--showOutputable :: Outputable a => DynFlags -> a -> String-showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr
− CabalApi.hs
@@ -1,143 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module CabalApi (- fromCabalFile- , cabalParseFile- , cabalBuildInfo- , cabalAllDependPackages- , cabalAllSourceDirs- , getGHCVersion- ) where--import Control.Applicative-import Control.Exception (throwIO)-import Data.List (intercalate)-import Data.Maybe (maybeToList, listToMaybe)-import Data.Set (fromList, toList)-import Distribution.Package (Dependency(Dependency), PackageName(PackageName))-import Distribution.PackageDescription-import Distribution.PackageDescription.Parse (readPackageDescription)-import Distribution.Simple.Program (ghcProgram)-import Distribution.Simple.Program.Types (programName, programFindVersion)-import Distribution.Text (display)-import Distribution.Verbosity (silent)-import Distribution.Version (versionBranch)-import System.FilePath-import Types--------------------------------------------------------------------fromCabalFile :: [GHCOption]- -> Cradle- -> IO ([GHCOption],[IncludeDir],[Package])-fromCabalFile ghcOptions cradle = do- cabal <- cabalParseFile cfile- case cabalBuildInfo cabal of- Nothing -> throwIO $ userError "cabal file is broken"- Just binfo -> return $ cookInfo ghcOptions cradle cabal binfo- where- Just cfile = cradleCabalFile cradle--cookInfo :: [String] -> Cradle -> GenericPackageDescription -> BuildInfo- -> ([GHCOption],[IncludeDir],[Package])-cookInfo ghcOptions cradle cabal binfo = (gopts,idirs,depPkgs)- where- wdir = cradleCurrentDir cradle- Just cdir = cradleCabalDir cradle- Just cfile = cradleCabalFile cradle- gopts = getGHCOptions ghcOptions binfo- idirs = includeDirectories cdir wdir $ cabalAllSourceDirs cabal- depPkgs = removeMe cfile $ cabalAllDependPackages cabal--removeMe :: FilePath -> [String] -> [String]-removeMe cabalfile = filter (/= me)- where- me = dropExtension $ takeFileName cabalfile--------------------------------------------------------------------cabalParseFile :: FilePath -> IO GenericPackageDescription-cabalParseFile = readPackageDescription silent--------------------------------------------------------------------getGHCOptions :: [String] -> BuildInfo -> [String]-getGHCOptions ghcOptions binfo = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs- where- exts = map (("-X" ++) . display) $ usedExtensions binfo- lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo- libs = map ("-l" ++) $ extraLibs binfo- libDirs = map ("-L" ++) $ extraLibDirs binfo---------------------------------------------------------------------- Causes error, catched in the upper function.-cabalBuildInfo :: GenericPackageDescription -> Maybe BuildInfo-cabalBuildInfo pd = fromLibrary pd <|> fromExecutable pd- where- fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c- fromExecutable c = buildInfo . condTreeData . snd <$> listToMaybe (condExecutables c)--------------------------------------------------------------------cabalAllSourceDirs :: GenericPackageDescription -> [FilePath]-cabalAllSourceDirs = fromPackageDescription (f libBuildInfo) (f buildInfo) (f testBuildInfo) (f benchmarkBuildInfo)- where- f getBuildInfo = concatMap (hsSourceDirs . getBuildInfo . condTreeData)--cabalAllDependPackages :: GenericPackageDescription -> [Package]-cabalAllDependPackages pd = uniqueAndSort pkgs- where- pkgs = map getDependencyPackageName $ cabalAllDependency pd--cabalAllDependency :: GenericPackageDescription -> [Dependency]-cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps- where- getDeps :: [Tree a] -> [Dependency]- getDeps = concatMap condTreeConstraints--getDependencyPackageName :: Dependency -> Package-getDependencyPackageName (Dependency (PackageName nm) _) = nm--------------------------------------------------------------------type Tree = CondTree ConfVar [Dependency]--fromPackageDescription :: ([Tree Library] -> [a])- -> ([Tree Executable] -> [a])- -> ([Tree TestSuite] -> [a])- -> ([Tree Benchmark] -> [a])- -> GenericPackageDescription- -> [a]-fromPackageDescription f1 f2 f3 f4 pd = lib ++ exe ++ tests ++ bench- where- lib = f1 . maybeToList . condLibrary $ pd- exe = f2 . map snd . condExecutables $ pd- tests = f3 . map snd . condTestSuites $ pd- bench = f4 . map snd . condBenchmarks $ pd--------------------------------------------------------------------includeDirectories :: String -> String -> [FilePath] -> [String]-includeDirectories cdir wdir [] = uniqueAndSort [cdir,wdir]-includeDirectories cdir wdir dirs = uniqueAndSort (map (cdir </>) dirs ++ [cdir,wdir])--------------------------------------------------------------------uniqueAndSort :: [String] -> [String]-uniqueAndSort = toList . fromList--------------------------------------------------------------------getGHCVersion :: IO (String, Int)-getGHCVersion = ghcVer >>= toTupple- where- ghcVer = programFindVersion ghcProgram silent (programName ghcProgram)- toTupple Nothing = throwIO $ userError "ghc not found"- toTupple (Just v)- | length vs < 2 = return (verstr, 0)- | otherwise = return (verstr, ver)- where- vs = versionBranch v- ver = (vs !! 0) * 100 + (vs !! 1)- verstr = intercalate "." . map show $ vs
ChangeLog view
@@ -1,3 +1,9 @@+2013-05-XX v2.0.0+ * ghc-mod also provides a library (Language.Haskell.GhcMod)++2013-05-13 v1.12.5+ * A bug fix for the case where a cabal file is broken.+ 2013-04-02 v1.12.4 * C-M-d on Emacs now can browse functions and types.
− Check.hs
@@ -1,31 +0,0 @@-module Check (checkSyntax) where--import Control.Applicative-import Control.Monad-import CoreMonad-import ErrMsg-import Exception-import GHC-import GHCApi-import Prelude-import Types--------------------------------------------------------------------checkSyntax :: Options -> Cradle -> String -> IO String-checkSyntax opt cradle file = unlines <$> check opt cradle file--------------------------------------------------------------------check :: Options -> Cradle -> String -> IO [String]-check opt cradle fileName = withGHC fileName $ checkIt `gcatch` handleErrMsg- where- checkIt = do- readLog <- initializeFlagsWithCradle opt cradle options True- setTargetFile fileName- checkSlowAndSet- void $ load LoadAllTargets- liftIO readLog- options- | expandSplice opt = "-w:" : ghcOpts opt- | otherwise = "-Wall" : ghcOpts opt
− Cradle.hs
@@ -1,73 +0,0 @@-module Cradle (findCradle) where--import Control.Applicative ((<$>))-import Control.Exception (throwIO)-import Control.Monad-import Data.List (isSuffixOf)-import System.Directory-import System.FilePath ((</>),takeDirectory)-import Types---- An error would be thrown-findCradle :: Maybe FilePath -> String -> IO Cradle-findCradle (Just sbox) strver = do- pkgConf <- checkPackageConf sbox strver- wdir <- getCurrentDirectory- cfiles <- cabalDir wdir- return $ case cfiles of- Nothing -> Cradle {- cradleCurrentDir = wdir- , cradleCabalDir = Nothing- , cradleCabalFile = Nothing- , cradlePackageConf = Just pkgConf- }- Just (cdir,cfile) -> Cradle {- cradleCurrentDir = wdir- , cradleCabalDir = Just cdir- , cradleCabalFile = Just cfile- , cradlePackageConf = Just pkgConf- }-findCradle Nothing strver = do- wdir <- getCurrentDirectory- cfiles <- cabalDir wdir- case cfiles of- Nothing -> return Cradle {- cradleCurrentDir = wdir- , cradleCabalDir = Nothing- , cradleCabalFile = Nothing- , cradlePackageConf = Nothing- }- Just (cdir,cfile) -> do- let sbox = cdir </> "cabal-dev"- pkgConf = packageConfName sbox strver- exist <- doesDirectoryExist pkgConf- return Cradle {- cradleCurrentDir = wdir- , cradleCabalDir = Just cdir- , cradleCabalFile = Just cfile- , cradlePackageConf = if exist then Just pkgConf else Nothing- }--cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))-cabalDir dir = do- cnts <- (filter isCabal <$> getDirectoryContents dir)- >>= filterM (\file -> doesFileExist (dir </> file))- let dir' = takeDirectory dir- case cnts of- [] | dir' == dir -> return Nothing- | otherwise -> cabalDir dir'- cfile:_ -> return $ Just (dir,dir </> cfile)- where- isCabal name = ".cabal" `isSuffixOf` name && length name > 6--packageConfName :: FilePath -> String -> FilePath-packageConfName path ver = path </> "packages-" ++ ver ++ ".conf"--checkPackageConf :: FilePath -> String -> IO FilePath-checkPackageConf path ver = do- let conf = packageConfName path ver- exist <- doesDirectoryExist conf- if exist then- return conf- else- throwIO $ userError $ conf ++ " not found"
− Debug.hs
@@ -1,42 +0,0 @@-module Debug (debugInfo, debug) where--import CabalApi-import Control.Applicative-import Control.Exception.IOChoice-import Control.Monad-import Data.List (intercalate)-import Data.Maybe-import GHC-import GHCApi-import Prelude-import Types--------------------------------------------------------------------debugInfo :: Options -> Cradle -> String -> String -> IO String-debugInfo opt cradle ver fileName = unlines <$> debug opt cradle ver fileName--debug :: Options -> Cradle -> String -> String -> IO [String]-debug opt cradle ver fileName = do- (gopts, incDir, pkgs) <-- if cabal then- fromCabalFile (ghcOpts opt) cradle ||> return (ghcOpts opt, [], [])- else- return (ghcOpts opt, [], [])- [fast] <- withGHC fileName $ do- void $ initializeFlagsWithCradle opt cradle gopts True- setTargetFile fileName- pure . canCheckFast <$> depanal [] False- return [- "GHC version: " ++ ver- , "Current directory: " ++ currentDir- , "Cabal file: " ++ cabalFile- , "GHC options: " ++ unwords gopts- , "Include directories: " ++ unwords incDir- , "Dependent packages: " ++ intercalate ", " pkgs- , "Fast check: " ++ if fast then "Yes" else "No"- ]- where- currentDir = cradleCurrentDir cradle- cabal = isJust $ cradleCabalFile cradle- cabalFile = fromMaybe "" $ cradleCabalFile cradle
− Doc.hs
@@ -1,24 +0,0 @@-module Doc where--import DynFlags (DynFlags)-import Gap (withStyle)-import Outputable-import Pretty--styleQualified :: PprStyle-styleQualified = mkUserStyle alwaysQualify AllTheWay--styleUnqualified :: PprStyle-styleUnqualified = mkUserStyle neverQualify AllTheWay--showQualifiedPage :: DynFlags -> SDoc -> String-showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified--showUnqualifiedPage :: DynFlags -> SDoc -> String-showUnqualifiedPage dflag = showDocWith PageMode . withStyle dflag styleUnqualified--showQualifiedOneLine :: DynFlags -> SDoc -> String-showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified--showUnqualifiedOneLine :: DynFlags -> SDoc -> String-showUnqualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleUnqualified
− ErrMsg.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE BangPatterns #-}--module ErrMsg (- LogReader- , setLogger- , handleErrMsg- ) where--import Bag-import Control.Applicative-import Data.IORef-import Data.Maybe-import Doc-import DynFlags-import ErrUtils-import GHC-import qualified Gap-import HscTypes-import Outputable-import System.FilePath (normalise)--------------------------------------------------------------------type LogReader = IO [String]--------------------------------------------------------------------setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)-setLogger False df = return (newdf, undefined)- where- newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()-setLogger True df = do- ref <- newIORef [] :: IO (IORef [String])- let newdf = Gap.setLogAction df $ appendLog ref- return (newdf, reverse <$> readIORef ref)- where- appendLog ref _ sev src _ msg = do- let !l = ppMsg src sev df msg- modifyIORef ref (\ls -> l : ls)--------------------------------------------------------------------handleErrMsg :: SourceError -> Ghc [String]-handleErrMsg err = do- dflag <- getSessionDynFlags- return . errBagToStrList dflag . srcErrorMessages $ err--errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]-errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList--------------------------------------------------------------------ppErrMsg :: DynFlags -> ErrMsg -> String-ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext- where- spn = head (errMsgSpans err)- msg = errMsgShortDoc err- ext = showMsg dflag (errMsgExtraInfo err)--ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String-ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"- where- cts = showMsg dflag msg- defaultPrefix- | dopt Opt_D_dump_splices dflag = ""- | otherwise = "Dummy:0:0:"- prefix = fromMaybe defaultPrefix $ do- (line,col,_,_) <- Gap.getSrcSpan spn- file <- normalise <$> Gap.getSrcFile spn- let severityCaption = Gap.showSeverityCaption sev- return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption--------------------------------------------------------------------showMsg :: DynFlags -> SDoc -> String-showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc- where- toNull '\n' = '\0'- toNull x = x
− Flag.hs
@@ -1,12 +0,0 @@-{-# LANGUAGE CPP #-}--module Flag where--import Types-import qualified Gap--listFlags :: Options -> IO String-listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option- | option <- Gap.fOptions- , prefix <- ["","no-"]- ]
− GHCApi.hs
@@ -1,172 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module GHCApi (- withGHC- , withGHCDummyFile- , initializeFlags- , initializeFlagsWithCradle- , setTargetFile- , getDynamicFlags- , setSlowDynFlags- , checkSlowAndSet- , canCheckFast- ) where--import CabalApi-import Control.Applicative-import Control.Exception-import Control.Monad-import CoreMonad-import Data.Maybe (isJust)-import DynFlags-import ErrMsg-import Exception-import GHC-import GHCChoice-import GHC.Paths (libdir)-import System.Exit-import System.IO-import Types--------------------------------------------------------------------withGHCDummyFile :: Alternative m => Ghc (m a) -> IO (m a)-withGHCDummyFile = withGHC "Dummy"--withGHC :: Alternative m => FilePath -> Ghc (m a) -> IO (m a)-withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do- dflags <- getSessionDynFlags- defaultCleanupHandler dflags body- where- ignore :: Alternative m => SomeException -> IO (m a)- ignore e = do- hPutStr stderr $ file ++ ":0:0:Error:"- hPrint stderr e- exitSuccess--------------------------------------------------------------------importDirs :: [IncludeDir]-importDirs = [".","..","../..","../../..","../../../..","../../../../.."]--data Build = CabalPkg | SingleFile deriving Eq--initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader-initializeFlagsWithCradle opt cradle ghcOptions logging- | cabal = withCabal ||> withoutCabal- | otherwise = withoutCabal- where- cabal = isJust $ cradleCabalFile cradle- withCabal = do- (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle- initSession CabalPkg opt gopts idirs (Just depPkgs) logging- withoutCabal =- initSession SingleFile opt ghcOptions importDirs Nothing logging--------------------------------------------------------------------initSession :: Build- -> Options- -> [GHCOption]- -> [IncludeDir]- -> Maybe [Package]- -> Bool- -> Ghc LogReader-initSession build opt cmdOpts idirs mDepPkgs logging = do- dflags0 <- getSessionDynFlags- (dflags1,readLog) <- setupDynamicFlags dflags0- _ <- setSessionDynFlags dflags1- return readLog- where- setupDynamicFlags df0 = do- df1 <- modifyFlagsWithOpts df0 cmdOpts- let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build- df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt- liftIO $ setLogger logging df3--------------------------------------------------------------------initializeFlags :: Options -> Ghc ()-initializeFlags opt = do- dflags0 <- getSessionDynFlags- dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt- void $ setSessionDynFlags dflags1---------------------------------------------------------------------- FIXME removing Options-modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Build -> DynFlags-modifyFlags d0 idirs mDepPkgs splice build- | splice = setSplice d4- | otherwise = d4- where- d1 = d0 { importPaths = idirs }- d2 = setFastOrNot d1 Fast- d3 = maybe d2 (addDevPkgs d2) mDepPkgs- d4 | build == CabalPkg = setCabalPkg d3- | otherwise = d3--setCabalPkg :: DynFlags -> DynFlags-setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage--setSplice :: DynFlags -> DynFlags-setSplice dflag = dopt_set dflag Opt_D_dump_splices--addDevPkgs :: DynFlags -> [Package] -> DynFlags-addDevPkgs df pkgs = df''- where- df' = dopt_set df Opt_HideAllPackages- df'' = df' {- packageFlags = map ExposePackage pkgs ++ packageFlags df- }--------------------------------------------------------------------setFastOrNot :: DynFlags -> CheckSpeed -> DynFlags-setFastOrNot dflags Slow = dflags {- ghcLink = LinkInMemory- , hscTarget = HscInterpreted- }-setFastOrNot dflags Fast = dflags {- ghcLink = NoLink- , hscTarget = HscNothing- }--setSlowDynFlags :: Ghc ()-setSlowDynFlags = (flip setFastOrNot Slow <$> getSessionDynFlags)- >>= void . setSessionDynFlags---- To check TH, a session module graph is necessary.--- "load" sets a session module graph using "depanal".--- But we have to set "-fno-code" to DynFlags before "load".--- So, this is necessary redundancy.-checkSlowAndSet :: Ghc ()-checkSlowAndSet = do- fast <- canCheckFast <$> depanal [] False- unless fast setSlowDynFlags--------------------------------------------------------------------modifyFlagsWithOpts :: DynFlags -> [String] -> Ghc DynFlags-modifyFlagsWithOpts dflags cmdOpts =- tfst <$> parseDynamicFlags dflags (map noLoc cmdOpts)- where- tfst (a,_,_) = a--------------------------------------------------------------------setTargetFile :: (GhcMonad m) => String -> m ()-setTargetFile file = do- target <- guessTarget file Nothing- setTargets [target]--------------------------------------------------------------------getDynamicFlags :: IO DynFlags-getDynamicFlags = runGhc (Just libdir) getSessionDynFlags--canCheckFast :: ModuleGraph -> Bool-canCheckFast = not . any (hasTHorQQ . ms_hspp_opts)- where- hasTHorQQ :: DynFlags -> Bool- hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes]
− GHCChoice.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module GHCChoice where--import Control.Exception-import CoreMonad-import Exception-import GHC--------------------------------------------------------------------(||>) :: Ghc a -> Ghc a -> Ghc a-x ||> y = x `gcatch` (\(_ :: IOException) -> y)--------------------------------------------------------------------{-| Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.--}-goNext :: Ghc a-goNext = liftIO . throwIO $ userError "goNext"--{-| Run any one 'Ghc' monad.--}-runAnyOne :: [Ghc a] -> Ghc a-runAnyOne = foldr (||>) goNext
− GHCMod.hs
@@ -1,172 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Main where--import Browse-import CabalApi-import Check-import Control.Applicative-import Control.Exception-import Cradle-import Data.Typeable-import Data.Version-import Debug-import Flag-import Info-import Lang-import Lint-import List-import Paths_ghc_mod-import Prelude-import System.Console.GetOpt-import System.Directory-import System.Environment (getArgs)-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)-import Types--------------------------------------------------------------------ghcOptHelp :: String-ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "--usage :: String-usage = "ghc-mod version " ++ showVersion version ++ "\n"- ++ "Usage:\n"- ++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l]\n"- ++ "\t ghc-mod lang [-l]\n"- ++ "\t ghc-mod flag [-l]\n"- ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] <module> [<module> ...]\n"- ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "<HaskellFile>\n"- ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"- ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"- ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"- ++ "\t ghc-mod boot\n"- ++ "\t ghc-mod help\n"--------------------------------------------------------------------argspec :: [OptDescr (Options -> Options)]-argspec = [ Option "l" ["tolisp"]- (NoArg (\opts -> opts { outputStyle = LispStyle }))- "print as a list of Lisp"- , Option "h" ["hlintOpt"]- (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")- "hlint options"- , Option "g" ["ghcOpt"]- (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")- "GHC options"- , Option "o" ["operators"]- (NoArg (\opts -> opts { operators = True }))- "print operators, too"- , Option "d" ["detailed"]- (NoArg (\opts -> opts { detailed = True }))- "print detailed info"- , Option "s" ["sandbox"]- (ReqArg (\s opts -> opts { sandbox = Just s }) "path")- "specify cabal-dev sandbox (default 'cabal-dev`)"- ]--parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])-parseArgs spec argv- = case getOpt Permute spec argv of- (o,n,[] ) -> (foldr id defaultOptions o, n)- (_,_,errs) -> throw (CmdArg errs)--------------------------------------------------------------------data GHCModError = SafeList- | NoSuchCommand String- | CmdArg [String]- | FileNotExist String deriving (Show, Typeable)--instance Exception GHCModError--------------------------------------------------------------------main :: IO ()-main = flip catches handlers $ do--- #if __GLASGOW_HASKELL__ >= 611- hSetEncoding stdout utf8--- #endif- args <- getArgs- let (opt',cmdArg) = parseArgs argspec args- (strVer,ver) <- getGHCVersion- cradle <- findCradle (sandbox opt') strVer- let opt = adjustOpts opt' cradle ver- cmdArg0 = cmdArg !. 0- cmdArg1 = cmdArg !. 1- cmdArg2 = cmdArg !. 2- cmdArg3 = cmdArg !. 3- cmdArg4 = cmdArg !. 4- res <- case cmdArg0 of- "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)- "list" -> listModules opt- "check" -> withFile (checkSyntax opt cradle) cmdArg1- "expand" -> withFile (checkSyntax opt { expandSplice = True } cradle) cmdArg1- "debug" -> withFile (debugInfo opt cradle strVer) cmdArg1- "type" -> withFile (typeExpr opt cradle cmdArg2 (read cmdArg3) (read cmdArg4)) cmdArg1- "info" -> withFile (infoExpr opt cradle cmdArg2 cmdArg3) cmdArg1- "lint" -> withFile (lintSyntax opt) cmdArg1- "lang" -> listLanguages opt- "flag" -> listFlags opt- "boot" -> do- mods <- listModules opt- langs <- listLanguages opt- flags <- listFlags opt- pre <- concat <$> mapM (browseModule opt) preBrowsedModules- return $ mods ++ langs ++ flags ++ pre- cmd -> throw (NoSuchCommand cmd)- putStr res- where- handlers = [Handler handler1, Handler handler2]- handler1 :: ErrorCall -> IO ()- handler1 = print -- for debug- handler2 :: GHCModError -> IO ()- handler2 SafeList = printUsage- handler2 (NoSuchCommand cmd) = do- hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"- printUsage- handler2 (CmdArg errs) = do- mapM_ (hPutStr stderr) errs- printUsage- handler2 (FileNotExist file) = do- hPutStrLn stderr $ "\"" ++ file ++ "\" not found"- printUsage- printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec- withFile cmd file = do- exist <- doesFileExist file- if exist- then cmd file- else throw (FileNotExist file)- xs !. idx- | length xs <= idx = throw SafeList- | otherwise = xs !! idx- adjustOpts opt cradle ver = case mPkgConf of- Nothing -> opt- Just pkgConf -> opt {- ghcOpts = ghcPackageConfOptions ver pkgConf ++ ghcOpts opt- }- where- mPkgConf = cradlePackageConf cradle--------------------------------------------------------------------preBrowsedModules :: [String]-preBrowsedModules = [- "Prelude"- , "Control.Applicative"- , "Control.Monad"- , "Control.Exception"- , "Data.Char"- , "Data.List"- , "Data.Maybe"- , "System.IO"- ]---ghcPackageConfOptions :: Int -> String -> [String]-ghcPackageConfOptions ver file- | ver >= 706 = ["-package-db", file, "-no-user-package-db"]- | otherwise = ["-package-conf", file, "-no-user-package-conf"]
− Gap.hs
@@ -1,182 +0,0 @@-{-# LANGUAGE CPP #-}--module Gap (- Gap.ClsInst- , mkTarget- , withStyle- , setLogAction- , supportedExtensions- , getSrcSpan- , getSrcFile- , setCtx- , fOptions- , toStringBuffer- , liftIO- , showSeverityCaption-#if __GLASGOW_HASKELL__ >= 702-#else- , module Pretty-#endif- ) where--import Control.Applicative hiding (empty)-import Control.Monad-import Data.Time.Clock-import DynFlags-import ErrUtils-import FastString-import GHC-import GHCChoice-import Outputable-import StringBuffer--import qualified InstEnv-import qualified Pretty-import qualified StringBuffer as SB---#if __GLASGOW_HASKELL__ >= 702-import CoreMonad (liftIO)-#else-import HscTypes (liftIO)-import Pretty-#endif--#if __GLASGOW_HASKELL__ < 706-import Control.Arrow-import Data.Convertible-#endif--{--pretty :: Outputable a => a -> String-pretty = showSDocForUser neverQualify . ppr--debug :: Outputable a => a -> b -> b-debug x v = trace (pretty x) v--}---------------------------------------------------------------------------------------------------------------------------------------#if __GLASGOW_HASKELL__ >= 706-type ClsInst = InstEnv.ClsInst-#else-type ClsInst = InstEnv.Instance-#endif--mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target-#if __GLASGOW_HASKELL__ >= 706-mkTarget = Target-#else-mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert-#endif-------------------------------------------------------------------------------------------------------------------------------------withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc-#if __GLASGOW_HASKELL__ >= 706-withStyle = withPprStyleDoc-#else-withStyle _ = withPprStyleDoc-#endif--setLogAction :: DynFlags- -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())- -> DynFlags-setLogAction df f =-#if __GLASGOW_HASKELL__ >= 706- df { log_action = f }-#else- df { log_action = f df }-#endif-------------------------------------------------------------------------------------------------------------------------------------supportedExtensions :: [String]-#if __GLASGOW_HASKELL__ >= 700-supportedExtensions = supportedLanguagesAndExtensions-#else-supportedExtensions = supportedLanguages-#endif-------------------------------------------------------------------------------------------------------------------------------------getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)-#if __GLASGOW_HASKELL__ >= 702-getSrcSpan (RealSrcSpan spn)-#else-getSrcSpan spn | isGoodSrcSpan spn-#endif- = Just (srcSpanStartLine spn- , srcSpanStartCol spn- , srcSpanEndLine spn- , srcSpanEndCol spn)-getSrcSpan _ = Nothing--getSrcFile :: SrcSpan -> Maybe String-#if __GLASGOW_HASKELL__ >= 702-getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn-#else-getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn-#endif-getSrcFile _ = Nothing--------------------------------------------------------------------toStringBuffer :: [String] -> Ghc StringBuffer-#if __GLASGOW_HASKELL__ >= 702-toStringBuffer = return . stringToStringBuffer . unlines-#else-toStringBuffer = liftIO . stringToStringBuffer . unlines-#endif--------------------------------------------------------------------fOptions :: [String]-#if __GLASGOW_HASKELL__ >= 704-fOptions = [option | (option,_,_) <- fFlags]- ++ [option | (option,_,_) <- fWarningFlags]- ++ [option | (option,_,_) <- fLangFlags]-#elif __GLASGOW_HASKELL__ == 702-fOptions = [option | (option,_,_,_) <- fFlags]-#else-fOptions = [option | (option,_,_) <- fFlags]-#endif-------------------------------------------------------------------------------------------------------------------------------------setCtx :: [ModSummary] -> Ghc Bool-#if __GLASGOW_HASKELL__ >= 704-setCtx ms = do-#if __GLASGOW_HASKELL__ >= 706- let modName = IIModule . moduleName . ms_mod-#else- let modName = IIModule . ms_mod-#endif- top <- map modName <$> filterM isTop ms- setContext top- return (not . null $ top)-#else-setCtx ms = do- top <- map ms_mod <$> filterM isTop ms- setContext top []- return (not . null $ top)-#endif- where- isTop mos = lookupMod ||> returnFalse- where- lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True- returnFalse = return False---showSeverityCaption :: Severity -> String-#if __GLASGOW_HASKELL__ >= 706-showSeverityCaption SevWarning = "Warning: "-showSeverityCaption _ = ""-#else-showSeverityCaption = const ""-#endif
− Info.hs
@@ -1,177 +0,0 @@-{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-}-{-# LANGUAGE Rank2Types #-}--module Info (infoExpr, typeExpr) where--import Control.Applicative-import Control.Monad (void, when)-import CoreUtils-import Data.Function-import Data.Generics-import Data.List-import Data.Maybe-import Data.Ord as O-import Data.Time.Clock-import Desugar-import Doc-import GHC-import GHC.SYB.Utils-import GHCApi-import GHCChoice-import qualified Gap-import HscTypes-import NameSet-import Outputable-import PprTyThing-import TcHsSyn (hsPatType)-import TcRnTypes-import Types--------------------------------------------------------------------type Expression = String-type ModuleString = String--data Cmd = Info | Type deriving Eq--------------------------------------------------------------------infoExpr :: Options -> Cradle -> ModuleString -> Expression -> FilePath -> IO String-infoExpr opt cradle modstr expr file = (++ "\n") <$> info opt cradle file modstr expr--info :: Options -> Cradle -> FilePath -> ModuleString -> Expression -> IO String-info opt cradle fileName modstr expr =- inModuleContext Info opt cradle fileName modstr exprToInfo "Cannot show info"- where- exprToInfo = infoThing expr--------------------------------------------------------------------class HasType a where- getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))--instance HasType (LHsExpr Id) where- getType tcm e = do- hs_env <- getSession- (_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e- return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe- where- modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm- rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm- ty_env = tcg_type_env $ fst $ tm_internals_ tcm--instance HasType (LHsBind Id) where- getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)- getType _ _ = return Nothing--instance HasType (LPat Id) where- getType _ (L spn pat) = return $ Just (spn, hsPatType pat)--typeExpr :: Options -> Cradle -> ModuleString -> Int -> Int -> FilePath -> IO String-typeExpr opt cradle modstr lineNo colNo file = Info.typeOf opt cradle file modstr lineNo colNo--typeOf :: Options -> Cradle -> FilePath -> ModuleString -> Int -> Int -> IO String-typeOf opt cradle fileName modstr lineNo colNo =- inModuleContext Type opt cradle fileName modstr exprToType errmsg- where- exprToType = do- modSum <- getModSummary $ mkModuleName modstr- p <- parseModule modSum- tcm@TypecheckedModule{tm_typechecked_source = tcs} <- typecheckModule p- let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]- es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]- ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]- bts <- mapM (getType tcm) bs- ets <- mapM (getType tcm) es- pts <- mapM (getType tcm) ps- dflag <- getSessionDynFlags- let sss = map (toTup dflag) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts]- return $ convert opt sss-- toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)- toTup dflag (spn, typ) = (fourInts spn, pretty dflag typ)-- fourInts :: SrcSpan -> (Int,Int,Int,Int)- fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan-- cmp a b- | a `isSubspanOf` b = O.LT- | b `isSubspanOf` a = O.GT- | otherwise = O.EQ-- errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])--listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]-listifySpans tcs lc = listifyStaged TypeChecker p tcs- where- p (L spn _) = isGoodSrcSpan spn && spn `spans` lc--listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]-listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))--pretty :: DynFlags -> Type -> String-pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False--------------------------------------------------------------------- from ghc/InteractiveUI.hs--infoThing :: String -> Ghc String-infoThing str = do- names <- parseName str- mb_stuffs <- mapM getInfo names- let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)- dflag <- getSessionDynFlags- return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)--filterOutChildren :: (a -> TyThing) -> [a] -> [a]-filterOutChildren get_thing xs- = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]- where- implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]--pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc-pprInfo pefas (thing, fixity, insts)- = pprTyThingInContextLoc pefas thing- $$ show_fixity fixity- $$ vcat (map pprInstance insts)- where- show_fixity fx- | fx == defaultFixity = Outputable.empty- | otherwise = ppr fx <+> ppr (getName thing)--------------------------------------------------------------------inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> IO String-inModuleContext cmd opt cradle fileName modstr action errmsg =- withGHCDummyFile (valid ||> invalid ||> return errmsg)- where- valid = do- void $ initializeFlagsWithCradle opt cradle ["-w:"] False- when (cmd == Info) setSlowDynFlags- setTargetFile fileName- checkSlowAndSet- void $ load LoadAllTargets- doif setContextFromTarget action- invalid = do- void $ initializeFlagsWithCradle opt cradle ["-w:"] False- setTargetBuffer- checkSlowAndSet- void $ load LoadAllTargets- doif setContextFromTarget action- setTargetBuffer = do- modgraph <- depanal [mkModuleName modstr] True- dflag <- getSessionDynFlags- let imports = concatMap (map (showQualifiedPage dflag . ppr . unLoc)) $- map ms_imps modgraph ++ map ms_srcimps modgraph- moddef = "module " ++ sanitize modstr ++ " where"- header = moddef : imports- importsBuf <- Gap.toStringBuffer header- clkTime <- Gap.liftIO getCurrentTime- setTargets [Gap.mkTarget (TargetModule $ mkModuleName modstr)- True- (Just (importsBuf, clkTime))]- doif m t = m >>= \ok -> if ok then t else goNext- sanitize = fromMaybe "SomeModule" . listToMaybe . words--setContextFromTarget :: Ghc Bool-setContextFromTarget = depanal [] False >>= Gap.setCtx
− Lang.hs
@@ -1,7 +0,0 @@-module Lang where--import qualified Gap-import Types--listLanguages :: Options -> IO String-listLanguages opt = return $ convert opt Gap.supportedExtensions
+ Language/Haskell/GhcMod.hs view
@@ -0,0 +1,48 @@+module Language.Haskell.GhcMod (+ -- * Cradle+ Cradle(..)+ , findCradle+ -- * GHC version+ , GHCVersion+ , getGHCVersion+ -- * Options+ , Options(..)+ , OutputStyle(..)+ , defaultOptions+ -- * Types+ , ModuleString+ , Expression+ -- * 'IO' utilities+ , browseModule+ , checkSyntax+ , lintSyntax+ , infoExpr+ , typeExpr+ , listModules+ , listLanguages+ , listFlags+ , debugInfo+ -- * Converting the 'Ghc' monad to the 'IO' monad+ , withGHC+ , withGHCDummyFile+ -- * 'Ghc' utilities+ , browse+ , check+ , info+ , typeOf+ , listMods+ , debug+ ) where++import Language.Haskell.GhcMod.Browse+import Language.Haskell.GhcMod.Check+import Language.Haskell.GhcMod.Cradle+import Language.Haskell.GhcMod.Debug+import Language.Haskell.GhcMod.Flag+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Info+import Language.Haskell.GhcMod.Lang+import Language.Haskell.GhcMod.Lint+import Language.Haskell.GhcMod.List+import Language.Haskell.GhcMod.Types+import Language.Haskell.GhcMod.CabalApi
+ Language/Haskell/GhcMod/Browse.hs view
@@ -0,0 +1,105 @@+module Language.Haskell.GhcMod.Browse (browseModule, browse) where++import Control.Applicative+import Data.Char+import Data.List+import Data.Maybe (fromMaybe)+import DataCon (dataConRepType)+import GHC+import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Types+import Name+import Outputable+import TyCon+import Type+import Var++----------------------------------------------------------------++-- | Getting functions, classes, etc from a module.+-- If 'detailed' is 'True', their types are also obtained.+browseModule :: Options+ -> ModuleString -- ^ A module name. (e.g. \"Data.List\")+ -> IO String+browseModule opt mdlName = convert opt . format <$> withGHCDummyFile (browse opt mdlName)+ where+ format+ | operators opt = formatOps+ | otherwise = removeOps+ removeOps = sort . filter (isAlpha.head)+ formatOps = sort . map formatOps'+ formatOps' x@(s:_)+ | isAlpha s = x+ | otherwise = "(" ++ name ++ ")" ++ tail_+ where+ (name, tail_) = break isSpace x+ formatOps' [] = error "formatOps'"++-- | Getting functions, classes, etc from a module.+-- If 'detailed' is 'True', their types are also obtained.+browse :: Options+ -> ModuleString -- ^ A module name. (e.g. \"Data.List\")+ -> Ghc [String]+browse opt mdlName = do+ initializeFlags opt+ getModule >>= getModuleInfo >>= listExports+ where+ getModule = findModule (mkModuleName mdlName) Nothing+ listExports Nothing = return []+ listExports (Just mdinfo)+ | detailed opt = processModule mdinfo+ | otherwise = return (processExports mdinfo)++processExports :: ModuleInfo -> [String]+processExports = map getOccString . modInfoExports++processModule :: ModuleInfo -> Ghc [String]+processModule minfo = mapM processName names+ where+ names = modInfoExports minfo+ processName :: Name -> Ghc String+ processName nm = do+ tyInfo <- modInfoLookupName minfo nm+ -- If nothing found, load dependent module and lookup global+ tyResult <- maybe (inOtherModule nm) (return . Just) tyInfo+ dflag <- getSessionDynFlags+ return $ fromMaybe (getOccString nm) (tyResult >>= showThing dflag)+ inOtherModule :: Name -> Ghc (Maybe TyThing)+ inOtherModule nm = getModuleInfo (nameModule nm) >> lookupGlobalName nm++showThing :: DynFlags -> TyThing -> Maybe String+showThing dflag (AnId i) = Just $ formatType dflag varType i+showThing dflag (ADataCon d) = Just $ formatType dflag dataConRepType d+showThing _ (ATyCon t) = unwords . toList <$> tyType t+ where+ toList t' = t' : getOccString t : map getOccString (tyConTyVars t)+showThing _ _ = Nothing++formatType :: NamedThing a => DynFlags -> (a -> Type) -> a -> String+formatType dflag f x = getOccString x ++ " :: " ++ showOutputable dflag (removeForAlls $ f x)++tyType :: TyCon -> Maybe String+tyType typ+ | isAlgTyCon typ+ && not (isNewTyCon typ)+ && not (isClassTyCon typ) = Just "data"+ | isNewTyCon typ = Just "newtype"+ | isClassTyCon typ = Just "class"+ | isSynTyCon typ = Just "type"+ | otherwise = Nothing++removeForAlls :: Type -> Type+removeForAlls ty = removeForAlls' ty' tty'+ where+ ty' = dropForAlls ty+ tty' = splitFunTy_maybe ty'++removeForAlls' :: Type -> Maybe (Type, Type) -> Type+removeForAlls' ty Nothing = ty+removeForAlls' ty (Just (pre, ftype))+ | isPredTy pre = mkFunTy pre (dropForAlls ftype)+ | otherwise = ty++showOutputable :: Outputable a => DynFlags -> a -> String+showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . ppr
+ Language/Haskell/GhcMod/CabalApi.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE OverloadedStrings #-}++module Language.Haskell.GhcMod.CabalApi (+ fromCabalFile+ , cabalParseFile+ , cabalBuildInfo+ , cabalAllDependPackages+ , cabalAllSourceDirs+ , getGHCVersion+ ) where++import Control.Applicative+import Control.Exception (throwIO)+import Data.List (intercalate)+import Data.Maybe (maybeToList, listToMaybe)+import Data.Set (fromList, toList)+import Distribution.Package (Dependency(Dependency), PackageName(PackageName))+import Distribution.PackageDescription+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.Simple.Program (ghcProgram)+import Distribution.Simple.Program.Types (programName, programFindVersion)+import Distribution.Text (display)+import Distribution.Verbosity (silent)+import Distribution.Version (versionBranch)+import Language.Haskell.GhcMod.Types+import System.FilePath++----------------------------------------------------------------++fromCabalFile :: [GHCOption]+ -> Cradle+ -> IO ([GHCOption],[IncludeDir],[Package])+fromCabalFile ghcOptions cradle = do+ cabal <- cabalParseFile cfile+ case cabalBuildInfo cabal of+ Nothing -> throwIO $ userError "cabal file is broken"+ Just binfo -> return $ cookInfo ghcOptions cradle cabal binfo+ where+ Just cfile = cradleCabalFile cradle++cookInfo :: [String] -> Cradle -> GenericPackageDescription -> BuildInfo+ -> ([GHCOption],[IncludeDir],[Package])+cookInfo ghcOptions cradle cabal binfo = (gopts,idirs,depPkgs)+ where+ wdir = cradleCurrentDir cradle+ Just cdir = cradleCabalDir cradle+ Just cfile = cradleCabalFile cradle+ gopts = getGHCOptions ghcOptions binfo+ idirs = includeDirectories cdir wdir $ cabalAllSourceDirs cabal+ depPkgs = removeMe cfile $ cabalAllDependPackages cabal++removeMe :: FilePath -> [String] -> [String]+removeMe cabalfile = filter (/= me)+ where+ me = dropExtension $ takeFileName cabalfile++----------------------------------------------------------------++cabalParseFile :: FilePath -> IO GenericPackageDescription+cabalParseFile = readPackageDescription silent++----------------------------------------------------------------++getGHCOptions :: [String] -> BuildInfo -> [String]+getGHCOptions ghcOptions binfo = ghcOptions ++ exts ++ [lang] ++ libs ++ libDirs+ where+ exts = map (("-X" ++) . display) $ usedExtensions binfo+ lang = maybe "-XHaskell98" (("-X" ++) . display) $ defaultLanguage binfo+ libs = map ("-l" ++) $ extraLibs binfo+ libDirs = map ("-L" ++) $ extraLibDirs binfo++----------------------------------------------------------------++-- Causes error, catched in the upper function.+cabalBuildInfo :: GenericPackageDescription -> Maybe BuildInfo+cabalBuildInfo pd = fromLibrary pd <|> fromExecutable pd+ where+ fromLibrary c = libBuildInfo . condTreeData <$> condLibrary c+ fromExecutable c = buildInfo . condTreeData . snd <$> listToMaybe (condExecutables c)++----------------------------------------------------------------++cabalAllSourceDirs :: GenericPackageDescription -> [FilePath]+cabalAllSourceDirs = fromPackageDescription (f libBuildInfo) (f buildInfo) (f testBuildInfo) (f benchmarkBuildInfo)+ where+ f getBuildInfo = concatMap (hsSourceDirs . getBuildInfo . condTreeData)++cabalAllDependPackages :: GenericPackageDescription -> [Package]+cabalAllDependPackages pd = uniqueAndSort pkgs+ where+ pkgs = map getDependencyPackageName $ cabalAllDependency pd++cabalAllDependency :: GenericPackageDescription -> [Dependency]+cabalAllDependency = fromPackageDescription getDeps getDeps getDeps getDeps+ where+ getDeps :: [Tree a] -> [Dependency]+ getDeps = concatMap condTreeConstraints++getDependencyPackageName :: Dependency -> Package+getDependencyPackageName (Dependency (PackageName nm) _) = nm++----------------------------------------------------------------++type Tree = CondTree ConfVar [Dependency]++fromPackageDescription :: ([Tree Library] -> [a])+ -> ([Tree Executable] -> [a])+ -> ([Tree TestSuite] -> [a])+ -> ([Tree Benchmark] -> [a])+ -> GenericPackageDescription+ -> [a]+fromPackageDescription f1 f2 f3 f4 pd = lib ++ exe ++ tests ++ bench+ where+ lib = f1 . maybeToList . condLibrary $ pd+ exe = f2 . map snd . condExecutables $ pd+ tests = f3 . map snd . condTestSuites $ pd+ bench = f4 . map snd . condBenchmarks $ pd++----------------------------------------------------------------++includeDirectories :: String -> String -> [FilePath] -> [String]+includeDirectories cdir wdir [] = uniqueAndSort [cdir,wdir]+includeDirectories cdir wdir dirs = uniqueAndSort (map (cdir </>) dirs ++ [cdir,wdir])++----------------------------------------------------------------++uniqueAndSort :: [String] -> [String]+uniqueAndSort = toList . fromList++----------------------------------------------------------------++-- | Getting GHC version. 7.6.3 becames 706 in the second of the result.+getGHCVersion :: IO (GHCVersion, Int)+getGHCVersion = ghcVer >>= toTupple+ where+ ghcVer = programFindVersion ghcProgram silent (programName ghcProgram)+ toTupple Nothing = throwIO $ userError "ghc not found"+ toTupple (Just v)+ | length vs < 2 = return (verstr, 0)+ | otherwise = return (verstr, ver)+ where+ vs = versionBranch v+ ver = (vs !! 0) * 100 + (vs !! 1)+ verstr = intercalate "." . map show $ vs
+ Language/Haskell/GhcMod/Check.hs view
@@ -0,0 +1,41 @@+module Language.Haskell.GhcMod.Check (checkSyntax, check) where++import Control.Applicative+import Control.Monad+import CoreMonad+import Exception+import GHC+import Language.Haskell.GhcMod.ErrMsg+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Types+import Prelude++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+-- Warnings and errors are returned.+checkSyntax :: Options+ -> Cradle+ -> FilePath -- ^ A target file+ -> IO String+checkSyntax opt cradle file = unlines <$> withGHC file (check opt cradle file)++----------------------------------------------------------------++-- | Checking syntax of a target file using GHC.+-- Warnings and errors are returned.+check :: Options+ -> Cradle+ -> FilePath -- ^ A target file+ -> Ghc [String]+check opt cradle fileName = checkIt `gcatch` handleErrMsg+ where+ checkIt = do+ readLog <- initializeFlagsWithCradle opt cradle options True+ setTargetFile fileName+ checkSlowAndSet+ void $ load LoadAllTargets+ liftIO readLog+ options+ | expandSplice opt = "-w:" : ghcOpts opt+ | otherwise = "-Wall" : ghcOpts opt
+ Language/Haskell/GhcMod/Cradle.hs view
@@ -0,0 +1,76 @@+module Language.Haskell.GhcMod.Cradle (findCradle) where++import Control.Applicative ((<$>))+import Control.Exception (throwIO)+import Control.Monad+import Data.List (isSuffixOf)+import Language.Haskell.GhcMod.Types+import System.Directory+import System.FilePath ((</>),takeDirectory)++-- | Finding 'Cradle'.+-- An error would be thrown.+findCradle :: Maybe FilePath -- ^ A 'FilePath' for a sandbox+ -> GHCVersion+ -> IO Cradle+findCradle (Just sbox) strver = do+ pkgConf <- checkPackageConf sbox strver+ wdir <- getCurrentDirectory+ cfiles <- cabalDir wdir+ return $ case cfiles of+ Nothing -> Cradle {+ cradleCurrentDir = wdir+ , cradleCabalDir = Nothing+ , cradleCabalFile = Nothing+ , cradlePackageConf = Just pkgConf+ }+ Just (cdir,cfile) -> Cradle {+ cradleCurrentDir = wdir+ , cradleCabalDir = Just cdir+ , cradleCabalFile = Just cfile+ , cradlePackageConf = Just pkgConf+ }+findCradle Nothing strver = do+ wdir <- getCurrentDirectory+ cfiles <- cabalDir wdir+ case cfiles of+ Nothing -> return Cradle {+ cradleCurrentDir = wdir+ , cradleCabalDir = Nothing+ , cradleCabalFile = Nothing+ , cradlePackageConf = Nothing+ }+ Just (cdir,cfile) -> do+ let sbox = cdir </> "cabal-dev"+ pkgConf = packageConfName sbox strver+ exist <- doesDirectoryExist pkgConf+ return Cradle {+ cradleCurrentDir = wdir+ , cradleCabalDir = Just cdir+ , cradleCabalFile = Just cfile+ , cradlePackageConf = if exist then Just pkgConf else Nothing+ }++cabalDir :: FilePath -> IO (Maybe (FilePath,FilePath))+cabalDir dir = do+ cnts <- (filter isCabal <$> getDirectoryContents dir)+ >>= filterM (\file -> doesFileExist (dir </> file))+ let dir' = takeDirectory dir+ case cnts of+ [] | dir' == dir -> return Nothing+ | otherwise -> cabalDir dir'+ cfile:_ -> return $ Just (dir,dir </> cfile)+ where+ isCabal name = ".cabal" `isSuffixOf` name && length name > 6++packageConfName :: FilePath -> String -> FilePath+packageConfName path ver = path </> "packages-" ++ ver ++ ".conf"++checkPackageConf :: FilePath -> String -> IO FilePath+checkPackageConf path ver = do+ let conf = packageConfName path ver+ exist <- doesDirectoryExist conf+ if exist then+ return conf+ else+ throwIO $ userError $ conf ++ " not found"
+ Language/Haskell/GhcMod/Debug.hs view
@@ -0,0 +1,53 @@+module Language.Haskell.GhcMod.Debug (debugInfo, debug) where++import Control.Applicative+import Control.Exception.IOChoice+import Control.Monad+import Data.List (intercalate)+import Data.Maybe+import GHC+import GhcMonad (liftIO)+import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Types+import Prelude++----------------------------------------------------------------++-- | Obtaining debug information.+debugInfo :: Options+ -> Cradle+ -> GHCVersion+ -> FilePath -- ^ A target file+ -> IO String+debugInfo opt cradle ver fileName = unlines <$> withGHC fileName (debug opt cradle ver fileName)++-- | Obtaining debug information.+debug :: Options+ -> Cradle+ -> GHCVersion+ -> FilePath -- ^ A target file+ -> Ghc [String]+debug opt cradle ver fileName = do+ (gopts, incDir, pkgs) <-+ if cabal then+ liftIO $ fromCabalFile (ghcOpts opt) cradle ||> return (ghcOpts opt, [], [])+ else+ return (ghcOpts opt, [], [])+ [fast] <- do+ void $ initializeFlagsWithCradle opt cradle gopts True+ setTargetFile fileName+ pure . canCheckFast <$> depanal [] False+ return [+ "GHC version: " ++ ver+ , "Current directory: " ++ currentDir+ , "Cabal file: " ++ cabalFile+ , "GHC options: " ++ unwords gopts+ , "Include directories: " ++ unwords incDir+ , "Dependent packages: " ++ intercalate ", " pkgs+ , "Fast check: " ++ if fast then "Yes" else "No"+ ]+ where+ currentDir = cradleCurrentDir cradle+ cabal = isJust $ cradleCabalFile cradle+ cabalFile = fromMaybe "" $ cradleCabalFile cradle
+ Language/Haskell/GhcMod/Doc.hs view
@@ -0,0 +1,24 @@+module Language.Haskell.GhcMod.Doc where++import DynFlags (DynFlags)+import Language.Haskell.GhcMod.Gap (withStyle)+import Outputable+import Pretty++styleQualified :: PprStyle+styleQualified = mkUserStyle alwaysQualify AllTheWay++styleUnqualified :: PprStyle+styleUnqualified = mkUserStyle neverQualify AllTheWay++showQualifiedPage :: DynFlags -> SDoc -> String+showQualifiedPage dflag = showDocWith PageMode . withStyle dflag styleQualified++showUnqualifiedPage :: DynFlags -> SDoc -> String+showUnqualifiedPage dflag = showDocWith PageMode . withStyle dflag styleUnqualified++showQualifiedOneLine :: DynFlags -> SDoc -> String+showQualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleQualified++showUnqualifiedOneLine :: DynFlags -> SDoc -> String+showUnqualifiedOneLine dflag = showDocWith OneLineMode . withStyle dflag styleUnqualified
+ Language/Haskell/GhcMod/ErrMsg.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE BangPatterns #-}++module Language.Haskell.GhcMod.ErrMsg (+ LogReader+ , setLogger+ , handleErrMsg+ ) where++import Bag+import Control.Applicative+import Data.IORef+import Data.Maybe+import DynFlags+import ErrUtils+import GHC+import HscTypes+import Language.Haskell.GhcMod.Doc+import qualified Language.Haskell.GhcMod.Gap as Gap+import Outputable+import System.FilePath (normalise)++----------------------------------------------------------------++type LogReader = IO [String]++----------------------------------------------------------------++setLogger :: Bool -> DynFlags -> IO (DynFlags, LogReader)+setLogger False df = return (newdf, undefined)+ where+ newdf = Gap.setLogAction df $ \_ _ _ _ _ -> return ()+setLogger True df = do+ ref <- newIORef [] :: IO (IORef [String])+ let newdf = Gap.setLogAction df $ appendLog ref+ return (newdf, reverse <$> readIORef ref)+ where+ appendLog ref _ sev src _ msg = do+ let !l = ppMsg src sev df msg+ modifyIORef ref (\ls -> l : ls)++----------------------------------------------------------------++handleErrMsg :: SourceError -> Ghc [String]+handleErrMsg err = do+ dflag <- getSessionDynFlags+ return . errBagToStrList dflag . srcErrorMessages $ err++errBagToStrList :: DynFlags -> Bag ErrMsg -> [String]+errBagToStrList dflag = map (ppErrMsg dflag) . reverse . bagToList++----------------------------------------------------------------++ppErrMsg :: DynFlags -> ErrMsg -> String+ppErrMsg dflag err = ppMsg spn SevError dflag msg ++ ext+ where+ spn = head (errMsgSpans err)+ msg = errMsgShortDoc err+ ext = showMsg dflag (errMsgExtraInfo err)++ppMsg :: SrcSpan -> Severity-> DynFlags -> SDoc -> String+ppMsg spn sev dflag msg = prefix ++ cts ++ "\0"+ where+ cts = showMsg dflag msg+ defaultPrefix+ | dopt Opt_D_dump_splices dflag = ""+ | otherwise = "Dummy:0:0:"+ prefix = fromMaybe defaultPrefix $ do+ (line,col,_,_) <- Gap.getSrcSpan spn+ file <- normalise <$> Gap.getSrcFile spn+ let severityCaption = Gap.showSeverityCaption sev+ return $ file ++ ":" ++ show line ++ ":" ++ show col ++ ":" ++ severityCaption++----------------------------------------------------------------++showMsg :: DynFlags -> SDoc -> String+showMsg dflag sdoc = map toNull $ showUnqualifiedPage dflag sdoc+ where+ toNull '\n' = '\0'+ toNull x = x
+ Language/Haskell/GhcMod/Flag.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}++module Language.Haskell.GhcMod.Flag where++import qualified Language.Haskell.GhcMod.Gap as Gap+import Language.Haskell.GhcMod.Types++-- | 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-"]+ ]
+ Language/Haskell/GhcMod/GHCApi.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Haskell.GhcMod.GHCApi (+ withGHC+ , withGHCDummyFile+ , initializeFlags+ , initializeFlagsWithCradle+ , setTargetFile+ , getDynamicFlags+ , setSlowDynFlags+ , checkSlowAndSet+ , canCheckFast+ ) where++import Control.Applicative+import Control.Exception+import Control.Monad+import CoreMonad+import Data.Maybe (isJust)+import DynFlags+import Exception+import GHC+import GHC.Paths (libdir)+import Language.Haskell.GhcMod.CabalApi+import Language.Haskell.GhcMod.ErrMsg+import Language.Haskell.GhcMod.GHCChoice+import Language.Haskell.GhcMod.Types+import System.Exit+import System.IO++----------------------------------------------------------------++-- | Converting the 'Ghc' monad to the 'IO' monad.+withGHCDummyFile :: Alternative m => Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities+ -> IO (m a)+withGHCDummyFile = withGHC "Dummy"++-- | Converting the 'Ghc' monad to the 'IO' monad.+withGHC :: Alternative m => FilePath -- ^ A target file displayed in an error message+ -> Ghc (m a) -- ^ 'Ghc' actions created by the Ghc utilities+ -> IO (m a)+withGHC file body = ghandle ignore $ runGhc (Just libdir) $ do+ dflags <- getSessionDynFlags+ defaultCleanupHandler dflags body+ where+ ignore :: Alternative m => SomeException -> IO (m a)+ ignore e = do+ hPutStr stderr $ file ++ ":0:0:Error:"+ hPrint stderr e+ exitSuccess++----------------------------------------------------------------++importDirs :: [IncludeDir]+importDirs = [".","..","../..","../../..","../../../..","../../../../.."]++data Build = CabalPkg | SingleFile deriving Eq++initializeFlagsWithCradle :: Options -> Cradle -> [GHCOption] -> Bool -> Ghc LogReader+initializeFlagsWithCradle opt cradle ghcOptions logging+ | cabal = withCabal ||> withoutCabal+ | otherwise = withoutCabal+ where+ cabal = isJust $ cradleCabalFile cradle+ withCabal = do+ (gopts,idirs,depPkgs) <- liftIO $ fromCabalFile ghcOptions cradle+ initSession CabalPkg opt gopts idirs (Just depPkgs) logging+ withoutCabal =+ initSession SingleFile opt ghcOptions importDirs Nothing logging++----------------------------------------------------------------++initSession :: Build+ -> Options+ -> [GHCOption]+ -> [IncludeDir]+ -> Maybe [Package]+ -> Bool+ -> Ghc LogReader+initSession build opt cmdOpts idirs mDepPkgs logging = do+ dflags0 <- getSessionDynFlags+ (dflags1,readLog) <- setupDynamicFlags dflags0+ _ <- setSessionDynFlags dflags1+ return readLog+ where+ setupDynamicFlags df0 = do+ df1 <- modifyFlagsWithOpts df0 cmdOpts+ let df2 = modifyFlags df1 idirs mDepPkgs (expandSplice opt) build+ df3 <- modifyFlagsWithOpts df2 $ ghcOpts opt+ liftIO $ setLogger logging df3++----------------------------------------------------------------++initializeFlags :: Options -> Ghc ()+initializeFlags opt = do+ dflags0 <- getSessionDynFlags+ dflags1 <- modifyFlagsWithOpts dflags0 $ ghcOpts opt+ void $ setSessionDynFlags dflags1++----------------------------------------------------------------++-- FIXME removing Options+modifyFlags :: DynFlags -> [IncludeDir] -> Maybe [Package] -> Bool -> Build -> DynFlags+modifyFlags d0 idirs mDepPkgs splice build+ | splice = setSplice d4+ | otherwise = d4+ where+ d1 = d0 { importPaths = idirs }+ d2 = setFastOrNot d1 Fast+ d3 = maybe d2 (addDevPkgs d2) mDepPkgs+ d4 | build == CabalPkg = setCabalPkg d3+ | otherwise = d3++setCabalPkg :: DynFlags -> DynFlags+setCabalPkg dflag = dopt_set dflag Opt_BuildingCabalPackage++setSplice :: DynFlags -> DynFlags+setSplice dflag = dopt_set dflag Opt_D_dump_splices++addDevPkgs :: DynFlags -> [Package] -> DynFlags+addDevPkgs df pkgs = df''+ where+ df' = dopt_set df Opt_HideAllPackages+ df'' = df' {+ packageFlags = map ExposePackage pkgs ++ packageFlags df+ }++----------------------------------------------------------------++setFastOrNot :: DynFlags -> CheckSpeed -> DynFlags+setFastOrNot dflags Slow = dflags {+ ghcLink = LinkInMemory+ , hscTarget = HscInterpreted+ }+setFastOrNot dflags Fast = dflags {+ ghcLink = NoLink+ , hscTarget = HscNothing+ }++setSlowDynFlags :: Ghc ()+setSlowDynFlags = (flip setFastOrNot Slow <$> getSessionDynFlags)+ >>= void . setSessionDynFlags++-- To check TH, a session module graph is necessary.+-- "load" sets a session module graph using "depanal".+-- But we have to set "-fno-code" to DynFlags before "load".+-- So, this is necessary redundancy.+checkSlowAndSet :: Ghc ()+checkSlowAndSet = do+ fast <- canCheckFast <$> depanal [] False+ unless fast setSlowDynFlags++----------------------------------------------------------------++modifyFlagsWithOpts :: DynFlags -> [String] -> Ghc DynFlags+modifyFlagsWithOpts dflags cmdOpts =+ tfst <$> parseDynamicFlags dflags (map noLoc cmdOpts)+ where+ tfst (a,_,_) = a++----------------------------------------------------------------++setTargetFile :: (GhcMonad m) => String -> m ()+setTargetFile file = do+ target <- guessTarget file Nothing+ setTargets [target]++----------------------------------------------------------------++getDynamicFlags :: IO DynFlags+getDynamicFlags = runGhc (Just libdir) getSessionDynFlags++canCheckFast :: ModuleGraph -> Bool+canCheckFast = not . any (hasTHorQQ . ms_hspp_opts)+ where+ hasTHorQQ :: DynFlags -> Bool+ hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes]
+ Language/Haskell/GhcMod/GHCChoice.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Language.Haskell.GhcMod.GHCChoice where++import Control.Exception+import CoreMonad+import Exception+import GHC++----------------------------------------------------------------++(||>) :: Ghc a -> Ghc a -> Ghc a+x ||> y = x `gcatch` (\(_ :: IOException) -> y)++----------------------------------------------------------------++{-| Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.+-}+goNext :: Ghc a+goNext = liftIO . throwIO $ userError "goNext"++{-| Run any one 'Ghc' monad.+-}+runAnyOne :: [Ghc a] -> Ghc a+runAnyOne = foldr (||>) goNext
+ Language/Haskell/GhcMod/Gap.hs view
@@ -0,0 +1,182 @@+{-# LANGUAGE CPP #-}++module Language.Haskell.GhcMod.Gap (+ Language.Haskell.GhcMod.Gap.ClsInst+ , mkTarget+ , withStyle+ , setLogAction+ , supportedExtensions+ , getSrcSpan+ , getSrcFile+ , setCtx+ , fOptions+ , toStringBuffer+ , liftIO+ , showSeverityCaption+#if __GLASGOW_HASKELL__ >= 702+#else+ , module Pretty+#endif+ ) where++import Control.Applicative hiding (empty)+import Control.Monad+import Data.Time.Clock+import DynFlags+import ErrUtils+import FastString+import GHC+import Language.Haskell.GhcMod.GHCChoice+import Outputable+import StringBuffer++import qualified InstEnv+import qualified Pretty+import qualified StringBuffer as SB+++#if __GLASGOW_HASKELL__ >= 702+import CoreMonad (liftIO)+#else+import HscTypes (liftIO)+import Pretty+#endif++#if __GLASGOW_HASKELL__ < 706+import Control.Arrow+import Data.Convertible+#endif++{-+pretty :: Outputable a => a -> String+pretty = showSDocForUser neverQualify . ppr++debug :: Outputable a => a -> b -> b+debug x v = trace (pretty x) v+-}++----------------------------------------------------------------+----------------------------------------------------------------+--+#if __GLASGOW_HASKELL__ >= 706+type ClsInst = InstEnv.ClsInst+#else+type ClsInst = InstEnv.Instance+#endif++mkTarget :: TargetId -> Bool -> Maybe (SB.StringBuffer, UTCTime) -> Target+#if __GLASGOW_HASKELL__ >= 706+mkTarget = Target+#else+mkTarget tid allowObjCode = Target tid allowObjCode . (fmap . second) convert+#endif++----------------------------------------------------------------+----------------------------------------------------------------++withStyle :: DynFlags -> PprStyle -> SDoc -> Pretty.Doc+#if __GLASGOW_HASKELL__ >= 706+withStyle = withPprStyleDoc+#else+withStyle _ = withPprStyleDoc+#endif++setLogAction :: DynFlags+ -> (DynFlags -> Severity -> SrcSpan -> PprStyle -> SDoc -> IO ())+ -> DynFlags+setLogAction df f =+#if __GLASGOW_HASKELL__ >= 706+ df { log_action = f }+#else+ df { log_action = f df }+#endif++----------------------------------------------------------------+----------------------------------------------------------------++supportedExtensions :: [String]+#if __GLASGOW_HASKELL__ >= 700+supportedExtensions = supportedLanguagesAndExtensions+#else+supportedExtensions = supportedLanguages+#endif++----------------------------------------------------------------+----------------------------------------------------------------++getSrcSpan :: SrcSpan -> Maybe (Int,Int,Int,Int)+#if __GLASGOW_HASKELL__ >= 702+getSrcSpan (RealSrcSpan spn)+#else+getSrcSpan spn | isGoodSrcSpan spn+#endif+ = Just (srcSpanStartLine spn+ , srcSpanStartCol spn+ , srcSpanEndLine spn+ , srcSpanEndCol spn)+getSrcSpan _ = Nothing++getSrcFile :: SrcSpan -> Maybe String+#if __GLASGOW_HASKELL__ >= 702+getSrcFile (RealSrcSpan spn) = Just . unpackFS . srcSpanFile $ spn+#else+getSrcFile spn | isGoodSrcSpan spn = Just . unpackFS . srcSpanFile $ spn+#endif+getSrcFile _ = Nothing++----------------------------------------------------------------++toStringBuffer :: [String] -> Ghc StringBuffer+#if __GLASGOW_HASKELL__ >= 702+toStringBuffer = return . stringToStringBuffer . unlines+#else+toStringBuffer = liftIO . stringToStringBuffer . unlines+#endif++----------------------------------------------------------------++fOptions :: [String]+#if __GLASGOW_HASKELL__ >= 704+fOptions = [option | (option,_,_) <- fFlags]+ ++ [option | (option,_,_) <- fWarningFlags]+ ++ [option | (option,_,_) <- fLangFlags]+#elif __GLASGOW_HASKELL__ == 702+fOptions = [option | (option,_,_,_) <- fFlags]+#else+fOptions = [option | (option,_,_) <- fFlags]+#endif++----------------------------------------------------------------+----------------------------------------------------------------++setCtx :: [ModSummary] -> Ghc Bool+#if __GLASGOW_HASKELL__ >= 704+setCtx ms = do+#if __GLASGOW_HASKELL__ >= 706+ let modName = IIModule . moduleName . ms_mod+#else+ let modName = IIModule . ms_mod+#endif+ top <- map modName <$> filterM isTop ms+ setContext top+ return (not . null $ top)+#else+setCtx ms = do+ top <- map ms_mod <$> filterM isTop ms+ setContext top []+ return (not . null $ top)+#endif+ where+ isTop mos = lookupMod ||> returnFalse+ where+ lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True+ returnFalse = return False+++showSeverityCaption :: Severity -> String+#if __GLASGOW_HASKELL__ >= 706+showSeverityCaption SevWarning = "Warning: "+showSeverityCaption _ = ""+#else+showSeverityCaption = const ""+#endif
+ Language/Haskell/GhcMod/Info.hs view
@@ -0,0 +1,207 @@+{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-}+{-# LANGUAGE Rank2Types #-}++module Language.Haskell.GhcMod.Info (+ infoExpr+ , info+ , typeExpr+ , typeOf+ ) where++import Control.Applicative+import Control.Monad (void, when)+import CoreUtils+import Data.Function+import Data.Generics hiding (typeOf)+import Data.List+import Data.Maybe+import Data.Ord as O+import Data.Time.Clock+import Desugar+import GHC+import GHC.SYB.Utils+import HscTypes+import Language.Haskell.GhcMod.Doc+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.GHCChoice+import qualified Language.Haskell.GhcMod.Gap as Gap+import Language.Haskell.GhcMod.Types+import NameSet+import Outputable+import PprTyThing+import TcHsSyn (hsPatType)+import TcRnTypes++----------------------------------------------------------------++data Cmd = Info | Type deriving Eq++----------------------------------------------------------------++-- | Obtaining information of a target expression. (GHCi's info:)+infoExpr :: Options+ -> Cradle+ -> FilePath -- ^ A target file+ -> ModuleString -- ^ A module name+ -> Expression -- ^ A Haskell expression+ -> IO String+infoExpr opt cradle file modstr expr = (++ "\n") <$> withGHCDummyFile (info opt cradle file modstr expr)++-- | Obtaining information of a target expression. (GHCi's info:)+info :: Options+ -> Cradle+ -> FilePath -- ^ A target file+ -> ModuleString -- ^ A module name+ -> Expression -- ^ A Haskell expression+ -> Ghc String+info opt cradle file modstr expr =+ inModuleContext Info opt cradle file modstr exprToInfo "Cannot show info"+ where+ exprToInfo = infoThing expr++----------------------------------------------------------------++class HasType a where+ getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))++instance HasType (LHsExpr Id) where+ getType tcm e = do+ hs_env <- getSession+ (_, mbe) <- Gap.liftIO $ deSugarExpr hs_env modu rn_env ty_env e+ return $ (getLoc e, ) <$> CoreUtils.exprType <$> mbe+ where+ modu = ms_mod $ pm_mod_summary $ tm_parsed_module tcm+ rn_env = tcg_rdr_env $ fst $ tm_internals_ tcm+ ty_env = tcg_type_env $ fst $ tm_internals_ tcm++instance HasType (LHsBind Id) where+ getType _ (L spn FunBind{fun_matches = MatchGroup _ typ}) = return $ Just (spn, typ)+ getType _ _ = return Nothing++instance HasType (LPat Id) where+ getType _ (L spn pat) = return $ Just (spn, hsPatType pat)++----------------------------------------------------------------++-- | Obtaining type of a target expression. (GHCi's type:)+typeExpr :: Options+ -> Cradle+ -> FilePath -- ^ A target file+ -> ModuleString -- ^ A odule name+ -> Int -- ^ Line number+ -> Int -- ^ Column number+ -> IO String+typeExpr opt cradle file modstr lineNo colNo = withGHCDummyFile $ typeOf opt cradle file modstr lineNo colNo++-- | Obtaining type of a target expression. (GHCi's type:)+typeOf :: Options+ -> Cradle+ -> FilePath -- ^ A target file+ -> ModuleString -- ^ A odule name+ -> Int -- ^ Line number+ -> Int -- ^ Column number+ -> Ghc String+typeOf opt cradle file modstr lineNo colNo =+ inModuleContext Type opt cradle file modstr exprToType errmsg+ where+ exprToType = do+ modSum <- getModSummary $ mkModuleName modstr+ p <- parseModule modSum+ tcm@TypecheckedModule{tm_typechecked_source = tcs} <- typecheckModule p+ let bs = listifySpans tcs (lineNo, colNo) :: [LHsBind Id]+ es = listifySpans tcs (lineNo, colNo) :: [LHsExpr Id]+ ps = listifySpans tcs (lineNo, colNo) :: [LPat Id]+ bts <- mapM (getType tcm) bs+ ets <- mapM (getType tcm) es+ pts <- mapM (getType tcm) ps+ dflag <- getSessionDynFlags+ let sss = map (toTup dflag) $ sortBy (cmp `on` fst) $ catMaybes $ concat [ets, bts, pts]+ return $ convert opt sss++ toTup :: DynFlags -> (SrcSpan, Type) -> ((Int,Int,Int,Int),String)+ toTup dflag (spn, typ) = (fourInts spn, pretty dflag typ)++ fourInts :: SrcSpan -> (Int,Int,Int,Int)+ fourInts = fromMaybe (0,0,0,0) . Gap.getSrcSpan++ cmp a b+ | a `isSubspanOf` b = O.LT+ | b `isSubspanOf` a = O.GT+ | otherwise = O.EQ++ errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])++listifySpans :: Typeable a => TypecheckedSource -> (Int, Int) -> [Located a]+listifySpans tcs lc = listifyStaged TypeChecker p tcs+ where+ p (L spn _) = isGoodSrcSpan spn && spn `spans` lc++listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))++pretty :: DynFlags -> Type -> String+pretty dflag = showUnqualifiedOneLine dflag . pprTypeForUser False++----------------------------------------------------------------+-- from ghc/InteractiveUI.hs++infoThing :: String -> Ghc String+infoThing str = do+ names <- parseName str+ mb_stuffs <- mapM getInfo names+ let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+ dflag <- getSessionDynFlags+ return $ showUnqualifiedPage dflag $ vcat (intersperse (text "") $ map (pprInfo False) filtered)++filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]+ where+ implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]++pprInfo :: PrintExplicitForalls -> (TyThing, GHC.Fixity, [Gap.ClsInst]) -> SDoc+pprInfo pefas (thing, fixity, insts)+ = pprTyThingInContextLoc pefas thing+ $$ show_fixity fixity+ $$ vcat (map pprInstance insts)+ where+ show_fixity fx+ | fx == defaultFixity = Outputable.empty+ | otherwise = ppr fx <+> ppr (getName thing)++----------------------------------------------------------------++inModuleContext :: Cmd -> Options -> Cradle -> FilePath -> ModuleString -> Ghc String -> String -> Ghc String+inModuleContext cmd opt cradle file modstr action errmsg =+ valid ||> invalid ||> return errmsg+ where+ valid = do+ void $ initializeFlagsWithCradle opt cradle ["-w:"] False+ when (cmd == Info) setSlowDynFlags+ setTargetFile file+ checkSlowAndSet+ void $ load LoadAllTargets+ doif setContextFromTarget action+ invalid = do+ void $ initializeFlagsWithCradle opt cradle ["-w:"] False+ setTargetBuffer+ checkSlowAndSet+ void $ load LoadAllTargets+ doif setContextFromTarget action+ setTargetBuffer = do+ modgraph <- depanal [mkModuleName modstr] True+ dflag <- getSessionDynFlags+ let imports = concatMap (map (showQualifiedPage dflag . ppr . unLoc)) $+ map ms_imps modgraph ++ map ms_srcimps modgraph+ moddef = "module " ++ sanitize modstr ++ " where"+ header = moddef : imports+ importsBuf <- Gap.toStringBuffer header+ clkTime <- Gap.liftIO getCurrentTime+ setTargets [Gap.mkTarget (TargetModule $ mkModuleName modstr)+ True+ (Just (importsBuf, clkTime))]+ doif m t = m >>= \ok -> if ok then t else goNext+ sanitize = fromMaybe "SomeModule" . listToMaybe . words++setContextFromTarget :: Ghc Bool+setContextFromTarget = depanal [] False >>= Gap.setCtx
+ Language/Haskell/GhcMod/Lang.hs view
@@ -0,0 +1,9 @@+module Language.Haskell.GhcMod.Lang where++import qualified Language.Haskell.GhcMod.Gap as Gap+import Language.Haskell.GhcMod.Types++-- | Listing language extensions.++listLanguages :: Options -> IO String+listLanguages opt = return $ convert opt Gap.supportedExtensions
+ Language/Haskell/GhcMod/Lint.hs view
@@ -0,0 +1,20 @@+module Language.Haskell.GhcMod.Lint where++import Control.Applicative+import Data.List+import Language.Haskell.GhcMod.Types+import Language.Haskell.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 = pack <$> lint opt file+ where+ pack = unlines . map (intercalate "\0" . lines)++lint :: Options+ -> FilePath -- ^ A target file.+ -> IO [String]+lint opt file = map show <$> hlint ([file, "--quiet"] ++ hlintOpts opt)
+ Language/Haskell/GhcMod/List.hs view
@@ -0,0 +1,25 @@+module Language.Haskell.GhcMod.List (listModules, listMods) where++import Control.Applicative+import Data.List+import GHC+import Language.Haskell.GhcMod.GHCApi+import Language.Haskell.GhcMod.Types+import Packages+import UniqFM++----------------------------------------------------------------++-- | Listing installed modules.+listModules :: Options -> IO String+listModules opt = convert opt . nub . sort <$> withGHCDummyFile (listMods opt)++-- | Listing installed modules.+listMods :: Options -> Ghc [String]+listMods opt = do+ initializeFlags opt+ getExposedModules <$> getSessionDynFlags+ where+ getExposedModules = map moduleNameString+ . concatMap exposedModules+ . eltsUFM . pkgIdMap . pkgState
+ Language/Haskell/GhcMod/Types.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE FlexibleInstances #-}++module Language.Haskell.GhcMod.Types where++-- | Output style.+data OutputStyle = LispStyle -- ^ S expression style+ | PlainStyle -- ^ Plain textstyle++data Options = Options {+ outputStyle :: OutputStyle+ , hlintOpts :: [String]+ , ghcOpts :: [String]+ , operators :: Bool+ -- | If 'True', 'browse' also returns types.+ , detailed :: Bool+ -- | Whether or not Template Haskell should be expanded.+ , expandSplice :: Bool+ -- | The sandbox directory.+ , sandbox :: Maybe FilePath+ }++-- | A default 'Options'.+defaultOptions :: Options+defaultOptions = Options {+ outputStyle = PlainStyle+ , hlintOpts = []+ , ghcOpts = []+ , operators = False+ , detailed = False+ , expandSplice = False+ , sandbox = Nothing+ }++----------------------------------------------------------------++convert :: ToString a => Options -> a -> String+convert Options{ outputStyle = LispStyle } = toLisp+convert Options{ outputStyle = PlainStyle } = toPlain++class ToString a where+ toLisp :: a -> String+ toPlain :: a -> String++instance ToString [String] where+ toLisp = addNewLine . toSexp True+ toPlain = unlines++instance ToString [((Int,Int,Int,Int),String)] where+ toLisp = addNewLine . toSexp False . map toS+ where+ toS x = "(" ++ tupToString x ++ ")"+ toPlain = unlines . map tupToString++toSexp :: Bool -> [String] -> String+toSexp False ss = "(" ++ unwords ss ++ ")"+toSexp True ss = "(" ++ unwords (map quote ss) ++ ")"++tupToString :: ((Int,Int,Int,Int),String) -> String+tupToString ((a,b,c,d),s) = show a ++ " "+ ++ show b ++ " "+ ++ show c ++ " "+ ++ show d ++ " "+ ++ quote s++quote :: String -> String+quote x = "\"" ++ x ++ "\""++addNewLine :: String -> String+addNewLine = (++ "\n")++----------------------------------------------------------------++-- | The environment where this library is used+data Cradle = Cradle {+ -- | The directory where this library is executed+ cradleCurrentDir :: FilePath+ -- | The directory where a cabal file is found+ , cradleCabalDir :: Maybe FilePath+ -- | The file name of the found cabal file+ , cradleCabalFile :: Maybe FilePath+ -- | The sandbox directory (e.g. \"\/foo\/bar\/packages-\<ver\>.conf/\")+ , cradlePackageConf :: Maybe FilePath+ } deriving (Eq, Show)++----------------------------------------------------------------++type GHCOption = String+type IncludeDir = FilePath+type Package = String++-- | GHC version in 'String'+type GHCVersion = String++-- | Haskell expression+type Expression = String++-- | Module name+type ModuleString = String++data CheckSpeed = Slow | Fast
− Lint.hs
@@ -1,14 +0,0 @@-module Lint where--import Control.Applicative-import Data.List-import Language.Haskell.HLint-import Types--lintSyntax :: Options -> String -> IO String-lintSyntax opt file = pack <$> lint opt file- where- pack = unlines . map (intercalate "\0" . lines)--lint :: Options -> String -> IO [String]-lint opt file = map show <$> hlint ([file, "--quiet"] ++ hlintOpts opt)
− List.hs
@@ -1,23 +0,0 @@-module List (listModules) where--import Control.Applicative-import Data.List-import GHC-import GHCApi-import Packages-import Types-import UniqFM--------------------------------------------------------------------listModules :: Options -> IO String-listModules opt = convert opt . nub . sort <$> list opt--list :: Options -> IO [String]-list opt = withGHCDummyFile $ do- initializeFlags opt- getExposedModules <$> getSessionDynFlags- where- getExposedModules = map moduleNameString- . concatMap exposedModules- . eltsUFM . pkgIdMap . pkgState
− Types.hs
@@ -1,80 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}--module Types where--data OutputStyle = LispStyle | PlainStyle--data Options = Options {- outputStyle :: OutputStyle- , hlintOpts :: [String]- , ghcOpts :: [String]- , operators :: Bool- , detailed :: Bool- , expandSplice :: Bool- , sandbox :: Maybe String- }--defaultOptions :: Options-defaultOptions = Options {- outputStyle = PlainStyle- , hlintOpts = []- , ghcOpts = []- , operators = False- , detailed = False- , expandSplice = False- , sandbox = Nothing- }--------------------------------------------------------------------convert :: ToString a => Options -> a -> String-convert Options{ outputStyle = LispStyle } = toLisp-convert Options{ outputStyle = PlainStyle } = toPlain--class ToString a where- toLisp :: a -> String- toPlain :: a -> String--instance ToString [String] where- toLisp = addNewLine . toSexp True- toPlain = unlines--instance ToString [((Int,Int,Int,Int),String)] where- toLisp = addNewLine . toSexp False . map toS- where- toS x = "(" ++ tupToString x ++ ")"- toPlain = unlines . map tupToString--toSexp :: Bool -> [String] -> String-toSexp False ss = "(" ++ unwords ss ++ ")"-toSexp True ss = "(" ++ unwords (map quote ss) ++ ")"--tupToString :: ((Int,Int,Int,Int),String) -> String-tupToString ((a,b,c,d),s) = show a ++ " "- ++ show b ++ " "- ++ show c ++ " "- ++ show d ++ " "- ++ quote s--quote :: String -> String-quote x = "\"" ++ x ++ "\""--addNewLine :: String -> String-addNewLine = (++ "\n")--------------------------------------------------------------------data Cradle = Cradle {- cradleCurrentDir :: FilePath- , cradleCabalDir :: Maybe FilePath- , cradleCabalFile :: Maybe FilePath- , cradlePackageConf :: Maybe FilePath- } deriving (Eq, Show)--------------------------------------------------------------------type GHCOption = String-type IncludeDir = FilePath-type Package = String--data CheckSpeed = Slow | Fast
elisp/Makefile view
@@ -21,3 +21,11 @@ clean: rm -f *.elc $(TEMPFILE)++VERSION = `grep version ghc.el | sed -e 's/[^0-9\.]//g'`++bump:+ echo "(define-package\n \"ghc-mod\"\n $(VERSION)\n \"Sub mode for Haskell mode\"\n nil)" > ghc-pkg.el++archive:+ git archive master -o ~/ghc-$(VERSION).tar --prefix=ghc-$(VERSION)/
elisp/ghc-doc.el view
@@ -15,10 +15,11 @@ (defun ghc-browse-document (&optional haskell-org) (interactive "P") (let ((mod0 (ghc-extract-module))- (expr (ghc-things-at-point)))+ (expr0 (ghc-things-at-point))) (cond- ((and (not mod0) expr)- (let* ((info (ghc-get-info expr))+ ((and (not mod0) expr0)+ (let* ((expr (ghc-read-expression expr0))+ (info (ghc-get-info expr0)) (mod (ghc-extact-module-from-info info)) (pkg (ghc-resolve-package-name mod))) (if (and pkg mod)@@ -104,6 +105,9 @@ (defun ghc-read-module-name (def) (read-from-minibuffer "Module name: " def ghc-input-map))++(defun ghc-read-expression (def)+ (read-from-minibuffer "Expression: " def ghc-input-map)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
elisp/ghc.el view
@@ -13,7 +13,7 @@ ;;; Code: -(defconst ghc-version "1.11.1")+(defconst ghc-version "2.0.0") ;; (eval-when-compile ;; (require 'haskell-mode))
ghc-mod.cabal view
@@ -1,5 +1,5 @@ Name: ghc-mod-Version: 1.12.5+Version: 2.0.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -37,27 +37,27 @@ test/data/check-test-subdir/test/*.hs test/data/check-test-subdir/test/Bar/*.hs test/data/check-test-subdir/src/Check/Test/*.hs-Executable ghc-mod++Library Default-Language: Haskell2010- Main-Is: GHCMod.hs- Other-Modules: Browse- CabalApi- Check- Cradle- Doc- Debug- ErrMsg- Flag- GHCApi- GHCChoice- Gap- Info- Lang- Lint- List- Paths_ghc_mod- Types GHC-Options: -Wall+ Exposed-Modules: Language.Haskell.GhcMod+ Other-Modules: Language.Haskell.GhcMod.Browse+ Language.Haskell.GhcMod.CabalApi+ Language.Haskell.GhcMod.Check+ Language.Haskell.GhcMod.Cradle+ Language.Haskell.GhcMod.Doc+ Language.Haskell.GhcMod.Debug+ Language.Haskell.GhcMod.ErrMsg+ Language.Haskell.GhcMod.Flag+ Language.Haskell.GhcMod.GHCApi+ Language.Haskell.GhcMod.GHCChoice+ Language.Haskell.GhcMod.Gap+ Language.Haskell.GhcMod.Info+ Language.Haskell.GhcMod.Lang+ Language.Haskell.GhcMod.Lint+ Language.Haskell.GhcMod.List+ Language.Haskell.GhcMod.Types Build-Depends: base >= 4.0 && < 5 , Cabal >= 1.10 , containers@@ -74,6 +74,18 @@ , syb , time , transformers++Executable ghc-mod+ Default-Language: Haskell2010+ Main-Is: GHCMod.hs+ Other-Modules: Paths_ghc_mod+ GHC-Options: -Wall+ HS-Source-Dirs: src+ Build-Depends: base >= 4.0 && < 5+ , directory+ , filepath+ , ghc+ , ghc-mod Test-Suite spec Default-Language: Haskell2010
+ src/GHCMod.hs view
@@ -0,0 +1,162 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Main where++import Control.Applicative+import Control.Exception+import Data.Typeable+import Data.Version+import Language.Haskell.GhcMod+import Paths_ghc_mod+import Prelude+import System.Console.GetOpt+import System.Directory+import System.Environment (getArgs)+import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)++----------------------------------------------------------------++ghcOptHelp :: String+ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "++usage :: String+usage = "ghc-mod version " ++ showVersion version ++ "\n"+ ++ "Usage:\n"+ ++ "\t ghc-mod list" ++ ghcOptHelp ++ "[-l]\n"+ ++ "\t ghc-mod lang [-l]\n"+ ++ "\t ghc-mod flag [-l]\n"+ ++ "\t ghc-mod browse" ++ ghcOptHelp ++ "[-l] [-o] [-d] <module> [<module> ...]\n"+ ++ "\t ghc-mod check" ++ ghcOptHelp ++ "<HaskellFile>\n"+ ++ "\t ghc-mod expand" ++ ghcOptHelp ++ "<HaskellFile>\n"+ ++ "\t ghc-mod debug" ++ ghcOptHelp ++ "<HaskellFile>\n"+ ++ "\t ghc-mod info" ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"+ ++ "\t ghc-mod type" ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"+ ++ "\t ghc-mod lint [-h opt] <HaskellFile>\n"+ ++ "\t ghc-mod boot\n"+ ++ "\t ghc-mod help\n"++----------------------------------------------------------------++argspec :: [OptDescr (Options -> Options)]+argspec = [ Option "l" ["tolisp"]+ (NoArg (\opts -> opts { outputStyle = LispStyle }))+ "print as a list of Lisp"+ , Option "h" ["hlintOpt"]+ (ReqArg (\h opts -> opts { hlintOpts = h : hlintOpts opts }) "hlintOpt")+ "hlint options"+ , Option "g" ["ghcOpt"]+ (ReqArg (\g opts -> opts { ghcOpts = g : ghcOpts opts }) "ghcOpt")+ "GHC options"+ , Option "o" ["operators"]+ (NoArg (\opts -> opts { operators = True }))+ "print operators, too"+ , Option "d" ["detailed"]+ (NoArg (\opts -> opts { detailed = True }))+ "print detailed info"+ , Option "s" ["sandbox"]+ (ReqArg (\s opts -> opts { sandbox = Just s }) "path")+ "specify cabal-dev sandbox (default 'cabal-dev`)"+ ]++parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])+parseArgs spec argv+ = case getOpt Permute spec argv of+ (o,n,[] ) -> (foldr id defaultOptions o, n)+ (_,_,errs) -> throw (CmdArg errs)++----------------------------------------------------------------++data GHCModError = SafeList+ | NoSuchCommand String+ | CmdArg [String]+ | FileNotExist String deriving (Show, Typeable)++instance Exception GHCModError++----------------------------------------------------------------++main :: IO ()+main = flip catches handlers $ do+-- #if __GLASGOW_HASKELL__ >= 611+ hSetEncoding stdout utf8+-- #endif+ args <- getArgs+ let (opt',cmdArg) = parseArgs argspec args+ (strVer,ver) <- getGHCVersion+ cradle <- findCradle (sandbox opt') strVer+ let opt = adjustOpts opt' cradle ver+ cmdArg0 = cmdArg !. 0+ cmdArg1 = cmdArg !. 1+ cmdArg2 = cmdArg !. 2+ cmdArg3 = cmdArg !. 3+ cmdArg4 = cmdArg !. 4+ res <- case cmdArg0 of+ "browse" -> concat <$> mapM (browseModule opt) (tail cmdArg)+ "list" -> listModules opt+ "check" -> checkSyntax opt cradle cmdArg1+ "expand" -> checkSyntax opt { expandSplice = True } cradle cmdArg1+ "debug" -> debugInfo opt cradle strVer cmdArg1+ "type" -> typeExpr opt cradle cmdArg1 cmdArg2 (read cmdArg3) (read cmdArg4)+ "info" -> infoExpr opt cradle cmdArg1 cmdArg2 cmdArg3+ "lint" -> withFile (lintSyntax opt) cmdArg1+ "lang" -> listLanguages opt+ "flag" -> listFlags opt+ "boot" -> do+ mods <- listModules opt+ langs <- listLanguages opt+ flags <- listFlags opt+ pre <- concat <$> mapM (browseModule opt) preBrowsedModules+ return $ mods ++ langs ++ flags ++ pre+ cmd -> throw (NoSuchCommand cmd)+ putStr res+ where+ handlers = [Handler handler1, Handler handler2]+ handler1 :: ErrorCall -> IO ()+ handler1 = print -- for debug+ handler2 :: GHCModError -> IO ()+ handler2 SafeList = printUsage+ handler2 (NoSuchCommand cmd) = do+ hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"+ printUsage+ handler2 (CmdArg errs) = do+ mapM_ (hPutStr stderr) errs+ printUsage+ handler2 (FileNotExist file) = do+ hPutStrLn stderr $ "\"" ++ file ++ "\" not found"+ printUsage+ printUsage = hPutStrLn stderr $ '\n' : usageInfo usage argspec+ withFile cmd file = do+ exist <- doesFileExist file+ if exist+ then cmd file+ else throw (FileNotExist file)+ xs !. idx+ | length xs <= idx = throw SafeList+ | otherwise = xs !! idx+ adjustOpts opt cradle ver = case mPkgConf of+ Nothing -> opt+ Just pkgConf -> opt {+ ghcOpts = ghcPackageConfOptions ver pkgConf ++ ghcOpts opt+ }+ where+ mPkgConf = cradlePackageConf cradle++----------------------------------------------------------------++preBrowsedModules :: [String]+preBrowsedModules = [+ "Prelude"+ , "Control.Applicative"+ , "Control.Monad"+ , "Control.Exception"+ , "Data.Char"+ , "Data.List"+ , "Data.Maybe"+ , "System.IO"+ ]+++ghcPackageConfOptions :: Int -> String -> [String]+ghcPackageConfOptions ver file+ | ver >= 706 = ["-package-db", file, "-no-user-package-db"]+ | otherwise = ["-package-conf", file, "-no-user-package-conf"]
test/BrowseSpec.hs view
@@ -1,10 +1,9 @@ module BrowseSpec where import Control.Applicative-import Test.Hspec-import Browse import Expectation-import Types+import Language.Haskell.GhcMod+import Test.Hspec spec :: Spec spec = do
test/CabalApiSpec.hs view
@@ -1,8 +1,8 @@ module CabalApiSpec where import Control.Applicative+import Language.Haskell.GhcMod.CabalApi import Test.Hspec-import CabalApi spec :: Spec spec = do
test/CheckSpec.hs view
@@ -1,13 +1,10 @@ module CheckSpec where -import CabalApi-import Check-import Cradle import Data.List (isSuffixOf, isInfixOf, isPrefixOf) import Expectation-import Test.Hspec-import Types+import Language.Haskell.GhcMod import System.FilePath+import Test.Hspec spec :: Spec spec = do
test/DebugSpec.hs view
@@ -1,18 +1,15 @@ module DebugSpec where -import CabalApi-import Cradle-import Debug import Expectation+import Language.Haskell.GhcMod import Test.Hspec-import Types checkFast :: String -> String -> IO () checkFast file ans = withDirectory_ "test/data" $ do (strVer,_) <- getGHCVersion cradle <- findCradle Nothing strVer- res <- debug defaultOptions cradle strVer file- res `shouldContain` ans+ res <- debugInfo defaultOptions cradle strVer file+ lines res `shouldContain` ans spec :: Spec spec = do
test/FlagSpec.hs view
@@ -1,10 +1,9 @@ module FlagSpec where import Control.Applicative-import Test.Hspec import Expectation-import Flag-import Types+import Language.Haskell.GhcMod+import Test.Hspec spec :: Spec spec = do
test/InfoSpec.hs view
@@ -1,14 +1,11 @@ module InfoSpec where -import CabalApi-import Cradle import Data.List (isPrefixOf) import Expectation-import Info-import Test.Hspec-import Types-import System.Process+import Language.Haskell.GhcMod import System.Exit+import System.Process+import Test.Hspec spec :: Spec spec = do@@ -17,38 +14,38 @@ withDirectory_ "test/data/ghc-mod-check" $ do (strVer,_) <- getGHCVersion cradle <- findCradle Nothing strVer- res <- typeExpr defaultOptions cradle "Data.Foo" 9 5 "Data/Foo.hs"+ res <- typeExpr defaultOptions cradle "Data/Foo.hs" "Data.Foo" 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 <- getGHCVersion >>= findCradle Nothing . fst- res <- typeExpr defaultOptions cradle "Bar" 5 1 "Bar.hs"+ res <- typeExpr defaultOptions cradle "Bar.hs" "Bar" 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 <- getGHCVersion >>= findCradle Nothing . fst- res <- typeExpr defaultOptions cradle "Main" 3 8 "Main.hs"+ res <- typeExpr defaultOptions cradle "Main.hs" "Main" 3 8 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""] describe "infoExpr" $ do it "works for non-export functions" $ do withDirectory_ "test/data" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst- res <- infoExpr defaultOptions cradle "Info" "fib" "Info.hs"+ res <- infoExpr defaultOptions cradle "Info.hs" "Info" "fib" res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`) it "works with a module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst- res <- infoExpr defaultOptions cradle "Bar" "foo" "Bar.hs"+ res <- infoExpr defaultOptions cradle "Bar.hs" "Bar" "foo" res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`) it "works with a module that imports another module using TemplateHaskell" $ do withDirectory_ "test/data" $ do cradle <- getGHCVersion >>= findCradle Nothing . fst- res <- infoExpr defaultOptions cradle "Main" "bar" "Main.hs"+ res <- infoExpr defaultOptions cradle "Main.hs" "Main" "bar" res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`) it "doesn't fail on unicode output" $ do
test/LangSpec.hs view
@@ -1,10 +1,9 @@ module LangSpec where import Control.Applicative-import Test.Hspec import Expectation-import Lang-import Types+import Language.Haskell.GhcMod+import Test.Hspec spec :: Spec spec = do
test/LintSpec.hs view
@@ -1,8 +1,7 @@ module LintSpec where +import Language.Haskell.GhcMod import Test.Hspec-import Lint-import Types spec :: Spec spec = do
test/ListSpec.hs view
@@ -1,10 +1,9 @@ module ListSpec where import Control.Applicative-import Test.Hspec import Expectation-import List-import Types+import Language.Haskell.GhcMod+import Test.Hspec spec :: Spec spec = do