From 390c509144f7460d796e32779dc0ec1efaa04f2d Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 24 Apr 2014 17:02:50 +0900 Subject: [PATCH] find functions went to lib. --- Language/Haskell/GhcMod/Find.hs | 49 +++++++++++++++++++++++++++++ Language/Haskell/GhcMod/Ghc.hs | 6 ++++ Language/Haskell/GhcMod/Internal.hs | 4 --- ghc-mod.cabal | 3 +- src/GHCModi.hs | 44 ++++++-------------------- 5 files changed, 66 insertions(+), 40 deletions(-) create mode 100644 Language/Haskell/GhcMod/Find.hs diff --git a/Language/Haskell/GhcMod/Find.hs b/Language/Haskell/GhcMod/Find.hs new file mode 100644 index 0000000..9cf3a1b --- /dev/null +++ b/Language/Haskell/GhcMod/Find.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE CPP, BangPatterns #-} + +module Language.Haskell.GhcMod.Find where + +import Data.Function (on) +import Data.List (groupBy, sort) +import Data.Maybe (fromMaybe) +import GHC (Ghc) +import qualified GHC as G +import Language.Haskell.GhcMod +import Language.Haskell.GhcMod.Browse (browseAll) +import Language.Haskell.GhcMod.Types (convert) + +#ifndef MIN_VERSION_containers +#define MIN_VERSION_containers(x,y,z) 1 +#endif + +#if MIN_VERSION_containers(0,5,0) +import Control.DeepSeq (force) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +#else +import Data.Map (Map) +import qualified Data.Map as M +#endif + +-- | Type of key for `SymMdlDb`. +type Symbol = String +-- | Database from 'Symbol' to modules. +newtype SymMdlDb = SymMdlDb (Map Symbol [ModuleString]) + +-- | Creating 'SymMdlDb'. +getSymMdlDb :: Ghc SymMdlDb +getSymMdlDb = do + sm <- G.getSessionDynFlags >>= browseAll +#if MIN_VERSION_containers(0,5,0) + let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm + !m = force $ M.fromList sms +#else + let !sms = map tieup $ groupBy ((==) `on` fst) $ sort sm + !m = M.fromList sms +#endif + return (SymMdlDb m) + where + tieup x = (head (map fst x), map snd x) + +-- | Looking up 'SymMdlDb' with 'Symbol' to find modules. +lookupSym :: Options -> Symbol -> SymMdlDb -> String +lookupSym opt sym (SymMdlDb db) = convert opt $ fromMaybe [] (M.lookup sym db) diff --git a/Language/Haskell/GhcMod/Ghc.hs b/Language/Haskell/GhcMod/Ghc.hs index b6c49b0..c36c213 100644 --- a/Language/Haskell/GhcMod/Ghc.hs +++ b/Language/Haskell/GhcMod/Ghc.hs @@ -8,10 +8,16 @@ module Language.Haskell.GhcMod.Ghc ( , info , types , modules + -- * 'SymMdlDb' + , Symbol + , SymMdlDb + , getSymMdlDb + , lookupSym ) where import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.Check +import Language.Haskell.GhcMod.Find import Language.Haskell.GhcMod.GHCApi import Language.Haskell.GhcMod.Info import Language.Haskell.GhcMod.List diff --git a/Language/Haskell/GhcMod/Internal.hs b/Language/Haskell/GhcMod/Internal.hs index 6266576..1ef2339 100644 --- a/Language/Haskell/GhcMod/Internal.hs +++ b/Language/Haskell/GhcMod/Internal.hs @@ -26,18 +26,14 @@ module Language.Haskell.GhcMod.Internal ( , setTargetFiles , addTargetFiles , handleErrMsg - , browseAll -- * 'Ghc' Choice , (||>) , goNext , runAnyOne -- * 'GhcMonad' Choice , (|||>) - -- * Misc - , convert ) where -import Language.Haskell.GhcMod.Browse import Language.Haskell.GhcMod.CabalApi import Language.Haskell.GhcMod.ErrMsg import Language.Haskell.GhcMod.GHCApi diff --git a/ghc-mod.cabal b/ghc-mod.cabal index bd8b98a..8bdcdf6 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -57,6 +57,7 @@ Library Language.Haskell.GhcMod.ErrMsg Language.Haskell.GhcMod.Flag Language.Haskell.GhcMod.GHCApi + Language.Haskell.GhcMod.Find Language.Haskell.GhcMod.GHCChoice Language.Haskell.GhcMod.Gap Language.Haskell.GhcMod.GhcPkg @@ -69,6 +70,7 @@ Library Language.Haskell.GhcMod.Types Build-Depends: base >= 4.0 && < 5 , containers + , deepseq , directory , filepath , ghc @@ -108,7 +110,6 @@ Executable ghc-modi HS-Source-Dirs: src Build-Depends: base >= 4.0 && < 5 , containers - , deepseq , directory , filepath , ghc diff --git a/src/GHCModi.hs b/src/GHCModi.hs index a6bfa2b..29a3cea 100644 --- a/src/GHCModi.hs +++ b/src/GHCModi.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP, BangPatterns #-} {-# LANGUAGE DeriveDataTypeable #-} -- Commands: @@ -24,8 +23,7 @@ import Control.Exception (SomeException(..), Exception) import qualified Control.Exception as E import Control.Monad (when, void) import CoreMonad (liftIO) -import Data.Function (on) -import Data.List (groupBy, sort, find) +import Data.List (find) import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as S @@ -44,24 +42,10 @@ import System.Directory (setCurrentDirectory) import System.Environment (getArgs) import System.IO (hFlush,stdout) -#ifndef MIN_VERSION_containers -#define MIN_VERSION_containers(x,y,z) 1 -#endif - -#if MIN_VERSION_containers(0,5,0) -import Control.DeepSeq (force) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as M -#else -import Data.Map (Map) -import qualified Data.Map as M -#endif - import Boot ---------------------------------------------------------------- -type DB = Map String [String] type Logger = IO String ---------------------------------------------------------------- @@ -119,9 +103,7 @@ main = E.handle cmdHandler $ where -- this is just in case. -- If an error is caught here, it is a bug of GhcMod library. - someHandler (SomeException e) = do - let ret = convert opt $ "ghc-modi:0:0:" ++ show e - putStr ret + someHandler (SomeException _) = do putStrLn "NG" ---------------------------------------------------------------- @@ -134,24 +116,16 @@ run cradle mlibdir opt body = G.runGhc mlibdir $ do ---------------------------------------------------------------- -setupDB :: Cradle -> Maybe FilePath -> Options -> MVar DB -> IO () +setupDB :: Cradle -> Maybe FilePath -> Options -> MVar SymMdlDb -> IO () setupDB cradle mlibdir opt mvar = E.handle handler $ do - sm <- run cradle mlibdir opt $ \_ -> G.getSessionDynFlags >>= browseAll -#if MIN_VERSION_containers(0,5,0) - let !sms = force $ map tieup $ groupBy ((==) `on` fst) $ sort sm - !m = force $ M.fromList sms -#else - let !sms = map tieup $ groupBy ((==) `on` fst) $ sort sm - !m = M.fromList sms -#endif - putMVar mvar m + db <- run cradle mlibdir opt $ \_ -> getSymMdlDb + putMVar mvar db where - tieup x = (head (map fst x), map snd x) - handler (SomeException _) = return () + handler (SomeException _) = return () -- fixme: put emptyDb? ---------------------------------------------------------------- -loop :: Options -> Set FilePath -> MVar DB -> Logger -> Ghc () +loop :: Options -> Set FilePath -> MVar SymMdlDb -> Logger -> Ghc () loop opt set mvar readLog = do cmdArg <- liftIO getLine let (cmd,arg') = break (== ' ') cmdArg @@ -211,11 +185,11 @@ checkStx opt set file readLog = do return $ Just mainfile isMain m = G.moduleNameString (G.moduleName (G.ms_mod m)) == "Main" -findSym :: Options -> Set FilePath -> String -> MVar DB +findSym :: Options -> Set FilePath -> String -> MVar SymMdlDb -> Ghc (String, Bool, Set FilePath) findSym opt set sym mvar = do db <- liftIO $ readMVar mvar - let ret = convert opt $ fromMaybe [] (M.lookup sym db) -- fixme + let ret = lookupSym opt sym db return (ret, True, set) lintStx :: Options -> Set FilePath -> FilePath