1-- | A test program to check that ghc has got all of its extensions registered
2--
3module Main where
4
5import Language.Haskell.Extension
6import Distribution.Text
7import Distribution.Simple.Utils
8import Distribution.Verbosity
9
10import Data.List ((\\))
11import Data.Maybe
12import Control.Applicative
13import Control.Monad
14import System.Environment
15import System.Exit
16
17-- | A list of GHC extensions that are deliberately not registered,
18-- e.g. due to being experimental and not ready for public consumption
19--
20exceptions = map readExtension []
21
22checkProblems :: [Extension] -> [String]
23checkProblems implemented =
24
25  let unregistered  =
26        [ ext | ext <- implemented          -- extensions that ghc knows about
27              , not (registered ext)        -- but that are not registered
28              , ext `notElem` exceptions ]  -- except for the exceptions
29
30      -- check if someone has forgotten to update the exceptions list...
31
32      -- exceptions that are not implemented
33      badExceptions  = exceptions \\ implemented
34
35      -- exceptions that are now registered
36      badExceptions' = filter registered exceptions
37
38   in catMaybes
39      [ check unregistered $ unlines
40          [ "The following extensions are known to GHC but are not in the "
41          , "extension registry in Language.Haskell.Extension."
42          , "  " ++ intercalate "\n  " (map display unregistered)
43          , "If these extensions are ready for public consumption then they "
44          , "should be registered. If they are still experimental and you "
45          , "think they are not ready to be registered then please add them "
46          , "to the exceptions list in this test program along with an "
47          , "explanation."
48          ]
49      , check badExceptions $ unlines
50          [ "Error in the extension exception list. The following extensions"
51          , "are listed as exceptions but are not even implemented by GHC:"
52          , "  " ++ intercalate "\n  " (map display badExceptions)
53          , "Please fix this test program by correcting the list of"
54          , "exceptions."
55          ]
56      , check badExceptions' $ unlines
57          [ "Error in the extension exception list. The following extensions"
58          , "are listed as exceptions to registration but they are in fact"
59          , "now registered in Language.Haskell.Extension:"
60          , "  " ++ intercalate "\n  " (map display badExceptions')
61          , "Please fix this test program by correcting the list of"
62          , "exceptions."
63          ]
64      ]
65  where
66   registered (UnknownExtension _) = False
67   registered _                    = True
68
69   check [] _ = Nothing
70   check _  i = Just i
71
72
73main = topHandler $ do
74  [ghcPath] <- getArgs
75  exts      <- getExtensions ghcPath
76  let problems = checkProblems exts
77  putStrLn (intercalate "\n" problems)
78  if null problems
79    then exitSuccess
80    else exitFailure
81
82getExtensions :: FilePath -> IO [Extension]
83getExtensions ghcPath =
84        map readExtension . lines
85    <$> rawSystemStdout normal ghcPath ["--supported-languages"]
86
87readExtension :: String -> Extension
88readExtension str = handleNoParse $ do
89    -- GHC defines extensions in a positive way, Cabal defines them
90    -- relative to H98 so we try parsing ("No" ++ extName) first
91    ext <- simpleParse ("No" ++ str)
92    case ext of
93      UnknownExtension _ -> simpleParse str
94      _                  -> return ext
95  where
96    handleNoParse :: Maybe Extension -> Extension
97    handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str)
98