Compile Shadok with haskell 2010

shadok.hs

import Shadok.Grammar
import Shadok.StateMachine

import Data.Map (Map, fromList, toList, member, lookup)
import Data.Maybe
import Data.List (intersperse)
import System.Console.GetOpt
--import qualified System
import System.IO
import System.Environment

data Flag 
    = Verbose  | NoGraphCheck | NoDeclCheck | Graphviz | GraphEasy | Start String | End String | HelpOption
       deriving Show 

options :: [OptDescr Flag]
options =
     [ Option ['v']     ["verbose"] (NoArg Verbose)       "chatty output", 
       Option ['n']     ["nographcheck"] (NoArg NoGraphCheck)       "do not check the graph (for connectivity, etc)", 
       Option ['d']     ["nodeclcheck"] (NoArg NoDeclCheck)       "do not check the mandatory declarations", 
       Option ['s']     ["start"] (ReqArg Start "State")    "declares the starting state", 
       Option ['e']     ["end"] (ReqArg End "State")    "declares the ending state", 
       Option ['g']     ["graphviz"] (NoArg Graphviz)    "produces a Graphviz .dot on the stdout",
       Option ['y']     ["grapheasy"] (NoArg GraphEasy)    "produces a Graph::Easy Perl script on the stdout",
       -- TODO: outputs SMC or Ragel 
       -- TODO: outputs CSS as in http://www.surfare.net/~toolman/temp/diagram.html
       Option ['h']     ["help"] (NoArg HelpOption)  "help (this text)"
     ]
-- TODO: an interactive mode. See messages by Henk-Jan van Tuyl 
header = "Usage: shadok [-v] [-n] input-file"

data OptionStore = ProgramOptions {opts'verbose::Bool, 
                  opts'noGraphCheck::Bool, opts'noDeclCheck::Bool,
                  opts'start::Maybe String, opts'end::Maybe String, 
                  opts'graphviz::Bool, opts'grapheasy::Bool}

getOptionStore :: ([Flag], [String]) -> OptionStore
getOptionStore (f, n) = processFlags f

-- Defaults
emptyOptionStore :: OptionStore
emptyOptionStore = 
    ProgramOptions {opts'verbose = False, opts'noGraphCheck = False, 
                    opts'noDeclCheck = False,
                    opts'start = Nothing, opts'end = Nothing,
                    opts'graphviz = False, opts'grapheasy = False}


programOpts :: [String] -> IO ([Flag], [String])
programOpts argv = 
       case getOpt RequireOrder options argv of
          (opts,args,[]  ) -> return (opts,args)
          (_,_,errs) -> error (concat errs ++ usageInfo header options)

optargs (opts, _) = opts
nonoptargs (_, args) = args

processFlags :: [Flag] -> OptionStore
processFlags []             = emptyOptionStore
processFlags (first : rest) =
  case first of
  Verbose        -> restOpts { opts'verbose = True }
  NoGraphCheck   -> restOpts { opts'noGraphCheck = True }
  NoDeclCheck   -> restOpts { opts'noDeclCheck = True }
  Start  s        -> restOpts { opts'start = Just s }
  End  s         -> restOpts { opts'end = Just s }
  Graphviz   -> restOpts { opts'graphviz = True }
  GraphEasy   -> restOpts { opts'grapheasy = True }
  {- Maybe this shouldn't be an error -}
  HelpOption           -> error (usageInfo header options)
  where restOpts = processFlags rest

checkArgs args =   
  let msg = "Only one argument authorized\n" ++ header in
    if length args /= 1 then
       error msg
    else
       return ()

checkStart Nothing g =
       return ()
checkStart (Just label) g =
       if isJust (Data.Map.lookup label (sm'nodemap g)) then
          return ()
       else
          error ("Node " ++ label ++ " is not in the state machine")

verbosePrint doit text =
  if doit then 
     System.IO.hPutStr System.IO.stderr (text ++ "\n\n")
  else
     System.IO.hPutStr System.IO.stderr ""

buildOptions nographcheck nodeclcheck initial final =
   CheckOptions (not nographcheck) (not nodeclcheck) initial final

main = do
  myargs <- getArgs
  actualOptions <- programOpts myargs
  -- TODO: options may be inconsistent. Test?
  let actualFlags = getOptionStore actualOptions
  let verbose = opts'verbose actualFlags
  let startState = opts'start actualFlags
  let endState = opts'end actualFlags
  let otherArgs = (nonoptargs actualOptions)
  checkArgs otherArgs
  let infile = otherArgs !! 0
  f <- System.IO.openFile (infile) System.IO.ReadMode
  input <- System.IO.hGetContents f
  let syntaxTree = parse input
  if (compileOK syntaxTree) then do
      let machine = build "Default title" (programOf syntaxTree)
      let options = buildOptions (opts'noGraphCheck actualFlags)
                                 (opts'noDeclCheck actualFlags)
                                 startState
                                 endState
      let result = semanticCheck (machine) options
      if (compileOK result) then do
          verbosePrint verbose ("Complete list of statements:\n" ++ show (sm'program machine))
          verbosePrint verbose ("Graph:\n" ++ show (sm'graph machine))
          verbosePrint verbose ("State machine has " ++ 
                        show (noNodes machine) ++ 
                        " states.\n")
                        -- TODO: why no noEdges?
          if (opts'graphviz actualFlags) then
              graphvizMake machine 
           else if (opts'grapheasy actualFlags) then
              grapheasyMake machine 
            else
              putStr ""
        else 
          putStrLn ("Semantic error in " ++ infile ++ ": " ++ (messageOf result))
          -- TODO: exit
    else -- TODO: on stderr
      putStrLn ("Syntax error in " ++ infile ++ ": " ++ (messageOf syntaxTree))
      -- TODO: exit
  putStr ""