From f3725127bc4f5b9a1a797f6a47f783a388ad3e1e Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Thu, 16 Feb 2012 14:44:20 +0900 Subject: [PATCH] Using io-choice. --- AA.hs | 42 ------------------------------------------ Cabal.hs | 3 ++- CabalDev.hs | 6 +++--- GHCChoice.hs | 25 +++++++++++++++++++++++++ Gap.hs | 4 ++-- Info.hs | 4 ++-- ghc-mod.cabal | 6 +++--- 7 files changed, 37 insertions(+), 53 deletions(-) delete mode 100644 AA.hs create mode 100644 GHCChoice.hs diff --git a/AA.hs b/AA.hs deleted file mode 100644 index f919c40..0000000 --- a/AA.hs +++ /dev/null @@ -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 diff --git a/Cabal.hs b/Cabal.hs index d47bc3f..91e75cb 100644 --- a/Cabal.hs +++ b/Cabal.hs @@ -14,6 +14,7 @@ import Distribution.Verbosity (silent) import ErrMsg import GHC import GHCApi +import GHCChoice import qualified Gap import Language.Haskell.Extension import System.Directory @@ -26,7 +27,7 @@ importDirs :: [String] importDirs = [".","..","../..","../../..","../../../..","../../../../.."] initializeGHC :: Options -> FilePath -> [String] -> Bool -> Ghc (FilePath,LogReader) -initializeGHC opt fileName ghcOptions logging = withCabal <|> withoutCabal +initializeGHC opt fileName ghcOptions logging = withCabal ||> withoutCabal where withoutCabal = do logReader <- initSession opt ghcOptions importDirs logging diff --git a/CabalDev.hs b/CabalDev.hs index 76ebb95..c7a32b1 100644 --- a/CabalDev.hs +++ b/CabalDev.hs @@ -5,17 +5,17 @@ module CabalDev (modifyOptions) where 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.IOChoice import Data.List (find) import System.Directory import System.FilePath (splitPath,joinPath,()) import Text.Regex.Posix ((=~)) import Types -import Data.Alternative.IO () modifyOptions :: Options -> IO Options -modifyOptions opts = found <|> notFound +modifyOptions opts = found ||> notFound where found = addPath opts <$> findCabalDev notFound = return opts diff --git a/GHCChoice.hs b/GHCChoice.hs new file mode 100644 index 0000000..fedfcf8 --- /dev/null +++ b/GHCChoice.hs @@ -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 diff --git a/Gap.hs b/Gap.hs index 046dcd9..d286abe 100644 --- a/Gap.hs +++ b/Gap.hs @@ -16,12 +16,12 @@ module Gap ( #endif ) where -import AA () import Control.Applicative hiding (empty) import Control.Monad import DynFlags import FastString import GHC +import GHCChoice import Language.Haskell.Extension import Outputable import StringBuffer @@ -117,7 +117,7 @@ setCtx ms = do return (not . null $ top) #endif where - isTop mos = lookupMod <|> returnFalse + isTop mos = lookupMod ||> returnFalse where lookupMod = lookupModule (ms_mod_name mos) Nothing >> return True returnFalse = return False diff --git a/Info.hs b/Info.hs index 99f3be4..4fcaff8 100644 --- a/Info.hs +++ b/Info.hs @@ -2,7 +2,6 @@ module Info (infoExpr, typeExpr) where -import AA import Cabal import Control.Applicative import CoreUtils @@ -15,6 +14,7 @@ import Desugar import GHC import GHC.SYB.Utils import GHCApi +import GHCChoice import qualified Gap import HscTypes import NameSet @@ -127,7 +127,7 @@ pprInfo pefas (thing, fixity, insts) inModuleContext :: Options -> FilePath -> ModuleString -> Ghc String -> String -> IO String inModuleContext opt fileName modstr action errmsg = - withGHC (valid <|> invalid <|> return errmsg) + withGHC (valid ||> invalid ||> return errmsg) where valid = do (file,_) <- initializeGHC opt fileName ["-w"] False diff --git a/ghc-mod.cabal b/ghc-mod.cabal index a68145f..b4cc97a 100644 --- a/ghc-mod.cabal +++ b/ghc-mod.cabal @@ -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 Executable ghc-mod Main-Is: GHCMod.hs - Other-Modules: AA - Browse + Other-Modules: Browse Cabal CabalDev Check ErrMsg Flag GHCApi + GHCChoice Gap Info Lang @@ -44,13 +44,13 @@ Executable ghc-mod GHC-Options: -Wall Build-Depends: base >= 4.0 && < 5 , Cabal - , alternative-io , directory , filepath , ghc , ghc-paths , ghc-syb-utils , hlint >= 1.7.1 + , io-choice , old-time , process , regex-posix