Split off happy-grammar and happy-tabular

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
+> mkHappyVar n  = "happy_var_" ++ show n

packages/tabular/happy-tabular.cabal

@@ -41,11 +41,14 @@ 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,
                        happy-grammar == 1.21.0
 
   default-language:    Haskell98
   default-extensions:  CPP, MagicHash, FlexibleContexts, NamedFieldPuns
-  ghc-options: -Wall
+  ghc-options: -Wall

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 _                 = []

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 _                 = []

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)
+> interleave' s = foldr1 (\a b -> a . str s . 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:
 

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 ()

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)

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)