> {-#LANGUAGE FlexibleContexts#-}


> module ProduceCode (produceParser) where


-- > import Paths_happy		( version )
-- > import Data.Version		( showVersion )


> import Grammar
> import Target                 ( Target(..) )
> import GenUtils               ( mapDollarDollar, str, char, nl, strspace,
>                                 interleave, interleave', maybestr,
>                                 brack, brack' )


> import Data.Maybe                     ( isJust, isNothing )
> import Data.Char
> import Data.List


> import Control.Monad.ST
> import Data.Array.ST      ( STUArray )
> import Data.Array.Unboxed ( UArray )
> import Data.Array.MArray
> import Data.Array.IArray








> produceParser :: Grammar                      -- grammar info
>               -> ActionTable                  -- action table
>               -> GotoTable                    -- goto table
>               -> String                       -- stuff to go at the top
>               -> Maybe String                 -- module header
>               -> Maybe String                 -- module trailer
>               -> Target                       -- type of code required
>               -> Bool                         -- use coercions
>               -> Bool                         -- use ghc extensions
>               -> Bool                         -- strict parser
>               -> String


> produceParser (Grammar
>               { productions = prods
>               , non_terminals = nonterms
>               , terminals = terms
>               , types = nt_types
>               , first_nonterm = first_nonterm'
>               , eof_term = eof
>               , first_term = fst_term
>               , lexer = lexer'
>               , imported_identity = imported_identity'
>               , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return)
>               , token_specs = token_rep
>               , token_type = token_type'
>               , starts = starts'
>               , error_handler = error_handler'
>               , attributetype = attributetype'
>               , attributes = attributes'
>               })
>               action goto top_options module_header module_trailer
>               target coerce ghc strict
>     = ( top_opts
>       . maybestr module_header . nl
>       . str comment
>               -- comment goes *after* the module header, so that we
>               -- don't screw up any OPTIONS pragmas in the header.
>       . produceAbsSynDecl . nl
>       . produceTypes
>       . produceActionTable target
>       . produceReductions
>       . produceTokenConverter . nl
>       . produceIdentityStuff
>       . produceMonadStuff
>       . produceEntries
>       . produceStrict strict
>       . produceAttributes attributes' attributetype' . nl
>       . maybestr module_trailer . nl
>       ) ""
>  where
>    n_starts = length starts'
>    token = brack token_type'
>
>    nowarn_opts = str "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}" . nl
>
>    top_opts = nowarn_opts .
>      case top_options of
>          "" -> str ""
>          _  -> str (unwords [ "{-# OPTIONS"
>                             , top_options
>                             , "#-}"
>                             ]) . nl




















>    produceAbsSynDecl
















        happyIn<n> :: ti -> HappyAbsSyn ti tj tk ...
        happyIn<n> x = unsafeCoerce# x
        {-# INLINE happyIn<n> #-}


        happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn
        happyOut<n> x = unsafeCoerce# x
        {-# INLINE happyOut<n> #-}


>     | coerce
>       = let
>             happy_item = str "HappyAbsSyn " . str_tyvars
>             bhappy_item = brack' happy_item
>
>             inject n ty
>               = mkHappyIn n . str " :: " . type_param n ty
>               . str " -> " . bhappy_item . char '\n'
>               . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"
>               . str "{-# INLINE " . mkHappyIn n . str " #-}"
>
>             extract n ty
>               = mkHappyOut n . str " :: " . bhappy_item
>               . str " -> " . type_param n ty . char '\n'
>               . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"
>               . str "{-# INLINE " . mkHappyOut n . str " #-}"
>         in
>           str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below
>         . interleave "\n" (map str
>           [ "#if __GLASGOW_HASKELL__ >= 607",
>             "type HappyAny = Happy_GHC_Exts.Any",
>             "#else",
>             "type HappyAny = forall a . a",
>             "#endif" ])
>         . interleave "\n"
>           [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ]
>         -- token injector
>         . str "happyInTok :: " . token . str " -> " . bhappy_item
>         . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n"
>         -- token extractor
>         . str "happyOutTok :: " . bhappy_item . str " -> " . token
>         . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n"


>         . str "\n"




















-> ()) as the type here, but this led to bogus optimisations (see GHC
ticket #1616).
















>     | otherwise
>       = str "data HappyAbsSyn " . str_tyvars
>       . str "\n\t= HappyTerminal " . token
>       . str "\n\t| HappyErrorToken Int\n"
>       . interleave "\n"
>         [ str "\t| " . makeAbsSynCon n . strspace . type_param n ty
>         | (n, ty) <- assocs nt_types,
>           (nt_types_index ! n) == n]


>     where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ]
>           str_tyvars = str (unwords all_tyvars)








>    produceTypes
>     | target == TargetArrayBased = id


>     | all isJust (elems nt_types) =
>       happyReductionDefinition . str "\n\n"
>     . interleave' ",\n "
>             [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ]
>                                                    (assocs action) ]
>     . str " :: " . str monad_context . str " => "
>     . intMaybeHash . str " -> " . happyReductionValue . str "\n\n"
>     . interleave' ",\n "
>             [ mkReduceFun i |
>                     (i,_action) <- zip [ n_starts :: Int .. ]
>                                        (drop n_starts prods) ]
>     . str " :: " . str monad_context . str " => "
>     . happyReductionValue . str "\n\n"


>     | otherwise = id


>       where intMaybeHash | ghc       = str "Happy_GHC_Exts.Int#"
>                          | otherwise = str "Int"
>             tokens =
>               case lexer' of
>                       Nothing -> char '[' . token . str "] -> "
>                       Just _ -> id
>             happyReductionDefinition =
>                      str "{- to allow type-synonyms as our monads (likely\n"
>                    . str " - with explicitly-specified bind and return)\n"
>                    . str " - in Haskell98, it seems that with\n"
>                    . str " - /type M a = .../, then /(HappyReduction M)/\n"
>                    . str " - is not allowed.  But Happy is a\n"
>                    . str " - code-generator that can just substitute it.\n"
>                    . str "type HappyReduction m = "
>                    . happyReduction (str "m")
>                    . str "\n-}"
>             happyReductionValue =
>                      str "({-"
>                    . str "HappyReduction "
>                    . brack monad_tycon
>                    . str " = -}"
>                    . happyReduction (brack monad_tycon)
>                    . str ")"
>             happyReduction m =
>                      str "\n\t   "
>                    . intMaybeHash
>                    . str " \n\t-> " . token
>                    . str "\n\t-> HappyState "
>                    . token
>                    . str " (HappyStk HappyAbsSyn -> " . tokens . result
>                    . str ")\n\t"
>                    . str "-> [HappyState "
>                    . token
>                    . str " (HappyStk HappyAbsSyn -> " . tokens . result
>                    . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> "
>                    . tokens
>                    . result
>                 where result = m . str " HappyAbsSyn"






















                ( <<user supplied string>> ) : happyRest












        happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275


                =  happyThen (code) (\r -> happyReturn (HappyAbsSyn r))
















>    produceReductions =
>       interleave "\n\n"
>          (zipWith produceReduction (drop n_starts prods) [ n_starts .. ])


>    produceReduction (nt, toks, (code,vars_used), _) i


>     | is_monad_prod && (use_monad || imported_identity')
>       = mkReductionHdr (showInt lt) monad_reduce
>       . char '(' . interleave " `HappyStk`\n\t" tokPatterns
>       . str "happyRest) tk\n\t = happyThen ("
>       . tokLets (char '(' . str code' . char ')')
>       . (if monad_pass_token then str " tk" else id)
>       . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))"


>     | specReduceFun lt
>       = mkReductionHdr id ("happySpecReduce_" ++ show lt)
>       . interleave "\n\t" tokPatterns
>       . str " =  "
>       . tokLets (
>           this_absSynCon . str "\n\t\t "
>           . char '(' . str code' . str "\n\t)"
>         )
>       . (if coerce || null toks || null vars_used then
>                 id
>          else
>                 nl . reductionFun . strspace
>               . interleave " " (map str (take (length toks) (repeat "_")))
>               . str " = notHappyAtAll ")


>     | otherwise
>       = mkReductionHdr (showInt lt) "happyReduce"
>       . char '(' . interleave " `HappyStk`\n\t" tokPatterns
>       . str "happyRest)\n\t = "
>       . tokLets
>          ( this_absSynCon . str "\n\t\t "
>          . char '(' . str code'. str "\n\t) `HappyStk` happyRest"
>          )


>       where
>               (code', is_monad_prod, monad_pass_token, monad_reduce)
>                     = case code of
>                         '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce")
>                         '%':'^':code1 -> (code1, True, True, "happyMonadReduce")
>                         '%':code1     -> (code1, True, False, "happyMonadReduce")
>                         _ -> (code, False, False, "")


>               -- adjust the nonterminal number for the array-based parser
>               -- so that nonterminals start at zero.
>               adjusted_nt | target == TargetArrayBased = nt - first_nonterm'
>                           | otherwise                  = nt
>
>               mkReductionHdr lt' s =
>                       mkReduceFun i . str " = "
>                       . str s . strspace . lt' . strspace . showInt adjusted_nt
>                       . strspace . reductionFun . nl
>                       . reductionFun . strspace
>
>               reductionFun = str "happyReduction_" . shows i
>
>               tokPatterns
>                | coerce = reverse (map mkDummyVar [1 .. length toks])
>                | otherwise = reverse (zipWith tokPattern [1..] toks)
>
>               tokPattern n _ | n `notElem` vars_used = char '_'
>               tokPattern n t | t >= firstStartTok && t < fst_term
>                       = if coerce
>                               then mkHappyVar n
>                               else brack' (
>                                    makeAbsSynCon t . str "  " . mkHappyVar n
>                                    )
>               tokPattern n t
>                       = if coerce
>                               then mkHappyTerminalVar n t
>                               else str "(HappyTerminal "
>                                  . mkHappyTerminalVar n t
>                                  . char ')'
>
>               tokLets code''
>                  | coerce && not (null cases)
>                       = interleave "\n\t" cases
>                       . code'' . str (take (length cases) (repeat '}'))
>                  | otherwise = code''
>
>               cases = [ str "case " . extract t . strspace . mkDummyVar n
>                       . str " of { " . tokPattern n t . str " -> "
>                       | (n,t) <- zip [1..] toks,
>                         n `elem` vars_used ]
>
>               extract t | t >= firstStartTok && t < fst_term = mkHappyOut t
>                         | otherwise                     = str "happyOutTok"
>
>               lt = length toks


>               this_absSynCon | coerce    = mkHappyIn nt
>                              | otherwise = makeAbsSynCon nt








>    produceTokenConverter
>       = case lexer' of {
>
>       Nothing ->
>         str "happyNewToken action sts stk [] =\n\t"
>       . eofAction "notHappyAtAll"
>       . str " []\n\n"
>       . str "happyNewToken action sts stk (tk:tks) =\n\t"
>       . str "let cont i = " . doAction . str " sts stk tks in\n\t"
>       . str "case tk of {\n\t"
>       . interleave ";\n\t" (map doToken token_rep)
>       . str "_ -> happyError' (tk:tks)\n\t"
>       . str "}\n\n"
>       . str "happyError_ tk tks = happyError' (tk:tks)\n";


>       Just (lexer'',eof') ->
>         str "happyNewToken action sts stk\n\t= "
>       . str lexer''
>       . str "(\\tk -> "
>       . str "\n\tlet cont i = "
>       . doAction
>       . str " sts stk in\n\t"
>       . str "case tk of {\n\t"
>       . str (eof' ++ " -> ")
>       . eofAction "tk" . str ";\n\t"
>       . interleave ";\n\t" (map doToken token_rep)
>       . str "_ -> happyError' tk\n\t"
>       . str "})\n\n"
>       . str "happyError_ tk = happyError' tk\n";
>       }


>       where


>         eofAction tk =
>           (case target of
>               TargetArrayBased ->
>                 str "happyDoAction " . eofTok . strspace . str tk . str " action"
>               _ ->  str "action "     . eofTok . strspace . eofTok
>                   . strspace . str tk . str " (HappyState action)")
>            . str " sts stk"
>         eofTok = showInt (tokIndex eof)
>
>         doAction = case target of
>           TargetArrayBased -> str "happyDoAction i tk action"
>           _   -> str "action i i tk (HappyState action)"
>
>         doToken (i,tok)
>               = str (removeDollarDollar tok)
>               . str " -> cont "
>               . showInt (tokIndex i)








>         removeDollarDollar xs = case mapDollarDollar xs of
>                                  Nothing -> xs
>                                  Just fn -> fn "happy_dollar_dollar"


>    mkHappyTerminalVar :: Int -> Int -> String -> String
>    mkHappyTerminalVar i t =
>     case tok_str_fn of
>       Nothing -> pat
>       Just fn -> brack (fn (pat []))
>     where
>         tok_str_fn = case lookup t token_rep of
>                     Nothing -> Nothing
>                     Just str' -> mapDollarDollar str'
>         pat = mkHappyVar i


>    tokIndex
>       = case target of
>               TargetHaskell    -> id
>               TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2
>                       -- tokens adjusted to start at zero, see ARRAY_NOTES








>    produceActionTable TargetHaskell
>       = foldr (.) id (map (produceStateFunction goto) (assocs action))
>
>    produceActionTable TargetArrayBased
>       = produceActionArray
>       . produceReduceArray
>       . str "happy_n_terms = " . shows n_terminals . str " :: Int\n"
>       . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n"


>    produceStateFunction goto' (state, acts)
>       = foldr (.) id (map produceActions assocs_acts)
>       . foldr (.) id (map produceGotos   (assocs gotos))
>       . mkActionName state
>       . (if ghc
>              then str " x = happyTcHack x "
>              else str " _ = ")
>       . mkAction default_act
>       . str "\n\n"
>
>       where gotos = goto' ! state
>
>             produceActions (_, LR'Fail{-'-}) = id
>             produceActions (t, action'@(LR'Reduce{-'-} _ _))
>                | action' == default_act = id
>                | otherwise = actionFunction t
>                            . mkAction action' . str "\n"
>             produceActions (t, action')
>               = actionFunction t
>               . mkAction action' . str "\n"
>
>             produceGotos (t, Goto i)
>               = actionFunction t
>               . str "happyGoto " . mkActionName i . str "\n"
>             produceGotos (_, NoGoto) = id
>
>             actionFunction t
>               = mkActionName state . strspace
>               . ('(' :) . showInt t
>               . str ") = "
>
>             default_act = getDefault assocs_acts
>
>             assocs_acts = assocs acts




>    produceActionArray
>       | ghc
>           = str "happyActOffsets :: HappyAddr\n"
>           . str "happyActOffsets = HappyA# \"" --"
>           . str (hexChars act_offs)
>           . str "\"#\n\n" --"
>
>           . str "happyGotoOffsets :: HappyAddr\n"
>           . str "happyGotoOffsets = HappyA# \"" --"
>           . str (hexChars goto_offs)
>           . str "\"#\n\n"  --"
>
>           . str "happyDefActions :: HappyAddr\n"
>           . str "happyDefActions = HappyA# \"" --"
>           . str (hexChars defaults)
>           . str "\"#\n\n" --"
>
>           . str "happyCheck :: HappyAddr\n"
>           . str "happyCheck = HappyA# \"" --"
>           . str (hexChars check)
>           . str "\"#\n\n" --"
>
>           . str "happyTable :: HappyAddr\n"
>           . str "happyTable = HappyA# \"" --"
>           . str (hexChars table)
>           . str "\"#\n\n" --"


>       | otherwise
>           = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n"
>           . str "happyActOffsets = Happy_Data_Array.listArray (0,"
>               . shows (n_states) . str ") (["
>           . interleave' "," (map shows act_offs)
>           . str "\n\t])\n\n"
>
>           . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n"
>           . str "happyGotoOffsets = Happy_Data_Array.listArray (0,"
>               . shows (n_states) . str ") (["
>           . interleave' "," (map shows goto_offs)
>           . str "\n\t])\n\n"
>
>           . str "happyDefActions :: Happy_Data_Array.Array Int Int\n"
>           . str "happyDefActions = Happy_Data_Array.listArray (0,"
>               . shows (n_states) . str ") (["
>           . interleave' "," (map shows defaults)
>           . str "\n\t])\n\n"
>
>           . str "happyCheck :: Happy_Data_Array.Array Int Int\n"
>           . str "happyCheck = Happy_Data_Array.listArray (0,"
>               . shows table_size . str ") (["
>           . interleave' "," (map shows check)
>           . str "\n\t])\n\n"
>
>           . str "happyTable :: Happy_Data_Array.Array Int Int\n"
>           . str "happyTable = Happy_Data_Array.listArray (0,"
>               . shows table_size . str ") (["
>           . interleave' "," (map shows table)
>           . str "\n\t])\n\n"
>
>    (_, last_state) = bounds action
>    n_states = last_state + 1
>    n_terminals = length terms
>    n_nonterminals = length nonterms - n_starts -- lose %starts
>
>    (act_offs,goto_offs,table,defaults,check)
>       = mkTables action goto first_nonterm' fst_term
>               n_terminals n_nonterminals n_starts
>
>    table_size = length table - 1
>
>    produceReduceArray
>       = {- str "happyReduceArr :: Array Int a\n" -}
>         str "happyReduceArr = Happy_Data_Array.array ("
>               . shows (n_starts :: Int) -- omit the %start reductions
>               . str ", "
>               . shows n_rules
>               . str ") [\n"
>       . interleave' ",\n" (map reduceArrElem [n_starts..n_rules])
>       . str "\n\t]\n\n"


>    n_rules = length prods - 1 :: Int


>    showInt i | ghc       = shows i . showChar '#'
>              | otherwise = shows i






>    nt_types_index :: Array Int Int
>    nt_types_index = array (bounds nt_types)
>                       [ (a, fn a b) | (a, b) <- assocs nt_types ]
>     where
>       fn n Nothing = n
>       fn _ (Just a) = case lookup a assoc_list of
>                         Just v -> v
>                         Nothing -> error ("cant find an item in list")
>       assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ]


>    makeAbsSynCon = mkAbsSynCon nt_types_index




>    produceIdentityStuff | use_monad = id
>     | imported_identity' =
>            str "type HappyIdentity = Identity\n"
>          . str "happyIdentity = Identity\n"
>          . str "happyRunIdentity = runIdentity\n\n"
>     | otherwise =
>            str "newtype HappyIdentity a = HappyIdentity a\n"
>          . str "happyIdentity = HappyIdentity\n"
>          . str "happyRunIdentity (HappyIdentity a) = a\n\n"
>          . str "instance Monad HappyIdentity where\n"
>          . str "    return = HappyIdentity\n"
>          . str "    (HappyIdentity p) >>= q = q p\n\n"










        happyThen    :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
        happyReturn  :: () => a -> HappyIdentity a
        happyThen1   m k tks = happyThen m (\a -> k a tks)
        happyReturn1 = \a tks -> happyReturn a






        happyThen    :: CONTEXT => P a -> (a -> P b) -> P b
        happyReturn  :: CONTEXT => a -> P a
        happyThen1   m k tks = happyThen m (\a -> k a tks)
        happyReturn1 = \a tks -> happyReturn a






        happyThen    :: CONTEXT => P a -> (a -> P b) -> P b
        happyReturn  :: CONTEXT => a -> P a








>    produceMonadStuff =
>            let pcont = str monad_context in
>            let pty = str monad_tycon in
>            str "happyThen :: " . pcont . str " => " . pty
>          . str " a -> (a -> "  . pty
>          . str " b) -> " . pty . str " b\n"
>          . str "happyThen = " . brack monad_then . nl
>          . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n"
>          . str "happyReturn = " . brack monad_return . nl
>          . case lexer' of
>               Nothing ->
>                  str "happyThen1 m k tks = (" . str monad_then
>                . str ") m (\\a -> k a tks)\n"
>                . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n"
>                . str "happyReturn1 = \\a tks -> " . brack monad_return
>                . str " a\n"
>                . str "happyError' :: " . str monad_context . str " => ["
>                . token
>                . str "] -> "
>                . str monad_tycon
>                . str " a\n"
>                . str "happyError' = "
>                . str (if use_monad then "" else "HappyIdentity . ")
>                . errorHandler
>                . str "\n\n"
>               _ ->
>                  str "happyThen1 = happyThen\n"
>                . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n"
>                . str "happyReturn1 = happyReturn\n"
>                . str "happyError' :: " . str monad_context . str " => "
>                                        . token . str " -> "
>                . str monad_tycon
>                . str " a\n"
>                . str "happyError' tk = "
>                . str (if use_monad then "" else "HappyIdentity ")
>                . errorHandler . str " tk\n"
>                . str "\n"










>    errorHandler =
>       case error_handler' of
>               Just h  -> str h
>               Nothing -> case lexer' of
>                               Nothing -> str "happyError"
>                               Just _  -> str "(\\token -> happyError)"


>    reduceArrElem n
>      = str "\t(" . shows n . str " , "
>      . str "happyReduce_" . shows n . char ')'








>    produceEntries
>       = interleave "\n\n" (map produceEntry (zip starts' [0..]))
>       . if null attributes' then id else produceAttrEntries starts'


>    produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no)
>       = (if null attributes' then str name else str "do_" . str name)
>       . maybe_tks
>       . str " = "
>       . str unmonad
>       . str "happySomeParser where\n"
>       . str "  happySomeParser = happyThen (happyParse "
>       . case target of
>            TargetHaskell -> str "action_" . shows no
>            TargetArrayBased
>                | ghc       -> shows no . str "#"
>                | otherwise -> shows no
>       . maybe_tks
>       . str ") "
>       . brack' (if coerce
>                    then str "\\x -> happyReturn (happyOut"
>                       . shows accept_nonterm . str " x)"
>                    else str "\\x -> case x of {HappyAbsSyn"
>                       . shows (nt_types_index ! accept_nonterm)
>                       . str " z -> happyReturn z; _other -> notHappyAtAll }"
>                )
>     where
>       maybe_tks | isNothing lexer' = str " tks"
>                 | otherwise = id
>       unmonad | use_monad = ""
>                 | otherwise = "happyRunIdentity "


>    produceAttrEntries starts''
>       = interleave "\n\n" (map f starts'')
>     where
>       f = case (use_monad,lexer') of
>             (True,Just _)  -> \(name,_,_,_) -> monadAndLexerAE name
>             (True,Nothing) -> \(name,_,_,_) -> monadAE name
>             (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer"
>             (False,Nothing)-> \(name,_,_,_) -> regularAE name
>
>       defaultAttr = fst (head attributes')
>
>       monadAndLexerAE name
>         = str name . str " = "
>         . str "do { "
>         . str "f <- do_" . str name . str "; "
>         . str "let { (conds,attrs) = f happyEmptyAttrs } in do { "
>         . str "sequence_ conds; "
>         . str "return (". str defaultAttr . str " attrs) }}"
>       monadAE name
>         = str name . str " toks = "
>         . str "do { "
>         . str "f <- do_" . str name . str " toks; "
>         . str "let { (conds,attrs) = f happyEmptyAttrs } in do { "
>         . str "sequence_ conds; "
>         . str "return (". str defaultAttr . str " attrs) }}"
>       regularAE name
>         = str name . str " toks = "
>         . str "let { "
>         . str "f = do_" . str name . str " toks; "
>         . str "(conds,attrs) = f happyEmptyAttrs; "
>         . str "x = foldr seq attrs conds; "
>         . str "} in (". str defaultAttr . str " x)"








> produceAttributes :: [(String, String)] -> String -> String -> String
> produceAttributes [] _ = id
> produceAttributes attrs attributeType
>     = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl
>     . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl


>   where attributes'  = foldl1 (\x y -> x . str ", " . y) $ map formatAttribute attrs
>         formatAttribute (ident,typ) = str ident . str " :: " . str typ
>         attrsErrors = foldl1 (\x y -> x . str ", " . y) $ map attrError attrs
>         attrError (ident,_) = str ident . str " = error \"invalid reference to attribute '" . str ident . str "'\""
>         attrHeader =
>             case attributeType of
>             [] -> str "HappyAttributes"
>             _  -> str attributeType










> produceStrict :: Bool -> String -> String
> produceStrict strict
>       | strict    = str "happySeq = happyDoSeq\n\n"
>       | otherwise = str "happySeq = happyDontSeq\n\n"










> actionVal :: LRAction -> Int
> actionVal (LR'Shift  state _) = state + 1
> actionVal (LR'Reduce rule _)  = -(rule + 1)
> actionVal LR'Accept           = -1
> actionVal (LR'Multiple _ a)   = actionVal a
> actionVal LR'Fail             = 0
> actionVal LR'MustFail         = 0


> mkAction :: LRAction -> String -> String
> mkAction (LR'Shift i _)       = str "happyShift " . mkActionName i
> mkAction LR'Accept            = str "happyAccept"
> mkAction LR'Fail              = str "happyFail"
> mkAction LR'MustFail          = str "happyFail"
> mkAction (LR'Reduce i _)      = str "happyReduce_" . shows i
> mkAction (LR'Multiple _ a)    = mkAction a


> mkActionName :: Int -> String -> String
> mkActionName i                = str "action_" . shows i






> getDefault :: [(Name, LRAction)] -> LRAction
> getDefault actions =
>   -- pick out the action for the error token, if any
>   case [ act | (e, act) <- actions, e == errorTok ] of
>
>       -- use error reduction as the default action, if there is one.
>       act@(LR'Reduce _ _) : _                 -> act
>       act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act
>
>       -- if the error token is shifted or otherwise, don't generate
>       --  a default action.  This is *important*!
>       (act : _) | act /= LR'Fail -> LR'Fail
>
>       -- no error actions, pick a reduce to be the default.
>       _      -> case reduces of
>                     [] -> LR'Fail
>                     (act:_) -> act    -- pick the first one we see for now
>
>   where reduces
>           =  [ act | (_,act@(LR'Reduce _ _)) <- actions ]
>           ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ]






> mkTables
>        :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int ->
>        ([Int]         -- happyActOffsets
>        ,[Int]         -- happyGotoOffsets
>        ,[Int]         -- happyTable
>        ,[Int]         -- happyDefAction
>        ,[Int]         -- happyCheck
>        )
>
> mkTables action goto first_nonterm' fst_term
>               n_terminals n_nonterminals n_starts
>  = ( elems act_offs,
>      elems goto_offs,
>      take max_off (elems table),
>      def_actions,
>      take max_off (elems check)
>   )
>  where
>
>        (table,check,act_offs,goto_offs,max_off)
>                = runST (genTables (length actions) max_token sorted_actions)
>
>        -- the maximum token number used in the parser
>        max_token = max n_terminals (n_starts+n_nonterminals) - 1
>
>        def_actions = map (\(_,_,def,_,_,_) -> def) actions
>
>        actions :: [TableEntry]
>        actions =
>                [ (ActionEntry,
>                   state,
>                   actionVal default_act,
>                   if null acts'' then 0
>                        else fst (last acts'') - fst (head acts''),
>                   length acts'',
>                   acts'')
>                | (state, acts) <- assocs action,
>                  let (err:_dummy:vec) = assocs acts
>                      vec' = drop (n_starts+n_nonterminals) vec
>                      acts' = filter (notFail) (err:vec')
>                      default_act = getDefault acts'
>                      acts'' = mkActVals acts' default_act
>                ]
>
>        -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0).
>        --  (see ARRAY_NOTES)
>        adjust token | token == errorTok = 0
>                     | otherwise         = token - fst_term + 1
>
>        mkActVals assocs' default_act =
>                [ (adjust token, actionVal act)
>                | (token, act) <- assocs'
>                , act /= default_act ]
>
>        gotos :: [TableEntry]
>        gotos = [ (GotoEntry,
>                   state, 0,
>                   if null goto_vals then 0
>                        else fst (last goto_vals) - fst (head goto_vals),
>                   length goto_vals,
>                   goto_vals
>                  )
>                | (state, goto_arr) <- assocs goto,
>                let goto_vals = mkGotoVals (assocs goto_arr)
>                ]
>
>        -- adjust nonterminals by -first_nonterm', so they start at zero
>        --  (see ARRAY_NOTES)
>        mkGotoVals assocs' =
>                [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ]
>
>        sorted_actions = reverse (sortBy cmp_state (actions++gotos))
>        cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_)
>                | width1 < width2  = LT
>                | width1 == width2 = compare tally1 tally2
>                | otherwise = GT


> data ActionOrGoto = ActionEntry | GotoEntry
> type TableEntry = (ActionOrGoto,
>                       Int{-stateno-},
>                       Int{-default-},
>                       Int{-width-},
>                       Int{-tally-},
>                       [(Int,Int)])


> genTables
>        :: Int                         -- number of actions
>        -> Int                         -- maximum token no.
>        -> [TableEntry]                -- entries for the table
>        -> ST s (UArray Int Int,       -- table
>                 UArray Int Int,       -- check
>                 UArray Int Int,       -- action offsets
>                 UArray Int Int,       -- goto offsets
>                 Int                   -- highest offset in table
>           )
>
> genTables n_actions max_token entries = do
>
>   table      <- newArray (0, mAX_TABLE_SIZE) 0
>   check      <- newArray (0, mAX_TABLE_SIZE) (-1)
>   act_offs   <- newArray (0, n_actions) 0
>   goto_offs  <- newArray (0, n_actions) 0
>   off_arr    <- newArray (-max_token, mAX_TABLE_SIZE) 0
>
>   max_off <- genTables' table check act_offs goto_offs
>                       off_arr entries max_token
>
>   table'     <- freeze table
>   check'     <- freeze check
>   act_offs'  <- freeze act_offs
>   goto_offs' <- freeze goto_offs
>   return (table',check',act_offs',goto_offs',max_off+1)


>   where
>        n_states = n_actions - 1
>        mAX_TABLE_SIZE = n_states * (max_token + 1)




> genTables'
>        :: STUArray s Int Int          -- table
>        -> STUArray s Int Int          -- check
>        -> STUArray s Int Int          -- action offsets
>        -> STUArray s Int Int          -- goto offsets
>        -> STUArray s Int Int          -- offset array
>        -> [TableEntry]                -- entries for the table
>        -> Int                         -- maximum token no.
>        -> ST s Int                    -- highest offset in table
>
> genTables' table check act_offs goto_offs off_arr entries max_token
>       = fit_all entries 0 1
>   where
>
>        fit_all [] max_off _ = return max_off
>        fit_all (s:ss) max_off fst_zero = do
>          (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero
>          ss' <- same_states s ss off
>          writeArray off_arr off 1
>          fit_all ss' new_max_off new_fst_zero
>
>        -- try to merge identical states.  We only try the next state(s)
>        -- in the list, but the list is kind-of sorted so we shouldn't
>        -- miss too many.
>        same_states _ [] _ = return []
>        same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off
>          | acts == acts' = do writeArray (which_off e) no off
>                               same_states s ss' off
>          | otherwise = return ss
>
>        which_off ActionEntry = act_offs
>        which_off GotoEntry   = goto_offs
>
>        -- fit a vector into the table.  Return the offset of the vector,
>        -- the maximum offset used in the table, and the offset of the first
>        -- entry in the table (used to speed up the lookups a bit).
>        fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero)
>
>        fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_))
>           max_off fst_zero = do
>                -- start at offset 1 in the table: all the empty states
>                -- (states with just a default reduction) are mapped to
>                -- offset zero.
>          off <- findFreeOffset (-t+fst_zero) check off_arr state
>          let new_max_off | furthest_right > max_off = furthest_right
>                          | otherwise                = max_off
>              furthest_right = off + max_token
>
>          -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do
>
>          writeArray (which_off act_or_goto) state_no off
>          addState off table check state
>          new_fst_zero <- findFstFreeSlot check fst_zero
>          return (off, new_max_off, new_fst_zero)




















> -- Find a valid offset in the table for this state.
> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int
> findFreeOffset off table off_arr state = do
>     -- offset 0 isn't allowed
>   if off == 0 then try_next else do
>
>     -- don't use an offset we've used before
>   b <- readArray off_arr off
>   if b /= 0 then try_next else do
>
>     -- check whether the actions for this state fit in the table
>   ok <- fits off state table
>   if not ok then try_next else return off
>  where
>       try_next = findFreeOffset (off+1) table off_arr state




> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool
> fits _   []           _     = return True
> fits off ((t,_):rest) table = do
>   i <- readArray table (off+t)
>   if i /= -1 then return False
>              else fits off rest table


> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)]
>          -> ST s ()
> addState _   _     _     [] = return ()
> addState off table check ((t,val):state) = do
>    writeArray table (off+t) val
>    writeArray check (off+t) t
>    addState off table check state


> notFail :: (Int, LRAction) -> Bool
> notFail (_, LR'Fail) = False
> notFail _           = True


> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int
> findFstFreeSlot table n = do
>        i <- readArray table n
>        if i == -1 then return n
>                   else findFstFreeSlot table (n+1)








> comment :: String
> comment =
>         "-- parser produced by Happy \n\n"


> mkAbsSynCon :: Array Int Int -> Int -> String -> String
> mkAbsSynCon fx t      = str "HappyAbsSyn"   . shows (fx ! t)


> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String
> mkHappyVar n          = str "happy_var_"    . shows n
> mkReduceFun n         = str "happyReduce_"  . shows n
> mkDummyVar n          = str "happy_x_"      . shows n


> mkHappyIn, mkHappyOut :: Int -> String -> String
> mkHappyIn n           = str "happyIn"  . shows n
> mkHappyOut n          = str "happyOut" . shows n


> type_param :: Int -> Maybe String -> ShowS
> type_param n Nothing   = char 't' . shows n
> type_param _ (Just ty) = brack ty


> specReduceFun :: Int -> Bool
> specReduceFun = (<= 3)










> hexChars :: [Int] -> String
> hexChars acts = concat (map hexChar acts)


> hexChar :: Int -> String
> hexChar i | i < 0 = hexChar (i + 2^16)
> hexChar i =  toHex (i `mod` 256) ++ toHex (i `div` 256)


> toHex :: Int -> String
> toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)]


> hexDig :: Int -> Char
> hexDig i | i <= 9    = chr (i + ord '0')
>          | otherwise = chr (i - 10 + ord 'a')