Optional bootstrapping

.appveyor.yml

@@ -29,8 +29,6 @@ install:
  - "cabal %CABOPTS% v2-update -vverbose+nowrap"
  - "cabal %CABOPTS% v2-install alex --bindir=/hsbin"
  - "alex --version"
- - "cabal %CABOPTS% v2-install happy --bindir=/hsbin"
- - "happy --version"
 
 build: off
 

.travis.yml

@@ -17,8 +17,8 @@ env:
 before_install:
  - sudo add-apt-repository -y ppa:hvr/ghc
  - sudo apt-get update
- - sudo apt-get install alex-3.1.7 happy-1.19.5 cabal-install-3.4 ghc-$GHCVER
- - export PATH=/opt/cabal/3.4/bin:/opt/ghc/$GHCVER/bin:/opt/alex/3.1.7/bin:/opt/happy/1.19.5/bin:$PATH
+ - sudo apt-get install alex-3.1.7 cabal-install-3.4 ghc-$GHCVER
+ - export PATH=/opt/cabal/3.4/bin:/opt/ghc/$GHCVER/bin:/opt/alex/3.1.7/bin:$PATH
 
 install:
  - cabal update

Makefile

@@ -1,21 +1,12 @@
 CABAL = cabal
 
-HAPPY = happy 
-HAPPY_OPTS = -agc
 HAPPY_VER = `awk '/^version:/ { print $$2 }' happy.cabal`
 
 ALEX = alex
 ALEX_OPTS = -g
 
 SDIST_DIR=dist-newstyle/sdist
 
-GEN = src/gen/Parser.hs src/gen/AttrGrammarParser.hs
-
-all : $(GEN)
-
-src/gen/%.hs : src/boot/%.ly
-	$(HAPPY) $(HAPPYFLAGS) $< -o $@
-
 sdist ::
 	@case "`$(CABAL) --numeric-version`" in \
 		2.[2-9].* | [3-9].* ) ;; \
@@ -25,10 +16,6 @@ sdist ::
 		echo "Error: Tree is not clean"; \
 		exit 1; \
 	fi
-	$(HAPPY) $(HAPPY_OPTS) src/Parser.ly -o src/Parser.hs
-	$(HAPPY) $(HAPPY_OPTS) src/AttrGrammarParser.ly -o src/AttrGrammarParser.hs
-	mv src/Parser.ly src/Parser.ly.boot
-	mv src/AttrGrammarParser.ly src/AttrGrammarParser.ly.boot
 	$(CABAL) v2-run gen-happy-sdist
 	$(CABAL) v2-sdist
 	@if [ ! -f "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" ]; then \
@@ -49,7 +36,14 @@ sdist-test-only ::
 	rm -rf "${SDIST_DIR}/happy-$(HAPPY_VER)/"
 	tar -xf "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" -C ${SDIST_DIR}/
 	echo "packages: ." > "${SDIST_DIR}/happy-$(HAPPY_VER)/cabal.project"
-	cd "${SDIST_DIR}/happy-$(HAPPY_VER)/" && cabal v2-test --enable-tests all
+	echo "tests: True" >> "${SDIST_DIR}/happy-$(HAPPY_VER)/cabal.project"
+	cd "${SDIST_DIR}/happy-$(HAPPY_VER)/" \
+		&& cabal v2-build all --flag -bootstrap \
+		&& cabal v2-install --flag -bootstrap --installdir="./bootstrap-root" \
+		&& cabal v2-test all -j --flag -bootstrap \
+		&& export PATH=./bootstrap-root:$$PATH \
+		&& cabal v2-build all --flag +bootstrap \
+		&& cabal v2-test all -j --flag +bootstrap
 	@echo ""
 	@echo "Success! ${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz is ready for distribution!"
 	@echo ""

examples/ErlParser.ly

@@ -13,7 +13,7 @@ Author    : Simon Marlow <[email protected]>
 > import Lexer
 > import AbsSyn
 > import Types
-> import ParseMonad
+> import ParseMonad.Class
 > }
 
 > %token

happy.cabal

@@ -155,6 +155,11 @@ extra-source-files:
         tests/rank2.y
         tests/shift01.y
 
+flag bootstrap
+  description: Optimize the implementation of happy using a pre-built happy
+  manual: True
+  default: True
+
 source-repository head
   type:     git
   location: https://github.com/simonmar/happy.git
@@ -182,16 +187,32 @@ executable happy
         LALR
         Lexer
         ParseMonad
+        ParseMonad.Class
         Parser
         ProduceCode
         ProduceGLRCode
         NameSet
         Target
         AttrGrammar
-        AttrGrammarParser
         ParamRules
         PrettyGrammar
 
+  if flag(bootstrap)
+    -- TODO put this back when Cabal can use it's qualified goals to better
+    -- understand bootstrapping, see
+    -- https://github.com/haskell/cabal/issues/7189
+    --build-tools: happy
+    cpp-options: -DHAPPY_BOOTSTRAP
+    other-modules:
+      ParseMonad.Bootstrapped
+      Parser.Bootstrapped
+      AttrGrammarParser
+  else
+    other-modules:
+      ParseMonad.Oracle
+      Parser.Oracle
+
+
 test-suite tests
   type: exitcode-stdio-1.0
   main-is: test.hs
@@ -200,4 +221,3 @@ test-suite tests
 
   build-depends: base, process
   default-language: Haskell98
-

src/AttrGrammar.lhs

@@ -1,15 +1,15 @@
 > module AttrGrammar
 > ( AgToken (..)
 > , AgRule (..)
+> , HasLexer (..)
 > , agLexAll
-> , agLexer
 > , subRefVal
 > , selfRefVal
 > , rightRefVal
 > ) where
 
 > import Data.Char
-> import ParseMonad
+> import ParseMonad.Class
 
 > data AgToken
 >   = AgTok_LBrace
@@ -62,32 +62,30 @@
 -- will wreck column alignment so attribute grammar specifications must
 -- not rely on layout.
 
-> type Pfunc a = String -> Int -> ParseResult a
-
-> agLexAll :: P [AgToken]
-> agLexAll = mkP $ aux []
+> agLexAll :: String -> Int -> ParseResult [AgToken]
+> agLexAll = aux []
 >  where aux toks [] _ = Right (reverse toks)
->        aux toks s l  = agLexer' (\t -> aux (t:toks)) s l
+>        aux toks s l  = agLexer (\t -> aux (t:toks)) s l
 
-> agLexer :: (AgToken -> P a) -> P a
-> agLexer m = mkP $ agLexer' (\x -> runP (m x))
+> instance HasLexer AgToken where
+>   lexToken = agLexer
 
-> agLexer' :: (AgToken -> Pfunc a) -> Pfunc a
-> agLexer' cont []         = cont AgTok_EOF []
-> agLexer' cont ('{':rest) = cont AgTok_LBrace rest
-> agLexer' cont ('}':rest) = cont AgTok_RBrace rest
-> agLexer' cont (';':rest) = cont AgTok_Semicolon rest
-> agLexer' cont ('=':rest) = cont AgTok_Eq rest
-> agLexer' cont ('w':'h':'e':'r':'e':rest) = cont AgTok_Where rest
-> agLexer' cont ('$':'$':rest) = agLexAttribute cont (\a -> AgTok_SelfRef a) rest
-> agLexer' cont ('$':'>':rest) = agLexAttribute cont (\a -> AgTok_RightmostRef a) rest
-> agLexer' cont s@('$':rest) =
+> agLexer :: (AgToken -> Pfunc a) -> Pfunc a
+> agLexer cont []         = cont AgTok_EOF []
+> agLexer cont ('{':rest) = cont AgTok_LBrace rest
+> agLexer cont ('}':rest) = cont AgTok_RBrace rest
+> agLexer cont (';':rest) = cont AgTok_Semicolon rest
+> agLexer cont ('=':rest) = cont AgTok_Eq rest
+> agLexer cont ('w':'h':'e':'r':'e':rest) = cont AgTok_Where rest
+> agLexer cont ('$':'$':rest) = agLexAttribute cont (\a -> AgTok_SelfRef a) rest
+> agLexer cont ('$':'>':rest) = agLexAttribute cont (\a -> AgTok_RightmostRef a) rest
+> agLexer cont s@('$':rest) =
 >     let (n,rest') = span isDigit rest
 >     in if null n
 >           then agLexUnknown cont s
 >           else agLexAttribute cont (\a -> AgTok_SubRef (read n,a)) rest'
-> agLexer' cont s@(c:rest)
->     | isSpace c = agLexer' cont (dropWhile isSpace rest)
+> agLexer cont s@(c:rest)
+>     | isSpace c = agLexer cont (dropWhile isSpace rest)
 >     | otherwise = agLexUnknown cont s
 
 > agLexUnknown :: (AgToken -> Pfunc a) -> Pfunc a

src/AttrGrammarParser.ly

@@ -7,7 +7,8 @@ or a conditional statement.
 > {
 > {-# OPTIONS_GHC -w #-}
 > module AttrGrammarParser (agParser) where
-> import ParseMonad
+> import ParseMonad.Class
+> import ParseMonad.Bootstrapped
 > import AttrGrammar
 > }
 
@@ -25,7 +26,7 @@ or a conditional statement.
 >   unknown   { AgTok_Unknown _ }
 >
 > %monad { P }
-> %lexer { agLexer } { AgTok_EOF }
+> %lexer { lexTokenP } { AgTok_EOF }
 
 > %%
 
@@ -64,5 +65,5 @@ or a conditional statement.
 
 > {
 > happyError :: P a
-> happyError = failP ("Parse error\n")
+> happyError = failP (\l -> show l ++ ": Parse error\n")
 > }

src/Grammar.lhs

@@ -1,4 +1,4 @@
------------------------------------------------------------------------------
+/-----------------------------------------------------------------------------
 The Grammar data type.
 
 (c) 1993-2001 Andy Gill, Simon Marlow
@@ -20,9 +20,16 @@ Here is our mid-section datatype
 
 > import GenUtils
 > import AbsSyn
-> import ParseMonad
+#ifdef HAPPY_BOOTSTRAP
+> import ParseMonad.Class
 > import AttrGrammar
+#endif
+
+This is only supported in the bootstrapped version
+#ifdef HAPPY_BOOTSTRAP
 > import AttrGrammarParser
+#endif
+
 > import ParamRules
 
 > import Data.Array
@@ -412,19 +419,28 @@ So is this.
 
 > checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
 > checkCode arity _   _             code []    = doCheckCode arity code
+
+#ifdef HAPPY_BOOTSTRAP
 > checkCode arity lhs nonterm_names code attrs = rewriteAttributeGrammar arity lhs nonterm_names code attrs
+#else
+> checkCode arity _   _             code (_:_) = do
+>   addErr "Attribute grammars are not supported in non-bootstrapped build"
+>   doCheckCode arity code
+#endif
 
 ------------------------------------------------------------------------------
 -- Special processing for attribute grammars.  We re-parse the body of the code
 -- block and output the nasty-looking record manipulation and let binding goop
 --
 
+#ifdef HAPPY_BOOTSTRAP
+
 > rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])
 > rewriteAttributeGrammar arity lhs nonterm_names code attrs =
 
    first we need to parse the body of the code block
 
->     case runP agParser code 0 of
+>     case runFromStartP agParser code 0 of
 >        Left msg  -> do addErr ("error in attribute grammar rules: "++msg)
 >                        return ("",[])
 >        Right rules  ->
@@ -470,7 +486,6 @@ So is this.
 >          checkArity x = when (x > arity) $ addErr (show x++" out of range")
 
 
-
 ------------------------------------------------------------------------------------
 -- Actually emit the code for the record bindings and conditionals
 --
@@ -539,6 +554,8 @@ So is this.
 >        formatToken (AgTok_Unknown x)     = x++" "
 >        formatToken AgTok_EOF = error "formatToken AgTok_EOF"
 
+#endif
+
 
 -----------------------------------------------------------------------------
 -- Check for every $i that i is <= the arity of the rule.