Skip to content

Commit

Permalink
Merge pull request #178 from simonmar/do-notation
Browse files Browse the repository at this point in the history 
Convert Main to use do notation
  • Loading branch information
@Ericson2314
Ericson2314 authored Dec 31, 2020
2 parents 33b552e + 8d89dbc commit 75dbfd2
Showing 1 changed file with 102 additions and 112 deletions.
214 changes: 102 additions & 112 deletions src/Main.lhs
View file
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

0 comments on commit 75dbfd2

Please sign in to comment.