1----------------------------------------------------------------------------- 2The code generator. 3 4(c) 1993-2001 Andy Gill, Simon Marlow 5----------------------------------------------------------------------------- 6 7> module ProduceCode (produceParser) where 8 9> import Paths_happy ( version ) 10> import Data.Version ( showVersion ) 11> import Grammar 12> import Target ( Target(..) ) 13> import GenUtils ( mapDollarDollar, str, char, nl, strspace, 14> interleave, interleave', maybestr, 15> brack, brack' ) 16 17> import Data.Maybe ( isJust, isNothing, fromMaybe ) 18> import Data.Char 19> import Data.List 20 21> import Control.Monad ( forM_ ) 22> import Control.Monad.ST 23> import Data.Bits ( setBit ) 24> import Data.Array.ST ( STUArray ) 25> import Data.Array.Unboxed ( UArray ) 26> import Data.Array.MArray 27> import Data.Array.IArray 28 29%----------------------------------------------------------------------------- 30Produce the complete output file. 31 32> produceParser :: Grammar -- grammar info 33> -> ActionTable -- action table 34> -> GotoTable -- goto table 35> -> String -- stuff to go at the top 36> -> Maybe String -- module header 37> -> Maybe String -- module trailer 38> -> Target -- type of code required 39> -> Bool -- use coercions 40> -> Bool -- use ghc extensions 41> -> Bool -- strict parser 42> -> String 43 44> produceParser (Grammar 45> { productions = prods 46> , non_terminals = nonterms 47> , terminals = terms 48> , types = nt_types 49> , first_nonterm = first_nonterm' 50> , eof_term = eof 51> , first_term = fst_term 52> , token_names = token_names' 53> , lexer = lexer' 54> , imported_identity = imported_identity' 55> , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return) 56> , token_specs = token_rep 57> , token_type = token_type' 58> , starts = starts' 59> , error_handler = error_handler' 60> , error_sig = error_sig' 61> , attributetype = attributetype' 62> , attributes = attributes' 63> }) 64> action goto top_options module_header module_trailer 65> target coerce ghc strict 66> = ( top_opts 67> . maybestr module_header . nl 68> . str comment 69> -- comment goes *after* the module header, so that we 70> -- don't screw up any OPTIONS pragmas in the header. 71> . produceAbsSynDecl . nl 72> . produceTypes 73> . produceExpListPerState 74> . produceActionTable target 75> . produceReductions 76> . produceTokenConverter . nl 77> . produceIdentityStuff 78> . produceMonadStuff 79> . produceEntries 80> . produceStrict strict 81> . produceAttributes attributes' attributetype' . nl 82> . maybestr module_trailer . nl 83> ) "" 84> where 85> n_starts = length starts' 86> token = brack token_type' 87> 88> nowarn_opts = str "{-# OPTIONS_GHC -w #-}" . nl 89> -- XXX Happy-generated code is full of warnings. Some are easy to 90> -- fix, others not so easy, and others would require GHC version 91> -- #ifdefs. For now I'm just disabling all of them. 92> 93> partTySigs_opts = ifGeGhc710 (str "{-# OPTIONS_GHC -XPartialTypeSignatures #-}" . nl) 94> 95> intMaybeHash | ghc = str "Happy_GHC_Exts.Int#" 96> | otherwise = str "Prelude.Int" 97> 98> -- Parsing monad and its constraints 99> pty = str monad_tycon 100> pcont = str monad_context 101> 102> -- If GHC is enabled, wrap the content in a CPP ifdef that includes the 103> -- content and tests whether the GHC version is >= 7.10.3 104> ifGeGhc710 :: (String -> String) -> String -> String 105> ifGeGhc710 content | ghc = str "#if __GLASGOW_HASKELL__ >= 710" . nl 106> . content 107> . str "#endif" . nl 108> | otherwise = id 109> 110> n_missing_types = length (filter isNothing (elems nt_types)) 111> happyAbsSyn = str "(HappyAbsSyn " . str wild_tyvars . str ")" 112> where wild_tyvars = unwords (replicate n_missing_types "_") 113> 114> -- This decides how to include (if at all) a type signature 115> -- See <https://github.com/simonmar/happy/issues/94> 116> filterTypeSig :: (String -> String) -> String -> String 117> filterTypeSig content | n_missing_types == 0 = content 118> | otherwise = ifGeGhc710 content 119> 120> top_opts = 121> nowarn_opts 122> . (case top_options of 123> "" -> str "" 124> _ -> str (unwords [ "{-# OPTIONS" 125> , top_options 126> , "#-}" 127> ]) . nl) 128> . partTySigs_opts 129 130%----------------------------------------------------------------------------- 131Make the abstract syntax type declaration, of the form: 132 133data HappyAbsSyn a t1 .. tn 134 = HappyTerminal a 135 | HappyAbsSyn1 t1 136 ... 137 | HappyAbsSynn tn 138 139> produceAbsSynDecl 140 141If we're using coercions, we need to generate the injections etc. 142 143 data HappyAbsSyn ti tj tk ... = HappyAbsSyn 144 145(where ti, tj, tk are type variables for the non-terminals which don't 146 have type signatures). 147 148 newtype HappyWrap<n> = HappyWrap<n> ti 149 happyIn<n> :: ti -> HappyAbsSyn ti tj tk ... 150 happyIn<n> x = unsafeCoerce# (HappyWrap<n> x) 151 {-# INLINE happyIn<n> #-} 152 153 happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn 154 happyOut<n> x = unsafeCoerce# x 155 {-# INLINE happyOut<n> #-} 156 157> | coerce 158> = let 159> happy_item = str "HappyAbsSyn " . str_tyvars 160> bhappy_item = brack' happy_item 161> 162> inject n ty 163> = (case ty of 164> Nothing -> id 165> Just tystr -> str "newtype " . mkHappyWrap n . str " = " . mkHappyWrap n . strspace . brack tystr . nl) 166> . mkHappyIn n . str " :: " . typeParam n ty 167> . str " -> " . bhappy_item . char '\n' 168> . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce#" . strspace 169> . mkHappyWrapCon ty n (str "x") 170> . nl 171> . str "{-# INLINE " . mkHappyIn n . str " #-}" 172> 173> extract n ty 174> = mkHappyOut n . str " :: " . bhappy_item 175> . str " -> " . typeParamOut n ty . char '\n' 176> . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" 177> . str "{-# INLINE " . mkHappyOut n . str " #-}" 178> in 179> str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below 180> . interleave "\n" (map str 181> [ "#if __GLASGOW_HASKELL__ >= 607", 182> "type HappyAny = Happy_GHC_Exts.Any", 183> "#else", 184> "type HappyAny = forall a . a", 185> "#endif" ]) 186> . interleave "\n" 187> [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ] 188> -- token injector 189> . str "happyInTok :: " . token . str " -> " . bhappy_item 190> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n" 191> -- token extractor 192> . str "happyOutTok :: " . bhappy_item . str " -> " . token 193> . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n" 194 195> . str "\n" 196 197NOTE: in the coerce case we always coerce all the semantic values to 198HappyAbsSyn which is declared to be a synonym for Any. This is the 199type that GHC officially knows nothing about - it's the same type used 200to implement Dynamic. (in GHC 6.6 and older, Any didn't exist, so we 201use the closest approximation namely forall a . a). 202 203It's vital that GHC doesn't know anything about this type, because it 204will use any knowledge it has to optimise, and if the knowledge is 205false then the optimisation may also be false. Previously we used (() 206-> ()) as the type here, but this led to bogus optimisations (see GHC 207ticket #1616). 208 209Also, note that we must use a newtype instead of just a type synonym, 210because the otherwise the type arguments to the HappyAbsSyn type 211constructor will lose information. See happy/tests/bug001 for an 212example where this matters. 213 214... Otherwise, output the declaration in full... 215 216> | otherwise 217> = str "data HappyAbsSyn " . str_tyvars 218> . str "\n\t= HappyTerminal " . token 219> . str "\n\t| HappyErrorToken Prelude.Int\n" 220> . interleave "\n" 221> [ str "\t| " . makeAbsSynCon n . strspace . typeParam n ty 222> | (n, ty) <- assocs nt_types, 223> (nt_types_index ! n) == n] 224 225> where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ] 226> str_tyvars = str (unwords all_tyvars) 227 228%----------------------------------------------------------------------------- 229Type declarations of the form: 230 231type HappyReduction a b = .... 232action_0, action_1 :: Int -> HappyReduction a b 233reduction_1, ... :: HappyReduction a b 234 235These are only generated if types for *all* rules are given (and not for array 236based parsers -- types aren't as important there). 237 238> produceTypes 239> | target == TargetArrayBased = id 240 241> | all isJust (elems nt_types) = 242> happyReductionDefinition . str "\n\n" 243> . interleave' ",\n " 244> [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ] 245> (assocs action) ] 246> . str " :: " . str monad_context . str " => " 247> . intMaybeHash . str " -> " . happyReductionValue . str "\n\n" 248> . interleave' ",\n " 249> [ mkReduceFun i | 250> (i,_action) <- zip [ n_starts :: Int .. ] 251> (drop n_starts prods) ] 252> . str " :: " . str monad_context . str " => " 253> . happyReductionValue . str "\n\n" 254 255> | otherwise = id 256 257> where tokens = 258> case lexer' of 259> Nothing -> char '[' . token . str "] -> " 260> Just _ -> id 261> happyReductionDefinition = 262> str "{- to allow type-synonyms as our monads (likely\n" 263> . str " - with explicitly-specified bind and return)\n" 264> . str " - in Haskell98, it seems that with\n" 265> . str " - /type M a = .../, then /(HappyReduction M)/\n" 266> . str " - is not allowed. But Happy is a\n" 267> . str " - code-generator that can just substitute it.\n" 268> . str "type HappyReduction m = " 269> . happyReduction (str "m") 270> . str "\n-}" 271> happyReductionValue = 272> str "({-" 273> . str "HappyReduction " 274> . brack monad_tycon 275> . str " = -}" 276> . happyReduction (brack monad_tycon) 277> . str ")" 278> happyReduction m = 279> str "\n\t " 280> . intMaybeHash 281> . str " \n\t-> " . token 282> . str "\n\t-> HappyState " 283> . token 284> . str " (HappyStk HappyAbsSyn -> " . tokens . result 285> . str ")\n\t" 286> . str "-> [HappyState " 287> . token 288> . str " (HappyStk HappyAbsSyn -> " . tokens . result 289> . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> " 290> . tokens 291> . result 292> where result = m . str " HappyAbsSyn" 293 294%----------------------------------------------------------------------------- 295Next, the reduction functions. Each one has the following form: 296 297happyReduce_n_m = happyReduce n m reduction where { 298 reduction ( 299 (HappyAbsSynX | HappyTerminal) happy_var_1 : 300 .. 301 (HappyAbsSynX | HappyTerminal) happy_var_q : 302 happyRest) 303 = HappyAbsSynY 304 ( <<user supplied string>> ) : happyRest 305 ; reduction _ _ = notHappyAtAll n m 306 307where n is the non-terminal number, and m is the rule number. 308 309NOTES on monad productions. These look like 310 311 happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275 312 happyReduction_275 (happyRest) 313 = happyThen (code) (\r -> happyReturn (HappyAbsSyn r)) 314 315why can't we pass the HappyAbsSyn constructor to happyMonadReduce and 316save duplicating the happyThen/happyReturn in each monad production? 317Because this would require happyMonadReduce to be polymorphic in the 318result type of the monadic action, and since in array-based parsers 319the whole thing is one recursive group, we'd need a type signature on 320happyMonadReduce to get polymorphic recursion. Sigh. 321 322> produceReductions = 323> interleave "\n\n" 324> (zipWith produceReduction (drop n_starts prods) [ n_starts .. ]) 325 326> produceReduction (Production nt toks (code,vars_used) _) i 327 328> | is_monad_prod && (use_monad || imported_identity') 329> = mkReductionHdr (showInt lt) monad_reduce 330> . char '(' . interleave " `HappyStk`\n\t" tokPatterns 331> . str "happyRest) tk\n\t = happyThen (" 332> . str "(" 333> . tokLets (char '(' . str code' . char ')') 334> . str ")" 335> . (if monad_pass_token then str " tk" else id) 336> . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))" 337 338> | specReduceFun lt 339> = mkReductionHdr id ("happySpecReduce_" ++ show lt) 340> . interleave "\n\t" tokPatterns 341> . str " = " 342> . tokLets ( 343> this_absSynCon . str "\n\t\t " 344> . char '(' . str code' . str "\n\t)" 345> ) 346> . (if coerce || null toks || null vars_used then 347> id 348> else 349> nl . reductionFun . strspace 350> . interleave " " (replicate (length toks) (str "_")) 351> . str " = notHappyAtAll ") 352 353> | otherwise 354> = mkReductionHdr (showInt lt) "happyReduce" 355> . char '(' . interleave " `HappyStk`\n\t" tokPatterns 356> . str "happyRest)\n\t = " 357> . tokLets 358> ( this_absSynCon . str "\n\t\t " 359> . char '(' . str code'. str "\n\t) `HappyStk` happyRest" 360> ) 361 362> where 363> (code', is_monad_prod, monad_pass_token, monad_reduce) 364> = case code of 365> '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce") 366> '%':'^':code1 -> (code1, True, True, "happyMonadReduce") 367> '%':code1 -> (code1, True, False, "happyMonadReduce") 368> _ -> (code, False, False, "") 369 370> -- adjust the nonterminal number for the array-based parser 371> -- so that nonterminals start at zero. 372> adjusted_nt | target == TargetArrayBased = nt - first_nonterm' 373> | otherwise = nt 374> 375> mkReductionHdr lt' s = 376> let tysig = case lexer' of 377> Nothing -> id 378> _ | target == TargetArrayBased -> 379> mkReduceFun i . str " :: " . pcont 380> . str " => " . intMaybeHash 381> . str " -> " . str token_type' 382> . str " -> " . intMaybeHash 383> . str " -> Happy_IntList -> HappyStk " 384> . happyAbsSyn . str " -> " 385> . pty . str " " . happyAbsSyn . str "\n" 386> | otherwise -> id in 387> filterTypeSig tysig . mkReduceFun i . str " = " 388> . str s . strspace . lt' . strspace . showInt adjusted_nt 389> . strspace . reductionFun . nl 390> . reductionFun . strspace 391> 392> reductionFun = str "happyReduction_" . shows i 393> 394> tokPatterns 395> | coerce = reverse (map mkDummyVar [1 .. length toks]) 396> | otherwise = reverse (zipWith tokPattern [1..] toks) 397> 398> tokPattern n _ | n `notElem` vars_used = char '_' 399> tokPattern n t | t >= firstStartTok && t < fst_term 400> = if coerce 401> then mkHappyWrapCon (nt_types ! t) t (mkHappyVar n) 402> else brack' ( 403> makeAbsSynCon t . str " " . mkHappyVar n 404> ) 405> tokPattern n t 406> = if coerce 407> then mkHappyTerminalVar n t 408> else str "(HappyTerminal " 409> . mkHappyTerminalVar n t 410> . char ')' 411> 412> tokLets code'' 413> | coerce && not (null cases) 414> = interleave "\n\t" cases 415> . code'' . str (replicate (length cases) '}') 416> | otherwise = code'' 417> 418> cases = [ str "case " . extract t . strspace . mkDummyVar n 419> . str " of { " . tokPattern n t . str " -> " 420> | (n,t) <- zip [1..] toks, 421> n `elem` vars_used ] 422> 423> extract t | t >= firstStartTok && t < fst_term = mkHappyOut t 424> | otherwise = str "happyOutTok" 425> 426> lt = length toks 427 428> this_absSynCon | coerce = mkHappyIn nt 429> | otherwise = makeAbsSynCon nt 430 431%----------------------------------------------------------------------------- 432The token conversion function. 433 434> produceTokenConverter 435> = case lexer' of { 436> 437> Nothing -> 438> str "happyNewToken action sts stk [] =\n\t" 439> . eofAction "notHappyAtAll" 440> . str " []\n\n" 441> . str "happyNewToken action sts stk (tk:tks) =\n\t" 442> . str "let cont i = " . doAction . str " sts stk tks in\n\t" 443> . str "case tk of {\n\t" 444> . interleave ";\n\t" (map doToken token_rep) 445> . str "_ -> happyError' ((tk:tks), [])\n\t" 446> . str "}\n\n" 447> . str "happyError_ explist " . eofTok . str " tk tks = happyError' (tks, explist)\n" 448> . str "happyError_ explist _ tk tks = happyError' ((tk:tks), explist)\n"; 449> -- when the token is EOF, tk == _|_ (notHappyAtAll) 450> -- so we must not pass it to happyError' 451 452> Just (lexer'',eof') -> 453> case (target, ghc) of 454> (TargetHaskell, True) -> 455> str "happyNewToken :: " . pcont . str " => " 456> . str "(Happy_GHC_Exts.Int#\n" 457> . str " -> Happy_GHC_Exts.Int#\n" 458> . str " -> " . token . str "\n" 459> . str " -> HappyState " . token . str " (t -> " 460> . pty . str " a)\n" 461> . str " -> [HappyState " . token . str " (t -> " 462> . pty . str " a)]\n" 463> . str " -> t\n" 464> . str " -> " . pty . str " a)\n" 465> . str " -> [HappyState " . token . str " (t -> " 466> . pty . str " a)]\n" 467> . str " -> t\n" 468> . str " -> " . pty . str " a\n" 469> _ -> id 470> . str "happyNewToken action sts stk\n\t= " 471> . str lexer'' 472> . str "(\\tk -> " 473> . str "\n\tlet cont i = " 474> . doAction 475> . str " sts stk in\n\t" 476> . str "case tk of {\n\t" 477> . str (eof' ++ " -> ") 478> . eofAction "tk" . str ";\n\t" 479> . interleave ";\n\t" (map doToken token_rep) 480> . str "_ -> happyError' (tk, [])\n\t" 481> . str "})\n\n" 482> . str "happyError_ explist " . eofTok . str " tk = happyError' (tk, explist)\n" 483> . str "happyError_ explist _ tk = happyError' (tk, explist)\n"; 484> -- superfluous pattern match needed to force happyError_ to 485> -- have the correct type. 486> } 487 488> where 489 490> eofAction tk = 491> (case target of 492> TargetArrayBased -> 493> str "happyDoAction " . eofTok . strspace . str tk . str " action" 494> _ -> str "action " . eofTok . strspace . eofTok 495> . strspace . str tk . str " (HappyState action)") 496> . str " sts stk" 497> eofTok = showInt (tokIndex eof) 498> 499> doAction = case target of 500> TargetArrayBased -> str "happyDoAction i tk action" 501> _ -> str "action i i tk (HappyState action)" 502> 503> doToken (i,tok) 504> = str (removeDollarDollar tok) 505> . str " -> cont " 506> . showInt (tokIndex i) 507 508Use a variable rather than '_' to replace '$$', so we can use it on 509the left hand side of '@'. 510 511> removeDollarDollar xs = case mapDollarDollar xs of 512> Nothing -> xs 513> Just fn -> fn "happy_dollar_dollar" 514 515> mkHappyTerminalVar :: Int -> Int -> String -> String 516> mkHappyTerminalVar i t = 517> case tok_str_fn of 518> Nothing -> pat 519> Just fn -> brack (fn (pat [])) 520> where 521> tok_str_fn = case lookup t token_rep of 522> Nothing -> Nothing 523> Just str' -> mapDollarDollar str' 524> pat = mkHappyVar i 525 526> tokIndex 527> = case target of 528> TargetHaskell -> id 529> TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2 530> -- tokens adjusted to start at zero, see ARRAY_NOTES 531 532%----------------------------------------------------------------------------- 533Action Tables. 534 535Here we do a bit of trickery and replace the normal default action 536(failure) for each state with at least one reduction action. For each 537such state, we pick one reduction action to be the default action. 538This should make the code smaller without affecting the speed. It 539changes the sematics for errors, however; errors could be detected in 540a different state now (but they'll still be detected at the same point 541in the token stream). 542 543Further notes on default cases: 544 545Default reductions are important when error recovery is considered: we 546don't allow reductions whilst in error recovery, so we'd like the 547parser to automatically reduce down to a state where the error token 548can be shifted before entering error recovery. This is achieved by 549using default reductions wherever possible. 550 551One case to consider is: 552 553State 345 554 555 con -> conid . (rule 186) 556 qconid -> conid . (rule 212) 557 558 error reduce using rule 212 559 '{' reduce using rule 186 560 etc. 561 562we should make reduce_212 the default reduction here. So the rules become: 563 564 * if there is a production 565 error -> reduce_n 566 then make reduce_n the default action. 567 * if there is a non-reduce action for the error token, the default action 568 for this state must be "fail". 569 * otherwise pick the most popular reduction in this state for the default. 570 * if there are no reduce actions in this state, then the default 571 action remains 'enter error recovery'. 572 573This gives us an invariant: there won't ever be a production of the 574type 'error -> reduce_n' explicitly in the grammar, which means that 575whenever an unexpected token occurs, either the parser will reduce 576straight back to a state where the error token can be shifted, or if 577none exists, we'll get a parse error. In theory, we won't need the 578machinery to discard states in the parser... 579 580> produceActionTable TargetHaskell 581> = foldr (.) id (map (produceStateFunction goto) (assocs action)) 582> 583> produceActionTable TargetArrayBased 584> = produceActionArray 585> . produceReduceArray 586> . str "happy_n_terms = " . shows n_terminals . str " :: Prelude.Int\n" 587> . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Prelude.Int\n\n" 588> 589> produceExpListPerState 590> = produceExpListArray 591> . str "{-# NOINLINE happyExpListPerState #-}\n" 592> . str "happyExpListPerState st =\n" 593> . str " token_strs_expected\n" 594> . str " where token_strs = " . str (show $ elems token_names') . str "\n" 595> . str " bit_start = st Prelude.* " . str (show nr_tokens) . str "\n" 596> . str " bit_end = (st Prelude.+ 1) Prelude.* " . str (show nr_tokens) . str "\n" 597> . str " read_bit = readArrayBit happyExpList\n" 598> . str " bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]\n" 599> . str " bits_indexed = Prelude.zip bits [0.." 600> . str (show (nr_tokens - 1)) . str "]\n" 601> . str " token_strs_expected = Prelude.concatMap f bits_indexed\n" 602> . str " f (Prelude.False, _) = []\n" 603> . str " f (Prelude.True, nr) = [token_strs Prelude.!! nr]\n" 604> . str "\n" 605> where (first_token, last_token) = bounds token_names' 606> nr_tokens = last_token - first_token + 1 607> 608> produceStateFunction goto' (state, acts) 609> = foldr (.) id (map produceActions assocs_acts) 610> . foldr (.) id (map produceGotos (assocs gotos)) 611> . mkActionName state 612> . (if ghc 613> then str " x = happyTcHack x " 614> else str " _ = ") 615> . mkAction default_act 616> . (case default_act of 617> LR'Fail -> callHappyExpListPerState 618> LR'MustFail -> callHappyExpListPerState 619> _ -> str "") 620> . str "\n\n" 621> 622> where gotos = goto' ! state 623> 624> callHappyExpListPerState = str " (happyExpListPerState " 625> . str (show state) . str ")" 626> 627> produceActions (_, LR'Fail{-'-}) = id 628> produceActions (t, action'@(LR'Reduce{-'-} _ _)) 629> | action' == default_act = id 630> | otherwise = producePossiblyFailingAction t action' 631> produceActions (t, action') 632> = producePossiblyFailingAction t action' 633> 634> producePossiblyFailingAction t action' 635> = actionFunction t 636> . mkAction action' 637> . (case action' of 638> LR'Fail -> str " []" 639> LR'MustFail -> str " []" 640> _ -> str "") 641> . str "\n" 642> 643> produceGotos (t, Goto i) 644> = actionFunction t 645> . str "happyGoto " . mkActionName i . str "\n" 646> produceGotos (_, NoGoto) = id 647> 648> actionFunction t 649> = mkActionName state . strspace 650> . ('(' :) . showInt t 651> . str ") = " 652> 653> default_act = getDefault assocs_acts 654> 655> assocs_acts = assocs acts 656 657action array indexed by (terminal * last_state) + state 658 659> produceActionArray 660> | ghc 661> = str "happyActOffsets :: HappyAddr\n" 662> . str "happyActOffsets = HappyA# \"" --" 663> . str (checkedHexChars min_off act_offs) 664> . str "\"#\n\n" --" 665> 666> . str "happyGotoOffsets :: HappyAddr\n" 667> . str "happyGotoOffsets = HappyA# \"" --" 668> . str (checkedHexChars min_off goto_offs) 669> . str "\"#\n\n" --" 670> 671> . str "happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int#\n" 672> . str "happyAdjustOffset off = " 673> . (if length table < 32768 674> then str "off" 675> else str "if happyLt off (" . shows min_off . str "# :: Happy_GHC_Exts.Int#)" 676> . str " then off Happy_GHC_Exts.+# 65536#" 677> . str " else off") 678> . str "\n\n" --" 679> 680> . str "happyDefActions :: HappyAddr\n" 681> . str "happyDefActions = HappyA# \"" --" 682> . str (hexChars defaults) 683> . str "\"#\n\n" --" 684> 685> . str "happyCheck :: HappyAddr\n" 686> . str "happyCheck = HappyA# \"" --" 687> . str (hexChars check) 688> . str "\"#\n\n" --" 689> 690> . str "happyTable :: HappyAddr\n" 691> . str "happyTable = HappyA# \"" --" 692> . str (hexChars table) 693> . str "\"#\n\n" --" 694 695> | otherwise 696> = str "happyActOffsets :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" 697> . str "happyActOffsets = Happy_Data_Array.listArray (0," 698> . shows n_states . str ") ([" 699> . interleave' "," (map shows act_offs) 700> . str "\n\t])\n\n" 701> 702> . str "happyGotoOffsets :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" 703> . str "happyGotoOffsets = Happy_Data_Array.listArray (0," 704> . shows n_states . str ") ([" 705> . interleave' "," (map shows goto_offs) 706> . str "\n\t])\n\n" 707> 708> . str "happyAdjustOffset :: Prelude.Int -> Prelude.Int\n" 709> . str "happyAdjustOffset = Prelude.id\n\n" 710> 711> . str "happyDefActions :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" 712> . str "happyDefActions = Happy_Data_Array.listArray (0," 713> . shows n_states . str ") ([" 714> . interleave' "," (map shows defaults) 715> . str "\n\t])\n\n" 716> 717> . str "happyCheck :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" 718> . str "happyCheck = Happy_Data_Array.listArray (0," 719> . shows table_size . str ") ([" 720> . interleave' "," (map shows check) 721> . str "\n\t])\n\n" 722> 723> . str "happyTable :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" 724> . str "happyTable = Happy_Data_Array.listArray (0," 725> . shows table_size . str ") ([" 726> . interleave' "," (map shows table) 727> . str "\n\t])\n\n" 728 729> produceExpListArray 730> | ghc 731> = str "happyExpList :: HappyAddr\n" 732> . str "happyExpList = HappyA# \"" --" 733> . str (hexChars explist) 734> . str "\"#\n\n" --" 735> | otherwise 736> = str "happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int\n" 737> . str "happyExpList = Happy_Data_Array.listArray (0," 738> . shows table_size . str ") ([" 739> . interleave' "," (map shows explist) 740> . str "\n\t])\n\n" 741 742> (_, last_state) = bounds action 743> n_states = last_state + 1 744> n_terminals = length terms 745> n_nonterminals = length nonterms - n_starts -- lose %starts 746> 747> (act_offs,goto_offs,table,defaults,check,explist,min_off) 748> = mkTables action goto first_nonterm' fst_term 749> n_terminals n_nonterminals n_starts (bounds token_names') 750> 751> table_size = length table - 1 752> 753> produceReduceArray 754> = {- str "happyReduceArr :: Array Int a\n" -} 755> str "happyReduceArr = Happy_Data_Array.array (" 756> . shows (n_starts :: Int) -- omit the %start reductions 757> . str ", " 758> . shows n_rules 759> . str ") [\n" 760> . interleave' ",\n" (map reduceArrElem [n_starts..n_rules]) 761> . str "\n\t]\n\n" 762 763> n_rules = length prods - 1 :: Int 764 765> showInt i | ghc = shows i . showChar '#' 766> | otherwise = shows i 767 768This lets examples like: 769 770 data HappyAbsSyn t1 771 = HappyTerminal ( HaskToken ) 772 | HappyAbsSyn1 ( HaskExp ) 773 | HappyAbsSyn2 ( HaskExp ) 774 | HappyAbsSyn3 t1 775 776*share* the defintion for ( HaskExp ) 777 778 data HappyAbsSyn t1 779 = HappyTerminal ( HaskToken ) 780 | HappyAbsSyn1 ( HaskExp ) 781 | HappyAbsSyn3 t1 782 783... cuting down on the work that the type checker has to do. 784 785Note, this *could* introduce lack of polymophism, 786for types that have alphas in them. Maybe we should 787outlaw them inside { } 788 789> nt_types_index :: Array Int Int 790> nt_types_index = array (bounds nt_types) 791> [ (a, fn a b) | (a, b) <- assocs nt_types ] 792> where 793> fn n Nothing = n 794> fn _ (Just a) = fromMaybe (error "can't find an item in list") (lookup a assoc_list) 795> assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ] 796 797> makeAbsSynCon = mkAbsSynCon nt_types_index 798 799 800> produceIdentityStuff | use_monad = id 801> | imported_identity' = 802> str "type HappyIdentity = Identity\n" 803> . str "happyIdentity = Identity\n" 804> . str "happyRunIdentity = runIdentity\n\n" 805> | otherwise = 806> str "newtype HappyIdentity a = HappyIdentity a\n" 807> . str "happyIdentity = HappyIdentity\n" 808> . str "happyRunIdentity (HappyIdentity a) = a\n\n" 809> . str "instance Prelude.Functor HappyIdentity where\n" 810> . str " fmap f (HappyIdentity a) = HappyIdentity (f a)\n\n" 811> . str "instance Applicative HappyIdentity where\n" 812> . str " pure = HappyIdentity\n" 813> . str " (<*>) = ap\n" 814> . str "instance Prelude.Monad HappyIdentity where\n" 815> . str " return = pure\n" 816> . str " (HappyIdentity p) >>= q = q p\n\n" 817 818MonadStuff: 819 820 - with no %monad or %lexer: 821 822 happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b 823 happyReturn :: () => a -> HappyIdentity a 824 happyThen1 m k tks = happyThen m (\a -> k a tks) 825 happyReturn1 = \a tks -> happyReturn a 826 827 - with %monad: 828 829 happyThen :: CONTEXT => P a -> (a -> P b) -> P b 830 happyReturn :: CONTEXT => a -> P a 831 happyThen1 m k tks = happyThen m (\a -> k a tks) 832 happyReturn1 = \a tks -> happyReturn a 833 834 - with %monad & %lexer: 835 836 happyThen :: CONTEXT => P a -> (a -> P b) -> P b 837 happyReturn :: CONTEXT => a -> P a 838 happyThen1 = happyThen 839 happyReturn1 = happyReturn 840 841 842> produceMonadStuff = 843> str "happyThen :: " . pcont . str " => " . pty 844> . str " a -> (a -> " . pty 845> . str " b) -> " . pty . str " b\n" 846> . str "happyThen = " . brack monad_then . nl 847> . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n" 848> . str "happyReturn = " . brack monad_return . nl 849> . case lexer' of 850> Nothing -> 851> str "happyThen1 m k tks = (" . str monad_then 852> . str ") m (\\a -> k a tks)\n" 853> . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n" 854> . str "happyReturn1 = \\a tks -> " . brack monad_return 855> . str " a\n" 856> . str "happyError' :: " . str monad_context . str " => ([" 857> . token 858> . str "], [Prelude.String]) -> " 859> . str monad_tycon 860> . str " a\n" 861> . str "happyError' = " 862> . str (if use_monad then "" else "HappyIdentity Prelude.. ") 863> . errorHandler . str "\n" 864> _ -> 865> let 866> happyParseSig 867> | target == TargetArrayBased = 868> str "happyParse :: " . pcont . str " => " . intMaybeHash 869> . str " -> " . pty . str " " . happyAbsSyn . str "\n" 870> . str "\n" 871> | otherwise = id 872> newTokenSig 873> | target == TargetArrayBased = 874> str "happyNewToken :: " . pcont . str " => " . intMaybeHash 875> . str " -> Happy_IntList -> HappyStk " . happyAbsSyn 876> . str " -> " . pty . str " " . happyAbsSyn . str"\n" 877> . str "\n" 878> | otherwise = id 879> doActionSig 880> | target == TargetArrayBased = 881> str "happyDoAction :: " . pcont . str " => " . intMaybeHash 882> . str " -> " . str token_type' . str " -> " . intMaybeHash 883> . str " -> Happy_IntList -> HappyStk " . happyAbsSyn 884> . str " -> " . pty . str " " . happyAbsSyn . str "\n" 885> . str "\n" 886> | otherwise = id 887> reduceArrSig 888> | target == TargetArrayBased = 889> str "happyReduceArr :: " . pcont 890> . str " => Happy_Data_Array.Array Prelude.Int (" . intMaybeHash 891> . str " -> " . str token_type' . str " -> " . intMaybeHash 892> . str " -> Happy_IntList -> HappyStk " . happyAbsSyn 893> . str " -> " . pty . str " " . happyAbsSyn . str ")\n" 894> . str "\n" 895> | otherwise = id in 896> filterTypeSig (happyParseSig . newTokenSig . doActionSig . reduceArrSig) 897> . str "happyThen1 :: " . pcont . str " => " . pty 898> . str " a -> (a -> " . pty 899> . str " b) -> " . pty . str " b\n" 900> . str "happyThen1 = happyThen\n" 901> . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n" 902> . str "happyReturn1 = happyReturn\n" 903> . str "happyError' :: " . str monad_context . str " => (" 904> . token . str ", [Prelude.String]) -> " 905> . str monad_tycon 906> . str " a\n" 907> . str "happyError' tk = " 908> . str (if use_monad then "" else "HappyIdentity ") 909> . errorHandler . str " tk\n" 910 911An error handler specified with %error is passed the current token 912when used with %lexer, but happyError (the old way but kept for 913compatibility) is not passed the current token. Also, the %errorhandlertype 914directive determins the API of the provided function. 915 916> errorHandler = 917> case error_handler' of 918> Just h -> case error_sig' of 919> ErrorHandlerTypeExpList -> str h 920> ErrorHandlerTypeDefault -> str "(\\(tokens, _) -> " . str h . str " tokens)" 921> Nothing -> case lexer' of 922> Nothing -> str "(\\(tokens, _) -> happyError tokens)" 923> Just _ -> str "(\\(tokens, explist) -> happyError)" 924 925> reduceArrElem n 926> = str "\t(" . shows n . str " , " 927> . str "happyReduce_" . shows n . char ')' 928 929----------------------------------------------------------------------------- 930-- Produce the parser entry and exit points 931 932> produceEntries 933> = interleave "\n\n" (map produceEntry (zip starts' [0..])) 934> . if null attributes' then id else produceAttrEntries starts' 935 936> produceEntry :: ((String, t0, Int, t1), Int) -> String -> String 937> produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no) 938> = (if null attributes' then str name else str "do_" . str name) 939> . maybe_tks 940> . str " = " 941> . str unmonad 942> . str "happySomeParser where\n" 943> . str " happySomeParser = happyThen (happyParse " 944> . case target of 945> TargetHaskell -> str "action_" . shows no 946> TargetArrayBased 947> | ghc -> shows no . str "#" 948> | otherwise -> shows no 949> . maybe_tks 950> . str ") " 951> . brack' (if coerce 952> then str "\\x -> happyReturn (let {" . mkHappyWrapCon (nt_types ! accept_nonterm) accept_nonterm (str "x'") 953> . str " = " . mkHappyOut accept_nonterm . str " x} in x')" 954> else str "\\x -> case x of {HappyAbsSyn" 955> . shows (nt_types_index ! accept_nonterm) 956> . str " z -> happyReturn z; _other -> notHappyAtAll }" 957> ) 958> where 959> maybe_tks | isNothing lexer' = str " tks" 960> | otherwise = id 961> unmonad | use_monad = "" 962> | otherwise = "happyRunIdentity " 963 964> produceAttrEntries starts'' 965> = interleave "\n\n" (map f starts'') 966> where 967> f = case (use_monad,lexer') of 968> (True,Just _) -> \(name,_,_,_) -> monadAndLexerAE name 969> (True,Nothing) -> \(name,_,_,_) -> monadAE name 970> (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer" 971> (False,Nothing)-> \(name,_,_,_) -> regularAE name 972> 973> defaultAttr = fst (head attributes') 974> 975> monadAndLexerAE name 976> = str name . str " = " 977> . str "do { " 978> . str "f <- do_" . str name . str "; " 979> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " 980> . str "Prelude.sequence_ conds; " 981> . str "Prelude.return (". str defaultAttr . str " attrs) }}" 982> monadAE name 983> = str name . str " toks = " 984> . str "do { " 985> . str "f <- do_" . str name . str " toks; " 986> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " 987> . str "Prelude.sequence_ conds; " 988> . str "Prelude.return (". str defaultAttr . str " attrs) }}" 989> regularAE name 990> = str name . str " toks = " 991> . str "let { " 992> . str "f = do_" . str name . str " toks; " 993> . str "(conds,attrs) = f happyEmptyAttrs; " 994> . str "x = Prelude.foldr Prelude.seq attrs conds; " 995> . str "} in (". str defaultAttr . str " x)" 996 997---------------------------------------------------------------------------- 998-- Produce attributes declaration for attribute grammars 999 1000> produceAttributes :: [(String, String)] -> String -> String -> String 1001> produceAttributes [] _ = id 1002> produceAttributes attrs attributeType 1003> = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl 1004> . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl 1005 1006> where attributes' = foldl1 (\x y -> x . str ", " . y) $ map formatAttribute attrs 1007> formatAttribute (ident,typ) = str ident . str " :: " . str typ 1008> attrsErrors = foldl1 (\x y -> x . str ", " . y) $ map attrError attrs 1009> attrError (ident,_) = str ident . str " = Prelude.error \"invalid reference to attribute '" . str ident . str "'\"" 1010> attrHeader = 1011> case attributeType of 1012> [] -> str "HappyAttributes" 1013> _ -> str attributeType 1014 1015 1016----------------------------------------------------------------------------- 1017-- Strict or non-strict parser 1018 1019> produceStrict :: Bool -> String -> String 1020> produceStrict strict 1021> | strict = str "happySeq = happyDoSeq\n\n" 1022> | otherwise = str "happySeq = happyDontSeq\n\n" 1023 1024----------------------------------------------------------------------------- 1025Replace all the $n variables with happy_vars, and return a list of all the 1026vars used in this piece of code. 1027 1028> actionVal :: LRAction -> Int 1029> actionVal (LR'Shift state _) = state + 1 1030> actionVal (LR'Reduce rule _) = -(rule + 1) 1031> actionVal LR'Accept = -1 1032> actionVal (LR'Multiple _ a) = actionVal a 1033> actionVal LR'Fail = 0 1034> actionVal LR'MustFail = 0 1035 1036> mkAction :: LRAction -> String -> String 1037> mkAction (LR'Shift i _) = str "happyShift " . mkActionName i 1038> mkAction LR'Accept = str "happyAccept" 1039> mkAction LR'Fail = str "happyFail" 1040> mkAction LR'MustFail = str "happyFail" 1041> mkAction (LR'Reduce i _) = str "happyReduce_" . shows i 1042> mkAction (LR'Multiple _ a) = mkAction a 1043 1044> mkActionName :: Int -> String -> String 1045> mkActionName i = str "action_" . shows i 1046 1047See notes under "Action Tables" above for some subtleties in this function. 1048 1049> getDefault :: [(Name, LRAction)] -> LRAction 1050> getDefault actions = 1051> -- pick out the action for the error token, if any 1052> case [ act | (e, act) <- actions, e == errorTok ] of 1053> 1054> -- use error reduction as the default action, if there is one. 1055> act@(LR'Reduce _ _) : _ -> act 1056> act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act 1057> 1058> -- if the error token is shifted or otherwise, don't generate 1059> -- a default action. This is *important*! 1060> (act : _) | act /= LR'Fail -> LR'Fail 1061> 1062> -- no error actions, pick a reduce to be the default. 1063> _ -> case reduces of 1064> [] -> LR'Fail 1065> (act:_) -> act -- pick the first one we see for now 1066> 1067> where reduces 1068> = [ act | (_, act@(LR'Reduce _ _)) <- actions ] 1069> ++ [ act | (_, LR'Multiple _ act@(LR'Reduce _ _)) <- actions ] 1070 1071----------------------------------------------------------------------------- 1072-- Generate packed parsing tables. 1073 1074-- happyActOff ! state 1075-- Offset within happyTable of actions for state 1076 1077-- happyGotoOff ! state 1078-- Offset within happyTable of gotos for state 1079 1080-- happyTable 1081-- Combined action/goto table 1082 1083-- happyDefAction ! state 1084-- Default action for state 1085 1086-- happyCheck 1087-- Indicates whether we should use the default action for state 1088 1089 1090-- the table is laid out such that the action for a given state & token 1091-- can be found by: 1092-- 1093-- off = happyActOff ! state 1094-- off_i = off + token 1095-- check | off_i => 0 = (happyCheck ! off_i) == token 1096-- | otherwise = False 1097-- action | check = happyTable ! off_i 1098-- | otherwise = happyDefAaction ! off_i 1099 1100 1101-- figure out the default action for each state. This will leave some 1102-- states with no *real* actions left. 1103 1104-- for each state with one or more real actions, sort states by 1105-- width/spread of tokens with real actions, then by number of 1106-- elements with actions, so we get the widest/densest states 1107-- first. (I guess the rationale here is that we can use the 1108-- thin/sparse states to fill in the holes later, and also we 1109-- have to do less searching for the more complicated cases). 1110 1111-- try to pair up states with identical sets of real actions. 1112 1113-- try to fit the actions into the check table, using the ordering 1114-- from above. 1115 1116 1117> mkTables 1118> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int -> (Int, Int) -> 1119> ( [Int] -- happyActOffsets 1120> , [Int] -- happyGotoOffsets 1121> , [Int] -- happyTable 1122> , [Int] -- happyDefAction 1123> , [Int] -- happyCheck 1124> , [Int] -- happyExpList 1125> , Int -- happyMinOffset 1126> ) 1127> 1128> mkTables action goto first_nonterm' fst_term 1129> n_terminals n_nonterminals n_starts 1130> token_names_bound 1131> 1132> = ( elems act_offs 1133> , elems goto_offs 1134> , take max_off (elems table) 1135> , def_actions 1136> , take max_off (elems check) 1137> , elems explist 1138> , min_off 1139> ) 1140> where 1141> 1142> (table,check,act_offs,goto_offs,explist,min_off,max_off) 1143> = runST (genTables (length actions) 1144> max_token token_names_bound 1145> sorted_actions explist_actions) 1146> 1147> -- the maximum token number used in the parser 1148> max_token = max n_terminals (n_starts+n_nonterminals) - 1 1149> 1150> def_actions = map (\(_,_,def,_,_,_) -> def) actions 1151> 1152> actions :: [TableEntry] 1153> actions = 1154> [ (ActionEntry, 1155> state, 1156> actionVal default_act, 1157> if null acts'' then 0 1158> else fst (last acts'') - fst (head acts''), 1159> length acts'', 1160> acts'') 1161> | (state, acts) <- assocs action, 1162> let (err:_dummy:vec) = assocs acts 1163> vec' = drop (n_starts+n_nonterminals) vec 1164> acts' = filter notFail (err:vec') 1165> default_act = getDefault acts' 1166> acts'' = mkActVals acts' default_act 1167> ] 1168> 1169> explist_actions :: [(Int, [Int])] 1170> explist_actions = [ (state, concatMap f $ assocs acts) 1171> | (state, acts) <- assocs action ] 1172> where 1173> f (t, LR'Shift _ _ ) = [t - fst token_names_bound] 1174> f (_, _) = [] 1175> 1176> -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0). 1177> -- (see ARRAY_NOTES) 1178> adjust token | token == errorTok = 0 1179> | otherwise = token - fst_term + 1 1180> 1181> mkActVals assocs' default_act = 1182> [ (adjust token, actionVal act) 1183> | (token, act) <- assocs' 1184> , act /= default_act ] 1185> 1186> gotos :: [TableEntry] 1187> gotos = [ (GotoEntry, 1188> state, 0, 1189> if null goto_vals then 0 1190> else fst (last goto_vals) - fst (head goto_vals), 1191> length goto_vals, 1192> goto_vals 1193> ) 1194> | (state, goto_arr) <- assocs goto, 1195> let goto_vals = mkGotoVals (assocs goto_arr) 1196> ] 1197> 1198> -- adjust nonterminals by -first_nonterm', so they start at zero 1199> -- (see ARRAY_NOTES) 1200> mkGotoVals assocs' = 1201> [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ] 1202> 1203> sorted_actions = sortBy (flip cmp_state) (actions ++ gotos) 1204> cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_) 1205> | width1 < width2 = LT 1206> | width1 == width2 = compare tally1 tally2 1207> | otherwise = GT 1208 1209> data ActionOrGoto = ActionEntry | GotoEntry 1210> type TableEntry = ( ActionOrGoto 1211> , Int {-stateno-} 1212> , Int {-default-} 1213> , Int {-width-} 1214> , Int {-tally-} 1215> , [(Int,Int)] 1216> ) 1217 1218> genTables 1219> :: Int -- number of actions 1220> -> Int -- maximum token no. 1221> -> (Int, Int) -- token names bounds 1222> -> [TableEntry] -- entries for the table 1223> -> [(Int, [Int])] -- expected tokens lists 1224> -> ST s ( UArray Int Int -- table 1225> , UArray Int Int -- check 1226> , UArray Int Int -- action offsets 1227> , UArray Int Int -- goto offsets 1228> , UArray Int Int -- expected tokens list 1229> , Int -- lowest offset in table 1230> , Int -- highest offset in table 1231> ) 1232> 1233> genTables n_actions max_token token_names_bound entries explist = do 1234> 1235> table <- newArray (0, mAX_TABLE_SIZE) 0 1236> check <- newArray (0, mAX_TABLE_SIZE) (-1) 1237> act_offs <- newArray (0, n_actions) 0 1238> goto_offs <- newArray (0, n_actions) 0 1239> off_arr <- newArray (-max_token, mAX_TABLE_SIZE) 0 1240> exp_array <- newArray (0, (n_actions * n_token_names + 15) `div` 16) 0 1241> 1242> (min_off,max_off) <- genTables' table check act_offs goto_offs off_arr exp_array entries 1243> explist max_token n_token_names 1244> 1245> table' <- freeze table 1246> check' <- freeze check 1247> act_offs' <- freeze act_offs 1248> goto_offs' <- freeze goto_offs 1249> exp_array' <- freeze exp_array 1250> return (table',check',act_offs',goto_offs',exp_array',min_off,max_off+1) 1251 1252> where 1253> n_states = n_actions - 1 1254> mAX_TABLE_SIZE = n_states * (max_token + 1) 1255> (first_token, last') = token_names_bound 1256> n_token_names = last' - first_token + 1 1257 1258 1259> genTables' 1260> :: STUArray s Int Int -- table 1261> -> STUArray s Int Int -- check 1262> -> STUArray s Int Int -- action offsets 1263> -> STUArray s Int Int -- goto offsets 1264> -> STUArray s Int Int -- offset array 1265> -> STUArray s Int Int -- expected token list 1266> -> [TableEntry] -- entries for the table 1267> -> [(Int, [Int])] -- expected tokens lists 1268> -> Int -- maximum token no. 1269> -> Int -- number of token names 1270> -> ST s (Int,Int) -- lowest and highest offsets in table 1271> 1272> genTables' table check act_offs goto_offs off_arr exp_array entries 1273> explist max_token n_token_names 1274> = fill_exp_array >> fit_all entries 0 0 1 1275> where 1276> 1277> fit_all [] min_off max_off _ = return (min_off, max_off) 1278> fit_all (s:ss) min_off max_off fst_zero = do 1279> (off, new_min_off, new_max_off, new_fst_zero) <- fit s min_off max_off fst_zero 1280> ss' <- same_states s ss off 1281> writeArray off_arr off 1 1282> fit_all ss' new_min_off new_max_off new_fst_zero 1283> 1284> fill_exp_array = 1285> forM_ explist $ \(state, tokens) -> 1286> forM_ tokens $ \token -> do 1287> let bit_nr = state * n_token_names + token 1288> let word_nr = bit_nr `div` 16 1289> let word_offset = bit_nr `mod` 16 1290> x <- readArray exp_array word_nr 1291> writeArray exp_array word_nr (setBit x word_offset) 1292> 1293> -- try to merge identical states. We only try the next state(s) 1294> -- in the list, but the list is kind-of sorted so we shouldn't 1295> -- miss too many. 1296> same_states _ [] _ = return [] 1297> same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off 1298> | acts == acts' = do writeArray (which_off e) no off 1299> same_states s ss' off 1300> | otherwise = return ss 1301> 1302> which_off ActionEntry = act_offs 1303> which_off GotoEntry = goto_offs 1304> 1305> -- fit a vector into the table. Return the offset of the vector, 1306> -- the maximum offset used in the table, and the offset of the first 1307> -- entry in the table (used to speed up the lookups a bit). 1308> fit (_,_,_,_,_,[]) min_off max_off fst_zero = return (0,min_off,max_off,fst_zero) 1309> 1310> fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_)) 1311> min_off max_off fst_zero = do 1312> -- start at offset 1 in the table: all the empty states 1313> -- (states with just a default reduction) are mapped to 1314> -- offset zero. 1315> off <- findFreeOffset (-t+fst_zero) check off_arr state 1316> let new_min_off | furthest_left < min_off = furthest_left 1317> | otherwise = min_off 1318> new_max_off | furthest_right > max_off = furthest_right 1319> | otherwise = max_off 1320> furthest_left = off 1321> furthest_right = off + max_token 1322> 1323> -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do 1324> 1325> writeArray (which_off act_or_goto) state_no off 1326> addState off table check state 1327> new_fst_zero <- findFstFreeSlot check fst_zero 1328> return (off, new_min_off, new_max_off, new_fst_zero) 1329 1330When looking for a free offest in the table, we use the 'check' table 1331rather than the main table. The check table starts off with (-1) in 1332every slot, because that's the only thing that doesn't overlap with 1333any tokens (non-terminals start at 0, terminals start at 1). 1334 1335Because we use 0 for LR'MustFail as well as LR'Fail, we can't check 1336for free offsets in the main table because we can't tell whether a 1337slot is free or not. 1338 1339> -- Find a valid offset in the table for this state. 1340> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int 1341> findFreeOffset off table off_arr state = do 1342> -- offset 0 isn't allowed 1343> if off == 0 then try_next else do 1344> 1345> -- don't use an offset we've used before 1346> b <- readArray off_arr off 1347> if b /= 0 then try_next else do 1348> 1349> -- check whether the actions for this state fit in the table 1350> ok <- fits off state table 1351> if not ok then try_next else return off 1352> where 1353> try_next = findFreeOffset (off+1) table off_arr state 1354 1355 1356> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool 1357> fits _ [] _ = return True 1358> fits off ((t,_):rest) table = do 1359> i <- readArray table (off+t) 1360> if i /= -1 then return False 1361> else fits off rest table 1362 1363> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] 1364> -> ST s () 1365> addState _ _ _ [] = return () 1366> addState off table check ((t,val):state) = do 1367> writeArray table (off+t) val 1368> writeArray check (off+t) t 1369> addState off table check state 1370 1371> notFail :: (Int, LRAction) -> Bool 1372> notFail (_, LR'Fail) = False 1373> notFail _ = True 1374 1375> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int 1376> findFstFreeSlot table n = do 1377> i <- readArray table n 1378> if i == -1 then return n 1379> else findFstFreeSlot table (n+1) 1380 1381----------------------------------------------------------------------------- 1382-- Misc. 1383 1384> comment :: String 1385> comment = 1386> "-- parser produced by Happy Version " ++ showVersion version ++ "\n\n" 1387 1388> mkAbsSynCon :: Array Int Int -> Int -> String -> String 1389> mkAbsSynCon fx t = str "HappyAbsSyn" . shows (fx ! t) 1390 1391> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String 1392> mkHappyVar n = str "happy_var_" . shows n 1393> mkReduceFun n = str "happyReduce_" . shows n 1394> mkDummyVar n = str "happy_x_" . shows n 1395 1396> mkHappyWrap :: Int -> String -> String 1397> mkHappyWrap n = str "HappyWrap" . shows n 1398 1399> mkHappyWrapCon :: Maybe a -> Int -> (String -> String) -> String -> String 1400> mkHappyWrapCon Nothing _ s = s 1401> mkHappyWrapCon (Just _) n s = brack' (mkHappyWrap n . strspace . s) 1402 1403> mkHappyIn, mkHappyOut :: Int -> String -> String 1404> mkHappyIn n = str "happyIn" . shows n 1405> mkHappyOut n = str "happyOut" . shows n 1406 1407> typeParam, typeParamOut :: Int -> Maybe String -> ShowS 1408> typeParam n Nothing = char 't' . shows n 1409> typeParam _ (Just ty) = brack ty 1410> typeParamOut n Nothing = char 't' . shows n 1411> typeParamOut n (Just _) = mkHappyWrap n 1412 1413> specReduceFun :: Int -> Bool 1414> specReduceFun = (<= 3) 1415 1416----------------------------------------------------------------------------- 1417-- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable 1418-- for placing in a string. 1419 1420> hexChars :: [Int] -> String 1421> hexChars = concatMap hexChar 1422 1423> hexChar :: Int -> String 1424> hexChar i | i < 0 = hexChar (i + 65536) 1425> hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256) 1426 1427> toHex :: Int -> String 1428> toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] 1429 1430> hexDig :: Int -> Char 1431> hexDig i | i <= 9 = chr (i + ord '0') 1432> | otherwise = chr (i - 10 + ord 'a') 1433 1434This guards against integers that are so large as to (when converted using 1435'hexChar') wrap around the maximum value of 16-bit numbers and then end up 1436larger than an expected minimum value. 1437 1438> checkedHexChars :: Int -> [Int] -> String 1439> checkedHexChars minValue = concatMap hexChar' 1440> where hexChar' i | checkHexChar minValue i = hexChar i 1441> | otherwise = error "grammar does not fit in 16-bit representation that is used with '--ghc'" 1442 1443> checkHexChar :: Int -> Int -> Bool 1444> checkHexChar minValue i = i <= 32767 || i - 65536 < minValue 1445