Using io-choice.

This commit is contained in:
Kazu Yamamoto 2012-02-16 14:44:20 +09:00
parent d373966625
commit f3725127bc
7 changed files with 37 additions and 53 deletions

42
AA.hs
View File

@ -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

View File

@ -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

View File

@ -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
View 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
View File

@ -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

View File

@ -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

View File

@ -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