GenerateProlog.hs

----------------------------------------------------------------------------
-- |
-- 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]