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

>    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')