SyntaxLib: init, produceReduceArray

Author: int-index

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,7 +577,7 @@ machinery to discard states in the parser...
 >
 >    produceActionTable TargetArrayBased
 >       = produceActionArray
->       . produceReduceArray
+>       . renderDocDec produceReduceArray
 >       . str "happy_n_terms = " . shows n_terminals . str " :: Prelude.Int\n"
 >       . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Prelude.Int\n\n"
 >
@@ -744,15 +745,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 +916,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,74 @@
+module Happy.Backend.LALR.SyntaxLib (
+    DocExp,
+    varE,
+    intE,
+    appE,
+    tupE,
+    listE,
+    varBind,
+    -- DocStmt,
+    DocDec,
+    renderDocDec
+  ) where
+
+import qualified Text.PrettyPrint as PP
+
+newtype Prec = Prec Int
+  deriving (Eq, Ord, 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++)
+
+renderDocDec :: DocDec -> StringBuilder
+renderDocDec (DocDec d) =
+  PP.fullRender PP.PageMode 80 1.5 (\td s -> fromTextDetails td . s) id d
+    . (\s -> '\n' : '\n' : s)
+
+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]
+
+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