---------------------------------------------------------------------------- -- | -- Module : SableCC.GenerateProlog -- Copyright : (c) Fontaine 2011 -- License : BSD3 -- -- Maintainer : fontaine@cs.uni-duesseldorf.de -- Stability : experimental -- Portability : GHC-only -- -- ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards #-} module SableCC.GenerateProlog ( generatePrologTables ) where import SableCC.XML.ParserDefinitionRaw as Raw import SableCC.XML.XML2Parser import SableCC.ParserDefinition as Parser import SableCC.LexerDefinition as Lexer import SableCC.AstDefinition as Ast import SableCC.ParserTypes as Parser import Data.Array as Array import Data.Char (ord) import qualified Data.Map as Map import Text.PrettyPrint.HughesPJ hiding (Mode) -- | Read the parser tables from an XML file and generate -- modules which contain the tables as Prolog clauses generatePrologTables :: FilePath -> IO () generatePrologTables xmlFile = do putStrLn "reading Parser" rawParser <- readParser xmlFile let lexerDefinition = makeLexerDefinition rawParser parserDefinition = makeParserDefinition rawParser astDefinition = makeAstDefinition rawParser putStrLn "writing parser_tables.pl" writeFile "parser_tables.pl" $ render $ vcat [ text "% Generated File DO NOT EDIT !!" ,text ":- style_check(-singleton)." ,text ":- discontiguous transition/3, accepts/3." ,text ":- discontiguous action/3, defaultAction/2." ,text ":- discontiguous goto/3, defaultGoto/2." ,breakLine ,text "% definition of the token classes" ,breakLine ,vcat $ map makeToken $ Array.assocs $ lexerTokens lexerDefinition ,breakLine ,text "% definition of the transition table" ,breakLine ,vcat $ map makeMode $ Array.assocs $ lexerModes lexerDefinition ,breakLine ,text "% definition of the mode transitions" ,breakLine ,vcat $ map makeModeTransition $ Array.assocs $ modeTransitions lexerDefinition ,breakLine ,breakLine ,text "% special EOF token for Parser" ,predicate "eof_token_id" [text "ptoken_" <> (int $ parser_parser_eof_index rawParser)] ,breakLine ,text "% definition of the LR action table" ,vcat $ map prologActionTable $ Array.assocs $ actionTable parserDefinition ,breakLine ,text "% parser error messages" ,vcat $ map parserErrorMessage $ Array.assocs $ errorTable parserDefinition ,text "% definition of the LR goto table" ,vcat $ map prologGotoTable $ Array.assocs $ gotoTable parserDefinition ,breakLine ,text "% definition of the CST -> AST reductions" ,vcat $ map makeReductionRule $ Array.elems $ reductionTable astDefinition ] breakLine :: Doc breakLine = text $ "% " ++ replicate 60 '-' term :: String -> [Doc] -> Doc term p l = text p <> (parens $ hsep $ punctuate comma l) predicate :: String -> [Doc] -> Doc predicate p l = term p l <> char '.' pString :: String -> Doc pString s = char '\'' <> text s <> char '\'' makeTokenID :: LexTokenID -> Doc makeTokenID (LexTokenID x) = text "token_" <> int x makeStateID :: LexStateID -> Doc makeStateID (LexStateID x) = text "state_" <> int x makeModeID :: ModeID -> Doc makeModeID (ModeID x) = text "mode_" <> int x makeToken :: (LexTokenID, Raw.Token) -> Doc makeToken (x, Raw.Token {..}) = predicate "token" [ makeTokenID x ,pString token_ename ,case token_parser_index of Nothing -> text "nothing" Just i -> term "just" [text "ptoken_" <> int i] ] makeMode :: (ModeID,(ModeName, Mode)) -> Doc makeMode (modeId,(modeName, mode)) = vcat [ breakLine ,text "% lexer mode : " <+> text modeName ,breakLine ,vcat $ map (makeTransition $ makeModeID modeId) $ Array.assocs $ modeStates mode ] makeTransition :: Doc -> (LexStateID, State) -> Doc makeTransition mode (state, State {..}) = vcat [ predicate "transition" [makeStateID state, mode, makeIntervalTree stateTransitions] ,predicate "accepts" [makeStateID state, mode, case stateAcceptedToken of Nothing -> text "nothing" Just i -> term "just" [makeTokenID i] ] ] makeIntervalTree :: IntervalTree -> Doc makeIntervalTree IntervalLeaf = text "leaf" makeIntervalTree (IntervalNode lowTree lowChar target highChar highTree) = term "node" [ makeIntervalTree lowTree , int $ ord lowChar , case target of Epsilon s -> term "epsilon" [makeStateID s] NotEpsilon s -> term "notEpsilon" [makeStateID s] , int $ ord highChar , makeIntervalTree highTree ] makeModeTransition :: ((LexTokenID,ModeID),ModeID) -> Doc makeModeTransition ((token,oldMode),newMode) = predicate "modeTransition" [ makeTokenID token , makeModeID oldMode , makeModeID newMode] mkLRState :: ParserStateID -> Doc mkLRState (ParserStateID x) = text "pstate_" <> int x prologActionTable :: (ParserStateID, TransitionList) -> Doc prologActionTable (pState, TransitionList {..}) = vcat [ breakLine ,text "% ParserState" <+> (text $ show pState) ,breakLine ,vcat $ map (mkTransition pState) $ Map.assocs transitionMap ,predicate "defaultAction" [mkLRState pState, makeAction defaultTransition] ,breakLine ] where mkTransition :: ParserStateID -> (ParserTokenID, Parser.Action) -> Doc mkTransition pState (ParserTokenID pToken, action) = predicate "action" [ mkLRState pState , text "ptoken_" <> int pToken , makeAction action] makeAction :: Parser.Action -> Doc makeAction x = case x of Shift state -> term "shift" [mkLRState state] Reduce (Reduction {..}) -> term "reduce" [ text "reduction_" <> (int $ unReductionID reductionID) , int popCount , text "goto_" <> (int $ unGotoIndex gotoIndex)] Accept -> text "accept" Error (ErrorID err) -> term "error" [text "error_" <> int err] parserErrorMessage :: (ErrorID, String) -> Doc parserErrorMessage (ErrorID i, msg) = predicate "errorMessage" [text "error_" <> int i, text $ show msg] prologGotoTable :: (GotoIndex, GotoMap) -> Doc prologGotoTable (GotoIndex i, GotoMap {..}) = vcat [ breakLine ,text "% Goto Table " <+> int i ,breakLine ,vcat $ map (mkGoto gotoIndex) $ Map.assocs gotoMap ,predicate "defaultGoto" [gotoIndex, mkLRState defaultGoto] ,breakLine ] where gotoIndex = text "goto_" <> int i mkGoto :: Doc -> (ParserStateID, ParserStateID) -> Doc mkGoto gi (from,to) = predicate "goto" [gi, mkLRState from, mkLRState to] makeReductionRule :: Ast.Action -> Doc makeReductionRule Ast.Action {..} = vcat [ text "% rule :" <+> (int $ rule_index actionRule) <+> (text $ rule_ename actionRule) ,predicate "reductionRule" [ text "reduction_" <> (int $ rule_index actionRule) ,plList popArgs ,expr $ actionExpression ] ] where popArgs = map (text . (++) "_" . action_result . unActionArgs) $ filter isPopAction $ rule_actions actionRule plList :: [Doc] -> Doc plList l = text "[" <+> (hsep $ punctuate (text " , ") l ) <+> text "]" plAtom :: String -> Doc plAtom s = char '\'' <> text s <> char '\'' expr :: ActionExpression -> Doc expr reduction = case reduction of Var s -> term "var" [text "_" <> text s] EmptyList -> text "emptyList" SingletonList e -> term "singletonList" [expr e] AppendNode l n -> term "appendNode" [expr l, expr n] AppendList l1 l2 -> term "appendList" [expr l1,expr l2] NewNode _prod alt l -> term "newNode" [ plAtom $ alt_name alt , plAtom $ alt_ename alt ,plList $ map expr l] FromNode e -> expr e FromList e -> term "head" [expr e] NodeResult e -> expr e ListResult e -> term "singletonList" [expr e] ResultNothing -> text "resultNothing"