-----------------------------------------------------------------------------
Abstract syntax for grammar files.

(c) 1993-2001 Andy Gill, Simon Marlow
-----------------------------------------------------------------------------

Here is the abstract syntax of the language we parse.

> module Happy.Frontend.AbsSyn (
>       BookendedAbsSyn(..),
>       AbsSyn(..), Directive(..),
>       getTokenType, getTokenSpec, getParserNames, getLexer,
>       getImportedIdentity, getMonad, getError,
>       getPrios, getPrioNames, getExpect, getErrorHandlerType,
>       getAttributes, getAttributetype,
>       Rule(..), Prod(..), Term(..), Prec(..)
>  ) where

> import Happy.Grammar (ErrorHandlerType(..))

> data BookendedAbsSyn
>     = BookendedAbsSyn
>         (Maybe String)       -- header
>         AbsSyn
>         (Maybe String)       -- footer

> data AbsSyn
>     = AbsSyn
>         [Directive String]   -- directives
>         [Rule]               -- productions

> data Rule
>     = Rule
>         String               -- name of the rule
>         [String]             -- parameters (see parametrized productions)
>         [Prod]               -- productions
>         (Maybe String)       -- type of the rule

> data Prod
>     = Prod
>         [Term]               -- terms that make up the rule
>         String               -- code body that runs when the rule reduces
>         Int                  -- line number
>         Prec                 -- inline precedence annotation for the rule

> data Term
>     = App
>         String               -- name of the term
>         [Term]               -- parameter arguments (usually this is empty)

> data Prec
>     = PrecNone               -- no user-specified precedence
>     | PrecShift              -- %shift
>     | PrecId String          -- %prec ID
>   deriving Int -> Prec -> ShowS
[Prec] -> ShowS
Prec -> String
(Int -> Prec -> ShowS)
-> (Prec -> String) -> ([Prec] -> ShowS) -> Show Prec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Prec -> ShowS
showsPrec :: Int -> Prec -> ShowS
$cshow :: Prec -> String
show :: Prec -> String
$cshowList :: [Prec] -> ShowS
showList :: [Prec] -> ShowS
Show

%-----------------------------------------------------------------------------
Parser Generator Directives.

ToDo: find a consistent way to analyse all the directives together and
generate some error messages.

>
> data Directive a
>       = TokenType     String                  -- %tokentype
>       | TokenSpec     [(a,String)]            -- %token
>       | TokenName     String (Maybe String) Bool -- %name/%partial (True <=> %partial)
>       | TokenLexer    String String           -- %lexer
>       | TokenErrorHandlerType String          -- %errorhandlertype
>       | TokenImportedIdentity                                 -- %importedidentity
>       | TokenMonad    String String String String -- %monad
>       | TokenNonassoc [String]                -- %nonassoc
>       | TokenRight    [String]                -- %right
>       | TokenLeft     [String]                -- %left
>       | TokenExpect   Int                     -- %expect
>       | TokenError    String                  -- %error
>       | TokenAttributetype String             -- %attributetype
>       | TokenAttribute String String          -- %attribute
>   deriving Int -> Directive a -> ShowS
[Directive a] -> ShowS
Directive a -> String
(Int -> Directive a -> ShowS)
-> (Directive a -> String)
-> ([Directive a] -> ShowS)
-> Show (Directive a)
forall a. Show a => Int -> Directive a -> ShowS
forall a. Show a => [Directive a] -> ShowS
forall a. Show a => Directive a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Directive a -> ShowS
showsPrec :: Int -> Directive a -> ShowS
$cshow :: forall a. Show a => Directive a -> String
show :: Directive a -> String
$cshowList :: forall a. Show a => [Directive a] -> ShowS
showList :: [Directive a] -> ShowS
Show

> getTokenType :: [Directive t] -> String
> getTokenType :: forall t. [Directive t] -> String
getTokenType [Directive t]
ds
>       = case [ String
t | (TokenType String
t) <- [Directive t]
ds ] of
>               [String
t] -> String
t
>               []  -> ShowS
forall a. HasCallStack => String -> a
error String
"no token type given"
>               [String]
_   -> ShowS
forall a. HasCallStack => String -> a
error String
"multiple token types"

> getParserNames :: [Directive t] -> [Directive t]
> getParserNames :: forall t. [Directive t] -> [Directive t]
getParserNames [Directive t]
ds = [ Directive t
t | t :: Directive t
t@(TokenName String
_ Maybe String
_ Bool
_) <- [Directive t]
ds ]

> getLexer :: [Directive t] -> Maybe (String, String)
> getLexer :: forall t. [Directive t] -> Maybe (String, String)
getLexer [Directive t]
ds
>       = case [ (String
a,String
b) | (TokenLexer String
a String
b) <- [Directive t]
ds ] of
>               [(String, String)
t] -> (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String, String)
t
>               []  -> Maybe (String, String)
forall a. Maybe a
Nothing
>               [(String, String)]
_   -> String -> Maybe (String, String)
forall a. HasCallStack => String -> a
error String
"multiple lexer directives"

> getImportedIdentity :: [Directive t] -> Bool
> getImportedIdentity :: forall t. [Directive t] -> Bool
getImportedIdentity [Directive t]
ds
>       = case [ (()) | Directive t
TokenImportedIdentity <- [Directive t]
ds ] of
>               [()
_] -> Bool
True
>               []  -> Bool
False
>               [()]
_   -> String -> Bool
forall a. HasCallStack => String -> a
error String
"multiple importedidentity directives"

> getMonad :: [Directive t] -> (Bool, String, String, String, String)
> getMonad :: forall t. [Directive t] -> (Bool, String, String, String, String)
getMonad [Directive t]
ds
>       = case [ (Bool
True,String
a,String
b,String
c,String
d) | (TokenMonad String
a String
b String
c String
d) <- [Directive t]
ds ] of
>               [(Bool, String, String, String, String)
t] -> (Bool, String, String, String, String)
t
>               []  -> (Bool
False,String
"()",String
"HappyIdentity",String
"Prelude.>>=",String
"Prelude.return")
>               [(Bool, String, String, String, String)]
_   -> String -> (Bool, String, String, String, String)
forall a. HasCallStack => String -> a
error String
"multiple monad directives"

> getTokenSpec :: [Directive t] -> [(t, String)]
> getTokenSpec :: forall t. [Directive t] -> [(t, String)]
getTokenSpec [Directive t]
ds = [[(t, String)]] -> [(t, String)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(t, String)]
t | (TokenSpec [(t, String)]
t) <- [Directive t]
ds ]

> getPrios :: [Directive t] -> [Directive t]
> getPrios :: forall t. [Directive t] -> [Directive t]
getPrios [Directive t]
ds = [ Directive t
d | Directive t
d <- [Directive t]
ds,
>                 case Directive t
d of
>                   TokenNonassoc [String]
_ -> Bool
True
>                   TokenLeft [String]
_ -> Bool
True
>                   TokenRight [String]
_ -> Bool
True
>                   Directive t
_ -> Bool
False
>               ]

> getPrioNames :: Directive t -> [String]
> getPrioNames :: forall t. Directive t -> [String]
getPrioNames (TokenNonassoc [String]
s) = [String]
s
> getPrioNames (TokenLeft [String]
s)     = [String]
s
> getPrioNames (TokenRight [String]
s)    = [String]
s
> getPrioNames Directive t
_                 = String -> [String]
forall a. HasCallStack => String -> a
error String
"Not an associativity token"

> getExpect :: [Directive t] -> Maybe Int
> getExpect :: forall t. [Directive t] -> Maybe Int
getExpect [Directive t]
ds
>         = case [ Int
n | (TokenExpect Int
n) <- [Directive t]
ds ] of
>                 [Int
t] -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
t
>                 []  -> Maybe Int
forall a. Maybe a
Nothing
>                 [Int]
_   -> String -> Maybe Int
forall a. HasCallStack => String -> a
error String
"multiple expect directives"

> getError :: [Directive t] -> Maybe String
> getError :: forall t. [Directive t] -> Maybe String
getError [Directive t]
ds
>       = case [ String
a | (TokenError String
a) <- [Directive t]
ds ] of
>               [String
t] -> String -> Maybe String
forall a. a -> Maybe a
Just String
t
>               []  -> Maybe String
forall a. Maybe a
Nothing
>               [String]
_   -> String -> Maybe String
forall a. HasCallStack => String -> a
error String
"multiple error directives"

> getErrorHandlerType :: [Directive t] -> ErrorHandlerType
> getErrorHandlerType :: forall t. [Directive t] -> ErrorHandlerType
getErrorHandlerType [Directive t]
ds
>       = case [ String
a | (TokenErrorHandlerType String
a) <- [Directive t]
ds ] of
>               [String
t] -> case String
t of
>                        String
"explist" -> ErrorHandlerType
ErrorHandlerTypeExpList
>                        String
"default" -> ErrorHandlerType
ErrorHandlerTypeDefault
>                        String
_ -> String -> ErrorHandlerType
forall a. HasCallStack => String -> a
error String
"unsupported %errorhandlertype value"
>               []  -> ErrorHandlerType
ErrorHandlerTypeDefault
>               [String]
_   -> String -> ErrorHandlerType
forall a. HasCallStack => String -> a
error String
"multiple errorhandlertype directives"

> getAttributes :: [Directive t] -> [(String, String)]
> getAttributes :: forall t. [Directive t] -> [(String, String)]
getAttributes [Directive t]
ds
>         = [ (String
ident,String
typ) | (TokenAttribute String
ident String
typ) <- [Directive t]
ds ]

> getAttributetype :: [Directive t] -> Maybe String
> getAttributetype :: forall t. [Directive t] -> Maybe String
getAttributetype [Directive t]
ds
>         = case [ String
t | (TokenAttributetype String
t) <- [Directive t]
ds ] of
>                  [String
t] -> String -> Maybe String
forall a. a -> Maybe a
Just String
t
>                  []  -> Maybe String
forall a. Maybe a
Nothing
>                  [String]
_   -> String -> Maybe String
forall a. HasCallStack => String -> a
error String
"multiple attributetype directives"