[ fix #340 ] fix Makefile and Test.hs for --glr parsers

The generated Test.hs file lacks imports, regressions introduced by work on #331 and #278.
BNFC · Feb 14, 2021 · 32a3d82 · 32a3d82
1 parent 2f15571
commit 32a3d82
Show file tree

Hide file tree

Showing 2 changed files with 23 additions and 16 deletions.
diff --git a/source/CHANGELOG.md b/source/CHANGELOG.md
@@ -3,6 +3,7 @@
 Andreas Abel <[email protected]>
 
 * Haskell: the `--functor` option now produces position-annotated ASTs [#176,#327]. Thanks @Commelina!
+* Haskell: fix generated `Makefile` and test parser for `--glr` mode [#340]
 * Haskell(/GADT): generated modules import `Prelude` explicitly, compatible with `{-# LANGUAGE NoImplicitPrelude #-}`
 * Haskell: generated code is warning free (and mostly that for `--xml[t]`) [#331]
 * Haskell: generated printer more robust wrt. identifier clashes [#337]

diff --git a/source/src/BNFC/Backend/Haskell.hs b/source/src/BNFC/Backend/Haskell.hs
@@ -163,13 +163,20 @@ distCleanRule opts makeFile = Makefile.mkRule "distclean" ["clean"] $
   alsoBak :: FilePath -> [FilePath]
   alsoBak s = [ s, s <.> "bak" ]
 
-makefileHeader :: Doc
-makefileHeader = vcat
+makefileHeader :: Options -> Doc
+makefileHeader Options{ glr } = vcat
   [ "# Makefile generated by BNFC."
   , ""
   , "GHC        = ghc"
   , "HAPPY      = happy"
-  , "HAPPY_OPTS = --ghc --coerce --array --info"
+  , hsep $ concat
+    [ [ "HAPPY_OPTS = --array --info" ]
+    , if glr == GLR
+      then [ "--glr --decode" ]
+      else [ "--ghc --coerce" ]
+        -- These options currently (2021-02-14) do not work with GLR mode
+        -- see https://github.com/simonmar/happy/issues/173
+    ]
   , "ALEX       = alex"
   , "ALEX_OPTS  = --ghc"
   , ""
@@ -182,7 +189,7 @@ makefile
   -> String    -- ^ Filename of the makefile.
   -> Doc       -- ^ Content of the makefile.
 makefile opts makeFile = vcat
-  [ makefileHeader
+  [ makefileHeader opts
   , phonyRule
   , defaultRule
   , vcat [ "# Rules for building the parser." , "" ]
@@ -234,13 +241,7 @@ makefile opts makeFile = vcat
 
   -- | Rule to invoke @happy@.
   happyRule :: Doc
-  happyRule = Makefile.mkRule "%.hs" [ "%.y" ] [ recipe ]
-    where
-    recipe = unwords . concat $
-      [ [ "${HAPPY}", "${HAPPY_OPTS}" ]
-      , when (glr opts == GLR) $ [ "--glr", "--decode" ]
-      , [ "$<" ]
-      ]
+  happyRule = Makefile.mkRule "%.hs" [ "%.y" ] [ "${HAPPY} ${HAPPY_OPTS} $<" ]
 
   -- | Rule to invoke @alex@.
   alexRule :: Doc
@@ -295,6 +296,7 @@ testfile opts cf = unlines $ concat $
     , "  , FilePath"
     ]
   , [ "  , getContents, readFile" | tokenText opts == StringToken ]
+  , [ "  , (.), error, flip, map, replicate, sequence_, zip" | use_glr ]
   , [ "  )" ]
   , case tokenText opts of
       StringToken -> []
@@ -312,10 +314,10 @@ testfile opts cf = unlines $ concat $
     , ""
     ]
   , table "" $ concat
-    [ [ [ "import " , absFileM      opts , " ()"                     ]           ]
+    [ [ [ "import " , absFileM      opts , " (" ++ if_glr impTopCat ++ ")" ] ]
     , [ [ "import " , layoutFileM   opts , " ( resolveLayout )"      ] | lay     ]
     , [ [ "import " , alexFileM     opts , " ( Token )"                          ]
-      , [ "import " , happyFileM    opts , " ( " ++ firstParser ++ ", myLexer )" ]
+      , [ "import " , happyFileM    opts , " ( " ++ impParser ++ ", myLexer" ++ impParGLR ++ ")" ]
       , [ "import " , printerFileM  opts , " ( Print, printTree )"               ]
       , [ "import " , templateFileM opts , " ()"                                 ]
       ]
@@ -364,7 +366,7 @@ testfile opts cf = unlines $ concat $
     , "    fs         -> mapM_ (runFile 2 " ++ firstParser ++ ") fs"
     , ""
     ]
-  , when use_glr $
+  , if_glr $
     [ "the_parser :: ParseFun " ++ show topType
     , "the_parser = lift_parser " ++ render (parserName topType)
     , ""
@@ -376,9 +378,13 @@ testfile opts cf = unlines $ concat $
     use_xml     = xml opts > 0
     xpr         = if use_xml then "XPrint a, "     else ""
     use_glr     = glr opts == GLR
-    if_glr s    = if use_glr then s else ""
-    firstParser = if use_glr then "the_parser" else render (parserName topType)
+    if_glr      :: Monoid a => a -> a
+    if_glr      = when use_glr
+    firstParser = if use_glr then "the_parser" else impParser
+    impParser   = render (parserName topType)
     topType     = firstEntry cf
+    impTopCat   = unwords [ "", identCat topType, "" ]
+    impParGLR   = if_glr ", GLRResult(..), Branch, ForestId, TreeDecode(..), decode"
     myLLexer atom
       | lay     = unwords [ "resolveLayout True $ myLexer", atom]
       | True    = unwords [ "myLexer", atom]