-----------------------------------------------------------------------------
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, ErrorHandlerInfo(..), getError,
>       getPrios, getPrioNames, getExpect, getErrorExpectedMode,
>       getAttributes, getAttributetype, getAttributeGrammarExtras,
>       parseTokenSpec,
>       Rule(..), Prod(..), Term(..), Prec(..),
>       TokenSpec(..) -- reexport
>  ) where

> import Data.Char (isAlphaNum)
> import Happy.Grammar
> import Happy.Grammar.ExpressionWithHole

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

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

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

> data Prod e
>     = Prod
>         [Term]               -- terms that make up the rule
>         e                    -- 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, TokenSpec)]        -- %token
>       | TokenName     String (Maybe String) Bool -- %name/%partial (True <=> %partial)
>       | TokenLexer    String String           -- %lexer
>       | TokenImportedIdentity                                 -- %importedidentity
>       | TokenMonad    String String String String -- %monad
>       | TokenNonassoc [String]                -- %nonassoc
>       | TokenRight    [String]                -- %right
>       | TokenLeft     [String]                -- %left
>       | TokenExpect   Int                     -- %expect
>       | TokenError    String (Maybe String)   -- %error
>       | TokenErrorExpected                    -- %error.expected
>       | TokenErrorHandlerType String          -- %errorhandlertype
>       | TokenAttributetype String             -- %attributetype
>       | TokenAttribute String String          -- %attribute
>   deriving (Directive a -> Directive a -> Bool
(Directive a -> Directive a -> Bool)
-> (Directive a -> Directive a -> Bool) -> Eq (Directive a)
forall a. Eq a => Directive a -> Directive a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Directive a -> Directive a -> Bool
== :: Directive a -> Directive a -> Bool
$c/= :: forall a. Eq a => Directive a -> Directive a -> Bool
/= :: Directive a -> Directive a -> Bool
Eq, 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
"Happy_Prelude.>>=",String
"Happy_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, TokenSpec)]
> getTokenSpec :: forall t. [Directive t] -> [(t, TokenSpec)]
getTokenSpec [Directive t]
ds = [[(t, TokenSpec)]] -> [(t, TokenSpec)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ [(t, TokenSpec)]
t | (TokenSpec [(t, TokenSpec)]
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] -> ErrorHandlerInfo
> getError :: forall t. [Directive t] -> ErrorHandlerInfo
getError [Directive t]
ds
>       = case [ (String
a, Maybe String
mb_b) | (TokenError String
a Maybe String
mb_b) <- [Directive t]
ds ] of
>               []                        -> ErrorHandlerInfo
DefaultErrorHandler
>               [(String
a,Maybe String
Nothing)]             -> String -> ErrorHandlerInfo
CustomErrorHandler String
a
>               [(String
abort,Just String
addMessage)] -> String -> String -> ErrorHandlerInfo
ResumptiveErrorHandler String
abort String
addMessage
>               [(String, Maybe String)]
_   -> String -> ErrorHandlerInfo
forall a. HasCallStack => String -> a
error String
"multiple error directives"


> getErrorExpectedMode :: Eq t => [Directive t] -> ErrorExpectedMode
> getErrorExpectedMode :: forall t. Eq t => [Directive t] -> ErrorExpectedMode
getErrorExpectedMode [Directive t]
ds
>   | [String
"explist"] <- [String]
old_directive
>   = ErrorExpectedMode
OldExpected
>   | Directive t
forall a. Directive a
TokenErrorExpected Directive t -> [Directive t] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Directive t]
ds
>   = ErrorExpectedMode
NewExpected
>   | [String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
old_directive Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
>   = String -> ErrorExpectedMode
forall a. HasCallStack => String -> a
error String
"multiple errorhandlertype directives"
>   | Bool
otherwise
>   = ErrorExpectedMode
NoExpected
>   where
>     old_directive :: [String]
old_directive = [ String
a | (TokenErrorHandlerType String
a) <- [Directive t]
ds ]

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

> getAttributeGrammarExtras :: [Directive t] -> Maybe AttributeGrammarExtras
> getAttributeGrammarExtras :: forall t. [Directive t] -> Maybe AttributeGrammarExtras
getAttributeGrammarExtras [Directive t]
ds = case ([Directive t] -> [(String, String)]
forall t. [Directive t] -> [(String, String)]
getAttributes [Directive t]
ds, [Directive t] -> Maybe String
forall t. [Directive t] -> Maybe String
getAttributetype [Directive t]
ds) of
>   ([], Maybe String
Nothing) -> Maybe AttributeGrammarExtras
forall a. Maybe a
Nothing
>   ([(String, String)]
as, Just String
at) -> AttributeGrammarExtras -> Maybe AttributeGrammarExtras
forall a. a -> Maybe a
Just (AttributeGrammarExtras -> Maybe AttributeGrammarExtras)
-> AttributeGrammarExtras -> Maybe AttributeGrammarExtras
forall a b. (a -> b) -> a -> b
$ AttributeGrammarExtras {
>           attributes :: [(String, String)]
attributes = [(String, String)]
as,
>           attributetype :: String
attributetype = String
at
>       }
>   ((String, String)
_ : [(String, String)]
_, Maybe String
Nothing) -> String -> Maybe AttributeGrammarExtras
forall a. HasCallStack => String -> a
error String
"attributes found without attribute type directive"

> -- | Parse a token spec.
> --
> -- The first occurence of '$$' indicates an expression in which the '$$'
> -- will be substituted for the actual lexed token. '$$' in string or char
> -- literals ('".."' and '\'.\'') however does not count.
> parseTokenSpec :: String -> TokenSpec
> parseTokenSpec :: String -> TokenSpec
parseTokenSpec String
code0 = String -> String -> TokenSpec
go String
code0 String
""
>   where go :: String -> String -> TokenSpec
go String
code String
acc =
>           case String
code of
>               [] -> String -> TokenSpec
TokenFixed String
code0
>
>               Char
'"'  :String
r    -> case ReadS String
forall a. Read a => ReadS a
reads String
code :: [(String,String)] of
>                                []       -> String -> String -> TokenSpec
go String
r (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc)
>                                (String
s,String
r'):[(String, String)]
_ -> String -> String -> TokenSpec
go String
r' (ShowS
forall a. [a] -> [a]
reverse (ShowS
forall a. Show a => a -> String
show String
s) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
acc)
>               Char
a:Char
'\'' :String
r | Char -> Bool
isAlphaNum Char
a -> String -> String -> TokenSpec
go String
r (Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:Char
aChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc)
>               Char
'\'' :String
r    -> case ReadS Char
forall a. Read a => ReadS a
reads String
code :: [(Char,String)] of
>                                []       -> String -> String -> TokenSpec
go String
r (Char
'\''Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc)
>                                (Char
c,String
r'):[(Char, String)]
_ -> String -> String -> TokenSpec
go String
r' (ShowS
forall a. [a] -> [a]
reverse (Char -> String
forall a. Show a => a -> String
show Char
c) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
acc)
>               Char
'\\':Char
'$':String
r -> String -> String -> TokenSpec
go String
r (Char
'$'Char -> ShowS
forall a. a -> [a] -> [a]
:String
acc)
>               Char
'$':Char
'$':String
r  -> ExpressionWithHole -> TokenSpec
TokenWithValue (ExpressionWithHole -> TokenSpec)
-> ExpressionWithHole -> TokenSpec
forall a b. (a -> b) -> a -> b
$ String -> String -> ExpressionWithHole
ExpressionWithHole (ShowS
forall a. [a] -> [a]
reverse String
acc) String
r
>               Char
c:String
r  -> String -> String -> TokenSpec
go String
r (Char
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
acc)