Skip to content

Convert Main to use do notation #178

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
merged 3 commits into from
Dec 31, 2020
Merged

Convert Main to use do notation #178

Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
c21d156
Convert Main to use do notation
Ericson2314 Dec 24, 2020
df95412
pure -> return for old GHCs
Ericson2314 Dec 24, 2020
8d89dbc
Fix branch between GLR vs non-GLR
Ericson2314 Dec 24, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
214 changes: 102 additions & 112 deletions src/Main.lhs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 ()
Expand All @@ -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) -> return (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 -> return 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)
Expand All @@ -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

Expand All @@ -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
Expand All @@ -134,68 +131,64 @@ 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 ())




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


%---------------------------------------
Expand All @@ -210,69 +203,66 @@ 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 do


%---------------------------------------
Resume normal (ie, non-GLR) processing

> let
> template = template_file template' target cli opt_coerce in
> let
> 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 ->
> 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
> in

> (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.

> }}

-----------------------------------------------------------------------------

> getProgramName :: IO String
Expand Down