find functions went to lib.
This commit is contained in:
parent
3059a295dc
commit
390c509144
49
Language/Haskell/GhcMod/Find.hs
Normal file
49
Language/Haskell/GhcMod/Find.hs
Normal file
@ -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)
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user