ProduceCode using syntax combinators

packages/backend-lalr/happy-backend-lalr.cabal

@@ -43,13 +43,15 @@ library
 
   exposed-modules:     Happy.Backend.LALR,
                        Happy.Backend.LALR.Target,
-                       Happy.Backend.LALR.ProduceCode
+                       Happy.Backend.LALR.ProduceCode,
+                       Happy.Backend.LALR.SyntaxLib
   build-depends:       base < 5,
                        array,
+                       pretty,
                        happy-grammar == 1.21.0,
                        happy-tabular == 1.21.0
 
   default-language:    Haskell98
-  default-extensions:  CPP, MagicHash, FlexibleContexts
+  default-extensions:  CPP, MagicHash, FlexibleContexts, GeneralizedNewtypeDeriving
   ghc-options:         -Wall
-  other-modules:       Paths_happy_backend_lalr
+  other-modules:       Paths_happy_backend_lalr

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

@@ -11,6 +11,7 @@ The code generator.
 > import Happy.Grammar
 > import Happy.Backend.LALR.Target ( Target(..) )
 > import Happy.Tabular.LALR
+> import Happy.Backend.LALR.SyntaxLib
 
 > import Data.Maybe                ( isJust, isNothing, fromMaybe )
 > import Data.Char                 ( ord, chr )
@@ -576,9 +577,18 @@ machinery to discard states in the parser...
 >
 >    produceActionTable TargetArrayBased
 >       = produceActionArray
->       . produceReduceArray
->       . str "happy_n_terms = " . shows n_terminals . str " :: Prelude.Int\n"
->       . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Prelude.Int\n\n"
+>       . renderDocDecs [
+>           [produceReduceArray],
+>           [
+>             sigD    "happy_n_terms" (varE "Prelude.Int"),
+>             varBind "happy_n_terms" (intE n_terminals)
+>           ],
+>           [
+>             sigD    "happy_n_nonterms" (varE "Prelude.Int"),
+>             varBind "happy_n_nonterms" (intE n_nonterminals)
+>           ]
+>         ]
+>       . nl
 >
 >    produceExpListPerState
 >       = produceExpListArray
@@ -744,15 +754,13 @@ action array indexed by (terminal * last_state) + state
 >
 >    table_size = length table - 1
 >
->    produceReduceArray
->       = {- str "happyReduceArr :: Array Int a\n" -}
->         str "happyReduceArr = Happy_Data_Array.array ("
->               . shows (n_starts :: Int) -- omit the %start reductions
->               . str ", "
->               . shows n_rules
->               . str ") [\n"
->       . interleave' ",\n" (map reduceArrElem [n_starts..n_rules])
->       . str "\n\t]\n\n"
+>    produceReduceArray =
+>       {- str "happyReduceArr :: Array Int a\n" -}
+>       varBind "happyReduceArr" $
+>         varE "Happy_Data_Array.array"
+>           `appE` tupE [intE n_starts, -- omit the %start reductions
+>                        intE n_rules]
+>           `appE` listE (map reduceArrElem [n_starts..n_rules])
 
 >    n_rules = length prods - 1 :: Int
 
@@ -917,8 +925,7 @@ directive determins the API of the provided function.
 >                               Just _  -> str "(\\(tokens, explist) -> happyError)"
 
 >    reduceArrElem n
->      = str "\t(" . shows n . str " , "
->      . str "happyReduce_" . shows n . char ')'
+>      = tupE [intE n, varE (mkReduceFun n "")]
 
 -----------------------------------------------------------------------------
 -- Produce the parser entry and exit points

packages/backend-lalr/src/Happy/Backend/LALR/SyntaxLib.hs

@@ -0,0 +1,82 @@
+module Happy.Backend.LALR.SyntaxLib (
+    DocExp,
+    varE,
+    intE,
+    appE,
+    tupE,
+    listE,
+    sigD,
+    varBind,
+    -- DocStmt,
+    DocDec,
+    renderDocDecs
+  ) where
+
+import qualified Text.PrettyPrint as PP
+
+newtype Prec = Prec Int
+  deriving (Eq, Ord, Show, Num, Bounded)
+
+atomPrec, appPrec, noPrec :: Prec
+atomPrec = maxBound
+appPrec = 10
+noPrec = (-1)
+
+type StringBuilder = String -> String
+
+fromTextDetails :: PP.TextDetails -> StringBuilder
+fromTextDetails td =
+  case td of
+    PP.Chr c -> (c:)
+    PP.Str str -> (str++)
+    PP.PStr str -> (str++)
+
+renderDocDecs :: [[DocDec]] -> StringBuilder
+renderDocDecs dss =
+  PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d
+  where
+    d = PP.vcat (map renderGroup dss)
+    renderGroup ds = PP.vcat [ d1 | DocDec d1 <- ds ] PP.$$ PP.text ""
+
+newtype DocExp = DocExp (Prec -> PP.Doc)
+
+-- newtype DocStmt = DocStmt Doc
+
+newtype DocDec = DocDec PP.Doc
+
+varE :: String -> DocExp
+varE str = DocExp (\_ -> PP.text str)
+
+intE :: Int -> DocExp
+intE n = DocExp (\_ -> parensIf (n < 0) (PP.int n))
+
+appE :: DocExp -> DocExp -> DocExp
+appE (DocExp e1) (DocExp e2) =
+  DocExp $ \p -> parensIf (p > appPrec) $
+    PP.sep [e1 appPrec, e2 atomPrec]
+
+tupE :: [DocExp] -> DocExp
+tupE ds =
+  DocExp $ \_ ->
+    PP.parens $ PP.sep $ PP.punctuate PP.comma $
+      [d noPrec | DocExp d <- ds]
+
+listE :: [DocExp] -> DocExp
+listE ds =
+  DocExp $ \_ ->
+    PP.brackets $ PP.sep $ PP.punctuate PP.comma $
+      [d noPrec | DocExp d <- ds]
+
+sigD :: String -> DocExp -> DocDec
+sigD lhs (DocExp rhs) =
+  DocDec $
+    PP.hang (PP.text lhs PP.<+> PP.text "::") 2 (rhs noPrec)
+
+varBind :: String -> DocExp -> DocDec
+varBind lhs (DocExp rhs) =
+  DocDec $
+    PP.hang (PP.text lhs PP.<+> PP.text "=") 2 (rhs noPrec)
+
+parensIf :: Bool -> PP.Doc -> PP.Doc
+parensIf True = PP.parens
+parensIf False = id