GaBuZoMeu/Registry/check-registry.hs

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)