TltParser.y

{
-----------------------------------------------------------------------------
-- |
-- Module      :  Language.TLT.TltParser
-- Copyright   :  (c) 2011 University of Minho
-- License     :  BSD3
--
-- Maintainer  :  hpacheco@di.uminho.pt
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Multifocal:
-- Bidirectional Two-level Transformation of XML Schemas
-- 
-- Parser for the two-level language.
--
-----------------------------------------------------------------------------

module Language.TLT.TltParser where

import Language.TLT.TltSyntax
import Language.TLT.TltLexer
import Language.XPath.HXTAliases
}

%name parseTLTToks
%tokentype {Token}

%token
	nop { TokNop }
	comp { TokComp }
	choice { TokChoice }
	try { TokTry }
	many { TokMany }
	all { TokAll }
	once { TokOnce }
	everywhere { TokEverywhere }
	outermost { TokOutermost }
	at { TokAt }
	when { TokWhen }
	hoist { TokHoist }
	plunge { TokPlunge }
	rename { TokRename }
	erase { TokErase }
	select { TokSelect }
	string { TokString $$ }
	'(' { TokSym '(' }
	')' { TokSym ')' }

%left		comp choice
%left		'(' ')'

%%

start :: { TLT }
start : tlt { $1 }

tltparens :: { TLT }
tltparens : nop { Nop }
          | erase { Erase }
		  | '(' tlt ')' { $2 }

tlt :: { TLT }
tlt : tlbase { $1 }
    | tlstrat { $1 }
    | tlloc { $1 }
    | tllens { $1 }
    | '(' tlt ')' { $2 }

tlbase :: { TLT }
tlbase : nop { Nop }
       | tlt comp tlt { Comp $1 $3 }
       | tlt choice tlt { Choice $1 $3 }
       | try tltparens { Try $2 }
       | many tltparens { Many $2 }

tlstrat :: { TLT }
tlstrat : all tltparens { All $2 }
        | once tltparens { Once $2 }
        | everywhere tltparens { Everywhere $2 }
        | outermost tltparens { Outermost $2 }

tlloc :: { TLT }
tlloc : at string tltparens { At $2 $3 }
      | when string tltparens { When $2 $3 }
      | hoist { Hoist }
      | plunge string { Plunge $2 }
      | rename string { Rename $2 }

tllens :: { TLT }
tllens : erase { Erase }
       | select string { case parseXPath $2 of { Nothing -> error ("error parsing xpath expression "++$2); Just xp -> Select xp } }

{
happyError :: [Token] -> a
happyError (x:_) = error $ "Parser Error: " ++ show x
-- ^ returns the first non-valid token

parseTLT :: String -> TLT
parseTLT str =
	case (lexTLT str) of
	 (Left err)   -> error $ "Lexer error: " ++ show err
	 (Right toks) -> parseTLTToks toks
}