Merge branch 'master' into release

Language/Haskell/GhcMod.hs

@@ -46,6 +46,7 @@ module Language.Haskell.GhcMod (
   , dumpSymbol
   -- * SymbolDb
   , loadSymbolDb
+  , isOutdated
   ) where
 
 import Language.Haskell.GhcMod.Boot

Language/Haskell/GhcMod/CabalApi.hs

@@ -31,7 +31,7 @@ import qualified Distribution.PackageDescription as P
 import Distribution.PackageDescription.Configuration (finalizePackageDescription)
 import Distribution.PackageDescription.Parse (readPackageDescription)
 import Distribution.Simple.Compiler (CompilerId(..), CompilerFlavor(..))
-import Distribution.Simple.Program (ghcProgram)
+import Distribution.Simple.Program as C (ghcProgram)
 import Distribution.Simple.Program.Types (programName, programFindVersion)
 import Distribution.System (buildPlatform)
 import Distribution.Text (display)
@@ -155,7 +155,7 @@ getGHCId = CompilerId GHC <$> getGHC
 
 getGHC :: IO Version
 getGHC = do
-    mv <- programFindVersion ghcProgram silent (programName ghcProgram)
+    mv <- programFindVersion C.ghcProgram silent (programName C.ghcProgram)
     case mv of
       -- TODO: MonadError it up
         Nothing -> E.throwIO $ userError "ghc not found"

Language/Haskell/GhcMod/CabalConfig.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE RecordWildCards, CPP #-}
 
 -- | This module facilitates extracting information from Cabal's on-disk
 -- 'LocalBuildInfo' (@dist/setup-config@).
@@ -6,13 +6,17 @@ module Language.Haskell.GhcMod.CabalConfig (
     CabalConfig
   , cabalConfigDependencies
   , cabalConfigFlags
+  , setupConfigFile
+  , World
+  , getCurrentWorld
+  , isWorldChanged
   ) where
 
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.GhcPkg
-import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Read
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
 
 import qualified Language.Haskell.GhcMod.Cabal16 as C16
 import qualified Language.Haskell.GhcMod.Cabal18 as C18
@@ -23,7 +27,7 @@ import qualified Language.Haskell.GhcMod.Cabal21 as C21
 #endif
 
 import Control.Applicative ((<$>))
-import Control.Monad (mplus)
+import Control.Monad (unless, void, mplus)
 #if MIN_VERSION_mtl(2,2,1)
 import Control.Monad.Except ()
 #else
@@ -39,9 +43,17 @@ import Distribution.PackageDescription (FlagAssignment)
 import Distribution.Simple.BuildPaths (defaultDistPref)
 import Distribution.Simple.Configure (localBuildInfoFile)
 import Distribution.Simple.LocalBuildInfo (ComponentName)
+import Data.Traversable (traverse)
 import MonadUtils (liftIO)
+import System.Directory (doesFileExist, getModificationTime)
 import System.FilePath ((</>))
 
+#if __GLASGOW_HASKELL__ <= 704
+import System.Time (ClockTime)
+#else
+import Data.Time (UTCTime)
+#endif
+
 ----------------------------------------------------------------
 
 -- | 'Show'ed cabal 'LocalBuildInfo' string
@@ -53,20 +65,26 @@ type CabalConfig = String
 getConfig :: (IOish m, MonadError GhcModError m)
           => Cradle
           -> m CabalConfig
-getConfig cradle = liftIO (readFile path) `tryFix` \_ ->
+getConfig cradle = do
+    world <- liftIO $ getCurrentWorld cradle
+    let valid = isSetupConfigValid world
+    unless valid configure
+    liftIO (readFile file) `tryFix` \_ ->
         configure `modifyError'` GMECabalConfigure
  where
+   file = setupConfigFile cradle
    prjDir = cradleRootDir cradle
-   path = prjDir </> configPath
 
    configure :: (IOish m, MonadError GhcModError m) => m ()
-   configure =
+   configure = withDirectory_ prjDir $ void $ readProcess' "cabal" ["configure"]
-       withDirectory_ prjDir $ readProcess' "cabal" ["configure"] >> return ()
 
 
+setupConfigFile :: Cradle -> FilePath
+setupConfigFile crdl = cradleRootDir crdl </> setupConfigPath
+
 -- | Path to 'LocalBuildInfo' file, usually @dist/setup-config@
-configPath :: FilePath
+setupConfigPath :: FilePath
-configPath = localBuildInfoFile defaultDistPref
+setupConfigPath = localBuildInfoFile defaultDistPref
 
 -- | Get list of 'Package's needed by all components of the current package
 cabalConfigDependencies :: (IOish m, MonadError GhcModError m)
@@ -175,3 +193,57 @@ extractField config field =
     case extractParens <$> find (field `isPrefixOf`) (tails config) of
         Just f -> Right f
         Nothing -> Left $ "extractField: failed extracting "++field++" from input, input contained `"++field++"'? " ++ show (field `isInfixOf` config)
+
+----------------------------------------------------------------
+
+#if __GLASGOW_HASKELL__ <= 704
+type ModTime = ClockTime
+#else
+type ModTime = UTCTime
+#endif
+
+data World = World {
+    worldCabalFile :: Maybe FilePath
+  , worldCabalFileModificationTime :: Maybe ModTime
+  , worldPackageCache :: FilePath
+  , worldPackageCacheModificationTime :: ModTime
+  , worldSetupConfig :: FilePath
+  , worldSetupConfigModificationTime :: Maybe ModTime
+  } deriving (Show, Eq)
+
+getCurrentWorld :: Cradle -> IO World
+getCurrentWorld crdl = do
+    cachePath <- getPackageCachePath crdl
+    let mCabalFile = cradleCabalFile crdl
+        pkgCache = cachePath </> packageCache
+        setupFile = setupConfigFile crdl
+    mCabalFileMTime <- getModificationTime `traverse` mCabalFile
+    pkgCacheMTime <- getModificationTime pkgCache
+    exist <- doesFileExist setupFile
+    mSeetupMTime <- if exist then
+                        Just <$> getModificationTime setupFile
+                      else
+                        return Nothing
+    return $ World {
+        worldCabalFile = mCabalFile
+      , worldCabalFileModificationTime = mCabalFileMTime
+      , worldPackageCache = pkgCache
+      , worldPackageCacheModificationTime = pkgCacheMTime
+      , worldSetupConfig = setupFile
+      , worldSetupConfigModificationTime = mSeetupMTime
+      }
+
+isWorldChanged :: World -> Cradle -> IO Bool
+isWorldChanged world crdl = do
+    world' <- getCurrentWorld crdl
+    return (world /= world')
+
+isSetupConfigValid :: World -> Bool
+isSetupConfigValid World{ worldSetupConfigModificationTime = Nothing, ..} = False
+isSetupConfigValid World{ worldSetupConfigModificationTime = Just mt, ..} =
+    cond1 && cond2
+  where
+    cond1 = case worldCabalFileModificationTime of
+        Nothing -> True
+        Just mtime -> mtime <= mt
+    cond2 = worldPackageCacheModificationTime <= mt

Language/Haskell/GhcMod/Check.hs

@@ -8,9 +8,8 @@ module Language.Haskell.GhcMod.Check (
 import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.DynFlags
 import qualified Language.Haskell.GhcMod.Gap as Gap
-import qualified GHC as G
 import Language.Haskell.GhcMod.Logger
-import Language.Haskell.GhcMod.Monad (IOish, GhcModT, overrideGhcUserOptions)
+import Language.Haskell.GhcMod.Monad (IOish, GhcModT)
 import Language.Haskell.GhcMod.Target (setTargetFiles)
 
 ----------------------------------------------------------------
@@ -30,10 +29,15 @@ checkSyntax files = either id id <$> check files
 check :: IOish m
       => [FilePath]  -- ^ The target files.
       -> GhcModT m (Either String String)
+{-
 check fileNames = overrideGhcUserOptions $ \ghcOpts -> do
   withLogger (setAllWarningFlags . setNoMaxRelevantBindings . Gap.setWarnTypedHoles . Gap.setDeferTypeErrors) $ do
     _ <- G.setSessionDynFlags =<< addCmdOpts ghcOpts =<< G.getSessionDynFlags
     setTargetFiles fileNames
+-}
+check fileNames =
+  withLogger (setAllWarningFlags . setNoMaxRelevantBindings) $
+    setTargetFiles fileNames
 
 ----------------------------------------------------------------
 

Language/Haskell/GhcMod/Error.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
 module Language.Haskell.GhcMod.Error (
     GhcModError(..)
+  , gmeDoc
   , modifyError
   , modifyError'
   , tryFix
@@ -10,6 +11,7 @@ module Language.Haskell.GhcMod.Error (
 
 import Control.Monad.Error (MonadError(..), Error(..))
 import Exception
+import Text.PrettyPrint
 
 data GhcModError = GMENoMsg
                  -- ^ Unknown error
@@ -29,6 +31,20 @@ instance Error GhcModError where
     noMsg = GMENoMsg
     strMsg = GMEString
 
+gmeDoc :: GhcModError -> Doc
+gmeDoc e = case e of
+    GMENoMsg ->
+        text "Unknown error"
+    GMEString msg ->
+        text msg
+    GMECabalConfigure msg ->
+        text "cabal configure failed: " <> gmeDoc msg
+    GMECabalFlags msg ->
+        text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg
+    GMEProcess cmd msg ->
+        text ("launching operating system process `"++unwords cmd++"` failed: ")
+          <> gmeDoc msg
+
 modifyError :: MonadError e m => (e -> e) -> m a -> m a
 modifyError f action = action `catchError` \e -> throwError $ f e
 

Language/Haskell/GhcMod/Find.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, BangPatterns #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
@@ -10,30 +10,27 @@ module Language.Haskell.GhcMod.Find
   , dumpSymbol
   , findSymbol
   , lookupSym
+  , isOutdated
   )
 #endif
   where
 
-import Config (cProjectVersion,cTargetPlatformString)
 import Control.Applicative ((<$>))
 import Control.Monad (when, void)
 import Control.Monad.Error.Class
 import Data.Function (on)
 import Data.List (groupBy, sort)
-import Data.List.Split (splitOn)
 import Data.Maybe (fromMaybe)
-import DynFlags (DynFlags(..), systemPackageConfig)
-import Exception (handleIO)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.GhcPkg
 import Language.Haskell.GhcMod.Monad
-import Language.Haskell.GhcMod.Utils
 import Language.Haskell.GhcMod.Types
+import Language.Haskell.GhcMod.Utils
 import Name (getOccString)
-import System.Directory (doesDirectoryExist, getAppUserDataDirectory, doesFileExist, getModificationTime)
+import System.Directory (doesFileExist, getModificationTime)
 import System.FilePath ((</>), takeDirectory)
 import System.IO
-import System.Environment
 
 #ifndef MIN_VERSION_containers
 #define MIN_VERSION_containers(x,y,z) 1
@@ -52,8 +49,14 @@ import qualified Data.Map as M
 -- | Type of function and operation names.
 type Symbol = String
 -- | Database from 'Symbol' to \['ModuleString'\].
-newtype SymbolDb = SymbolDb (Map Symbol [ModuleString])
+data SymbolDb = SymbolDb {
-    deriving (Show)
+    table :: Map Symbol [ModuleString]
+  , packageCachePath :: FilePath
+  , symbolDbCachePath :: FilePath
+  } deriving (Show)
+
+isOutdated :: SymbolDb -> IO Bool
+isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
 
 ----------------------------------------------------------------
 
@@ -66,12 +69,6 @@ symbolCacheVersion = 0
 symbolCache :: String
 symbolCache = "ghc-mod-"++ show symbolCacheVersion ++".cache"
 
-packageCache :: String
-packageCache = "package.cache"
-
-packageConfDir :: String
-packageConfDir = "package.conf.d"
-
 ----------------------------------------------------------------
 
 -- | Looking up 'SymbolDb' with 'Symbol' to \['ModuleString'\]
@@ -85,39 +82,21 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
 lookupSymbol sym db = convert' $ lookupSym sym db
 
 lookupSym :: Symbol -> SymbolDb -> [ModuleString]
-lookupSym sym (SymbolDb db) = fromMaybe [] $ M.lookup sym db
+lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
 
 ---------------------------------------------------------------
 
 -- | Loading a file and creates 'SymbolDb'.
 loadSymbolDb :: (IOish m, MonadError GhcModError m) => m SymbolDb
-loadSymbolDb = SymbolDb <$> readSymbolDb
+loadSymbolDb = do
-
--- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
--- this is a guess but >=7.6 uses 'getExecutablePath'.
-ghcModExecutable :: IO FilePath
-#ifndef SPEC
-ghcModExecutable = do
-    dir <- getExecutablePath'
-    return $ dir </> "ghc-mod"
-#else
-ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
-                                              -- compiling spec
-                      return "dist/build/ghc-mod/ghc-mod"
-#endif
- where
-    getExecutablePath' :: IO FilePath
-# if __GLASGOW_HASKELL__ >= 706
-    getExecutablePath' = takeDirectory <$> getExecutablePath
-# else
-    getExecutablePath' = return ""
-# endif
-
-readSymbolDb :: (IOish m, MonadError GhcModError m) => m (Map Symbol [ModuleString])
-readSymbolDb = do
     ghcMod <- liftIO ghcModExecutable
     file <- chop <$> readProcess' ghcMod ["dumpsym"]
-    M.fromAscList . map conv . lines <$> liftIO (readFile file)
+    !db <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
+    return $ SymbolDb {
+        table = db
+      , packageCachePath = takeDirectory file </> packageCache
+      , symbolDbCachePath = file
+      }
   where
     conv :: String -> (Symbol,[ModuleString])
     conv = read
@@ -127,24 +106,18 @@ readSymbolDb = do
 ----------------------------------------------------------------
 -- used 'ghc-mod dumpsym'
 
-getSymbolCachePath :: IOish m => GhcModT m FilePath
-getSymbolCachePath = do
-    u:_ <- filter (/= GlobalDb) . cradlePkgDbStack <$> cradle
-    Just db <- (liftIO . flip resolvePackageDb u) =<< G.getSessionDynFlags
-    return db
-  `catchError` const (fail "Couldn't find non-global package database for symbol cache")
-
 -- | 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
-    dir <- getSymbolCachePath
+    crdl <- cradle
+    dir <- liftIO $ getPackageCachePath crdl
     let cache = dir </> symbolCache
         pkgdb = dir </> packageCache
 
-    create <- liftIO $ cache `isNewerThan` pkgdb
+    create <- liftIO $ cache `isOlderThan` pkgdb
     when create $ (liftIO . writeSymbolCache cache) =<< getSymbolTable
     return $ unlines [cache]
 
@@ -155,15 +128,15 @@ writeSymbolCache cache sm =
   void . withFile cache WriteMode $ \hdl ->
       mapM (hPrint hdl) sm
 
-isNewerThan :: FilePath -> FilePath -> IO Bool
+isOlderThan :: FilePath -> FilePath -> IO Bool
-isNewerThan ref file = do
+isOlderThan cache file = do
-    exist <- doesFileExist ref
+    exist <- doesFileExist cache
     if not exist then
         return True
       else do
-        tRef <- getModificationTime ref
+        tCache <- getModificationTime cache
         tFile <- getModificationTime file
-        return $ tRef <= tFile -- including equal just in case
+        return $ tCache <= tFile -- including equal just in case
 
 -- | Browsing all functions in all system/user modules.
 getSymbolTable :: IOish m => GhcModT m [(Symbol,[ModuleString])]
@@ -192,16 +165,3 @@ collectModules :: [(Symbol,ModuleString)]
 collectModules = map tieup . groupBy ((==) `on` fst) . sort
   where
     tieup x = (head (map fst x), map snd x)
-
---- Copied from ghc module `Packages' unfortunately it's not exported :/
-resolvePackageDb :: DynFlags -> GhcPkgDb -> IO (Maybe FilePath)
-resolvePackageDb df GlobalDb         = return $ Just (systemPackageConfig df)
-resolvePackageDb _  (PackageDb name) = return $ Just name
-resolvePackageDb _  UserDb           = handleIO (\_ -> return Nothing) $ do
-    appdir <- getAppUserDataDirectory "ghc"
-    let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
-        pkgconf = dir </> packageConfDir
-    exist <- doesDirectoryExist pkgconf
-    return $ if exist then Just pkgconf else Nothing
-  where
-    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString

Language/Haskell/GhcMod/GhcPkg.hs

@@ -8,9 +8,12 @@ module Language.Haskell.GhcMod.GhcPkg (
   , fromInstalledPackageId'
   , getSandboxDb
   , getPackageDbStack
+  , getPackageCachePath
+  , packageCache
+  , packageConfDir
   ) where
 
-import Config (cProjectVersionInt)
+import Config (cProjectVersion, cTargetPlatformString, cProjectVersionInt)
 import Control.Applicative ((<$>))
 import Control.Exception (SomeException(..))
 import qualified Control.Exception as E
@@ -18,8 +21,10 @@ import Data.Char (isSpace)
 import Data.List (isPrefixOf, intercalate)
 import Data.List.Split (splitOn)
 import Distribution.Package (InstalledPackageId(..))
+import Exception (handleIO)
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
+import System.Directory (doesDirectoryExist, getAppUserDataDirectory)
 import System.FilePath ((</>))
 
 ghcVersion :: Int
@@ -46,6 +51,8 @@ getSandboxDbDir sconf = do
     parse = head . filter (key `isPrefixOf`) . lines
     extractValue = dropWhileEnd isSpace . dropWhile isSpace . drop keyLen
 
+----------------------------------------------------------------
+
 getPackageDbStack :: FilePath -- ^ Project Directory (where the
                                  -- cabal.sandbox.config file would be if it
                                  -- exists)
@@ -54,6 +61,8 @@ getPackageDbStack cdir =
     (getSandboxDb cdir >>= \db -> return [GlobalDb, PackageDb db])
       `E.catch` \(_ :: SomeException) -> return [GlobalDb, UserDb]
 
+----------------------------------------------------------------
+
 fromInstalledPackageId' :: InstalledPackageId -> Maybe Package
 fromInstalledPackageId' pid = let
     InstalledPackageId pkg = pid
@@ -68,6 +77,8 @@ fromInstalledPackageId pid =
       Nothing -> error $
         "fromInstalledPackageId: `"++show pid++"' is not a valid package-id"
 
+----------------------------------------------------------------
+
 -- | Get options needed to add a list of package dbs to ghc-pkg's db stack
 ghcPkgDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
                   -> [String]
@@ -78,6 +89,8 @@ ghcDbStackOpts :: [GhcPkgDb] -- ^ Package db stack
                -> [String]
 ghcDbStackOpts dbs = ghcDbOpt `concatMap` dbs
 
+----------------------------------------------------------------
+
 ghcPkgDbOpt :: GhcPkgDb -> [String]
 ghcPkgDbOpt GlobalDb = ["--global"]
 ghcPkgDbOpt UserDb   = ["--user"]
@@ -95,3 +108,31 @@ ghcDbOpt UserDb
 ghcDbOpt (PackageDb pkgDb)
   | ghcVersion < 706 = ["-no-user-package-conf", "-package-conf", pkgDb]
   | otherwise        = ["-no-user-package-db",   "-package-db",   pkgDb]
+
+----------------------------------------------------------------
+
+packageCache :: String
+packageCache = "package.cache"
+
+packageConfDir :: String
+packageConfDir = "package.conf.d"
+
+-- fixme: error handling
+getPackageCachePath :: Cradle -> IO FilePath
+getPackageCachePath crdl = do
+    let u:_ = filter (/= GlobalDb) $ cradlePkgDbStack crdl
+    Just db <- resolvePath u
+    return db
+
+--- Copied from ghc module `Packages' unfortunately it's not exported :/
+resolvePath :: GhcPkgDb -> IO (Maybe FilePath)
+resolvePath (PackageDb name) = return $ Just name
+resolvePath UserDb           = handleIO (\_ -> return Nothing) $ do
+    appdir <- getAppUserDataDirectory "ghc"
+    let dir = appdir </> (target_arch ++ '-':target_os ++ '-':cProjectVersion)
+        pkgconf = dir </> packageConfDir
+    exist <- doesDirectoryExist pkgconf
+    return $ if exist then Just pkgconf else Nothing
+  where
+    [target_arch,_,target_os] = splitOn "-" cTargetPlatformString
+resolvePath _ = error "GlobalDb cannot be used in resolvePath"

Language/Haskell/GhcMod/Internal.hs

@@ -16,8 +16,9 @@ module Language.Haskell.GhcMod.Internal (
   , cabalDependPackages
   , cabalSourceDirs
   , cabalAllTargets
-  -- * GHC.Paths
+  -- * Various Paths
   , ghcLibDir
+  , ghcModExecutable
   -- * IO
   , getDynamicFlags
   -- * Targets
@@ -42,21 +43,30 @@ module Language.Haskell.GhcMod.Internal (
   , getCompilerMode
   , setCompilerMode
   , withOptions
+  -- * 'GhcModError'
+  , gmeDoc
   -- * 'GhcMonad' Choice
   , (||>)
   , goNext
   , runAnyOne
+  -- * World
+  , World
+  , getCurrentWorld
+  , isWorldChanged
   ) where
 
 import GHC.Paths (libdir)
 
 import Language.Haskell.GhcMod.CabalApi
+import Language.Haskell.GhcMod.CabalConfig
 import Language.Haskell.GhcMod.DynFlags
+import Language.Haskell.GhcMod.Error
 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
+import Language.Haskell.GhcMod.Utils
 
 -- | Obtaining the directory for ghc system libraries.
 ghcLibDir :: FilePath

Language/Haskell/GhcMod/Monad.hs

@@ -200,11 +200,11 @@ initializeFlagsWithCradle opt c
   | cabal     = withCabal
   | otherwise = withSandbox
   where
-    mCradleFile = cradleCabalFile c
+    mCabalFile = cradleCabalFile c
-    cabal = isJust mCradleFile
+    cabal = isJust mCabalFile
     ghcopts = ghcUserOptions opt
     withCabal = do
-        pkgDesc <- parseCabalFile c $ fromJust mCradleFile
+        pkgDesc <- parseCabalFile c $ fromJust mCabalFile
         compOpts <- getCompilerOptions ghcopts c pkgDesc
         initSession CabalPkg opt compOpts
     withSandbox = initSession SingleFile opt compOpts

Language/Haskell/GhcMod/Types.hs

@@ -25,7 +25,12 @@ newtype LineSeparator = LineSeparator String
 
 data Options = Options {
     outputStyle   :: OutputStyle
-  , hlintOpts     :: [String]
+  -- | Line separator string.
+  , lineSeparator :: LineSeparator
+  -- | @ghc@ program name.
+  , ghcProgram    :: FilePath
+  -- | @cabal@ program name.
+  , cabalProgram  :: FilePath
     -- | GHC command line options set on the @ghc-mod@ command line
   , ghcUserOptions:: [GHCOption]
   -- | If 'True', 'browse' also returns operators.
@@ -34,15 +39,17 @@ data Options = Options {
   , detailed      :: Bool
   -- | If 'True', 'browse' will return fully qualified name
   , qualified     :: Bool
-  -- | Line separator string.
+  , hlintOpts     :: [String]
-  , lineSeparator :: LineSeparator
   }
 
+
 -- | A default 'Options'.
 defaultOptions :: Options
 defaultOptions = Options {
     outputStyle   = PlainStyle
   , hlintOpts     = []
+  , ghcProgram    = "ghc"
+  , cabalProgram  = "cabal"
   , ghcUserOptions= []
   , operators     = False
   , detailed      = False

Language/Haskell/GhcMod/Utils.hs

@@ -1,11 +1,17 @@
+{-# LANGUAGE CPP #-}
 module Language.Haskell.GhcMod.Utils where
 
-
+import Control.Applicative ((<$>))
 import Language.Haskell.GhcMod.Error
 import MonadUtils (MonadIO, liftIO)
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import System.Exit (ExitCode(..))
 import System.Process (readProcessWithExitCode)
+import System.FilePath (takeDirectory)
+import System.Environment
+#ifndef SPEC
+import System.FilePath ((</>))
+#endif
 
 -- dropWhileEnd is not provided prior to base 4.5.0.0.
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
@@ -42,3 +48,23 @@ withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
 withDirectory_ dir action =
     gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
                 (\_ -> liftIO (setCurrentDirectory dir) >> action)
+
+-- | Returns the path to the currently running ghc-mod executable. With ghc<7.6
+-- this is a guess but >=7.6 uses 'getExecutablePath'.
+ghcModExecutable :: IO FilePath
+#ifndef SPEC
+ghcModExecutable = do
+    dir <- getExecutablePath'
+    return $ dir </> "ghc-mod"
+#else
+ghcModExecutable = do _ <- getExecutablePath' -- get rid of unused warning when
+                                              -- compiling spec
+                      return "dist/build/ghc-mod/ghc-mod"
+#endif
+ where
+    getExecutablePath' :: IO FilePath
+# if __GLASGOW_HASKELL__ >= 706
+    getExecutablePath' = takeDirectory <$> getExecutablePath
+# else
+    getExecutablePath' = return ""
+# endif

ghc-mod.cabal

@@ -86,8 +86,8 @@ Library
                         Language.Haskell.GhcMod.Lang
                         Language.Haskell.GhcMod.Lint
                         Language.Haskell.GhcMod.Logger
-                        Language.Haskell.GhcMod.Monad
                         Language.Haskell.GhcMod.Modules
+                        Language.Haskell.GhcMod.Monad
                         Language.Haskell.GhcMod.PkgDoc
                         Language.Haskell.GhcMod.Read
                         Language.Haskell.GhcMod.SrcUtils
@@ -106,6 +106,7 @@ Library
                       , io-choice
                       , monad-journal >= 0.4
                       , old-time
+                      , pretty
                       , process
                       , syb
                       , time
@@ -134,8 +135,11 @@ Executable ghc-mod
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
+                      , data-default
                       , directory
                       , filepath
+                      , pretty
+                      , process
                       , mtl >= 2.0
                       , ghc
                       , ghc-mod
@@ -144,8 +148,11 @@ Executable ghc-modi
   Default-Language:     Haskell2010
   Main-Is:              GHCModi.hs
   Other-Modules:        Paths_ghc_mod
+                        Misc
                         Utils
   GHC-Options:          -Wall -threaded
+  if os(windows)
+      Cpp-Options:      -DWINDOWS
   Default-Extensions:   ConstraintKinds, FlexibleContexts
   HS-Source-Dirs:       src
   Build-Depends:        base >= 4.0 && < 5
@@ -153,7 +160,10 @@ Executable ghc-modi
                       , containers
                       , directory
                       , filepath
+                      , old-time
+                      , process
                       , split
+                      , time
                       , ghc
                       , ghc-mod
 
@@ -199,6 +209,7 @@ Test-Suite spec
                       , io-choice
                       , monad-journal >= 0.4
                       , old-time
+                      , pretty
                       , process
                       , syb
                       , time

src/GHCMod.hs

@@ -3,187 +3,451 @@
 module Main where
 
 import Config (cProjectVersion)
-import Control.Applicative ((<$>))
+import Control.Arrow
-import Control.Exception (Exception, Handler(..), ErrorCall(..))
+import Control.Applicative
-import CoreMonad (liftIO)
+import Control.Exception (Exception, Handler(..), catches, throw)
-import qualified Control.Exception as E
 import Data.Typeable (Typeable)
 import Data.Version (showVersion)
+import Data.Default
+import Data.List
+import Data.Char (isSpace)
 import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt (OptDescr(..), ArgDescr(..), ArgOrder(..))
 import qualified System.Console.GetOpt as O
-import System.Directory (doesFileExist)
 import System.Environment (getArgs)
 import System.Exit (exitFailure)
-import System.IO (hPutStr, hPutStrLn, stdout, stderr, hSetEncoding, utf8)
+import System.IO (hPutStrLn, stdout, stderr, hSetEncoding, utf8)
+--import System.Process (rawSystem)
+--import System.Exit (exitWith)
+import Text.PrettyPrint
 
 ----------------------------------------------------------------
 
 progVersion :: String
-progVersion = "ghc-mod version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
+progVersion =
+    "ghc-mod version " ++ showVersion version ++ " compiled by GHC "
+                       ++ cProjectVersion ++ "\n"
 
-ghcOptHelp :: String
+optionUsage :: (String -> String) -> [OptDescr a] -> [String]
-ghcOptHelp = " [-g GHC_opt1 -g GHC_opt2 ...] "
+optionUsage indent opts = concatMap optUsage opts
+ where
+   optUsage (Option so lo dsc udsc) =
+       [ concat $ intersperse ", " $ addLabel `map` allFlags
+       , indent $ udsc
+       , ""
+       ]
+    where
+      allFlags = shortFlags ++ longFlags
+      shortFlags = (('-':) . return) `map` so :: [String]
+      longFlags  = ("--"++) `map` lo
 
+      addLabel f@('-':'-':_) = f ++ flagLabel "="
+      addLabel f@('-':_)     = f ++ flagLabel " "
+      addLabel _ = undefined
+
+      flagLabel s =
+          case dsc of
+            NoArg  _ -> ""
+            ReqArg _ label -> s ++ label
+            OptArg _ label -> s ++ "["++label++"]"
+
+-- TODO: Generate the stuff below automatically
 usage :: String
-usage =    progVersion
+usage =
-        ++ "Usage:\n"
+ "Usage: ghc-mod [OPTIONS...] COMMAND [OPTIONS...] \n\
-        ++ "\t ghc-mod list   " ++ ghcOptHelp ++ "[-l] [-d]\n"
+ \*Global Options (OPTIONS)*\n\
-        ++ "\t ghc-mod lang    [-l]\n"
+ \    Global options can be specified before and after the command and\n\
-        ++ "\t ghc-mod flag    [-l]\n"
+ \    interspersed with command specific options\n\
-        ++ "\t ghc-mod browse " ++ ghcOptHelp ++ "[-l] [-o] [-d] [-q] [<package>:]<module> [[<package>:]<module> ...]\n"
+ \\n"
-        ++ "\t ghc-mod check  " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
+   ++ (unlines $ indent <$> optionUsage indent globalArgSpec) ++
-        ++ "\t ghc-mod expand " ++ ghcOptHelp ++ "<HaskellFiles...>\n"
+ "*Commands*\n\
-        ++ "\t ghc-mod debug  " ++ ghcOptHelp ++ "\n"
+ \    - version\n\
-        ++ "\t ghc-mod info   " ++ ghcOptHelp ++ "<HaskellFile> <module> <expression>\n"
+ \        Print the version of the program.\n\
-        ++ "\t ghc-mod type   " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \\n\
-        ++ "\t ghc-mod split  " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \    - help | --help\n\
-        ++ "\t ghc-mod sig    " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \       Print this help message.\n\
-        ++ "\t ghc-mod refine " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no> <expression>\n"
+ \\n\
-        ++ "\t ghc-mod auto   " ++ ghcOptHelp ++ "<HaskellFile> <module> <line-no> <column-no>\n"
+ \    - list [FLAGS...]\n\
-        ++ "\t ghc-mod find    <symbol>\n"
+ \        List all visible modules.\n\
-        ++ "\t ghc-mod lint    [-h opt] <HaskellFile>\n"
+ \      Flags:\n\
-        ++ "\t ghc-mod root\n"
+ \        -d\n\
-        ++ "\t ghc-mod doc     <module>\n"
+ \            Also print the modules' package.\n\
-        ++ "\t ghc-mod boot\n"
+ \\n\
-        ++ "\t ghc-mod version\n"
+ \    - lang\n\
-        ++ "\t ghc-mod help\n"
+ \        List all known GHC language extensions.\n\
-        ++ "\n"
+ \\n\
-        ++ "<module> for \"info\" and \"type\" is not used, anything is OK.\n"
+ \    - flag\n\
-        ++ "It is necessary to maintain backward compatibility.\n"
+ \        List GHC -f<bla> flags.\n\
+ \\n\
+ \    - browse [FLAGS...] [PACKAGE:]MODULE...\n\
+ \        List symbols in a module.\n\
+ \      Flags:\n\
+ \        -o\n\
+ \            Also print operators.\n\
+ \        -d\n\
+ \            Print symbols with accompanying signatures.\n\
+ \        -q\n\
+ \            Qualify symbols.\n\
+ \\n\
+ \    - check FILE...\n\
+ \        Load the given files using GHC and report errors/warnings, but\n\
+ \        don't produce output files.\n\
+ \\n\
+ \    - expand FILE...\n\
+ \        Like `check' but also pass `-ddump-splices' to GHC.\n\
+ \\n\
+ \    - info   FILE [MODULE] EXPR\n\
+ \        Look up an identifier in the context of FILE (like ghci's `:info')\n\
+ \        MODULE is completely ignored and only allowed for backwards\n\
+ \        compatibility.\n\
+ \\n\
+ \    - type FILE [MODULE] LINE COL\n\
+ \        Get the type of the expression under (LINE,COL).\n\
+ \\n\
+ \    - split FILE [MODULE] LINE COL\n\
+ \        Split a function case by examining a type's constructors.\n\
+ \\n\
+ \        For example given the following code snippet:\n\
+ \\n\
+ \            f :: [a] -> a\n\
+ \            f x = _body\n\
+ \\n\
+ \        would be replaced by:\n\
+ \\n\
+ \            f :: [a] -> a\n\
+ \            f [] = _body\n\
+ \            f (x:xs) = _body\n\
+ \\n\
+ \        (See https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\
+ \\n\
+ \    - sig FILE MODULE LINE COL\n\
+ \        Generate initial code given a signature.\n\
+ \\n\
+ \        For example when (LINE,COL) is on the signature in the following\n\
+ \        code snippet:\n\
+ \\n\
+ \            func :: [a] -> Maybe b -> (a -> b) -> (a,b)\n\
+ \\n\
+ \        ghc-mod would add the following on the next line:\n\
+ \\n\
+ \            func x y z f = _func_body\n\
+ \\n\
+ \        (See: https://github.com/kazu-yamamoto/ghc-mod/pull/274)\n\
+ \\n\
+ \    - refine FILE MODULE LINE COL EXPR\n\
+ \        Refine the typed hole at (LINE,COL) given EXPR.\n\
+ \\n\
+ \        For example if EXPR is `filter', which has type `(a -> Bool) -> [a]\n\
+ \          -> [a]' and (LINE,COL) is on the hole `_body' in the following\n\
+ \        code snippet:\n\
+ \\n\
+ \            filterNothing :: [Maybe a] -> [a]\n\
+ \            filterNothing xs = _body\n\
+ \\n\
+ \        ghc-mod changes the code to get a value of type `[a]', which\n\
+ \        results in:\n\
+ \\n\
+ \            filterNothing xs = filter _body_1 _body_2\n\
+ \\n\
+ \        (See also: https://github.com/kazu-yamamoto/ghc-mod/issues/311)\n\
+ \\n\
+ \    - auto FILE MODULE LINE COL\n\
+ \        Try to automatically fill the contents of a hole.\n\
+ \\n\
+ \    - find SYMBOL\n\
+ \        List all modules that define SYMBOL.\n\
+ \\n\
+ \    - lint FILE\n\
+ \        Check files using `hlint'.\n\
+ \      Flags:\n\
+ \        -l\n\
+ \            Option to be passed to hlint.\n\
+ \\n\
+ \    - root FILE\n\
+ \       Try to find the project directory given FILE. For Cabal\n\
+ \       projects this is the directory containing the cabal file, for\n\
+ \       projects that use a cabal sandbox but have no cabal file this is the\n\
+ \       directory containing the sandbox and otherwise this is the directory\n\
+ \       containing FILE.\n\
+ \\n\
+ \    - doc MODULE\n\
+ \        Try finding the html documentation directory for the given MODULE.\n\
+ \\n\
+ \    - debug\n\
+ \        Print debugging information. Please include the output in any bug\n\
+ \        reports you submit.\n\
+ \\n\
+ \    - boot\n\
+ \         Internal command used by the emacs frontend.\n"
+ -- "\n\
+ -- \The following forms are supported so ghc-mod can be invoked by\n\
+ -- \`cabal repl':\n\
+ -- \\n\
+ -- \     ghc-mod --make GHC_OPTIONS\n\
+ -- \         Pass all options through to the GHC executable.\n\
+ -- \\n\
+ -- \     ghc-mod --interactive GHC_OPTIONS [--ghc-mod]\n\
+ -- \         Start ghci emulation mode. GHC_OPTIONS are passed to the\n\
+ -- \         GHC API. If `--ghc-mod' is given ghc-mod specific extensions\n\
+ -- \         are enabled.\n"
+ where
+   indent = ("    "++)
 
+cmdUsage :: String -> String -> String
+cmdUsage cmd s =
+  let
+      -- Find command head
+      a = dropWhile (not . (("    - " ++ cmd) `isInfixOf`)) $ lines s
+      -- Take til the end of the current command block
+      b = flip takeWhile a $ \l ->
+           all isSpace l || (isIndented l && (isCurrCmdHead l || isNotCmdHead l))
+      -- Drop extra newline from the end
+      c = dropWhileEnd (all isSpace) b
+
+      isIndented    = ("    " `isPrefixOf`)
+      isNotCmdHead  = ( not .  ("    - " `isPrefixOf`))
+      isCurrCmdHead = (("    - " ++ cmd) `isPrefixOf`)
+
+      unindent (' ':' ':' ':' ':l) = l
+      unindent l = l
+  in unlines $ unindent <$> c
 ----------------------------------------------------------------
 
-argspec :: [OptDescr (Options -> Options)]
+option :: [Char] -> [String] -> String -> ArgDescr a -> OptDescr a
-argspec =
+option s l udsc dsc = Option s l dsc udsc
-    let option s l udsc dsc = Option s l dsc udsc
+
+reqArg :: String -> (String -> a) -> ArgDescr a
 reqArg udsc dsc = ReqArg dsc udsc
-    in
-      [ option "l" ["tolisp"] "print as a list of Lisp" $
-               NoArg $ \o -> o { outputStyle = LispStyle }
 
-      , option "h" ["hlintOpt"] "hlint options" $
+globalArgSpec :: [OptDescr (Options -> Options)]
-               reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
+globalArgSpec =
-
+      [ option "v" ["verbose"] "Be more verbose." $
-      , option "g" ["ghcOpt"] "GHC options" $
-               reqArg "ghcOpt" $ \g o ->
-                   o { ghcUserOptions = g : ghcUserOptions o }
-
-      , option "v" ["verbose"] "verbose" $
                NoArg $ \o -> o { ghcUserOptions = "-v" : ghcUserOptions o }
 
-      , option "o" ["operators"] "print operators, too" $
+      , option "l" ["tolisp"] "Format output as an S-Expression" $
-               NoArg $ \o -> o { operators = True }
+               NoArg $ \o -> o { outputStyle = LispStyle }
 
-      , option "d" ["detailed"] "print detailed info" $
+      , option "b" ["boundary"] "Output line separator"$
-               NoArg $ \o -> o { detailed = True }
+               reqArg "SEP" $ \s o -> o { lineSeparator = LineSeparator s }
 
-      , option "q" ["qualified"] "show qualified names" $
+      , option "g" ["ghcOpt"] "Option to be passed to GHC" $
-               NoArg $ \o -> o { qualified = True }
+               reqArg "OPT" $ \g o ->
+                   o { ghcUserOptions = g : ghcUserOptions o }
 
-      , option "b" ["boundary"] "specify line separator (default is Nul string)"$
+      , option "" ["with-ghc"] "GHC executable to use" $
-               reqArg "sep" $ \s o -> o { lineSeparator = LineSeparator s }
+               reqArg "PROG" $ \p o -> o { ghcProgram = p }
+
+      , option "" ["with-cabal"] "cabal-install executable to use" $
+               reqArg "PROG" $ \p o -> o { cabalProgram = p }
   ]
 
-parseArgs :: [OptDescr (Options -> Options)] -> [String] -> (Options, [String])
+parseGlobalArgs ::[String] -> (Options, [String])
-parseArgs spec argv
+parseGlobalArgs argv
-    = case O.getOpt Permute spec argv of
+    = case O.getOpt RequireOrder globalArgSpec argv of
-        (o,n,[]  ) -> (foldr id defaultOptions o, n)
+        (o,r,[]  ) -> (foldr id defaultOptions o, r)
-        (_,_,errs) -> E.throw (CmdArg errs)
+        (_,_,errs) ->
+            fatalError $ "Parsing command line options failed: \n" ++ concat errs
+
+parseCommandArgs :: [OptDescr (Options -> Options)]
+                 -> [String]
+                 -> Options
+                 -> (Options, [String])
+parseCommandArgs spec argv opts
+    = case O.getOpt RequireOrder (globalArgSpec ++ spec) argv of
+        (o,r,[])   -> (foldr id opts o, r)
+        (_,_,errs) ->
+            fatalError $ "Parsing command options failed: \n" ++ concat errs
 
 ----------------------------------------------------------------
 
-data GHCModError = SafeList
+data CmdError = UnknownCommand String
-                 | ArgumentsMismatch String
+              | NoSuchFileError String
-                 | NoSuchCommand String
+              | LibraryError GhcModError
-                 | CmdArg [String]
-                 | FileNotExist String deriving (Show, Typeable)
 
-instance Exception GHCModError
+                deriving (Show, Typeable)
+
+instance Exception CmdError
 
 ----------------------------------------------------------------
 
+data InteractiveOptions = InteractiveOptions {
+      ghcModExtensions :: Bool
+    }
+
+instance Default InteractiveOptions where
+    def = InteractiveOptions False
+
+handler :: IO a -> IO a
+handler = flip catches $
+          [ Handler $ \(FatalError msg) -> exitError msg
+          , Handler $ \(InvalidCommandLine e) -> do
+                case e of
+                  Left cmd ->
+                      exitError $ (cmdUsage cmd usage)
+                               ++ "\nghc-mod: Invalid command line form."
+                  Right msg -> exitError msg
+          ]
+
 main :: IO ()
-main = flip E.catches handlers $ do
+main = handler $ do
     hSetEncoding stdout utf8
     args <- getArgs
-    let (opt,cmdArg) = parseArgs argspec args
-    let cmdArg0 = cmdArg !. 0
-        cmdArg1 = cmdArg !. 1
-        cmdArg3 = cmdArg !. 3
-        cmdArg4 = cmdArg !. 4
-        cmdArg5 = cmdArg !. 5
-        remainingArgs = tail cmdArg
-        nArgs :: Int -> a -> a
-        nArgs n f = if length remainingArgs == n
-                        then f
-                        else E.throw (ArgumentsMismatch cmdArg0)
-    (res, _) <- runGhcModT opt $ case cmdArg0 of
-      "list"    -> modules
-      "lang"    -> languages
-      "flag"    -> flags
-      "browse"  -> concat <$> mapM browse remainingArgs
-      "check"   -> checkSyntax remainingArgs
-      "expand"  -> expandTemplate remainingArgs
-      "debug"   -> debugInfo
-      "info"    -> nArgs 3 info cmdArg1 cmdArg3
-      "type"    -> nArgs 4 $ types cmdArg1 (read cmdArg3) (read cmdArg4)
-      "split"   -> nArgs 4 $ splits cmdArg1 (read cmdArg3) (read cmdArg4)
-      "sig"     -> nArgs 4 $ sig cmdArg1 (read cmdArg3) (read cmdArg4)
-      "refine"  -> nArgs 5 $ refine cmdArg1 (read cmdArg3) (read cmdArg4) cmdArg5
-      "auto"    -> nArgs 4 $ auto cmdArg1 (read cmdArg3) (read cmdArg4)
-      "find"    -> nArgs 1 $ findSymbol cmdArg1
-      "lint"    -> nArgs 1 $ withFile lint cmdArg1
-      "root"    -> rootInfo
-      "doc"     -> nArgs 1 $ pkgDoc cmdArg1
-      "dumpsym" -> dumpSymbol
-      "boot"    -> boot
-      "version" -> return progVersion
-      "help"    -> return $ O.usageInfo usage argspec
-      cmd       -> E.throw (NoSuchCommand cmd)
 
+    let (ghcArgs, modArgs) = second stripSeperator $ span (/="--") args
+        _realGhcArgs = filter (/="--ghc-mod") ghcArgs
+
+        (globalOptions,_cmdArgs) = parseGlobalArgs modArgs
+
+        stripSeperator ("--":rest) = rest
+        stripSeperator l = l
+
+    case args of
+      _
+          -- | "--numeric-version" `elem` ghcArgs || "--make" `elem` ghcArgs -> do
+          --     rawSystem (ghcProgram globalOptions) realGhcArgs >>= exitWith
+
+          -- | "--interactive" `elem` ghcArgs -> do
+          --     let interactiveOptions = if "--ghc-mod" `elem` ghcArgs
+          --                              then def { ghcModExtensions = True }
+          --                              else def
+
+          --     -- TODO: pass ghcArgs' to ghc API
+          --     putStrLn "\ninteractive\n"
+          --     --print realGhcArgs
+          --     (res, _) <- runGhcModT globalOptions $ undefined
+          --     case res of
+          --       Right s -> putStr s
+          --       Left e -> exitError $ render (gmeDoc e)
+
+
+          | otherwise -> do
+              (res, _) <- runGhcModT globalOptions $ commands args
               case res of
                 Right s -> putStr s
-      Left (GMENoMsg) ->
+                Left e -> exitError $ render (gmeDoc e)
-          hPutStrLn stderr "Unknown error"
-      Left (GMEString msg) ->
-          hPutStrLn stderr msg
-      Left (GMECabalConfigure msg) ->
-          hPutStrLn stderr $ "cabal configure failed: " ++ show msg
-      Left (GMECabalFlags msg) ->
-          hPutStrLn stderr $ "retrieval of the cabal configuration flags failed: " ++ show msg
-      Left (GMEProcess cmd msg) ->
-          hPutStrLn stderr $
-            "launching operating system process `"++c++"` failed: " ++ show msg
-          where c = unwords cmd
 
+              -- Obtain ghc options by letting ourselfs be executed by
+              -- @cabal repl@
+              -- TODO: need to do something about non-cabal projects
+              -- exe <- ghcModExecutable
+              -- let cabalArgs = ["repl", "-v0", "--with-ghc="++exe]
+              --              ++ (("--ghc-option="++) `map` ("--ghc-mod":"--":args))
+
+              -- print cabalArgs
+
+              -- rawSystem "cabal" cabalArgs >>= exitWith
+
+commands :: IOish m => [String] -> GhcModT m String
+commands []         = fatalError "No command given (try --help)\n"
+commands (cmd:args) = fn args
  where
-    handlers = [Handler (handleThenExit handler1), Handler (handleThenExit handler2)]
+   fn = case cmd of
-    handleThenExit handler e = handler e >> exitFailure
+     _ | cmd == "list" || cmd == "modules" -> modulesCmd
-    handler1 :: ErrorCall -> IO ()
+     _ | cmd == "help" || cmd == "--help"  -> const $ return usage
-    handler1 = print -- for debug
+     "version" -> const $ return progVersion
-    handler2 :: GHCModError -> IO ()
+     "lang"    -> languagesCmd
-    handler2 SafeList = printUsage
+     "flag"    -> flagsCmd
-    handler2 (ArgumentsMismatch cmd) = do
+     "browse"  -> browseCmd
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\": Arguments did not match"
+     "check"   -> checkSyntaxCmd
-        printUsage
+     "expand"  -> expandTemplateCmd
-    handler2 (NoSuchCommand cmd) = do
+     "debug"   -> debugInfoCmd
-        hPutStrLn stderr $ "\"" ++ cmd ++ "\" not supported"
+     "info"    -> infoCmd
-        printUsage
+     "type"    -> typesCmd
-    handler2 (CmdArg errs) = do
+     "split"   -> splitsCmd
-        mapM_ (hPutStr stderr) errs
+     "sig"     -> sigCmd
-        printUsage
+     "refine"  -> refineCmd
-    handler2 (FileNotExist file) = do
+     "auto"    -> autoCmd
-        hPutStrLn stderr $ "\"" ++ file ++ "\" not found"
+     "find"    -> findSymbolCmd
-        printUsage
+     "lint"    -> lintCmd
-    printUsage = hPutStrLn stderr $ '\n' : O.usageInfo usage argspec
+     "root"    -> rootInfoCmd
-    withFile :: IOish m => (FilePath -> GhcModT m a) -> FilePath -> GhcModT m a
+     "doc"     -> pkgDocCmd
-    withFile cmd file = do
+     "dumpsym" -> dumpSymbolCmd
-        exist <- liftIO $ doesFileExist file
+     "boot"    -> bootCmd
-        if exist
+     _         -> fatalError $ "unknown command: `" ++ cmd ++ "'"
-            then cmd file
+
-            else E.throw (FileNotExist file)
+newtype FatalError = FatalError String deriving (Show, Typeable)
-    xs !. idx
+instance Exception FatalError
-      | length xs <= idx = E.throw SafeList
+
-      | otherwise = xs !! idx
+newtype InvalidCommandLine = InvalidCommandLine (Either String String)
+    deriving (Show, Typeable)
+instance Exception InvalidCommandLine
+
+exitError :: String -> IO a
+exitError msg = hPutStrLn stderr msg >> exitFailure
+
+fatalError :: String -> a
+fatalError s = throw $ FatalError $ "ghc-mod: " ++ s
+
+withParseCmd :: IOish m
+             => [OptDescr (Options -> Options)]
+             -> ([String] -> GhcModT m a)
+             -> [String]
+             -> GhcModT m a
+withParseCmd spec action args  = do
+  (opts', rest) <- parseCommandArgs spec args <$> options
+  withOptions (const opts') $ action rest
+
+modulesCmd, languagesCmd, flagsCmd, browseCmd, checkSyntaxCmd, expandTemplateCmd,
+  debugInfoCmd, infoCmd, typesCmd, splitsCmd, sigCmd, refineCmd, autoCmd,
+  findSymbolCmd, lintCmd, rootInfoCmd, pkgDocCmd, dumpSymbolCmd, bootCmd
+  :: IOish m => [String] -> GhcModT m String
+
+modulesCmd    = withParseCmd [] $ \[] -> modules
+languagesCmd  = withParseCmd [] $ \[] -> languages
+flagsCmd      = withParseCmd [] $ \[] -> flags
+debugInfoCmd  = withParseCmd [] $ \[] -> debugInfo
+rootInfoCmd   = withParseCmd [] $ \[] -> rootInfo
+-- internal
+dumpSymbolCmd = withParseCmd [] $ \[] -> dumpSymbol
+bootCmd       = withParseCmd [] $ \[] -> boot
+
+findSymbolCmd     = withParseCmd [] $ \[sym]  -> findSymbol sym
+pkgDocCmd         = withParseCmd [] $ \[mdl]  -> pkgDoc mdl
+lintCmd           = withParseCmd s  $ \[file] -> lint file
+ where s = hlintArgSpec
+browseCmd         = withParseCmd s  $ \mdls   -> concat <$> browse `mapM` mdls
+ where s = browseArgSpec
+checkSyntaxCmd    = withParseCmd [] $ checkAction checkSyntax
+expandTemplateCmd = withParseCmd [] $ checkAction expandTemplate
+
+typesCmd      = withParseCmd [] $ locAction  "type"  types
+splitsCmd     = withParseCmd [] $ locAction  "split" splits
+sigCmd        = withParseCmd [] $ locAction  "sig"    sig
+autoCmd       = withParseCmd [] $ locAction  "auto"   auto
+refineCmd     = withParseCmd [] $ locAction' "refine" refine
+
+infoCmd       = withParseCmd [] $ action
+  where action [file,_,expr] = info file expr
+        action [file,expr]   = info file expr
+        action _ = throw $ InvalidCommandLine (Left "info")
+
+checkAction :: ([t] -> a) -> [t] -> a
+checkAction _ []         = throw $ InvalidCommandLine (Right "No files given.")
+checkAction action files = action files
+
+locAction :: String -> (String -> Int -> Int -> a) -> [String] -> a
+locAction _ action [file,_,line,col] = action file (read line) (read col)
+locAction _ action [file,  line,col] = action file (read line) (read col)
+locAction cmd _ _ = throw $ InvalidCommandLine (Left cmd)
+
+locAction' :: String -> (String -> Int -> Int -> String -> a) -> [String] -> a
+locAction' _ action [f,_,line,col,expr] = action f (read line) (read col) expr
+locAction' _ action [f,  line,col,expr] = action f (read line) (read col) expr
+locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
+
+hlintArgSpec :: [OptDescr (Options -> Options)]
+hlintArgSpec =
+    [ option "h" ["hlintOpt"] "Option to be passed to hlint" $
+             reqArg "hlintOpt" $ \h o -> o { hlintOpts = h : hlintOpts o }
+    ]
+browseArgSpec :: [OptDescr (Options -> Options)]
+browseArgSpec =
+    [ option "o" ["operators"] "Also print operators." $
+             NoArg $ \o -> o { operators = True }
+    , option "d" ["detailed"] "Print symbols with accompanying signature." $
+             NoArg $ \o -> o { detailed = True }
+    , option "q" ["qualified"] "Qualify symbols" $
+             NoArg $ \o -> o { qualified = True }
+    ]

src/GHCModi.hs

@@ -20,36 +20,27 @@ module Main where
 
 import Config (cProjectVersion)
 import Control.Applicative ((<$>))
-import Control.Concurrent.Async (Async, async, wait)
+import Control.Exception (SomeException(..))
-import Control.Exception (SomeException(..), Exception)
 import qualified Control.Exception as E
 import Control.Monad (when)
 import CoreMonad (liftIO)
-import Data.List (find, intercalate)
+import Data.List (intercalate)
 import Data.List.Split (splitOn)
-import Data.Maybe (fromMaybe)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Data.Typeable (Typeable)
 import Data.Version (showVersion)
-import qualified GHC as G
 import Language.Haskell.GhcMod
 import Language.Haskell.GhcMod.Internal
 import Paths_ghc_mod
 import System.Console.GetOpt
 import System.Directory (setCurrentDirectory)
 import System.Environment (getArgs)
-import System.IO (hFlush,stdout)
 import System.Exit (ExitCode, exitFailure)
+import System.IO (hFlush,stdout)
 
+import Misc
 import Utils
 
 ----------------------------------------------------------------
 
-type Logger = IO String
-
-----------------------------------------------------------------
-
 progVersion :: String
 progVersion = "ghc-modi version " ++ showVersion version ++ " compiled by GHC " ++ cProjectVersion ++ "\n"
 
@@ -79,13 +70,6 @@ parseArgs spec argv
 
 ----------------------------------------------------------------
 
-data GHCModiError = CmdArg [String]
-                  deriving (Show, Typeable)
-
-instance Exception GHCModiError
-
-----------------------------------------------------------------
-
 -- Running two GHC monad threads disables the handling of
 -- C-c since installSignalHandlers is called twice, sigh.
 
@@ -96,14 +80,21 @@ main = E.handle cmdHandler $
     cmdHandler (CmdArg _) = putStr $ usageInfo usage argspec
     go (_,"help":_) = putStr $ usageInfo usage argspec
     go (_,"version":_) = putStr progVersion
-    go (opt,_) = flip E.catches handlers $ do
+    go (opt,_) = emptyNewUnGetLine >>= run opt
+
+run :: Options -> UnGetLine -> IO ()
+run opt ref = flip E.catches handlers $ do
     cradle0 <- findCradle
     let rootdir = cradleRootDir cradle0
 --        c = cradle0 { cradleCurrentDir = rootdir } TODO: ?????
     setCurrentDirectory rootdir
-        symDb <- async $ runGhcModT opt loadSymbolDb
+    prepareAutogen cradle0
-        (res, _) <- runGhcModT opt $ loop S.empty symDb
+    -- Asynchronous db loading starts here.
-
+    symdbreq <- newSymDbReq opt
+    (res, _) <- runGhcModT opt $ do
+        crdl <- cradle
+        world <- liftIO $ getCurrentWorld crdl
+        loop symdbreq ref world
     case res of
         Right () -> return ()
         Left (GMECabalConfigure msg) -> do
@@ -114,6 +105,7 @@ main = E.handle cmdHandler $
     -- this is just in case.
     -- If an error is caught here, it is a bug of GhcMod library.
     handlers = [ E.Handler (\(_ :: ExitCode) -> return ())
+               , E.Handler (\(_ :: Restart) -> run opt ref)
                , E.Handler (\(SomeException e) -> bug $ show e) ]
 
 bug :: String -> IO ()
@@ -132,91 +124,63 @@ replace needle replacement = intercalate replacement . splitOn needle
 
 ----------------------------------------------------------------
 
-loop :: IOish m => Set FilePath -> SymDbReq -> GhcModT m ()
+loop :: IOish m => SymDbReq -> UnGetLine -> World -> GhcModT m ()
-loop set symDbReq = do
+loop symdbreq ref world = do
-    cmdArg <- liftIO getLine
+    -- blocking
+    cmdArg <- liftIO $ getCommand ref
+    -- after blocking, we need to see if the world has changed.
+    crdl <- cradle
+    changed <- liftIO $ isWorldChanged world crdl
+    when changed $ do
+        liftIO $ ungetCommand ref cmdArg
+        E.throw Restart
+    cradle >>= liftIO . prepareAutogen
     let (cmd,arg') = break (== ' ') cmdArg
         arg = dropWhile (== ' ') arg'
-    (ret,ok,set') <- case cmd of
+    (ret,ok) <- case cmd of
-        "check"  -> checkStx set arg
+        "check"  -> checkStx arg
-        "find"   -> findSym set arg symDbReq
+        "find"   -> findSym arg symdbreq
-        "lint"   -> lintStx set arg
+        "lint"   -> lintStx arg
-        "info"   -> showInfo set arg
+        "info"   -> showInfo arg
-        "type"   -> showType set arg
+        "type"   -> showType arg
-        "split"  -> doSplit set arg
+        "split"  -> doSplit arg
-        "sig"    -> doSig set arg
+        "sig"    -> doSig arg
-        "refine" -> doRefine set arg
+        "refine" -> doRefine arg
-        "auto"   -> doAuto set arg
+        "auto"   -> doAuto arg
-        "boot"   -> bootIt set
+        "boot"   -> bootIt
-        "browse" -> browseIt set arg
+        "browse" -> browseIt arg
-        "quit"   -> return ("quit", False, set)
+        "quit"   -> return ("quit", False)
-        ""       -> return ("quit", False, set)
+        ""       -> return ("quit", False)
-        _        -> return ([], True, set)
+        _        -> return ([], True)
     if ok then do
         liftIO $ putStr ret
         liftIO $ putStrLn "OK"
       else do
         liftIO $ putStrLn $ notGood ret
     liftIO $ hFlush stdout
-    when ok $ loop set' symDbReq
+    when ok $ loop symdbreq ref world
 
 ----------------------------------------------------------------
 
-checkStx :: IOish m
+checkStx :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+checkStx file = do
-         -> FilePath
+    eret <- check [file]
-         -> GhcModT m (String, Bool, Set FilePath)
-checkStx set file = do
-    set' <- newFileSet set file
-    let files = S.toList set'
-    eret <- check files
     case eret of
-        Right ret -> return (ret, True, set')
+        Right ret -> return (ret, True)
-        Left ret  -> return (ret, True, set) -- fxime: set
+        Left ret  -> return (ret, True)
-
-newFileSet :: IOish m => Set FilePath -> FilePath -> GhcModT m (Set FilePath)
-newFileSet set file = do
-    let set1
-         | S.member file set = set
-         | otherwise         = S.insert file set
-    mx <- isSameMainFile file <$> getModSummaryForMain
-    return $ case mx of
-        Nothing       -> set1
-        Just mainfile -> S.delete mainfile set1
-
-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"
-
-isSameMainFile :: FilePath -> (Maybe G.ModSummary) -> Maybe FilePath
-isSameMainFile _    Nothing  = Nothing
-isSameMainFile file (Just x)
-    | mainfile == file = Nothing
-    | otherwise        = Just mainfile
-  where
-    mmainfile = G.ml_hs_file (G.ms_location x)
-    -- G.ms_hspp_file x is a temporary file with CPP.
-    -- this is a just fake.
-    mainfile = fromMaybe (G.ms_hspp_file x) mmainfile
 
 ----------------------------------------------------------------
 
-type SymDbReq = Async (Either GhcModError SymbolDb, GhcModLog)
+findSym :: IOish m => Symbol -> SymDbReq -> GhcModT m (String, Bool)
-
+findSym sym symdbreq = do
-findSym :: IOish m => Set FilePath -> String -> SymDbReq
+    db <- getDb symdbreq >>= checkDb symdbreq
-        -> GhcModT m (String, Bool, Set FilePath)
-findSym set sym dbReq = do
-    db <- hoistGhcModT =<< liftIO (wait dbReq)
     ret <- lookupSymbol sym db
-    return (ret, True, set)
+    return (ret, True)
 
-lintStx :: IOish m => Set FilePath
+lintStx :: IOish m => FilePath -> GhcModT m (String, Bool)
-        -> FilePath
+lintStx optFile = do
-        -> GhcModT m (String, Bool, Set FilePath)
-lintStx set optFile = do
     ret <- withOptions changeOpt $ lint file
-    return (ret, True, set)
+    return (ret, True)
   where
     (opts,file) = parseLintOptions optFile
     hopts = if opts == "" then [] else read opts
@@ -239,85 +203,56 @@ parseLintOptions optFile = case brk (== ']') (dropWhile (/= '[') optFile) of
 
 ----------------------------------------------------------------
 
-showInfo :: IOish m
+showInfo :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+showInfo fileArg = do
-         -> FilePath
-         -> GhcModT m (String, Bool, Set FilePath)
-showInfo set fileArg = do
     let [file, expr] = splitN 2 fileArg
-    set' <- newFileSet set file
     ret <- info file expr
-    return (ret, True, set')
+    return (ret, True)
 
-showType :: IOish m
+showType :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+showType fileArg  = do
-         -> FilePath
-         -> GhcModT m (String, Bool, Set FilePath)
-showType set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- types file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
-doSplit :: IOish m
+doSplit :: IOish m => FilePath -> GhcModT m (String, Bool)
-        => Set FilePath
+doSplit fileArg  = do
-        -> FilePath
-        -> GhcModT m (String, Bool, Set FilePath)
-doSplit set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- splits file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
-doSig :: IOish m
+doSig :: IOish m => FilePath -> GhcModT m (String, Bool)
-      => Set FilePath
+doSig fileArg  = do
-      -> FilePath
-      -> GhcModT m (String, Bool, Set FilePath)
-doSig set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- sig file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
-doRefine :: IOish m
+doRefine :: IOish m => FilePath -> GhcModT m (String, Bool)
-         => Set FilePath
+doRefine fileArg  = do
-         -> FilePath
-         -> GhcModT m (String, Bool, Set FilePath)
-doRefine set fileArg  = do
     let [file, line, column, expr] = splitN 4 fileArg
-    set' <- newFileSet set file
     ret <- refine file (read line) (read column) expr
-    return (ret, True, set')
+    return (ret, True)
 
-doAuto :: IOish m
+doAuto :: IOish m => FilePath -> GhcModT m (String, Bool)
-       => Set FilePath
+doAuto fileArg  = do
-       -> FilePath
-       -> GhcModT m (String, Bool, Set FilePath)
-doAuto set fileArg  = do
     let [file, line, column] = splitN 3 fileArg
-    set' <- newFileSet set file
     ret <- auto file (read line) (read column)
-    return (ret, True, set')
+    return (ret, True)
 
 ----------------------------------------------------------------
 
-bootIt :: IOish m
+bootIt :: IOish m => GhcModT m (String, Bool)
-       => Set FilePath
+bootIt = do
-       -> GhcModT m (String, Bool, Set FilePath)
-bootIt set = do
     ret <- boot
-    return (ret, True, set)
+    return (ret, True)
 
-browseIt :: IOish m
+browseIt :: IOish m => ModuleString -> GhcModT m (String, Bool)
-         => Set FilePath
+browseIt mdl = do
-         -> ModuleString
-         -> GhcModT m (String, Bool, Set FilePath)
-browseIt set mdl = do
     let (det,rest') = break (== ' ') mdl
         rest = dropWhile (== ' ') rest'
     ret <- if det == "-d"
                then withOptions setDetailed (browse rest)
                else browse mdl
-    return (ret, True, set)
+    return (ret, True)
   where
     setDetailed opt = opt { detailed = True }

src/Misc.hs

@@ -0,0 +1,154 @@
+{-# LANGUAGE DeriveDataTypeable, CPP #-}
+
+module Misc (
+    GHCModiError(..)
+  , Restart(..)
+  , UnGetLine
+  , emptyNewUnGetLine
+  , ungetCommand
+  , getCommand
+  , SymDbReq
+  , newSymDbReq
+  , getDb
+  , checkDb
+  , prepareAutogen
+  ) where
+
+import Control.Applicative ((<$>))
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async (Async, async, wait)
+import Control.Exception (Exception)
+import Control.Monad (unless, when)
+import CoreMonad (liftIO)
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+import Data.List (isPrefixOf)
+import Data.Maybe (isJust)
+import Data.Typeable (Typeable)
+import System.Directory (doesDirectoryExist, getDirectoryContents)
+import System.IO (openBinaryFile, IOMode(..))
+import System.Process
+
+import Language.Haskell.GhcMod
+import Language.Haskell.GhcMod.Internal
+
+----------------------------------------------------------------
+
+data GHCModiError = CmdArg [String] deriving (Show, Typeable)
+
+instance Exception GHCModiError
+
+----------------------------------------------------------------
+
+data Restart = Restart deriving (Show, Typeable)
+
+instance Exception Restart
+
+----------------------------------------------------------------
+
+newtype UnGetLine = UnGetLine (IORef (Maybe String))
+
+emptyNewUnGetLine :: IO UnGetLine
+emptyNewUnGetLine = UnGetLine <$> newIORef Nothing
+
+ungetCommand :: UnGetLine -> String -> IO ()
+ungetCommand (UnGetLine ref) cmd = writeIORef ref (Just cmd)
+
+getCommand :: UnGetLine -> IO String
+getCommand (UnGetLine ref) = do
+    mcmd <- readIORef ref
+    case mcmd of
+        Nothing -> getLine
+        Just cmd -> do
+            writeIORef ref Nothing
+            return cmd
+
+----------------------------------------------------------------
+
+type SymDbReqAction = (Either GhcModError SymbolDb, GhcModLog)
+data SymDbReq = SymDbReq (IORef (Async SymDbReqAction)) (IO SymDbReqAction)
+
+newSymDbReq :: Options -> IO SymDbReq
+newSymDbReq opt = do
+    let act = runGhcModT opt loadSymbolDb
+    req <- async act
+    ref <- newIORef req
+    return $ SymDbReq ref act
+
+getDb :: IOish m => SymDbReq -> GhcModT m SymbolDb
+getDb (SymDbReq ref _) = do
+    req <- liftIO $ readIORef ref
+    -- 'wait' really waits for the asynchronous action at the fist time.
+    -- Then it reads a cached value from the second time.
+    hoistGhcModT =<< liftIO (wait req)
+
+checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
+checkDb (SymDbReq ref act) db = do
+    outdated <- liftIO $ isOutdated db
+    if outdated then do
+        -- async and wait here is unnecessary because this is essentially
+        -- synchronous. But Async can be used a cache.
+        req <- liftIO $ async act
+        liftIO $ writeIORef ref req
+        hoistGhcModT =<< liftIO (wait req)
+      else
+        return db
+
+----------------------------------------------------------------
+
+build :: IO ProcessHandle
+build = do
+#ifdef WINDOWS
+    nul <- openBinaryFile "NUL" AppendMode
+#else
+    nul <- openBinaryFile "/dev/null" AppendMode
+#endif
+    (_, _, _, hdl) <- createProcess $ pro nul
+    return hdl
+ where
+   pro nul = CreateProcess {
+       cmdspec = RawCommand "cabal" ["build"]
+     , cwd = Nothing
+     , env = Nothing
+     , std_in = Inherit
+     , std_out = UseHandle nul
+     , std_err = UseHandle nul
+     , close_fds = False
+#if __GLASGOW_HASKELL__ >= 702
+      , create_group = True
+#endif
+#if __GLASGOW_HASKELL__ >= 707
+      , delegate_ctlc = False
+#endif
+     }
+
+autogen :: String
+autogen = "dist/build/autogen"
+
+isAutogenPrepared :: IO Bool
+isAutogenPrepared = do
+    exist <- doesDirectoryExist autogen
+    if exist then do
+        files <- filter ("." `isPrefixOf`) <$> getDirectoryContents autogen
+        if length files >= 2 then
+            return True
+          else
+            return False
+      else
+        return False
+
+watch :: Int -> ProcessHandle -> IO ()
+watch 0 _ = return ()
+watch n hdl = do
+    prepared <- isAutogenPrepared
+    if prepared then
+        interruptProcessGroupOf hdl
+      else do
+        threadDelay 100000
+        watch (n - 1) hdl
+
+prepareAutogen :: Cradle -> IO ()
+prepareAutogen crdl = when (isJust $ cradleCabalFile crdl) $ do
+    prepared <- isAutogenPrepared
+    unless prepared $ do
+        hdl <- build
+        watch 30 hdl