diff --git a/packages/backend-lalr/happy-backend-lalr.cabal b/packages/backend-lalr/happy-backend-lalr.cabal index eae9353b..099ee99e 100644 --- a/packages/backend-lalr/happy-backend-lalr.cabal +++ b/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 \ No newline at end of file + other-modules: Paths_happy_backend_lalr diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs b/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs index 6f08bfba..f96369f3 100644 --- a/packages/backend-lalr/src/Happy/Backend/LALR/ProduceCode.lhs +++ b/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 diff --git a/packages/backend-lalr/src/Happy/Backend/LALR/SyntaxLib.hs b/packages/backend-lalr/src/Happy/Backend/LALR/SyntaxLib.hs new file mode 100644 index 00000000..a14b9fb2 --- /dev/null +++ b/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