Using io-choice.
This commit is contained in:
parent
d373966625
commit
f3725127bc
42
AA.hs
42
AA.hs
@ -1,42 +0,0 @@
|
|||||||
{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
||||||
|
|
||||||
module AA where
|
|
||||||
|
|
||||||
import Control.Applicative
|
|
||||||
import Control.Exception
|
|
||||||
import Control.Monad
|
|
||||||
import CoreMonad
|
|
||||||
import Data.Typeable
|
|
||||||
import Exception
|
|
||||||
import GHC
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
|
||||||
|
|
||||||
instance Applicative Ghc where
|
|
||||||
pure = return
|
|
||||||
(<*>) = ap
|
|
||||||
|
|
||||||
instance Alternative Ghc where
|
|
||||||
empty = goNext
|
|
||||||
x <|> y = x `gcatch` (\(_ :: SomeException) -> y)
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
|
||||||
|
|
||||||
{-| Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.
|
|
||||||
-}
|
|
||||||
goNext :: Ghc a
|
|
||||||
goNext = liftIO $ throwIO AltGhcgoNext
|
|
||||||
|
|
||||||
{-| Run any one 'Ghc' monad.
|
|
||||||
-}
|
|
||||||
runAnyOne :: [Ghc a] -> Ghc a
|
|
||||||
runAnyOne = foldr (<|>) goNext
|
|
||||||
|
|
||||||
----------------------------------------------------------------
|
|
||||||
|
|
||||||
{-| Exception to control 'Alternative' 'Ghc'.
|
|
||||||
-}
|
|
||||||
data AltGhcgoNext = AltGhcgoNext deriving (Show, Typeable)
|
|
||||||
|
|
||||||
instance Exception AltGhcgoNext
|
|
3
Cabal.hs
3
Cabal.hs
@ -14,6 +14,7 @@ import Distribution.Verbosity (silent)
|
|||||||
import ErrMsg
|
import ErrMsg
|
||||||
import GHC
|
import GHC
|
||||||
import GHCApi
|
import GHCApi
|
||||||
|
import GHCChoice
|
||||||
import qualified Gap
|
import qualified Gap
|
||||||
import Language.Haskell.Extension
|
import Language.Haskell.Extension
|
||||||
import System.Directory
|
import System.Directory
|
||||||
@ -26,7 +27,7 @@ importDirs :: [String]
|
|||||||
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
|
importDirs = [".","..","../..","../../..","../../../..","../../../../.."]
|
||||||
|
|
||||||
initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
|
initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader)
|
||||||
initializeGHC opt fileName ghcOptions logging = withCabal <|> withoutCabal
|
initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal
|
||||||
where
|
where
|
||||||
withoutCabal = do
|
withoutCabal = do
|
||||||
logReader <- initSession opt ghcOptions importDirs logging
|
logReader <- initSession opt ghcOptions importDirs logging
|
||||||
|
@ -5,17 +5,17 @@ module CabalDev (modifyOptions) where
|
|||||||
options ghc-mod uses to check the source. Otherwise just pass it on.
|
options ghc-mod uses to check the source. Otherwise just pass it on.
|
||||||
-}
|
-}
|
||||||
|
|
||||||
import Control.Applicative ((<$>),(<|>))
|
import Control.Applicative ((<$>))
|
||||||
import Control.Exception (throwIO)
|
import Control.Exception (throwIO)
|
||||||
|
import Control.Exception.IOChoice
|
||||||
import Data.List (find)
|
import Data.List (find)
|
||||||
import System.Directory
|
import System.Directory
|
||||||
import System.FilePath (splitPath,joinPath,(</>))
|
import System.FilePath (splitPath,joinPath,(</>))
|
||||||
import Text.Regex.Posix ((=~))
|
import Text.Regex.Posix ((=~))
|
||||||
import Types
|
import Types
|
||||||
import Data.Alternative.IO ()
|
|
||||||
|
|
||||||
modifyOptions :: Options -> IO Options
|
modifyOptions :: Options -> IO Options
|
||||||
modifyOptions opts = found <|> notFound
|
modifyOptions opts = found ||> notFound
|
||||||
where
|
where
|
||||||
found = addPath opts <$> findCabalDev
|
found = addPath opts <$> findCabalDev
|
||||||
notFound = return opts
|
notFound = return opts
|
||||||
|
25
GHCChoice.hs
Normal file
25
GHCChoice.hs
Normal file
@ -0,0 +1,25 @@
|
|||||||
|
{-# LANGUAGE ScopedTypeVariables #-}
|
||||||
|
|
||||||
|
module GHCChoice where
|
||||||
|
|
||||||
|
import Control.Exception
|
||||||
|
import CoreMonad
|
||||||
|
import Exception
|
||||||
|
import GHC
|
||||||
|
|
||||||
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
(||>) :: Ghc a -> Ghc a -> Ghc a
|
||||||
|
x ||> y = x `gcatch` (\(_ :: IOException) -> y)
|
||||||
|
|
||||||
|
----------------------------------------------------------------
|
||||||
|
|
||||||
|
{-| Go to the next 'Ghc' monad by throwing 'AltGhcgoNext'.
|
||||||
|
-}
|
||||||
|
goNext :: Ghc a
|
||||||
|
goNext = liftIO . throwIO $ userError "goNext"
|
||||||
|
|
||||||
|
{-| Run any one 'Ghc' monad.
|
||||||
|
-}
|
||||||
|
runAnyOne :: [Ghc a] -> Ghc a
|
||||||
|
runAnyOne = foldr (||>) goNext
|
4
Gap.hs
4
Gap.hs
@ -16,12 +16,12 @@ module Gap (
|
|||||||
#endif
|
#endif
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import AA ()
|
|
||||||
import Control.Applicative hiding (empty)
|
import Control.Applicative hiding (empty)
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import DynFlags
|
import DynFlags
|
||||||
import FastString
|
import FastString
|
||||||
import GHC
|
import GHC
|
||||||
|
import GHCChoice
|
||||||
import Language.Haskell.Extension
|
import Language.Haskell.Extension
|
||||||
import Outputable
|
import Outputable
|
||||||
import StringBuffer
|
import StringBuffer
|
||||||
@ -117,7 +117,7 @@ setCtx ms = do
|
|||||||
return (not . null $ top)
|
return (not . null $ top)
|
||||||
#endif
|
#endif
|
||||||
where
|
where
|
||||||
isTop mos = lookupMod <|> returnFalse
|
isTop mos = lookupMod ||> returnFalse
|
||||||
where
|
where
|
||||||
lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True
|
lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True
|
||||||
returnFalse = return False
|
returnFalse = return False
|
||||||
|
4
Info.hs
4
Info.hs
@ -2,7 +2,6 @@
|
|||||||
|
|
||||||
module Info (infoExpr, typeExpr) where
|
module Info (infoExpr, typeExpr) where
|
||||||
|
|
||||||
import AA
|
|
||||||
import Cabal
|
import Cabal
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import CoreUtils
|
import CoreUtils
|
||||||
@ -15,6 +14,7 @@ import Desugar
|
|||||||
import GHC
|
import GHC
|
||||||
import GHC.SYB.Utils
|
import GHC.SYB.Utils
|
||||||
import GHCApi
|
import GHCApi
|
||||||
|
import GHCChoice
|
||||||
import qualified Gap
|
import qualified Gap
|
||||||
import HscTypes
|
import HscTypes
|
||||||
import NameSet
|
import NameSet
|
||||||
@ -127,7 +127,7 @@ pprInfo pefas (thing, fixity, insts)
|
|||||||
|
|
||||||
inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String
|
inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String
|
||||||
inModuleContext opt fileName modstr action errmsg =
|
inModuleContext opt fileName modstr action errmsg =
|
||||||
withGHC (valid <|> invalid <|> return errmsg)
|
withGHC (valid ||> invalid ||> return errmsg)
|
||||||
where
|
where
|
||||||
valid = do
|
valid = do
|
||||||
(file,_) <- initializeGHC opt fileName ["-w"] False
|
(file,_) <- initializeGHC opt fileName ["-w"] False
|
||||||
|
@ -23,14 +23,14 @@ 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
|
ghc-flymake.el ghc-command.el ghc-info.el ghc-ins-mod.el
|
||||||
Executable ghc-mod
|
Executable ghc-mod
|
||||||
Main-Is: GHCMod.hs
|
Main-Is: GHCMod.hs
|
||||||
Other-Modules: AA
|
Other-Modules: Browse
|
||||||
Browse
|
|
||||||
Cabal
|
Cabal
|
||||||
CabalDev
|
CabalDev
|
||||||
Check
|
Check
|
||||||
ErrMsg
|
ErrMsg
|
||||||
Flag
|
Flag
|
||||||
GHCApi
|
GHCApi
|
||||||
|
GHCChoice
|
||||||
Gap
|
Gap
|
||||||
Info
|
Info
|
||||||
Lang
|
Lang
|
||||||
@ -44,13 +44,13 @@ Executable ghc-mod
|
|||||||
GHC-Options: -Wall
|
GHC-Options: -Wall
|
||||||
Build-Depends: base >= 4.0 && < 5
|
Build-Depends: base >= 4.0 && < 5
|
||||||
, Cabal
|
, Cabal
|
||||||
, alternative-io
|
|
||||||
, directory
|
, directory
|
||||||
, filepath
|
, filepath
|
||||||
, ghc
|
, ghc
|
||||||
, ghc-paths
|
, ghc-paths
|
||||||
, ghc-syb-utils
|
, ghc-syb-utils
|
||||||
, hlint >= 1.7.1
|
, hlint >= 1.7.1
|
||||||
|
, io-choice
|
||||||
, old-time
|
, old-time
|
||||||
, process
|
, process
|
||||||
, regex-posix
|
, regex-posix
|
||||||
|
Loading…
Reference in New Issue
Block a user