----------------------------------------------------------------------------- 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 ParseMonad.Class > import AbsSyn > import Grammar > import PrettyGrammar > import Parser > import Tabular > import ProduceCode (produceParser) > import ProduceGLRCode > import Info (genInfoFile) > import Target (Target(..)) > import System.Console.GetOpt > import Control.Monad ( liftM, when ) > import System.Environment > import System.Exit (exitWith, ExitCode(..)) > import Data.Char > 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,_,[]) | DumpHelp `elem` cli -> do > prog <- getProgramName > bye (usageInfo (usageHeader prog) argInfo) > (cli,_,_) | OptDebugParser `elem` cli > && OptArrayTarget `notElem` cli -> do > die "Cannot use debugging without -a\n" > (cli,[fl_name],[]) -> > runParserGen cli fl_name > (_,_,errors) -> do > prog <- getProgramName > die (concat errors ++ > usageInfo (usageHeader prog) argInfo) > where > runParserGen cli fl_name = do Open the file. > fl <- readFile fl_name > (file,name) <- possDelit (reverse fl_name) fl Parse, using bootstrapping parser. > (abssyn, hd, tl) <- case runFromStartP ourParser file 1 of > Left err -> die (fl_name ++ ':' : err) > Right abssyn@(AbsSyn hd _ _ tl) -> return (abssyn, hd, tl) Mangle the syntax into something useful. > g <- case {-# SCC "Mangler" #-} (mangler fl_name abssyn) of > Left s -> die (unlines s ++ "\n"); > Right g -> return g > optPrint cli DumpMangle $ putStr $ show g > let select_reductions | OptGLR `elem` cli = 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 cli DumpLR0 $ putStr $ show sets > optPrint cli DumpAction $ putStr $ show action > optPrint cli DumpGoto $ putStr $ show goto > optPrint cli DumpLA $ putStr $ show lainfo > optPrint cli 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 cli > let info = genInfoFile > (map fst sets) > g > action > goto > (token_specs g) > conflictArray > fl_name > unused_rules > unused_terminals > case info_filename of > Just s -> do > writeFile s info > hPutStrLn stderr ("Grammar info written to: " ++ s) > Nothing -> return () Pretty print the grammar. > pretty_filename <- getPrettyFileName name cli > 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 g 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: > target <- getTarget cli > outfilename <- getOutputFileName fl_name cli > template' <- getTemplate getDataDir cli > opt_coerce <- getCoerce target cli > opt_strict <- getStrict cli > opt_array <- getArray cli > opt_ghc <- getGhc cli Add any special options or imports required by the parsing machinery. > let > header = Just $ > (case hd of Just s -> s; Nothing -> "") > ++ importsToInject cli %--------------------------------------- Branch off to GLR parser production > let glr_decode | OptGLR_Decode `elem` cli = TreeDecode > | otherwise = LabelDecode > filtering | OptGLR_Filter `elem` cli = UseFiltering > | otherwise = NoFiltering > ghc_exts | OptGhcTarget `elem` cli = UseGhcExts > (importsToInject cli) Unlike below, don't always passs CPP, because only one of the files needs it. > (langExtsToInject cli) > | otherwise = NoGhcExts > debug = OptDebugParser `elem` cli > if OptGLR `elem` cli > then produceGLRParser > outfilename -- specified output file name > template' -- template files directory > action -- action table (:: ActionTable) > goto -- goto table (:: GotoTable) > header -- header from grammar spec > tl -- trailer from grammar spec > (debug, (glr_decode,filtering,ghc_exts)) > -- controls decoding code-gen > g -- grammar object > else do %--------------------------------------- Resume normal (ie, non-GLR) processing > let > template = template' ++ "/HappyTemplate.hs" Read in the template file for this target: > templ <- readFile template and generate the code. > magic_name <- getMagicName cli > let > outfile = produceParser > g > action > goto CPP is needed in all cases with unified template > ("CPP" : langExtsToInject cli) > header > tl > target > opt_coerce > opt_ghc > opt_strict > magic_filter = > case magic_name of > Nothing -> id > Just name' -> > let > small_name = name' > big_name = toUpper (head name') : tail name' > filter_output ('h':'a':'p':'p':'y':rest) = > small_name ++ filter_output rest > filter_output ('H':'a':'p':'p':'y':rest) = > big_name ++ filter_output rest > filter_output (c:cs) = c : filter_output cs > filter_output [] = [] > in > filter_output > vars_to_define = concat > [ [ "HAPPY_DEBUG" | debug ] > , [ "HAPPY_ARRAY" | opt_array ] > , [ "HAPPY_GHC" | opt_ghc ] > , [ "HAPPY_COERCE" | opt_coerce ] > ] > defines = unlines > [ "#define " ++ d ++ " 1" | d <- vars_to_define ] > (if outfilename == "-" then putStr else writeFile outfilename) > (magic_filter (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 = [] ------------------------------------------------------------------------------ > possDelit :: String -> String -> IO (String,String) > possDelit ('y':'l':'.':nm) fl = return (deLitify fl,reverse nm) > possDelit ('y':'.':nm) fl = return (fl,reverse nm) > possDelit f _ = > dieHappy ("`" ++ reverse f ++ "' does not end in `.y' or `.ly'\n") > deLitify :: String -> String > deLitify = deLit > where > deLit ('>':' ':r) = deLit1 r > deLit ('>':'\t':r) = '\t' : deLit1 r > deLit ('>':'\n':r) = deLit r > deLit ('>':_) = error "Error when de-litify-ing" > deLit ('\n':r) = '\n' : deLit r > deLit r = deLit2 r > deLit1 ('\n':r) = '\n' : deLit r > deLit1 (c:r) = c : deLit1 r > deLit1 [] = [] > deLit2 ('\n':r) = '\n' : deLit r > deLit2 (_:r) = deLit2 r > deLit2 [] = [] ------------------------------------------------------------------------------ The command line arguments. > data CLIFlags = > DumpMangle > | DumpLR0 > | DumpAction > | DumpGoto > | DumpLA > | DumpVersion > | 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" 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" > ] ----------------------------------------------------------------------------- How would we like our code to be generated? > optToTarget :: CLIFlags -> Maybe Target > optToTarget OptArrayTarget = Just TargetArrayBased > optToTarget _ = Nothing Note: we need -cpp at the moment because the template has some GHC version-dependent stuff in it. > langExtsToInject :: [CLIFlags] -> [String] > langExtsToInject cli > | OptGhcTarget `elem` cli = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] > | otherwise = [] > importsToInject :: [CLIFlags] -> String > importsToInject cli = > concat ["\n", import_array, import_bits, > glaexts_import, debug_imports, applicative_imports] > where > glaexts_import | is_ghc = import_glaexts > | otherwise = "" > > debug_imports | is_debug = import_debug > | otherwise = "" > > applicative_imports = import_applicative > > is_ghc = OptGhcTarget `elem` cli > is_debug = OptDebugParser `elem` cli CPP is turned on for -fglasgow-exts, so we can use conditional compilation: > import_glaexts :: String > import_glaexts = "import qualified GHC.Exts as Happy_GHC_Exts\n" > import_array :: String > import_array = "import qualified Data.Array as Happy_Data_Array\n" > import_bits :: String > import_bits = "import qualified Data.Bits as Bits\n" > import_debug :: String > import_debug = > "import qualified System.IO as Happy_System_IO\n" ++ > "import qualified System.IO.Unsafe as Happy_System_IO_Unsafe\n" ++ > "import qualified Debug.Trace as Happy_Debug_Trace\n" > import_applicative :: String > import_applicative = "import Control.Applicative(Applicative(..))\n" ++ > "import Control.Monad (ap)\n" ------------------------------------------------------------------------------ Extract various command-line options. > getTarget :: [CLIFlags] -> IO Target > getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of > (t:ts) | all (==t) ts -> return t > [] -> return TargetHaskell > _ -> dieHappy "multiple target options\n" > 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 :: Target -> [CLIFlags] -> IO Bool > getCoerce _target cli > = if OptUseCoercions `elem` cli > then if OptGhcTarget `elem` cli > then return True > else dieHappy ("-c/--coerce may only be used " ++ > "in conjunction with -g/--ghc\n") > else return False > getArray :: [CLIFlags] -> IO Bool > getArray cli = return (OptArrayTarget `elem` cli) > getGhc :: [CLIFlags] -> IO Bool > getGhc cli = return (OptGhcTarget `elem` cli) > getStrict :: [CLIFlags] -> IO Bool > getStrict cli = return (OptStrict `elem` cli) ------------------------------------------------------------------------------ > 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" -----------------------------------------------------------------------------