82bb0090c0
This turned out to be quite involved but save for this huge commit it's actually quite awesome and squashes quite a few bugs and nasty problems (hopefully). Most importantly we now have native cabal component support without the user having to do anything to get it! To do this we traverse imports starting from each component's entrypoints (library modules or Main source file for executables) and use this information to find which component's options each module will build with. Under the assumption that these modules have to build with every component they're used in we can now just pick one. Quite a few internal assumptions have been invalidated by this change. Most importantly the runGhcModT* family of cuntions now change the current working directory to `cradleRootDir`.
189 lines
6.4 KiB
Haskell
189 lines
6.4 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(..)
|
|
, GMConfigStateFileError(..)
|
|
, GmError
|
|
, gmeDoc
|
|
, ghcExceptionDoc
|
|
, liftMaybe
|
|
, overrideError
|
|
, modifyError
|
|
, modifyError'
|
|
, modifyGmError
|
|
, tryFix
|
|
, GHandler(..)
|
|
, gcatches
|
|
, module Control.Monad.Error
|
|
, module Control.Exception
|
|
) where
|
|
|
|
import Control.Arrow
|
|
import Control.Exception
|
|
import Control.Monad.Error
|
|
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
|
|
|
|
gmCsfeDoc :: GMConfigStateFileError -> Doc
|
|
gmCsfeDoc GMConfigStateFileNoHeader = text $
|
|
"Saved package config file header is missing. "
|
|
++ "Try re-running the 'configure' command."
|
|
|
|
gmCsfeDoc GMConfigStateFileBadHeader = text $
|
|
"Saved package config file header is corrupt. "
|
|
++ "Try re-running the 'configure' command."
|
|
|
|
gmCsfeDoc GMConfigStateFileNoParse = text $
|
|
"Saved package config file body is corrupt. "
|
|
++ "Try re-running the 'configure' command."
|
|
|
|
gmCsfeDoc GMConfigStateFileMissing = text $
|
|
"Run the 'configure' command first."
|
|
|
|
-- gmCsfeDoc (ConfigStateFileBadVersion oldCabal oldCompiler _) = text $
|
|
-- "You need to re-run the 'configure' command. "
|
|
-- ++ "The version of Cabal being used has changed (was "
|
|
-- ++ display oldCabal ++ ", now "
|
|
-- ++ display currentCabalId ++ ")."
|
|
-- ++ badCompiler
|
|
-- where
|
|
-- badCompiler
|
|
-- | oldCompiler == currentCompilerId = ""
|
|
-- | otherwise =
|
|
-- " Additionally the compiler is different (was "
|
|
-- ++ display oldCompiler ++ ", now "
|
|
-- ++ display currentCompilerId
|
|
-- ++ ") which is probably the cause of the problem."
|
|
|
|
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
|
|
GMECabalFlags msg ->
|
|
text "Retrieval of the cabal configuration flags failed: " <> gmeDoc msg
|
|
GMECabalComponent cn ->
|
|
text "Cabal component " <> quotes (gmComponentNameDoc cn)
|
|
<> text " could not be found."
|
|
GMECabalCompAssignment ctx ->
|
|
text "Could not find a consistent component assignment for modules:" $$
|
|
(nest 4 $ foldr ($+$) empty $ map ctxDoc ctx) $$
|
|
empty $$
|
|
text "Try this and that"
|
|
|
|
where
|
|
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 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 (_out, _err, 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 ++"\"."
|
|
GMECabalStateFile csfe ->
|
|
gmCsfeDoc csfe
|
|
|
|
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 :: ExceptionMonad m => m a -> [GHandler m a] -> m a
|
|
gcatches io handlers = io `gcatch` gcatchesHandler handlers
|
|
|
|
gcatchesHandler :: 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
|