From c21d156b7c6befb2d667095dc38b8ead01780af7 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 24 Dec 2020 21:13:18 +0000 Subject: [PATCH 1/3] Convert Main to use do notation I don't think the expression style improves what is sprawling imperative code either way. More likely it predates do notation becoming popular! --- src/Main.lhs | 152 ++++++++++++++++++++++++--------------------------- 1 file changed, 71 insertions(+), 81 deletions(-) diff --git a/src/Main.lhs b/src/Main.lhs index 5b272ae0..31a1c1da 100644 --- a/src/Main.lhs +++ b/src/Main.lhs @@ -33,11 +33,11 @@ Path settings auto-generated by Cabal: > import Data.Version ( showVersion ) > main :: IO () -> main = +> main = do Read and parse the CLI arguments. -> getArgs >>= \ args -> +> args <- getArgs > main2 args > main2 :: [String] -> IO () @@ -62,32 +62,31 @@ Read and parse the CLI arguments. > usageInfo (usageHeader prog) argInfo) > where -> runParserGen cli fl_name = +> runParserGen cli fl_name = do Open the file. -> readFile fl_name >>= \ fl -> -> possDelit (reverse fl_name) fl >>= \ (file,name) -> +> fl <- readFile fl_name +> (file,name) <- possDelit (reverse fl_name) fl Parse, using bootstrapping parser. -> case runP ourParser file 1 of { -> Left err -> die (fl_name ++ ':' : err); -> Right abssyn@(AbsSyn hd _ _ tl) -> +> (abssyn, hd, tl) <- case runP ourParser file 1 of +> Left err -> die (fl_name ++ ':' : err) +> Right abssyn@(AbsSyn hd _ _ tl) -> pure (abssyn, hd, tl) Mangle the syntax into something useful. -> case {-# SCC "Mangler" #-} (mangler fl_name abssyn) of { +> g <- case {-# SCC "Mangler" #-} (mangler fl_name abssyn) of > Left s -> die (unlines s ++ "\n"); -> Right g -> +> Right g -> pure g #ifdef DEBUG -> optPrint cli DumpMangle (putStr (show g)) >> +> optPrint cli DumpMangle $ putStr $ show g #endif - > let first = {-# SCC "First" #-} (mkFirst g) > closures = {-# SCC "Closures" #-} (precalcClosure0 g) > sets = {-# SCC "LR0_Sets" #-} (genLR0items g closures) @@ -97,15 +96,14 @@ Mangle the syntax into something useful. > goto = {-# SCC "Goto" #-} (genGotoTable g sets) > action = {-# SCC "Action" #-} (genActionTable g first items2) > (conflictArray,(sr,rr)) = {-# SCC "Conflict" #-} (countConflicts action) -> in #ifdef DEBUG -> optPrint cli DumpLR0 (putStr (show sets)) >> -> optPrint cli DumpAction (putStr (show action)) >> -> optPrint cli DumpGoto (putStr (show goto)) >> -> optPrint cli DumpLA (putStr (show _lainfo)) >> -> optPrint cli DumpLA (putStr (show la)) >> +> optPrint cli DumpLR0 $ putStr $ show sets +> optPrint cli DumpAction $ putStr $ show action +> optPrint cli DumpGoto $ putStr $ show goto +> optPrint cli DumpLA $ putStr $ show _lainfo +> optPrint cli DumpLA $ putStr $ show la #endif @@ -115,15 +113,14 @@ Report any unused rules and terminals > | otherwise = first_reduction > (unused_rules, unused_terminals) > = find_redundancies reduction_filter g action -> in > optIO (not (null unused_rules)) -> (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) >> +> (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) > optIO (not (null unused_terminals)) -> (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) >> +> (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) Print out the info file. -> getInfoFileName name cli >>= \info_filename -> +> info_filename <- getInfoFileName name cli > let info = genInfoFile > (map fst sets) > g @@ -134,46 +131,44 @@ Print out the info file. > fl_name > unused_rules > unused_terminals -> in -> (case info_filename of -> Just s -> writeFile s info >> -> hPutStrLn stderr ("Grammar info written to: " ++ s) -> Nothing -> return ()) >> +> case info_filename of +> Just s -> do +> writeFile s info +> hPutStrLn stderr ("Grammar info written to: " ++ s) +> Nothing -> return () Pretty print the grammar. -> getPrettyFileName name cli >>= \pretty_filename -> -> (let out = render (ppAbsSyn abssyn) -> in -> case pretty_filename of -> Just s -> writeFile s out >> -> hPutStrLn stderr ("Production rules written to: " ++ s) -> Nothing -> return ()) >> +> pretty_filename <- getPrettyFileName name cli +> case pretty_filename of +> Just s -> do +> let out = render (ppAbsSyn abssyn) +> writeFile s out +> hPutStrLn stderr ("Production rules written to: " ++ s) +> Nothing -> return () Report any conflicts in the grammar. -> (case expect g of -> Just n | n == sr && rr == 0 -> return () -> Just _ | rr > 0 -> -> die ("The grammar has reduce/reduce conflicts.\n" ++ -> "This is not allowed when an expect directive is given\n") -> Just _ -> -> die ("The grammar has " ++ show sr ++ -> " shift/reduce conflicts.\n" ++ -> "This is different from the number given in the " ++ -> "expect directive\n") -> _ -> do - -> (if sr /= 0 -> then hPutStrLn stderr ("shift/reduce conflicts: " ++ show sr) -> else return ()) +> case expect g of +> Just n | n == sr && rr == 0 -> return () +> Just _ | rr > 0 -> +> die ("The grammar has reduce/reduce conflicts.\n" ++ +> "This is not allowed when an expect directive is given\n") +> Just _ -> +> die ("The grammar has " ++ show sr ++ +> " shift/reduce conflicts.\n" ++ +> "This is different from the number given in the " ++ +> "expect directive\n") +> _ -> do -> (if rr /= 0 -> then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr) -> else return ()) +> (if sr /= 0 +> then hPutStrLn stderr ("shift/reduce conflicts: " ++ show sr) +> else return ()) -> ) >> +> (if rr /= 0 +> then hPutStrLn stderr ("reduce/reduce conflicts: " ++ show rr) +> else return ()) @@ -181,21 +176,19 @@ Report any conflicts in the grammar. Now, let's get on with generating the parser. Firstly, find out what kind of code we should generate, and where it should go: -> getTarget cli >>= \target -> -> getOutputFileName fl_name cli >>= \outfilename -> -> getTemplate getDataDir cli >>= \template' -> -> getCoerce target cli >>= \opt_coerce -> -> getStrict cli >>= \opt_strict -> -> getGhc cli >>= \opt_ghc -> +> target <- getTarget cli +> outfilename <- getOutputFileName fl_name cli +> template' <- getTemplate getDataDir cli +> opt_coerce <- getCoerce target cli +> opt_strict <- getStrict cli +> opt_ghc <- getGhc cli Add any special options or imports required by the parsing machinery. > let -> header = Just ( -> (case hd of Just s -> s; Nothing -> "") -> ++ importsToInject cli -> ) -> in +> header = Just $ +> (case hd of Just s -> s; Nothing -> "") +> ++ importsToInject cli %--------------------------------------- @@ -210,33 +203,33 @@ Branch off to GLR parser production > (optsToInject target cli) > | otherwise = NoGhcExts > debug = OptDebugParser `elem` cli -> in > if OptGLR `elem` cli -> then produceGLRParser outfilename -- specified output file name -> template' -- template files directory -> action -- action table (:: ActionTable) -> goto -- goto table (:: GotoTable) -> header -- header from grammar spec -> tl -- trailer from grammar spec -> (debug, (glr_decode,filtering,ghc_exts)) -> -- controls decoding code-gen -> g -- grammar object -> else +> then produceGLRParser +> outfilename -- specified output file name +> template' -- template files directory +> action -- action table (:: ActionTable) +> goto -- goto table (:: GotoTable) +> header -- header from grammar spec +> tl -- trailer from grammar spec +> (debug, (glr_decode,filtering,ghc_exts)) +> -- controls decoding code-gen +> g -- grammar object +> else pure () %--------------------------------------- Resume normal (ie, non-GLR) processing > let -> template = template_file template' target cli opt_coerce in +> template = template_file template' target cli opt_coerce Read in the template file for this target: -> readFile template >>= \ templ -> +> templ <- readFile template and generate the code. -> getMagicName cli >>= \ magic_name -> +> magic_name <- getMagicName cli > let > outfile = produceParser > g @@ -264,15 +257,12 @@ and generate the code. > filter_output [] = [] > in > filter_output -> in > (if outfilename == "-" then putStr else writeFile outfilename) > (magic_filter (outfile ++ templ)) Successfully Finished. -> }} - ----------------------------------------------------------------------------- > getProgramName :: IO String From df95412f90a07aae4879952984c82c7092620ec7 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 24 Dec 2020 22:13:36 +0000 Subject: [PATCH 2/3] pure -> return for old GHCs --- src/Main.lhs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Main.lhs b/src/Main.lhs index 31a1c1da..e41563b2 100644 --- a/src/Main.lhs +++ b/src/Main.lhs @@ -73,13 +73,13 @@ Parse, using bootstrapping parser. > (abssyn, hd, tl) <- case runP ourParser file 1 of > Left err -> die (fl_name ++ ':' : err) -> Right abssyn@(AbsSyn hd _ _ tl) -> pure (abssyn, hd, tl) +> Right abssyn@(AbsSyn hd _ _ tl) -> return (abssyn, hd, tl) Mangle the syntax into something useful. > g <- case {-# SCC "Mangler" #-} (mangler fl_name abssyn) of > Left s -> die (unlines s ++ "\n"); -> Right g -> pure g +> Right g -> return g #ifdef DEBUG @@ -214,7 +214,7 @@ Branch off to GLR parser production > (debug, (glr_decode,filtering,ghc_exts)) > -- controls decoding code-gen > g -- grammar object -> else pure () +> else return () %--------------------------------------- From 8d89dbccee2059f5e886b319a7654c60461edeae Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 24 Dec 2020 22:18:46 +0000 Subject: [PATCH 3/3] Fix branch between GLR vs non-GLR --- src/Main.lhs | 70 ++++++++++++++++++++++++++-------------------------- 1 file changed, 35 insertions(+), 35 deletions(-) diff --git a/src/Main.lhs b/src/Main.lhs index e41563b2..2b5809c6 100644 --- a/src/Main.lhs +++ b/src/Main.lhs @@ -214,52 +214,52 @@ Branch off to GLR parser production > (debug, (glr_decode,filtering,ghc_exts)) > -- controls decoding code-gen > g -- grammar object -> else return () +> else do %--------------------------------------- Resume normal (ie, non-GLR) processing -> let -> template = template_file template' target cli opt_coerce +> let +> template = template_file template' target cli opt_coerce Read in the template file for this target: -> templ <- readFile template +> templ <- readFile template and generate the code. -> magic_name <- getMagicName cli -> let -> outfile = produceParser -> g -> action -> goto -> (optsToInject target cli) -> header -> tl -> target -> opt_coerce -> opt_ghc -> opt_strict -> magic_filter = -> case magic_name of -> Nothing -> id -> Just name' -> -> let -> small_name = name' -> big_name = toUpper (head name') : tail name' -> filter_output ('h':'a':'p':'p':'y':rest) = -> small_name ++ filter_output rest -> filter_output ('H':'a':'p':'p':'y':rest) = -> big_name ++ filter_output rest -> filter_output (c:cs) = c : filter_output cs -> filter_output [] = [] -> in -> filter_output - -> (if outfilename == "-" then putStr else writeFile outfilename) -> (magic_filter (outfile ++ templ)) +> magic_name <- getMagicName cli +> let +> outfile = produceParser +> g +> action +> goto +> (optsToInject target cli) +> header +> tl +> target +> opt_coerce +> opt_ghc +> opt_strict +> magic_filter = +> case magic_name of +> Nothing -> id +> Just name' -> +> let +> small_name = name' +> big_name = toUpper (head name') : tail name' +> filter_output ('h':'a':'p':'p':'y':rest) = +> small_name ++ filter_output rest +> filter_output ('H':'a':'p':'p':'y':rest) = +> big_name ++ filter_output rest +> filter_output (c:cs) = c : filter_output cs +> filter_output [] = [] +> in +> filter_output + +> (if outfilename == "-" then putStr else writeFile outfilename) +> (magic_filter (outfile ++ templ)) Successfully Finished.