-----------------------------------------------------------------------------
The main driver.

(c) 1993-2003 Andy Gill, Simon Marlow
GLR amendments (c) University of Durham, Ben Medlock 2001
-----------------------------------------------------------------------------

> module Main (main) where

Path settings auto-generated by Cabal:

> import Paths_happy

> import Happy.Grammar
> import Happy.Frontend
> import Happy.Frontend.AbsSyn
> import Happy.Frontend.Mangler
> import Happy.Frontend.PrettyGrammar
> import Happy.Backend.LALR
> import Happy.Backend.LALR.ProduceCode (produceParser)
> import Happy.Backend.GLR
> import Happy.Backend.GLR.ProduceCode
> import Happy.Tabular
> import Happy.Tabular.Info (genInfoFile)

> import System.Console.GetOpt
> import Control.Monad ( liftM, when, unless )
> import System.Environment
> import System.Exit (exitWith, ExitCode(..))
> import Data.Char
> import Data.List ( union )
> import System.IO
> import Data.List( isSuffixOf )
> import Data.Version ( showVersion )

> main :: IO ()
> main = do

Read and parse the CLI arguments.

>       args <- getArgs
>       main2 args

> main2 :: [String] -> IO ()
> main2 args =

Read and parse the CLI arguments.

>       case getOpt Permute argInfo (constArgs ++ args) of
>               (cli,_,[]) | DumpVersion `elem` cli ->
>                  bye copyright
>               (cli,_,[]) | DumpNumericVersion `elem` cli ->
>                  bye projectVersion
>               (cli,_,[]) | DumpHelp `elem` cli -> do
>                  prog <- getProgramName
>                  bye (usageInfo (usageHeader prog) argInfo)
>               (cli,[fl_name],[]) ->
>                  runParserGen cli fl_name
>               (_,_,errors) -> do
>                  prog <- getProgramName
>                  die (concat errors ++
>                       usageInfo (usageHeader prog) argInfo)

>  where
>    runParserGen cliOpts fl_name = do

Open the file.

>       fl <- readFile fl_name
>       (name, file) <- case fileNameAndType fl_name of
>                         Nothing -> die ("`" ++ fl_name ++ "' does not end in `.y' or `.ly'\n")
>                         Just (name, Y) -> return (name, fl)
>                         Just (name, LY) -> return (name, deLitify fl)

Parse, using bootstrapping parser.

>       (BookendedAbsSyn pragma hd abssyn tl) <- case parseYFileContents file of
>               Left err -> die (fl_name ++ ':' : err)
>               Right bas -> return bas

Combine options set via OPTIONS_HAPPY with those provided via the CLI.

>       opts <-
>          case pragma of
>            Just happyPragma -> do
>              let (pragmaName, pragmaArgs) = break isSpace happyPragma
>              when (pragmaName /= "OPTIONS_HAPPY") $
>                die ("Unknown happy pragma '" ++ pragmaName ++ "', expected OPTIONS_HAPPY")
>              case getOpt Permute argInfo (words pragmaArgs) of
>                (pragmaOpts,_,[]) -> return (union pragmaOpts cliOpts)
>                (_,_,errors) -> die ("Invalid options in OPTIONS_HAPPY: " ++ concat errors)
>            Nothing -> return cliOpts

If no -g flag has been passed, show a warning.

>       unless (OptGhcTarget `elem` opts) $
>           hPutStrLn stderr "Warning: With happy 2.0, the --ghc flag has become non-optional. To suppress this warning, pass the --ghc flag."


Mangle the syntax into something useful.

>       (g, mAg, common_options) <- case {-# SCC "Mangler" #-} mangler fl_name abssyn of
>               Left  s  -> die (unlines s ++ "\n")
>               Right gd -> return gd

>       optPrint opts DumpMangle $ putStr $ show g

>       let select_reductions | OptGLR `elem` opts = select_all_reductions
>                             | otherwise         = select_first_reduction

>       let tables      = genTables select_reductions g
>           sets        = lr0items tables
>           lainfo      = (la_prop tables, la_spont tables)
>           la          = lookaheads tables
>           goto        = gotoTable tables
>           action      = actionTable tables
>           (conflictArray,(sr,rr)) = conflicts tables

Debug output

>       optPrint opts DumpLR0    $ putStr $ show sets
>       optPrint opts DumpAction $ putStr $ show action
>       optPrint opts DumpGoto   $ putStr $ show goto
>       optPrint opts DumpLA     $ putStr $ show lainfo
>       optPrint opts DumpLA     $ putStr $ show la

Report any unused rules and terminals

>       let (unused_rules, unused_terminals) = redundancies tables
>       when (not (null unused_rules))
>          (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules)))
>       when (not (null unused_terminals))
>          (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals)))

Print out the info file.

>       info_filename <- getInfoFileName name opts
>       let info = genInfoFile
>                       (map fst sets)
>                       g
>                       action
>                       goto
>                       conflictArray
>                       fl_name
>                       unused_rules
>                       unused_terminals
>                       version
>       case info_filename of
>         Just s  -> do
>           writeFile s info
>           hPutStrLn stderr ("Grammar info written to: " ++ s)
>         Nothing -> return ()


Pretty print the AbsSyn.

>       pretty_filename <- getPrettyFileName name opts
>       case pretty_filename of
>         Just s   -> do
>           let out = render (ppAbsSyn abssyn)
>           writeFile s out
>           hPutStrLn stderr ("Production rules written to: " ++ s)
>         Nothing  -> return ()

Report any conflicts in the grammar.

>       case expect common_options of
>         Just n | n == sr && rr == 0 -> return ()
>         Just _ | rr > 0 ->
>                 die ("The grammar has reduce/reduce conflicts.\n" ++
>                      "This is not allowed when an expect directive is given\n")
>         Just _ ->
>                die ("The grammar has " ++ show sr ++
>                     " shift/reduce conflicts.\n" ++
>                     "This is different from the number given in the " ++
>                     "expect directive\n")
>         _ -> do

>          (if sr /= 0
>              then hPutStrLn stderr ("shift/reduce conflicts:  " ++ show sr)
>              else return ())

>          (if rr /= 0
>              then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr)
>              else return ())




Now, let's get on with generating the parser.  Firstly, find out what kind
of code we should generate, and where it should go:

>       outfilename <- getOutputFileName fl_name opts
>       opt_coerce  <- getCoerce opts
>       opt_strict  <- getStrict opts
>       opt_debug   <- getDebug opts

Add any special options or imports required by the parsing machinery.

>       let
>           header = Just $
>             (case hd of Just s -> s; Nothing -> "")
>             ++ importsToInject opt_debug

>       if OptGLR `elem` opts


%---------------------------------------
Branch off to GLR parser production

>         then do

>           let
>             glr_decode
>               | OptGLR_Decode `elem` opts = TreeDecode
>               | otherwise                 = LabelDecode
>             filtering
>               | OptGLR_Filter `elem` opts = UseFiltering
>               | otherwise                 = NoFiltering
>             ghc_exts                      = UseGhcExts
>                                               (importsToInject opt_debug)

Unlike below, don't always pass CPP, because only one of the files needs it.

>                                              (langExtsToInject)
>           template' <- getTemplate glrBackendDataDir opts
>           let basename  = takeWhile (/='.') outfilename
>           let tbls  = (action,goto)
>           (parseName,_,_,_) <- case starts g of
>                                [s] -> return s
>                                s:_ -> do
>                                          putStrLn "GLR-Happy doesn't support multiple start points (yet)"
>                                          putStrLn "Defaulting to first start point."
>                                          return s
>                                [] -> error "produceGLRParser: []"
>           base <- readFile (baseTemplate template')
>           lib <- readFile (libTemplate template')
>           let (dat, parser) = produceGLRParser
>                 (base, lib)   -- templates
>                 basename      -- basename of specified output file name
>                 tbls          -- action table (:: ActionTable)
>                               -- goto table (:: GotoTable)
>                 parseName
>                 header        -- header from grammar spec
>                 tl            -- trailer from grammar spec
>                 (opt_debug, (glr_decode,filtering,ghc_exts))
>                               -- controls decoding code-gen
>                 g             -- grammar object
>                common_options     -- grammar object
>           writeFile (basename ++ "Data.hs") dat
>           writeFile (basename ++ ".hs") parser


%---------------------------------------
Resume normal (ie, non-GLR) processing

>         else do

>           template'   <- getTemplate lalrBackendDataDir opts
>           let
>               template = template' ++ "/HappyTemplate.hs"

Read in the template file for this target:

>           templ <- readFile template

and generate the code.

>           magic_name <- getMagicName opts
>           let
>               outfile = produceParser
>                           g
>                           mAg
>                           common_options
>                           action
>                           goto

CPP is needed in all cases with unified template

>                           ("CPP" : langExtsToInject)
>                           header
>                           tl
>                           opt_coerce
>                           opt_strict

>               defines' = defines opt_debug opt_coerce

>           (if outfilename == "-" then putStr else writeFile outfilename)
>                   (magicFilter magic_name (outfile ++ defines' ++ templ))

Successfully Finished.

-----------------------------------------------------------------------------

> getProgramName :: IO String
> getProgramName = liftM (`withoutSuffix` ".bin") getProgName
>    where str' `withoutSuffix` suff
>             | suff `isSuffixOf` str' = take (length str' - length suff) str'
>             | otherwise              = str'

> bye :: String -> IO a
> bye s = putStr s >> exitWith ExitSuccess

> die :: String -> IO a
> die s = hPutStr stderr s >> exitWith (ExitFailure 1)

> dieHappy :: String -> IO a
> dieHappy s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)

> optPrint :: [CLIFlags] -> CLIFlags -> IO () -> IO ()
> optPrint cli pass io =
>       when (elem pass cli) (putStr "\n---------------------\n" >> io)

> constArgs :: [String]
> constArgs = []

------------------------------------------------------------------------------
The command line arguments.

> data CLIFlags =
>                 DumpMangle
>               | DumpLR0
>               | DumpAction
>               | DumpGoto
>               | DumpLA
>               | DumpVersion
>               | DumpNumericVersion
>               | DumpHelp
>               | OptInfoFile (Maybe String)
>               | OptPrettyFile (Maybe String)
>               | OptTemplate String
>               | OptMagicName String

>               | OptGhcTarget
>               | OptArrayTarget
>               | OptUseCoercions
>               | OptDebugParser
>               | OptStrict
>               | OptOutputFile String
>               | OptGLR
>               | OptGLR_Decode
>               | OptGLR_Filter
>  deriving Eq

> argInfo :: [OptDescr CLIFlags]
> argInfo  = [
>    Option ['o'] ["outfile"] (ReqArg OptOutputFile "FILE")
>       "write the output to FILE (default: file.hs)",
>    Option ['i'] ["info"] (OptArg OptInfoFile "FILE")
>       "put detailed grammar info in FILE",
>    Option ['p'] ["pretty"] (OptArg OptPrettyFile "FILE")
>       "pretty print the production rules to FILE",
>    Option ['t'] ["template"] (ReqArg OptTemplate "DIR")
>       "look in DIR for template files",
>    Option ['m'] ["magic-name"] (ReqArg OptMagicName "NAME")
>       "use NAME as the symbol prefix instead of \"happy\"",
>    Option ['s'] ["strict"] (NoArg OptStrict)
>       "evaluate semantic values strictly (experimental)",
>    Option ['g'] ["ghc"]    (NoArg OptGhcTarget)
>       "use GHC extensions",
>    Option ['c'] ["coerce"] (NoArg OptUseCoercions)
>       "use type coercions (only available with -g)",
>    Option ['a'] ["array"] (NoArg OptArrayTarget)
>       "generate an array-based parser",
>    Option ['d'] ["debug"] (NoArg OptDebugParser)
>       "produce a debugging parser (only with -a)",
>    Option ['l'] ["glr"] (NoArg OptGLR)
>       "Generate a GLR parser for ambiguous grammars",
>    Option ['k'] ["decode"] (NoArg OptGLR_Decode)
>       "Generate simple decoding code for GLR result",
>    Option ['f'] ["filter"] (NoArg OptGLR_Filter)
>       "Filter the GLR parse forest with respect to semantic usage",
>    Option ['?'] ["help"] (NoArg DumpHelp)
>       "display this help and exit",
>    Option ['V','v'] ["version"] (NoArg DumpVersion)   -- ToDo: -v is deprecated
>       "output version information and exit",
>    Option [] ["numeric-version"] (NoArg DumpNumericVersion)   -- ToDo: -v is deprecated
>       "output the version number and exit",

Various debugging/dumping options...

>    Option [] ["ddump-mangle"] (NoArg DumpMangle)
>       "Dump mangled input",
>    Option [] ["ddump-lr0"] (NoArg DumpLR0)
>       "Dump LR0 item sets",
>    Option [] ["ddump-action"] (NoArg DumpAction)
>       "Dump action table",
>    Option [] ["ddump-goto"] (NoArg DumpGoto)
>       "Dump goto table",
>    Option [] ["ddump-lookaheads"] (NoArg DumpLA)
>       "Dump lookahead info"

>    ]

------------------------------------------------------------------------------
Extract various command-line options.

> getOutputFileName :: String -> [CLIFlags] -> IO String
> getOutputFileName ip_file cli
>       = case [ s | (OptOutputFile s) <- cli ] of
>               []   -> return (base ++ ".hs")
>                        where (base, _ext) = break (== '.') ip_file
>               f:fs -> return (last (f:fs))

> getInfoFileName :: String -> [CLIFlags] -> IO (Maybe String)
> getInfoFileName base cli
>       = case [ s | (OptInfoFile s) <- cli ] of
>               []      -> return Nothing
>               [f]     -> case f of
>                               Nothing -> return (Just (base ++ ".info"))
>                               Just j  -> return (Just j)
>               _many   -> dieHappy "multiple --info/-i options\n"

> getPrettyFileName :: String -> [CLIFlags] -> IO (Maybe String)
> getPrettyFileName base cli
>       = case [ s | (OptPrettyFile s) <- cli ] of
>               []      -> return Nothing
>               [f]     -> case f of
>                               Nothing -> return (Just (base ++ ".grammar"))
>                               Just j  -> return (Just j)
>               _many   -> dieHappy "multiple --pretty/-p options\n"

> getTemplate :: IO String -> [CLIFlags] -> IO String
> getTemplate def cli
>       = case [ s | (OptTemplate s) <- cli ] of
>               []         -> def
>               f:fs       -> return (last (f:fs))

> getMagicName :: [CLIFlags] -> IO (Maybe String)
> getMagicName cli
>       = case [ s | (OptMagicName s) <- cli ] of
>               []         -> return Nothing
>               f:fs       -> return (Just (map toLower (last (f:fs))))

> getCoerce :: [CLIFlags] -> IO Bool
> getCoerce cli = return (OptUseCoercions `elem` cli)

> getStrict :: [CLIFlags] -> IO Bool
> getStrict cli = return (OptStrict `elem` cli)

> getDebug :: [CLIFlags] -> IO Bool
> getDebug cli = return (OptDebugParser `elem` cli)

------------------------------------------------------------------------------

> projectVersion :: String
> projectVersion = showVersion version

> copyright :: String
> copyright = unlines [
>  "Happy Version " ++ showVersion version ++ " Copyright (c) 1993-1996 Andy Gill, Simon Marlow (c) 1997-2005 Simon Marlow","",
>  "Happy is a Yacc for Haskell, and comes with ABSOLUTELY NO WARRANTY.",
>  "This program is free software; you can redistribute it and/or modify",
>  "it under the terms given in the file 'LICENSE' distributed with",
>  "the Happy sources."]

> usageHeader :: String -> String
> usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file\n"

-----------------------------------------------------------------------------
