---------------------------------------------------------------------------- -- | -- Module : SableCC.GenerateProlog -- Copyright : (c) Fontaine 2011,2012 -- License : BSD3 -- -- Maintainer : fontaine@cs.uni-duesseldorf.de -- Stability : experimental -- Portability : GHC-only -- -- ----------------------------------------------------------------------------- {-# LANGUAGE RecordWildCards, OverloadedStrings #-} 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 System.IO (withFile,IOMode (WriteMode)) import Data.Maybe import Data.Array as Array import Data.Char (ord) import qualified Data.Map as Map import Control.Monad.Trans.Reader import Text.PrettyPrint.Leijen.Text.Monadic hiding (Doc) import qualified Text.PrettyPrint.Leijen.Text.Monadic as PPM import qualified Data.Text.Lazy as T import Data.Text.Lazy (Text) import System.FilePath as FilePath -- | 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 grammarName = FilePath.takeBaseName xmlFile env = makePrologEnv grammarName rawParser lexerDefinition parserDefinition astDefinition runEnv = flip runReader env let tablesName = "parser_tables_"++ grammarName tablesFile = tablesName ++ ".pl" putStrLn $ "writing " ++ tablesFile withFile tablesFile WriteMode $ flip hPutDoc $ runEnv $ vcatM [ text "% Generated File DO NOT EDIT !!" ,text ":- module(" <+> textPack tablesName <+> text ",[" ,nest 4 $ vcatM [ text "transition/2, accepts/2, action/3, defaultAction/2, goto/3, defaultGoto/2" ,text ",modeTransition/3 ,errorMessage/2, reductionRule/3" ,text "])." ] ,text ":- discontiguous transition/2, accepts/2." ,text ":- discontiguous action/3, defaultAction/2." ,text ":- discontiguous goto/3, defaultGoto/2." ,breakLine ,text "% definition of the transition table" ,breakLine ,vcatM $ map makeMode $ Array.assocs $ lexerModes lexerDefinition ,breakLine ,text "% definition of the mode transitions" ,breakLine ,vcatM $ 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" ,vcatM $ map prologActionTable $ Array.assocs $ actionTable parserDefinition ,breakLine ,text "% parser error messages" ,vcatM $ map parserErrorMessage $ Array.assocs $ errorTable parserDefinition ,text "% definition of the LR goto table" ,vcatM $ map prologGotoTable $ Array.assocs $ gotoTable parserDefinition ,breakLine ,text "% definition of the CST -> AST reductions" ,vcatM $ map makeReductionRule $ Array.elems $ reductionTable astDefinition ] let astName = "ast_"++ grammarName astFile = astName ++ ".pl" putStrLn $ "writing " ++ astFile withFile astFile WriteMode $ flip hPutDoc $ runEnv $ vcatM [ text "% Generated File DO NOT EDIT !!" ,text ":- module(" <+> textPack astName <+> text ",[ adt/3])." ,text "% encoding of the data type used for the ast" ,makePrologADT astDefinition ] data Env = Env { envGrammarName :: String ,envRawDefinition :: Raw.Parser ,envLexerDefinition :: LexerDefinition ,envParserDefinition :: ParserDefinition ,envAstDefinition :: AstDefinition ,envParserTokenTable :: Array ParserTokenID LexTokenID } makePrologEnv :: String -> Raw.Parser -> LexerDefinition -> ParserDefinition -> AstDefinition -> Env makePrologEnv grammarName rawDef lexerDef parserDef astDef = Env { envGrammarName = grammarName ,envRawDefinition = rawDef ,envLexerDefinition = lexerDef ,envParserDefinition = parserDef ,envAstDefinition = astDef ,envParserTokenTable = parserTokTable } where parserTokTable = Array.array bounds reverseAssocs bounds = (minimum $ map fst reverseAssocs, maximum $ map fst reverseAssocs) reverseAssocs = mapMaybe getTokenAssoc $ Array.assocs $ lexerTokens lexerDef getTokenAssoc :: (LexTokenID, Raw.Token) -> Maybe (ParserTokenID,LexTokenID) getTokenAssoc (lexId,tok) = case token_parser_index tok of Nothing -> Nothing Just i -> Just (ParserTokenID i, lexId) type Doc = Reader Env PPM.Doc breakLine :: Doc breakLine = text "%" <+> (text $ T.replicate 60 "-") textPack :: String -> Doc textPack = text . T.pack textShow :: Show a => a -> Doc textShow = text . T.pack . show vcatM :: [Doc] -> Doc vcatM = vcat . sequence -- not correkt! nest 4 $ vcatM [..] does not work !? term :: Text -> [Doc] -> Doc term p [] = text p term p l = text p <> (parens $ hsep $ punctuate comma $ sequence l) predicate :: Text -> [Doc] -> Doc predicate p l = term p l <> char '.' pString :: String -> Doc pString s = char '\'' <> (text $ T.pack s) <> char '\'' plList :: [Doc] -> Doc plList l = text "[" <+> (hsep $ punctuate (text " , ") $ sequence l ) <+> text "]" makeTokenID :: LexTokenID -> Doc makeTokenID (LexTokenID x) = text "token_" <> int x makeTokenName :: LexTokenID -> Doc makeTokenName tokID = do table <- asks envLexerDefinition let tokenName = Raw.token_name ( lexerTokens table ! tokID) text "token_" <> textPack tokenName makeModeStateID :: ModeID -> LexStateID -> Doc makeModeStateID modeID (LexStateID stateId) = do table <- asks envLexerDefinition grammar <- asks envGrammarName let modeName = fst ( lexerModes table ! modeID) text "state_" <> textPack grammar <> text "_" <> textPack modeName <> text "_" <> int stateId makeMode :: (ModeID,(ModeName, Mode)) -> Doc makeMode (modeId,(modeName, mode)) = vcatM [ breakLine ,text "% lexer mode : " <+> textPack modeName ,breakLine ,vcatM $ map (makeTransition modeId) $ Array.assocs $ modeStates mode ] makeTransition :: ModeID -> (LexStateID, State) -> Doc makeTransition mode (stateID, state) = vcatM [ predicate "transition" [makeModeStateID mode stateID, makeIntervalTree mode $ stateTransitions state] ,predicate "accepts" [makeModeStateID mode stateID, makeAcceptedToken state] ] makeAcceptedToken :: State -> Doc makeAcceptedToken state = case stateAcceptedToken state of Nothing -> text "nothing" Just i -> term "just" [makeTokenName i] makeIntervalTree :: ModeID -> IntervalTree -> Doc makeIntervalTree _mode IntervalLeaf = text "leaf" makeIntervalTree mode (IntervalNode lowTree lowChar target highChar highTree) = term "node" [ makeIntervalTree mode lowTree , int $ ord lowChar , case target of Epsilon s -> term "epsilon" [makeModeStateID mode s] NotEpsilon s -> term "notEpsilon" [makeModeStateID mode s] , int $ ord highChar , makeIntervalTree mode highTree ] makeModeTransition :: ((LexTokenID,ModeID),ModeID) -> Doc makeModeTransition ((token,oldMode),newMode) = predicate "modeTransition" [ makeTokenName token , makeModeStateID oldMode (LexStateID 0) , makeModeStateID newMode (LexStateID 0)] makeLRState :: ParserStateID -> Doc makeLRState (ParserStateID i) = do grammar <- asks envGrammarName text "pstate_" <> textPack grammar <> text "_" <> int i makeGotoIndex :: GotoIndex -> Doc makeGotoIndex (GotoIndex i) = do grammar <- asks envGrammarName text "goto_" <> textPack grammar <> text "_" <> int i makeReductionIndex :: ReductionID -> Doc makeReductionIndex (ReductionID i) = do grammar <- asks envGrammarName text "reduction_" <> textPack grammar <> text "_" <> int i makeErrorIndex :: ErrorID -> Doc makeErrorIndex (ErrorID i) = do grammar <- asks envGrammarName text "error_" <> textPack grammar <> text "_" <> int i prologActionTable :: (ParserStateID, TransitionList) -> Doc prologActionTable (pState, TransitionList {..}) = vcatM [ breakLine ,text "% ParserState" <+> textShow pState ,breakLine ,vcatM $ map (mkTransition pState) $ Map.assocs transitionMap ,predicate "defaultAction" [makeLRState pState, makeAction defaultTransition] ,breakLine ] where mkTransition :: ParserStateID -> (ParserTokenID, Parser.Action) -> Doc mkTransition pState (pToken, action) = predicate "action" [ makeLRState pState , makeParserTokenName pToken , makeAction action] makeParserTokenName :: ParserTokenID -> Doc makeParserTokenName x@(ParserTokenID i) = do table <- asks envParserTokenTable eofID <- fmap parser_parser_eof_index $ asks envRawDefinition if i == eofID then text "token_eof" else makeTokenName $ table ! x makeAction :: Parser.Action -> Doc makeAction x = case x of Shift state -> term "shift" [makeLRState state] Reduce (Reduction {..}) -> term "reduce" [ makeReductionIndex reductionID , int popCount , makeGotoIndex gotoIndex] Accept -> text "accept" Error err -> term "error" [makeErrorIndex err] parserErrorMessage :: (ErrorID, String) -> Doc parserErrorMessage (errorID, msg) = predicate "errorMessage" [makeErrorIndex errorID, textShow msg] prologGotoTable :: (GotoIndex, GotoMap) -> Doc prologGotoTable (gotoIndex, GotoMap {..}) = vcatM [ breakLine ,text "% Goto Table " <+> makeGotoIndex gotoIndex ,breakLine ,vcatM $ map mkGoto $ Map.assocs gotoMap ,predicate "defaultGoto" [makeGotoIndex gotoIndex, makeLRState defaultGoto] ,breakLine ] where mkGoto (from,to) = predicate "goto" [makeGotoIndex gotoIndex, makeLRState from, makeLRState to] makeReductionRule :: Ast.Action -> Doc makeReductionRule Ast.Action {..} = vcatM [ text "% rule :" <+> (int $ rule_index actionRule) <+> (textPack $ rule_ename actionRule) ,predicate "reductionRule" [ makeReductionIndex $ ReductionID $ rule_index actionRule ,plList popArgs ,expr $ actionExpression ] ] where popArgs = map (textPack . (++) "_" . action_result . unActionArgs) $ filter isPopAction $ rule_actions actionRule plAtom :: String -> Doc plAtom s = char '\'' <> textPack s <> char '\'' expr :: ActionExpression -> Doc expr reduction = case reduction of Var s -> term "var" [text "_" <> textPack 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" makePrologADT :: AstDefinition -> Doc makePrologADT astDefinition = vcatM $ map makePrologType $ productions astDefinition where makePrologType :: Raw.Prod -> Doc makePrologType prod = vcatM [ text "% ADT for " <+> (textPack $ tail $ prod_ename prod) ,vcatM $ map (makeAlt (tail $ prod_ename prod)) $ prod_alt prod ] makeAlt typeName alt = predicate "adt" [pString typeName, textPack $ alt_name alt, plList $ map makeElem $ alt_elem alt ] makeElem elem = case (elem_modifier elem, elem_is_list elem) of (Just "*", True ) -> term "list" [body] (Just "?", False) -> term "optional" [body] (Nothing , False) -> body x -> error $ "makeElem: unexpected combination of modifier and islist : " ++ show x where body = pString $ tail $ elem_etype elem