more applicative.
error msg fix.
This commit is contained in:
parent
7474968486
commit
96cbf68e16
6
Cabal.hs
6
Cabal.hs
@ -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
|
||||
|
17
CabalDev.hs
17
CabalDev.hs
@ -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
|
||||
|
@ -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
9
Gap.hs
@ -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
21
Info.hs
@ -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
|
||||
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user