Merge remote-tracking branch 'kazu/master'

Conflicts:
	Language/Haskell/GhcMod/Check.hs
	Language/Haskell/GhcMod/FillSig.hs
	Language/Haskell/GhcMod/GHCApi.hs

Language/Haskell/GhcMod.hs

@@ -13,6 +13,14 @@ module Language.Haskell.GhcMod (
   , ModuleString
   , Expression
   , GhcPkgDb
+  , Symbol
+  , SymbolDb
+  -- * Monad Types
+  , GhcModT
+  , IOish
+  -- * Monad utilities
+  , runGhcModT
+  , withOptions
   -- * 'GhcMod' utilities
   , boot
   , browse
@@ -20,7 +28,6 @@ module Language.Haskell.GhcMod (
   , checkSyntax
   , debugInfo
   , expandTemplate
-  , findSymbol
   , info
   , lint
   , pkgDoc
@@ -32,20 +39,26 @@ module Language.Haskell.GhcMod (
   , modules
   , languages
   , flags
+  , findSymbol
+  , lookupSymbol
+  , dumpSymbol
+  -- * SymbolDb
+  , loadSymbolDb
   ) where
 
 import Language.Haskell.GhcMod.Boot
 import Language.Haskell.GhcMod.Browse
+import Language.Haskell.GhcMod.CaseSplit
 import Language.Haskell.GhcMod.Check
 import Language.Haskell.GhcMod.Cradle
 import Language.Haskell.GhcMod.Debug
+import Language.Haskell.GhcMod.FillSig
 import Language.Haskell.GhcMod.Find
 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.Monad
 import Language.Haskell.GhcMod.PkgDoc
-import Language.Haskell.GhcMod.FillSig
-import Language.Haskell.GhcMod.CaseSplit
 import Language.Haskell.GhcMod.Types

Language/Haskell/GhcMod/Browse.hs

@@ -11,11 +11,11 @@ import Exception (ghandle)
 import FastString (mkFastString)
 import GHC (GhcException(CmdLineError), ModuleInfo, Name, TyThing, DynFlags, Type, TyCon)
 import qualified GHC as G
-import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
-import Language.Haskell.GhcMod.DynFlags
-import Language.Haskell.GhcMod.Gap
-import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Doc (showPage, styleUnqualified)
+import Language.Haskell.GhcMod.Gap
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT, options)
+import Language.Haskell.GhcMod.Target (setTargetFiles)
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)
 import Outputable (ppr, Outputable)

Language/Haskell/GhcMod/CabalConfig.hs

@@ -14,6 +14,10 @@ import Language.Haskell.GhcMod.Types
 import qualified Language.Haskell.GhcMod.Cabal16 as C16
 import qualified Language.Haskell.GhcMod.Cabal18 as C18
 
+#ifndef MIN_VERSION_mtl
+#define MIN_VERSION_mtl(x,y,z) 1
+#endif
+
 import qualified Control.Exception as E
 import Control.Applicative ((<$>))
 import Control.Monad (mplus)
@@ -59,7 +63,7 @@ configDependencies :: PackageIdentifier -> CabalConfig -> [Package]
 configDependencies thisPkg config = map fromInstalledPackageId deps
  where
     deps :: [InstalledPackageId]
-    deps = case (deps18 `mplus` deps16) of
+    deps = case deps18 `mplus` deps16 of
         Right ps -> ps
         Left msg -> error msg
 

Language/Haskell/GhcMod/CaseSplit.hs

@@ -184,7 +184,7 @@ getBindingText text srcSpan =
            [T.drop (sc - 1) $ T.take ec $ head lines_]
       else -- several lines
             let (first,rest,last_) = (head lines_, tail $ init lines_, last lines_)
-             in (T.drop (sc - 1) first) : rest ++ [T.take ec last_]
+             in T.drop (sc - 1) first : rest ++ [T.take ec last_]
 
 srcSpanDifference :: SrcSpan -> SrcSpan -> (Int,Int,Int,Int)
 srcSpanDifference b v =

Language/Haskell/GhcMod/Check.hs

@@ -9,7 +9,8 @@ import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.DynFlags
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Logger
-import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT, withErrorHandler)
+import Language.Haskell.GhcMod.Target (setTargetFiles)
 
 ----------------------------------------------------------------
 
@@ -19,7 +20,7 @@ checkSyntax :: IOish m
             => [FilePath]  -- ^ The target files.
             -> GhcModT m String
 checkSyntax [] = return ""
-checkSyntax files = withErrorHandler sessionName $ do
+checkSyntax files = withErrorHandler sessionName $
     either id id <$> check files
   where
     sessionName = case files of
@@ -33,7 +34,7 @@ checkSyntax files = withErrorHandler sessionName $ do
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
-check fileNames = do
+check fileNames =
   withLogger (setAllWaringFlags . setNoMaxRelevantBindings) $
     setTargetFiles fileNames
 
@@ -44,7 +45,7 @@ expandTemplate :: IOish m
                => [FilePath]  -- ^ The target files.
                -> GhcModT m String
 expandTemplate [] = return ""
-expandTemplate files = withErrorHandler sessionName $ do
+expandTemplate files = withErrorHandler sessionName $
     either id id <$> expand files
   where
     sessionName = case files of

Language/Haskell/GhcMod/Convert.hs

@@ -81,14 +81,14 @@ instance ToString ((Int,Int,Int,Int),String) where
     toPlain opt x = tupToString opt x
 
 instance ToString (String, (Int,Int,Int,Int),[String]) where
-    toLisp  opt (s,x,y) = toSexp2 $ [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
+    toLisp  opt (s,x,y) = toSexp2 [toLisp opt s, ('(' :) . fourIntsToString opt x . (')' :), toLisp opt y]
     toPlain opt (s,x,y) = inter '\n' [toPlain opt s, fourIntsToString opt x, toPlain opt y]
 
 toSexp1 :: Options -> [String] -> Builder
 toSexp1 opt ss = ('(' :) . inter ' ' (map (quote opt) ss) . (')' :)
 
 toSexp2 :: [Builder] -> Builder
-toSexp2 ss = ('(' :) . (inter ' ' ss) . (')' :)
+toSexp2 ss = ('(' :) . inter ' ' ss . (')' :)
 
 fourIntsToString :: Options -> (Int,Int,Int,Int) -> Builder
 fourIntsToString _ (a,b,c,d) = (show a ++) . (' ' :)

Language/Haskell/GhcMod/Cradle.hs

@@ -22,8 +22,7 @@ import System.FilePath ((</>), takeDirectory)
 --   Find a sandbox according to a cabal sandbox config
 --   in a cabal directory.
 findCradle :: IO Cradle
-findCradle = do
+findCradle = findCradle' =<< getCurrentDirectory
-    findCradle' =<< getCurrentDirectory
 
 findCradle' :: FilePath -> IO Cradle
 findCradle' dir = cabalCradle dir ||> sandboxCradle dir ||> plainCradle dir

Language/Haskell/GhcMod/Debug.hs

@@ -16,7 +16,7 @@ debugInfo :: IOish m => GhcModT m String
 debugInfo = cradle >>= \c -> convert' =<< do
     CompilerOptions gopts incDir pkgs <-
         if isJust $ cradleCabalFile c then
-            (fromCabalFile c ||> simpleCompilerOption)
+            fromCabalFile c ||> simpleCompilerOption
           else
             simpleCompilerOption
     return [

Language/Haskell/GhcMod/DynFlags.hs

@@ -2,17 +2,14 @@
 
 module Language.Haskell.GhcMod.DynFlags where
 
+import Control.Applicative ((<$>))
+import Control.Monad (void)
+import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..))
+import qualified GHC as G
+import GHC.Paths (libdir)
+import GhcMonad
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Types
-
-import Control.Applicative ((<$>))
-import Control.Monad (forM, void, (>=>))
-import GHC (DynFlags(..), GhcMode(..), GhcLink(..), HscTarget(..), LoadHowMuch(..))
-import qualified GHC as G
-import GhcMonad
-import GHC.Paths (libdir)
-import DynFlags (ExtensionFlag(..), xopt)
-
 import System.IO.Unsafe (unsafePerformIO)
 
 data Build = CabalPkg | SingleFile deriving Eq
@@ -71,40 +68,9 @@ addCmdOpts cmdOpts df =
 
 ----------------------------------------------------------------
 
--- | Set the files as targets and load them.
-setTargetFiles :: (GhcMonad m) => [FilePath] -> m ()
-setTargetFiles files = do
-    targets <- forM files $ \file -> G.guessTarget file Nothing
-    G.setTargets targets
-    xs <- G.depanal [] False
-    -- FIXME, checking state
-    loadTargets $ needsFallback xs
-  where
-    loadTargets False = do
-        -- Reporting error A and error B
-        void $ G.load LoadAllTargets
-        mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
-        -- Reporting error B and error C
-        mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
-        -- Error B duplicates. But we cannot ignore both error reportings,
-        -- sigh. So, the logger makes log messages unique by itself.
-    loadTargets True = do
-        df <- G.getSessionDynFlags
-        void $ G.setSessionDynFlags (setModeIntelligent df)
-        void $ G.load LoadAllTargets
-
-needsFallback :: G.ModuleGraph -> Bool
-needsFallback = any (hasTHorQQ . G.ms_hspp_opts)
-  where
-    hasTHorQQ :: DynFlags -> Bool
-    hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes]
-
-----------------------------------------------------------------
-
 -- | Return the 'DynFlags' currently in use in the GHC session.
 getDynamicFlags :: IO DynFlags
-getDynamicFlags = do
+getDynamicFlags = G.runGhc (Just libdir) G.getSessionDynFlags
-    G.runGhc (Just libdir) G.getSessionDynFlags
 
 withDynFlags :: GhcMonad m
              => (DynFlags -> DynFlags)
@@ -138,7 +104,7 @@ setAllWaringFlags :: DynFlags -> DynFlags
 setAllWaringFlags df = df { warningFlags = allWarningFlags }
 
 allWarningFlags :: Gap.WarnFlags
-allWarningFlags = unsafePerformIO $ do
+allWarningFlags = unsafePerformIO $
     G.runGhc (Just libdir) $ do
         df <- G.getSessionDynFlags
         df' <- addCmdOpts ["-Wall"] df

Language/Haskell/GhcMod/FillSig.hs

@@ -6,7 +6,7 @@ module Language.Haskell.GhcMod.FillSig (
   ) where
 
 import Data.Char (isSymbol)
-import Data.List (find, intercalate)
+import Data.List (find)
 import Data.Maybe (isJust)
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags, SrcSpan, Type, GenLocated(L))
@@ -48,7 +48,7 @@ sig file lineNo colNo = ghandle handler body
         whenFound opt (getSignature modSum lineNo colNo) $ \s -> case s of
           Signature loc names ty ->
             ("function", fourInts loc, map (initialBody dflag style ty) names)
-          InstanceDecl loc cls -> do
+          InstanceDecl loc cls ->
              ("instance", fourInts loc, map (\x -> initialBody dflag style (G.idType x) x)
                                             (Ty.classMethods cls))
 
@@ -112,8 +112,8 @@ initialBody' fname args =
   case initialBodyArgs args infiniteVars infiniteFns of
     []      -> fname
     arglist -> if isSymbolName fname
-               then (head arglist) ++ " " ++ fname ++ " " ++ (intercalate " " (tail arglist))
+               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
-               else fname ++ " " ++ (intercalate " " arglist)
+               else fname ++ " " ++ unwords arglist
   ++ " = " ++ (if isSymbolName fname then "" else '_':fname) ++ "_body"
 
 initialBodyArgs :: [FnArg] -> [String] -> [String] -> [String]
@@ -136,7 +136,7 @@ instance FnArgsInfo (G.HsType G.RdrName) (G.RdrName) where
   getFnArgs (G.HsForAllTy _ _ _ (L _ iTy))  = getFnArgs iTy
   getFnArgs (G.HsParTy (L _ iTy))           = getFnArgs iTy
   getFnArgs (G.HsFunTy (L _ lTy) (L _ rTy)) = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
-    where fnarg = \ty -> case ty of
+    where fnarg ty = case ty of
               (G.HsForAllTy _ _ _ (L _ iTy)) -> fnarg iTy
               (G.HsParTy (L _ iTy))          -> fnarg iTy
               (G.HsFunTy _ _)                -> True
@@ -149,7 +149,7 @@ instance FnArgsInfo (HE.Type HE.SrcSpanInfo) (HE.Name HE.SrcSpanInfo) where
   getFnArgs (HE.TyForall _ _ _ iTy) = getFnArgs iTy
   getFnArgs (HE.TyParen _ iTy)      = getFnArgs iTy
   getFnArgs (HE.TyFun _ lTy rTy)    = (if fnarg lTy then FnArgFunction else FnArgNormal):getFnArgs rTy
-    where fnarg = \ty -> case ty of
+    where fnarg ty = case ty of
               (HE.TyForall _ _ _ iTy) -> fnarg iTy
               (HE.TyParen _ iTy)      -> fnarg iTy
               (HE.TyFun _ _ _)        -> True

Language/Haskell/GhcMod/Find.hs

@@ -1,13 +1,18 @@
 {-# LANGUAGE CPP, BangPatterns #-}
 
-module Language.Haskell.GhcMod.Find (
+module Language.Haskell.GhcMod.Find
+#ifndef SPEC
+  (
     Symbol
   , SymbolDb
-  , getSymbolDb
+  , loadSymbolDb
   , lookupSymbol
   , dumpSymbol
   , findSymbol
-  ) where
+  , lookupSym
+  )
+#endif
+  where
 
 import Config (cProjectVersion,cTargetPlatformString)
 import Control.Applicative ((<$>))
@@ -19,16 +24,17 @@ import Data.List (groupBy, sort)
 import Data.List.Split (splitOn)
 import Data.Maybe (fromMaybe)
 import DynFlags (DynFlags(..), systemPackageConfig)
-import Exception (handleIO)
+import Exception (ghandle, handleIO)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Types
 import Name (getOccString)
 import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
 import System.FilePath ((</>))
 import System.IO
-import System.Process (readProcess)
+import System.Environment (getExecutablePath)
 
 #ifndef MIN_VERSION_containers
 #define MIN_VERSION_containers(x,y,z) 1
@@ -44,11 +50,10 @@ import qualified Data.Map as M
 
 ----------------------------------------------------------------
 
--- | Type of key for `SymbolDb`.
+-- | Type of function and operation names.
 type Symbol = String
-type Db = Map Symbol [ModuleString]
+-- | Database from 'Symbol' to \['ModuleString'\].
--- | Database from 'Symbol' to modules.
+newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
-newtype SymbolDb = SymbolDb Db
 
 ----------------------------------------------------------------
 
@@ -63,26 +68,37 @@ packageConfDir = "package.conf.d"
 
 ----------------------------------------------------------------
 
--- | Finding modules to which the symbol belong.
+-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
+--   which will be concatenated. 'loadSymbolDb' is called internally.
 findSymbol :: IOish m => Symbol -> GhcModT m String
-findSymbol sym = convert' =<< lookupSymbol' sym <$> liftIO getSymbolDb
+findSymbol sym = liftIO loadSymbolDb >>= lookupSymbol sym
 
-lookupSymbol' :: Symbol -> SymbolDb -> [ModuleString]
+-- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
-lookupSymbol' sym (SymbolDb db) = fromMaybe [] (M.lookup sym db)
+--   which will be concatenated.
+lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
+lookupSymbol sym db = convert' $ lookupSym sym db
 
--- | Looking up 'SymbolDb' with 'Symbol' to find modules.
+lookupSym :: Symbol -> SymbolDb -> [ModuleString]
-lookupSymbol :: Options -> Symbol -> SymbolDb -> String
+lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
-lookupSymbol opt sym db = convert opt $ lookupSymbol' sym db
 
 ---------------------------------------------------------------
 
--- | Creating 'SymbolDb'.
+-- | Loading a file and creates 'SymbolDb'.
-getSymbolDb :: IO SymbolDb
+loadSymbolDb :: IO SymbolDb
-getSymbolDb = SymbolDb <$> loadSymbolDb
+loadSymbolDb = SymbolDb <$> readSymbolDb
 
-loadSymbolDb :: IO Db
+ghcModExecutable :: IO FilePath
-loadSymbolDb = handle (\(SomeException _) -> return M.empty) $ do
+ghcModExecutable =
-    file <- chop <$> readProcess "ghc-mod" ["dumpsym"] []
+#ifndef SPEC
+    getExecutablePath
+#else
+    return "dist/build/ghc-mod/ghc-mod"
+#endif
+
+readSymbolDb :: IO (Map Symbol [ModuleString])
+readSymbolDb = handle (\(SomeException _) -> return M.empty) $ do
+    ghcMod <- ghcModExecutable
+    file <- chop <$> readProcess' ghcMod ["dumpsym"]
     M.fromAscList . map conv . lines <$> readFile file
   where
     conv :: String -> (Symbol,[ModuleString])
@@ -101,6 +117,9 @@ getPath = do
         []  -> return Nothing
         u:_ -> liftIO $ resolvePackageDb df u
 
+-- | Dumping a set of ('Symbol',\['ModuleString'\]) to a file
+--   if the file does not exist or is invalid.
+--   The file name is printed.
 dumpSymbol :: IOish m => GhcModT m String
 dumpSymbol = do
     mdir <- getPath
@@ -109,12 +128,12 @@ dumpSymbol = do
         Just dir -> do
             let cache = dir </> symbolCache
                 pkgdb = dir </> packageCache
-            do -- fixme: bracket
+            ghandle (\(SomeException _) -> return "") $ do
                 create <- liftIO $ needToCreate cache pkgdb
                 when create $ do
                     sm <- getSymbol
                     void . liftIO $ withFile cache WriteMode $ \hdl ->
-                        mapM (hPutStrLn hdl . show) sm
+                        mapM (hPrint hdl) sm
                 return cache
     return $ ret ++ "\n"
 

Language/Haskell/GhcMod/GHCApi.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE ScopedTypeVariables, RecordWildCards, CPP #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Language.Haskell.GhcMod.GHCApi (
     ghcPkgDb
@@ -11,7 +11,8 @@ module Language.Haskell.GhcMod.GHCApi (
   ) where
 
 import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
+import Language.Haskell.GhcMod.Target (setTargetFiles)
 import Language.Haskell.GhcMod.Types
 
 import Control.Applicative ((<$>))
@@ -42,8 +43,7 @@ modules :: G.PackageConfig -> [ModuleString]
 modules = map G.moduleNameString . G.exposedModules
 
 findModule :: ModuleString -> PkgDb -> [Package]
-findModule m db = do
+findModule m db = M.elems $ package `M.map` (containsModule `M.filter` db)
-  M.elems $ package `M.map` (containsModule `M.filter` db)
  where
     containsModule :: G.PackageConfig -> Bool
     containsModule pkgConf =
@@ -65,10 +65,10 @@ type Binding = String
 -- should look for @module@ in the working directory.
 --
 -- To map a 'ModuleString' to a package see 'findModule'
-moduleInfo :: GhcMonad m
+moduleInfo :: IOish m
            => Maybe Package
            -> ModuleString
-           -> m (Maybe G.ModuleInfo)
+           -> GhcModT m (Maybe G.ModuleInfo)
 moduleInfo mpkg mdl = do
     let mdlName = G.mkModuleName mdl
         mfsPkgId = G.packageIdFS . ghcPkgId <$> mpkg
@@ -79,9 +79,8 @@ moduleInfo mpkg mdl = do
        Just _ -> return ()
        Nothing -> setTargetFiles [mdl]
 
-localModuleInfo :: GhcMonad m => ModuleString -> m (Maybe G.ModuleInfo)
+localModuleInfo :: IOish m => ModuleString -> GhcModT m (Maybe G.ModuleInfo)
 localModuleInfo mdl = moduleInfo Nothing mdl
 
 bindings :: G.ModuleInfo -> [Binding]
-bindings minfo = do
+bindings minfo = map (G.occNameString . G.getOccName) $ G.modInfoExports minfo
-  map (G.occNameString . G.getOccName) $ G.modInfoExports minfo

Language/Haskell/GhcMod/Gap.hs

@@ -39,6 +39,7 @@ module Language.Haskell.GhcMod.Gap (
   , GLMatch
   , getClass
   , occName
+  , setFlags
   ) where
 
 import Control.Applicative hiding (empty)
@@ -459,3 +460,13 @@ getClass _ = Nothing
 occName :: RdrName -> OccName
 occName = rdrNameOcc
 #endif
+
+----------------------------------------------------------------
+----------------------------------------------------------------
+
+setFlags :: DynFlags -> DynFlags
+#if __GLASGOW_HASKELL__ >= 708
+setFlags df = df `gopt_unset` Opt_SpecConstr -- consume memory if -O2
+#else
+setFlags = id
+#endif

Language/Haskell/GhcMod/Ghc.hs

@@ -1,6 +0,0 @@
-module Language.Haskell.GhcMod.Ghc (
-    -- * 'SymMdlDb'
-    module Language.Haskell.GhcMod.Find
-  ) where
-
-import Language.Haskell.GhcMod.Find

Language/Haskell/GhcMod/Internal.hs

@@ -26,6 +26,26 @@ module Language.Haskell.GhcMod.Internal (
   , withLogger
   , setNoWaringFlags
   , setAllWaringFlags
+  -- * Environment, state and logging
+  , GhcModEnv(..)
+  , newGhcModEnv
+  , GhcModState
+  , defaultState
+  , Mode(..)
+  , GhcModWriter
+  -- * Monad utilities
+  , runGhcMod
+  , runGhcModT'
+  , withErrorHandler
+  -- ** Conversion
+  , liftGhcMod
+  , toGhcModT
+  -- ** Accessing 'GhcModEnv' and 'GhcModState'
+  , options
+  , cradle
+  , getMode
+  , setMode
+  , withOptions
   -- * 'Ghc' Choice
   , (||>)
   , goNext
@@ -40,6 +60,8 @@ import Language.Haskell.GhcMod.CabalApi
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.GHCChoice
 import Language.Haskell.GhcMod.Logger
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Target
 import Language.Haskell.GhcMod.Types
 
 -- | Obtaining the directory for ghc system libraries.

Language/Haskell/GhcMod/Lint.hs

@@ -6,6 +6,7 @@ import CoreMonad (liftIO)
 import Language.Haskell.GhcMod.Logger (checkErrorPrefix)
 import Language.Haskell.GhcMod.Convert
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Types
 import Language.Haskell.HLint (hlint)
 
 -- | Checking syntax of a target file using hlint.
@@ -15,7 +16,7 @@ lint :: IOish m
      -> GhcModT m String
 lint file = do
   opt <- options
-  ghandle handler . pack =<< (liftIO $ hlint $ file : "--quiet" : hlintOpts opt)
+  ghandle handler . pack =<< liftIO (hlint $ file : "--quiet" : hlintOpts opt)
  where
     pack = convert' . map (init . show) -- init drops the last \n.
     handler (SomeException e) = return $ checkErrorPrefix ++ show e ++ "\n"

Language/Haskell/GhcMod/List.hs

@@ -4,8 +4,9 @@ import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
 import Data.List (nub, sort)
 import qualified GHC as G
-import Language.Haskell.GhcMod.Monad
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Types
 import Packages (pkgIdMap, exposedModules, sourcePackageId, display)
 import UniqFM (eltsUFM)
 
@@ -15,7 +16,7 @@ import UniqFM (eltsUFM)
 modules :: IOish m => GhcModT m String
 modules = do
     opt <- options
-    convert opt . (arrange opt) <$> (getModules `G.gcatch` handler)
+    convert opt . arrange opt <$> (getModules `G.gcatch` handler)
   where
     getModules = getExposedModules <$> G.getSessionDynFlags
     getExposedModules = concatMap exposedModules'

Language/Haskell/GhcMod/Logger.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns, CPP #-}
+{-# LANGUAGE CPP #-}
 
 module Language.Haskell.GhcMod.Logger (
     withLogger
@@ -21,6 +21,7 @@ import Language.Haskell.GhcMod.DynFlags (withDynFlags, withCmdFlags)
 import qualified Language.Haskell.GhcMod.Gap as Gap
 import Language.Haskell.GhcMod.Convert (convert')
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.Types
 import Outputable (PprStyle, SDoc)
 import System.FilePath (normalise)
 
@@ -62,9 +63,9 @@ withLogger :: IOish m
            -> GhcModT m ()
            -> GhcModT m (Either String String)
 withLogger setDF body = ghandle sourceError $ do
-    logref <- liftIO $ newLogRef
+    logref <- liftIO newLogRef
     wflags <- filter ("-fno-warn" `isPrefixOf`) . ghcOpts <$> options
-    withDynFlags (setLogger logref . setDF) $ do
+    withDynFlags (setLogger logref . setDF) $
         withCmdFlags wflags $ do
             body
             Right <$> readAndClearLogRef logref
@@ -78,8 +79,8 @@ withLogger setDF body = ghandle sourceError $ do
 sourceError :: IOish m => SourceError -> GhcModT m (Either String String)
 sourceError err = do
     dflags <- G.getSessionDynFlags
-    style <- toGhcMod getStyle
+    style <- toGhcModT getStyle
-    ret <- convert' $ (errBagToStrList dflags style . srcErrorMessages $ err)
+    ret <- convert' (errBagToStrList dflags style . srcErrorMessages $ err)
     return $ Left ret
 
 errBagToStrList :: DynFlags -> PprStyle -> Bag ErrMsg -> [String]

Language/Haskell/GhcMod/Monad.hs

@@ -5,23 +5,32 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Language.Haskell.GhcMod.Monad (
+  -- * Monad Types
     GhcMod
- , runGhcMod
- , liftGhcMod
   , GhcModT
   , IOish
+  -- ** Environment, state and logging
   , GhcModEnv(..)
- , GhcModWriter
- , GhcModState(..)
- , runGhcModT'
- , runGhcModT
   , newGhcModEnv
+  , GhcModState
+  , defaultState
+  , Mode(..)
+  , GhcModWriter
+  -- * Monad utilities
+  , runGhcMod
+  , runGhcModT
+  , runGhcModT'
   , withErrorHandler
- , toGhcMod
+  -- ** Conversion
+  , liftGhcMod
+  , toGhcModT
+  -- ** Accessing 'GhcModEnv' and 'GhcModState'
   , options
   , cradle
- , Options(..)
+  , getMode
- , defaultOptions
+  , setMode
+  , withOptions
+  -- ** Exporting convenient modules
   , module Control.Monad.Reader.Class
   , module Control.Monad.Writer.Class
   , module Control.Monad.State.Class
@@ -97,10 +106,12 @@ data GhcModEnv = GhcModEnv {
     , gmCradle     :: Cradle
     }
 
-data GhcModState = GhcModState deriving (Eq,Show,Read)
+data GhcModState = GhcModState Mode deriving (Eq,Show,Read)
+
+data Mode = Simple | Intelligent deriving (Eq,Show,Read)
 
 defaultState :: GhcModState
-defaultState = GhcModState
+defaultState = GhcModState Simple
 
 type GhcModWriter = ()
 
@@ -188,8 +199,9 @@ initSession :: GhcMonad m
             -> m ()
 initSession build Options {..} CompilerOptions {..} = do
     df <- G.getSessionDynFlags
-    void $ G.setSessionDynFlags =<< (addCmdOpts ghcOptions
+    void $ G.setSessionDynFlags =<< addCmdOpts ghcOptions
-      $ setModeSimple
+      ( setModeSimple
+      $ Gap.setFlags
       $ setIncludeDirs includeDirs
       $ setBuildEnv build
       $ setEmptyLogger
@@ -263,8 +275,8 @@ withErrorHandler label = ghandle ignore
         exitSuccess
 
 -- | This is only a transitional mechanism don't use it for new code.
-toGhcMod :: IOish m => Ghc a -> GhcModT m a
+toGhcModT :: IOish m => Ghc a -> GhcModT m a
-toGhcMod a = do
+toGhcModT a = do
     s <- gmGhcSession <$> ask
     liftIO $ unGhc a $ Session s
 
@@ -276,6 +288,25 @@ options = gmOptions <$> ask
 cradle :: IOish m => GhcModT m Cradle
 cradle = gmCradle <$> ask
 
+getMode :: IOish m => GhcModT m Mode
+getMode = do
+    GhcModState mode <- get
+    return mode
+
+setMode :: IOish m => Mode -> GhcModT m ()
+setMode mode = put $ GhcModState mode
+
+----------------------------------------------------------------
+
+withOptions :: IOish m => (Options -> Options) -> GhcModT m a -> GhcModT m a
+withOptions changeOpt action = local changeEnv action
+  where
+    changeEnv e = e { gmOptions = changeOpt opt }
+      where
+        opt = gmOptions e
+
+----------------------------------------------------------------
+
 instance (MonadBaseControl IO m) => MonadBase IO (GhcModT m) where
     liftBase = GhcModT . liftBase
 

Language/Haskell/GhcMod/SrcUtils.hs

@@ -9,17 +9,19 @@ import Data.Generics
 import Data.Maybe (fromMaybe)
 import Data.Ord as O
 import GHC (LHsExpr, LPat, Id, DynFlags, SrcSpan, Type, Located, ParsedSource, RenamedSource, TypecheckedSource, GenLocated(L))
-import GhcMonad
 import qualified GHC as G
 import GHC.SYB.Utils (Stage(..), everythingStaged)
+import GhcMonad
+import qualified Language.Haskell.Exts.Annotated as HE
 import Language.Haskell.GhcMod.Doc (showOneLine, getStyle)
 import Language.Haskell.GhcMod.DynFlags
 import Language.Haskell.GhcMod.Gap (HasType(..), setWarnTypedHoles, setDeferTypeErrors)
 import qualified Language.Haskell.GhcMod.Gap as Gap
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
+import Language.Haskell.GhcMod.Target (setTargetFiles)
+import OccName (OccName)
 import Outputable (PprStyle)
 import TcHsSyn (hsPatType)
-import OccName (OccName)
-import qualified Language.Haskell.Exts.Annotated as HE
 
 ----------------------------------------------------------------
 
@@ -79,7 +81,7 @@ pretty dflag style = showOneLine dflag style . Gap.typeForUser
 
 ----------------------------------------------------------------
 
-inModuleContext ::GhcMonad m => FilePath -> (DynFlags -> PprStyle -> m a) -> m a
+inModuleContext :: IOish m => FilePath -> (DynFlags -> PprStyle -> GhcModT m a) -> GhcModT m a
 inModuleContext file action =
     withDynFlags (setWarnTypedHoles . setDeferTypeErrors . setNoWaringFlags) $ do
     setTargetFiles [file]

Language/Haskell/GhcMod/Target.hs

@@ -0,0 +1,39 @@
+module Language.Haskell.GhcMod.Target (
+    setTargetFiles
+  ) where
+
+import Control.Applicative ((<$>))
+import Control.Monad (forM, void, (>=>))
+import DynFlags (ExtensionFlag(..), xopt)
+import GHC (DynFlags(..), LoadHowMuch(..))
+import qualified GHC as G
+import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
+
+-- | Set the files as targets and load them.
+setTargetFiles :: IOish m => [FilePath] -> GhcModT m ()
+setTargetFiles files = do
+    targets <- forM files $ \file -> G.guessTarget file Nothing
+    G.setTargets targets
+    xs <- G.depanal [] False
+    -- FIXME, checking state
+    loadTargets $ needsFallback xs
+  where
+    loadTargets False = do
+        -- Reporting error A and error B
+        void $ G.load LoadAllTargets
+        mss <- filter (\x -> G.ms_hspp_file x `elem` files) <$> G.getModuleGraph
+        -- Reporting error B and error C
+        mapM_ (G.parseModule >=> G.typecheckModule >=> G.desugarModule) mss
+        -- Error B duplicates. But we cannot ignore both error reportings,
+        -- sigh. So, the logger makes log messages unique by itself.
+    loadTargets True = do
+        df <- G.getSessionDynFlags
+        void $ G.setSessionDynFlags (setModeIntelligent df)
+        void $ G.load LoadAllTargets
+
+needsFallback :: G.ModuleGraph -> Bool
+needsFallback = any (hasTHorQQ . G.ms_hspp_opts)
+  where
+    hasTHorQQ :: DynFlags -> Bool
+    hasTHorQQ dflags = any (`xopt` dflags) [Opt_TemplateHaskell, Opt_QuasiQuotes]

Language/Haskell/GhcMod/Utils.hs

@@ -1,5 +1,6 @@
 module Language.Haskell.GhcMod.Utils where
 
+import MonadUtils (MonadIO, liftIO)
 import Control.Exception (bracket)
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import System.Process (readProcessWithExitCode)
@@ -18,16 +19,16 @@ extractParens str = extractParens' str 0
    extractParens' (s:ss) level
        | s `elem` "([{" = s : extractParens' ss (level+1)
        | level == 0 = extractParens' ss 0
-       | s `elem` "}])" && level == 1 = s:[]
+       | s `elem` "}])" && level == 1 = [s]
        | s `elem` "}])" = s : extractParens' ss (level-1)
        | otherwise = s : extractParens' ss level
 
-readProcess' :: String -> [String] -> IO String
+readProcess' :: MonadIO m => String -> [String] -> m String
 readProcess' cmd opts = do
-  (rv,output,err) <- readProcessWithExitCode cmd opts ""
+  (rv,output,err) <- liftIO $ readProcessWithExitCode cmd opts ""
   case rv of
     ExitFailure val -> do
-        hPutStrLn stderr err
+        liftIO $ hPutStrLn stderr err
         fail $ cmd ++ " " ++ unwords opts ++ " (exit " ++ show val ++ ")"
     ExitSuccess ->
         return output

ghc-mod.cabal

@@ -53,19 +53,17 @@ Library
   GHC-Options:          -Wall
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   Exposed-Modules:      Language.Haskell.GhcMod
-                        Language.Haskell.GhcMod.Ghc
-                        Language.Haskell.GhcMod.Monad
                         Language.Haskell.GhcMod.Internal
   Other-Modules:        Language.Haskell.GhcMod.Boot
                         Language.Haskell.GhcMod.Browse
-                        Language.Haskell.GhcMod.CabalApi
-                        Language.Haskell.GhcMod.CabalConfig
                         Language.Haskell.GhcMod.Cabal16
                         Language.Haskell.GhcMod.Cabal18
+                        Language.Haskell.GhcMod.CabalApi
+                        Language.Haskell.GhcMod.CabalConfig
                         Language.Haskell.GhcMod.CaseSplit
                         Language.Haskell.GhcMod.Check
-                        Language.Haskell.GhcMod.Cradle
                         Language.Haskell.GhcMod.Convert
+                        Language.Haskell.GhcMod.Cradle
                         Language.Haskell.GhcMod.Debug
                         Language.Haskell.GhcMod.Doc
                         Language.Haskell.GhcMod.DynFlags
@@ -76,16 +74,18 @@ Library
                         Language.Haskell.GhcMod.GHCChoice
                         Language.Haskell.GhcMod.Gap
                         Language.Haskell.GhcMod.GhcPkg
-                        Language.Haskell.GhcMod.Logger
                         Language.Haskell.GhcMod.Info
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
                         Language.Haskell.GhcMod.List
+                        Language.Haskell.GhcMod.Logger
+                        Language.Haskell.GhcMod.Monad
                         Language.Haskell.GhcMod.PkgDoc
-                        Language.Haskell.GhcMod.Utils
-                        Language.Haskell.GhcMod.Types
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
+                        Language.Haskell.GhcMod.Target
+                        Language.Haskell.GhcMod.Types
+                        Language.Haskell.GhcMod.Utils
   Build-Depends:        base >= 4.0 && < 5
                       , containers
                       , deepseq
@@ -198,6 +198,7 @@ Test-Suite spec
     Build-Depends:      Cabal >= 1.18
   if impl(ghc < 7.6.0)
     Build-Depends:      executable-path
+  CPP-Options:        -DSPEC=1
 
 Source-Repository head
   Type:                 git

src/GHCMod.hs

@@ -10,8 +10,6 @@ import qualified Control.Exception as E
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
 import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Ghc
-import Language.Haskell.GhcMod.Monad
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O

src/GHCModi.hs

@@ -31,11 +31,8 @@ import Data.Set (Set)
 import qualified Data.Set as S
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
-import GHC (GhcMonad)
 import qualified GHC as G
 import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Ghc
-import Language.Haskell.GhcMod.Monad
 import Paths_ghc_mod
 import System.Console.GetOpt
 import System.Directory (setCurrentDirectory)
@@ -116,7 +113,7 @@ replace (x:xs)    =  x  : replace xs
 ----------------------------------------------------------------
 
 setupDB :: MVar SymbolDb -> IO ()
-setupDB mvar = getSymbolDb >>= putMVar mvar
+setupDB mvar = loadSymbolDb >>= putMVar mvar
 
 ----------------------------------------------------------------
 
@@ -154,14 +151,14 @@ checkStx :: IOish m
          -> FilePath
          -> GhcModT m (String, Bool, Set FilePath)
 checkStx set file = do
-    set' <- toGhcMod $ newFileSet set file
+    set' <- newFileSet set file
     let files = S.toList set'
     eret <- check files
     case eret of
         Right ret -> return (ret, True, set')
         Left ret  -> return (ret, True, set) -- fxime: set
 
-newFileSet :: GhcMonad m => Set FilePath -> FilePath -> m (Set FilePath)
+newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath)
 newFileSet set file = do
     let set1
          | S.member file set = set
@@ -171,7 +168,7 @@ newFileSet set file = do
         Nothing       -> set1
         Just mainfile -> S.delete mainfile set1
 
-getModSummaryForMain :: GhcMonad m => m (Maybe G.ModSummary)
+getModSummaryForMain :: IOish m => GhcModT m (Maybe G.ModSummary)
 getModSummaryForMain = find isMain <$> G.getModuleGraph
   where
     isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main"
@@ -193,21 +190,19 @@ findSym :: IOish m => Set FilePath -> String -> MVar SymbolDb
         -> GhcModT m (String, Bool, Set FilePath)
 findSym set sym mvar = do
     db <- liftIO $ readMVar mvar
-    opt <- options
+    ret <- lookupSymbol sym db
-    let ret = lookupSymbol opt sym db
     return (ret, True, set)
 
 lintStx :: IOish m => Set FilePath
         -> FilePath
         -> GhcModT m (String, Bool, Set FilePath)
 lintStx set optFile = do
-    ret <- local env' $ lint file
+    ret <- withOptions changeOpt $ lint file
     return (ret, True, set)
   where
     (opts,file) = parseLintOptions optFile
     hopts = if opts == "" then [] else read opts
-    env' e = e { gmOptions = opt' $ gmOptions e }
+    changeOpt o = o { hlintOpts = hopts }
-    opt' o = o { hlintOpts = hopts }
 
 -- |
 -- >>> parseLintOptions "[\"--ignore=Use camelCase\", \"--ignore=Eta reduce\"] file name"

test/CheckSpec.hs

@@ -2,7 +2,6 @@ module CheckSpec where
 
 import Data.List (isSuffixOf, isInfixOf, isPrefixOf)
 import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Cradle
 import System.FilePath
 import Test.Hspec
 

test/FindSpec.hs

@@ -0,0 +1,16 @@
+module FindSpec where
+
+import Control.Applicative ((<$>))
+import Data.List (isPrefixOf)
+import Language.Haskell.GhcMod.Find
+import Test.Hspec
+import TestUtils
+
+import qualified Data.Map
+
+spec :: Spec
+spec = do
+    describe "db <- loadSymbolDb" $ do
+        it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do
+            db <- loadSymbolDb
+            lookupSym "head" db `shouldContain` ["Data.List"]

test/InfoSpec.hs

@@ -4,7 +4,6 @@ module InfoSpec where
 import Control.Applicative ((<$>))
 import Data.List (isPrefixOf)
 import Language.Haskell.GhcMod
-import Language.Haskell.GhcMod.Cradle
 #if __GLASGOW_HASKELL__ < 706
 import System.Environment.Executable (getExecutablePath)
 #else
@@ -22,38 +21,32 @@ spec = do
     describe "types" $ do
         it "shows types of the expression and its outers" $ do
             withDirectory_ "test/data/ghc-mod-check" $ do
-                cradle <- findCradleWithoutSandbox
                 res <- runD $ types "Data/Foo.hs" 9 5
                 res `shouldBe` "9 5 11 40 \"Int -> a -> a -> a\"\n7 1 11 40 \"Int -> Integer\"\n"
 
         it "works with a module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
                 res <- runD $ types "Bar.hs" 5 1
                 res `shouldBe` unlines ["5 1 5 20 \"[Char]\""]
 
         it "works with a module that imports another module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
                 res <- runD $ types "Main.hs" 3 8
                 res `shouldBe` unlines ["3 8 3 16 \"String -> IO ()\"", "3 8 3 20 \"IO ()\"", "3 1 3 20 \"IO ()\""]
 
     describe "info" $ do
         it "works for non-export functions" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
                 res <- runD $ info "Info.hs" "fib"
                 res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
 
         it "works with a module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
                 res <- runD $ info "Bar.hs" "foo"
                 res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
 
         it "works with a module that imports another module using TemplateHaskell" $ do
             withDirectory_ "test/data" $ do
-                cradle <- findCradleWithoutSandbox
                 res <- runD $ info "Main.hs" "bar"
                 res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)