From fa2940fb3a37cb7b3282553ad21037ff886cc431 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 24 Dec 2020 22:13:11 +0000 Subject: [PATCH] Get rid of template preprocessing Instead of preprocessing an outer layer of CPP when building happy, just always produce code that uses CPP. Combined with #175, this means happy now has a perfectly bog standard build system, with Makefiles and extra steps strictly optional. I gather Hugs, and possibly other Haskell implementations, out of the box doesn't support CPP, but I don't want this to stop us. Those can just manually run CPP on the generated code first. --- .gitignore | 13 -- Makefile | 1 - cabal.project | 1 - {templates => data}/GLR_Base.hs | 0 {templates => data}/GLR_Lib.hs | 6 +- .../HappyTemplate.hs | 122 +++++++++--------- gen-happy-sdist/Main.hs | 78 ----------- gen-happy-sdist/Setup.hs | 2 - gen-happy-sdist/gen-happy-sdist.cabal | 15 --- happy.cabal | 16 +-- src/Main.lhs | 51 ++++---- src/ProduceCode.lhs | 14 +- src/ProduceGLRCode.lhs | 37 ++++-- 13 files changed, 122 insertions(+), 234 deletions(-) rename {templates => data}/GLR_Base.hs (100%) rename {templates => data}/GLR_Lib.hs (98%) rename templates/GenericTemplate.hs => data/HappyTemplate.hs (80%) delete mode 100644 gen-happy-sdist/Main.hs delete mode 100644 gen-happy-sdist/Setup.hs delete mode 100644 gen-happy-sdist/gen-happy-sdist.cabal diff --git a/.gitignore b/.gitignore index 3bfa0459..c0634f89 100644 --- a/.gitignore +++ b/.gitignore @@ -4,18 +4,5 @@ dist-newstyle cabal-dev .cabal-sandbox cabal.sandbox.config -GLR_Base -GLR_Lib -GLR_Lib-ghc -GLR_Lib-ghc-debug -HappyTemplate -HappyTemplate-arrays -HappyTemplate-arrays-coerce -HappyTemplate-arrays-coerce-debug -HappyTemplate-arrays-debug -HappyTemplate-arrays-ghc -HappyTemplate-arrays-ghc-debug -HappyTemplate-coerce -HappyTemplate-ghc .*.swp .*.swo diff --git a/Makefile b/Makefile index d9235997..0956380b 100644 --- a/Makefile +++ b/Makefile @@ -16,7 +16,6 @@ sdist :: echo "Error: Tree is not clean"; \ exit 1; \ fi - $(CABAL) v2-run gen-happy-sdist $(CABAL) v2-sdist @if [ ! -f "${SDIST_DIR}/happy-$(HAPPY_VER).tar.gz" ]; then \ echo "Error: source tarball not found: dist/happy-$(HAPPY_VER).tar.gz"; \ diff --git a/cabal.project b/cabal.project index 27b2c885..8834d044 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,2 @@ packages: ./ - ./gen-happy-sdist/ diff --git a/templates/GLR_Base.hs b/data/GLR_Base.hs similarity index 100% rename from templates/GLR_Base.hs rename to data/GLR_Base.hs diff --git a/templates/GLR_Lib.hs b/data/GLR_Lib.hs similarity index 98% rename from templates/GLR_Lib.hs rename to data/GLR_Lib.hs index 8a85b47a..abc660af 100644 --- a/templates/GLR_Lib.hs +++ b/data/GLR_Lib.hs @@ -1,5 +1,3 @@ -{-# LINE 1 "GLR_Lib.hs" #-} - {- GLR_Lib.lhs $Id: GLR_Lib.lhs,v 1.5 2005/08/03 13:42:23 paulcc Exp $ @@ -39,6 +37,10 @@ ) where +#if defined(HAPPY_GHC) && !defined(__GLASGOW_HASKELL__) +# error `HAPPY_GHC` is defined but this code isn't being built with GHC. +#endif + import Data.Char import qualified Data.Map as Map diff --git a/templates/GenericTemplate.hs b/data/HappyTemplate.hs similarity index 80% rename from templates/GenericTemplate.hs rename to data/HappyTemplate.hs index 6bfd3d3a..e9125ea6 100644 --- a/templates/GenericTemplate.hs +++ b/data/HappyTemplate.hs @@ -1,85 +1,83 @@ -- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $ #ifdef HAPPY_GHC -#undef __GLASGOW_HASKELL__ -#define HAPPY_IF_GHC_GT_706 #if __GLASGOW_HASKELL__ > 706 -#define HAPPY_ELSE #else -#define HAPPY_ENDIF #endif -#define HAPPY_DEFINE #define -#endif - -#ifdef HAPPY_GHC -#define ILIT(n) n# -#define IBOX(n) (Happy_GHC_Exts.I# (n)) -#define FAST_INT Happy_GHC_Exts.Int# +# if !defined(__GLASGOW_HASKELL__) +# error `HAPPY_GHC` is defined but this code isn't being built with GHC. +# endif +# define ILIT(n) n# +# define IBOX(n) (Happy_GHC_Exts.I# (n)) +# define FAST_INT Happy_GHC_Exts.Int# -- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. -HAPPY_IF_GHC_GT_706 -HAPPY_DEFINE LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) -HAPPY_DEFINE GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) -HAPPY_DEFINE EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) -HAPPY_ELSE -HAPPY_DEFINE LT(n,m) (n Happy_GHC_Exts.<# m) -HAPPY_DEFINE GTE(n,m) (n Happy_GHC_Exts.>=# m) -HAPPY_DEFINE EQ(n,m) (n Happy_GHC_Exts.==# m) -HAPPY_ENDIF -#define PLUS(n,m) (n Happy_GHC_Exts.+# m) -#define MINUS(n,m) (n Happy_GHC_Exts.-# m) -#define TIMES(n,m) (n Happy_GHC_Exts.*# m) -#define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) -#define IF_GHC(x) (x) +# if __GLASGOW_HASKELL__ > 706 +# define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Prelude.Bool) +# define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Prelude.Bool) +# define EQ(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.==# m)) :: Prelude.Bool) +# else +# define LT(n,m) (n Happy_GHC_Exts.<# m) +# define GTE(n,m) (n Happy_GHC_Exts.>=# m) +# define EQ(n,m) (n Happy_GHC_Exts.==# m) +# endif +# define PLUS(n,m) (n Happy_GHC_Exts.+# m) +# define MINUS(n,m) (n Happy_GHC_Exts.-# m) +# define TIMES(n,m) (n Happy_GHC_Exts.*# m) +# define NEGATE(n) (Happy_GHC_Exts.negateInt# (n)) +# define IF_GHC(x) (x) #else -#define ILIT(n) (n) -#define IBOX(n) (n) -#define FAST_INT Prelude.Int -#define LT(n,m) (n Prelude.< m) -#define GTE(n,m) (n Prelude.>= m) -#define EQ(n,m) (n Prelude.== m) -#define PLUS(n,m) (n Prelude.+ m) -#define MINUS(n,m) (n Prelude.- m) -#define TIMES(n,m) (n Prelude.* m) -#define NEGATE(n) (Prelude.negate (n)) -#define IF_GHC(x) +# define ILIT(n) (n) +# define IBOX(n) (n) +# define FAST_INT Prelude.Int +# define LT(n,m) (n Prelude.< m) +# define GTE(n,m) (n Prelude.>= m) +# define EQ(n,m) (n Prelude.== m) +# define PLUS(n,m) (n Prelude.+ m) +# define MINUS(n,m) (n Prelude.- m) +# define TIMES(n,m) (n Prelude.* m) +# define NEGATE(n) (Prelude.negate (n)) +# define IF_GHC(x) #endif data Happy_IntList = HappyCons FAST_INT Happy_IntList #if defined(HAPPY_ARRAY) -#define CONS(h,t) (HappyCons (h) (t)) +# define CONS(h,t) (HappyCons (h) (t)) #else -#define CONS(h,t) ((h):(t)) +# define CONS(h,t) ((h):(t)) #endif #if defined(HAPPY_ARRAY) -#define ERROR_TOK ILIT(0) -#define DO_ACTION(state,i,tk,sts,stk) happyDoAction i tk state sts (stk) -#define HAPPYSTATE(i) (i) -#define GOTO(action) happyGoto -#define IF_ARRAYS(x) (x) +# define ERROR_TOK ILIT(0) +# define DO_ACTION(state,i,tk,sts,stk) happyDoAction i tk state sts (stk) +# define HAPPYSTATE(i) (i) +# define GOTO(action) happyGoto +# define IF_ARRAYS(x) (x) #else -#define ERROR_TOK ILIT(1) -#define DO_ACTION(state,i,tk,sts,stk) state i i tk HAPPYSTATE(state) sts (stk) -#define HAPPYSTATE(i) (HappyState (i)) -#define GOTO(action) action -#define IF_ARRAYS(x) +# define ERROR_TOK ILIT(1) +# define DO_ACTION(state,i,tk,sts,stk) state i i tk HAPPYSTATE(state) sts (stk) +# define HAPPYSTATE(i) (HappyState (i)) +# define GOTO(action) action +# define IF_ARRAYS(x) #endif #if defined(HAPPY_COERCE) -#define GET_ERROR_TOKEN(x) (case Happy_GHC_Exts.unsafeCoerce# x of { IBOX(i) -> i }) -#define MK_ERROR_TOKEN(i) (Happy_GHC_Exts.unsafeCoerce# IBOX(i)) -#define MK_TOKEN(x) (happyInTok (x)) +# if !defined(HAPPY_GHC) +# error `HAPPY_COERCE` requires `HAPPY_GHC` +# endif +# define GET_ERROR_TOKEN(x) (case Happy_GHC_Exts.unsafeCoerce# x of { IBOX(i) -> i }) +# define MK_ERROR_TOKEN(i) (Happy_GHC_Exts.unsafeCoerce# IBOX(i)) +# define MK_TOKEN(x) (happyInTok (x)) #else -#define GET_ERROR_TOKEN(x) (case x of { HappyErrorToken IBOX(i) -> i }) -#define MK_ERROR_TOKEN(i) (HappyErrorToken IBOX(i)) -#define MK_TOKEN(x) (HappyTerminal (x)) +# define GET_ERROR_TOKEN(x) (case x of { HappyErrorToken IBOX(i) -> i }) +# define MK_ERROR_TOKEN(i) (HappyErrorToken IBOX(i)) +# define MK_TOKEN(x) (HappyTerminal (x)) #endif #if defined(HAPPY_DEBUG) -#define DEBUG_TRACE(s) (happyTrace (s)) $ +# define DEBUG_TRACE(s) (happyTrace (s)) $ happyTrace string expr = Happy_System_IO_Unsafe.unsafePerformIO $ do Happy_System_IO.hPutStr Happy_System_IO.stderr string return expr #else -#define DEBUG_TRACE(s) {- nothing -} +# define DEBUG_TRACE(s) {- nothing -} #endif infixr 9 `HappyStk` @@ -98,7 +96,7 @@ happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll -- the stack in this case. happyAccept ERROR_TOK tk st sts (_ `HappyStk` ans `HappyStk` _) = happyReturn1 ans -happyAccept j tk st sts (HappyStk ans _) = +happyAccept j tk st sts (HappyStk ans _) = IF_GHC(happyTcHack j IF_ARRAYS(happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- @@ -107,7 +105,7 @@ happyAccept j tk st sts (HappyStk ans _) = #if defined(HAPPY_ARRAY) happyDoAction i tk st - = DEBUG_TRACE("state: " ++ show IBOX(st) ++ + = DEBUG_TRACE("state: " ++ show IBOX(st) ++ ",\ttoken: " ++ show IBOX(i) ++ ",\taction: ") case action of @@ -257,7 +255,7 @@ happyDropStk n (x `HappyStk` xs) = happyDropStk MINUS(n,(ILIT(1)::FAST_INT)) xs -- Moving to a new state after a reduction #if defined(HAPPY_ARRAY) -happyGoto nt j tk st = +happyGoto nt j tk st = DEBUG_TRACE(", goto state " ++ show IBOX(new_state) ++ "\n") happyDoAction j tk new_state where off = happyAdjustOffset (indexShortOffAddr happyGotoOffsets st) @@ -273,7 +271,7 @@ happyGoto action j tk st = action j j tk (HappyState action) -- parse error if we are in recovery and we fail again happyFail explist ERROR_TOK tk old_st _ stk@(x `HappyStk` _) = let i = GET_ERROR_TOKEN(x) in --- trace "failing" $ +-- trace "failing" $ happyError_ explist i tk {- We don't need state discarding for our restricted implementation of @@ -281,7 +279,7 @@ happyFail explist ERROR_TOK tk old_st _ stk@(x `HappyStk` _) = for now --SDM -- discard a state -happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) +happyFail ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) (saved_tok `HappyStk` _ `HappyStk` stk) = -- trace ("discarding state, depth " ++ show (length stk)) $ DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk)) @@ -308,7 +306,7 @@ happyTcHack x y = y #endif ----------------------------------------------------------------------------- --- Seq-ing. If the --strict flag is given, then Happy emits +-- Seq-ing. If the --strict flag is given, then Happy emits -- happySeq = happyDoSeq -- otherwise it emits -- happySeq = happyDontSeq diff --git a/gen-happy-sdist/Main.hs b/gen-happy-sdist/Main.hs deleted file mode 100644 index 74293b9a..00000000 --- a/gen-happy-sdist/Main.hs +++ /dev/null @@ -1,78 +0,0 @@ -module Main (main) where - -import Control.Monad -import Language.Preprocessor.Cpphs -import System.Directory -import System.FilePath - -main :: IO () -main = do - sequence_ ([ cpp_template "GenericTemplate.hs" dst opts | (dst,opts) <- templates ] ++ - [ cpp_template "GLR_Base.hs" dst opts | (dst,opts) <- glr_base_templates ] ++ - [ cpp_template "GLR_Lib.hs" dst opts | (dst,opts) <- glr_templates ]) - - putStrLn "" - putStrLn "-- fragment for happy.cabal file" - putStrLn "data-dir: data/" - putStrLn "" - putStrLn "data-files:" - forM_ all_template_files $ \fn -> putStrLn (" " ++ fn) - putStrLn "-- end of fragment" - putStrLn "" - putStrLn "You can invoke `cabal sdist` now" - -cpp_template :: FilePath -> FilePath -> [String] -> IO () -cpp_template src0 dst0 defs = do - ex <- doesFileExist src - unless ex $ - fail ("file " ++ show src ++ " not found; are you in the right directory?") - - putStrLn ("generating " ++ show dst ++ " (from " ++ show src ++ ")...") - createDirectoryIfMissing False "data" - srcdat <- readFile src - outdat <- runCpphs cppflags src =<< readFile src - writeFile dst outdat - - return () - where - src = "templates" src0 - dst = "data" dst0 - - cppflags = defaultCpphsOptions - { defines = [(d,"1") | d <- defs ] - , boolopts = defaultBoolOptions - { hashline = False - , locations = True - , ansi = False - , macros = True - } - } - - -all_template_files :: [FilePath] -all_template_files = map fst (templates ++ glr_base_templates ++ glr_templates) - -templates :: [(FilePath,[String])] -templates = [ - ("HappyTemplate" , []), - ("HappyTemplate-ghc" , ["HAPPY_GHC"]), - ("HappyTemplate-coerce" , ["HAPPY_GHC","HAPPY_COERCE"]), - ("HappyTemplate-arrays" , ["HAPPY_ARRAY"]), - ("HappyTemplate-arrays-ghc" , ["HAPPY_ARRAY","HAPPY_GHC"]), - ("HappyTemplate-arrays-coerce" , ["HAPPY_ARRAY","HAPPY_GHC","HAPPY_COERCE"]), - ("HappyTemplate-arrays-debug" , ["HAPPY_ARRAY","HAPPY_DEBUG"]), - ("HappyTemplate-arrays-ghc-debug" , ["HAPPY_ARRAY","HAPPY_GHC","HAPPY_DEBUG"]), - ("HappyTemplate-arrays-coerce-debug" , ["HAPPY_ARRAY","HAPPY_GHC","HAPPY_COERCE","HAPPY_DEBUG"]) - ] - -glr_base_templates :: [(FilePath,[String])] -glr_base_templates = [ - ("GLR_Base" , []) - ] - -glr_templates :: [(FilePath,[String])] -glr_templates = [ - ("GLR_Lib" , []), - ("GLR_Lib-ghc" , ["HAPPY_GHC"]), - ("GLR_Lib-ghc-debug" , ["HAPPY_GHC", "HAPPY_DEBUG"]) - ] diff --git a/gen-happy-sdist/Setup.hs b/gen-happy-sdist/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/gen-happy-sdist/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/gen-happy-sdist/gen-happy-sdist.cabal b/gen-happy-sdist/gen-happy-sdist.cabal deleted file mode 100644 index cc2a7684..00000000 --- a/gen-happy-sdist/gen-happy-sdist.cabal +++ /dev/null @@ -1,15 +0,0 @@ -cabal-version: 1.12 -name: gen-happy-sdist -version: 0 -synopsis: Tool for generating `happy` sdist -category: Development -build-type: Simple - -executable gen-happy-sdist - default-language: Haskell2010 - main-is: Main.hs - build-depends: base < 5 - , cpphs >= 1.20.8 && < 1.21 - , directory < 1.4 - , process < 1.7 - , filepath < 1.5 diff --git a/happy.cabal b/happy.cabal index f6bacd8a..a50a11d2 100644 --- a/happy.cabal +++ b/happy.cabal @@ -34,19 +34,9 @@ tested-with: data-dir: data/ data-files: - HappyTemplate - HappyTemplate-arrays - HappyTemplate-arrays-coerce - HappyTemplate-arrays-coerce-debug - HappyTemplate-arrays-debug - HappyTemplate-arrays-ghc - HappyTemplate-arrays-ghc-debug - HappyTemplate-coerce - HappyTemplate-ghc - GLR_Base - GLR_Lib - GLR_Lib-ghc - GLR_Lib-ghc-debug + HappyTemplate.hs + GLR_Base.hs + GLR_Lib.hs extra-source-files: ANNOUNCE diff --git a/src/Main.lhs b/src/Main.lhs index 2c15724b..195ab732 100644 --- a/src/Main.lhs +++ b/src/Main.lhs @@ -182,6 +182,7 @@ of code we should generate, and where it should go: > template' <- getTemplate getDataDir cli > opt_coerce <- getCoerce target cli > opt_strict <- getStrict cli +> opt_array <- getArray cli > opt_ghc <- getGhc cli Add any special options or imports required by the parsing machinery. @@ -201,7 +202,10 @@ Branch off to GLR parser production > | otherwise = NoFiltering > ghc_exts | OptGhcTarget `elem` cli = UseGhcExts > (importsToInject cli) -> (optsToInject target cli) + +Unlike below, don't always passs CPP, because only one of the files needs it. + +> (langExtsToInject cli) > | otherwise = NoGhcExts > debug = OptDebugParser `elem` cli > if OptGLR `elem` cli @@ -222,7 +226,7 @@ Branch off to GLR parser production Resume normal (ie, non-GLR) processing > let -> template = template_file template' target cli opt_coerce +> template = template' ++ "/HappyTemplate.hs" Read in the template file for this target: @@ -236,7 +240,10 @@ and generate the code. > g > action > goto -> (optsToInject target cli) + +CPP is needed in all cases with unified template + +> ("CPP" : langExtsToInject cli) > header > tl > target @@ -259,8 +266,17 @@ and generate the code. > in > filter_output +> vars_to_define = concat +> [ [ "HAPPY_DEBUG" | debug ] +> , [ "HAPPY_ARRAY" | opt_array ] +> , [ "HAPPY_GHC" | opt_ghc ] +> , [ "HAPPY_COERCE" | opt_coerce ] +> ] +> defines = unlines +> [ "#define " ++ d ++ " 1" | d <- vars_to_define ] + > (if outfilename == "-" then putStr else writeFile outfilename) -> (magic_filter (outfile ++ templ)) +> (magic_filter (outfile ++ defines ++ templ)) Successfully Finished. @@ -451,29 +467,13 @@ How would we like our code to be generated? > optToTarget OptArrayTarget = Just TargetArrayBased > optToTarget _ = Nothing -> template_file :: String -> Target -> [CLIFlags] -> Bool -> String -> template_file temp_dir target cli _coerce -> = temp_dir ++ "/HappyTemplate" ++ array_extn ++ ghc_extn ++ debug_extn -> where -> ghc_extn | OptUseCoercions `elem` cli = "-coerce" -> | OptGhcTarget `elem` cli = "-ghc" -> | otherwise = "" -> -> array_extn | target == TargetArrayBased = "-arrays" -> | otherwise = "" -> -> debug_extn | OptDebugParser `elem` cli = "-debug" -> | otherwise = "" - Note: we need -cpp at the moment because the template has some GHC version-dependent stuff in it. -> optsToInject :: Target -> [CLIFlags] -> String -> optsToInject tgt cli -> | OptGhcTarget `elem` cli = "-XMagicHash -XBangPatterns -XTypeSynonymInstances -XFlexibleInstances -cpp" -> | tgt == TargetArrayBased = "-cpp" -> | OptDebugParser `elem` cli = "-cpp" -> | otherwise = "" +> langExtsToInject :: [CLIFlags] -> [String] +> langExtsToInject cli +> | OptGhcTarget `elem` cli = ["MagicHash", "BangPatterns", "TypeSynonymInstances", "FlexibleInstances"] +> | otherwise = [] > importsToInject :: [CLIFlags] -> String > importsToInject cli = @@ -567,6 +567,9 @@ Extract various command-line options. > "in conjunction with -g/--ghc\n") > else return False +> getArray :: [CLIFlags] -> IO Bool +> getArray cli = return (OptArrayTarget `elem` cli) + > getGhc :: [CLIFlags] -> IO Bool > getGhc cli = return (OptGhcTarget `elem` cli) diff --git a/src/ProduceCode.lhs b/src/ProduceCode.lhs index 2961c14f..f84f0810 100644 --- a/src/ProduceCode.lhs +++ b/src/ProduceCode.lhs @@ -32,7 +32,7 @@ Produce the complete output file. > produceParser :: Grammar -- grammar info > -> ActionTable -- action table > -> GotoTable -- goto table -> -> String -- stuff to go at the top +> -> [String] -- language extensions > -> Maybe String -- module header > -> Maybe String -- module trailer > -> Target -- type of code required @@ -61,7 +61,7 @@ Produce the complete output file. > , attributetype = attributetype' > , attributes = attributes' > }) -> action goto top_options module_header module_trailer +> action goto lang_exts module_header module_trailer > target coerce ghc strict > = ( top_opts > . maybestr module_header . nl @@ -90,7 +90,7 @@ Produce the complete output file. > -- fix, others not so easy, and others would require GHC version > -- #ifdefs. For now I'm just disabling all of them. > -> partTySigs_opts = ifGeGhc710 (str "{-# OPTIONS_GHC -XPartialTypeSignatures #-}" . nl) +> partTySigs_opts = ifGeGhc710 (str "{-# LANGUAGE PartialTypeSignatures #-}" . nl) > > intMaybeHash | ghc = str "Happy_GHC_Exts.Int#" > | otherwise = str "Prelude.Int" @@ -119,12 +119,8 @@ Produce the complete output file. > > top_opts = > nowarn_opts -> . (case top_options of -> "" -> str "" -> _ -> str (unwords [ "{-# OPTIONS" -> , top_options -> , "#-}" -> ]) . nl) +> . (str $ unlines +> [ unwords [ "{-# LANGUAGE", l, "#-}" ] | l <- lang_exts ]) > . partTySigs_opts %----------------------------------------------------------------------------- diff --git a/src/ProduceGLRCode.lhs b/src/ProduceGLRCode.lhs index 335c9ee3..aac13946 100644 --- a/src/ProduceGLRCode.lhs +++ b/src/ProduceGLRCode.lhs @@ -27,8 +27,8 @@ This module is designed as an extension to the Haskell parser generator Happy. File and Function Names > base_template, lib_template :: String -> String -> base_template td = td ++ "/GLR_Base" -- NB Happy uses / too -> lib_template td = td ++ "/GLR_Lib" -- Windows accepts this? +> base_template td = td ++ "/GLR_Base.hs" -- NB Happy uses / too +> lib_template td = td ++ "/GLR_Lib.hs" -- Windows accepts this? --- prefix for production names, to avoid name clashes @@ -56,7 +56,8 @@ This type represents whether GHC extensions are used or not > data GhcExts > = NoGhcExts -> | UseGhcExts String String -- imports and options +> | UseGhcExts String -- imports +> [String] -- language extensions --- this is where the exts matter @@ -117,16 +118,19 @@ the driver and data strs (large template). > > mkFiles basename tables start templdir header trailer (debug,options) g > = do -> let debug_ext = if debug then "-debug" else "" -> let (ext,imps,opts) = case ghcExts_opt of -> UseGhcExts is os -> ("-ghc", is, os) -> _ -> ("", "", "") +> let (imps, lang_exts) = case ghcExts_opt of +> UseGhcExts is os -> (is, os) +> _ -> ("", []) > base <- readFile (base_template templdir) > --writeFile (basename ++ ".si") (unlines $ map show sem_info) -> writeFile (basename ++ "Data.hs") (content base opts $ "") +> writeFile (basename ++ "Data.hs") (content base lang_exts $ "") -> lib <- readFile (lib_template templdir ++ ext ++ debug_ext) -> writeFile (basename ++ ".hs") (lib_content imps opts lib) +> lib <- readFile (lib_template templdir) +> let defines = concat +> [ [ "HAPPY_DEBUG" | debug ] +> , [ "HAPPY_GHC" | UseGhcExts _ _ <- return ghcExts_opt ] +> ] +> writeFile (basename ++ ".hs") (lib_content defines imps lang_exts lib) > where > (_,_,ghcExts_opt) = options @@ -174,8 +178,9 @@ Extract the string that comes before the module declaration... > -- Assume these options ONLY related to code which is in > -- parser tail or in sem. rules -> content base_defs opts -> = str ("{-# OPTIONS " ++ opts ++ " #-}") .nl +> content base_defs lang_exts +> = str (unlines +> [ "{-# LANGUAGE " ++ l ++ " #-}\n" | l <- lang_exts ]) > . str (unlines $ maybe [] fst header_parts) .nl > . nl > . str (comment "data") .nl .nl @@ -220,10 +225,14 @@ Extract the string that comes before the module declaration... > . nl > . table_text -> lib_content imps opts lib_text +> lib_content defines imps lang_exts lib_text > = let (pre,_drop_me : post) = break (== "fakeimport DATA") $ lines lib_text > in -> unlines [ "{-# OPTIONS " ++ opts ++ " #-}\n" +> unlines [ "{-# LANGUAGE CPP #-}" +> , unlines +> [ "#define " ++ d ++ " 1" | d <- defines ] +> , unlines +> [ "{-# LANGUAGE " ++ l ++ " #-}\n" | l <- lang_exts ] > , comment "driver" ++ "\n" > , "module " ++ mod_name ++ "(" > , case lexer g of