From 4aa441a0557bd87ceedb5704e0d8793a1079cc44 Mon Sep 17 00:00:00 2001 From: David Knothe Date: Wed, 20 Oct 2021 17:18:27 +0200 Subject: [PATCH] Split out Tabular some more but also add Main --- .../frontend/src/Happy/Frontend/Mangler.lhs | 2 +- packages/tabular/happy-tabular.cabal | 5 +- packages/tabular/src/Happy/Tabular.lhs | 51 +------- .../src/Happy/Tabular/FindRedundancies.lhs | 52 ++++++++ packages/tabular/src/Happy/Tabular/Info.lhs | 9 +- packages/tabular/src/Happy/Tabular/LALR.lhs | 17 +-- packages/tabular/src/Happy/Tabular/Main.hs | 114 +++++++++++++++++ packages/tabular/src/Happy/Tabular/Tables.lhs | 24 ++++ src/GenUtils.lhs | 28 ++++- src/Main.lhs | 117 ++++-------------- src/ProduceCode.lhs | 2 +- src/ProduceGLRCode.lhs | 2 +- 12 files changed, 254 insertions(+), 169 deletions(-) create mode 100644 packages/tabular/src/Happy/Tabular/FindRedundancies.lhs create mode 100644 packages/tabular/src/Happy/Tabular/Main.hs create mode 100644 packages/tabular/src/Happy/Tabular/Tables.lhs diff --git a/packages/frontend/src/Happy/Frontend/Mangler.lhs b/packages/frontend/src/Happy/Frontend/Mangler.lhs index 0f64a5f2..3e819cf7 100644 --- a/packages/frontend/src/Happy/Frontend/Mangler.lhs +++ b/packages/frontend/src/Happy/Frontend/Mangler.lhs @@ -476,4 +476,4 @@ So is this. > c:r -> go r (c:acc) used > mkHappyVar :: Int -> String -> mkHappyVar n = "happy_var_" ++ show n \ No newline at end of file +> mkHappyVar n = "happy_var_" ++ show n diff --git a/packages/tabular/happy-tabular.cabal b/packages/tabular/happy-tabular.cabal index 48fd1645..a9379fc5 100644 --- a/packages/tabular/happy-tabular.cabal +++ b/packages/tabular/happy-tabular.cabal @@ -41,6 +41,9 @@ library Happy.Tabular.Info, Happy.Tabular.LALR, Happy.Tabular.NameSet + Happy.Tabular.Main + Happy.Tabular.FindRedundancies + Happy.Tabular.Tables build-depends: base < 5, array, containers >= 0.4.2, @@ -48,4 +51,4 @@ library default-language: Haskell98 default-extensions: CPP, MagicHash, FlexibleContexts, NamedFieldPuns - ghc-options: -Wall \ No newline at end of file + ghc-options: -Wall diff --git a/packages/tabular/src/Happy/Tabular.lhs b/packages/tabular/src/Happy/Tabular.lhs index f86d1c78..ea2aed84 100644 --- a/packages/tabular/src/Happy/Tabular.lhs +++ b/packages/tabular/src/Happy/Tabular.lhs @@ -7,12 +7,13 @@ > ) where > import Happy.Grammar +> import Happy.Tabular.FindRedundancies > import Happy.Tabular.First > import Happy.Tabular.LALR +> import Happy.Tabular.Tables > import Happy.Tabular.NameSet (NameSet) -> import Data.Array( Array, assocs, elems, (!) ) -> import Data.List ( nub ) +> import Data.Array( Array ) > data Tables = > Tables { @@ -45,49 +46,3 @@ > redundancies = find_redundancies select_reductions g actionTable > in Tables { lr0items, la_spont, la_prop, lookaheads, lr1items, > gotoTable, actionTable, conflicts, redundancies } - ------------------------------------------------------------------------------ -Find unused rules and tokens - -> find_redundancies -> :: SelectReductions -> Grammar -> ActionTable -> ([Int], [String]) -> find_redundancies extract_reductions g action_table = -> (unused_rules, map (env !) unused_terminals) -> where -> Grammar { terminals = terms, -> token_names = env, -> eof_term = eof, -> starts = starts', -> productions = productions' -> } = g -> actions = concat (map assocs (elems action_table)) -> start_rules = [ 0 .. (length starts' - 1) ] -> used_rules = start_rules ++ -> nub [ r | (_,a) <- actions, r <- extract_reductions a ] -> used_tokens = errorTok : eof : -> nub [ t | (t,a) <- actions, is_shift a ] -> n_prods = length productions' -> unused_terminals = filter (`notElem` used_tokens) terms -> unused_rules = filter (`notElem` used_rules ) [0..n_prods-1] - -> is_shift :: LRAction -> Bool -> is_shift (LR'Shift _ _) = True -> is_shift (LR'Multiple _ LR'Shift{}) = True -> is_shift _ = False - ---- -selects what counts as a reduction when calculating used/unused - -> type SelectReductions = LRAction -> [Int] - -> select_all_reductions :: SelectReductions -> select_all_reductions = go -> where go (LR'Reduce r _) = [r] -> go (LR'Multiple as a) = concatMap go (a : as) -> go _ = [] - -> select_first_reduction :: SelectReductions -> select_first_reduction = go -> where go (LR'Reduce r _) = [r] -> go (LR'Multiple _ a) = go a -- eg R/R conflict -> go _ = [] diff --git a/packages/tabular/src/Happy/Tabular/FindRedundancies.lhs b/packages/tabular/src/Happy/Tabular/FindRedundancies.lhs new file mode 100644 index 00000000..e962a20f --- /dev/null +++ b/packages/tabular/src/Happy/Tabular/FindRedundancies.lhs @@ -0,0 +1,52 @@ +> module Happy.Tabular.FindRedundancies where + +> import Happy.Grammar +> import Happy.Tabular.Tables +> import Data.Array( assocs, elems, (!) ) +> import Data.List + +Find unused rules and tokens + +> find_redundancies +> :: SelectReductions -> Grammar -> ActionTable -> ([Int], [String]) +> find_redundancies extract_reductions g action_table = +> (unused_rules, map (env !) unused_terminals) +> where +> Grammar { terminals = terms, +> token_names = env, +> eof_term = eof, +> starts = starts', +> productions = productions' +> } = g + +> actions = concat (map assocs (elems action_table)) +> start_rules = [ 0 .. (length starts' - 1) ] +> used_rules = start_rules ++ +> nub [ r | (_,a) <- actions, r <- extract_reductions a ] +> used_tokens = errorTok : eof : +> nub [ t | (t,a) <- actions, is_shift a ] +> n_prods = length productions' +> unused_terminals = filter (`notElem` used_tokens) terms +> unused_rules = filter (`notElem` used_rules ) [0..n_prods-1] + +> is_shift :: LRAction -> Bool +> is_shift (LR'Shift _ _) = True +> is_shift (LR'Multiple _ LR'Shift{}) = True +> is_shift _ = False + +--- +selects what counts as a reduction when calculating used/unused + +> type SelectReductions = LRAction -> [Int] + +> select_all_reductions :: SelectReductions +> select_all_reductions = go +> where go (LR'Reduce r _) = [r] +> go (LR'Multiple as a) = concatMap go (a : as) +> go _ = [] + +> select_first_reduction :: SelectReductions +> select_first_reduction = go +> where go (LR'Reduce r _) = [r] +> go (LR'Multiple _ a) = go a -- eg R/R conflict +> go _ = [] diff --git a/packages/tabular/src/Happy/Tabular/Info.lhs b/packages/tabular/src/Happy/Tabular/Info.lhs index 6f8cffdb..316c0f98 100644 --- a/packages/tabular/src/Happy/Tabular/Info.lhs +++ b/packages/tabular/src/Happy/Tabular/Info.lhs @@ -6,11 +6,12 @@ Generating info files. > module Happy.Tabular.Info (genInfoFile) where -> import Data.Set ( Set ) -> import qualified Data.Set as Set hiding ( Set ) > import Happy.Grammar -> import Happy.Tabular.LALR ( Lr0Item(..), LRAction(..), Goto(..), GotoTable, ActionTable ) +> import Happy.Tabular.Tables +> import Happy.Tabular.LALR ( Lr0Item(..) ) +> import Data.Set ( Set ) +> import qualified Data.Set as Set hiding ( Set ) > import Data.Array > import Data.List (nub) > import Data.Version ( Version, showVersion ) @@ -227,4 +228,4 @@ Produce a file of parser information, useful for debugging the parser. > interleave :: String -> [String -> String] -> String -> String > interleave s = foldr (\a b -> a . str s . b) id > interleave' :: String -> [String -> String] -> String -> String -> interleave' s = foldr1 (\a b -> a . str s . b) \ No newline at end of file +> interleave' s = foldr1 (\a b -> a . str s . b) diff --git a/packages/tabular/src/Happy/Tabular/LALR.lhs b/packages/tabular/src/Happy/Tabular/LALR.lhs index 209cd29e..71cf1ecf 100644 --- a/packages/tabular/src/Happy/Tabular/LALR.lhs +++ b/packages/tabular/src/Happy/Tabular/LALR.lhs @@ -8,14 +8,14 @@ Generation of LALR parsing tables. > module Happy.Tabular.LALR > (genActionTable, genGotoTable, genLR0items, precalcClosure0, > propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts, -> Lr0Item(..), Lr1Item(..), ItemSetWithGotos, LRAction(..), Lr1State, -> ActionTable, GotoTable, Goto(..)) +> Lr0Item(..), Lr1Item, ItemSetWithGotos, Lr1State) > where > import Happy.Tabular.First ( mkClosure ) > import Happy.Tabular.NameSet ( NameSet ) > import qualified Happy.Tabular.NameSet as NameSet > import Happy.Grammar +> import Happy.Tabular.Tables > import qualified Data.Set as Set hiding ( Set ) > import Data.Set ( Set ) @@ -47,19 +47,6 @@ This means rule $a$, with dot at $b$ (all starting at 0) > type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)]) -> data LRAction = LR'Shift Int Priority -- state number and priority -> | LR'Reduce Int Priority-- rule no and priority -> | LR'Accept -- :-) -> | LR'Fail -- :-( -> | LR'MustFail -- :-( -> | LR'Multiple [LRAction] LRAction -- conflict -> deriving (Eq,Show) - -> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction) -> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto) -> data Goto = Goto Int | NoGoto -> deriving (Eq, Show) - ----------------------------------------------------------------------------- Token numbering in an array-based parser: diff --git a/packages/tabular/src/Happy/Tabular/Main.hs b/packages/tabular/src/Happy/Tabular/Main.hs new file mode 100644 index 00000000..628424f5 --- /dev/null +++ b/packages/tabular/src/Happy/Tabular/Main.hs @@ -0,0 +1,114 @@ +module Happy.Tabular.Main ( + TabularArgs(..), TabularResult, runTabular + ) where + +import Happy.Grammar +import Happy.Tabular.Tables +import qualified Happy.Tabular.LALR as LALR +import Happy.Tabular.FindRedundancies +import Happy.Tabular.Info +import Happy.Tabular +import Data.Array (Array) +import System.IO +import System.Exit (exitWith, ExitCode(..)) +import Control.Monad +import Data.Version (Version) + +-------- Main entry point (runTabular) -------- + +data TabularArgs = TabularArgs { + inFile :: String, -- printed to the info file, not used otherwise + infoFile :: Maybe String, + + dumpLR0 :: Bool, + dumpLA :: Bool, + dumpAction :: Bool, + dumpGoto :: Bool +} + +type TabularResult = (ActionTable, GotoTable, [LALR.Lr1State], [Int]) + +runTabular :: Bool -> TabularArgs -> Grammar -> Version -> IO TabularResult +runTabular glr args g version = do + let select_reductions = + if glr + then select_all_reductions + else select_first_reduction + + let tables = genTables select_reductions g + sets = lr0items tables + la = lookaheads tables + items2 = lr1items tables + goto = gotoTable tables + action = actionTable tables + (conflictArray, (sr,rr)) = conflicts tables + optPrint (dumpLR0 args) (print sets) + optPrint (dumpLA args) (print la) + optPrint (dumpAction args) (print action) + optPrint (dumpGoto args) (print goto) + reportUnusedRules tables + let (unused_rules, unused_terminals) = redundancies tables + writeInfoFile sets g action goto conflictArray (inFile args) (infoFile args) unused_rules unused_terminals version + reportConflicts g sr rr + return (action, goto, items2, unused_rules) + where + optPrint b io = when b (putStr "\n---------------------\n" >> io) + +-------- Helpers -------- + +reportUnusedRules :: Tables -> IO () +reportUnusedRules tables = do + 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)) + +reportConflicts :: Grammar -> Int -> Int -> IO () +reportConflicts g sr rr = 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 () + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +writeInfoFile + :: [LALR.ItemSetWithGotos] + -> Grammar + -> ActionTable + -> GotoTable + -> Array Int (Int,Int) + -> String + -> Maybe String + -> [Int] + -> [String] + -> Version + -> IO () +writeInfoFile sets g action goto conflictArray file info_file unused_rules unused_terminals version = + let info = genInfoFile + (map fst sets) + g + action + goto + (token_specs g) + conflictArray + file + unused_rules + unused_terminals + version + in case info_file of + Just s -> writeFile s info >> hPutStrLn stderr ("Grammar info written to: " ++ s) + Nothing -> return () diff --git a/packages/tabular/src/Happy/Tabular/Tables.lhs b/packages/tabular/src/Happy/Tabular/Tables.lhs new file mode 100644 index 00000000..466be1c5 --- /dev/null +++ b/packages/tabular/src/Happy/Tabular/Tables.lhs @@ -0,0 +1,24 @@ +Datatypes for goto and action tables which are consumed by happy-backend. + +> module Happy.Tabular.Tables ( +> LRAction(..), ActionTable, Goto(..), GotoTable +> ) where + +> import Happy.Grammar + +> import Data.Array + +> data LRAction = LR'Shift Int Priority -- state number and priority +> | LR'Reduce Int Priority-- rule no and priority +> | LR'Accept -- :-) +> | LR'Fail -- :-( +> | LR'MustFail -- :-( +> | LR'Multiple [LRAction] LRAction -- conflict +> deriving (Eq, Show) + +> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction) + +> data Goto = Goto Int | NoGoto +> deriving(Eq, Show) + +> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto) diff --git a/src/GenUtils.lhs b/src/GenUtils.lhs index ebcc7826..709f601e 100644 --- a/src/GenUtils.lhs +++ b/src/GenUtils.lhs @@ -5,12 +5,20 @@ All the code below is understood to be in the public domain. ----------------------------------------------------------------------------- > module GenUtils ( - > str, char, nl, brack, brack', > interleave, interleave', -> strspace, maybestr +> strspace, maybestr, +> die, dieHappy, +> optPrint, +> getProgramName > ) where +> import Data.List (isSuffixOf) +> import Control.Monad +> import System.IO (stderr, hPutStr) +> import System.Environment +> import System.Exit (exitWith, ExitCode(..)) + %------------------------------------------------------------------------------- Fast string-building functions. @@ -36,3 +44,19 @@ Fast string-building functions. > brack s = str ('(' : s) . char ')' > brack' :: (String -> String) -> String -> String > brack' s = char '(' . s . char ')' + +> die :: String -> IO a +> die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +> dieHappy :: String -> IO a +> dieHappy s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + +> getProgramName :: IO String +> getProgramName = liftM (`withoutSuffix` ".bin") getProgName +> where str' `withoutSuffix` suff +> | suff `isSuffixOf` str' = take (length str' - length suff) str' +> | otherwise = str' + +> optPrint :: Bool -> IO () -> IO () +> optPrint b io = +> when b (putStr "\n---------------------\n" >> io) diff --git a/src/Main.lhs b/src/Main.lhs index 20738439..d7e5c6b2 100644 --- a/src/Main.lhs +++ b/src/Main.lhs @@ -1,5 +1,4 @@ ------------------------------------------------------------------------------ -The main driver. + main driver. (c) 1993-2003 Andy Gill, Simon Marlow GLR amendments (c) University of Durham, Ben Medlock 2001 @@ -11,24 +10,22 @@ 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.Tabular +> import Happy.Tabular.Main +> import GenUtils > import ProduceCode (produceParser) > import ProduceGLRCode -> import Happy.Tabular.Info (genInfoFile) > import Target (Target(..)) > import System.Console.GetOpt -> import Control.Monad ( liftM, when ) +> import Control.Monad ( 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 () @@ -83,55 +80,23 @@ Mangle the syntax into something useful. > 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 -> version -> case info_filename of -> Just s -> do -> writeFile s info -> hPutStrLn stderr ("Grammar info written to: " ++ s) -> Nothing -> return () +> infoFileName <- getInfoFileName name cli + +Print the grammar. + +> when (DumpMangle `elem` cli) $ putStr (show g) + +Convert the grammar into action and goto tables. +> let tabularArgs = TabularArgs { +> inFile = fl_name, +> infoFile = infoFileName, +> dumpLR0 = DumpLR0 `elem` cli, +> dumpLA = DumpLA `elem` cli, +> dumpAction = DumpAction `elem` cli, +> dumpGoto = DumpGoto `elem` cli +> } +> (action, goto, _, _) <- runTabular (OptGLR `elem` cli) tabularArgs g version Pretty print the AbsSyn. @@ -143,31 +108,6 @@ Pretty print the AbsSyn. > 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: @@ -276,25 +216,9 @@ 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 = [] @@ -307,6 +231,7 @@ The command line arguments. > | DumpAction > | DumpGoto > | DumpLA +> > | DumpVersion > | DumpHelp > | OptInfoFile (Maybe String) diff --git a/src/ProduceCode.lhs b/src/ProduceCode.lhs index faf5e8e5..f18f63cd 100644 --- a/src/ProduceCode.lhs +++ b/src/ProduceCode.lhs @@ -13,7 +13,7 @@ The code generator. > import GenUtils ( str, char, nl, strspace, > interleave, interleave', maybestr, > brack, brack' ) -> import Happy.Tabular.LALR +> import Happy.Tabular.Tables > import Data.Maybe ( isJust, isNothing, fromMaybe ) > import Data.Char ( ord, chr ) diff --git a/src/ProduceGLRCode.lhs b/src/ProduceGLRCode.lhs index d3570633..c8262cae 100644 --- a/src/ProduceGLRCode.lhs +++ b/src/ProduceGLRCode.lhs @@ -21,7 +21,7 @@ This module is designed as an extension to the Haskell parser generator Happy. > import Data.Char ( isSpace, isAlphaNum ) > import Data.List ( nub, (\\), sort, find, tails ) > import Data.Version ( showVersion ) -> import Happy.Tabular.LALR +> import Happy.Tabular.Tables %----------------------------------------------------------------------------- File and Function Names