> 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 :: ti -> HappyAbsSyn ti tj tk ... happyIn x = unsafeCoerce# x {-# INLINE happyIn #-} happyOut :: HappyAbsSyn ti tj tk ... -> tn happyOut x = unsafeCoerce# x {-# INLINE happyOut #-} > | 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" ( <> ) : 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')