more applicative.

error msg fix.
This commit is contained in:
Kazu Yamamoto 2012-02-15 14:52:48 +09:00
parent 7474968486
commit 96cbf68e16
6 changed files with 34 additions and 32 deletions

View File

@ -25,11 +25,9 @@ importDirs :: [String]
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
initializeGHC opt fileName ghcOptions logging =
withCabal `gcatch` withoutCabal
initializeGHC opt fileName ghcOptions logging = withCabal <|> withoutCabal
where
withoutCabal :: SomeException -> Ghc (FilePath,LogReader)
withoutCabal _ = do
withoutCabal = do
logReader <- initSession opt ghcOptions importDirs logging
return (fileName,logReader)
withCabal = do

View File

@ -5,21 +5,20 @@ module CabalDev (modifyOptions) where
options ghc-mod uses to check the source. Otherwise just pass it on.
-}
import Control.Applicative ((<$>))
import Control.Exception (SomeException, throwIO)
import Data.List (find)
import GHC (gcatch)
import Control.Applicative ((<$>),(<|>))
import Control.Exception (throwIO)
import Data.List (find)
import System.Directory
import System.FilePath (splitPath,joinPath,(</>))
import Text.Regex.Posix ((=~))
import System.FilePath (splitPath,joinPath,(</>))
import Text.Regex.Posix ((=~))
import Types
import Data.Alternative.IO ()
modifyOptions :: Options -> IO Options
modifyOptions opts = found `gcatch` notFound
modifyOptions opts = found <|> notFound
where
found = addPath opts <$> findCabalDev
notFound :: SomeException -> IO Options
notFound _ = return opts
notFound = return opts
findCabalDev :: IO String
findCabalDev = getCurrentDirectory >>= searchIt . splitPath

View File

@ -1,6 +1,7 @@
module GHCApi where
import Control.Monad
import Control.Exception
import Control.Applicative
import CoreMonad
import DynFlags
import ErrMsg
@ -11,13 +12,13 @@ import Types
----------------------------------------------------------------
withGHC :: (MonadPlus m) => Ghc (m a) -> IO (m a)
withGHC :: Alternative m => Ghc (m a) -> IO (m a)
withGHC body = ghandle ignore $ runGhc (Just libdir) $ do
dflags <- getSessionDynFlags
defaultCleanupHandler dflags body
where
ignore :: (MonadPlus m) => SomeException -> IO (m a)
ignore _ = return mzero
ignore :: Alternative m => SomeException -> IO (m a)
ignore _ = return empty
----------------------------------------------------------------

9
Gap.hs
View File

@ -15,8 +15,8 @@ module Gap (
#endif
) where
import AA ()
import Control.Applicative hiding (empty)
import Control.Exception
import Control.Monad
import DynFlags
import FastString
@ -115,10 +115,7 @@ setCtx ms = do
return (not . null $ top)
#endif
where
isTop mos = lookupMod `gcatch` returnFalse
isTop mos = lookupMod <|> returnFalse
where
lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True
returnFalse = constE $ return False
constE :: a -> (SomeException -> a)
constE func = \_ -> func
returnFalse = return False

21
Info.hs
View File

@ -2,6 +2,7 @@
module Info (infoExpr, typeExpr) where
import AA
import Cabal
import Control.Applicative
import CoreUtils
@ -34,7 +35,8 @@ infoExpr :: Options -> ModuleString -> Expression -> FilePath -> IO String
infoExpr opt modstr expr file = (++ "\n") <$> info opt file modstr expr
info :: Options -> FilePath -> ModuleString -> FilePath -> IO String
info opt fileName modstr expr = inModuleContext opt fileName modstr exprToInfo
info opt fileName modstr expr =
inModuleContext opt fileName modstr exprToInfo "Cannot show info"
where
exprToInfo = infoThing expr
@ -44,7 +46,8 @@ typeExpr :: Options -> ModuleString -> Int -> Int -> FilePath -> IO String
typeExpr opt modstr lineNo colNo file = Info.typeOf opt file modstr lineNo colNo
typeOf :: Options -> FilePath -> ModuleString -> Int -> Int -> IO String
typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr exprToType
typeOf opt fileName modstr lineNo colNo =
inModuleContext opt fileName modstr exprToType errmsg
where
exprToType = do
modSum <- getModSummary $ mkModuleName modstr
@ -66,6 +69,8 @@ typeOf opt fileName modstr lineNo colNo = inModuleContext opt fileName modstr ex
| b `isSubspanOf` a = O.GT
| otherwise = O.EQ
errmsg = convert opt ([] :: [((Int,Int,Int,Int),String)])
findExpr :: TypecheckedModule -> Int -> Int -> [LHsExpr Id]
findExpr tcm line col =
let src = tm_typechecked_source tcm
@ -119,19 +124,20 @@ pprInfo pefas (thing, fixity, insts)
----------------------------------------------------------------
inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> IO String
inModuleContext opt fileName modstr action = withGHC valid
inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String
inModuleContext opt fileName modstr action errmsg =
withGHC (valid <|> invalid <|> return errmsg)
where
valid = do
(file,_) <- initializeGHC opt fileName ["-w"] False
setTargetFile file
load LoadAllTargets
mif setContextFromTarget action invalid
doif setContextFromTarget action
invalid = do
initializeGHC opt fileName ["-w"] False
setTargetBuffer
load LoadAllTargets
mif setContextFromTarget action (return errorMessage)
doif setContextFromTarget action
setTargetBuffer = do
modgraph <- depanal [mkModuleName modstr] True
let imports = concatMap (map (showSDoc . ppr . unLoc)) $
@ -141,9 +147,8 @@ inModuleContext opt fileName modstr action = withGHC valid
importsBuf <- Gap.toStringBuffer header
clkTime <- Gap.liftIO getClockTime
setTargets [Target (TargetModule $ mkModuleName modstr) True (Just (importsBuf, clkTime))]
mif m t e = m >>= \ok -> if ok then t else e
doif m t = m >>= \ok -> if ok then t else goNext
sanitize = fromMaybe "SomeModule" . listToMaybe . words
errorMessage = "Couldn't determine type"
setContextFromTarget :: Ghc Bool
setContextFromTarget = depanal [] False >>= Gap.setCtx

View File

@ -23,7 +23,8 @@ Data-Files: Makefile ghc.el ghc-func.el ghc-doc.el ghc-comp.el
ghc-flymake.el ghc-command.el ghc-info.el ghc-ins-mod.el
Executable ghc-mod
Main-Is: GHCMod.hs
Other-Modules: Browse
Other-Modules: AA
Browse
Cabal
CabalDev
Check
@ -43,6 +44,7 @@ Executable ghc-mod
GHC-Options: -Wall
Build-Depends: base >= 4.0 && < 5
, Cabal
, alternative-io
, directory
, filepath
, ghc