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