GaBuZoMeu/Registry/check-registry.hs

90 lines
2.8 KiB
Haskell
Raw Permalink Normal View History

2023-06-08 21:49:35 +02:00
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
2023-10-01 15:46:34 +02:00
let theDate = dateOf (head (registryOf syntaxTree))
2023-06-08 21:49:35 +02:00
let result = semanticCheck (registryOf syntaxTree)
if (checkOK result) then do
if verbose opts then
2023-10-01 15:46:34 +02:00
putStrLn (registryfilename ++ " of " ++ theDate ++ " is OK")
2023-06-08 21:49:35 +02:00
else
nothing
Exit.exitWith Exit.ExitSuccess
else do
2023-10-01 15:46:34 +02:00
putStrLn ("Semantic error in " ++ registryfilename ++ " of " ++ theDate ++ ": " ++
2023-06-08 21:49:35 +02:00
(messageOf result))
Exit.exitWith (Exit.ExitFailure 3)
else do
putStrLn ("Syntax error in " ++ registryfilename ++ ": " ++
(messageOf syntaxTree))
2023-10-01 15:46:34 +02:00
Exit.exitWith (Exit.ExitFailure 2)