GaBuZoMeu/Registry/check-registry.hs
Stephane Bortzmeyer 2fc541c0a7 Initial import
2023-06-08 21:49:35 +02:00

88 lines
2.8 KiB
Haskell

import qualified System.IO
import qualified System.Environment
import qualified Data.List as List
import qualified System.Exit as Exit
import qualified System.Console.GetOpt as GetOpt
import Registry.Grammar
import Registry.Types
import Registry.Registry
nothing = putStr ""
-- Options handling
data Flag
= Verbose | Help deriving Show
options :: [GetOpt.OptDescr Flag]
options =
[ GetOpt.Option ['v'] ["verbose"] (GetOpt.NoArg Verbose) "Detailed output",
GetOpt.Option ['h'] ["help"] (GetOpt.NoArg Help) "Help message"
]
data OptionStore = ProgramOptions {verbose::Bool, help::Bool}
header = do
myself <- System.Environment.getProgName
return ("Usage: " ++ myself ++ " [-v] registry-file")
fatal detailed msg = do
myheader <- header
if detailed then
System.IO.hPutStrLn System.IO.stderr (GetOpt.usageInfo myheader options)
else
System.IO.hPutStrLn System.IO.stderr (myheader)
if msg /= "" then
System.IO.hPutStrLn System.IO.stderr msg
else
nothing
Exit.exitWith (Exit.ExitFailure 1)
-- Defaults
emptyOptionStore :: OptionStore
emptyOptionStore =
ProgramOptions {verbose = False, help = False}
processFlags :: [Flag] -> OptionStore
processFlags [] = emptyOptionStore
processFlags (first : rest) =
case first of
Verbose -> restOpts { verbose = True }
Help -> restOpts { help = True }
where restOpts = processFlags rest
programOpts :: [String] -> IO ([Flag], [String])
programOpts argv =
case GetOpt.getOpt GetOpt.Permute options argv of
(o,n,[] ) -> return(o,n)
(_,_,errs) -> fatal True (concat errs)
getOptionStore :: ([Flag], [String]) -> OptionStore
getOptionStore (f, n) = processFlags f
--
main = do
myargs <- System.Environment.getArgs
results <- programOpts myargs
let opts = getOptionStore results
let args = snd results
if help opts then
fatal True ""
else
nothing
if length (args) /= 1 then
fatal False "One and only one argument accepted"
else
nothing
let registryfilename = args !! 0
input <- System.IO.readFile registryfilename
let syntaxTree = parse input
if (checkOK syntaxTree) then do
let result = semanticCheck (registryOf syntaxTree)
if (checkOK result) then do
if verbose opts then
putStrLn (registryfilename ++ " is OK") -- TODO: display the date
else
nothing
Exit.exitWith Exit.ExitSuccess
else do
putStrLn ("Semantic error in " ++ registryfilename ++ ": " ++
(messageOf result))
Exit.exitWith (Exit.ExitFailure 3)
else do
putStrLn ("Syntax error in " ++ registryfilename ++ ": " ++
(messageOf syntaxTree))
Exit.exitWith (Exit.ExitFailure 2)