90 lines
2.8 KiB
Haskell
90 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 theDate = dateOf (head (registryOf syntaxTree))
|
|
let result = semanticCheck (registryOf syntaxTree)
|
|
if (checkOK result) then do
|
|
if verbose opts then
|
|
putStrLn (registryfilename ++ " of " ++ theDate ++ " is OK")
|
|
else
|
|
nothing
|
|
Exit.exitWith Exit.ExitSuccess
|
|
else do
|
|
putStrLn ("Semantic error in " ++ registryfilename ++ " of " ++ theDate ++ ": " ++
|
|
(messageOf result))
|
|
Exit.exitWith (Exit.ExitFailure 3)
|
|
else do
|
|
putStrLn ("Syntax error in " ++ registryfilename ++ ": " ++
|
|
(messageOf syntaxTree))
|
|
Exit.exitWith (Exit.ExitFailure 2)
|