Add exe ghc-supported-languages

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

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)

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 \