    Module for producing GLR (Tomita) parsing code.
    This module is designed as an extension to the Haskell parser generator Happy.

    (c) University of Durham, Ben Medlock 2001
            -- initial code, for structure parsing
    (c) University of Durham, Paul Callaghan 2004
            -- extension to semantic rules, and various optimisations
    %-----------------------------------------------------------------------------

    > module Happy.Backend.GLR.ProduceCode
    >                       ( produceGLRParser
    >                       , baseTemplate
    >                       , libTemplate
    >                       , DecodeOption(..)
    >                       , FilterOption(..)
    >                       , GhcExts(..)
    >                       , Options
    >                       ) where

    > import Happy.Paths ( version )
    > import Happy.Grammar
    > import Happy.Grammar.ExpressionWithHole ( substExpressionWithHole )
    > import Happy.Tabular.LALR
    > import Data.Array ( Array, (!), array, assocs )
    > import Data.Char ( isSpace, isAlphaNum )
    > import Data.List ( nub, (\\), sort, find, tails )
    > import Data.Version ( showVersion )

    %-----------------------------------------------------------------------------
    File and Function Names

    > baseTemplate, libTemplate :: String -> String
    > baseTemplate :: String -> String
    baseTemplate String
    td = String
    td String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "/GLR_Base.hs"          -- NB Happy uses / too
    > libTemplate :: String -> String
    libTemplate  String
    td = String
    td String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "/GLR_Lib.hs"           -- Windows accepts this?

    ---
    prefix for production names, to avoid name clashes

    > prefix :: String
    > prefix :: String
    prefix = String
    "G_"

    %-----------------------------------------------------------------------------
    This type represents choice of decoding style for the result

    > data DecodeOption
    >  = TreeDecode
    >  | LabelDecode

    ---
    This type represents whether filtering done or not

    > data FilterOption
    >  = NoFiltering
    >  | UseFiltering

    ---
    This type represents whether GHC extensions are used or not
     - extra values are imports and ghc options reqd

    > data GhcExts
    >  = NoGhcExts
    >  | UseGhcExts String   -- imports
    >               [String] -- language extensions

    ---
    this is where the exts matter

    > show_st :: GhcExts -> {-State-}Int -> String
    > show_st :: GhcExts -> Int -> String
    show_st UseGhcExts{} = (String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "#") (String -> String) -> (Int -> String) -> Int -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String
    forall a. Show a => a -> String
    show
    > show_st GhcExts
    NoGhcExts    = Int -> String
    forall a. Show a => a -> String
    show

    ---

    > type DebugMode = Bool
    > type Options = (DecodeOption, FilterOption, GhcExts)

    %-----------------------------------------------------------------------------
    "produceGLRParser" generates the files containing the Tomita parsing code.
    It produces two files - one for the data (small template), and one for
    the driver and data strs (large template).

    > produceGLRParser
    >        :: (String      -- Base Template
    >           ,String)     -- Lib template
    >        -> String        -- Root of Output file name
    >        -> (ActionTable
    >           ,GotoTable)   -- LR tables
    >        -> String        -- Start parse function name
    >        -> Maybe String  -- Module header
    >        -> Maybe String  -- User-defined stuff (token DT, lexer etc.)
    >        -> (DebugMode,Options)       -- selecting code-gen style
    >        -> Grammar String -- Happy Grammar
    >        -> Directives       -- Directives in the .y-file
    >        -> (String       -- data
    >           ,String)      -- parser
    >
    > produceGLRParser :: (String, String)
    -> String
    -> (ActionTable, GotoTable)
    -> String
    -> Maybe String
    -> Maybe String
    -> (DebugMode, Options)
    -> Grammar String
    -> Directives
    -> (String, String)
    produceGLRParser (String
    base, String
    lib) String
    basename (ActionTable, GotoTable)
    tables String
    start Maybe String
    header Maybe String
    trailer (DebugMode
    debug,Options
    options) Grammar String
    g Directives
    pragmas
    >  = ( String -> String -> String
    content String
    base (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String
    ""
    >    , String -> String
    lib_content String
    lib
    >    )
    >  where
    >   (String
    imps, [String]
    lang_exts) = case GhcExts
    ghcExts_opt of
    >     UseGhcExts String
    is [String]
    os -> (String
    is, [String]
    os)
    >     GhcExts
    _                -> (String
    "", [])
    >
    >   defines :: [String]
    defines = [[String]] -> [String]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
    >      [ [ String
    "HAPPY_DEBUG" | DebugMode
    debug ]
    >      , [ String
    "HAPPY_GHC"   | UseGhcExts String
    _ [String]
    _ <- GhcExts -> [GhcExts]
    forall a. a -> [a]
    forall (m :: * -> *) a. Monad m => a -> m a
    return GhcExts
    ghcExts_opt ]
    >      ]
    >   (DecodeOption
    _,FilterOption
    _,GhcExts
    ghcExts_opt) = Options
    options

    Extract the module name from the given module declaration, if it exists.

    >   m_mod_decl :: Maybe (Int, String)
    m_mod_decl = ((Int, String) -> DebugMode)
    -> [(Int, String)] -> Maybe (Int, String)
    forall (t :: * -> *) a.
    Foldable t =>
    (a -> DebugMode) -> t a -> Maybe a
    find (Int, String) -> DebugMode
    forall {a}. (a, String) -> DebugMode
    isModKW ([(Int, String)] -> Maybe (Int, String))
    -> (String -> [(Int, String)]) -> String -> Maybe (Int, String)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [Int] -> [String] -> [(Int, String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] ([String] -> [(Int, String)])
    -> (String -> [String]) -> String -> [(Int, String)]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    forall a. [a] -> [[a]]
    tails (String -> [String]) -> (String -> String) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char
    ' 'Char -> String -> String
    forall a. a -> [a] -> [a]
    :) (String -> Maybe (Int, String))
    -> Maybe String -> Maybe (Int, String)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< Maybe String
    header
    >   isModKW :: (a, String) -> DebugMode
    isModKW (a
    _, Char
    c0:Char
    'm':Char
    'o':Char
    'd':Char
    'u':Char
    'l':Char
    'e':Char
    c1:String
    _) = DebugMode -> DebugMode
    not (Char -> DebugMode
    validIDChar Char
    c0 DebugMode -> DebugMode -> DebugMode
    || Char -> DebugMode
    validIDChar Char
    c1)
    >   isModKW (a, String)
    _                                    = DebugMode
    False
    >   validIDChar :: Char -> DebugMode
    validIDChar Char
    c      = Char -> DebugMode
    isAlphaNum Char
    c DebugMode -> DebugMode -> DebugMode
    || Char
    c Char -> String -> DebugMode
    forall a. Eq a => a -> [a] -> DebugMode
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
    `elem` String
    "_'"
    >   validModNameChar :: Char -> DebugMode
    validModNameChar Char
    c = Char -> DebugMode
    validIDChar Char
    c DebugMode -> DebugMode -> DebugMode
    || Char
    c Char -> Char -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == Char
    '.'
    >   data_mod :: String
    data_mod = String
    mod_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Data"
    >   mod_name :: String
    mod_name = case Maybe (Int, String)
    m_mod_decl of
    >     Just (Int
    _, String
    md) -> (Char -> DebugMode) -> String -> String
    forall a. (a -> DebugMode) -> [a] -> [a]
    takeWhile Char -> DebugMode
    validModNameChar ((Char -> DebugMode) -> String -> String
    forall a. (a -> DebugMode) -> [a] -> [a]
    dropWhile (DebugMode -> DebugMode
    not (DebugMode -> DebugMode)
    -> (Char -> DebugMode) -> Char -> DebugMode
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> DebugMode
    validModNameChar) (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    8 String
    md))

    Or use a default based upon the filename (original behaviour).

    >     Maybe (Int, String)
    Nothing      -> String -> String
    forall a. [a] -> [a]
    reverse (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> DebugMode) -> String -> String
    forall a. (a -> DebugMode) -> [a] -> [a]
    takeWhile (Char -> String -> DebugMode
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
    `notElem` String
    "\\/") (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    forall a. [a] -> [a]
    reverse String
    basename

    Remove the module declaration from the header so that the remainder of
    the header can be used in the generated code.

    >   header_sans_mod :: Maybe String
    header_sans_mod = (((Int, String) -> Maybe String)
     -> Maybe (Int, String) -> Maybe String)
    -> Maybe (Int, String)
    -> ((Int, String) -> Maybe String)
    -> Maybe String
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip (Maybe String
    -> ((Int, String) -> Maybe String)
    -> Maybe (Int, String)
    -> Maybe String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Maybe String
    header) Maybe (Int, String)
    m_mod_decl (((Int, String) -> Maybe String) -> Maybe String)
    -> ((Int, String) -> Maybe String) -> Maybe String
    forall a b. (a -> b) -> a -> b
    $ \ (Int
    mi, String
    _) -> do
    >       hdr <- Maybe String
    header

    Extract the string that comes before the module declaration...

    >       let (before, mod_decl) = splitAt mi hdr

    >       let isWhereKW (Char
    c0:Char
    'w':Char
    'h':Char
    'e':Char
    'r':Char
    'e':Char
    c1:String
    _) = DebugMode -> DebugMode
    not (Char -> DebugMode
    validIDChar Char
    c0 DebugMode -> DebugMode -> DebugMode
    || Char -> DebugMode
    validIDChar Char
    c1)
    >           isWhereKW String
    _ = DebugMode
    False
    >       let where_after = (String -> DebugMode) -> [String] -> [String]
    forall a. (a -> DebugMode) -> [a] -> [a]
    dropWhile (DebugMode -> DebugMode
    not (DebugMode -> DebugMode)
    -> (String -> DebugMode) -> String -> DebugMode
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> DebugMode
    isWhereKW) ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    forall a. [a] -> [[a]]
    tails (String -> [String]) -> (String -> String) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n") (String -> [String]) -> String -> [String]
    forall a b. (a -> b) -> a -> b
    $ String
    mod_decl
    >       let after = Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop Int
    6 (String -> String) -> ([String] -> String) -> [String] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat ([String] -> String)
    -> ([String] -> [String]) -> [String] -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> [String] -> [String]
    forall a. Int -> [a] -> [a]
    take Int
    1 ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ [String]
    where_after

    ...and combine it with the string that comes after the 'where' keyword.

    >       return $ before ++ "\n" ++ after

    >   (String -> String
    sem_def, SemInfo
    sem_info) = Options
    -> Grammar String -> Directives -> (String -> String, SemInfo)
    mkGSemType Options
    options Grammar String
    g Directives
    pragmas
    >   table_text :: String -> String
    table_text = (ActionTable, GotoTable)
    -> SemInfo -> GhcExts -> Grammar String -> String -> String
    mkTbls (ActionTable, GotoTable)
    tables SemInfo
    sem_info (GhcExts
    ghcExts_opt) Grammar String
    g

    >   header_parts :: Maybe ([String], [String])
    header_parts = (String -> ([String], [String]))
    -> Maybe String -> Maybe ([String], [String])
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((String -> DebugMode) -> [String] -> ([String], [String])
    forall a. (a -> DebugMode) -> [a] -> ([a], [a])
    span (\String
    x -> Int -> String -> String
    forall a. Int -> [a] -> [a]
    take Int
    3 ((Char -> DebugMode) -> String -> String
    forall a. (a -> DebugMode) -> [a] -> [a]
    dropWhile Char -> DebugMode
    isSpace String
    x) String -> String -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == String
    "{-#")
    >                                  ([String] -> ([String], [String]))
    -> (String -> [String]) -> String -> ([String], [String])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines)
    >                       Maybe String
    header_sans_mod
    >       -- Split off initial options, if they are present
    >       -- Assume these options ONLY related to code which is in
    >       --   parser tail or in sem. rules

    >   content :: String -> String -> String
    content String
    base_defs
    >    = String -> String -> String
    str ([String] -> String
    unlines
    >            [ String
    "{-# LANGUAGE " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " #-}\n" | String
    l <- [String]
    lang_exts ])
    >    (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str ([String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ [String]
    -> (([String], [String]) -> [String])
    -> Maybe ([String], [String])
    -> [String]
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe [] ([String], [String]) -> [String]
    forall a b. (a, b) -> a
    fst Maybe ([String], [String])
    header_parts) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >    (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >    (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String -> String
    comment String
    "data")                      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >    (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    "module " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    data_mod String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " where")   (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl

    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe String -> String -> String
    maybestr ((([String], [String]) -> String)
    -> Maybe ([String], [String]) -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ([String] -> String
    unlines([String] -> String)
    -> (([String], [String]) -> [String])
    -> ([String], [String])
    -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .([String], [String]) -> [String]
    forall a b. (a, b) -> b
    snd) Maybe ([String], [String])
    header_parts) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    base_defs (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl

    >    (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . let count_nls :: String -> Int
    count_nls     = String -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (String -> Int) -> (String -> String) -> String -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> DebugMode) -> String -> String
    forall a. (a -> DebugMode) -> [a] -> [a]
    filter (Char -> Char -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    ==Char
    '\n')
    >          pre_trailer :: Int
    pre_trailer   = Int -> (String -> Int) -> Maybe String -> Int
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Int
    0 String -> Int
    count_nls Maybe String
    header_sans_mod -- check fmt below
    >                        Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + String -> Int
    count_nls String
    base_defs
    >                        Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    10                           -- for the other stuff
    >          post_trailer :: Int
    post_trailer  = Int
    pre_trailer Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int -> (String -> Int) -> Maybe String -> Int
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Int
    0 String -> Int
    count_nls Maybe String
    trailer Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    4
    >      in
    >         String -> String -> String
    str (String
    "{-# LINE " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    pre_trailer String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " "
    >                          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show (String
    basename String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Data.hs") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "#-}")
    >               -- This should show a location in basename.y -- but Happy
    >               -- doesn't pass this info through. But we still avoid being
    >               -- told a location in GLR_Base!
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Maybe String -> String -> String
    maybestr Maybe String
    trailer
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    "{-# LINE " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    post_trailer String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " "
    >                          String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. Show a => a -> String
    show (String
    basename String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "Data.hs") String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "#-}")
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl

    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Grammar String -> Directives -> String -> String
    mkGSymbols Grammar String
    g Directives
    pragmas (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    sem_def                     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> MonadInfo -> SemInfo -> String -> String
    mkSemObjects  Options
    options (Directives -> MonadInfo
    monad_sub Directives
    pragmas) SemInfo
    sem_info  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Options -> MonadInfo -> SemInfo -> String -> String
    mkDecodeUtils Options
    options (Directives -> MonadInfo
    monad_sub Directives
    pragmas) SemInfo
    sem_info  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    user_def_token_code (Directives -> String
    token_type Directives
    pragmas)            (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    table_text

    >   lib_content :: String -> String
    lib_content String
    lib_text
    >    = let ([String]
    pre,String
    _drop_me : [String]
    post) = (String -> DebugMode) -> [String] -> ([String], [String])
    forall a. (a -> DebugMode) -> [a] -> ([a], [a])
    break (String -> String -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == String
    "fakeimport DATA") ([String] -> ([String], [String]))
    -> [String] -> ([String], [String])
    forall a b. (a -> b) -> a -> b
    $ String -> [String]
    lines String
    lib_text
    >      in
    >      [String] -> String
    unlines [ String
    "{-# LANGUAGE CPP #-}"
    >              , [String] -> String
    unlines
    >                  [ String
    "#define " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    d String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " 1" | String
    d <- [String]
    defines ]
    >              , [String] -> String
    unlines
    >                  [ String
    "{-# LANGUAGE " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " #-}\n" | String
    l <- [String]
    lang_exts ]
    >              , String -> String
    comment String
    "driver" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\n"
    >              , String
    "module " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    mod_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "("
    >              , case Directives -> Maybe (String, String)
    lexer Directives
    pragmas of
    >                  Maybe (String, String)
    Nothing     -> String
    ""
    >                  Just (String
    lf,String
    _) -> String
    "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lf String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ","
    >              , String
    "  " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    start
    >              , String
    ""
    >              , [String] -> String
    unlines [String]
    pre
    >              , String
    imps
    >              , String
    "import " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    data_mod
    >              , String
    start String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " = glr_parse "
    >              , String
    "use_filtering = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ DebugMode -> String
    forall a. Show a => a -> String
    show DebugMode
    use_filtering
    >              , String
    "top_symbol = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    prefix String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    start_prod
    >              , [String] -> String
    unlines [String]
    post
    >              ]
    >   start_prod :: String
    start_prod = Grammar String -> Array Name String
    forall eliminator. Grammar eliminator -> Array Name String
    token_names Grammar String
    g Array Name String -> Name -> String
    forall i e. Ix i => Array i e -> i -> e
    ! (let (String
    _,Name
    _,Name
    i,DebugMode
    _) = [(String, Name, Name, DebugMode)]
    -> (String, Name, Name, DebugMode)
    forall a. HasCallStack => [a] -> a
    head ([(String, Name, Name, DebugMode)]
     -> (String, Name, Name, DebugMode))
    -> [(String, Name, Name, DebugMode)]
    -> (String, Name, Name, DebugMode)
    forall a b. (a -> b) -> a -> b
    $ Grammar String -> [(String, Name, Name, DebugMode)]
    forall eliminator.
    Grammar eliminator -> [(String, Name, Name, DebugMode)]
    starts Grammar String
    g in Name
    i)
    >   use_filtering :: DebugMode
    use_filtering = case Options
    options of (DecodeOption
    _, FilterOption
    UseFiltering,GhcExts
    _) -> DebugMode
    True
    >                                   Options
    _                   -> DebugMode
    False

    > comment :: String -> String
    > comment :: String -> String
    comment String
    which
    >  = String
    "-- parser (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    which String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") produced by Happy (GLR) Version " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
    >       Version -> String
    showVersion Version
    version

    > user_def_token_code :: String -> String -> String
    > user_def_token_code :: String -> String -> String
    user_def_token_code String
    tokenType
    >  = String -> String -> String
    str String
    "type UserDefTok = " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    tokenType                     (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "instance TreeDecode " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    brack String
    tokenType (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " where"  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "  decode_b f (Branch (SemTok t) []) = [happy_return t]" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "instance LabelDecode " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    brack String
    tokenType (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " where" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "  unpack (SemTok t) = t"                                (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl

    %-----------------------------------------------------------------------------
    Formats the tables as code.

    > mkTbls :: (ActionTable        -- Action table from Happy
    >           ,GotoTable)         -- Goto table from Happy
    >        -> SemInfo             -- info about production mapping
    >        -> GhcExts             -- Use unboxed values?
    >        -> Grammar String      -- Happy Grammar
    >        -> ShowS
    >
    > mkTbls :: (ActionTable, GotoTable)
    -> SemInfo -> GhcExts -> Grammar String -> String -> String
    mkTbls (ActionTable
    action,GotoTable
    goto) SemInfo
    sem_info GhcExts
    exts Grammar String
    g
    >  = let gsMap :: [(Name, String)]
    gsMap = Grammar String -> [(Name, String)]
    mkGSymMap Grammar String
    g
    >        semfn_map :: Array Name String
    semfn_map = SemInfo -> Array Name String
    mk_semfn_map SemInfo
    sem_info
    >    in
    >      ActionTable
    -> [(Name, String)]
    -> (Name -> String)
    -> GhcExts
    -> Grammar String
    -> String
    -> String
    writeActionTbl ActionTable
    action [(Name, String)]
    gsMap (Array Name String
    semfn_map Array Name String -> Name -> String
    forall i e. Ix i => Array i e -> i -> e
    !) GhcExts
    exts Grammar String
    g
    >    (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . GotoTable -> [(Name, String)] -> GhcExts -> String -> String
    writeGotoTbl   GotoTable
    goto   [(Name, String)]
    gsMap GhcExts
    exts

    %-----------------------------------------------------------------------------
    Create a mapping of Happy grammar symbol integers to the data representation
    that will be used for them in the GLR parser.

    > mkGSymMap :: Grammar String -> [(Name,String)]
    > mkGSymMap :: Grammar String -> [(Name, String)]
    mkGSymMap Grammar String
    g
    >  =    [ -- (errorTok, prefix ++ "Error")
    >       ]
    >    [(Name, String)] -> [(Name, String)] -> [(Name, String)]
    forall a. [a] -> [a] -> [a]
    ++ [ (Name
    i, String
    prefix String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Grammar String -> Array Name String
    forall eliminator. Grammar eliminator -> Array Name String
    token_names Grammar String
    g) Array Name String -> Name -> String
    forall i e. Ix i => Array i e -> i -> e
    ! Name
    i)
    >       | Name
    i <- Grammar String -> [Name]
    user_non_terminals Grammar String
    g ]   -- Non-terminals
    >    [(Name, String)] -> [(Name, String)] -> [(Name, String)]
    forall a. [a] -> [a] -> [a]
    ++ [ (Name
    i, String
    "HappyTok (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ TokenSpec -> String
    mkMatch TokenSpec
    tok String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
    >       | (Name
    i,TokenSpec
    tok) <- Grammar String -> [(Name, TokenSpec)]
    forall eliminator. Grammar eliminator -> [(Name, TokenSpec)]
    token_specs Grammar String
    g ]    -- Tokens (terminals)
    >    [(Name, String)] -> [(Name, String)] -> [(Name, String)]
    forall a. [a] -> [a] -> [a]
    ++ [(Grammar String -> Name
    forall eliminator. Grammar eliminator -> Name
    eof_term Grammar String
    g,String
    "HappyEOF")]       -- EOF symbol (internal terminal)
    >  where
    >   mkMatch :: TokenSpec -> String
    mkMatch TokenSpec
    tok = case TokenSpec
    tok of
    >                   TokenFixed String
    t -> String
    t
    >                   TokenWithValue ExpressionWithHole
    e -> ExpressionWithHole -> String -> String
    substExpressionWithHole ExpressionWithHole
    e String
    "_"

    > toGSym :: [(Name, String)] -> Name -> String
    > toGSym :: [(Name, String)] -> Name -> String
    toGSym [(Name, String)]
    gsMap Name
    i
    >  = case Name -> [(Name, String)] -> Maybe String
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Name
    i [(Name, String)]
    gsMap of
    >     Maybe String
    Nothing -> String -> String
    forall a. HasCallStack => String -> a
    error (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String
    "No representation for symbol " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Name -> String
    forall a. Show a => a -> String
    show Name
    i
    >     Just String
    g  -> String
    g

    %-----------------------------------------------------------------------------
    Take the ActionTable from Happy and turn it into a String representing a
    function that can be included as the action table in the GLR parser.
    It also shares identical reduction values as CAFs

    > writeActionTbl
    >  :: ActionTable -> [(Name,String)] -> (Name->String)
    >                                       -> GhcExts -> Grammar String -> ShowS
    > writeActionTbl :: ActionTable
    -> [(Name, String)]
    -> (Name -> String)
    -> GhcExts
    -> Grammar String
    -> String
    -> String
    writeActionTbl ActionTable
    acTbl [(Name, String)]
    gsMap Name -> String
    semfn_map GhcExts
    exts Grammar String
    g
    >  = String -> [String -> String] -> String -> String
    interleave String
    "\n"
    >  ([String -> String] -> String -> String)
    -> [String -> String] -> String -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> String -> String) -> [String] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String -> String
    str
    >  ([String] -> [String -> String]) -> [String] -> [String -> String]
    forall a b. (a -> b) -> a -> b
    $ [String]
    mkLines [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    errorLine] [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String]
    mkReductions
    >  where
    >   name :: String
    name      = String
    "action"
    >   mkLines :: [String]
    mkLines   = ((Int, Array Name LRAction) -> [String])
    -> [(Int, Array Name LRAction)] -> [String]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((Int, Array Name LRAction) -> [String]
    mkState) (ActionTable -> [(Int, Array Name LRAction)]
    forall i e. Ix i => Array i e -> [(i, e)]
    assocs ActionTable
    acTbl)
    >   errorLine :: String
    errorLine = String
    name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " _ _ = Error"
    >   mkState :: (Int, Array Name LRAction) -> [String]
    mkState (Int
    i,Array Name LRAction
    arr)
    >    = (String -> DebugMode) -> [String] -> [String]
    forall a. (a -> DebugMode) -> [a] -> [a]
    filter (String -> String -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    /=String
    "") ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ ((Name, LRAction) -> String) -> [(Name, LRAction)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> (Name, LRAction) -> String
    mkLine Int
    i) (Array Name LRAction -> [(Name, LRAction)]
    forall i e. Ix i => Array i e -> [(i, e)]
    assocs Array Name LRAction
    arr)
    >
    >   mkLine :: Int -> (Name, LRAction) -> String
    mkLine Int
    state (Name
    symInt,LRAction
    action)
    >    | Name
    symInt Name -> Name -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == Name
    errorTok       -- skip error productions
    >    = String
    ""                       -- NB see ProduceCode's handling of these
    >    | Name
    symInt Name -> Name -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == Name
    catchTok       -- skip error productions
    >    = String
    ""                       -- NB see ProduceCode's handling of these
    >    | DebugMode
    otherwise
    >    = case LRAction
    action of
    >       LRAction
    LR'Fail     -> String
    ""
    >       LRAction
    LR'MustFail -> String
    ""
    >       LRAction
    _           -> [String] -> String
    unwords [ String
    startLine , LRAction -> String
    mkAct LRAction
    action ]
    >    where
    >     startLine :: String
    startLine
    >      = [String] -> String
    unwords [ String
    name , GhcExts -> Int -> String
    show_st GhcExts
    exts Int
    state, String
    "(" , String
    getTok , String
    ") =" ]
    >     getTok :: String
    getTok = [(Name, String)] -> Name -> String
    toGSym [(Name, String)]
    gsMap Name
    symInt
    >   mkAct :: LRAction -> String
    mkAct LRAction
    act
    >    = case LRAction
    act of
    >       LR'Shift Int
    newSt Priority
    _ -> String
    "Shift " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    newSt String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " []"
    >       LR'Reduce Int
    r    Priority
    _ -> String
    "Reduce " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "[" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    mkRed Int
    r String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "]"
    >       LRAction
    LR'Accept        -> String
    "Accept"
    >       LR'Multiple [LRAction]
    rs (LR'Shift Int
    st Priority
    _)
    >                        -> String
    "Shift " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    st String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [LRAction] -> String
    mkReds [LRAction]
    rs
    >       LR'Multiple [LRAction]
    rs r :: LRAction
    r@(LR'Reduce{})
    >                        -> String
    "Reduce " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [LRAction] -> String
    mkReds (LRAction
    rLRAction -> [LRAction] -> [LRAction]
    forall a. a -> [a] -> [a]
    :[LRAction]
    rs)
    >       LRAction
    _ -> String -> String
    forall a. HasCallStack => String -> a
    error String
    "writeActionTbl/mkAct: Unhandled case"
    >    where
    >     mkReds :: [LRAction] -> String
    mkReds [LRAction]
    rs = String
    "[" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    forall a. HasCallStack => [a] -> [a]
    tail ([String] -> String
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [ String
    "," String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    mkRed Int
    r | LR'Reduce Int
    r Priority
    _ <- [LRAction]
    rs ]) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "]"

    >   mkRed :: a -> String
    mkRed a
    r = String
    "red_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ a -> String
    forall a. Show a => a -> String
    show a
    r
    >   mkReductions :: [String]
    mkReductions = [ (Name, Production String) -> String
    forall {eliminator}. (Name, Production eliminator) -> String
    mkRedDefn (Name, Production String)
    p
    >                  | p :: (Name, Production String)
    p@(Name
    _, Production Name
    n [Name]
    _ (String, [Int])
    _ Priority
    _) <- [Name] -> [Production String] -> [(Name, Production String)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int -> Name
    MkName Int
    0 ..] ([Production String] -> [(Name, Production String)])
    -> [Production String] -> [(Name, Production String)]
    forall a b. (a -> b) -> a -> b
    $ Grammar String -> [Production String]
    forall eliminator. Grammar eliminator -> [Production eliminator]
    productions Grammar String
    g
    >                  , Name
    n Name -> [Name] -> DebugMode
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
    `notElem` Grammar String -> [Name]
    start_productions Grammar String
    g ]

    >   mkRedDefn :: (Name, Production eliminator) -> String
    mkRedDefn (Name
    r, Production Name
    lhs_id [Name]
    rhs_ids (eliminator
    _code,[Int]
    _dollar_vars) Priority
    _)
    >    = Name -> String
    forall a. Show a => a -> String
    mkRed Name
    r String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " = ("String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    lhs String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "," String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    arity String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " :: Int," String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    sem String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    ")"
    >      where
    >         lhs :: String
    lhs = [(Name, String)] -> Name -> String
    toGSym [(Name, String)]
    gsMap (Name -> String) -> Name -> String
    forall a b. (a -> b) -> a -> b
    $ Name
    lhs_id
    >         arity :: Int
    arity = [Name] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Name]
    rhs_ids
    >         sem :: String
    sem = Name -> String
    semfn_map Name
    r

    %-----------------------------------------------------------------------------
    Do the same with the Happy goto table.

    > writeGotoTbl :: GotoTable -> [(Name,String)] -> GhcExts -> ShowS
    > writeGotoTbl :: GotoTable -> [(Name, String)] -> GhcExts -> String -> String
    writeGotoTbl GotoTable
    goTbl [(Name, String)]
    gsMap GhcExts
    exts
    >  = String -> [String -> String] -> String -> String
    interleave String
    "\n" ((String -> String -> String) -> [String] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String -> String
    str ([String] -> [String -> String]) -> [String] -> [String -> String]
    forall a b. (a -> b) -> a -> b
    $ (String -> DebugMode) -> [String] -> [String]
    forall a. (a -> DebugMode) -> [a] -> [a]
    filter (DebugMode -> DebugMode
    not(DebugMode -> DebugMode)
    -> (String -> DebugMode) -> String -> DebugMode
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    .String -> DebugMode
    forall a. [a] -> DebugMode
    forall (t :: * -> *) a. Foldable t => t a -> DebugMode
    null) [String]
    mkLines)
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    errorLine (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >  where
    >   name :: String
    name    = String
    "goto"
    >   errorLine :: String
    errorLine = String
    "goto _ _ = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ GhcExts -> Int -> String
    show_st GhcExts
    exts (Int -> Int
    forall a. Num a => a -> a
    negate Int
    1)
    >   mkLines :: [String]
    mkLines = ((Int, Array Name Goto) -> String)
    -> [(Int, Array Name Goto)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, Array Name Goto) -> String
    mkState (GotoTable -> [(Int, Array Name Goto)]
    forall i e. Ix i => Array i e -> [(i, e)]
    assocs GotoTable
    goTbl)
    >
    >   mkState :: (Int, Array Name Goto) -> String
    mkState (Int
    i,Array Name Goto
    arr)
    >    = [String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> DebugMode) -> [String] -> [String]
    forall a. (a -> DebugMode) -> [a] -> [a]
    filter (String -> String -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    /=String
    "") ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ ((Name, Goto) -> String) -> [(Name, Goto)] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> (Name, Goto) -> String
    mkLine Int
    i) (Array Name Goto -> [(Name, Goto)]
    forall i e. Ix i => Array i e -> [(i, e)]
    assocs Array Name Goto
    arr)
    >
    >   mkLine :: Int -> (Name, Goto) -> String
    mkLine Int
    state (Name
    ntInt,Goto
    goto)
    >    = case Goto
    goto of
    >       Goto
    NoGoto  -> String
    ""
    >       Goto Int
    st -> [String] -> String
    unwords [ String
    startLine , GhcExts -> Int -> String
    show_st GhcExts
    exts Int
    st ]
    >    where
    >     startLine :: String
    startLine
    >      = [String] -> String
    unwords [ String
    name , GhcExts -> Int -> String
    show_st GhcExts
    exts Int
    state, String
    getGSym , String
    "=" ]
    >     getGSym :: String
    getGSym = [(Name, String)] -> Name -> String
    toGSym [(Name, String)]
    gsMap Name
    ntInt

    %-----------------------------------------------------------------------------
    Create the 'GSymbol' ADT for the symbols in the grammar

    > mkGSymbols :: Grammar String -> Directives -> ShowS
    > mkGSymbols :: Grammar String -> Directives -> String -> String
    mkGSymbols Grammar String
    g Directives
    pragmas
    >  = String -> String -> String
    str String
    dec
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    eof
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    tok
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String -> String] -> String -> String
    interleave String
    "\n" [ String -> String -> String
    str String
    " | " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    prefix (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    sym (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " "
    >                    | String
    sym <- [String]
    syms ]
    >  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    der
    >    -- ++ eq_inst
    >    -- ++ ord_inst
    >  where
    >   dec :: String
    dec  = String
    "data GSymbol"
    >   eof :: String
    eof  = String
    " = HappyEOF"
    >   tok :: String
    tok  = String
    " | HappyTok {-!Int-} (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Directives -> String
    token_type Directives
    pragmas String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")"
    >   der :: String
    der  = String
    "   deriving (Show,Eq,Ord)"
    >   syms :: [String]
    syms = [ Grammar String -> Array Name String
    forall eliminator. Grammar eliminator -> Array Name String
    token_names Grammar String
    g Array Name String -> Name -> String
    forall i e. Ix i => Array i e -> i -> e
    ! Name
    i | Name
    i <- Grammar String -> [Name]
    user_non_terminals Grammar String
    g ]

    NOTES:
    Was considering avoiding use of Eq/Ord over tokens, but this then means
    hand-coding the Eq/Ord classes since we're over-riding the usual order
    except in one case.

    maybe possible to form a union and do some juggling, but this isn't that
    easy, eg input type of "action".

    plus, issues about how token info gets into TreeDecode sem values - which
    might be tricky to arrange.
    <>   eq_inst = "instance Eq GSymbol where"
    <>           : "  HappyTok i _ == HappyTok j _ = i == j"
    <>           : [ "  i == j = fromEnum i == fromEnum j"

    %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    Semantic actions on rules.

    These are stored in a union type "GSem", and the semantic values are held
    on the branches created at the appropriate reduction.

    "GSem" type has one constructor per distinct type of semantic action and
    pattern of child usage.

    %-----------------------------------------------------------------------------
    Creating a type for storing semantic rules
     - also collects information on code structure and constructor names, for
       use in later stages.

    > type SemInfo
    >  = [(String, String, [Int], [((Int, Int), ([(Int, TokenSpec)], String), [Int])])]

    > mkGSemType :: Options -> Grammar String -> Directives -> (ShowS, SemInfo)
    > mkGSemType :: Options
    -> Grammar String -> Directives -> (String -> String, SemInfo)
    mkGSemType (DecodeOption
    TreeDecode,FilterOption
    _,GhcExts
    _) Grammar String
    g Directives
    pragmas
    >  = (String -> String
    def, ((String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
     -> (String, String, [Int],
         [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> [(String,
         (String, String, [Int],
          [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    -> SemInfo
    forall a b. (a -> b) -> [a] -> [b]
    map (String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> (String, String, [Int],
        [((Int, Int), ([(Int, TokenSpec)], String), [Int])])
    forall a b. (a, b) -> b
    snd [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms)
    >  where
    >   mtype :: String -> String
    mtype String
    s = case Directives -> MonadInfo
    monad_sub Directives
    pragmas of
    >               MonadInfo
    Nothing       -> String
    s
    >               Just (String
    ty,String
    _,String
    _) -> String
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Char
    ' ' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String -> String -> String
    brack String
    s String
    ""

    >   def :: String -> String
    def  = String -> String -> String
    str String
    "data GSem" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " = NoSem"  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " | SemTok (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++  Directives -> String
    token_type Directives
    pragmas String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")") (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String -> String] -> String -> String
    interleave String
    "\n" [ String -> String -> String
    str String
    " | " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    sym (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " "
    >                          | String
    sym <- ((String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
     -> String)
    -> [(String,
         (String, String, [Int],
          [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> String
    forall a b. (a, b) -> a
    fst [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms ]
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "instance Show GSem where" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String -> String] -> String -> String
    interleave String
    "\n" [ String -> String -> String
    str String
    "  show " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    c (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "{} = " (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String -> String
    forall a. Show a => a -> String
    show String
    c)
    >                          | (String
    _,String
    c,[Int]
    _,[((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    _) <- ((String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
     -> (String, String, [Int],
         [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> [(String,
         (String, String, [Int],
          [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    -> SemInfo
    forall a b. (a -> b) -> [a] -> [b]
    map (String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> (String, String, [Int],
        [((Int, Int), ([(Int, TokenSpec)], String), [Int])])
    forall a b. (a, b) -> b
    snd [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms ]

    >   syms :: [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms = [ (String
    c_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")", (String
    rty, String
    c_name, [Int]
    mask, [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info))
    >          | (Int
    i,this :: ([Int], [String], String)
    this@([Int]
    mask,[String]
    args,String
    rty)) <- [Int]
    -> [([Int], [String], String)]
    -> [(Int, ([Int], [String], String))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] ([([Int], [String], String)] -> [([Int], [String], String)]
    forall a. Eq a => [a] -> [a]
    nub ([([Int], [String], String)] -> [([Int], [String], String)])
    -> [([Int], [String], String)] -> [([Int], [String], String)]
    forall a b. (a -> b) -> a -> b
    $ ((([Int], [String], String), (Int, ([(Int, TokenSpec)], String)))
     -> ([Int], [String], String))
    -> [(([Int], [String], String),
         (Int, ([(Int, TokenSpec)], String)))]
    -> [([Int], [String], String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (([Int], [String], String), (Int, ([(Int, TokenSpec)], String)))
    -> ([Int], [String], String)
    forall a b. (a, b) -> a
    fst [(([Int], [String], String), (Int, ([(Int, TokenSpec)], String)))]
    info)
    >                                               -- find unique types (plus mask)
    >          , let c_name :: String
    c_name = String
    "Sem_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i
    >          , let mrty :: String
    mrty = String -> String
    mtype String
    rty
    >          , let ty :: String
    ty = (String -> String -> String) -> String -> [String] -> String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\String
    l String
    r -> String
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " -> " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    r) String
    mrty [String]
    args

    >          , let code_info :: [(Int, ([(Int, TokenSpec)], String))]
    code_info = [ (Int, ([(Int, TokenSpec)], String))
    j_code | (([Int], [String], String)
    that, (Int, ([(Int, TokenSpec)], String))
    j_code) <- [(([Int], [String], String), (Int, ([(Int, TokenSpec)], String)))]
    info, ([Int], [String], String)
    this ([Int], [String], String) -> ([Int], [String], String) -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == ([Int], [String], String)
    that ]
    >          , let prod_info :: [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info = [ ((Int
    i,Int
    k), ([(Int, TokenSpec)], String)
    code, [Int]
    js)
    >                            | (Int
    k,([(Int, TokenSpec)], String)
    code) <- [Int]
    -> [([(Int, TokenSpec)], String)]
    -> [(Int, ([(Int, TokenSpec)], String))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] ([([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)]
    forall a. Eq a => [a] -> [a]
    nub ([([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)])
    -> [([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)]
    forall a b. (a -> b) -> a -> b
    $ ((Int, ([(Int, TokenSpec)], String))
     -> ([(Int, TokenSpec)], String))
    -> [(Int, ([(Int, TokenSpec)], String))]
    -> [([(Int, TokenSpec)], String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, ([(Int, TokenSpec)], String)) -> ([(Int, TokenSpec)], String)
    forall a b. (a, b) -> b
    snd [(Int, ([(Int, TokenSpec)], String))]
    code_info)
    >                            , let js :: [Int]
    js = [ Int
    j | (Int
    j,([(Int, TokenSpec)], String)
    code2) <- [(Int, ([(Int, TokenSpec)], String))]
    code_info
    >                                           , ([(Int, TokenSpec)], String)
    code ([(Int, TokenSpec)], String)
    -> ([(Int, TokenSpec)], String) -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == ([(Int, TokenSpec)], String)
    code2 ]
    >                            ]
    >            -- collect specific info about productions with this type
    >          ]

    >   info :: [(([Int], [String], String), (Int, ([(Int, TokenSpec)], String)))]
    info = [ (([Int]
    var_mask, [String]
    args, String
    i_ty), (Int
    j,([(Int, TokenSpec)]
    ts_pats,String
    code)))
    >          | Name
    i <- Grammar String -> [Name]
    user_non_terminals Grammar String
    g
    >          , let i_ty :: String
    i_ty = Name -> String
    typeOf Name
    i
    >          , Int
    j <- Grammar String -> Name -> [Int]
    forall eliminator. Grammar eliminator -> Name -> [Int]
    lookupProdsOfName Grammar String
    g Name
    i  -- all prod numbers
    >          , let Production Name
    _ [Name]
    ts (String
    raw_code,[Int]
    dollar_vars) Priority
    _ = Grammar String -> Int -> Production String
    forall eliminator.
    Grammar eliminator -> Int -> Production eliminator
    lookupProdNo Grammar String
    g Int
    j
    >          , let var_mask :: [Int]
    var_mask = (Int -> Int) -> [Int] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    x -> Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) [Int]
    vars_used
    >                           where vars_used :: [Int]
    vars_used = [Int] -> [Int]
    forall a. Ord a => [a] -> [a]
    sort ([Int] -> [Int]) -> [Int] -> [Int]
    forall a b. (a -> b) -> a -> b
    $ [Int] -> [Int]
    forall a. Eq a => [a] -> [a]
    nub [Int]
    dollar_vars
    >          , let args :: [String]
    args = [ Name -> String
    typeOf (Name -> String) -> Name -> String
    forall a b. (a -> b) -> a -> b
    $ [Name]
    ts [Name] -> Int -> Name
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    v | Int
    v <- [Int]
    var_mask ]
    >          , let code :: String
    code | (Char -> DebugMode) -> String -> DebugMode
    forall (t :: * -> *) a.
    Foldable t =>
    (a -> DebugMode) -> t a -> DebugMode
    all Char -> DebugMode
    isSpace String
    raw_code = String
    "()"
    >                     | DebugMode
    otherwise            = String
    raw_code
    >          , let ts_pats :: [(Int, TokenSpec)]
    ts_pats = [ (Int
    kInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1,TokenSpec
    c) | Int
    k <- [Int]
    var_mask
    >                                    , (Name
    t,TokenSpec
    c) <- Grammar String -> [(Name, TokenSpec)]
    forall eliminator. Grammar eliminator -> [(Name, TokenSpec)]
    token_specs Grammar String
    g
    >                                    , [Name]
    ts [Name] -> Int -> Name
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    k Name -> Name -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == Name
    t ]
    >          ]

    >   typeOf :: Name -> String
    typeOf Name
    n | Name
    n Name -> [Name] -> DebugMode
    forall a. Eq a => a -> [a] -> DebugMode
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> DebugMode
    `elem` Grammar String -> [Name]
    forall eliminator. Grammar eliminator -> [Name]
    terminals Grammar String
    g = Directives -> String
    token_type Directives
    pragmas
    >            | DebugMode
    otherwise            = case Grammar String -> Array Name (Maybe String)
    forall eliminator. Grammar eliminator -> Array Name (Maybe String)
    types Grammar String
    g Array Name (Maybe String) -> Name -> Maybe String
    forall i e. Ix i => Array i e -> i -> e
    ! Name
    n of
    >                                       Maybe String
    Nothing -> String
    "()"         -- default
    >                                       Just String
    t  -> String
    t

    > -- NB expects that such labels are Showable
    > mkGSemType (DecodeOption
    LabelDecode,FilterOption
    _,GhcExts
    _) Grammar String
    g Directives
    pragmas
    >  = (String -> String
    def, ((String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
     -> (String, String, [Int],
         [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> [(String,
         (String, String, [Int],
          [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    -> SemInfo
    forall a b. (a -> b) -> [a] -> [b]
    map (String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> (String, String, [Int],
        [((Int, Int), ([(Int, TokenSpec)], String), [Int])])
    forall a b. (a, b) -> b
    snd [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms)
    >  where
    >   def :: String -> String
    def = String -> String -> String
    str String
    "data GSem" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " = NoSem"  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " | SemTok (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++  Directives -> String
    token_type Directives
    pragmas String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")")
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String -> String] -> String -> String
    interleave String
    "\n" [ String -> String -> String
    str String
    " | "  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    sym (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " "
    >                         | String
    sym <- ((String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
     -> String)
    -> [(String,
         (String, String, [Int],
          [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String,
     (String, String, [Int],
      [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))
    -> String
    forall a b. (a, b) -> a
    fst [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms ]
    >       (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    "   deriving (Show)" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl

    >   syms :: [(String,
      (String, String, [Int],
       [((Int, Int), ([(Int, TokenSpec)], String), [Int])]))]
    syms = [ (String
    c_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")", (String
    ty, String
    c_name, [Int]
    mask, [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info))
    >          | (Int
    i,this :: ([Int], String)
    this@([Int]
    mask,String
    ty)) <- [Int] -> [([Int], String)] -> [(Int, ([Int], String))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] ([([Int], String)] -> [([Int], String)]
    forall a. Eq a => [a] -> [a]
    nub ([([Int], String)] -> [([Int], String)])
    -> [([Int], String)] -> [([Int], String)]
    forall a b. (a -> b) -> a -> b
    $ ((([Int], String), (Int, ([(Int, TokenSpec)], String)))
     -> ([Int], String))
    -> [(([Int], String), (Int, ([(Int, TokenSpec)], String)))]
    -> [([Int], String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (([Int], String), (Int, ([(Int, TokenSpec)], String)))
    -> ([Int], String)
    forall a b. (a, b) -> a
    fst [(([Int], String), (Int, ([(Int, TokenSpec)], String)))]
    info)
    >                                               -- find unique types
    >          , let c_name :: String
    c_name = String
    "Sem_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i
    >          , let code_info :: [(Int, ([(Int, TokenSpec)], String))]
    code_info = [ (Int, ([(Int, TokenSpec)], String))
    j_code | (([Int], String)
    that, (Int, ([(Int, TokenSpec)], String))
    j_code) <- [(([Int], String), (Int, ([(Int, TokenSpec)], String)))]
    info, ([Int], String)
    this ([Int], String) -> ([Int], String) -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == ([Int], String)
    that ]
    >          , let prod_info :: [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info = [ ((Int
    i,Int
    k), ([(Int, TokenSpec)], String)
    code, [Int]
    js)
    >                            | (Int
    k,([(Int, TokenSpec)], String)
    code) <- [Int]
    -> [([(Int, TokenSpec)], String)]
    -> [(Int, ([(Int, TokenSpec)], String))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    0..] ([([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)]
    forall a. Eq a => [a] -> [a]
    nub ([([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)])
    -> [([(Int, TokenSpec)], String)] -> [([(Int, TokenSpec)], String)]
    forall a b. (a -> b) -> a -> b
    $ ((Int, ([(Int, TokenSpec)], String))
     -> ([(Int, TokenSpec)], String))
    -> [(Int, ([(Int, TokenSpec)], String))]
    -> [([(Int, TokenSpec)], String)]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int, ([(Int, TokenSpec)], String)) -> ([(Int, TokenSpec)], String)
    forall a b. (a, b) -> b
    snd [(Int, ([(Int, TokenSpec)], String))]
    code_info)
    >                            , let js :: [Int]
    js = [ Int
    j | (Int
    j,([(Int, TokenSpec)], String)
    code2) <- [(Int, ([(Int, TokenSpec)], String))]
    code_info
    >                                           , ([(Int, TokenSpec)], String)
    code ([(Int, TokenSpec)], String)
    -> ([(Int, TokenSpec)], String) -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == ([(Int, TokenSpec)], String)
    code2 ]

    >                            ]
    >            -- collect specific info about productions with this type
    >          ]

    >   info :: [(([Int], String), (Int, ([(Int, TokenSpec)], String)))]
    info = [ (([Int]
    var_mask,String
    i_ty), (Int
    j,([(Int, TokenSpec)]
    ts_pats,String
    code)))
    >          | Name
    i <- Grammar String -> [Name]
    user_non_terminals Grammar String
    g
    >          , let i_ty :: String
    i_ty = Name -> String
    typeOf Name
    i
    >          , Int
    j <- Grammar String -> Name -> [Int]
    forall eliminator. Grammar eliminator -> Name -> [Int]
    lookupProdsOfName Grammar String
    g Name
    i  -- all prod numbers
    >          , let Production Name
    _ [Name]
    ts (String
    code,[Int]
    dollar_vars) Priority
    _ = Grammar String -> Int -> Production String
    forall eliminator.
    Grammar eliminator -> Int -> Production eliminator
    lookupProdNo Grammar String
    g Int
    j
    >          , let var_mask :: [Int]
    var_mask = (Int -> Int) -> [Int] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (\Int
    x -> Int
    x Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1) [Int]
    vars_used
    >                           where vars_used :: [Int]
    vars_used = [Int] -> [Int]
    forall a. Ord a => [a] -> [a]
    sort ([Int] -> [Int]) -> [Int] -> [Int]
    forall a b. (a -> b) -> a -> b
    $ [Int] -> [Int]
    forall a. Eq a => [a] -> [a]
    nub [Int]
    dollar_vars
    >          , let ts_pats :: [(Int, TokenSpec)]
    ts_pats = [ (Int
    kInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1,TokenSpec
    c) | Int
    k <- [Int]
    var_mask
    >                                    , (Name
    t,TokenSpec
    c) <- Grammar String -> [(Name, TokenSpec)]
    forall eliminator. Grammar eliminator -> [(Name, TokenSpec)]
    token_specs Grammar String
    g
    >                                    , [Name]
    ts [Name] -> Int -> Name
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    k Name -> Name -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == Name
    t ]
    >          ]

    >   typeOf :: Name -> String
    typeOf Name
    n = case Grammar String -> Array Name (Maybe String)
    forall eliminator. Grammar eliminator -> Array Name (Maybe String)
    types Grammar String
    g Array Name (Maybe String) -> Name -> Maybe String
    forall i e. Ix i => Array i e -> i -> e
    ! Name
    n of
    >                Maybe String
    Nothing -> String
    "()"                -- default
    >                Just String
    t  -> String
    t

    %---------------------------------------
    Creates the appropriate semantic values.
     - for label-decode, these are the code, but abstracted over the child indices
     - for tree-decode, these are the code abstracted over the children's values

    > mkSemObjects :: Options -> MonadInfo -> SemInfo -> ShowS
    > mkSemObjects :: Options -> MonadInfo -> SemInfo -> String -> String
    mkSemObjects (DecodeOption
    LabelDecode,FilterOption
    filter_opt,GhcExts
    _) MonadInfo
    _ SemInfo
    sem_info
    >  = String -> [String -> String] -> String -> String
    interleave String
    "\n"
    >  ([String -> String] -> String -> String)
    -> [String -> String] -> String -> String
    forall a b. (a -> b) -> a -> b
    $ [   String -> String -> String
    str ((Int, Int) -> String
    mkSemFn_Name (Int, Int)
    ij)
    >      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " ns@(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    pat String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "happy_rest) = ")
    >      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " Branch (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    c_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    code String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")) ")
    >      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (FilterOption -> String
    nodes FilterOption
    filter_opt)
    >    | (String
    _ty, String
    c_name, [Int]
    mask, [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info) <- SemInfo
    sem_info
    >    , ((Int, Int)
    ij, ([(Int, TokenSpec)]
    pats,String
    code), [Int]
    _ps) <- [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info
    >    , let pat :: String
    pat | [Int] -> DebugMode
    forall a. [a] -> DebugMode
    forall (t :: * -> *) a. Foldable t => t a -> DebugMode
    null [Int]
    mask = String
    ""
    >              | DebugMode
    otherwise = (Int -> String) -> [Int] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\Int
    v -> [(Int, TokenSpec)] -> Int -> String
    mk_tok_binder [(Int, TokenSpec)]
    pats (Int
    vInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ":")
    >                                      [Int
    0..[Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    mask]

    >    , let nodes :: FilterOption -> String
    nodes FilterOption
    NoFiltering  = String
    "ns"
    >          nodes FilterOption
    UseFiltering = String
    "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Int -> String -> String) -> String -> [Int] -> String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\Int
    l -> Int -> String -> String
    mkHappyVar (Int
    lInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    showChar Char
    ':') String
    "[])" [Int]
    mask
    >    ]
    >    where
    >       mk_tok_binder :: [(Int, TokenSpec)] -> Int -> String
    mk_tok_binder [(Int, TokenSpec)]
    pats Int
    v
    >        = (String -> String) -> [(Int, TokenSpec)] -> Int -> String -> String
    mk_binder (\String
    s -> String
    "(_,_,HappyTok (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "))") [(Int, TokenSpec)]
    pats Int
    v String
    ""

    > mkSemObjects (DecodeOption
    TreeDecode,FilterOption
    filter_opt,GhcExts
    _) MonadInfo
    monad_info SemInfo
    sem_info
    >  = String -> [String -> String] -> String -> String
    interleave String
    "\n"
    >  ([String -> String] -> String -> String)
    -> [String -> String] -> String -> String
    forall a b. (a -> b) -> a -> b
    $ [   String -> String -> String
    str ((Int, Int) -> String
    mkSemFn_Name (Int, Int)
    ij)
    >      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " ns@(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    pat String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "happy_rest) = ")
    >      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " Branch (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    c_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    sem String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")) ")
    >      (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (FilterOption -> String
    nodes FilterOption
    filter_opt)
    >    | (String
    _ty, String
    c_name, [Int]
    mask, [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info) <- SemInfo
    sem_info
    >    , ((Int, Int)
    ij, ([(Int, TokenSpec)]
    pats,String
    code), [Int]
    _) <- [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    prod_info
    >    , let indent :: String -> String
    indent String
    c = String -> String
    forall a. HasCallStack => [a] -> [a]
    init (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> Char -> String
    forall a. Int -> a -> [a]
    replicate Int
    4 Char
    ' 'String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $ String -> [String]
    lines String
    c
    >    , let mcode :: String
    mcode = case MonadInfo
    monad_info of
    >                    MonadInfo
    Nothing -> String
    code
    >                    Just (String
    _,String
    _,String
    rtn) -> case String
    code of
    >                                        Char
    '%':String
    code' -> String
    "\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String
    indent String
    code'
    >                                        String
    _         -> String
    rtn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    code String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")"
    >    , let sem :: String
    sem = (Int -> String -> String) -> String -> [Int] -> String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\Int
    v String
    t -> [(Int, TokenSpec)] -> Int -> String -> String
    mk_lambda [(Int, TokenSpec)]
    pats (Int
    v Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + Int
    1) String
    "" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    t) String
    mcode [Int]
    mask
    >    , let pat :: String
    pat | [Int] -> DebugMode
    forall a. [a] -> DebugMode
    forall (t :: * -> *) a. Foldable t => t a -> DebugMode
    null [Int]
    mask = String
    ""
    >              | DebugMode
    otherwise = (Int -> String) -> [Int] -> String
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\Int
    v -> Int -> String -> String
    mkHappyVar (Int
    vInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) String
    ":")
    >                                      [Int
    0..[Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    mask]
    >    , let nodes :: FilterOption -> String
    nodes FilterOption
    NoFiltering  = String
    "ns"
    >          nodes FilterOption
    UseFiltering = String
    "(" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ (Int -> String -> String) -> String -> [Int] -> String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\Int
    l -> Int -> String -> String
    mkHappyVar (Int
    lInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +Int
    1) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    showChar Char
    ':') String
    "[])" [Int]
    mask
    >    ]

    > mk_lambda :: [(Int, TokenSpec)] -> Int -> String -> String
    > mk_lambda :: [(Int, TokenSpec)] -> Int -> String -> String
    mk_lambda [(Int, TokenSpec)]
    pats Int
    v
    >  = (\String
    s -> String
    "\\" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " -> ") (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String) -> [(Int, TokenSpec)] -> Int -> String -> String
    mk_binder String -> String
    forall a. a -> a
    id [(Int, TokenSpec)]
    pats Int
    v

    > mk_binder :: (String -> String) -> [(Int, TokenSpec)] -> Int -> String -> String
    > mk_binder :: (String -> String) -> [(Int, TokenSpec)] -> Int -> String -> String
    mk_binder String -> String
    wrap [(Int, TokenSpec)]
    pats Int
    v
    >  = case Int -> [(Int, TokenSpec)] -> Maybe TokenSpec
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Int
    v [(Int, TokenSpec)]
    pats of
    >       Maybe TokenSpec
    Nothing -> Int -> String -> String
    mkHappyVar Int
    v
    >       Just TokenSpec
    p  -> case TokenSpec
    p of
    >                     TokenFixed String
    p' -> String -> String
    wrap (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> String
    mkHappyVar Int
    v (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    showChar Char
    '@' (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    brack String
    p'
    >                     TokenWithValue ExpressionWithHole
    e -> String -> String
    wrap (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String) -> String -> String
    brack' (ExpressionWithHole -> String -> String
    substExpressionWithHole ExpressionWithHole
    e (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> String
    mkHappyVar Int
    v)

    ---
    standardise the naming scheme

    > mkSemFn_Name :: (Int, Int) -> String
    > mkSemFn_Name :: (Int, Int) -> String
    mkSemFn_Name (Int
    i,Int
    j) = String
    "semfn_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    i String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    j

    ---
    maps production name to the underlying (possibly shared) semantic function

    > mk_semfn_map :: SemInfo -> Array Name String
    > mk_semfn_map :: SemInfo -> Array Name String
    mk_semfn_map SemInfo
    sem_info
    >  = (Name, Name) -> [(Name, String)] -> Array Name String
    forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
    array (Name
    i_min, Name
    i_max) [(Name, String)]
    prod_map
    >    where
    >        i_min :: Name
    i_min = Int -> Name
    MkName Int
    0
    >        i_max :: Name
    i_max = Int -> Name
    MkName (Int -> Name) -> Int -> Name
    forall a b. (a -> b) -> a -> b
    $ [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum ([Int] -> Int) -> [Int] -> Int
    forall a b. (a -> b) -> a -> b
    $ ((Name, String) -> Int) -> [(Name, String)] -> [Int]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Int
    getName (Name -> Int) -> ((Name, String) -> Name) -> (Name, String) -> Int
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Name, String) -> Name
    forall a b. (a, b) -> a
    fst) [(Name, String)]
    prod_map
    >        prod_map :: [(Name, String)]
    prod_map = [ (Int -> Name
    MkName Int
    p, (Int, Int) -> String
    mkSemFn_Name (Int, Int)
    ij)
    >                   | (String
    _,String
    _,[Int]
    _,[((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    pi') <- SemInfo
    sem_info, ((Int, Int)
    ij,([(Int, TokenSpec)], String)
    _,[Int]
    ps) <- [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    pi', Int
    p <- [Int]
    ps ]

    %-----------------------------------------------------------------------------
    Create default decoding functions

    Idea is that sem rules are stored as functions in the AbsSyn names, and
    only unpacked when needed. Using classes here to manage the unpacking.

    > mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> ShowS
    > mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> String -> String
    mkDecodeUtils (DecodeOption
    TreeDecode,FilterOption
    filter_opt,GhcExts
    _) MonadInfo
    monad_info SemInfo
    seminfo
    >  = String -> [String -> String] -> String -> String
    interleave String
    "\n"
    >  ([String -> String] -> String -> String)
    -> [String -> String] -> String -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> String -> String) -> [String] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String -> String
    str (MonadInfo -> [String]
    monad_defs MonadInfo
    monad_info)
    >    [String -> String] -> [String -> String] -> [String -> String]
    forall a. [a] -> [a] -> [a]
    ++ ((String, [(String, [Int])]) -> String -> String)
    -> [(String, [(String, [Int])])] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String, [(String, [Int])]) -> String -> String
    mk_inst [(String, [(String, [Int])])]
    ty_cs
    >    where
    >       ty_cs :: [(String, [(String, [Int])])]
    ty_cs = [ (String
    ty, [ (String
    c_name, [Int]
    mask)
    >                      | (String
    ty2, String
    c_name, [Int]
    mask, [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    _j_vs) <- SemInfo
    seminfo
    >                      , String
    ty2 String -> String -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == String
    ty
    >                      ])
    >               | String
    ty <- [String] -> [String]
    forall a. Eq a => [a] -> [a]
    nub [ String
    ty | (String
    ty,String
    _,[Int]
    _,[((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    _) <- SemInfo
    seminfo ]
    >               ]               -- group by same type

    >       mk_inst :: (String, [(String, [Int])]) -> String -> String
    mk_inst (String
    ty, [(String, [Int])]
    cs_vs)
    >        = String -> String -> String
    str (String
    "instance TreeDecode (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") where ") (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    nl
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String -> String] -> String -> String
    interleave String
    "\n"
    >          [   String -> String -> String
    str String
    "  "
    >            (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    "decode_b f (Branch (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    c_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " s)")
    >            (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str (String
    " (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    var_pat String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ")) = ")
    >            (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . MonadInfo -> String -> [String] -> String -> String
    forall {a} {b}.
    Maybe (a, b, String) -> String -> [String] -> String -> String
    cross_prod MonadInfo
    monad_info String
    "s" (FilterOption -> [String]
    nodes FilterOption
    filter_opt)
    >          | (String
    c_name, [Int]
    vs) <- [(String, [Int])]
    cs_vs
    >          , let vars :: [String]
    vars = [ String
    "b_" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ Int -> String
    forall a. Show a => a -> String
    show Int
    n | Int
    n <- FilterOption -> [Int] -> [Int]
    var_range FilterOption
    filter_opt [Int]
    vs ]
    >          , let var_pat :: String
    var_pat = (String -> String -> String) -> String -> [String] -> String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\String
    l String
    r -> String
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ":" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    r) String
    "_" [String]
    vars
    >          , let nodes :: FilterOption -> [String]
    nodes FilterOption
    NoFiltering  = [ [String]
    vars [String] -> Int -> String
    forall a. HasCallStack => [a] -> Int -> a
    !! Int
    n | Int
    n <- [Int]
    vs ]
    >                nodes FilterOption
    UseFiltering = [String]
    vars
    >          ]

    >       var_range :: FilterOption -> [Int] -> [Int]
    var_range FilterOption
    _            [] = []
    >       var_range FilterOption
    NoFiltering  [Int]
    vs = [Int
    0 .. [Int] -> Int
    forall a. Ord a => [a] -> a
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum [Int]
    vs ]
    >       var_range FilterOption
    UseFiltering [Int]
    vs = [Int
    0 .. [Int] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [Int]
    vs Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - Int
    1]

    >       cross_prod :: Maybe (a, b, String) -> String -> [String] -> String -> String
    cross_prod Maybe (a, b, String)
    Nothing String
    s_var [String]
    nodes
    >        = (String -> String) -> [String -> String] -> String -> String
    cross_prod_ (Char -> String -> String
    char Char
    '[' (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    s_var (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    char Char
    ']')
    >                      ((String -> String -> String) -> [String] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String -> String
    str [String]
    nodes)
    >       cross_prod (Just (a
    _,b
    _,String
    rtn)) String
    s_var [String]
    nodes
    >        = String -> String -> String
    str String
    "map happy_join $ "
    >        (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (String -> String) -> [String -> String] -> String -> String
    cross_prod_ (Char -> String -> String
    char Char
    '[' (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    rtn (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    char Char
    ' ' (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    s_var (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    char Char
    ']')
    >                      ((String -> String -> String) -> [String] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String -> String
    str [String]
    nodes)

    >       cross_prod_ :: (String -> String) -> [String -> String] -> String -> String
    cross_prod_ = ((String -> String) -> (String -> String) -> String -> String)
    -> (String -> String) -> [String -> String] -> String -> String
    forall b a. (b -> a -> b) -> b -> [a] -> b
    forall (t :: * -> *) b a.
    Foldable t =>
    (b -> a -> b) -> b -> t a -> b
    foldl (\String -> String
    s String -> String
    a -> (String -> String) -> String -> String
    brack'
    >                                  ((String -> String) -> String -> String)
    -> (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String
    str String
    "cross_fn"
    >                                  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    char Char
    ' ' (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    s
    >                                  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    " $ decode f "
    >                                  (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    a)

    > mkDecodeUtils (DecodeOption
    LabelDecode,FilterOption
    _,GhcExts
    _) MonadInfo
    monad_info SemInfo
    seminfo
    >  = String -> [String -> String] -> String -> String
    interleave String
    "\n"
    >  ([String -> String] -> String -> String)
    -> [String -> String] -> String -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> String -> String) -> [String] -> [String -> String]
    forall a b. (a -> b) -> [a] -> [b]
    map String -> String -> String
    str
    >  ([String] -> [String -> String]) -> [String] -> [String -> String]
    forall a b. (a -> b) -> a -> b
    $ MonadInfo -> [String]
    monad_defs MonadInfo
    monad_info [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ ((String, [(String, [Int])]) -> [String])
    -> [(String, [(String, [Int])])] -> [String]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap ((String, [(String, [Int])]) -> [String]
    forall {b}. (String, [(String, b)]) -> [String]
    mk_inst) [(String, [(String, [Int])])]
    ty_cs
    >    where
    >       ty_cs :: [(String, [(String, [Int])])]
    ty_cs = [ (String
    ty, [ (String
    c_name, [Int]
    mask)
    >                      | (String
    ty2, String
    c_name, [Int]
    mask, [((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    _) <- SemInfo
    seminfo
    >                      , String
    ty2 String -> String -> DebugMode
    forall a. Eq a => a -> a -> DebugMode
    == String
    ty
    >                      ])
    >               | String
    ty <- [String] -> [String]
    forall a. Eq a => [a] -> [a]
    nub [ String
    ty | (String
    ty,String
    _,[Int]
    _,[((Int, Int), ([(Int, TokenSpec)], String), [Int])]
    _) <- SemInfo
    seminfo ]
    >               ]               -- group by same type

    >       mk_inst :: (String, [(String, b)]) -> [String]
    mk_inst (String
    ty, [(String, b)]
    cns)
    >        = (String
    "instance LabelDecode (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ty String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") where ")
    >        String -> [String] -> [String]
    forall a. a -> [a] -> [a]
    : [ String
    "  unpack (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    c_name String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " s) = s"
    >          | (String
    c_name, b
    _mask) <- [(String, b)]
    cns ]

    ---
    This selects the info used for monadic parser generation

    > type MonadInfo = Maybe (String,String,String)
    > monad_sub :: Directives -> MonadInfo
    > monad_sub :: Directives -> MonadInfo
    monad_sub Directives
    pragmas
    >  = case Directives -> (DebugMode, String, String, String, String)
    monad Directives
    pragmas of
    >      (DebugMode
    True, String
    _, String
    ty,String
    bd,String
    ret) -> (String, String, String) -> MonadInfo
    forall a. a -> Maybe a
    Just (String
    ty,String
    bd,String
    ret)
    >      (DebugMode, String, String, String, String)
    _                    -> MonadInfo
    forall a. Maybe a
    Nothing
    >    -- TMP: only use monad info if it was user-declared, and ignore ctxt
    >    -- TMP: otherwise default to non-monadic code
    >    -- TMP: (NB not sure of consequences of monads-everywhere yet)

    ---
    form the various monad-related defs.

    > monad_defs :: MonadInfo -> [String]
    > monad_defs :: MonadInfo -> [String]
    monad_defs MonadInfo
    Nothing
    >  = [ String
    "type Decode_Result a = a"
    >    , String
    "happy_ap = ($)"
    >    , String
    "happy_return = id"]
    > monad_defs (Just (String
    ty,String
    tn,String
    rtn))
    >  = [ String
    "happy_join x = (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") x id"
    >    , String
    "happy_ap f a = (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") f (\\f -> (" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    tn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ") a (\\a -> " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    rtn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "(f a)))"
    >    , String
    "type Decode_Result a = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String -> String -> String
    brack String
    ty String
    " a"
    >    , String
    "happy_return = " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    rtn String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " :: a -> Decode_Result a"
    >    ]

    %-----------------------------------------------------------------------------
    Util Functions

    ---
    remove Happy-generated start symbols.

    > user_non_terminals :: Grammar String -> [Name]
    > user_non_terminals :: Grammar String -> [Name]
    user_non_terminals Grammar String
    g
    >  = Grammar String -> [Name]
    forall eliminator. Grammar eliminator -> [Name]
    non_terminals Grammar String
    g [Name] -> [Name] -> [Name]
    forall a. Eq a => [a] -> [a] -> [a]
    \\ Grammar String -> [Name]
    start_productions Grammar String
    g

    > start_productions :: Grammar String -> [Name]
    > start_productions :: Grammar String -> [Name]
    start_productions Grammar String
    g = [ Name
    s | (String
    _,Name
    s,Name
    _,DebugMode
    _) <- Grammar String -> [(String, Name, Name, DebugMode)]
    forall eliminator.
    Grammar eliminator -> [(String, Name, Name, DebugMode)]
    starts Grammar String
    g ]

    ---

    > mkHappyVar :: Int -> String -> String
    > mkHappyVar :: Int -> String -> String
    mkHappyVar Int
    n = String -> String -> String
    str String
    "happy_var_" (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> String -> String
    forall a. Show a => a -> String -> String
    shows Int
    n

    %------------------------------------------------------------------------------
    Fast string-building functions

    > str :: String -> String -> String
    > str :: String -> String -> String
    str = String -> String -> String
    showString
    > char :: Char -> String -> String
    > char :: Char -> String -> String
    char Char
    c = (Char
    c Char -> String -> String
    forall a. a -> [a] -> [a]
    :)
    > interleave :: String -> [String -> String] -> String -> String
    > interleave :: String -> [String -> String] -> String -> String
    interleave String
    s = ((String -> String) -> (String -> String) -> String -> String)
    -> (String -> String) -> [String -> String] -> String -> String
    forall a b. (a -> b -> b) -> b -> [a] -> b
    forall (t :: * -> *) a b.
    Foldable t =>
    (a -> b -> b) -> b -> t a -> b
    foldr (\String -> String
    a String -> String
    b -> String -> String
    a (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> String
    str String
    s (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    b) String -> String
    forall a. a -> a
    id

    > nl :: String -> String
    > nl :: String -> String
    nl = Char -> String -> String
    char Char
    '\n'

    > maybestr :: Maybe String -> String -> String
    > maybestr :: Maybe String -> String -> String
    maybestr (Just String
    s)     = String -> String -> String
    str String
    s
    > maybestr Maybe String
    _            = String -> String
    forall a. a -> a
    id

    > brack :: String -> String -> String
    > brack :: String -> String -> String
    brack String
    s = String -> String -> String
    str (Char
    '(' Char -> String -> String
    forall a. a -> [a] -> [a]
    : String
    s) (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    char Char
    ')'
    > brack' :: (String -> String) -> String -> String
    > brack' :: (String -> String) -> String -> String
    brack' String -> String
    s = Char -> String -> String
    char Char
    '(' (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String
    s (String -> String) -> (String -> String) -> String -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Char -> String -> String
    char Char
    ')'