    -----------------------------------------------------------------------------
    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)       -- options
    >         (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)