Changing GHCMod as a library.

Language/Haskell/GhcMod.hs

@@ -0,0 +1,27 @@
+module Language.Haskell.GhcMod (
+    browseModule
+  , checkSyntax
+  , module Language.Haskell.GhcMod.Cradle
+  , debugInfo
+  , debug
+  , infoExpr
+  , typeExpr
+  , listLanguages
+  , lintSyntax
+  , listModules
+  , module Language.Haskell.GhcMod.Types
+  , listFlags
+  , getGHCVersion
+  ) 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.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

@@ -0,0 +1,97 @@
+module Language.Haskell.GhcMod.Browse (browseModule) 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
+
+----------------------------------------------------------------
+
+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

Language/Haskell/GhcMod/CabalApi.hs

@@ -0,0 +1,143 @@
+{-# 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
+
+----------------------------------------------------------------
+
+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

Language/Haskell/GhcMod/Check.hs

@@ -0,0 +1,31 @@
+module Language.Haskell.GhcMod.Check (checkSyntax) 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
+
+----------------------------------------------------------------
+
+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

Language/Haskell/GhcMod/Cradle.hs

@@ -0,0 +1,73 @@
+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)
+
+-- 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"

Language/Haskell/GhcMod/Debug.hs

@@ -0,0 +1,42 @@
+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 Language.Haskell.GhcMod.CabalApi
+import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Types
+import Prelude
+
+----------------------------------------------------------------
+
+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

Language/Haskell/GhcMod/Doc.hs

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

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

@@ -0,0 +1,12 @@
+{-# LANGUAGE CPP #-}
+
+module Language.Haskell.GhcMod.Flag where
+
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Types
+
+listFlags :: Options -> IO String
+listFlags opt = return $ convert opt [ "-f" ++ prefix ++ option
+                                     | option <- Gap.fOptions
+                                     , prefix <- ["","no-"]
+                                     ]

Language/Haskell/GhcMod/GHCApi.hs

@@ -0,0 +1,172 @@
+{-# 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
+
+----------------------------------------------------------------
+
+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]

Language/Haskell/GhcMod/GHCChoice.hs

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

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

@@ -0,0 +1,177 @@
+{-# LANGUAGE TupleSections, FlexibleInstances, TypeSynonymInstances #-}
+{-# LANGUAGE Rank2Types #-}
+
+module Language.Haskell.GhcMod.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 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
+
+----------------------------------------------------------------
+
+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 = Language.Haskell.GhcMod.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

Language/Haskell/GhcMod/Lang.hs

@@ -0,0 +1,7 @@
+module Language.Haskell.GhcMod.Lang where
+
+import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Types
+
+listLanguages :: Options -> IO String
+listLanguages opt = return $ convert opt Gap.supportedExtensions

Language/Haskell/GhcMod/Lint.hs

@@ -0,0 +1,14 @@
+module Language.Haskell.GhcMod.Lint where
+
+import Control.Applicative
+import Data.List
+import Language.Haskell.GhcMod.Types
+import Language.Haskell.HLint
+
+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)

Language/Haskell/GhcMod/List.hs

@@ -0,0 +1,23 @@
+module Language.Haskell.GhcMod.List (listModules) where
+
+import Control.Applicative
+import Data.List
+import GHC
+import Language.Haskell.GhcMod.GHCApi
+import Language.Haskell.GhcMod.Types
+import Packages
+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

Language/Haskell/GhcMod/Types.hs

@@ -0,0 +1,80 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Language.Haskell.GhcMod.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