GenerateProlog.hs

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