161 lines
5.6 KiB
Haskell
161 lines
5.6 KiB
Haskell
-- ghc-mod: Making Haskell development *more* fun
|
|
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
|
--
|
|
-- This program is free software: you can redistribute it and/or modify
|
|
-- it under the terms of the GNU Affero General Public License as published by
|
|
-- the Free Software Foundation, either version 3 of the License, or
|
|
-- (at your option) any later version.
|
|
--
|
|
-- This program is distributed in the hope that it will be useful,
|
|
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
-- GNU Affero General Public License for more details.
|
|
--
|
|
-- You should have received a copy of the GNU Affero General Public License
|
|
-- along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
{-# LANGUAGE ExistentialQuantification #-}
|
|
module Language.Haskell.GhcMod.Error (
|
|
GhcModError(..)
|
|
, GmError
|
|
, gmeDoc
|
|
, ghcExceptionDoc
|
|
, liftMaybe
|
|
, overrideError
|
|
, modifyError
|
|
, modifyError'
|
|
, modifyGmError
|
|
, tryFix
|
|
, GHandler(..)
|
|
, gcatches
|
|
, module Control.Monad.Error
|
|
, module Control.Exception
|
|
) where
|
|
|
|
import Control.Arrow hiding ((<+>))
|
|
import Control.Exception
|
|
import Control.Monad.Error hiding (MonadIO, liftIO)
|
|
import qualified Data.Set as Set
|
|
import Data.List
|
|
import Data.Version
|
|
import System.Process (showCommandForUser)
|
|
import Text.PrettyPrint
|
|
import Text.Printf
|
|
|
|
import Exception
|
|
import Panic
|
|
import Config (cProjectVersion, cHostPlatformString)
|
|
import Paths_ghc_mod (version)
|
|
|
|
import Language.Haskell.GhcMod.Types
|
|
import Language.Haskell.GhcMod.Pretty
|
|
|
|
type GmError m = MonadError GhcModError m
|
|
|
|
gmeDoc :: GhcModError -> Doc
|
|
gmeDoc e = case e of
|
|
GMENoMsg ->
|
|
text "Unknown error"
|
|
GMEString msg ->
|
|
text msg
|
|
GMECabalConfigure msg ->
|
|
text "Configuring cabal project failed" <+>: gmeDoc msg
|
|
GMEStackConfigure msg ->
|
|
text "Configuring stack project failed" <+>: gmeDoc msg
|
|
GMEStackBootstrap msg ->
|
|
text "Bootstrapping stack project environment failed" <+>: gmeDoc msg
|
|
GMECabalCompAssignment ctx ->
|
|
text "Could not find a consistent component assignment for modules:" $$
|
|
(nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
|
|
text "" $$
|
|
(if all (Set.null . snd) ctx
|
|
then noComponentSuggestions
|
|
else empty) $$
|
|
text "- To find out which components ghc-mod knows about try:" $$
|
|
nest 4 (backticks $ text "ghc-mod debug")
|
|
|
|
where
|
|
noComponentSuggestions =
|
|
text "- Are some of these modules part of a test and or benchmark?\
|
|
\ Try enabling them:" $$
|
|
nest 4 (backticks $ text "cabal configure --enable-tests [--enable-benchmarks]")
|
|
|
|
backticks d = char '`' <> d <> char '`'
|
|
ctxDoc = moduleDoc *** compsDoc
|
|
>>> first (<> colon) >>> uncurry (flip hang 4)
|
|
|
|
moduleDoc (Left fn) =
|
|
text "File " <> quotes (text fn)
|
|
moduleDoc (Right mdl) =
|
|
text "Module " <> quotes (text $ moduleNameString mdl)
|
|
|
|
compsDoc sc | Set.null sc = text "has no known components"
|
|
compsDoc sc = fsep $ punctuate comma $
|
|
map gmComponentNameDoc $ Set.toList sc
|
|
GMEProcess _fn cmd args emsg -> let c = showCommandForUser cmd args in
|
|
case emsg of
|
|
Right err ->
|
|
text (printf "Launching system command `%s` failed: " c)
|
|
<> gmeDoc err
|
|
Left rv -> text $
|
|
printf "Launching system command `%s` failed (exited with %d)" c rv
|
|
GMENoCabalFile ->
|
|
text "No cabal file found."
|
|
GMETooManyCabalFiles cfs ->
|
|
text $ "Multiple cabal files found. Possible cabal files: \""
|
|
++ intercalate "\", \"" cfs ++"\"."
|
|
|
|
ghcExceptionDoc :: GhcException -> Doc
|
|
ghcExceptionDoc e@(CmdLineError _) =
|
|
text $ "<command line>: " ++ showGhcException e ""
|
|
ghcExceptionDoc (UsageError str) = strDoc str
|
|
ghcExceptionDoc (Panic msg) = vcat $ map text $ lines $ printf "\
|
|
\GHC panic! (the 'impossible' happened)\n\
|
|
\ ghc-mod version %s\n\
|
|
\ GHC library version %s for %s:\n\
|
|
\ %s\n\
|
|
\\n\
|
|
\Please report this as a bug: %s\n"
|
|
gmVer ghcVer platform msg url
|
|
where
|
|
gmVer = showVersion version
|
|
ghcVer = cProjectVersion
|
|
platform = cHostPlatformString
|
|
url = "https://github.com/kazu-yamamoto/ghc-mod/issues" :: String
|
|
|
|
ghcExceptionDoc e = text $ showGhcException e ""
|
|
|
|
liftMaybe :: MonadError e m => e -> m (Maybe a) -> m a
|
|
liftMaybe e action = maybe (throwError e) return =<< action
|
|
|
|
overrideError :: MonadError e m => e -> m a -> m a
|
|
overrideError e action = modifyError (const e) action
|
|
|
|
modifyError :: MonadError e m => (e -> e) -> m a -> m a
|
|
modifyError f action = action `catchError` \e -> throwError $ f e
|
|
|
|
infixr 0 `modifyError'`
|
|
modifyError' :: MonadError e m => m a -> (e -> e) -> m a
|
|
modifyError' = flip modifyError
|
|
|
|
modifyGmError :: (MonadIO m, ExceptionMonad m)
|
|
=> (GhcModError -> GhcModError) -> m a -> m a
|
|
modifyGmError f a = gcatch a $ \(ex :: GhcModError) -> liftIO $ throwIO (f ex)
|
|
|
|
tryFix :: MonadError e m => m a -> (e -> m ()) -> m a
|
|
tryFix action f = do
|
|
action `catchError` \e -> f e >> action
|
|
|
|
data GHandler m a = forall e . Exception e => GHandler (e -> m a)
|
|
|
|
gcatches :: (MonadIO m, ExceptionMonad m) => m a -> [GHandler m a] -> m a
|
|
gcatches io handlers = io `gcatch` gcatchesHandler handlers
|
|
|
|
gcatchesHandler :: (MonadIO m, ExceptionMonad m)
|
|
=> [GHandler m a] -> SomeException -> m a
|
|
gcatchesHandler handlers e = foldr tryHandler (liftIO $ throw e) handlers
|
|
where tryHandler (GHandler handler) res
|
|
= case fromException e of
|
|
Just e' -> handler e'
|
|
Nothing -> res
|