Refactoring to use cabal-helper-wrapper
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`.
This commit is contained in:
Daniel Gröber
@@ -1,4 +1,3 @@
|
||||
{-# LANGUAGE TypeFamilies, ScopedTypeVariables, DeriveDataTypeable #-}
|
||||
-- ghc-mod: Making Haskell development *more* fun
|
||||
-- Copyright (C) 2015 Daniel Gröber <dxld ÄT darkboxed DOT org>
|
||||
--
|
||||
@@ -14,64 +13,47 @@
|
||||
--
|
||||
-- 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 Exception
|
||||
, module Control.Exception
|
||||
) where
|
||||
|
||||
import Control.Monad.Error (MonadError(..), Error(..))
|
||||
import Control.Arrow
|
||||
import Control.Exception
|
||||
import Control.Monad.Error
|
||||
import qualified Data.Set as Set
|
||||
import Data.List
|
||||
import Data.Typeable
|
||||
import Exception
|
||||
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
|
||||
|
||||
data GhcModError = GMENoMsg
|
||||
-- ^ Unknown error
|
||||
|
||||
| GMEString String
|
||||
-- ^ Some Error with a message. These are produced mostly by
|
||||
-- 'fail' calls on GhcModT.
|
||||
|
||||
| GMEIOException IOException
|
||||
-- ^ IOExceptions captured by GhcModT's MonadIO instance
|
||||
|
||||
| GMECabalConfigure GhcModError
|
||||
-- ^ Configuring a cabal project failed.
|
||||
|
||||
| GMECabalFlags GhcModError
|
||||
-- ^ Retrieval of the cabal configuration flags failed.
|
||||
|
||||
| GMEProcess [String] GhcModError
|
||||
-- ^ Launching an operating system process failed. The first
|
||||
-- field is the command.
|
||||
|
||||
| GMENoCabalFile
|
||||
-- ^ No cabal file found.
|
||||
|
||||
| GMETooManyCabalFiles [FilePath]
|
||||
-- ^ Too many cabal files found.
|
||||
|
||||
| GMECabalStateFile GMConfigStateFileError
|
||||
-- ^ Reading Cabal's state configuration file falied somehow.
|
||||
deriving (Eq,Show,Typeable)
|
||||
|
||||
data GMConfigStateFileError
|
||||
= GMConfigStateFileNoHeader
|
||||
| GMConfigStateFileBadHeader
|
||||
| GMConfigStateFileNoParse
|
||||
| GMConfigStateFileMissing
|
||||
-- | GMConfigStateFileBadVersion PackageIdentifier PackageIdentifier (Either ConfigStateFileError LocalBuildInfo)
|
||||
deriving (Eq, Show, Read, Typeable)
|
||||
|
||||
gmCsfeDoc :: GMConfigStateFileError -> Doc
|
||||
gmCsfeDoc GMConfigStateFileNoHeader = text $
|
||||
"Saved package config file header is missing. "
|
||||
@@ -103,31 +85,45 @@ gmCsfeDoc GMConfigStateFileMissing = text $
|
||||
-- ++ display currentCompilerId
|
||||
-- ++ ") which is probably the cause of the problem."
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
instance Exception GhcModError
|
||||
|
||||
instance Error GhcModError where
|
||||
noMsg = GMENoMsg
|
||||
strMsg = GMEString
|
||||
|
||||
gmeDoc :: GhcModError -> Doc
|
||||
gmeDoc e = case e of
|
||||
GMENoMsg ->
|
||||
text "Unknown error"
|
||||
GMEString msg ->
|
||||
text msg
|
||||
GMEIOException ioe ->
|
||||
text $ show ioe
|
||||
GMECabalConfigure msg ->
|
||||
text "cabal configure failed: " <> gmeDoc msg
|
||||
text "Configuring cabal project failed: " <> gmeDoc msg
|
||||
GMECabalFlags msg ->
|
||||
text "retrieval of the cabal configuration flags failed: " <> gmeDoc msg
|
||||
GMEProcess cmd msg ->
|
||||
text ("launching operating system process `"++unwords cmd++"` failed: ")
|
||||
<> gmeDoc 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 ->
|
||||
@@ -136,6 +132,32 @@ gmeDoc e = case e of
|
||||
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
|
||||
@@ -144,6 +166,23 @@ 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 fix = do
|
||||
action `catchError` \e -> fix e >> action
|
||||
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
|
||||
|
||||
Reference in New Issue
Block a user