diff --git a/Cabal-tests/Cabal-tests.cabal b/Cabal-tests/Cabal-tests.cabal index f9fe954f76f..7989b532bed 100644 --- a/Cabal-tests/Cabal-tests.cabal +++ b/Cabal-tests/Cabal-tests.cabal @@ -200,3 +200,13 @@ test-suite no-thunks-test if impl(ghc >=8.6) build-depends: , nothunks >=0.1.1.0 && <0.3 + +executable lang-tests + hs-source-dirs: tests/misc + main-is: ghc-supported-languages.hs + build-depends: + , base + , Cabal + + ghc-options: -Wall + default-language: Haskell2010 diff --git a/Cabal-tests/tests/misc/ghc-supported-languages.hs b/Cabal-tests/tests/misc/ghc-supported-languages.hs index e8036a0364b..597d5a9e46f 100644 --- a/Cabal-tests/tests/misc/ghc-supported-languages.hs +++ b/Cabal-tests/tests/misc/ghc-supported-languages.hs @@ -1,97 +1,98 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + -- | A test program to check that ghc has got all of its extensions registered --- module Main where -import Language.Haskell.Extension -import Distribution.Text +import Distribution.Compat.Prelude +import Distribution.Simple.Errors import Distribution.Simple.Utils +import Distribution.Text import Distribution.Verbosity +import qualified Distribution.Verbosity as V +import Language.Haskell.Extension import Data.List ((\\)) -import Data.Maybe -import Control.Applicative -import Control.Monad import System.Environment -import System.Exit -- | A list of GHC extensions that are deliberately not registered, -- e.g. due to being experimental and not ready for public consumption --- +exceptions :: [Extension] exceptions = map readExtension [] checkProblems :: [Extension] -> [String] checkProblems implemented = - - let unregistered = - [ ext | ext <- implemented -- extensions that ghc knows about - , not (registered ext) -- but that are not registered - , ext `notElem` exceptions ] -- except for the exceptions + -- Extensions that ghc knows about but that are not registered except for the exceptions + let unregistered = [ext | ext <- implemented, not (registered ext), ext `notElem` exceptions] -- check if someone has forgotten to update the exceptions list... - -- exceptions that are not implemented - badExceptions = exceptions \\ implemented + badExceptions = exceptions \\ implemented -- exceptions that are now registered badExceptions' = filter registered exceptions - in catMaybes - [ check unregistered $ unlines - [ "The following extensions are known to GHC but are not in the " - , "extension registry in Language.Haskell.Extension." - , " " ++ intercalate "\n " (map display unregistered) - , "If these extensions are ready for public consumption then they " - , "should be registered. If they are still experimental and you " - , "think they are not ready to be registered then please add them " - , "to the exceptions list in this test program along with an " - , "explanation." - ] - , check badExceptions $ unlines - [ "Error in the extension exception list. The following extensions" - , "are listed as exceptions but are not even implemented by GHC:" - , " " ++ intercalate "\n " (map display badExceptions) - , "Please fix this test program by correcting the list of" - , "exceptions." - ] - , check badExceptions' $ unlines - [ "Error in the extension exception list. The following extensions" - , "are listed as exceptions to registration but they are in fact" - , "now registered in Language.Haskell.Extension:" - , " " ++ intercalate "\n " (map display badExceptions') - , "Please fix this test program by correcting the list of" - , "exceptions." - ] - ] + [ check unregistered $ + unlines + [ "The following extensions are known to GHC but are not in the " + , "extension registry in Language.Haskell.Extension." + , " " ++ intercalate "\n " (map display unregistered) + , "If these extensions are ready for public consumption then they " + , "should be registered. If they are still experimental and you " + , "think they are not ready to be registered then please add them " + , "to the exceptions list in this test program along with an " + , "explanation." + ] + , check badExceptions $ + unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions but are not even implemented by GHC:" + , " " ++ intercalate "\n " (map display badExceptions) + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + , check badExceptions' $ + unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions to registration but they are in fact" + , "now registered in Language.Haskell.Extension:" + , " " ++ intercalate "\n " (map display badExceptions') + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + ] where - registered (UnknownExtension _) = False - registered _ = True - - check [] _ = Nothing - check _ i = Just i + registered (UnknownExtension _) = False + registered _ = True + check [] _ = Nothing + check _ i = Just i -main = topHandler $ do - [ghcPath] <- getArgs - exts <- getExtensions ghcPath - let problems = checkProblems exts - putStrLn (intercalate "\n" problems) - if null problems - then exitSuccess - else exitFailure +main :: IO a +main = topHandler (isUserException (Proxy @(VerboseException CabalException))) $ do + getArgs >>= \case + [ghcPath] -> do + exts <- getExtensions ghcPath + let problems = checkProblems exts + putStrLn (intercalate "\n" problems) + if null problems + then exitSuccess + else exitFailure + _ -> dieNoVerbosity "needs the path to ghc as the single argument" getExtensions :: FilePath -> IO [Extension] getExtensions ghcPath = - map readExtension . lines - <$> rawSystemStdout normal ghcPath ["--supported-languages"] + map readExtension . lines + <$> rawSystemStdout (Verbosity V.normal defaultVerbosityHandles) ghcPath ["--supported-languages"] readExtension :: String -> Extension readExtension str = handleNoParse $ do - -- GHC defines extensions in a positive way, Cabal defines them - -- relative to H98 so we try parsing ("No" ++ extName) first - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext + -- GHC defines extensions in a positive way, Cabal defines them + -- relative to H98 so we try parsing ("No" ++ extName) first + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext where handleNoParse :: Maybe Extension -> Extension handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) diff --git a/Makefile b/Makefile index 9b0cae9f668..f0bf50e6e72 100644 --- a/Makefile +++ b/Makefile @@ -31,7 +31,8 @@ FORMAT_DIRS := \ Cabal-syntax \ cabal-install \ cabal-testsuite/src \ - cabal-validate + cabal-validate \ + Cabal-tests/tests/misc FORMAT_DIRS_TODO := \ Cabal-QuickCheck \