Remove code changes

packages/grammar/src/Happy/Grammar/Grammar.lhs

@@ -28,7 +28,12 @@ The Grammar data type.
 
 > data Production
 >       = Production Name [Name] (String,[Int]) Priority
->       deriving (Show)
+
+#ifdef DEBUG
+
+>       deriving Show
+
+#endif
 
 > data Grammar
 >       = Grammar {
@@ -53,11 +58,11 @@ The Grammar data type.
 >               attributetype     :: String,
 >               lexer             :: Maybe (String,String),
 >               error_handler     :: Maybe String,
->               error_sig         :: ErrorHandlerType,
->               hd                :: Maybe String,
->               tl                :: Maybe String
+>               error_sig         :: ErrorHandlerType
 >       }
 
+#ifdef DEBUG
+
 > instance Show Grammar where
 >       showsPrec _ (Grammar
 >               { productions           = p
@@ -83,12 +88,24 @@ The Grammar data type.
 >        . showString "\neof = "           . shows eof
 >        . showString "\n"
 
+#endif
+
 > data Assoc = LeftAssoc | RightAssoc | None
+
+#ifdef DEBUG
+
 >       deriving Show
 
+#endif
+
 > data Priority = No | Prio Assoc Int | PrioLowest
+
+#ifdef DEBUG
+
 >       deriving Show
 
+#endif
+
 > instance Eq Priority where
 >   No == No = True
 >   Prio _ i == Prio _ j = i == j

packages/tabular/src/Happy/Tabular.hs

@@ -1,93 +1,84 @@
-module Happy.Tabular(
-    mkFirst, genLR0Items, genLookaheads, genLR1States, genActionTable, genGotoTable, countConflicts,
-    Lr0Item(..), Lr1Item(..), Lr0State, Lr1State, LookaheadInfo,
-    TabularArgs(..), TabularResult, runTabular
-  ) where
+module Happy.Tabular (TabularArgs(..), Lr1State, TabularResult, runTabular) where
 
 import Happy.Grammar.Grammar
-import Happy.Tabular.NameSet (NameSet)
 import Happy.Tabular.Tables
 import Happy.Tabular.First
-import qualified Happy.Tabular.LALR as LALR
-import Happy.Tabular.LALR (Lr0Item, Lr1Item, precalcClosure0, propLookaheads, calcLookaheads, mergeLookaheadInfo)
+import Happy.Tabular.LALR
 import Happy.Tabular.FindRedundancies
 import Happy.Tabular.Info
 import Data.Set (Set)
 import Data.Array (Array)
 import System.IO
-import System.Exit
+import System.Exit hiding (die)
 import Control.Monad
 
--------- Pure tabular functions, may be called without creating TabularArgs --------
-
-type Lr0State = (Set Lr0Item, [(Name, Int)])
-type Lr1State = ([Lr1Item], [(Name, Int)])
-type LookaheadInfo = Array Int [(Lr0Item, NameSet)]
-
-genLR0Items :: Grammar -> [Lr0State]
-genLR0Items g = LALR.genLR0items g (precalcClosure0 g)
-
-genLookaheads :: Grammar -> [Lr0State] -> ([Name] -> NameSet) -> LookaheadInfo
-genLookaheads g sets first =
-    let (spont, prop) = propLookaheads g sets first in
-        calcLookaheads (length sets) spont prop
-
-genLR1States :: LookaheadInfo -> [Lr0State] -> [Lr1State]
-genLR1States = mergeLookaheadInfo
-
-genActionTable :: Grammar -> ([Name] -> NameSet) -> [Lr1State] -> ActionTable
-genActionTable = LALR.genActionTable
-
-genGotoTable :: Grammar -> [Lr0State] -> GotoTable
-genGotoTable = LALR.genGotoTable
-
-countConflicts :: ActionTable -> (Array Int (Int, Int), (Int, Int))
-countConflicts = LALR.countConflicts
-
 -------- Main entry point (runTabular) --------
 
 data TabularArgs = TabularArgs {
   inFile :: String, -- printed to the info file, not used otherwise
-  infoFile :: Maybe String,
+  infoFile :: Maybe String
+
+#ifdef DEBUG
 
+  , 
   dumpLR0 :: Bool,
   dumpLA :: Bool,
   dumpAction :: Bool,
   dumpGoto :: Bool
+
+#endif
+
 }
 
+type Lr1State = ([Lr1Item], [(Name, Int)])
 type TabularResult = (ActionTable, GotoTable, [Lr1State], [Int])
 
-runTabular :: TabularArgs -> Grammar -> IO TabularResult
-runTabular args g = 
-   let first       = mkFirst g
-       sets        = genLR0Items g
-       la          = genLookaheads g sets first
-       items2      = genLR1States la sets
-       goto        = genGotoTable g sets
-       action      = genActionTable g first items2
-       (conflictArray, (sr,rr)) = (countConflicts action)
+runTabular :: TabularArgs -> Bool -> Grammar -> IO TabularResult
+runTabular args glr g = 
+    let first       = {-# SCC "First" #-} (mkFirst g)
+        closures    = {-# SCC "Closures" #-} (precalcClosure0 g)
+        sets        = {-# SCC "LR0_Sets" #-} (genLR0items g closures)
+        _lainfo@(spont,prop) = {-# SCC "Prop" #-} (propLookaheads g sets first)
+        la          = {-# SCC "Calc" #-} (calcLookaheads (length sets) spont prop)
+        items2      = {-# SCC "Merge" #-} (mergeLookaheadInfo la sets)
+        goto        = {-# SCC "Goto" #-} (genGotoTable g sets)
+        action      = {-# SCC "Action" #-} (genActionTable g first items2)
+        (conflictArray,(sr,rr))   = {-# SCC "Conflict" #-} (countConflicts action)
     in do
+
+#ifdef DEBUG
+
         optPrint (dumpLR0 args) (print sets)
         optPrint (dumpLA args) (print la)
         optPrint (dumpAction args) (print action)
         optPrint (dumpGoto args) (print goto)
-        (unused_rules, unused_terminals) <- reportUnusedRules g action
+
+#endif
+
+        (unused_rules, unused_terminals) <- reportUnusedRules glr g action
         writeInfoFile sets g action goto conflictArray (inFile args) (infoFile args) unused_rules unused_terminals
         reportConflicts g sr rr
         return (action, goto, items2, unused_rules)
+
+#ifdef DEBUG
+
     where
       optPrint b io = when b (putStr "\n---------------------\n" >> io)
 
+#endif
+
 
 -------- Helpers --------
 
-reportUnusedRules :: Grammar -> ActionTable -> IO ([Int], [String])
-reportUnusedRules g action = 
-    let result@(unused_rules, unused_terminals) = find_redundancies first_reduction g action in do
-        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))
-        return result
+reportUnusedRules :: Bool -> Grammar -> ActionTable -> IO ([Int], [String])
+reportUnusedRules glr g action = 
+    let reduction_filter = if glr then any_reduction else first_reduction
+        (unused_rules, unused_terminals) = find_redundancies reduction_filter g action in do
+    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)))
+    return (unused_rules, unused_terminals)
 
 reportConflicts :: Grammar -> Int -> Int -> IO ()
 reportConflicts g sr rr = case expect g of
@@ -106,14 +97,27 @@ reportConflicts g sr rr = case expect g of
         if rr /= 0
           then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr)
           else return ()
-#if !MIN_VERSION_base(4,8,0)
-    where die s = hPutStr stderr s >> exitWith (ExitFailure 1) 
-#endif
+
+die :: String -> IO a
+die s = hPutStr stderr s >> exitWith (ExitFailure 1)
 
 type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)])
 writeInfoFile :: [ItemSetWithGotos] -> Grammar -> ActionTable -> GotoTable -> Array Int (Int,Int) -> String -> Maybe String -> [Int] -> [String] -> IO ()
 writeInfoFile sets g action goto conflictArray file info_file unused_rules unused_terminals = 
     let info = genInfoFile (map fst sets) g action goto (token_specs g) conflictArray file unused_rules unused_terminals in
         case info_file of
             Just s -> writeFile s info >> hPutStrLn stderr ("Grammar info written to: " ++ s)
-            Nothing -> return ()
+            Nothing -> return ()
+
+---
+--- selects what counts as a reduction when calculating used/unused
+
+any_reduction :: LRAction -> [Int]
+any_reduction (LR'Reduce r _)    = [r]
+any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as)
+any_reduction _                  = []
+
+first_reduction :: LRAction -> [Int]
+first_reduction (LR'Reduce r _)   = [r]
+first_reduction (LR'Multiple _ a) = first_reduction a   -- eg R/R conflict
+first_reduction _                 = []

packages/tabular/src/Happy/Tabular/FindRedundancies.lhs

@@ -32,17 +32,4 @@ Find unused rules and tokens
 > 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
-
-> any_reduction :: LRAction -> [Int]
-> any_reduction (LR'Reduce r _)    = [r]
-> any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as)
-> any_reduction _                  = []
-
-> first_reduction :: LRAction -> [Int]
-> first_reduction (LR'Reduce r _)   = [r]
-> first_reduction (LR'Multiple _ a) = first_reduction a   -- eg R/R conflict
-> first_reduction _                 = []
+> is_shift _                          = False

packages/tabular/src/Happy/Tabular/LALR.lhs

@@ -36,11 +36,24 @@ Generation of LALR parsing tables.
 This means rule $a$, with dot at $b$ (all starting at 0)
 
 > data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int                  -- (rule, dot)
->       deriving (Eq,Ord,Show)
+>       deriving (Eq,Ord
+
+#ifdef DEBUG
+
+>       ,Show
+
+#endif
+
+>       )
 
 > data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet  -- (rule, dot, lookahead)
+
+#ifdef DEBUG
+
 >       deriving (Show)
 
+#endif
+
 > type RuleList = [Lr0Item]
 
 -----------------------------------------------------------------------------

packages/tabular/src/Happy/Tabular/Tables.lhs

@@ -14,11 +14,27 @@ Datatypes for goto and action tables which are consumed by happy-backend.
 >               | LR'Fail               -- :-(
 >               | LR'MustFail           -- :-(
 >               | LR'Multiple [LRAction] LRAction       -- conflict
->       deriving (Eq, Show)
+>       deriving(Eq
+
+#ifdef DEBUG
+
+>       ,Show
+
+#endif
+
+>       )
 
 > type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction)
 
 > data Goto = Goto Int | NoGoto
->       deriving(Eq, Show)
+>       deriving(Eq
+
+#ifdef DEBUG
+
+>       ,Show
+
+#endif
+
+>       )
 
 > type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto)

src/AbsSyn.lhs

@@ -47,8 +47,13 @@ Here is the abstract syntax of the language we parse.
 >     = PrecNone               -- no user-specified precedence
 >     | PrecShift              -- %shift
 >     | PrecId String          -- %prec ID
+
+#ifdef DEBUG
+
 >   deriving Show
 
+#endif
+
 %-----------------------------------------------------------------------------
 Parser Generator Directives.