Merge remote-tracking branch 'sergv/master'

Language/Haskell/GhcMod.hs

@@ -17,7 +17,7 @@ module Language.Haskell.GhcMod (
   , gmLog
   -- * Types
   , ModuleString
-  , Expression
+  , Expression(..)
   , GhcPkgDb
   , Symbol
   , SymbolDb

Language/Haskell/GhcMod/Boot.hs

@@ -9,8 +9,9 @@ import Language.Haskell.GhcMod.Modules
 
 -- | Printing necessary information for front-end booting.
 boot :: IOish m => GhcModT m String
-boot =  concat <$> sequence [modules, languages, flags,
+boot = concat <$> sequence ms
-                             concat <$> mapM browse preBrowsedModules]
+  where
+    ms = [modules, languages, flags, concat <$> mapM browse preBrowsedModules]
 
 preBrowsedModules :: [String]
 preBrowsedModules = [

Language/Haskell/GhcMod/Browse.hs

@@ -27,7 +27,7 @@ import Exception (ExceptionMonad, ghandle)
 --   If 'detailed' is 'True', their types are also obtained.
 --   If 'operators' is 'True', operators are also returned.
 browse :: forall m. IOish m
-       => ModuleString -- ^ A module name. (e.g. \"Data.List\")
+       => String -- ^ A module name. (e.g. \"Data.List\", "base:Prelude")
        -> GhcModT m String
 browse pkgmdl = do
     convert' . sort =<< go
@@ -48,7 +48,7 @@ browse pkgmdl = do
 
     tryModuleInfo m = fromJust <$> G.getModuleInfo m
 
-    (mpkg,mdl) = splitPkgMdl pkgmdl
+    (mpkg, mdl) = splitPkgMdl pkgmdl
     mdlname = G.mkModuleName mdl
     mpkgid = mkFastString <$> mpkg
 
@@ -59,9 +59,10 @@ browse pkgmdl = do
 -- >>> splitPkgMdl "Prelude"
 -- (Nothing,"Prelude")
 splitPkgMdl :: String -> (Maybe String,String)
-splitPkgMdl pkgmdl = case break (==':') pkgmdl of
+splitPkgMdl pkgmdl =
-    (mdl,"")    -> (Nothing,mdl)
+  case break (==':') pkgmdl of
-    (pkg,_:mdl) -> (Just pkg,mdl)
+    (mdl, "")    -> (Nothing, mdl)
+    (pkg, _:mdl) -> (Just pkg, mdl)
 
 -- Haskell 2010:
 -- small -> ascSmall | uniSmall | _

Language/Haskell/GhcMod/Convert.hs

@@ -64,6 +64,10 @@ instance ToString [String] where
   toLisp  opt = toSexp1 opt
   toPlain opt = inter '\n' . map (toPlain opt)
 
+instance ToString [ModuleString] where
+  toLisp  opt = toLisp opt . map getModuleString
+  toPlain opt = toPlain opt . map getModuleString
+
 -- |
 --
 -- >>> let inp = [((1,2,3,4),"foo"),((5,6,7,8),"bar")] :: [((Int,Int,Int,Int),String)]

Language/Haskell/GhcMod/FillSig.hs

@@ -11,7 +11,7 @@ import Data.Char (isSymbol)
 import Data.Function (on)
 import Data.List (find, nub, sortBy)
 import qualified Data.Map as M
-import Data.Maybe (isJust, catMaybes)
+import Data.Maybe (catMaybes)
 import Exception (ghandle, SomeException(..))
 import GHC (GhcMonad, Id, ParsedModule(..), TypecheckedModule(..), DynFlags,
             SrcSpan, Type, GenLocated(L))
@@ -79,17 +79,14 @@ sig file lineNo colNo =
           Signature loc names ty ->
               ("function", fourInts loc, map (initialBody dflag style ty) names)
 
-          InstanceDecl loc cls -> let
+          InstanceDecl loc cls ->
-                body x = initialBody dflag style (G.idType x) x
+            let body x = initialBody dflag style (G.idType x) x
-            in
+            in ("instance", fourInts loc, body `map` Ty.classMethods cls)
-              ("instance", fourInts loc, body `map` Ty.classMethods cls)
 
           TyFamDecl loc name flavour vars ->
             let (rTy, initial) = initialTyFamString flavour
                 body = initialFamBody dflag style name vars
             in (rTy, fourInts loc, [initial ++ body])
-
-
   where
     fallback (SomeException _) = do
       opt <- options
@@ -244,9 +241,11 @@ initialHead1 :: String -> [FnArg] -> [String] -> String
 initialHead1 fname args elts =
   case initialBodyArgs1 args elts of
     []      -> fname
-    arglist -> if isSymbolName fname
+    arglist
-               then head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
+      | isSymbolName fname ->
-               else fname ++ " " ++ unwords arglist
+        head arglist ++ " " ++ fname ++ " " ++ unwords (tail arglist)
+      | otherwise ->
+        fname ++ " " ++ unwords arglist
 
 initialBodyArgs1 :: [FnArg] -> [String] -> [String]
 initialBodyArgs1 args elts = take (length args) elts
@@ -337,8 +336,9 @@ refine :: IOish m
        -> Int          -- ^ Column number.
        -> Expression   -- ^ A Haskell expression.
        -> GhcModT m String
-refine file lineNo colNo expr =
+refine file lineNo colNo (Expression expr) =
-  ghandle handler $ runGmlT' [Left file] deferErrors $ do
+  ghandle handler $
+    runGmlT' [Left file] deferErrors $ do
       opt <- options
       style <- getStyle
       dflag <- G.getSessionDynFlags
@@ -355,32 +355,39 @@ refine file lineNo colNo expr =
                 iArgs = take diffArgs eArgs
                 text = initialHead1 expr iArgs (infinitePrefixSupply name)
              in (fourInts loc, doParen paren text)
-
   where
     handler (SomeException _) = emptyResult =<< options
 
 -- Look for the variable in the specified position
-findVar :: GhcMonad m => DynFlags -> PprStyle
+findVar
-                      -> G.TypecheckedModule -> G.TypecheckedSource
+  :: GhcMonad m
-                      -> Int -> Int -> m (Maybe (SrcSpan, String, Type, Bool))
+  => DynFlags
+  -> PprStyle
+  -> G.TypecheckedModule
+  -> G.TypecheckedSource
+  -> Int
+  -> Int
+  -> m (Maybe (SrcSpan, String, Type, Bool))
 findVar dflag style tcm tcs lineNo colNo =
-  let lst = sortBy (cmp `on` G.getLoc) $
+  case lst of
-                listifySpans tcs (lineNo, colNo) :: [G.LHsExpr Id]
+    e@(L _ (G.HsVar i)):others -> do
-  in case lst of
+      tyInfo <- Gap.getType tcm e
-      e@(L _ (G.HsVar i)):others ->
+      case tyInfo of
-        do tyInfo <- Gap.getType tcm e
+        Just (s, typ)
-           let name = getFnName dflag style i
+          | name == "undefined" || head name == '_' ->
-           if (name == "undefined" || head name == '_') && isJust tyInfo
+            return $ Just (s, name, typ, b)
-              then let Just (s,t) = tyInfo
+          where
-                       b = case others of  -- If inside an App, we need
+            name = getFnName dflag style i
-                                           -- parenthesis
+            -- If inside an App, we need parenthesis
-                             [] -> False
+            b = case others of
                   L _ (G.HsApp (L _ a1) (L _ a2)):_ ->
                     isSearchedVar i a1 || isSearchedVar i a2
                   _  -> False
-                    in return $ Just (s, name, t, b)
-              else return Nothing
         _ -> return Nothing
+    _ -> return Nothing
+  where
+    lst :: [G.LHsExpr Id]
+    lst = sortBy (cmp `on` G.getLoc) $ listifySpans tcs (lineNo, colNo)
 
 infinitePrefixSupply :: String -> [String]
 infinitePrefixSupply "undefined" = repeat "undefined"

Language/Haskell/GhcMod/Find.hs

@@ -1,9 +1,8 @@
-{-# LANGUAGE CPP, BangPatterns #-}
+{-# LANGUAGE CPP, BangPatterns, DoAndIfThenElse #-}
 
 module Language.Haskell.GhcMod.Find
 #ifndef SPEC
-  (
+  ( Symbol
-    Symbol
   , SymbolDb
   , loadSymbolDb
   , lookupSymbol
@@ -16,48 +15,39 @@ module Language.Haskell.GhcMod.Find
   where
 
 import Control.Applicative ((<$>))
-import Control.Monad (when, void)
+import Control.Monad (when, void, (<=<))
 import Data.Function (on)
 import Data.List (groupBy, sort)
-import Data.Maybe (fromMaybe)
 import qualified GHC as G
 import Language.Haskell.GhcMod.Convert
+import Language.Haskell.GhcMod.Gap (listVisibleModules)
 import Language.Haskell.GhcMod.Monad
+import Language.Haskell.GhcMod.PathsAndFiles
 import Language.Haskell.GhcMod.Types
 import Language.Haskell.GhcMod.Utils
-import Language.Haskell.GhcMod.PathsAndFiles
+import Language.Haskell.GhcMod.World (timedPackageCaches)
-import Language.Haskell.GhcMod.Gap (listVisibleModules)
 import Name (getOccString)
 import Module (moduleName)
 import System.Directory (doesFileExist, getModificationTime)
-import System.FilePath ((</>), takeDirectory)
+import System.FilePath ((</>))
 import System.IO
 
-#ifndef MIN_VERSION_containers
-#define MIN_VERSION_containers(x,y,z) 1
-#endif
-
-#if MIN_VERSION_containers(0,5,0)
 import Data.Map (Map)
 import qualified Data.Map as M
-#else
-import Data.Map (Map)
-import qualified Data.Map as M
-#endif
 
 ----------------------------------------------------------------
 
 -- | Type of function and operation names.
 type Symbol = String
 -- | Database from 'Symbol' to \['ModuleString'\].
-data SymbolDb = SymbolDb {
+data SymbolDb = SymbolDb
-    table :: Map Symbol [ModuleString]
+  { table             :: Map Symbol [ModuleString]
-  , packageCachePath :: FilePath
   , symbolDbCachePath :: FilePath
   } deriving (Show)
 
-isOutdated :: SymbolDb -> IO Bool
+isOutdated :: (GmEnv m, IOish m) => SymbolDb -> m Bool
-isOutdated db = symbolDbCachePath db `isOlderThan` packageCachePath db
+isOutdated db =
+  liftIO . (isOlderThan (symbolDbCachePath db) <=< timedPackageCaches) =<< cradle
 
 ----------------------------------------------------------------
 
@@ -72,7 +62,7 @@ lookupSymbol :: IOish m => Symbol -> SymbolDb -> GhcModT m String
 lookupSymbol sym db = convert' $ lookupSym sym db
 
 lookupSym :: Symbol -> SymbolDb -> [ModuleString]
-lookupSym sym db = fromMaybe [] $ M.lookup sym $ table db
+lookupSym sym db = M.findWithDefault [] sym $ table db
 
 ---------------------------------------------------------------
 
@@ -83,14 +73,14 @@ loadSymbolDb = do
   tmpdir <- cradleTempDir <$> cradle
   file   <- liftIO $ chop <$> readProcess ghcMod ["dumpsym", tmpdir] ""
   !db    <- M.fromAscList . map conv . lines <$> liftIO (readFile file)
-    return $ SymbolDb {
+  return $ SymbolDb
-        table = db
+    { table             = db
-      , packageCachePath = takeDirectory file </> packageCache
     , symbolDbCachePath = file
     }
   where
-    conv :: String -> (Symbol,[ModuleString])
+    conv :: String -> (Symbol, [ModuleString])
     conv = read
+    chop :: String -> String
     chop "" = ""
     chop xs = init xs
 
@@ -102,33 +92,36 @@ loadSymbolDb = do
 --   The file name is printed.
 
 dumpSymbol :: IOish m => FilePath -> GhcModT m String
-dumpSymbol dir = runGmPkgGhc $ do
+dumpSymbol dir = do
-    let cache = dir </> symbolCacheFile
+  crdl <- cradle
-        pkgdb = dir </> packageCache
+  runGmPkgGhc $ do
-
+    create <- liftIO $ isOlderThan cache =<< timedPackageCaches crdl
-    create <- liftIO $ cache `isOlderThan` pkgdb
+    when create $
-    when create $ (liftIO . writeSymbolCache cache) =<< getGlobalSymbolTable
+      liftIO . writeSymbolCache cache =<< getGlobalSymbolTable
     return $ unlines [cache]
+  where
+    cache = dir </> symbolCacheFile
 
 writeSymbolCache :: FilePath
-                 -> [(Symbol,[ModuleString])]
+                 -> [(Symbol, [ModuleString])]
                  -> IO ()
 writeSymbolCache cache sm =
   void . withFile cache WriteMode $ \hdl ->
     mapM (hPrint hdl) sm
 
-isOlderThan :: FilePath -> FilePath -> IO Bool
+-- | Check whether given file is older than any file from the given set.
-isOlderThan cache file = do
+-- Returns True if given file does not exist.
+isOlderThan :: FilePath -> [TimedFile] -> IO Bool
+isOlderThan cache files = do
   exist <- doesFileExist cache
-    if not exist then
+  if not exist
-        return True
+  then return True
   else do
     tCache <- getModificationTime cache
-        tFile <- getModificationTime file
+    return $ any (tCache <=) $ map tfTime files -- including equal just in case
-        return $ tCache <= tFile -- including equal just in case
 
 -- | Browsing all functions in all system modules.
-getGlobalSymbolTable :: LightGhc [(Symbol,[ModuleString])]
+getGlobalSymbolTable :: LightGhc [(Symbol, [ModuleString])]
 getGlobalSymbolTable = do
   df  <- G.getSessionDynFlags
   let mods = listVisibleModules df
@@ -138,14 +131,15 @@ getGlobalSymbolTable = do
 
 extractBindings :: (Maybe G.ModuleInfo, G.Module)
                 -> [(Symbol, ModuleString)]
-extractBindings (Nothing,_)  = []
+extractBindings (Nothing,  _)   = []
-extractBindings (Just inf,mdl) =
+extractBindings (Just inf, mdl) =
-    map (\name -> (getOccString name, moduleNameString $ moduleName mdl)) names
+  map (\name -> (getOccString name, modStr)) names
   where
     names  = G.modInfoExports inf
+    modStr = ModuleString $ moduleNameString $ moduleName mdl
 
-collectModules :: [(Symbol,ModuleString)]
+collectModules :: [(Symbol, ModuleString)]
-               -> [(Symbol,[ModuleString])]
+               -> [(Symbol, [ModuleString])]
 collectModules = map tieup . groupBy ((==) `on` fst) . sort
   where
     tieup x = (head (map fst x), map snd x)

Language/Haskell/GhcMod/Gap.hs

@@ -103,6 +103,8 @@ import Parser
 import SrcLoc
 import Packages
 
+import Language.Haskell.GhcMod.Types (Expression(..))
+
 ----------------------------------------------------------------
 ----------------------------------------------------------------
 --
@@ -325,8 +327,8 @@ filterOutChildren get_thing xs
   where
     implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
 
-infoThing :: GhcMonad m => String -> m SDoc
+infoThing :: GhcMonad m => Expression -> m SDoc
-infoThing str = do
+infoThing (Expression str) = do
     names <- parseName str
 #if __GLASGOW_HASKELL__ >= 708
     mb_stuffs <- mapM (getInfo False) names

Language/Haskell/GhcMod/Info.hs

@@ -30,21 +30,22 @@ info :: IOish m
      -> Expression   -- ^ A Haskell expression.
      -> GhcModT m String
 info file expr =
-    ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $
+  ghandle handler $
+    runGmlT' [Left file] deferErrors $
+      withContext $
         convert <$> options <*> body
   where
     handler (SomeException ex) = do
-        gmLog GmException "info" $
+      gmLog GmException "info" $ text "" $$ nest 4 (showDoc ex)
-                text "" $$ nest 4 (showDoc ex)
       convert' "Cannot show info"
 
+    body :: GhcMonad m => m String
     body = do
       sdoc  <- Gap.infoThing expr
       st    <- getStyle
       dflag <- G.getSessionDynFlags
       return $ showPage dflag st sdoc
 
-
 ----------------------------------------------------------------
 
 -- | Obtaining type of a target expression. (GHCi's type:)
@@ -54,14 +55,14 @@ types :: IOish m
       -> Int          -- ^ Column number.
       -> GhcModT m String
 types file lineNo colNo =
-    ghandle handler $ runGmlT' [Left file] deferErrors $ withContext $ do
+  ghandle handler $
+    runGmlT' [Left file] deferErrors $
+      withContext $ do
         crdl         <- cradle
         modSum       <- Gap.fileModSummary (cradleCurrentDir crdl </> file)
         srcSpanTypes <- getSrcSpanType modSum lineNo colNo
-
         dflag        <- G.getSessionDynFlags
         st           <- getStyle
-
         convert' $ map (toTup dflag st) $ sortBy (cmp `on` fst) srcSpanTypes
  where
    handler (SomeException ex) = do

Language/Haskell/GhcMod/Types.hs

@@ -83,7 +83,6 @@ data Options = Options {
   , hlintOpts     :: [String]
   } deriving (Show)
 
-
 -- | A default 'Options'.
 defaultOptions :: Options
 defaultOptions = Options {
@@ -93,7 +92,7 @@ defaultOptions = Options {
   , ghcProgram     = "ghc"
   , ghcPkgProgram  = "ghc-pkg"
   , cabalProgram   = "cabal"
-  , ghcUserOptions= []
+  , ghcUserOptions = []
   , operators      = False
   , detailed       = False
   , qualified      = False
@@ -140,30 +139,30 @@ type PackageId  = String
 type Package = (PackageBaseName, PackageVersion, PackageId)
 
 pkgName :: Package -> PackageBaseName
-pkgName (n,_,_) = n
+pkgName (n, _, _) = n
 
 pkgVer :: Package -> PackageVersion
-pkgVer (_,v,_) = v
+pkgVer (_, v, _) = v
 
 pkgId :: Package -> PackageId
-pkgId (_,_,i) = i
+pkgId (_, _, i) = i
 
 showPkg :: Package -> String
-showPkg (n,v,_) = intercalate "-" [n,v]
+showPkg (n, v, _) = intercalate "-" [n, v]
 
 showPkgId :: Package -> String
-showPkgId (n,v,i) = intercalate "-" [n,v,i]
+showPkgId (n, v, i) = intercalate "-" [n, v, i]
 
 -- | Haskell expression.
-type Expression = String
+newtype Expression = Expression { getExpression :: String }
+  deriving (Show, Eq, Ord)
 
 -- | Module name.
-type ModuleString = String
+newtype ModuleString = ModuleString { getModuleString :: String }
+  deriving (Show, Read, Eq, Ord)
 
--- | A Module
+data GmLogLevel =
-type Module = [String]
+    GmSilent
-
-data GmLogLevel = GmSilent
   | GmPanic
   | GmException
   | GmError
@@ -180,28 +179,25 @@ data GmModuleGraph = GmModuleGraph {
   } deriving (Eq, Ord, Show, Read, Generic, Typeable)
 
 instance Serialize GmModuleGraph where
-    put GmModuleGraph {..} = let
+  put GmModuleGraph {..} = put (mpim, graph)
+    where
       mpim :: Map ModulePath Integer
+      mpim = Map.fromList $ Map.keys gmgGraph `zip` [0..]
       graph :: Map Integer (Set Integer)
-
+      graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
-        mpim = Map.fromList $
-                (Map.keys gmgGraph) `zip` [0..]
       mpToInt :: ModulePath -> Integer
       mpToInt mp = fromJust $ Map.lookup mp mpim
 
-        graph = Map.map (Set.map mpToInt) $ Map.mapKeys mpToInt gmgGraph
-        in put (mpim, graph)
-
   get = do
     (mpim :: Map ModulePath Integer, graph :: Map Integer (Set Integer)) <- get
-     let
+    let impm = swapMap mpim
-         swapMap = Map.fromList . map swap . Map.toList
-         swap (a,b) = (b,a)
-         impm = swapMap mpim
         intToMp i = fromJust $ Map.lookup i impm
         mpGraph :: Map ModulePath (Set ModulePath)
         mpGraph = Map.map (Set.map intToMp) $ Map.mapKeys intToMp graph
     return $ GmModuleGraph mpGraph
+    where
+      swapMap :: (Ord k, Ord v) => Map k v -> Map v k
+      swapMap = Map.fromList . map (\(x, y) -> (y, x)) . Map.toList
 
 instance Monoid GmModuleGraph where
   mempty  = GmModuleGraph mempty
@@ -211,15 +207,15 @@ instance Monoid GmModuleGraph where
 data GmComponentType = GMCRaw
                      | GMCResolved
 data GmComponent (t :: GmComponentType) eps = GmComponent {
-      gmcHomeModuleGraph :: GmModuleGraph,
+    gmcHomeModuleGraph :: GmModuleGraph
-      gmcName            :: ChComponentName,
+  , gmcName            :: ChComponentName
-      gmcGhcOpts         :: [GHCOption],
+  , gmcGhcOpts         :: [GHCOption]
-      gmcGhcPkgOpts      :: [GHCOption],
+  , gmcGhcPkgOpts      :: [GHCOption]
-      gmcGhcSrcOpts      :: [GHCOption],
+  , gmcGhcSrcOpts      :: [GHCOption]
-      gmcGhcLangOpts     :: [GHCOption],
+  , gmcGhcLangOpts     :: [GHCOption]
-      gmcRawEntrypoints  :: ChEntrypoint,
+  , gmcRawEntrypoints  :: ChEntrypoint
-      gmcEntrypoints     :: eps,
+  , gmcEntrypoints     :: eps
-      gmcSourceDirs      :: [FilePath]
+  , gmcSourceDirs      :: [FilePath]
   } deriving (Eq, Ord, Show, Read, Generic, Functor)
 
 instance Serialize eps => Serialize (GmComponent t eps)
@@ -236,11 +232,15 @@ instance Show ModuleName where
   show mn = "ModuleName " ++ show (moduleNameString mn)
 
 instance Read ModuleName where
-    readsPrec d r = readParen (d > app_prec)
+  readsPrec d =
-                         (\r' -> [(mkModuleName m,t) |
+    readParen
-                                 ("ModuleName",s) <- lex r',
+      (d > app_prec)
-                                 (m,t) <- readsPrec (app_prec+1) s]) r
+      (\r' -> [ (mkModuleName m, t)
-        where app_prec = 10
+              | ("ModuleName", s) <- lex r'
+              , (m, t)            <- readsPrec (app_prec + 1) s
+              ])
+    where
+      app_prec = 10
 
 data GhcModError
   = GMENoMsg

Language/Haskell/GhcMod/Utils.hs

@@ -15,26 +15,26 @@
 -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DoAndIfThenElse #-}
+
 module Language.Haskell.GhcMod.Utils (
     module Language.Haskell.GhcMod.Utils
   , module Utils
   , readProcess
   ) where
 
-import Control.Arrow
 import Control.Applicative
 import Data.Char
+import Exception
 import Language.Haskell.GhcMod.Error
 import Language.Haskell.GhcMod.Monad.Types
-import Exception
 import System.Directory (getCurrentDirectory, setCurrentDirectory, doesFileExist,
-                         getTemporaryDirectory, canonicalizePath, doesFileExist)
+                         getTemporaryDirectory, canonicalizePath)
-import System.Process (readProcess)
+import System.Environment
-import System.Directory ()
 import System.FilePath (splitDrive, takeDirectory, takeFileName, pathSeparators,
                         (</>))
 import System.IO.Temp (createTempDirectory)
-import System.Environment
+import System.Process (readProcess)
 import Text.Printf
 
 import Paths_ghc_mod (getLibexecDir)
@@ -44,32 +44,23 @@ import Utils
 dropWhileEnd :: (a -> Bool) -> [a] -> [a]
 dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
 
-extractParens :: String -> String
-extractParens str = extractParens' str 0
- where
-   extractParens' :: String -> Int -> String
-   extractParens' [] _ = []
-   extractParens' (s:ss) level
-       | s `elem` "([{" = s : extractParens' ss (level+1)
-       | level == 0 = extractParens' ss 0
-       | s `elem` "}])" && level == 1 = [s]
-       | s `elem` "}])" = s : extractParens' ss (level-1)
-       | otherwise = s : extractParens' ss level
-
 withDirectory_ :: (MonadIO m, ExceptionMonad m) => FilePath -> m a -> m a
 withDirectory_ dir action =
-    gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory)
+  gbracket
+    (liftIO getCurrentDirectory)
+    (liftIO . setCurrentDirectory)
     (\_ -> liftIO (setCurrentDirectory dir) >> action)
 
 uniqTempDirName :: FilePath -> FilePath
-uniqTempDirName dir = ("ghc-mod"++) $ uncurry (++)
+uniqTempDirName dir =
-        $ map escapeDriveChar *** map escapePathChar
+  "ghc-mod" ++ map escapeDriveChar drive ++ map escapePathChar path
-        $ splitDrive dir
   where
+    (drive, path) = splitDrive dir
+    escapeDriveChar :: Char -> Char
     escapeDriveChar c
       | isAlphaNum c = c
       | otherwise     = '-'
-
+    escapePathChar :: Char -> Char
     escapePathChar c
       | c `elem` pathSeparators = '-'
       | otherwise               = c
@@ -131,10 +122,8 @@ tryFindGhcModTreeLibexecDir :: IO (Maybe FilePath)
 tryFindGhcModTreeLibexecDir  = do
   exe <- getExecutablePath'
   dir <- case takeFileName exe of
-    "ghc" -> do -- we're probably in ghci; try CWD
+    "ghc" -> getCurrentDirectory -- we're probably in ghci; try CWD
-        getCurrentDirectory
+    _     -> return $ (!!4) $ iterate takeDirectory exe
-    _ ->
-        return $ (!!4) $ iterate takeDirectory exe
   exists <- doesFileExist $ dir </> "ghc-mod.cabal"
   return $ if exists
            then Just dir

src/GHCMod.hs

@@ -513,8 +513,8 @@ autoCmd       = withParseCmd [] $ locAction  "auto"   auto
 refineCmd     = withParseCmd [] $ locAction' "refine" refine
 
 infoCmd       = withParseCmd [] $ action
-  where action [file,_,expr] = info file expr
+  where action [file,_,expr] = info file $ Expression expr
-        action [file,expr]   = info file expr
+        action [file,expr]   = info file $ Expression expr
         action _ = throw $ InvalidCommandLine (Left "info")
 
 legacyInteractiveCmd = withParseCmd [] $ \[] -> legacyInteractive >> return ""
@@ -528,9 +528,9 @@ 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' :: String -> (String -> Int -> Int -> Expression -> 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) (Expression expr)
-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) (Expression expr)
 locAction' cmd _ _ = throw $ InvalidCommandLine (Left cmd)
 
 

src/Misc.hs

@@ -75,7 +75,7 @@ getDb (SymDbReq ref _) = do
 
 checkDb :: IOish m => SymDbReq -> SymbolDb -> GhcModT m SymbolDb
 checkDb (SymDbReq ref act) db = do
-    outdated <- liftIO $ isOutdated db
+    outdated <- isOutdated db
     if outdated then do
         -- async and wait here is unnecessary because this is essentially
         -- synchronous. But Async can be used a cache.

test/FindSpec.hs

@@ -9,4 +9,4 @@ spec = do
     describe "db <- loadSymbolDb" $ do
         it "lookupSymbol' db \"head\"  contains at least `Data.List'" $ do
             db <- runD loadSymbolDb
-            lookupSym "head" db `shouldContain` ["Data.List"]
+            lookupSym "head" db `shouldContain` [ModuleString "Data.List"]

test/InfoSpec.hs

@@ -34,17 +34,17 @@ spec = do
     describe "info" $ do
         it "works for non exported functions" $ do
             let tdir = "test/data/non-exported"
-            res <- runD' tdir $ info "Fib.hs" "fib"
+            res <- runD' tdir $ info "Fib.hs" $ Expression "fib"
             res `shouldSatisfy` ("fib :: Int -> Int" `isPrefixOf`)
 
         it "works with a module using TemplateHaskell" $ do
             let tdir = "test/data/template-haskell"
-            res <- runD' tdir $ info "Bar.hs" "foo"
+            res <- runD' tdir $ info "Bar.hs" $ Expression "foo"
             res `shouldSatisfy` ("foo :: ExpQ" `isPrefixOf`)
 
         it "works with a module that imports another module using TemplateHaskell" $ do
             let tdir = "test/data/template-haskell"
-            res <- runD' tdir $ info "ImportsTH.hs" "bar"
+            res <- runD' tdir $ info "ImportsTH.hs" $ Expression "bar"
             res `shouldSatisfy` ("bar :: [Char]" `isPrefixOf`)
 
 getDistDir :: IO FilePath

test/UtilsSpec.hs

@@ -1,11 +0,0 @@
-module UtilsSpec where
-
-import Language.Haskell.GhcMod.Utils
-import Test.Hspec
-
-spec :: Spec
-spec = do
-    describe "extractParens" $ do
-        it "extracts the part of a string surrounded by parentheses" $ do
-            extractParens "asdasdasd ( hello [ world ] )()() kljlkjlkjlk" `shouldBe` "( hello [ world ] )"
-            extractParens "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")][][]" `shouldBe` "[(PackageName \"template-haskell\",InstalledPackageId \"template-haskell-2.9.0.0-8e2a49468f3b663b671c437d8579cd28\"),(PackageName \"base\",InstalledPackageId \"base-4.7.0.0-e4567cc9a8ef85f78696b03f3547b6d5\"),(PackageName \"Cabal\",InstalledPackageId \"Cabal-1.18.1.3-b9a44a5b15a8bce47d40128ac326e369\")]"