    /-----------------------------------------------------------------------------
    The Grammar data type.

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

    Mangler converts AbsSyn to Grammar

    > {-# LANGUAGE ScopedTypeVariables #-}

    > module Happy.Frontend.Mangler (mangler) where

    > import Happy.Grammar
    > import Happy.Frontend.AbsSyn
    > import Happy.Frontend.Mangler.Monad
    > import Happy.Frontend.AttrGrammar.Mangler

    > import Happy.Frontend.ParamRules

    > import Data.Array ( Array, (!), accumArray, array, listArray )
    > import Data.Char  ( isAlphaNum, isDigit, isLower )
    > import Data.List  ( zip4, sortBy )
    > import Data.Ord

    > import Control.Monad.Writer ( Writer, mapWriter, runWriter )

    -----------------------------------------------------------------------------
    -- The Mangler

    This bit is a real mess, mainly because of the error message support.

    > mangler :: FilePath -> AbsSyn String -> Either [ErrMsg] (Grammar String, Maybe AttributeGrammarExtras, Directives)
    > mangler :: String
    -> AbsSyn String
    -> Either
         [String] (Grammar String, Maybe AttributeGrammarExtras, Directives)
    mangler String
    file abssyn :: AbsSyn String
    abssyn@(AbsSyn [Directive String]
    dirs [Rule String]
    _)
    >   | [String] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [String]
    errs = (Grammar String, Maybe AttributeGrammarExtras, Directives)
    -> Either
         [String] (Grammar String, Maybe AttributeGrammarExtras, Directives)
    forall a b. b -> Either a b
    Right (Grammar String
    gd, Maybe AttributeGrammarExtras
    mAg, Directives
    ps)
    >   | Bool
    otherwise = [String]
    -> Either
         [String] (Grammar String, Maybe AttributeGrammarExtras, Directives)
    forall a b. a -> Either a b
    Left [String]
    errs
    >   where mAg :: Maybe AttributeGrammarExtras
    mAg = [Directive String] -> Maybe AttributeGrammarExtras
    forall t. [Directive t] -> Maybe AttributeGrammarExtras
    getAttributeGrammarExtras [Directive String]
    dirs
    >         ((Grammar String
    gd, Directives
    ps), [String]
    errs) = Writer [String] (Grammar String, Directives)
    -> ((Grammar String, Directives), [String])
    forall w a. Writer w a -> (a, w)
    runWriter (String
    -> CodeChecker String
    -> String
    -> AbsSyn String
    -> Writer [String] (Grammar String, Directives)
    forall e.
    e
    -> CodeChecker e -> String -> AbsSyn e -> M (Grammar e, Directives)
    manglerM String
    "no code" CodeChecker String
    checkCode String
    file AbsSyn String
    abssyn)

    If any attribute directives were used, we are in an attribute grammar, so
    go do special processing.  If not, pass on to the regular processing routine

    >         checkCode :: CodeChecker String
    >         checkCode :: CodeChecker String
    checkCode = case Maybe AttributeGrammarExtras
    mAg of
    >             Maybe AttributeGrammarExtras
    Nothing -> \[Name]
    lhs [Name]
    _             String
    code ->
    >                 Int -> String -> M (String, [Int])
    doCheckCode ([Name] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Name]
    lhs) String
    code
    >             Just AttributeGrammarExtras
    a  -> \[Name]
    lhs [Name]
    nonterm_names String
    code ->
    >                 [Name]
    -> [Name] -> String -> AttributeGrammarExtras -> M (String, [Int])
    rewriteAttributeGrammar [Name]
    lhs [Name]
    nonterm_names String
    code AttributeGrammarExtras
    a

    > -- | Function to check elimination rules
    > type CodeChecker e = [Name] -> [Name] -> e -> M (e, [Int])

    > manglerM
    >   :: forall e
    >   .  e
    >   -- ^ Empty elimination rule, used for starting productions. Will never be run.
    >   -> CodeChecker e
    >   -> FilePath
    >   -> AbsSyn e
    >   -> M (Grammar e, Directives)
    > manglerM :: forall e.
    e
    -> CodeChecker e -> String -> AbsSyn e -> M (Grammar e, Directives)
    manglerM e
    noCode CodeChecker e
    checkCode String
    file (AbsSyn [Directive String]
    dirs [Rule e]
    rules') =
    >   -- add filename to all error messages
    >   (((Grammar e, Directives), [String])
     -> ((Grammar e, Directives), [String]))
    -> Writer [String] (Grammar e, Directives)
    -> Writer [String] (Grammar e, Directives)
    forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
    mapWriter (\((Grammar e, Directives)
    a,[String]
    e) -> ((Grammar e, Directives)
    a, (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (\String
    s -> String
    file String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s) [String]
    e)) (Writer [String] (Grammar e, Directives)
     -> Writer [String] (Grammar e, Directives))
    -> Writer [String] (Grammar e, Directives)
    -> Writer [String] (Grammar e, Directives)
    forall a b. (a -> b) -> a -> b
    $ do

    >   rules <- case [Rule e] -> Either String [Rule1 e]
    forall e. [Rule e] -> Either String [Rule1 e]
    expand_rules [Rule e]
    rules' of
    >              Left String
    err -> String -> M ()
    addErr String
    err M ()
    -> WriterT [String] Identity [Rule1 e]
    -> WriterT [String] Identity [Rule1 e]
    forall a b.
    WriterT [String] Identity a
    -> WriterT [String] Identity b -> WriterT [String] Identity b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> [Rule1 e] -> WriterT [String] Identity [Rule1 e]
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
    >              Right [Rule1 e]
    as -> [Rule1 e] -> WriterT [String] Identity [Rule1 e]
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [Rule1 e]
    as
    >   nonterm_strs <- checkRules [n | Rule1 n _ _ <- rules] "" []

    >   let

    >       terminal_strs  = [[String]] -> [String]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ((Directive String -> [String]) -> [Directive String] -> [[String]]
    forall a b. (a -> b) -> [a] -> [b]
    map Directive String -> [String]
    forall a. Directive a -> [a]
    getTerm [Directive String]
    dirs) [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    eofName]

    >       first_nt, first_t, last_start, last_nt, last_t :: Name

    >       first_nt   = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName Name
    firstStartTok Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Directive String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Directive String]
    starts'
    >       first_t    = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName Name
    first_nt Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    nonterm_strs
    >       last_start = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName Name
    first_nt Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1
    >       last_nt    = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName Name
    first_t  Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1
    >       last_t     = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ Name -> Int
    getName Name
    first_t Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [String] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [String]
    terminal_strs Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1

    >       start_names    = [ Name
    firstStartTok .. Name
    last_start ]
    >       nonterm_names  = [ Name
    first_nt .. Name
    last_nt ]
    >       terminal_names = [ Name
    first_t .. Name
    last_t ]

    >       starts'     = case [Directive String] -> [Directive String]
    forall t. [Directive t] -> [Directive t]
    getParserNames [Directive String]
    dirs of
    >                       [] -> [String -> Maybe String -> Bool -> Directive String
    forall a. String -> Maybe String -> Bool -> Directive a
    TokenName String
    "happyParse" Maybe String
    forall a. Maybe a
    Nothing Bool
    False]
    >                       [Directive String]
    ns -> [Directive String]
    ns
    >       error_resumptive | ResumptiveErrorHandler{} <- [Directive String] -> ErrorHandlerInfo
    forall t. [Directive t] -> ErrorHandlerInfo
    getError [Directive String]
    dirs = Bool
    True
    >                        | Bool
    otherwise                                 = Bool
    False
    >
    >       start_strs  = [ String
    startNameString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++Char
    '_'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    p  | (TokenName String
    p Maybe String
    _ Bool
    _) <- [Directive String]
    starts' ]

    Build up a mapping from name values to strings.

    >       name_env = (Name
    errorTok, String
    errorName) (Name, String) -> [(Name, String)] -> [(Name, String)]
    forall a. a -> [a] -> [a]
    :
    >                  (Name
    catchTok, String
    catchName) (Name, String) -> [(Name, String)] -> [(Name, String)]
    forall a. a -> [a] -> [a]
    :
    >                  (Name
    dummyTok, String
    dummyName) (Name, String) -> [(Name, String)] -> [(Name, String)]
    forall a. a -> [a] -> [a]
    :
    >                  [Name] -> [String] -> [(Name, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    start_names    [String]
    start_strs [(Name, String)] -> [(Name, String)] -> [(Name, String)]
    forall a. [a] -> [a] -> [a]
    ++
    >                  [Name] -> [String] -> [(Name, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    nonterm_names  [String]
    nonterm_strs [(Name, String)] -> [(Name, String)] -> [(Name, String)]
    forall a. [a] -> [a] -> [a]
    ++
    >                  [Name] -> [String] -> [(Name, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name]
    terminal_names [String]
    terminal_strs

    >       lookupName :: String -> [Name]
    >       lookupName String
    n = [ Name
    t | (Name
    t,String
    r) <- [(Name, String)]
    name_env, String
    r String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    n
    >                          , Name
    t Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Name
    catchTok Bool -> Bool -> Bool
    || Bool
    error_resumptive ]
    >                            -- hide catchName unless %errorresumptive is active
    >                            -- issue93.y uses catch as a nonterminal, we should not steal it

    >       mapToName String
    str' =
    >             case String -> [Name]
    lookupName String
    str' of
    >                [Name
    a]   -> Name -> WriterT [String] Identity Name
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    a
    >                []    -> do String -> M ()
    addErr (String
    "unknown identifier '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'")
    >                            Name -> WriterT [String] Identity Name
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    errorTok -- SG: What a confusing use of errorTok.. Use dummyTok?
    >                (Name
    a:[Name]
    _) -> do String -> M ()
    addErr (String
    "multiple use of '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str' String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'")
    >                            Name -> WriterT [String] Identity Name
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    a

    Start symbols...

    >               -- default start token is the first non-terminal in the grammar
    >       lookupStart (TokenName String
    _ Maybe String
    Nothing  Bool
    _) = Name -> WriterT [String] Identity Name
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Name
    first_nt
    >       lookupStart (TokenName String
    _ (Just String
    n) Bool
    _) = String -> WriterT [String] Identity Name
    mapToName String
    n
    >       lookupStart Directive a
    _ = String -> WriterT [String] Identity Name
    forall a. HasCallStack => String -> a
    error String
    "lookupStart: Not a TokenName"
    >   -- in

    >   start_toks <- mapM lookupStart starts'

    >   let
    >       parser_names   = [ String
    s | TokenName String
    s Maybe String
    _ Bool
    _ <- [Directive String]
    starts' ]
    >       start_partials = [ Bool
    b | TokenName String
    _ Maybe String
    _ Bool
    b <- [Directive String]
    starts' ]
    >       start_prods = (Name -> Name -> Production e)
    -> [Name] -> [Name] -> [Production e]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Name
    nm Name
    tok -> Name -> [Name] -> (e, [Int]) -> Priority -> Production e
    forall eliminator.
    Name
    -> [Name]
    -> (eliminator, [Int])
    -> Priority
    -> Production eliminator
    Production Name
    nm [Name
    tok] (e
    noCode,[]) Priority
    No)
    >                        [Name]
    start_names [Name]
    start_toks

    Deal with priorities...

    >       priodir = [Int] -> [Directive String] -> [(Int, Directive String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    1..] ([Directive String] -> [Directive String]
    forall t. [Directive t] -> [Directive t]
    getPrios [Directive String]
    dirs)
    >
    >       mkPrio :: Int -> Directive a -> Priority
    >       mkPrio Int
    i (TokenNonassoc [String]
    _) = Assoc -> Int -> Priority
    Prio Assoc
    None Int
    i
    >       mkPrio Int
    i (TokenRight [String]
    _) = Assoc -> Int -> Priority
    Prio Assoc
    RightAssoc Int
    i
    >       mkPrio Int
    i (TokenLeft [String]
    _) = Assoc -> Int -> Priority
    Prio Assoc
    LeftAssoc Int
    i
    >       mkPrio Int
    _ Directive a
    _ = String -> Priority
    forall a. HasCallStack => String -> a
    error String
    "Panic: impossible case in mkPrio"

    >       prios = [ (Name
    name,Int -> Directive String -> Priority
    forall a. Int -> Directive a -> Priority
    mkPrio Int
    i Directive String
    dir)
    >               | (Int
    i,Directive String
    dir) <- [(Int, Directive String)]
    priodir
    >               , String
    nm <- Directive String -> [String]
    forall t. Directive t -> [String]
    getPrioNames Directive String
    dir
    >               , Name
    name <- String -> [Name]
    lookupName String
    nm
    >               ]

    >       prioByString = [ (String
    name, Int -> Directive String -> Priority
    forall a. Int -> Directive a -> Priority
    mkPrio Int
    i Directive String
    dir)
    >                      | (Int
    i,Directive String
    dir) <- [(Int, Directive String)]
    priodir
    >                      , String
    name <- Directive String -> [String]
    forall t. Directive t -> [String]
    getPrioNames Directive String
    dir
    >                      ]

    Translate the rules from string to name-based.

    >       convNT (Rule1 String
    nt [Prod1 e]
    prods Maybe (String, Subst)
    ty)
    >         = do nt' <- String -> WriterT [String] Identity Name
    mapToName String
    nt
    >              return (nt', prods, ty)
    >
    >       transRule (Name
    nt, t (Prod1 e)
    prods, c
    _ty)
    >         = (Prod1 e -> WriterT [String] Identity (Production e))
    -> t (Prod1 e) -> WriterT [String] Identity (t (Production e))
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> t a -> m (t b)
    mapM (Name -> Prod1 e -> WriterT [String] Identity (Production e)
    finishRule Name
    nt) t (Prod1 e)
    prods
    >
    >       finishRule :: Name -> Prod1 e -> Writer [ErrMsg] (Production e)
    >       finishRule Name
    nt (Prod1 [String]
    lhs e
    code Int
    line Prec
    prec)
    >         = ((Production e, [String]) -> (Production e, [String]))
    -> WriterT [String] Identity (Production e)
    -> WriterT [String] Identity (Production e)
    forall a w b w'. ((a, w) -> (b, w')) -> Writer w a -> Writer w' b
    mapWriter (\(Production e
    a,[String]
    e) -> (Production e
    a, (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> String -> String
    addLine Int
    line) [String]
    e)) (WriterT [String] Identity (Production e)
     -> WriterT [String] Identity (Production e))
    -> WriterT [String] Identity (Production e)
    -> WriterT [String] Identity (Production e)
    forall a b. (a -> b) -> a -> b
    $ do
    >           lhs' <- (String -> WriterT [String] Identity Name)
    -> [String] -> WriterT [String] Identity [Name]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM String -> WriterT [String] Identity Name
    mapToName [String]
    lhs
    >           code' <- checkCode lhs' nonterm_names code
    >           case mkPrec lhs' prec of
    >               Left String
    s  -> do String -> M ()
    addErr (String
    "Undeclared precedence token: " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s)
    >                             Production e -> WriterT [String] Identity (Production e)
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> [Name] -> (e, [Int]) -> Priority -> Production e
    forall eliminator.
    Name
    -> [Name]
    -> (eliminator, [Int])
    -> Priority
    -> Production eliminator
    Production Name
    nt [Name]
    lhs' (e, [Int])
    code' Priority
    No)
    >               Right Priority
    p -> Production e -> WriterT [String] Identity (Production e)
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> [Name] -> (e, [Int]) -> Priority -> Production e
    forall eliminator.
    Name
    -> [Name]
    -> (eliminator, [Int])
    -> Priority
    -> Production eliminator
    Production Name
    nt [Name]
    lhs' (e, [Int])
    code' Priority
    p)
    >
    >       mkPrec :: [Name] -> Prec -> Either String Priority
    >       mkPrec [Name]
    lhs Prec
    PrecNone =
    >         case (Name -> Bool) -> [Name] -> [Name]
    forall a. (a -> Bool) -> [a] -> [a]
    filter ((Name -> [Name] -> Bool) -> [Name] -> Name -> Bool
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip Name -> [Name] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    elem [Name]
    terminal_names) [Name]
    lhs of
    >                            [] -> Priority -> Either String Priority
    forall a b. b -> Either a b
    Right Priority
    No
    >                            [Name]
    xs -> case Name -> [(Name, Priority)] -> Maybe Priority
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup ([Name] -> Name
    forall a. HasCallStack => [a] -> a
    last [Name]
    xs) [(Name, Priority)]
    prios of
    >                                    Maybe Priority
    Nothing -> Priority -> Either String Priority
    forall a b. b -> Either a b
    Right Priority
    No
    >                                    Just Priority
    p  -> Priority -> Either String Priority
    forall a b. b -> Either a b
    Right Priority
    p
    >       mkPrec [Name]
    _ (PrecId String
    s) =
    >         case String -> [(String, Priority)] -> Maybe Priority
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    s [(String, Priority)]
    prioByString of
    >                           Maybe Priority
    Nothing -> String -> Either String Priority
    forall a b. a -> Either a b
    Left String
    s
    >                           Just Priority
    p -> Priority -> Either String Priority
    forall a b. b -> Either a b
    Right Priority
    p
    >
    >       mkPrec [Name]
    _ Prec
    PrecShift = Priority -> Either String Priority
    forall a b. b -> Either a b
    Right Priority
    PrioLowest
    >
    >   -- in

    >   rules1 <- mapM convNT rules
    >   rules2 <- mapM transRule rules1

    >   let
    >       type_env = [(String
    nt, String
    t) | Rule1 String
    nt [Prod1 e]
    _ (Just (String
    t,[])) <- [Rule1 e]
    rules] Subst -> Subst -> Subst
    forall a. [a] -> [a] -> [a]
    ++
    >                  [(String
    nt, [Directive String] -> String
    forall t. [Directive t] -> String
    getTokenType [Directive String]
    dirs) | String
    nt <- [String]
    terminal_strs] -- XXX: Doesn't handle $$ type!
    >
    >       fixType (String
    ty,Subst
    s) = String -> String -> WriterT [String] Identity String
    go String
    "" String
    ty
    >         where go :: String -> String -> WriterT [String] Identity String
    go String
    acc [] = String -> WriterT [String] Identity String
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> String
    forall a. [a] -> [a]
    reverse String
    acc)
    >               go String
    acc (Char
    c:String
    r) | Char -> Bool
    isLower Char
    c = -- look for a run of alphanumerics starting with a lower case letter
    >                                let (String
    cs,String
    r1) = (Char -> Bool) -> String -> (String, String)
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span Char -> Bool
    isAlphaNum String
    r
    >                                    go1 :: String -> WriterT [String] Identity String
    go1 String
    x = String -> String -> WriterT [String] Identity String
    go (String -> String
    forall a. [a] -> [a]
    reverse String
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    acc) String
    r1
    >                                in case String -> Subst -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    cs) Subst
    s of
    >                                        Maybe String
    Nothing -> String -> WriterT [String] Identity String
    go1 (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    cs) -- no binding found
    >                                        Just String
    a -> case String -> Subst -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup String
    a Subst
    type_env of
    >                                          Maybe String
    Nothing -> do
    >                                            String -> M ()
    addErr (String
    "Parameterized rule argument '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    a String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "' does not have type")
    >                                            String -> WriterT [String] Identity String
    go1 (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    cs)
    >                                          Just String
    t -> String -> WriterT [String] Identity String
    go1 (String -> WriterT [String] Identity String)
    -> String -> WriterT [String] Identity String
    forall a b. (a -> b) -> a -> b
    $ String
    "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    t String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")"
    >                            | Bool
    otherwise = String -> String -> WriterT [String] Identity String
    go (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    acc) String
    r
    >
    >       convType (a
    nm, (String, Subst)
    t)
    >         = do t' <- (String, Subst) -> WriterT [String] Identity String
    fixType (String, Subst)
    t
    >              return (nm, t')
    >
    >   -- in
    >   tys <- mapM convType [ (nm, t) | (nm, _, Just t) <- rules1 ]
    >

    >   let
    >       type_array :: Array Name (Maybe String)
    >       type_array = (Maybe String -> Maybe String -> Maybe String)
    -> Maybe String
    -> (Name, Name)
    -> [(Name, Maybe String)]
    -> Array Name (Maybe String)
    forall i e a.
    Ix i =>
    (e -> a -> e) -> e -> (i, i) -> [(i, a)] -> Array i e
    accumArray (\Maybe String
    _ Maybe String
    x -> Maybe String
    x) Maybe String
    forall a. Maybe a
    Nothing (Name
    first_nt, Name
    last_nt)
    >                    [ (Name
    nm, String -> Maybe String
    forall a. a -> Maybe a
    Just String
    t) | (Name
    nm, String
    t) <- [(Name, String)]
    tys ]

    >       env_array :: Array Name String
    >       env_array = (Name, Name) -> [(Name, String)] -> Array Name String
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (Name
    errorTok, Name
    last_t) [(Name, String)]
    name_env
    >   -- in

    Get the token specs in terms of Names.

    >   let
    >       fixTokenSpec (String
    a,b
    b) = do n <- String -> WriterT [String] Identity Name
    mapToName String
    a; return (n,b)
    >   -- in
    >   tokspec <- mapM fixTokenSpec (getTokenSpec dirs)

    >   let
    >      ass = [(Name, Int)] -> [(Name, [Int])]
    forall a b. Ord a => [(a, b)] -> [(a, [b])]
    combinePairs [ (Name
    a,Int
    no)
    >                         | (Production Name
    a [Name]
    _ (e, [Int])
    _ Priority
    _,Int
    no) <- [Production e] -> [Int] -> [(Production e, Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Production e]
    productions' [Int
    0..] ]
    >      arr = (Name, Name) -> [(Name, [Int])] -> Array Name [Int]
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (Name
    firstStartTok, Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ [(Name, [Int])] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, [Int])]
    ass Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Name -> Int
    getName Name
    firstStartTok) [(Name, [Int])]
    ass

    >      lookup_prods :: Name -> [Int]
    >      lookup_prods Name
    x | Name
    x Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    >= Name
    firstStartTok Bool -> Bool -> Bool
    && Name
    x Name -> Name -> Bool
    forall a. Ord a => a -> a -> Bool
    < Name
    first_t = Array Name [Int]
    arr Array Name [Int] -> Name -> [Int]
    forall i e. Ix i => Array i e -> i -> e
    ! Name
    x
    >      lookup_prods Name
    _ = String -> [Int]
    forall a. HasCallStack => String -> a
    error String
    "lookup_prods"
    >
    >      productions' = [Production e]
    start_prods [Production e] -> [Production e] -> [Production e]
    forall a. [a] -> [a] -> [a]
    ++ [[Production e]] -> [Production e]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [[Production e]]
    rules2
    >      prod_array  = (Int, Int) -> [Production e] -> Array Int (Production e)
    forall i e. Ix i => (i, i) -> [e] -> Array i e
    listArray (Int
    0,[Production e] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Production e]
    productions' Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) [Production e]
    productions'

    >   return  (Grammar {
    >               productions       = productions',
    >               lookupProdNo      = (prod_array !),
    >               lookupProdsOfName = lookup_prods,
    >               token_specs       = tokspec,
    >               terminals         = errorTok : catchTok : terminal_names,
    >               non_terminals     = start_names ++ nonterm_names,
    >                                       -- INCLUDES the %start tokens
    >               starts            = zip4 parser_names start_names start_toks
    >                                       start_partials,
    >               types             = type_array,
    >               token_names       = env_array,
    >               first_nonterm     = first_nt,
    >               first_term        = first_t,
    >               eof_term          = last terminal_names,
    >               priorities        = prios
    >       },
    >       Directives {
    >               imported_identity                 = getImportedIdentity dirs,
    >               monad             = getMonad dirs,
    >               lexer             = getLexer dirs,
    >               error_handler     = getError dirs,
    >               error_expected    = getErrorExpectedMode dirs,
    >               token_type        = getTokenType dirs,
    >               expect            = getExpect dirs
    >       })

    Gofer-like stuff:

    > combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]
    > combinePairs :: forall a b. Ord a => [(a, b)] -> [(a, [b])]
    combinePairs [(a, b)]
    xs =
    >       [(a, [b])] -> [(a, [b])]
    forall {a} {a}. Eq a => [(a, [a])] -> [(a, [a])]
    combine [ (a
    a,[b
    b]) | (a
    a,b
    b) <- ((a, b) -> (a, b) -> Ordering) -> [(a, b)] -> [(a, b)]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (((a, b) -> a) -> (a, b) -> (a, b) -> Ordering
    forall a b. Ord a => (b -> a) -> b -> b -> Ordering
    comparing (a, b) -> a
    forall a b. (a, b) -> a
    fst) [(a, b)]
    xs]
    >  where
    >       combine :: [(a, [a])] -> [(a, [a])]
    combine [] = []
    >       combine ((a
    a,[a]
    b):(a
    c,[a]
    d):[(a, [a])]
    r) | a
    a a -> a -> Bool
    forall a. Eq a => a -> a -> Bool
    == a
    c = [(a, [a])] -> [(a, [a])]
    combine ((a
    a,[a]
    b[a] -> [a] -> [a]
    forall a. [a] -> [a] -> [a]
    ++[a]
    d) (a, [a]) -> [(a, [a])] -> [(a, [a])]
    forall a. a -> [a] -> [a]
    : [(a, [a])]
    r)
    >       combine ((a, [a])
    a:[(a, [a])]
    r) = (a, [a])
    a (a, [a]) -> [(a, [a])] -> [(a, [a])]
    forall a. a -> [a] -> [a]
    : [(a, [a])] -> [(a, [a])]
    combine [(a, [a])]
    r
    >

    For combining actions with possible error messages.

    > addLine :: Int -> String -> String
    > addLine :: Int -> String -> String
    addLine Int
    l String
    s = Int -> String
    forall a. Show a => a -> String
    show Int
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s

    > getTerm :: Directive a -> [a]
    > getTerm :: forall a. Directive a -> [a]
    getTerm (TokenSpec [(a, TokenSpec)]
    stuff) = ((a, TokenSpec) -> a) -> [(a, TokenSpec)] -> [a]
    forall a b. (a -> b) -> [a] -> [b]
    map (a, TokenSpec) -> a
    forall a b. (a, b) -> a
    fst [(a, TokenSpec)]
    stuff
    > getTerm Directive a
    _                 = []

    So is this.

    > checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]
    > checkRules :: [String] -> String -> [String] -> Writer [String] [String]
    checkRules (String
    name:[String]
    rest) String
    above [String]
    nonterms
    >       | String
    name String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    above = [String] -> String -> [String] -> Writer [String] [String]
    checkRules [String]
    rest String
    name [String]
    nonterms
    >       | String
    name String -> [String] -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` [String]
    nonterms
    >               = do String -> M ()
    addErr (String
    "Multiple rules for '" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "'")
    >                    [String] -> String -> [String] -> Writer [String] [String]
    checkRules [String]
    rest String
    name [String]
    nonterms
    >       | Bool
    otherwise = [String] -> String -> [String] -> Writer [String] [String]
    checkRules [String]
    rest String
    name (String
    name String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [String]
    nonterms)

    > checkRules [] String
    _ [String]
    nonterms = [String] -> Writer [String] [String]
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([String] -> [String]
    forall a. [a] -> [a]
    reverse [String]
    nonterms)

    -----------------------------------------------------------------------------
    -- Check for every $i that i is <= the arity of the rule.

    -- At the same time, we collect a list of the variables actually used in this
    -- code, which is used by the backend.

    > doCheckCode :: Int -> String -> M (String, [Int])
    > doCheckCode :: Int -> String -> M (String, [Int])
    doCheckCode Int
    arity String
    code0 = String -> String -> [Int] -> M (String, [Int])
    go String
    code0 String
    "" []
    >   where go :: String -> String -> [Int] -> M (String, [Int])
    go String
    code String
    acc [Int]
    used =
    >           case String
    code of
    >               [] -> (String, [Int]) -> M (String, [Int])
    forall a. a -> WriterT [String] Identity a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (String -> String
    forall a. [a] -> [a]
    reverse String
    acc, [Int]
    used)
    >
    >               Char
    '"'  :String
    r    -> case ReadS String
    forall a. Read a => ReadS a
    reads String
    code :: [(String,String)] of
    >                                []       -> String -> String -> [Int] -> M (String, [Int])
    go String
    r (Char
    '"'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    acc) [Int]
    used
    >                                (String
    s,String
    r'):Subst
    _ -> String -> String -> [Int] -> M (String, [Int])
    go String
    r' (String -> String
    forall a. [a] -> [a]
    reverse (String -> String
    forall a. Show a => a -> String
    show String
    s) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    acc) [Int]
    used
    >               Char
    a:Char
    '\'' :String
    r | Char -> Bool
    isAlphaNum Char
    a -> String -> String -> [Int] -> M (String, [Int])
    go String
    r (Char
    '\''Char -> String -> String
    forall a. a -> [a] -> [a]
    :Char
    aChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    acc) [Int]
    used
    >               Char
    '\'' :String
    r    -> case ReadS Char
    forall a. Read a => ReadS a
    reads String
    code :: [(Char,String)] of
    >                                []       -> String -> String -> [Int] -> M (String, [Int])
    go String
    r  (Char
    '\''Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    acc) [Int]
    used
    >                                (Char
    c,String
    r'):[(Char, String)]
    _ -> String -> String -> [Int] -> M (String, [Int])
    go String
    r' (String -> String
    forall a. [a] -> [a]
    reverse (Char -> String
    forall a. Show a => a -> String
    show Char
    c) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    acc) [Int]
    used
    >               Char
    '\\':Char
    '$':String
    r -> String -> String -> [Int] -> M (String, [Int])
    go String
    r (Char
    '$'Char -> String -> String
    forall a. a -> [a] -> [a]
    :String
    acc) [Int]
    used
    >
    >               Char
    '$':Char
    '>':String
    r -- the "rightmost token"
    >                       | Int
    arity Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    0 -> do String -> M ()
    addErr String
    "$> in empty rule"
    >                                          String -> String -> [Int] -> M (String, [Int])
    go String
    r String
    acc [Int]
    used
    >                       | Bool
    otherwise  -> String -> String -> [Int] -> M (String, [Int])
    go String
    r (String -> String
    forall a. [a] -> [a]
    reverse (Int -> String
    mkHappyVar Int
    arity) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    acc)
    >                                        (Int
    arity Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    used)
    >
    >               Char
    '$':r :: String
    r@(Char
    i:String
    _) | Char -> Bool
    isDigit Char
    i ->
    >                       case ReadS Int
    forall a. Read a => ReadS a
    reads String
    r :: [(Int,String)] of
    >                         (Int
    j,String
    r'):[(Int, String)]
    _ ->
    >                            if Int
    j Int -> Int -> Bool
    forall a. Ord a => a -> a -> Bool
    > Int
    arity
    >                                 then do String -> M ()
    addErr (Char
    '$'Char -> String -> String
    forall a. a -> [a] -> [a]
    : Int -> String
    forall a. Show a => a -> String
    show Int
    j String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " out of range")
    >                                         String -> String -> [Int] -> M (String, [Int])
    go String
    r' String
    acc [Int]
    used
    >                                 else String -> String -> [Int] -> M (String, [Int])
    go String
    r' (String -> String
    forall a. [a] -> [a]
    reverse (Int -> String
    mkHappyVar Int
    j) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    acc)
    >                                        (Int
    j Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int]
    used)
    >                         [] -> String -> M (String, [Int])
    forall a. HasCallStack => String -> a
    error String
    "doCheckCode []"
    >               Char
    c:String
    r  -> String -> String -> [Int] -> M (String, [Int])
    go String
    r (Char
    cChar -> String -> String
    forall a. a -> [a] -> [a]
    :String
    acc) [Int]
    used

    > mkHappyVar :: Int -> String
    > mkHappyVar :: Int -> String
    mkHappyVar Int
    n  = String
    "happy_var_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n