{-|
Module : Cmd.Lalr
Description : CLI for the `pp lalr` command
Copyright : (c) 2017 Patrick Champion
License : see LICENSE file
Maintainer : chlablak@gmail.com
Stability : provisional
Portability : portable
-}
module Cmd.Lalr
( commandArgs
, dispatch
) where
import Args
import Control.Monad (when)
import qualified Data.Graph.Inductive.Graph as Gr
import qualified Data.Map.Strict as Map
import Data.Semigroup ((<>))
import qualified Data.Set as Set
import qualified Data.Vector as Vector
import qualified Log
import Options.Applicative
import qualified PP
import qualified PP.Builders.Lalr as Builder
import qualified PP.Grammars.Ebnf as Grammar
import qualified PP.Lexers.Dfa as Lexer
import qualified PP.Parsers.Lr as Parser
import qualified PP.Templates.Dfa as DfaTemplate
import qualified PP.Templates.Lr as LrTemplate
import qualified Work
-- |Command arguments
commandArgs :: Parser CommandArgs
commandArgs = LalrCmd <$> lalrArgs
where
lalrArgs = LalrArgs
<$> strOption ( long "file"
<> short 'f'
<> metavar "FILENAME"
<> help "Input file" )
<*> switch ( long "collection"
<> help "Print the items sets collection" )
<*> option auto ( long "set"
<> metavar "I"
<> value (-1)
<> help "Print a specific items set" )
<*> switch ( long "table"
<> help "Print the LALR parsing table" )
<*> strOption ( long "test-with"
<> short 't'
<> metavar "FILENAME"
<> value ""
<> help "Test the table on a source file" )
<*> strOption ( long "template"
<> metavar "FILENAME"
<> value ""
<> help "Specify a template file to use" )
<*> switch ( long "dfa"
<> help "Print the DFA" )
<*> switch ( long "ast"
<> help "Print the parsed AST (with --test-with)" )
<*> strOption ( long "ast-to-html"
<> metavar "FILENAME"
<> value ""
<> help "Output the parsed AST to HTML list" )
-- |Command dispatch
dispatch :: Args -> Log.Logger
dispatch (Args cargs (LalrCmd args)) = do
Log.pushTag "lalr"
input <- Log.io $ readFile $ lalrFile args
case PP.parseAst input :: (PP.To Grammar.Syntax) of
Left err -> do
Log.err $ "error in file '" ++ lalrFile args ++ "':"
Log.err $ show err
Log.abort
Right ast -> do
r <- Log.io $ PP.rules' $ PP.lexify ast
case r of
Left err -> do
Log.err $ "cannot make rules: " ++ err
Log.abort
Right rules -> do
let (prs, lrs) = PP.separate rules
case PP.extend prs of
Left err -> do
Log.err "cannot extend the input grammar:"
Log.err err
Log.abort
Right g' -> do
let rs = PP.ruleSet g'
let (errors, warnings) = PP.check rs
mapM_ Log.warn warnings
if errors /= [] then do
Log.err "errors found in rules:"
mapM_ Log.err errors
Log.abort
else do
let fs = PP.firstSet rs
Log.pushTask "compute collection and table"
c <- Work.reuse (useWork cargs)
(lalrFile args)
"collection"
(Log.io $ return $ PP.collection rs fs)
:: Log.LoggerIO (PP.LrCollection Builder.LalrItem)
-- Flag '--collection'
when (showCollection args) $
printCollection c
-- Flag '--set'
when (showSetI args /= (-1)) $
printSet (showSetI args) $ c Vector.! showSetI args
t <- Work.reuse (useWork cargs)
(lalrFile args)
"table"
(Log.io $ return $ PP.table c)
case t of
Left err -> do
Log.popTask
Log.err "grammar is not LALR:"
mapM_ Log.err err
Log.abort
Right t -> do
Log.popTask
-- Flag '--table'
when (showTable args) $ do
Log.info "table:"
printTable t
Log.pushTask "compute DFA"
dfa' <- Work.reuse (useWork cargs)
(lalrFile args)
"dfa"
(Log.io $ Lexer.createDfa' lrs)
case dfa' of
Left err -> do
Log.popTask
Log.err $ "cannot create DFA: " ++ err
Log.abort
Right dfa -> do
Log.popTask
-- Flag `--dfa`
when (showDfa args) $
printDfa dfa
-- Flag '--test-with'
when (testWith args /= "") $ do
source <- Log.io $ readFile $ testWith args
let lconfig = Lexer.dfaConfig source dfa
let tokens = PP.output $ PP.consume lconfig
let cfg = PP.parse' t $ PP.config t tokens :: [Parser.LrConfig]
-- Flag `--ast`
when (showAst args) $ do
Log.info "parsed AST:"
Log.out $ Parser.prettyAst $ Parser.lrAst $ head cfg
-- Flag `--ast-to-html`
when (astHtml args /= "") $ do
Log.info $ "AST to HTML: " ++ astHtml args
Log.io $ writeFile (astHtml args) (astToHtml $ Parser.lrAst $ head cfg)
printCfg cfg
-- Flag '--template'
when (template args /= "") $ do
te <- Log.io $ readFile $ template args
let c1 = LrTemplate.context t
let c2 = DfaTemplate.context dfa
let compiled = PP.compile (PP.mergeContext c1 c2) te
Log.info "compiled template:"
Log.out compiled
-- End
Log.popTag
return ()
-- |Pretty print for collection
printCollection :: PP.LrCollection Builder.LalrItem -> Log.Logger
printCollection c = do
Log.info "collection:"
Vector.imapM_ printSet c
-- |Pretty print for set
printSet :: Int -> PP.LrSet Builder.LalrItem -> Log.Logger
printSet i is = do
Log.info $ "items set " ++ show i ++ ":"
mapM_ (Log.out . show) $ Set.toList is
-- |Pretty print for table
printTable :: PP.LrTable -> Log.Logger
printTable = Log.out . Map.showTree
-- |Pretty print for configuration
printCfg :: [Parser.LrConfig] -> Log.Logger
printCfg = printCfg' . head
where
printCfg' (Parser.LrConfig c _ a i _) = do
Log.out $ "after " ++ show c ++ " iterations: "
case a of
PP.LrAccept -> Log.out "input accepted"
_ -> Log.out $ "error at " ++ show (take 20 (str i))
str = concatMap (\(PP.OToken2 v _) -> v)
-- |Pretty print for DFA
printDfa :: PP.DfaGraph -> Log.Logger
printDfa = Log.out . Gr.prettify
-- |Print the AST to HTML
astToHtml :: Parser.LrAst -> String
astToHtml (Parser.LrAstRoot xs) = "<ul>" ++ concatMap astToHtml xs ++ "</ul>"
astToHtml (Parser.LrAstNonTerm r xs) = "<li>" ++ r ++ "<ul>" ++ concatMap astToHtml xs ++ "</ul></li>"
astToHtml (Parser.LrAstTerm t) = "<li>" ++ show t ++ "</li>"