> {-#LANGUAGE FlexibleContexts#-}
> module ProduceCode (produceParser) where
> 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
> -> ActionTable
> -> GotoTable
> -> String
> -> Maybe String
> -> Maybe String
> -> Target
> -> Bool
> -> Bool
> -> Bool
> -> 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
>
>
> . 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"
> . 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 ]
>
> . str "happyInTok :: " . token . str " -> " . bhappy_item
> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n"
>
> . 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, "")
>
>
> 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
>
> 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
>
> (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 = Happy_Data_Array.array ("
> . shows (n_starts :: Int)
> . 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 =
>
> case [ act | (e, act) <- actions, e == errorTok ] of
>
>
> act@(LR'Reduce _ _) : _ -> act
> act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act
>
>
>
> (act : _) | act /= LR'Fail -> LR'Fail
>
>
> _ -> case reduces of
> [] -> LR'Fail
> (act:_) -> act
>
> where reduces
> = [ act | (_,act@(LR'Reduce _ _)) <- actions ]
> ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ]
> mkTables
> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int ->
> ([Int]
> ,[Int]
> ,[Int]
> ,[Int]
> ,[Int]
> )
>
> 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)
>
>
> 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 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)
> ]
>
>
>
> 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,
> Int,
> Int,
> Int,
> [(Int,Int)])
> genTables
> :: Int
> -> Int
> -> [TableEntry]
> -> ST s (UArray Int Int,
> UArray Int Int,
> UArray Int Int,
> UArray Int Int,
> Int
> )
>
> 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
> -> STUArray s Int Int
> -> STUArray s Int Int
> -> STUArray s Int Int
> -> STUArray s Int Int
> -> [TableEntry]
> -> Int
> -> ST s Int
>
> 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
>
>
>
>
> 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 (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero)
>
> fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_))
> max_off fst_zero = do
>
>
>
> 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
>
>
>
> 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)
>
> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int
> findFreeOffset off table off_arr state = do
>
> if off == 0 then try_next else do
>
>
> b <- readArray off_arr off
> if b /= 0 then try_next else do
>
>
> 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')