AstDefinition.hs

----------------------------------------------------------------------------
-- |
-- Module      :  SableCC.AstDefinition
-- Copyright   :  (c) Fontaine 2011
-- License     :  BSD3
--
-- Maintainer  :  fontaine@cs.uni-duesseldorf.de
-- Stability   :  experimental
-- Portability :  GHC-only
--
--
-- The data type AstDefinition stores the structure of an Abstract Syntax Tree,
-- as it is modelled by the SableCC parser generator.
-- It also stores the SabelCC generated reduce actions for AST generation.
--
-----------------------------------------------------------------------------

{-
prototype of a Haskell backend for LR-parser-tables generated by SableCC
-}
{-# LANGUAGE GeneralizedNewtypeDeriving, RecordWildCards #-}
module SableCC.AstDefinition
where
import qualified SableCC.XML.ParserDefinitionRaw as Raw
import SableCC.XML.ParserDefinitionRaw hiding (Action)
import SableCC.ParserTypes hiding (Action)

import Data.Array as Array
import Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe

data AstDefinition = AstDefinition {
   productions :: [Prod]
  ,reductionTable :: Array ReductionID Action
  }

data Action = Action {
   actionRule :: Rule
  ,actionExpression :: ActionExpression
  }

data ActionExpression
  = Var String
  | EmptyList
  | SingletonList ActionExpression
  | AppendNode ActionExpression ActionExpression
  | AppendList ActionExpression ActionExpression
  | NewNode Prod Alt [ActionExpression]
  | FromNode ActionExpression
  | FromList ActionExpression
  | NodeResult ActionExpression
  | ListResult ActionExpression
  | ResultNothing
  deriving (Show)

-- | Translate the raw parser definition that is read from the XML file
-- to more highlevel representation.
-- This function also compiles the imperative reduce actions to a functional style.
makeAstDefinition :: Raw.Parser -> AstDefinition
makeAstDefinition rawParser = AstDefinition {..}
  where
    productions = Raw.parser_prods rawParser
    reductionTable = mkArray ReductionID $ map makeAction $ Raw.parser_rules rawParser

    mkArray :: Ix i => (Int -> i) -> [e] -> Array i e
    mkArray iType elems = listArray (iType 0, iType $ length elems -1 ) elems

    makeAction :: Rule -> Action
    makeAction rule = Action {..}
      where
        actionRule = rule
        actionExpression = runInterpreter [] $ rule_actions rule

    enameTable :: Map String (Prod,Alt)
    enameTable = Map.fromList $ do
         prod <- parser_prods rawParser
         alt <- prod_alt prod
         return (alt_ename alt,(prod,alt))

    runInterpreter :: [(String, ActionExpression)] -> [Raw.Action] -> ActionExpression
    runInterpreter env (h:r@(_:_)) = runInterpreter ((innerAction env h): env) r
    runInterpreter env [ret] = returnAction env ret

    innerAction :: [(String, ActionExpression)] -> Raw.Action -> (String, ActionExpression)
    innerAction env action = case action of
      Pop (ActionArgs {..}) -> (action_result, Var action_result)
      MakeList (ActionArgs {..}) -> (action_result, EmptyList)
      FetchList (ActionArgs {..}) | action_index == 0 -> (action_result, FromList $ valueOf action_arg_from)
      FetchList {} -> error "interpretAction : FETCHLIST expection Index == 0"
      FetchNode (ActionArgs {..}) | action_index == 0-> (action_result, FromNode $ valueOf action_arg_from)
      FetchNode (ActionArgs {..}) -> error "interpretAction :FETCHNODE expection Index == 0"
      AddList (ActionArgs {..}) -> (action_tolist, smartAppendList (valueOf action_tolist) (valueOf action_fromlist))
      AddNode (ActionArgs {..}) -> (action_tolist, smartAppendNode (valueOf action_tolist) (valueOf action_node))
      MakeNode (ActionArgs {..}) -> (action_result, NewNode prod alt $ makeChildren action_args)
        where
          (prod,alt) = case Map.lookup action_etype enameTable of
             Nothing -> error $ "cannot find " ++ action_etype ++ " in enameTable"
             Just res -> res

      other                      -> error $ "innerAction " ++ show other
      where
        valueOf = valueOfEnv env
        makeChildren = map toArg
          where
            toArg a = case a of
              ActionArgNull -> ResultNothing
              ActionArgList s -> valueOf s
              ActionArg s -> valueOf s

    smartAppendList :: ActionExpression -> ActionExpression -> ActionExpression
    smartAppendList EmptyList l = l
    smartAppendList a b = AppendList a b

    smartAppendNode :: ActionExpression -> ActionExpression -> ActionExpression
    smartAppendNode EmptyList l = SingletonList l
    smartAppendNode a b = AppendNode a b

    returnAction :: [(String, ActionExpression)] -> Raw.Action -> ActionExpression
    returnAction env action = case action of
      ReturnNode (ActionArgs {..})-> NodeResult $ valueOfEnv env action_node
      ReturnList (ActionArgs {..})-> ListResult $ valueOfEnv env action_list
      other                      -> error $ "returnAction " ++ show other

    valueOfEnv :: [(String, ActionExpression)] -> String -> ActionExpression
    valueOfEnv env ident = case List.lookup ident env of
          Nothing -> error $ "interpretAction, variable not in scope : " ++ ident
          Just a -> a