Begin to separate grammars from their eliminators

Instead of assuming we always have raw Haskell code (a `String`) which
eliminates each production rule, use a type variable.

As one would hope, much code only cares about the grammar itself, and
works with that type abstract. The new types thus recover free theorems,
yay! Only a little bit of the frontend and the backends actually wants
it to be strings.

These type parameter can be leveraged in the future. Some possibilities
are:

- a TH-based frontend to Happy

- interpreting the grammar where we don't have custom elimination rules
  at all, but just create an "untyped" parse tree.

lib/backend-glr/src/Happy/Backend/GLR/ProduceCode.lhs

@@ -89,7 +89,7 @@ the driver and data strs (large template).
 >        -> Maybe String  -- Module header
 >        -> Maybe String  -- User-defined stuff (token DT, lexer etc.)
 >        -> (DebugMode,Options)       -- selecting code-gen style
->        -> Grammar       -- Happy Grammar
+>        -> Grammar String -- Happy Grammar
 >        -> Pragmas       -- Pragmas in the .y-file
 >        -> (String       -- data
 >           ,String)      -- parser
@@ -248,7 +248,7 @@ Formats the tables as code.
 >           ,GotoTable)         -- Goto table from Happy
 >        -> SemInfo             -- info about production mapping
 >        -> GhcExts             -- Use unboxed values?
->        -> Grammar             -- Happy Grammar
+>        -> Grammar String      -- Happy Grammar
 >        -> ShowS
 >
 > mkTbls (action,goto) sem_info exts g
@@ -263,7 +263,7 @@ Formats the tables as code.
 Create a mapping of Happy grammar symbol integers to the data representation
 that will be used for them in the GLR parser.
 
-> mkGSymMap :: Grammar -> [(Name,String)]
+> mkGSymMap :: Grammar String -> [(Name,String)]
 > mkGSymMap g
 >  =    [ -- (errorTok, prefix ++ "Error")
 >       ]
@@ -291,7 +291,7 @@ It also shares identical reduction values as CAFs
 
 > writeActionTbl
 >  :: ActionTable -> [(Int,String)] -> (Name->String)
->                                       -> GhcExts -> Grammar -> ShowS
+>                                       -> GhcExts -> Grammar String -> ShowS
 > writeActionTbl acTbl gsMap semfn_map exts g
 >  = interleave "\n"
 >  $ map str
@@ -372,7 +372,7 @@ Do the same with the Happy goto table.
 %-----------------------------------------------------------------------------
 Create the 'GSymbol' ADT for the symbols in the grammar
 
-> mkGSymbols :: Grammar -> Pragmas -> ShowS
+> mkGSymbols :: Grammar String -> Pragmas -> ShowS
 > mkGSymbols g pragmas
 >  = str dec
 >  . str eof
@@ -423,7 +423,7 @@ Creating a type for storing semantic rules
 > type SemInfo
 >  = [(String, String, [Int], [((Int,Int), ([(Int,String)],String), [Int])])]
 
-> mkGSemType :: Options -> Grammar -> Pragmas -> (ShowS, SemInfo)
+> mkGSemType :: Options -> Grammar String -> Pragmas -> (ShowS, SemInfo)
 > mkGSemType (TreeDecode,_,_) g pragmas
 >  = (def, map snd syms)
 >  where
@@ -702,11 +702,11 @@ Util Functions
 ---
 remove Happy-generated start symbols.
 
-> user_non_terminals :: Grammar -> [Name]
+> user_non_terminals :: Grammar String -> [Name]
 > user_non_terminals g
 >  = non_terminals g \\ start_productions g
 
-> start_productions :: Grammar -> [Name]
+> start_productions :: Grammar String -> [Name]
 > start_productions g = [ s | (_,s,_,_) <- starts g ]
 
 

lib/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs

@@ -28,7 +28,7 @@ The code generator.
 %-----------------------------------------------------------------------------
 Produce the complete output file.
 
-> produceParser :: Grammar                      -- grammar info
+> produceParser :: Grammar String               -- grammar info
 >               -> Maybe AttributeGrammarExtras
 >               -> Pragmas                      -- pragmas supplied in the .y-file
 >               -> ActionTable                  -- action table

lib/frontend/boot-src/Parser.ly

@@ -55,14 +55,14 @@ The parser.
 > parser :: { BookendedAbsSyn }
 >       : optCode core_parser optCode   { BookendedAbsSyn $1 $2 $3 }
 
-> core_parser :: { AbsSyn }
+> core_parser :: { AbsSyn String }
 >       : tokInfos "%%" rules           { AbsSyn (reverse $1) (reverse $3) }
 
-> rules :: { [Rule] }
+> rules :: { [Rule String] }
 >       : rules rule    { $2 : $1 }
 >       | rule          { [$1] }
 
-> rule :: { Rule }
+> rule :: { Rule String }
 >       : id params "::" code ":" prods         { Rule $1 $2 $6 (Just $4) }
 >       | id params "::" code id ":" prods      { Rule $1 $2 $7 (Just $4) }
 >       | id params ":" prods                   { Rule $1 $2 $4 Nothing }
@@ -75,11 +75,11 @@ The parser.
 >       : id                            { [$1] }
 >       | comma_ids "," id              { $3 : $1 }
 
-> prods :: { [Prod] }
+> prods :: { [Prod String] }
 >       : prod "|" prods                { $1 : $3 }
 >       | prod                          { [$1] }
 
-> prod :: { Prod }
+> prod :: { Prod String }
 >       : terms prec code ";"           {% lineP >>= \l -> return (Prod $1 $3 l $2) }
 >       | terms prec code               {% lineP >>= \l -> return (Prod $1 $3 l $2) }
 

lib/frontend/src/Happy/Frontend/AbsSyn.lhs

@@ -21,25 +21,25 @@ Here is the abstract syntax of the language we parse.
 > data BookendedAbsSyn
 >     = BookendedAbsSyn
 >         (Maybe String)       -- header
->         AbsSyn
+>         (AbsSyn String)
 >         (Maybe String)       -- footer
 
-> data AbsSyn
+> data AbsSyn e
 >     = AbsSyn
 >         [Directive String]   -- directives
->         [Rule]               -- productions
+>         [Rule e]             -- productions
 
-> data Rule
+> data Rule e
 >     = Rule
 >         String               -- name of the rule
 >         [String]             -- parameters (see parametrized productions)
->         [Prod]               -- productions
+>         [Prod e]             -- productions
 >         (Maybe String)       -- type of the rule
 
-> data Prod
+> data Prod e
 >     = Prod
 >         [Term]               -- terms that make up the rule
->         String               -- code body that runs when the rule reduces
+>         e                    -- code body that runs when the rule reduces
 >         Int                  -- line number
 >         Prec                 -- inline precedence annotation for the rule
 

lib/frontend/src/Happy/Frontend/Mangler.lhs

@@ -6,6 +6,8 @@ The Grammar data type.
 
 Mangler converts AbsSyn to Grammar
 
+> {-# LANGUAGE ScopedTypeVariables #-}
+
 > module Happy.Frontend.Mangler (mangler) where
 
 > import Happy.Grammar
@@ -27,32 +29,35 @@ Mangler converts AbsSyn to Grammar
 
 This bit is a real mess, mainly because of the error message support.
 
-> mangler :: FilePath -> AbsSyn -> Either [ErrMsg] (Grammar, Maybe AttributeGrammarExtras, Pragmas)
+> mangler :: FilePath -> AbsSyn String -> Either [ErrMsg] (Grammar String, Maybe AttributeGrammarExtras, Pragmas)
 > mangler file abssyn@(AbsSyn dirs _)
 >   | null errs = Right (gd, mAg, ps)
 >   | otherwise = Left errs
 >   where mAg = getAttributeGrammarExtras dirs
->         ((gd, ps), errs) = runWriter (manglerM checkCode file abssyn)
+>         ((gd, ps), errs) = runWriter (manglerM "no code" checkCode file abssyn)
 
 If any attribute directives were used, we are in an attribute grammar, so
 go do special processing.  If not, pass on to the regular processing routine
 
->         checkCode :: CodeChecker
+>         checkCode :: CodeChecker String
 >         checkCode = case mAg of
 >             Nothing -> \lhs _             code ->
 >                 doCheckCode (length lhs) code
 >             Just a  -> \lhs nonterm_names code ->
 >                 rewriteAttributeGrammar lhs nonterm_names code a
 
 > -- | Function to check elimination rules
-> type CodeChecker = [Name] -> [Name] -> String -> M (String,[Int])
+> type CodeChecker e = [Name] -> [Name] -> e -> M (e, [Int])
 
 > manglerM
->   :: CodeChecker
+>   :: forall e
+>   .  e
+>   -- ^ Empty elimination rule, used for starting productions. Will never be run.
+>   -> CodeChecker e
 >   -> FilePath
->   -> AbsSyn
->   -> M (Grammar, Pragmas)
-> manglerM checkCode file (AbsSyn dirs rules') =
+>   -> AbsSyn e
+>   -> M (Grammar e, Pragmas)
+> manglerM noCode checkCode file (AbsSyn dirs rules') =
 >   -- add filename to all error messages
 >   mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do
 
@@ -116,7 +121,7 @@ Start symbols...
 >   let
 >       parser_names   = [ s | TokenName s _ _ <- starts' ]
 >       start_partials = [ b | TokenName _ _ b <- starts' ]
->       start_prods = zipWith (\nm tok -> Production nm [tok] ("no code",[]) No)
+>       start_prods = zipWith (\nm tok -> Production nm [tok] (noCode,[]) No)
 >                        start_names start_toks
 
 Deal with priorities...
@@ -149,7 +154,7 @@ Translate the rules from string to name-based.
 >       transRule (nt, prods, _ty)
 >         = mapM (finishRule nt) prods
 >
->       finishRule :: Name -> Prod1 -> Writer [ErrMsg] Production
+>       finishRule :: Name -> Prod1 e -> Writer [ErrMsg] (Production e)
 >       finishRule nt (Prod1 lhs code line prec)
 >         = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do
 >           lhs' <- mapM mapToName lhs

lib/frontend/src/Happy/Frontend/ParamRules.hs

@@ -13,7 +13,7 @@ import qualified Data.Map as M    -- XXX: Make it work with old GHC.
 -- This transformation is fairly straightforward: we walk through every rule
 -- and collect every possible instantiation of parameterized productions. Then,
 -- we generate a new non-parametrized rule for each of these.
-expand_rules :: [Rule] -> Either String [Rule1]
+expand_rules :: [Rule e] -> Either String [Rule1 e]
 expand_rules rs = do let (funs,rs1) = split_rules rs
                      (as,is) <- runM2 (mapM (`inst_rule` []) rs1)
                      bs <- make_insts funs (S.toList is) S.empty
@@ -22,13 +22,13 @@ expand_rules rs = do let (funs,rs1) = split_rules rs
 type RuleName = String
 
 data Inst     = Inst RuleName [RuleName] deriving (Eq, Ord)
-newtype Funs  = Funs (M.Map RuleName Rule)
+newtype Funs e = Funs (M.Map RuleName (Rule e))
 
 -- | Similar to 'Rule', but `Term`'s have been flattened into `RuleName`'s
-data Rule1    = Rule1 RuleName [Prod1] (Maybe (String, Subst))
+data Rule1 e  = Rule1 RuleName [Prod1 e] (Maybe (String, Subst))
 
 -- | Similar to 'Prod', but `Term`'s have been flattened into `RuleName`'s
-data Prod1    = Prod1 [RuleName] String Int Prec
+data Prod1 e  = Prod1 [RuleName] e Int Prec
 
 inst_name :: Inst -> RuleName
 inst_name (Inst f [])  = f
@@ -57,11 +57,11 @@ from_terms :: Subst -> [Term] -> M1 [RuleName]
 from_terms s ts = mapM (from_term s) ts
 
 -- XXX: perhaps change the line to the line of the instance
-inst_prod :: Subst -> Prod -> M1 Prod1
+inst_prod :: Subst -> Prod e -> M1 (Prod1 e)
 inst_prod s (Prod ts c l p)  = do xs <- from_terms s ts
                                   return (Prod1 xs c l p)
 
-inst_rule :: Rule -> [RuleName] -> M2 Rule1
+inst_rule :: Rule e -> [RuleName] -> M2 (Rule1 e)
 inst_rule (Rule x xs ps t) ts  = do s <- build xs ts []
                                     ps1 <- lift $ mapM (inst_prod s) ps
                                     let y = inst_name (Inst x ts)
@@ -73,7 +73,7 @@ inst_rule (Rule x xs ps t) ts  = do s <- build xs ts []
 
         err m = throwError ("In " ++ inst_name (Inst x ts) ++ ": " ++ m)
 
-make_rule :: Funs -> Inst -> M2 Rule1
+make_rule :: Funs e -> Inst -> M2 (Rule1 e)
 make_rule (Funs funs) (Inst f xs) =
   case M.lookup f funs of
     Just r  -> inst_rule r xs
@@ -84,7 +84,7 @@ runM2 m = case runWriter (runExceptT m) of
             (Left e,_)   -> Left e
             (Right a,xs) -> Right (a,xs)
 
-make_insts :: Funs -> [Inst] -> S.Set Inst -> Either String [Rule1]
+make_insts :: Funs e -> [Inst] -> S.Set Inst -> Either String [Rule1 e]
 make_insts _ [] _ = return []
 make_insts funs is done =
   do (as,ws) <- runM2 (mapM (make_rule funs) is)
@@ -94,7 +94,7 @@ make_insts funs is done =
      return (as++bs)
 
 
-split_rules :: [Rule] -> (Funs,[Rule])
+split_rules :: [Rule e] -> (Funs e,[Rule e])
 split_rules rs = let (xs,ys) = partition has_args rs
                  in (Funs (M.fromList [ (x,r) | r@(Rule x _ _ _) <- xs ]),ys)
   where has_args (Rule _ args _ _) = not (null args)

lib/frontend/src/Happy/Frontend/Parser.hs

@@ -30,22 +30,22 @@ happyIn4 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap4 x)
 happyOut4 :: (HappyAbsSyn ) -> HappyWrap4
 happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x
 {-# INLINE happyOut4 #-}
-newtype HappyWrap5 = HappyWrap5 (AbsSyn)
-happyIn5 :: (AbsSyn) -> (HappyAbsSyn )
+newtype HappyWrap5 = HappyWrap5 (AbsSyn String)
+happyIn5 :: (AbsSyn String) -> (HappyAbsSyn )
 happyIn5 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap5 x)
 {-# INLINE happyIn5 #-}
 happyOut5 :: (HappyAbsSyn ) -> HappyWrap5
 happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x
 {-# INLINE happyOut5 #-}
-newtype HappyWrap6 = HappyWrap6 ([Rule])
-happyIn6 :: ([Rule]) -> (HappyAbsSyn )
+newtype HappyWrap6 = HappyWrap6 ([Rule String])
+happyIn6 :: ([Rule String]) -> (HappyAbsSyn )
 happyIn6 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap6 x)
 {-# INLINE happyIn6 #-}
 happyOut6 :: (HappyAbsSyn ) -> HappyWrap6
 happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x
 {-# INLINE happyOut6 #-}
-newtype HappyWrap7 = HappyWrap7 (Rule)
-happyIn7 :: (Rule) -> (HappyAbsSyn )
+newtype HappyWrap7 = HappyWrap7 (Rule String)
+happyIn7 :: (Rule String) -> (HappyAbsSyn )
 happyIn7 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap7 x)
 {-# INLINE happyIn7 #-}
 happyOut7 :: (HappyAbsSyn ) -> HappyWrap7
@@ -65,15 +65,15 @@ happyIn9 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap9 x)
 happyOut9 :: (HappyAbsSyn ) -> HappyWrap9
 happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x
 {-# INLINE happyOut9 #-}
-newtype HappyWrap10 = HappyWrap10 ([Prod])
-happyIn10 :: ([Prod]) -> (HappyAbsSyn )
+newtype HappyWrap10 = HappyWrap10 ([Prod String])
+happyIn10 :: ([Prod String]) -> (HappyAbsSyn )
 happyIn10 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap10 x)
 {-# INLINE happyIn10 #-}
 happyOut10 :: (HappyAbsSyn ) -> HappyWrap10
 happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x
 {-# INLINE happyOut10 #-}
-newtype HappyWrap11 = HappyWrap11 (Prod)
-happyIn11 :: (Prod) -> (HappyAbsSyn )
+newtype HappyWrap11 = HappyWrap11 (Prod String)
+happyIn11 :: (Prod String) -> (HappyAbsSyn )
 happyIn11 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap11 x)
 {-# INLINE happyIn11 #-}
 happyOut11 :: (HappyAbsSyn ) -> HappyWrap11

lib/frontend/src/Happy/Frontend/PrettyGrammar.hs

@@ -9,7 +9,7 @@ import Happy.Frontend.AbsSyn
 render :: Doc -> String
 render = maybe "" ($ "")
 
-ppAbsSyn :: AbsSyn -> Doc
+ppAbsSyn :: AbsSyn String -> Doc
 ppAbsSyn (AbsSyn ds rs) = vsep (vcat (map ppDirective ds) : map ppRule rs)
 
 ppDirective :: Directive a -> Doc
@@ -22,13 +22,13 @@ ppDirective dir =
   where
   prec x xs = text x <+> hsep (map text xs)
 
-ppRule :: Rule -> Doc
+ppRule :: Rule String -> Doc
 ppRule (Rule name _ prods _) = text name
                             $$ vcat (zipWith (<+>) starts (map ppProd prods))
   where
   starts = text "  :" : repeat (text "  |")
 
-ppProd :: Prod -> Doc
+ppProd :: Prod String -> Doc
 ppProd (Prod ts _ _ p) = psDoc <+> ppPrec p
   where
   psDoc   = if null ts then text "{- empty -}" else hsep (map ppTerm ts)

lib/grammar/src/Happy/Grammar.lhs

@@ -24,14 +24,14 @@ The Grammar data type.
 > import Data.Char (isAlphaNum)
 > type Name = Int
 
-> data Production
->       = Production Name [Name] (String,[Int]) Priority
+> data Production eliminator
+>       = Production Name [Name] (eliminator,[Int]) Priority
 >       deriving Show
 
-> data Grammar
+> data Grammar eliminator
 >       = Grammar {
->               productions       :: [Production],
->               lookupProdNo      :: Int -> Production,
+>               productions       :: [Production eliminator],
+>               lookupProdNo      :: Int -> Production eliminator,
 >               lookupProdsOfName :: Name -> [Int],
 >               token_specs       :: [(Name,String)],
 >               terminals         :: [Name],
@@ -51,7 +51,7 @@ The Grammar data type.
 >               attributetype     :: String
 >       }
 
-> instance Show Grammar where
+> instance Show eliminator => Show (Grammar eliminator) where
 >       showsPrec _ (Grammar
 >               { productions           = p
 >               , token_specs           = t