happy-meta 0.2.0.1 → 0.2.0.2
raw patch · 20 files changed
+5758/−4743 lines, 20 files
Files
- dist/build/AttrGrammarParser.hs +43/−26
- dist/build/Parser.hs +43/−26
- happy-meta.cabal +1/−1
- src/AbsSyn.lhs +175/−137
- src/AttrGrammar.lhs +136/−107
- src/AttrGrammarParser.ly +82/−68
- src/First.lhs +88/−67
- src/GenUtils.lhs +288/−224
- src/Grammar.lhs +779/−594
- src/LALR.lhs +909/−668
- src/Lexer.lhs +302/−251
- src/NameSet.hs +10/−10
- src/ParamRules.hs +92/−92
- src/ParseMonad.lhs +31/−22
- src/Parser.ly +177/−146
- src/ProduceCode.lhs +1306/−1211
- src/ProduceGLRCode.lhs +898/−703
- src/Target.lhs +21/−13
- src/Text/Happy.hs +171/−171
- src/Text/Happy/HappyTemplate.hs +206/−206
dist/build/AttrGrammarParser.hs view
@@ -4,10 +4,18 @@ module AttrGrammarParser (agParser) where import ParseMonad import AttrGrammar +#if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array +#else +import qualified Array as Happy_Data_Array +#endif +#if __GLASGOW_HASKELL__ >= 503 import qualified GHC.Exts as Happy_GHC_Exts +#else +import qualified GlaExts as Happy_GHC_Exts +#endif --- parser produced by Happy Version 1.18.5 +-- parser produced by Happy Version 1.18.4 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -345,7 +353,7 @@ {-# LINE 1 "templates\\GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 30 "templates\\GenericTemplate.hs" #-} +{-# LINE 28 "templates\\GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -354,11 +362,11 @@ -{-# LINE 51 "templates\\GenericTemplate.hs" #-} +{-# LINE 49 "templates\\GenericTemplate.hs" #-} -{-# LINE 61 "templates\\GenericTemplate.hs" #-} +{-# LINE 59 "templates\\GenericTemplate.hs" #-} -{-# LINE 70 "templates\\GenericTemplate.hs" #-} +{-# LINE 68 "templates\\GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -401,26 +409,35 @@ happyShift new_state i tk st - where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where !(off) = indexShortOffAddr happyActOffsets st - !(off_i) = (off Happy_GHC_Exts.+# i) + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False - !(action) - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st -{-# LINE 130 "templates\\GenericTemplate.hs" #-} +{-# LINE 127 "templates\\GenericTemplate.hs" #-} indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 Happy_GHC_Exts.narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + Happy_GHC_Exts.intToInt16# i +#else + Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16# +#endif where - !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - !off' = off Happy_GHC_Exts.*# 2# +#if __GLASGOW_HASKELL__ >= 503 + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) +#else + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low) +#endif + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# @@ -434,13 +451,13 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 163 "templates\\GenericTemplate.hs" #-} +{-# LINE 170 "templates\\GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -484,19 +501,19 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - !(off) = indexShortOffAddr happyGotoOffsets st1 - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i @@ -514,9 +531,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state - where !(off) = indexShortOffAddr happyGotoOffsets st - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i
dist/build/Parser.hs view
@@ -5,10 +5,18 @@ import ParseMonad import AbsSyn import Lexer +#if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array +#else +import qualified Array as Happy_Data_Array +#endif +#if __GLASGOW_HASKELL__ >= 503 import qualified GHC.Exts as Happy_GHC_Exts +#else +import qualified GlaExts as Happy_GHC_Exts +#endif --- parser produced by Happy Version 1.18.5 +-- parser produced by Happy Version 1.18.4 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -732,7 +740,7 @@ {-# LINE 1 "templates\\GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 30 "templates\\GenericTemplate.hs" #-} +{-# LINE 28 "templates\\GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -741,11 +749,11 @@ -{-# LINE 51 "templates\\GenericTemplate.hs" #-} +{-# LINE 49 "templates\\GenericTemplate.hs" #-} -{-# LINE 61 "templates\\GenericTemplate.hs" #-} +{-# LINE 59 "templates\\GenericTemplate.hs" #-} -{-# LINE 70 "templates\\GenericTemplate.hs" #-} +{-# LINE 68 "templates\\GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -788,26 +796,35 @@ happyShift new_state i tk st - where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where !(off) = indexShortOffAddr happyActOffsets st - !(off_i) = (off Happy_GHC_Exts.+# i) + where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where off = indexShortOffAddr happyActOffsets st + off_i = (off Happy_GHC_Exts.+# i) check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False - !(action) - | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st + action | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st -{-# LINE 130 "templates\\GenericTemplate.hs" #-} +{-# LINE 127 "templates\\GenericTemplate.hs" #-} indexShortOffAddr (HappyA# arr) off = +#if __GLASGOW_HASKELL__ > 500 Happy_GHC_Exts.narrow16Int# i +#elif __GLASGOW_HASKELL__ == 500 + Happy_GHC_Exts.intToInt16# i +#else + Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16# +#endif where - !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) - !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - !off' = off Happy_GHC_Exts.*# 2# +#if __GLASGOW_HASKELL__ >= 503 + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) +#else + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low) +#endif + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# @@ -821,13 +838,13 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 163 "templates\\GenericTemplate.hs" #-} +{-# LINE 170 "templates\\GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in + let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -871,19 +888,19 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) + where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - !(off) = indexShortOffAddr happyGotoOffsets st1 - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i + off = indexShortOffAddr happyGotoOffsets st1 + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i @@ -901,9 +918,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state - where !(off) = indexShortOffAddr happyGotoOffsets st - !(off_i) = (off Happy_GHC_Exts.+# nt) - !(new_state) = indexShortOffAddr happyTable off_i + where off = indexShortOffAddr happyGotoOffsets st + off_i = (off Happy_GHC_Exts.+# nt) + new_state = indexShortOffAddr happyTable off_i
happy-meta.cabal view
@@ -1,5 +1,5 @@ Name: happy-meta -Version: 0.2.0.1 +Version: 0.2.0.2 Synopsis: Quasi-quoter for Happy parsers -- Description: License: BSD3
src/AbsSyn.lhs view
@@ -1,137 +1,175 @@-------------------------------------------------------------------------------Abstract syntax for grammar files.--(c) 1993-2001 Andy Gill, Simon Marlow--------------------------------------------------------------------------------Here is the abstract syntax of the language we parse.--> module AbsSyn (-> AbsSyn(..), Directive(..),-> getTokenType, getTokenSpec, getParserNames, getLexer,-> getImportedIdentity, getMonad, getError,-> getPrios, getPrioNames, getExpect,-> getAttributes, getAttributetype,-> Rule,Prod,Term(..)-> ) where--> data AbsSyn-> = AbsSyn-> (Maybe String) -- header-> [Directive String] -- directives-> [Rule] -- productions-> (Maybe String) -- footer--> type Rule = (String,[String],[Prod],Maybe String)-> type Prod = ([Term],String,Int,Maybe String)-> data Term = App String [Term]----#ifdef DEBUG--> deriving Show--#endif--%------------------------------------------------------------------------------Parser Generator Directives.--ToDo: find a consistent way to analyse all the directives together and-generate some error messages.--> data Directive a-> = TokenType String -- %tokentype-> | TokenSpec [(a,String)] -- %token-> | TokenName String (Maybe String) Bool -- %name/%partial (True <=> %partial)-> | TokenLexer String String -- %lexer-> | TokenImportedIdentity -- %importedidentity-> | TokenMonad String String String String -- %monad-> | TokenNonassoc [String] -- %nonassoc-> | TokenRight [String] -- %right-> | TokenLeft [String] -- %left-> | TokenExpect Int -- %expect-> | TokenError String -- %error-> | TokenAttributetype String -- %attributetype-> | TokenAttribute String String -- %attribute- --#ifdef DEBUG--> deriving Show--#endif--> getTokenType :: [Directive t] -> String-> getTokenType ds -> = case [ t | (TokenType t) <- ds ] of -> [t] -> t-> [] -> error "no token type given"-> _ -> error "multiple token types"--> getParserNames :: [Directive t] -> [Directive t]-> getParserNames ds = [ t | t@(TokenName _ _ _) <- ds ]--> getLexer :: [Directive t] -> Maybe (String, String)-> getLexer ds -> = case [ (a,b) | (TokenLexer a b) <- ds ] of-> [t] -> Just t-> [] -> Nothing-> _ -> error "multiple lexer directives"--> getImportedIdentity :: [Directive t] -> Bool-> getImportedIdentity ds -> = case [ (()) | TokenImportedIdentity <- ds ] of-> [_] -> True-> [] -> False-> _ -> error "multiple importedidentity directives"--> getMonad :: [Directive t] -> (Bool, String, String, String, String)-> getMonad ds -> = case [ (True,a,b,c,d) | (TokenMonad a b c d) <- ds ] of-> [t] -> t-> [] -> (False,"()","HappyIdentity",">>=","return")-> _ -> error "multiple monad directives"--> getTokenSpec :: [Directive t] -> [(t, String)]-> getTokenSpec ds = concat [ t | (TokenSpec t) <- ds ]--> getPrios :: [Directive t] -> [Directive t]-> getPrios ds = [ d | d <- ds,-> case d of-> TokenNonassoc _ -> True-> TokenLeft _ -> True-> TokenRight _ -> True-> _ -> False-> ]--> getPrioNames :: Directive t -> [String]-> getPrioNames (TokenNonassoc s) = s-> getPrioNames (TokenLeft s) = s-> getPrioNames (TokenRight s) = s-> getPrioNames _ = error "Not an associativity token"--> getExpect :: [Directive t] -> Maybe Int-> getExpect ds-> = case [ n | (TokenExpect n) <- ds ] of-> [t] -> Just t-> [] -> Nothing-> _ -> error "multiple expect directives"--> getError :: [Directive t] -> Maybe String-> getError ds -> = case [ a | (TokenError a) <- ds ] of-> [t] -> Just t-> [] -> Nothing-> _ -> error "multiple error directives"--> getAttributes :: [Directive t] -> [(String, String)]-> getAttributes ds-> = [ (ident,typ) | (TokenAttribute ident typ) <- ds ]--> getAttributetype :: [Directive t] -> Maybe String-> getAttributetype ds-> = case [ t | (TokenAttributetype t) <- ds ] of-> [t] -> Just t-> [] -> Nothing-> _ -> error "multiple attributetype directives"+ + + + + + + + + + + + + + + + +> module AbsSyn ( +> AbsSyn(..), Directive(..), +> getTokenType, getTokenSpec, getParserNames, getLexer, +> getImportedIdentity, getMonad, getError, +> getPrios, getPrioNames, getExpect, +> getAttributes, getAttributetype, +> Rule,Prod,Term(..) +> ) where + + +> data AbsSyn +> = AbsSyn +> (Maybe String) -- header +> [Directive String] -- directives +> [Rule] -- productions +> (Maybe String) -- footer + + +> type Rule = (String,[String],[Prod],Maybe String) +> type Prod = ([Term],String,Int,Maybe String) +> data Term = App String [Term] + + + + + + +#ifdef DEBUG + + +> deriving Show + + +#endif + + + + + + + + + + + + + + +> data Directive a +> = TokenType String -- %tokentype +> | TokenSpec [(a,String)] -- %token +> | TokenName String (Maybe String) Bool -- %name/%partial (True <=> %partial) +> | TokenLexer String String -- %lexer +> | TokenImportedIdentity -- %importedidentity +> | TokenMonad String String String String -- %monad +> | TokenNonassoc [String] -- %nonassoc +> | TokenRight [String] -- %right +> | TokenLeft [String] -- %left +> | TokenExpect Int -- %expect +> | TokenError String -- %error +> | TokenAttributetype String -- %attributetype +> | TokenAttribute String String -- %attribute + + + + +#ifdef DEBUG + + +> deriving Show + + +#endif + + +> getTokenType :: [Directive t] -> String +> getTokenType ds +> = case [ t | (TokenType t) <- ds ] of +> [t] -> t +> [] -> error "no token type given" +> _ -> error "multiple token types" + + +> getParserNames :: [Directive t] -> [Directive t] +> getParserNames ds = [ t | t@(TokenName _ _ _) <- ds ] + + +> getLexer :: [Directive t] -> Maybe (String, String) +> getLexer ds +> = case [ (a,b) | (TokenLexer a b) <- ds ] of +> [t] -> Just t +> [] -> Nothing +> _ -> error "multiple lexer directives" + + +> getImportedIdentity :: [Directive t] -> Bool +> getImportedIdentity ds +> = case [ (()) | TokenImportedIdentity <- ds ] of +> [_] -> True +> [] -> False +> _ -> error "multiple importedidentity directives" + + +> getMonad :: [Directive t] -> (Bool, String, String, String, String) +> getMonad ds +> = case [ (True,a,b,c,d) | (TokenMonad a b c d) <- ds ] of +> [t] -> t +> [] -> (False,"()","HappyIdentity",">>=","return") +> _ -> error "multiple monad directives" + + +> getTokenSpec :: [Directive t] -> [(t, String)] +> getTokenSpec ds = concat [ t | (TokenSpec t) <- ds ] + + +> getPrios :: [Directive t] -> [Directive t] +> getPrios ds = [ d | d <- ds, +> case d of +> TokenNonassoc _ -> True +> TokenLeft _ -> True +> TokenRight _ -> True +> _ -> False +> ] + + +> getPrioNames :: Directive t -> [String] +> getPrioNames (TokenNonassoc s) = s +> getPrioNames (TokenLeft s) = s +> getPrioNames (TokenRight s) = s +> getPrioNames _ = error "Not an associativity token" + + +> getExpect :: [Directive t] -> Maybe Int +> getExpect ds +> = case [ n | (TokenExpect n) <- ds ] of +> [t] -> Just t +> [] -> Nothing +> _ -> error "multiple expect directives" + + +> getError :: [Directive t] -> Maybe String +> getError ds +> = case [ a | (TokenError a) <- ds ] of +> [t] -> Just t +> [] -> Nothing +> _ -> error "multiple error directives" + + +> getAttributes :: [Directive t] -> [(String, String)] +> getAttributes ds +> = [ (ident,typ) | (TokenAttribute ident typ) <- ds ] + + +> getAttributetype :: [Directive t] -> Maybe String +> getAttributetype ds +> = case [ t | (TokenAttributetype t) <- ds ] of +> [t] -> Just t +> [] -> Nothing +> _ -> error "multiple attributetype directives"
src/AttrGrammar.lhs view
@@ -1,107 +1,136 @@-> module AttrGrammar -> ( AgToken (..)-> , AgRule (..)-> , agLexAll-> , agLexer-> , subRefVal-> , selfRefVal-> , rightRefVal-> ) where--> import Data.Char-> import ParseMonad--> data AgToken -> = AgTok_LBrace-> | AgTok_RBrace-> | AgTok_Where-> | AgTok_Semicolon-> | AgTok_Eq-> | AgTok_SelfRef String-> | AgTok_SubRef (Int, String)-> | AgTok_RightmostRef String-> | AgTok_Unknown String-> | AgTok_EOF-> deriving (Show,Eq,Ord)--> subRefVal :: AgToken -> (Int, String)-> subRefVal (AgTok_SubRef x) = x-> subRefVal _ = error "subRefVal: Bad value"-> selfRefVal :: AgToken -> String-> selfRefVal (AgTok_SelfRef x) = x-> selfRefVal _ = error "selfRefVal: Bad value"-> rightRefVal :: AgToken -> String-> rightRefVal (AgTok_RightmostRef x) = x-> rightRefVal _ = error "rightRefVal: Bad value"--> data AgRule-> = SelfAssign String [AgToken]-> | SubAssign (Int,String) [AgToken]-> | RightmostAssign String [AgToken]-> | Conditional [AgToken]-> deriving (Show,Eq,Ord)---------------------------------------------------------------------- For the most part, the body of the attribute grammar rules--- is uninterpreted haskell expressions. We only need to know about--- a) braces and semicolons to break the rules apart--- b) the equals sign to break the rules into LValues and the RHS--- c) attribute references, which are $$, $x (postivie integer x)--- or $> (for the rightmost symbol) followed by an optional--- attribute specifier, which is a dot followed by a--- Haskell variable identifier--- Examples:--- $$--- $1--- $>--- $$.pos--- $3.value--- $2.someAttribute0'------ Everything else can be treated as uninterpreted strings. Our munging--- will wreck column alignment so attribute grammar specifications must--- not rely on layout.--> type Pfunc a = String -> Int -> ParseResult a--> agLexAll :: P [AgToken]-> agLexAll = P $ aux []-> where aux toks [] _ = OkP (reverse toks)-> aux toks s l = agLexer' (\t -> aux (t:toks)) s l--> agLexer :: (AgToken -> P a) -> P a-> agLexer m = P $ agLexer' (\x -> runP (m x))--> agLexer' :: (AgToken -> Pfunc a) -> Pfunc a-> agLexer' cont [] = cont AgTok_EOF []-> agLexer' cont ('{':rest) = cont AgTok_LBrace rest-> agLexer' cont ('}':rest) = cont AgTok_RBrace rest-> agLexer' cont (';':rest) = cont AgTok_Semicolon rest-> agLexer' cont ('=':rest) = cont AgTok_Eq rest-> agLexer' cont ('w':'h':'e':'r':'e':rest) = cont AgTok_Where rest-> agLexer' cont ('$':'$':rest) = agLexAttribute cont (\a -> AgTok_SelfRef a) rest-> agLexer' cont ('$':'>':rest) = agLexAttribute cont (\a -> AgTok_RightmostRef a) rest-> agLexer' cont s@('$':rest) =-> let (n,rest') = span isDigit rest-> in if null n -> then agLexUnknown cont s-> else agLexAttribute cont (\a -> AgTok_SubRef (read n,a)) rest'-> agLexer' cont s@(c:rest)-> | isSpace c = agLexer' cont (dropWhile isSpace rest)-> | otherwise = agLexUnknown cont s--> agLexUnknown :: (AgToken -> Pfunc a) -> Pfunc a-> agLexUnknown cont s = let (u,rest) = aux [] s in cont (AgTok_Unknown u) rest-> where aux t [] = (reverse t,[])-> aux t ('$':c:cs)-> | c /= '$' && not (isDigit c) = aux ('$':t) (c:cs)-> | otherwise = (reverse t,'$':c:cs)-> aux t (c:cs)-> | isSpace c || c `elem` "{};=" = (reverse t,c:cs)-> | otherwise = aux (c:t) cs--> agLexAttribute :: (AgToken -> Pfunc a) -> (String -> AgToken) -> Pfunc a-> agLexAttribute cont k ('.':x:xs) -> | isLower x = let (ident,rest) = span (\c -> isAlphaNum c || c == '\'') xs in cont (k (x:ident)) rest-> | otherwise = \_ -> FailP "bad attribute identifier"-> agLexAttribute cont k rest = cont (k "") rest+> module AttrGrammar +> ( AgToken (..) +> , AgRule (..) +> , agLexAll +> , agLexer +> , subRefVal +> , selfRefVal +> , rightRefVal +> ) where + + +> import Data.Char +> import ParseMonad + + +> data AgToken +> = AgTok_LBrace +> | AgTok_RBrace +> | AgTok_Where +> | AgTok_Semicolon +> | AgTok_Eq +> | AgTok_SelfRef String +> | AgTok_SubRef (Int, String) +> | AgTok_RightmostRef String +> | AgTok_Unknown String +> | AgTok_EOF +> deriving (Show,Eq,Ord) + + +> subRefVal :: AgToken -> (Int, String) +> subRefVal (AgTok_SubRef x) = x +> subRefVal _ = error "subRefVal: Bad value" +> selfRefVal :: AgToken -> String +> selfRefVal (AgTok_SelfRef x) = x +> selfRefVal _ = error "selfRefVal: Bad value" +> rightRefVal :: AgToken -> String +> rightRefVal (AgTok_RightmostRef x) = x +> rightRefVal _ = error "rightRefVal: Bad value" + + +> data AgRule +> = SelfAssign String [AgToken] +> | SubAssign (Int,String) [AgToken] +> | RightmostAssign String [AgToken] +> | Conditional [AgToken] +> deriving (Show,Eq,Ord) + + + + + + + + + + + + + + +-- or $> (for the rightmost symbol) followed by an optional + + + + + + + + + + +-- $> + + + + + + + + + + + + + + + + +> type Pfunc a = String -> Int -> ParseResult a + + +> agLexAll :: P [AgToken] +> agLexAll = P $ aux [] +> where aux toks [] _ = OkP (reverse toks) +> aux toks s l = agLexer' (\t -> aux (t:toks)) s l + + +> agLexer :: (AgToken -> P a) -> P a +> agLexer m = P $ agLexer' (\x -> runP (m x)) + + +> agLexer' :: (AgToken -> Pfunc a) -> Pfunc a +> agLexer' cont [] = cont AgTok_EOF [] +> agLexer' cont ('{':rest) = cont AgTok_LBrace rest +> agLexer' cont ('}':rest) = cont AgTok_RBrace rest +> agLexer' cont (';':rest) = cont AgTok_Semicolon rest +> agLexer' cont ('=':rest) = cont AgTok_Eq rest +> agLexer' cont ('w':'h':'e':'r':'e':rest) = cont AgTok_Where rest +> agLexer' cont ('$':'$':rest) = agLexAttribute cont (\a -> AgTok_SelfRef a) rest +> agLexer' cont ('$':'>':rest) = agLexAttribute cont (\a -> AgTok_RightmostRef a) rest +> agLexer' cont s@('$':rest) = +> let (n,rest') = span isDigit rest +> in if null n +> then agLexUnknown cont s +> else agLexAttribute cont (\a -> AgTok_SubRef (read n,a)) rest' +> agLexer' cont s@(c:rest) +> | isSpace c = agLexer' cont (dropWhile isSpace rest) +> | otherwise = agLexUnknown cont s + + +> agLexUnknown :: (AgToken -> Pfunc a) -> Pfunc a +> agLexUnknown cont s = let (u,rest) = aux [] s in cont (AgTok_Unknown u) rest +> where aux t [] = (reverse t,[]) +> aux t ('$':c:cs) +> | c /= '$' && not (isDigit c) = aux ('$':t) (c:cs) +> | otherwise = (reverse t,'$':c:cs) +> aux t (c:cs) +> | isSpace c || c `elem` "{};=" = (reverse t,c:cs) +> | otherwise = aux (c:t) cs + + +> agLexAttribute :: (AgToken -> Pfunc a) -> (String -> AgToken) -> Pfunc a +> agLexAttribute cont k ('.':x:xs) +> | isLower x = let (ident,rest) = span (\c -> isAlphaNum c || c == '\'') xs in cont (k (x:ident)) rest +> | otherwise = \_ -> FailP "bad attribute identifier" +> agLexAttribute cont k rest = cont (k "") rest
src/AttrGrammarParser.ly view
@@ -1,68 +1,82 @@-This parser parses the contents of the attribute grammar-into a list of rules. A rule can either be an assignment-to an attribute of the LHS (synthesized attribute), and -assignment to an attribute of the RHS (an inherited attribute),-or a conditional statement.--> {-> {-# OPTIONS_GHC -w #-}-> module AttrGrammarParser (agParser) where-> import ParseMonad-> import AttrGrammar-> }--> %name agParser-> %tokentype { AgToken }-> %token-> "{" { AgTok_LBrace }-> "}" { AgTok_RBrace }-> ";" { AgTok_Semicolon }-> "=" { AgTok_Eq }-> where { AgTok_Where }-> selfRef { AgTok_SelfRef _ }-> subRef { AgTok_SubRef _ }-> rightRef { AgTok_RightmostRef _ }-> unknown { AgTok_Unknown _ }->-> %monad { P }-> %lexer { agLexer } { AgTok_EOF }--> %%--> agParser :: { [AgRule] }-> : rules { $1 }--> rules :: { [AgRule] }-> : rule ";" rules { $1 : $3 }-> | rule { $1 : [] }-> | { [] }--> rule :: { AgRule }-> : selfRef "=" code { SelfAssign (selfRefVal $1) $3 }-> | subRef "=" code { SubAssign (subRefVal $1) $3 }-> | rightRef "=" code { RightmostAssign (rightRefVal $1) $3 }-> | where code { Conditional $2 }--> code :: { [AgToken] }-> : "{" code0 "}" code { [$1] ++ $2 ++ [$3] ++ $4 }-> | "=" code { $1 : $2 }-> | selfRef code { $1 : $2 }-> | subRef code { $1 : $2 }-> | rightRef code { $1 : $2 }-> | unknown code { $1 : $2 }-> | { [] }--> code0 :: { [AgToken] }-> : "{" code0 "}" code0 { [$1] ++ $2 ++ [$3] ++ $4 }-> | "=" code0 { $1 : $2 }-> | ";" code0 { $1 : $2 }-> | selfRef code0 { $1 : $2 }-> | subRef code0 { $1 : $2 }-> | rightRef code { $1 : $2 }-> | unknown code0 { $1 : $2 }-> | { [] }--> {-> happyError :: P a-> happyError = fail ("Parse error\n")-> }+ + + + + + + + + + + + +> { +> {-# OPTIONS_GHC -w #-} +> module AttrGrammarParser (agParser) where +> import ParseMonad +> import AttrGrammar +> } + + +> %name agParser +> %tokentype { AgToken } +> %token +> "{" { AgTok_LBrace } +> "}" { AgTok_RBrace } +> ";" { AgTok_Semicolon } +> "=" { AgTok_Eq } +> where { AgTok_Where } +> selfRef { AgTok_SelfRef _ } +> subRef { AgTok_SubRef _ } +> rightRef { AgTok_RightmostRef _ } +> unknown { AgTok_Unknown _ } +> +> %monad { P } +> %lexer { agLexer } { AgTok_EOF } + + +> %% + + +> agParser :: { [AgRule] } +> : rules { $1 } + + +> rules :: { [AgRule] } +> : rule ";" rules { $1 : $3 } +> | rule { $1 : [] } +> | { [] } + + +> rule :: { AgRule } +> : selfRef "=" code { SelfAssign (selfRefVal $1) $3 } +> | subRef "=" code { SubAssign (subRefVal $1) $3 } +> | rightRef "=" code { RightmostAssign (rightRefVal $1) $3 } +> | where code { Conditional $2 } + + +> code :: { [AgToken] } +> : "{" code0 "}" code { [$1] ++ $2 ++ [$3] ++ $4 } +> | "=" code { $1 : $2 } +> | selfRef code { $1 : $2 } +> | subRef code { $1 : $2 } +> | rightRef code { $1 : $2 } +> | unknown code { $1 : $2 } +> | { [] } + + +> code0 :: { [AgToken] } +> : "{" code0 "}" code0 { [$1] ++ $2 ++ [$3] ++ $4 } +> | "=" code0 { $1 : $2 } +> | ";" code0 { $1 : $2 } +> | selfRef code0 { $1 : $2 } +> | subRef code0 { $1 : $2 } +> | rightRef code { $1 : $2 } +> | unknown code0 { $1 : $2 } +> | { [] } + + +> { +> happyError :: P a +> happyError = fail ("Parse error\n") +> }
src/First.lhs view
@@ -1,67 +1,88 @@-------------------------------------------------------------------------------Implementation of FIRST--(c) 1993-2001 Andy Gill, Simon Marlow--------------------------------------------------------------------------------> module First ( mkFirst ) where--> import GenUtils-> import NameSet ( NameSet )-> import qualified NameSet as Set-> import Grammar-> import Data.IntSet (IntSet)--\subsection{Utilities}--> joinSymSets :: (a -> NameSet) -> [a] -> NameSet-> joinSymSets f = foldr -> (\ h b -> let-> h' = f h-> in-> if incEmpty h'-> then Set.filter (not. isEmpty) h' `Set.union` b-> else h')-> (Set.singleton epsilonTok)--Does the Set include the $\epsilon$ symbol ?--> incEmpty :: NameSet -> Bool-> incEmpty set = any isEmpty (Set.toAscList set)--\subsection{Implementation of FIRST}--> mkFirst :: Grammar -> [Name] -> NameSet-> mkFirst (Grammar { first_term = fst_term-> , lookupProdNo = prodNo-> , lookupProdsOfName = prodsOfName-> , non_terminals = nts-> })-> = joinSymSets (\ h -> case lookup h env of-> Nothing -> Set.singleton h-> Just ix -> ix)-> where-> env = mkClosure (==) (getNext fst_term prodNo prodsOfName)-> [ (name,Set.empty) | name <- nts ]--> getNext :: Name -> (a -> (b, [Name], c, d)) -> (Name -> [a])-> -> [(Name, IntSet)] -> [(Name, NameSet)]-> getNext fst_term prodNo prodsOfName env = -> [ (nm, next nm) | (nm,_) <- env ]-> where -> fn t | t == errorTok || t >= fst_term = Set.singleton t-> fn x = case lookup x env of-> Just t -> t-> Nothing -> error "attempted FIRST(e) :-("--> next :: Name -> NameSet-> next t | t >= fst_term = Set.singleton t-> next n = -> foldb Set.union -> [ joinSymSets fn (snd4 (prodNo rl)) | -> rl <- prodsOfName n ]--My little hack--> snd4 :: (a, b, c, d) -> b-> snd4 (_,b,_,_) = b+ + + + + + + + + + + + +> module First ( mkFirst ) where + + +> import GenUtils +> import NameSet ( NameSet ) +> import qualified NameSet as Set +> import Grammar +> import Data.IntSet (IntSet) + + + + + + +> joinSymSets :: (a -> NameSet) -> [a] -> NameSet +> joinSymSets f = foldr +> (\ h b -> let +> h' = f h +> in +> if incEmpty h' +> then Set.filter (not. isEmpty) h' `Set.union` b +> else h') +> (Set.singleton epsilonTok) + + + + + + +> incEmpty :: NameSet -> Bool +> incEmpty set = any isEmpty (Set.toAscList set) + + + + + + +> mkFirst :: Grammar -> [Name] -> NameSet +> mkFirst (Grammar { first_term = fst_term +> , lookupProdNo = prodNo +> , lookupProdsOfName = prodsOfName +> , non_terminals = nts +> }) +> = joinSymSets (\ h -> case lookup h env of +> Nothing -> Set.singleton h +> Just ix -> ix) +> where +> env = mkClosure (==) (getNext fst_term prodNo prodsOfName) +> [ (name,Set.empty) | name <- nts ] + + +> getNext :: Name -> (a -> (b, [Name], c, d)) -> (Name -> [a]) +> -> [(Name, IntSet)] -> [(Name, NameSet)] +> getNext fst_term prodNo prodsOfName env = +> [ (nm, next nm) | (nm,_) <- env ] +> where +> fn t | t == errorTok || t >= fst_term = Set.singleton t +> fn x = case lookup x env of +> Just t -> t +> Nothing -> error "attempted FIRST(e) :-(" + + +> next :: Name -> NameSet +> next t | t >= fst_term = Set.singleton t +> next n = +> foldb Set.union +> [ joinSymSets fn (snd4 (prodNo rl)) | +> rl <- prodsOfName n ] + + + + + + +> snd4 :: (a, b, c, d) -> b +> snd4 (_,b,_,_) = b
src/GenUtils.lhs view
@@ -1,224 +1,288 @@-------------------------------------------------------------------------------Some General Utilities, including sorts, etc.-This is realy just an extended prelude.-All the code below is understood to be in the public domain.--------------------------------------------------------------------------------> module GenUtils (--> partition', tack, -> assocMaybeErr,-> arrElem,-> memoise,-> returnMaybe,handleMaybe, findJust,-> MaybeErr(..),-> mapMaybe,-> maybeMap,-> joinMaybe,-> mkClosure,-> foldb,-> listArray',-> cjustify,-> ljustify,-> rjustify,-> space,-> copy,-> combinePairs,-> --trace, -- re-export it -> fst3,-> snd3,-> thd3,-> mapDollarDollar,-> str, char, nl, brack, brack',-> interleave, interleave',-> strspace, maybestr-> ) where--> import Data.Char (isAlphaNum)-> import Data.List-> import Data.Ix ( Ix(..) )-> import Data.Array ( Array, listArray, array, (!) )--%--------------------------------------------------------------------------------Here are two defs that everyone seems to define ... -HBC has it in one of its builtin modules--> mapMaybe :: (a -> Maybe b) -> [a] -> [b]-> mapMaybe _ [] = []-> mapMaybe f (a:r) = case f a of-> Nothing -> mapMaybe f r-> Just b -> b : mapMaybe f r--> maybeMap :: (a -> b) -> Maybe a -> Maybe b-> maybeMap f (Just a) = Just (f a)-> maybeMap _ Nothing = Nothing--> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a -> joinMaybe _ Nothing Nothing = Nothing-> joinMaybe _ (Just g) Nothing = Just g-> joinMaybe _ Nothing (Just g) = Just g-> joinMaybe f (Just g) (Just h) = Just (f g h)--> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show)--@mkClosure@ makes a closure, when given a comparison and iteration loop. -Be careful, because if the functional always makes the object different, -This will never terminate.--> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a-> mkClosure eq f = match . iterate f-> where-> match (a:b:_) | a `eq` b = a-> match (_:c) = match c-> match [] = error "Can't happen: match []"--> foldb :: (a -> a -> a) -> [a] -> a-> foldb _ [] = error "can't reduce an empty list using foldb"-> foldb _ [x] = x-> foldb f l = foldb f (foldb' l)-> where -> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs-> foldb' (x:y:xs) = f x y : foldb' xs-> foldb' xs = xs--> returnMaybe :: a -> Maybe a-> returnMaybe = Just--> handleMaybe :: Maybe a -> Maybe a -> Maybe a-> handleMaybe m k = case m of-> Nothing -> k-> _ -> m- -> findJust :: (a -> Maybe b) -> [a] -> Maybe b-> findJust f = foldr handleMaybe Nothing . map f---Gofer-like stuff:--> fst3 :: (a, b, c) -> a-> fst3 (a,_,_) = a-> snd3 :: (a, b, c) -> b-> snd3 (_,a,_) = a-> thd3 :: (a, b, c) -> c-> thd3 (_,_,a) = a--> cjustify, ljustify, rjustify :: Int -> String -> String-> cjustify n s = space halfm ++ s ++ space (m - halfm)-> where m = n - length s-> halfm = m `div` 2-> ljustify n s = s ++ space (max 0 (n - length s))-> rjustify n s = space (n - length s) ++ s--> space :: Int -> String-> space n = copy n ' '--> copy :: Int -> a -> [a] -- make list of n copies of x-> copy n x = take n xs where xs = x:xs--> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]]-> partition' _ [] = []-> partition' _ [x] = [[x]]-> partition' f (x:x':xs) | f x == f x' -> = tack x (partition' f (x':xs))-> | otherwise -> = [x] : partition' f (x':xs)--> tack :: a -> [[a]] -> [[a]]-> tack x xss = (x : head xss) : tail xss--> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])]-> combinePairs xs = -> combine [ (a,[b]) | (a,b) <- sortBy (\ (a,_) (b,_) -> compare a b) xs]-> where-> combine [] = []-> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r)-> combine (a:r) = a : combine r-> --> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String-> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of-> [] -> Failed "assoc: "-> (val:_) -> Succeeded val-> --Now some utilties involving arrays. Here is a version of @elem@ that-uses partial application to optimise lookup.--> arrElem :: (Ix a, Ord a) => [a] -> a -> Bool-> arrElem obj = \x -> inRange size x && arr ! x -> where-> obj' = sort obj-> size = (head obj',last obj')-> arr = listArray size [ i `elem` obj | i <- range size ]---You can use this function to simulate memoisation. For example:-- > fib = memoise (0,100) fib'- > where- > fib' 0 = 0- > fib' 1 = 0- > fib' n = fib (n-1) + fib (n-2)--will give a very efficent variation of the fib function.---> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b-> memoise bds f = (!) arr-> where arr = array bds [ (t, f t) | t <- range bds ]--> listArray' :: (Int,Int) -> [a] -> Array Int a-> listArray' (low,up) elems = -> if length elems /= up-low+1 then error "wibble" else-> listArray (low,up) elems----Replace $$ with an arbitrary string, being careful to avoid ".." and '.'.--> mapDollarDollar :: String -> Maybe (String -> String)-> mapDollarDollar code0 = go code0 ""-> where go code acc =-> case code of-> [] -> Nothing-> -> '"' :r -> case reads code :: [(String,String)] of-> [] -> go r ('"':acc)-> (s,r'):_ -> go r' (reverse (show s) ++ acc)-> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc)-> '\'' :r -> case reads code :: [(Char,String)] of-> [] -> go r ('\'':acc)-> (c,r'):_ -> go r' (reverse (show c) ++ acc)-> '\\':'$':r -> go r ('$':acc)-> '$':'$':r -> Just (\repl -> reverse acc ++ repl ++ r)-> c:r -> go r (c:acc)---%--------------------------------------------------------------------------------Fast string-building functions. --> str :: String -> String -> String-> str = showString-> char :: Char -> String -> String-> char c = (c :)-> interleave :: String -> [String -> String] -> String -> String-> interleave s = foldr (\a b -> a . str s . b) id-> interleave' :: String -> [String -> String] -> String -> String-> interleave' s = foldr1 (\a b -> a . str s . b) --> strspace :: String -> String-> strspace = char ' '-> nl :: String -> String-> nl = char '\n'--> maybestr :: Maybe String -> String -> String-> maybestr (Just s) = str s-> maybestr _ = id--> brack :: String -> String -> String-> brack s = str ('(' : s) . char ')'-> brack' :: (String -> String) -> String -> String-> brack' s = char '(' . s . char ')'--+ + + + + + + + + + + + +> module GenUtils ( + + +> partition', tack, +> assocMaybeErr, +> arrElem, +> memoise, +> returnMaybe,handleMaybe, findJust, +> MaybeErr(..), +> mapMaybe, +> maybeMap, +> joinMaybe, +> mkClosure, +> foldb, +> listArray', +> cjustify, +> ljustify, +> rjustify, +> space, +> copy, +> combinePairs, +> --trace, -- re-export it +> fst3, +> snd3, +> thd3, +> mapDollarDollar, +> str, char, nl, brack, brack', +> interleave, interleave', +> strspace, maybestr +> ) where + + +> import Data.Char (isAlphaNum) +> import Data.List +> import Data.Ix ( Ix(..) ) +> import Data.Array ( Array, listArray, array, (!) ) + + + + + + + + + + + + +> mapMaybe :: (a -> Maybe b) -> [a] -> [b] +> mapMaybe _ [] = [] +> mapMaybe f (a:r) = case f a of +> Nothing -> mapMaybe f r +> Just b -> b : mapMaybe f r + + +> maybeMap :: (a -> b) -> Maybe a -> Maybe b +> maybeMap f (Just a) = Just (f a) +> maybeMap _ Nothing = Nothing + + +> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a +> joinMaybe _ Nothing Nothing = Nothing +> joinMaybe _ (Just g) Nothing = Just g +> joinMaybe _ Nothing (Just g) = Just g +> joinMaybe f (Just g) (Just h) = Just (f g h) + + +> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show) + + + + + + + + + + +> mkClosure :: (a -> a -> Bool) -> (a -> a) -> a -> a +> mkClosure eq f = match . iterate f +> where +> match (a:b:_) | a `eq` b = a +> match (_:c) = match c +> match [] = error "Can't happen: match []" + + +> foldb :: (a -> a -> a) -> [a] -> a +> foldb _ [] = error "can't reduce an empty list using foldb" +> foldb _ [x] = x +> foldb f l = foldb f (foldb' l) +> where +> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs +> foldb' (x:y:xs) = f x y : foldb' xs +> foldb' xs = xs + + +> returnMaybe :: a -> Maybe a +> returnMaybe = Just + + +> handleMaybe :: Maybe a -> Maybe a -> Maybe a +> handleMaybe m k = case m of +> Nothing -> k +> _ -> m + + +> findJust :: (a -> Maybe b) -> [a] -> Maybe b +> findJust f = foldr handleMaybe Nothing . map f + + + + + + + + +> fst3 :: (a, b, c) -> a +> fst3 (a,_,_) = a +> snd3 :: (a, b, c) -> b +> snd3 (_,a,_) = a +> thd3 :: (a, b, c) -> c +> thd3 (_,_,a) = a + + +> cjustify, ljustify, rjustify :: Int -> String -> String +> cjustify n s = space halfm ++ s ++ space (m - halfm) +> where m = n - length s +> halfm = m `div` 2 +> ljustify n s = s ++ space (max 0 (n - length s)) +> rjustify n s = space (n - length s) ++ s + + +> space :: Int -> String +> space n = copy n ' ' + + +> copy :: Int -> a -> [a] -- make list of n copies of x +> copy n x = take n xs where xs = x:xs + + +> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]] +> partition' _ [] = [] +> partition' _ [x] = [[x]] +> partition' f (x:x':xs) | f x == f x' +> = tack x (partition' f (x':xs)) +> | otherwise +> = [x] : partition' f (x':xs) + + +> tack :: a -> [[a]] -> [[a]] +> tack x xss = (x : head xss) : tail xss + + +> combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])] +> combinePairs xs = +> combine [ (a,[b]) | (a,b) <- sortBy (\ (a,_) (b,_) -> compare a b) xs] +> where +> combine [] = [] +> combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r) +> combine (a:r) = a : combine r +> + + +> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String +> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of +> [] -> Failed "assoc: " +> (val:_) -> Succeeded val +> + + + + + + + + +> arrElem :: (Ix a, Ord a) => [a] -> a -> Bool +> arrElem obj = \x -> inRange size x && arr ! x +> where +> obj' = sort obj +> size = (head obj',last obj') +> arr = listArray size [ i `elem` obj | i <- range size ] + + + + + + + + + > fib = memoise (0,100) fib' + > where + > fib' 0 = 0 + > fib' 1 = 0 + > fib' n = fib (n-1) + fib (n-2) + + + + + + + + +> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b +> memoise bds f = (!) arr +> where arr = array bds [ (t, f t) | t <- range bds ] + + +> listArray' :: (Int,Int) -> [a] -> Array Int a +> listArray' (low,up) elems = +> if length elems /= up-low+1 then error "wibble" else +> listArray (low,up) elems + + + + + + + + + + +> mapDollarDollar :: String -> Maybe (String -> String) +> mapDollarDollar code0 = go code0 "" +> where go code acc = +> case code of +> [] -> Nothing +> +> '"' :r -> case reads code :: [(String,String)] of +> [] -> go r ('"':acc) +> (s,r'):_ -> go r' (reverse (show s) ++ acc) +> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) +> '\'' :r -> case reads code :: [(Char,String)] of +> [] -> go r ('\'':acc) +> (c,r'):_ -> go r' (reverse (show c) ++ acc) +> '\\':'$':r -> go r ('$':acc) +> '$':'$':r -> Just (\repl -> reverse acc ++ repl ++ r) +> c:r -> go r (c:acc) + + + + + + + + + + +> str :: String -> String -> String +> str = showString +> char :: Char -> String -> String +> char c = (c :) +> interleave :: String -> [String -> String] -> String -> String +> interleave s = foldr (\a b -> a . str s . b) id +> interleave' :: String -> [String -> String] -> String -> String +> interleave' s = foldr1 (\a b -> a . str s . b) + + +> strspace :: String -> String +> strspace = char ' ' +> nl :: String -> String +> nl = char '\n' + + +> maybestr :: Maybe String -> String -> String +> maybestr (Just s) = str s +> maybestr _ = id + + +> brack :: String -> String -> String +> brack s = str ('(' : s) . char ')' +> brack' :: (String -> String) -> String -> String +> brack' s = char '(' . s . char ')' + + +
src/Grammar.lhs view
@@ -1,594 +1,779 @@-------------------------------------------------------------------------------The Grammar data type.--(c) 1993-2001 Andy Gill, Simon Marlow--------------------------------------------------------------------------------Here is our mid-section datatype--> module Grammar (-> Name, isEmpty, -> -> Production, Grammar(..), mangler,-> -> LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..),-> Assoc(..),-> -> errorName, errorTok, startName, firstStartTok, dummyTok,-> eofName, epsilonTok-> ) where--> import GenUtils-> import AbsSyn-> import ParseMonad-> import AttrGrammar-> import AttrGrammarParser-> import ParamRules--> import Data.Array-> import Data.Char-> import Data.List-> import Data.Maybe (fromMaybe)--> import Control.Monad.Writer--#ifdef DEBUG--> import System.IOExts--#endif--> type Name = Int--> type Production = (Name,[Name],(String,[Int]),Priority)--> data Grammar -> = Grammar {-> productions :: [Production],-> lookupProdNo :: Int -> Production,-> lookupProdsOfName :: Name -> [Int],-> token_specs :: [(Name,String)],-> terminals :: [Name],-> non_terminals :: [Name],-> starts :: [(String,Name,Name,Bool)],-> types :: Array Int (Maybe String),-> token_names :: Array Int String,-> first_nonterm :: Name,-> first_term :: Name,-> eof_term :: Name,-> priorities :: [(Name,Priority)],-> token_type :: String,-> imported_identity :: Bool,-> monad :: (Bool,String,String,String,String),-> expect :: Maybe Int,-> attributes :: [(String,String)],-> attributetype :: String,-> lexer :: Maybe (String,String),-> error_handler :: Maybe String-> }--#ifdef DEBUG--> instance Show Grammar where-> showsPrec _ (Grammar -> { productions = p-> , token_specs = t-> , terminals = ts-> , non_terminals = nts-> , starts = starts-> , types = tys-> , token_names = e-> , first_nonterm = fnt-> , first_term = ft-> , eof_term = eof-> })-> = showString "productions = " . shows p-> . showString "\ntoken_specs = " . shows t-> . showString "\nterminals = " . shows ts-> . showString "\nnonterminals = " . shows nts-> . showString "\nstarts = " . shows starts-> . showString "\ntypes = " . shows tys-> . showString "\ntoken_names = " . shows e-> . showString "\nfirst_nonterm = " . shows fnt-> . showString "\nfirst_term = " . shows ft-> . showString "\neof = " . shows eof-> . showString "\n"--#endif--> data Assoc = LeftAssoc | RightAssoc | None--#ifdef DEBUG--> deriving Show--#endif--> data Priority = No | Prio Assoc Int--#ifdef DEBUG--> deriving Show--#endif--> instance Eq Priority where-> No == No = True-> Prio _ i == Prio _ j = i == j-> _ == _ = False--> mkPrio :: Int -> Directive a -> Priority-> mkPrio i (TokenNonassoc _) = Prio None i-> mkPrio i (TokenRight _) = Prio RightAssoc i-> mkPrio i (TokenLeft _) = Prio LeftAssoc i-> mkPrio _ _ = error "Panic: impossible case in mkPrio"---------------------------------------------------------------------------------- Magic name values--All the tokens in the grammar are mapped onto integers, for speed.-The namespace is broken up as follows:--epsilon = 0-error = 1-dummy = 2-%start = 3..s-non-terminals = s..n-terminals = n..m-%eof = m--These numbers are deeply magical, change at your own risk. Several-other places rely on these being arranged as they are, including-ProduceCode.lhs and the various HappyTemplates.--Unfortunately this means you can't tell whether a given token is a-terminal or non-terminal without knowing the boundaries of the-namespace, which are kept in the Grammar structure.--In hindsight, this was probably a bad idea.--> startName, eofName, errorName, dummyName :: String-> startName = "%start" -- with a suffix, like %start_1, %start_2 etc.-> eofName = "%eof" -> errorName = "error"-> dummyName = "%dummy" -- shouldn't occur in the grammar anywhere--> firstStartTok, dummyTok, errorTok, epsilonTok :: Name-> firstStartTok = 3-> dummyTok = 2-> errorTok = 1-> epsilonTok = 0--> isEmpty :: Name -> Bool-> isEmpty n | n == epsilonTok = True-> | otherwise = False---------------------------------------------------------------------------------- The Mangler--This bit is a real mess, mainly because of the error message support.--> type ErrMsg = String-> type M a = Writer [ErrMsg] a--> addErr :: ErrMsg -> M ()-> addErr e = tell [e]--> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg]-> mangler file abssyn-> | null errs = Succeeded g-> | otherwise = Failed errs-> where (g, errs) = runWriter (manglerM file abssyn)--> manglerM :: FilePath -> AbsSyn -> M Grammar-> manglerM file (AbsSyn _hd dirs rules' _tl) =-> -- add filename to all error messages-> mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do--> rules <- case expand_rules rules' of-> Left err -> addErr err >> return []-> Right as -> return as-> nonterm_strs <- checkRules ([n | (n,_,_) <- rules]) "" []--> let--> terminal_strs = concat (map getTerm dirs) ++ [eofName]--> n_starts = length starts'-> n_nts = length nonterm_strs-> n_ts = length terminal_strs-> first_nt = firstStartTok + n_starts-> first_t = first_nt + n_nts-> last_start = first_nt - 1-> last_nt = first_t - 1-> last_t = first_t + n_ts - 1--> start_names = [ firstStartTok .. last_start ]-> nonterm_names = [ first_nt .. last_nt ]-> terminal_names = [ first_t .. last_t ]--> starts' = case getParserNames dirs of-> [] -> [TokenName "happyParse" Nothing False]-> ns -> ns->-> start_strs = [ startName++'_':p | (TokenName p _ _) <- starts' ]--Build up a mapping from name values to strings.--> name_env = (errorTok, errorName) :-> (dummyTok, dummyName) :-> zip start_names start_strs ++-> zip nonterm_names nonterm_strs ++-> zip terminal_names terminal_strs--> lookupName :: String -> [Name]-> lookupName n = [ t | (t,r) <- name_env, r == n ]--> mapToName str' =-> case lookupName str' of-> [a] -> return a-> [] -> do addErr ("unknown identifier '" ++ str' ++ "'")-> return errorTok-> (a:_) -> do addErr ("multiple use of '" ++ str' ++ "'")-> return a--Start symbols...--> -- default start token is the first non-terminal in the grammar-> lookupStart (TokenName _ Nothing _) = return first_nt-> lookupStart (TokenName _ (Just n) _) = mapToName n-> lookupStart _ = error "lookupStart: Not a TokenName"-> -- in--> start_toks <- mapM lookupStart starts'--> let-> parser_names = [ s | TokenName s _ _ <- starts' ]-> start_partials = [ b | TokenName _ _ b <- starts' ]-> start_prods = zipWith (\nm tok -> (nm, [tok], ("no code",[]), No))-> start_names start_toks--Deal with priorities...--> priodir = zip [1..] (getPrios dirs)->-> prios = [ (name,mkPrio i dir)-> | (i,dir) <- priodir-> , nm <- AbsSyn.getPrioNames dir-> , name <- lookupName nm-> ]--> prioByString = [ (name, mkPrio i dir)-> | (i,dir) <- priodir-> , name <- AbsSyn.getPrioNames dir-> ]--Translate the rules from string to name-based.--> convNT (nt, prods, ty) -> = do nt' <- mapToName nt-> return (nt', prods, ty)->-> attrs = getAttributes dirs-> attrType = fromMaybe "HappyAttrs" (getAttributetype dirs)->-> transRule (nt, prods, _ty)-> = mapM (finishRule nt) prods->-> finishRule nt (lhs,code,line,prec)-> = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do-> lhs' <- mapM mapToName lhs-> code' <- checkCode (length lhs) lhs' nonterm_names code attrs-> case mkPrec lhs' prec of-> Left s -> do addErr ("Undeclared precedence token: " ++ s)-> return (nt, lhs', code', No)-> Right p -> return (nt, lhs', code', p)->-> mkPrec :: [Name] -> Maybe String -> Either String Priority-> mkPrec lhs prio =-> case prio of-> Nothing -> case filter (flip elem terminal_names) lhs of-> [] -> Right No-> xs -> case lookup (last xs) prios of-> Nothing -> Right No-> Just p -> Right p-> Just s -> case lookup s prioByString of-> Nothing -> Left s-> Just p -> Right p-> -- in--> rules1 <- mapM convNT rules-> rules2 <- mapM transRule rules1--> let-> tys = accumArray (\_ x -> x) Nothing (first_nt, last_nt) -> [ (nm, Just ty) | (nm, _, Just ty) <- rules1 ]--> env_array :: Array Int String-> env_array = array (errorTok, last_t) name_env-> -- in--Get the token specs in terms of Names.--> let -> fixTokenSpec (a,b) = do n <- mapToName a; return (n,b)-> -- in-> tokspec <- mapM fixTokenSpec (getTokenSpec dirs)--> let-> ass = combinePairs [ (a,no)-> | ((a,_,_,_),no) <- zip productions' [0..] ]-> arr = array (firstStartTok, length ass - 1 + firstStartTok) ass--> lookup_prods :: Name -> [Int]-> lookup_prods x | x >= firstStartTok && x < first_t = arr ! x-> lookup_prods _ = error "lookup_prods"->-> productions' = start_prods ++ concat rules2-> prod_array = listArray' (0,length productions' - 1) productions'-> -- in--> return (Grammar {-> productions = productions',-> lookupProdNo = (prod_array !),-> lookupProdsOfName = lookup_prods,-> token_specs = tokspec,-> terminals = errorTok : terminal_names,-> non_terminals = start_names ++ nonterm_names,-> -- INCLUDES the %start tokens-> starts = zip4 parser_names start_names start_toks-> start_partials,-> types = tys,-> token_names = env_array,-> first_nonterm = first_nt,-> first_term = first_t,-> eof_term = last terminal_names,-> priorities = prios,-> imported_identity = getImportedIdentity dirs,-> monad = getMonad dirs,-> lexer = getLexer dirs,-> error_handler = getError dirs,-> token_type = getTokenType dirs,-> expect = getExpect dirs,-> attributes = attrs,-> attributetype = attrType-> })--For combining actions with possible error messages.--> addLine :: Int -> String -> String-> addLine l s = show l ++ ": " ++ s--> getTerm :: Directive a -> [a]-> getTerm (TokenSpec stuff) = map fst stuff-> getTerm _ = []--So is this.--> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String]-> checkRules (name:rest) above nonterms-> | name == above = checkRules rest name nonterms-> | name `elem` nonterms -> = do addErr ("Multiple rules for '" ++ name ++ "'")-> checkRules rest name nonterms-> | otherwise = checkRules rest name (name : nonterms)--> checkRules [] _ nonterms = return (reverse nonterms)----------------------------------------------------------------------------------- If any attribute directives were used, we are in an attribute grammar, so--- go do special processing. If not, pass on to the regular processing routine--> checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])-> checkCode arity _ _ code [] = doCheckCode arity code-> checkCode arity lhs nonterm_names code attrs = rewriteAttributeGrammar arity lhs nonterm_names code attrs----------------------------------------------------------------------------------- Special processing for attribute grammars. We re-parse the body of the code--- block and output the nasty-looking record manipulation and let binding goop-----> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int])-> rewriteAttributeGrammar arity lhs nonterm_names code attrs =-- first we need to parse the body of the code block--> case runP agParser code 0 of-> FailP msg -> do addErr ("error in attribute grammar rules: "++msg)-> return ("",[])-> OkP rules ->-- now we break the rules into three lists, one for synthesized attributes,- one for inherited attributes, and one for conditionals--> let (selfRules,subRules,conditions) = partitionRules [] [] [] rules-> attrNames = map fst attrs-> defaultAttr = head attrNames-- now check that $i references are in range--> in do let prods = mentionedProductions rules-> mapM checkArity prods-- and output the rules--> rulesStr <- formatRules arity attrNames defaultAttr -> allSubProductions selfRules -> subRules conditions-- return the munged code body and all sub-productions mentioned--> return (rulesStr,nub (allSubProductions++prods))---> where partitionRules a b c [] = (a,b,c)-> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (SubAssign (arity,attr) toks : b) c xs-> partitionRules a b c (x@(SelfAssign _ _ ) : xs) = partitionRules (x:a) b c xs-> partitionRules a b c (x@(SubAssign _ _) : xs) = partitionRules a (x:b) c xs-> partitionRules a b c (x@(Conditional _) : xs) = partitionRules a b (x:c) xs--> allSubProductions = map (+1) (findIndices (`elem` nonterm_names) lhs)--> mentionedProductions rules = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ]--> getTokens (SelfAssign _ toks) = toks-> getTokens (SubAssign _ toks) = toks-> getTokens (Conditional toks) = toks-> getTokens (RightmostAssign _ toks) = toks-> -> checkArity x = when (x > arity) $ addErr (show x++" out of range")------------------------------------------------------------------------------------------- Actually emit the code for the record bindings and conditionals-----> formatRules :: Int -> [String] -> String -> [Name] -> -> [AgRule] -> [AgRule] -> [AgRule] -> -> M String--> formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $-> concat [ "\\happyInhAttrs -> let { "-> , "happySelfAttrs = happyInhAttrs",formattedSelfRules-> , subProductionRules-> , "; happyConditions = ", formattedConditions-> , " } in (happyConditions,happySelfAttrs)"-> ]->-> where formattedSelfRules = case selfRules of [] -> []; _ -> "{ "++formattedSelfRules'++" }"-> formattedSelfRules' = concat $ intersperse ", " $ map formatSelfRule selfRules-> formatSelfRule (SelfAssign [] toks) = defaultAttr++" = "++(formatTokens toks)-> formatSelfRule (SelfAssign attr toks) = attr++" = "++(formatTokens toks)-> formatSelfRule _ = error "formatSelfRule: Not a self rule"--> subRulesMap :: [(Int,[(String,[AgToken])])]-> subRulesMap = map (\l -> foldr (\ (_,x) (i,xs) -> (i,x:xs))-> (fst $ head l,[snd $ head l])-> (tail l) ) .-> groupBy (\x y -> (fst x) == (fst y)) .-> sortBy (\x y -> compare (fst x) (fst y)) .-> map (\(SubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules--> subProductionRules = concat $ map formatSubRules prods--> formatSubRules i = -> let attrs = fromMaybe [] . lookup i $ subRulesMap-> attrUpdates' = concat $ intersperse ", " $ map (formatSubRule i) attrs-> attrUpdates = case attrUpdates' of [] -> []; x -> "{ "++x++" }"-> in concat ["; (happyConditions_",show i,",happySubAttrs_",show i,") = ",mkHappyVar i-> ," happyEmptyAttrs"-> , attrUpdates-> ]-> -> formattedConditions = concat $ intersperse "++" $ localConditions : (map (\i -> "happyConditions_"++(show i)) prods)-> localConditions = "["++(concat $ intersperse ", " $ map formatCondition conditions)++"]"-> formatCondition (Conditional toks) = formatTokens toks-> formatCondition _ = error "formatCondition: Not a condition"--> formatSubRule _ ([],toks) = defaultAttr++" = "++(formatTokens toks)-> formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks)--> formatTokens tokens = concat (map formatToken tokens)--> formatToken AgTok_LBrace = "{ "-> formatToken AgTok_RBrace = "} "-> formatToken AgTok_Where = "where "-> formatToken AgTok_Semicolon = "; "-> formatToken AgTok_Eq = "="-> formatToken (AgTok_SelfRef []) = "("++defaultAttr++" happySelfAttrs) "-> formatToken (AgTok_SelfRef x) = "("++x++" happySelfAttrs) "-> formatToken (AgTok_RightmostRef x) = formatToken (AgTok_SubRef (arity,x))-> formatToken (AgTok_SubRef (i,[])) -> | i `elem` prods = "("++defaultAttr++" happySubAttrs_"++(show i)++") "-> | otherwise = mkHappyVar i ++ " "-> formatToken (AgTok_SubRef (i,x)) -> | i `elem` prods = "("++x++" happySubAttrs_"++(show i)++") "-> | otherwise = error ("lhs "++(show i)++" is not a non-terminal")-> formatToken (AgTok_Unknown x) = x++" "-> formatToken AgTok_EOF = error "formatToken AgTok_EOF"----------------------------------------------------------------------------------- Check for every $i that i is <= the arity of the rule.---- At the same time, we collect a list of the variables actually used in this--- code, which is used by the backend.--> doCheckCode :: Int -> String -> M (String, [Int])-> doCheckCode arity code0 = go code0 "" []-> where go code acc used =-> case code of-> [] -> return (reverse acc, used)-> -> '"' :r -> case reads code :: [(String,String)] of-> [] -> go r ('"':acc) used-> (s,r'):_ -> go r' (reverse (show s) ++ acc) used-> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) used-> '\'' :r -> case reads code :: [(Char,String)] of-> [] -> go r ('\'':acc) used-> (c,r'):_ -> go r' (reverse (show c) ++ acc) used-> '\\':'$':r -> go r ('$':acc) used->-> '$':'>':r -- the "rightmost token"-> | arity == 0 -> do addErr "$> in empty rule"-> go r acc used-> | otherwise -> go r (reverse (mkHappyVar arity) ++ acc)-> (arity : used)->-> '$':r@(i:_) | isDigit i -> -> case reads r :: [(Int,String)] of-> (j,r'):_ -> -> if j > arity -> then do addErr ('$': show j ++ " out of range")-> go r' acc used-> else go r' (reverse (mkHappyVar j) ++ acc) -> (j : used)-> [] -> error "doCheckCode []"-> c:r -> go r (c:acc) used--> mkHappyVar :: Int -> String-> mkHappyVar n = "happy_var_" ++ show n---------------------------------------------------------------------------------- Internal Reduction Datatypes--> data LRAction = LR'Shift Int Priority -- state number and priority-> | LR'Reduce Int Priority-- rule no and priority-> | LR'Accept -- :-)-> | LR'Fail -- :-(-> | LR'MustFail -- :-(-> | LR'Multiple [LRAction] LRAction -- conflict-> deriving(Eq--#ifdef DEBUG--> ,Show--#endif--> ) --> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction)-- instance Text LRAction where - showsPrec _ (LR'Shift i _) = showString ("s" ++ show i)- showsPrec _ (LR'Reduce i _) - = showString ("r" ++ show i)- showsPrec _ (LR'Accept) = showString ("acc")- showsPrec _ (LR'Fail) = showString (" ")- instance Eq LRAction where { (==) = primGenericEq } --> data Goto = Goto Int | NoGoto -> deriving(Eq--#ifdef DEBUG--> ,Show--#endif--> ) --> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto)+ + + + + + + + + + + + + + + + +> module Grammar ( +> Name, isEmpty, +> +> Production, Grammar(..), mangler, +> +> LRAction(..), ActionTable, Goto(..), GotoTable, Priority(..), +> Assoc(..), +> +> errorName, errorTok, startName, firstStartTok, dummyTok, +> eofName, epsilonTok +> ) where + + +> import GenUtils +> import AbsSyn +> import ParseMonad +> import AttrGrammar +> import AttrGrammarParser +> import ParamRules + + +> import Data.Array +> import Data.Char +> import Data.List +> import Data.Maybe (fromMaybe) + + +> import Control.Monad.Writer + + +#ifdef DEBUG + + +> import System.IOExts + + +#endif + + +> type Name = Int + + +> type Production = (Name,[Name],(String,[Int]),Priority) + + +> data Grammar +> = Grammar { +> productions :: [Production], +> lookupProdNo :: Int -> Production, +> lookupProdsOfName :: Name -> [Int], +> token_specs :: [(Name,String)], +> terminals :: [Name], +> non_terminals :: [Name], +> starts :: [(String,Name,Name,Bool)], +> types :: Array Int (Maybe String), +> token_names :: Array Int String, +> first_nonterm :: Name, +> first_term :: Name, +> eof_term :: Name, +> priorities :: [(Name,Priority)], +> token_type :: String, +> imported_identity :: Bool, +> monad :: (Bool,String,String,String,String), +> expect :: Maybe Int, +> attributes :: [(String,String)], +> attributetype :: String, +> lexer :: Maybe (String,String), +> error_handler :: Maybe String +> } + + +#ifdef DEBUG + + +> instance Show Grammar where +> showsPrec _ (Grammar +> { productions = p +> , token_specs = t +> , terminals = ts +> , non_terminals = nts +> , starts = starts +> , types = tys +> , token_names = e +> , first_nonterm = fnt +> , first_term = ft +> , eof_term = eof +> }) +> = showString "productions = " . shows p +> . showString "\ntoken_specs = " . shows t +> . showString "\nterminals = " . shows ts +> . showString "\nnonterminals = " . shows nts +> . showString "\nstarts = " . shows starts +> . showString "\ntypes = " . shows tys +> . showString "\ntoken_names = " . shows e +> . showString "\nfirst_nonterm = " . shows fnt +> . showString "\nfirst_term = " . shows ft +> . showString "\neof = " . shows eof +> . showString "\n" + + +#endif + + +> data Assoc = LeftAssoc | RightAssoc | None + + +#ifdef DEBUG + + +> deriving Show + + +#endif + + +> data Priority = No | Prio Assoc Int + + +#ifdef DEBUG + + +> deriving Show + + +#endif + + +> instance Eq Priority where +> No == No = True +> Prio _ i == Prio _ j = i == j +> _ == _ = False + + +> mkPrio :: Int -> Directive a -> Priority +> mkPrio i (TokenNonassoc _) = Prio None i +> mkPrio i (TokenRight _) = Prio RightAssoc i +> mkPrio i (TokenLeft _) = Prio LeftAssoc i +> mkPrio _ _ = error "Panic: impossible case in mkPrio" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +> startName, eofName, errorName, dummyName :: String +> startName = "%start" -- with a suffix, like %start_1, %start_2 etc. +> eofName = "%eof" +> errorName = "error" +> dummyName = "%dummy" -- shouldn't occur in the grammar anywhere + + +> firstStartTok, dummyTok, errorTok, epsilonTok :: Name +> firstStartTok = 3 +> dummyTok = 2 +> errorTok = 1 +> epsilonTok = 0 + + +> isEmpty :: Name -> Bool +> isEmpty n | n == epsilonTok = True +> | otherwise = False + + + + + + + + + + + + +> type ErrMsg = String +> type M a = Writer [ErrMsg] a + + +> addErr :: ErrMsg -> M () +> addErr e = tell [e] + + +> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg] +> mangler file abssyn +> | null errs = Succeeded g +> | otherwise = Failed errs +> where (g, errs) = runWriter (manglerM file abssyn) + + +> manglerM :: FilePath -> AbsSyn -> M Grammar +> manglerM file (AbsSyn _hd dirs rules' _tl) = +> -- add filename to all error messages +> mapWriter (\(a,e) -> (a, map (\s -> file ++ ": " ++ s) e)) $ do + + +> rules <- case expand_rules rules' of +> Left err -> addErr err >> return [] +> Right as -> return as +> nonterm_strs <- checkRules ([n | (n,_,_) <- rules]) "" [] + + +> let + + +> terminal_strs = concat (map getTerm dirs) ++ [eofName] + + +> n_starts = length starts' +> n_nts = length nonterm_strs +> n_ts = length terminal_strs +> first_nt = firstStartTok + n_starts +> first_t = first_nt + n_nts +> last_start = first_nt - 1 +> last_nt = first_t - 1 +> last_t = first_t + n_ts - 1 + + +> start_names = [ firstStartTok .. last_start ] +> nonterm_names = [ first_nt .. last_nt ] +> terminal_names = [ first_t .. last_t ] + + +> starts' = case getParserNames dirs of +> [] -> [TokenName "happyParse" Nothing False] +> ns -> ns +> +> start_strs = [ startName++'_':p | (TokenName p _ _) <- starts' ] + + + + + + +> name_env = (errorTok, errorName) : +> (dummyTok, dummyName) : +> zip start_names start_strs ++ +> zip nonterm_names nonterm_strs ++ +> zip terminal_names terminal_strs + + +> lookupName :: String -> [Name] +> lookupName n = [ t | (t,r) <- name_env, r == n ] + + +> mapToName str' = +> case lookupName str' of +> [a] -> return a +> [] -> do addErr ("unknown identifier '" ++ str' ++ "'") +> return errorTok +> (a:_) -> do addErr ("multiple use of '" ++ str' ++ "'") +> return a + + + + + + +> -- default start token is the first non-terminal in the grammar +> lookupStart (TokenName _ Nothing _) = return first_nt +> lookupStart (TokenName _ (Just n) _) = mapToName n +> lookupStart _ = error "lookupStart: Not a TokenName" +> -- in + + +> start_toks <- mapM lookupStart starts' + + +> let +> parser_names = [ s | TokenName s _ _ <- starts' ] +> start_partials = [ b | TokenName _ _ b <- starts' ] +> start_prods = zipWith (\nm tok -> (nm, [tok], ("no code",[]), No)) +> start_names start_toks + + + + + + +> priodir = zip [1..] (getPrios dirs) +> +> prios = [ (name,mkPrio i dir) +> | (i,dir) <- priodir +> , nm <- AbsSyn.getPrioNames dir +> , name <- lookupName nm +> ] + + +> prioByString = [ (name, mkPrio i dir) +> | (i,dir) <- priodir +> , name <- AbsSyn.getPrioNames dir +> ] + + + + + + +> convNT (nt, prods, ty) +> = do nt' <- mapToName nt +> return (nt', prods, ty) +> +> attrs = getAttributes dirs +> attrType = fromMaybe "HappyAttrs" (getAttributetype dirs) +> +> transRule (nt, prods, _ty) +> = mapM (finishRule nt) prods +> +> finishRule nt (lhs,code,line,prec) +> = mapWriter (\(a,e) -> (a, map (addLine line) e)) $ do +> lhs' <- mapM mapToName lhs +> code' <- checkCode (length lhs) lhs' nonterm_names code attrs +> case mkPrec lhs' prec of +> Left s -> do addErr ("Undeclared precedence token: " ++ s) +> return (nt, lhs', code', No) +> Right p -> return (nt, lhs', code', p) +> +> mkPrec :: [Name] -> Maybe String -> Either String Priority +> mkPrec lhs prio = +> case prio of +> Nothing -> case filter (flip elem terminal_names) lhs of +> [] -> Right No +> xs -> case lookup (last xs) prios of +> Nothing -> Right No +> Just p -> Right p +> Just s -> case lookup s prioByString of +> Nothing -> Left s +> Just p -> Right p +> -- in + + +> rules1 <- mapM convNT rules +> rules2 <- mapM transRule rules1 + + +> let +> tys = accumArray (\_ x -> x) Nothing (first_nt, last_nt) +> [ (nm, Just ty) | (nm, _, Just ty) <- rules1 ] + + +> env_array :: Array Int String +> env_array = array (errorTok, last_t) name_env +> -- in + + + + + + +> let +> fixTokenSpec (a,b) = do n <- mapToName a; return (n,b) +> -- in +> tokspec <- mapM fixTokenSpec (getTokenSpec dirs) + + +> let +> ass = combinePairs [ (a,no) +> | ((a,_,_,_),no) <- zip productions' [0..] ] +> arr = array (firstStartTok, length ass - 1 + firstStartTok) ass + + +> lookup_prods :: Name -> [Int] +> lookup_prods x | x >= firstStartTok && x < first_t = arr ! x +> lookup_prods _ = error "lookup_prods" +> +> productions' = start_prods ++ concat rules2 +> prod_array = listArray' (0,length productions' - 1) productions' +> -- in + + +> return (Grammar { +> productions = productions', +> lookupProdNo = (prod_array !), +> lookupProdsOfName = lookup_prods, +> token_specs = tokspec, +> terminals = errorTok : terminal_names, +> non_terminals = start_names ++ nonterm_names, +> -- INCLUDES the %start tokens +> starts = zip4 parser_names start_names start_toks +> start_partials, +> types = tys, +> token_names = env_array, +> first_nonterm = first_nt, +> first_term = first_t, +> eof_term = last terminal_names, +> priorities = prios, +> imported_identity = getImportedIdentity dirs, +> monad = getMonad dirs, +> lexer = getLexer dirs, +> error_handler = getError dirs, +> token_type = getTokenType dirs, +> expect = getExpect dirs, +> attributes = attrs, +> attributetype = attrType +> }) + + + + + + +> addLine :: Int -> String -> String +> addLine l s = show l ++ ": " ++ s + + +> getTerm :: Directive a -> [a] +> getTerm (TokenSpec stuff) = map fst stuff +> getTerm _ = [] + + + + + + +> checkRules :: [String] -> String -> [String] -> Writer [ErrMsg] [String] +> checkRules (name:rest) above nonterms +> | name == above = checkRules rest name nonterms +> | name `elem` nonterms +> = do addErr ("Multiple rules for '" ++ name ++ "'") +> checkRules rest name nonterms +> | otherwise = checkRules rest name (name : nonterms) + + +> checkRules [] _ nonterms = return (reverse nonterms) + + + + + + + + + + + + +> checkCode :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int]) +> checkCode arity _ _ code [] = doCheckCode arity code +> checkCode arity lhs nonterm_names code attrs = rewriteAttributeGrammar arity lhs nonterm_names code attrs + + + + + + + + + + + + +> rewriteAttributeGrammar :: Int -> [Name] -> [Name] -> String -> [(String,String)] -> M (String,[Int]) +> rewriteAttributeGrammar arity lhs nonterm_names code attrs = + + + + + + +> case runP agParser code 0 of +> FailP msg -> do addErr ("error in attribute grammar rules: "++msg) +> return ("",[]) +> OkP rules -> + + + + + + + + +> let (selfRules,subRules,conditions) = partitionRules [] [] [] rules +> attrNames = map fst attrs +> defaultAttr = head attrNames + + + + + + +> in do let prods = mentionedProductions rules +> mapM checkArity prods + + + + + + +> rulesStr <- formatRules arity attrNames defaultAttr +> allSubProductions selfRules +> subRules conditions + + + + + + +> return (rulesStr,nub (allSubProductions++prods)) + + + + +> where partitionRules a b c [] = (a,b,c) +> partitionRules a b c (RightmostAssign attr toks : xs) = partitionRules a (SubAssign (arity,attr) toks : b) c xs +> partitionRules a b c (x@(SelfAssign _ _ ) : xs) = partitionRules (x:a) b c xs +> partitionRules a b c (x@(SubAssign _ _) : xs) = partitionRules a (x:b) c xs +> partitionRules a b c (x@(Conditional _) : xs) = partitionRules a b (x:c) xs + + +> allSubProductions = map (+1) (findIndices (`elem` nonterm_names) lhs) + + +> mentionedProductions rules = [ i | (AgTok_SubRef (i,_)) <- concat (map getTokens rules) ] + + +> getTokens (SelfAssign _ toks) = toks +> getTokens (SubAssign _ toks) = toks +> getTokens (Conditional toks) = toks +> getTokens (RightmostAssign _ toks) = toks +> +> checkArity x = when (x > arity) $ addErr (show x++" out of range") + + + + + + + + + + + + + + +> formatRules :: Int -> [String] -> String -> [Name] +> -> [AgRule] -> [AgRule] -> [AgRule] +> -> M String + + +> formatRules arity _attrNames defaultAttr prods selfRules subRules conditions = return $ +> concat [ "\\happyInhAttrs -> let { " +> , "happySelfAttrs = happyInhAttrs",formattedSelfRules +> , subProductionRules +> , "; happyConditions = ", formattedConditions +> , " } in (happyConditions,happySelfAttrs)" +> ] +> +> where formattedSelfRules = case selfRules of [] -> []; _ -> "{ "++formattedSelfRules'++" }" +> formattedSelfRules' = concat $ intersperse ", " $ map formatSelfRule selfRules +> formatSelfRule (SelfAssign [] toks) = defaultAttr++" = "++(formatTokens toks) +> formatSelfRule (SelfAssign attr toks) = attr++" = "++(formatTokens toks) +> formatSelfRule _ = error "formatSelfRule: Not a self rule" + + +> subRulesMap :: [(Int,[(String,[AgToken])])] +> subRulesMap = map (\l -> foldr (\ (_,x) (i,xs) -> (i,x:xs)) +> (fst $ head l,[snd $ head l]) +> (tail l) ) . +> groupBy (\x y -> (fst x) == (fst y)) . +> sortBy (\x y -> compare (fst x) (fst y)) . +> map (\(SubAssign (i,ident) toks) -> (i,(ident,toks))) $ subRules + + +> subProductionRules = concat $ map formatSubRules prods + + +> formatSubRules i = +> let attrs = fromMaybe [] . lookup i $ subRulesMap +> attrUpdates' = concat $ intersperse ", " $ map (formatSubRule i) attrs +> attrUpdates = case attrUpdates' of [] -> []; x -> "{ "++x++" }" +> in concat ["; (happyConditions_",show i,",happySubAttrs_",show i,") = ",mkHappyVar i +> ," happyEmptyAttrs" +> , attrUpdates +> ] +> +> formattedConditions = concat $ intersperse "++" $ localConditions : (map (\i -> "happyConditions_"++(show i)) prods) +> localConditions = "["++(concat $ intersperse ", " $ map formatCondition conditions)++"]" +> formatCondition (Conditional toks) = formatTokens toks +> formatCondition _ = error "formatCondition: Not a condition" + + +> formatSubRule _ ([],toks) = defaultAttr++" = "++(formatTokens toks) +> formatSubRule _ (attr,toks) = attr++" = "++(formatTokens toks) + + +> formatTokens tokens = concat (map formatToken tokens) + + +> formatToken AgTok_LBrace = "{ " +> formatToken AgTok_RBrace = "} " +> formatToken AgTok_Where = "where " +> formatToken AgTok_Semicolon = "; " +> formatToken AgTok_Eq = "=" +> formatToken (AgTok_SelfRef []) = "("++defaultAttr++" happySelfAttrs) " +> formatToken (AgTok_SelfRef x) = "("++x++" happySelfAttrs) " +> formatToken (AgTok_RightmostRef x) = formatToken (AgTok_SubRef (arity,x)) +> formatToken (AgTok_SubRef (i,[])) +> | i `elem` prods = "("++defaultAttr++" happySubAttrs_"++(show i)++") " +> | otherwise = mkHappyVar i ++ " " +> formatToken (AgTok_SubRef (i,x)) +> | i `elem` prods = "("++x++" happySubAttrs_"++(show i)++") " +> | otherwise = error ("lhs "++(show i)++" is not a non-terminal") +> formatToken (AgTok_Unknown x) = x++" " +> formatToken AgTok_EOF = error "formatToken AgTok_EOF" + + + + + + + + + + + + + + + + +> doCheckCode :: Int -> String -> M (String, [Int]) +> doCheckCode arity code0 = go code0 "" [] +> where go code acc used = +> case code of +> [] -> return (reverse acc, used) +> +> '"' :r -> case reads code :: [(String,String)] of +> [] -> go r ('"':acc) used +> (s,r'):_ -> go r' (reverse (show s) ++ acc) used +> a:'\'' :r | isAlphaNum a -> go r ('\'':a:acc) used +> '\'' :r -> case reads code :: [(Char,String)] of +> [] -> go r ('\'':acc) used +> (c,r'):_ -> go r' (reverse (show c) ++ acc) used +> '\\':'$':r -> go r ('$':acc) used +> +> '$':'>':r -- the "rightmost token" +> | arity == 0 -> do addErr "$> in empty rule" +> go r acc used +> | otherwise -> go r (reverse (mkHappyVar arity) ++ acc) +> (arity : used) +> +> '$':r@(i:_) | isDigit i -> +> case reads r :: [(Int,String)] of +> (j,r'):_ -> +> if j > arity +> then do addErr ('$': show j ++ " out of range") +> go r' acc used +> else go r' (reverse (mkHappyVar j) ++ acc) +> (j : used) +> [] -> error "doCheckCode []" +> c:r -> go r (c:acc) used + + +> mkHappyVar :: Int -> String +> mkHappyVar n = "happy_var_" ++ show n + + + + + + + + +> data LRAction = LR'Shift Int Priority -- state number and priority +> | LR'Reduce Int Priority-- rule no and priority +> | LR'Accept -- :-) +> | LR'Fail -- :-( +> | LR'MustFail -- :-( +> | LR'Multiple [LRAction] LRAction -- conflict +> deriving(Eq + + +#ifdef DEBUG + + +> ,Show + + +#endif + + +> ) + + +> type ActionTable = Array Int{-state-} (Array Int{-terminal#-} LRAction) + + + + + + + + + + + + + + + + + + +> data Goto = Goto Int | NoGoto +> deriving(Eq + + +#ifdef DEBUG + + +> ,Show + + +#endif + + +> ) + + +> type GotoTable = Array Int{-state-} (Array Int{-nonterminal #-} Goto)
src/LALR.lhs view
@@ -1,668 +1,909 @@-------------------------------------------------------------------------------Generation of LALR parsing tables.--(c) 1993-1996 Andy Gill, Simon Marlow-(c) 1997-2001 Simon Marlow--------------------------------------------------------------------------------> module LALR-> (genActionTable, genGotoTable, genLR0items, precalcClosure0,-> propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts,-> Lr0Item(..), Lr1Item)-> where--> import GenUtils-> import Data.Set ( Set )-> import qualified Data.Set as Set hiding ( Set )-> import qualified NameSet-> import NameSet ( NameSet )-> import Grammar--> import Control.Monad.ST-> import Data.Array.ST-> import Data.Array as Array-> import Data.List (nub)--> unionMap :: (Ord b) => (a -> Set b) -> Set a -> Set b-> unionMap f = Set.fold (Set.union . f) Set.empty--> unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet-> unionNameMap f = NameSet.fold (NameSet.union . f) NameSet.empty--This means rule $a$, with dot at $b$ (all starting at 0)--> data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int -- (rule, dot)-> deriving (Eq,Ord)--> data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet -- (rule, dot, lookahead)-> type RuleList = [Lr0Item]--------------------------------------------------------------------------------Generating the closure of a set of LR(0) items--Precalculate the rule closure for each non-terminal in the grammar,-using a memo table so that no work is repeated.--> precalcClosure0 :: Grammar -> Name -> RuleList-> precalcClosure0 g = -> \n -> case lookup n info' of-> Nothing -> []-> Just c -> c-> where->-> info' :: [(Name, RuleList)]-> info' = map (\(n,rules) -> (n,map (\rule -> Lr0 rule 0) (NameSet.toAscList rules))) info--> info :: [(Name, NameSet)]-> info = mkClosure (==) (\f -> map (follow f) f)-> (map (\nt -> (nt,NameSet.fromList (lookupProdsOfName g nt))) nts)--> follow :: [(Name, NameSet)] -> (Name, NameSet) -> (Name, NameSet)-> follow f (nt,rules) = (nt, unionNameMap (followNT f) rules `NameSet.union` rules)--> followNT :: [(Name, NameSet)] -> Int -> NameSet-> followNT f rule = -> case findRule g rule 0 of-> Just nt | nt >= firstStartTok && nt < fst_term ->-> case lookup nt f of-> Just rs -> rs-> Nothing -> error "followNT"-> _ -> NameSet.empty--> nts = non_terminals g-> fst_term = first_term g--> closure0 :: Grammar -> (Name -> RuleList) -> Set Lr0Item -> Set Lr0Item-> closure0 g closureOfNT set = Set.fold addRules Set.empty set-> where-> fst_term = first_term g-> addRules rule set' = Set.union (Set.fromList (rule : closureOfRule rule)) set'-> -> closureOfRule (Lr0 rule dot) = -> case findRule g rule dot of -> (Just nt) | nt >= firstStartTok && nt < fst_term -> -> closureOfNT nt-> _ -> []--------------------------------------------------------------------------------Generating the closure of a set of LR(1) items--> closure1 :: Grammar -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item]-> closure1 g first set-> = fst (mkClosure (\(_,new) _ -> null new) addItems ([],set))-> where-> fst_term = first_term g--> addItems :: ([Lr1Item],[Lr1Item]) -> ([Lr1Item],[Lr1Item])-> addItems (old_items, new_items) = (new_old_items, new_new_items)-> where-> new_old_items = new_items `union_items` old_items-> new_new_items = subtract_items -> (foldr union_items [] (map fn new_items))-> new_old_items--> fn :: Lr1Item -> [Lr1Item]-> fn (Lr1 rule dot as) =-> case lookupProdNo g rule of { (_name,lhs,_,_) ->-> case drop dot lhs of-> (b:beta) | b >= firstStartTok && b < fst_term ->-> let terms = unionNameMap -> (\a -> first (beta ++ [a])) as-> in-> [ (Lr1 rule' 0 terms) | rule' <- lookupProdsOfName g b ]-> _ -> []-> }--Subtract the first set of items from the second.--> subtract_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]-> subtract_items items1 items2 = foldr (subtract_item items2) [] items1--These utilities over item sets are crucial to performance.--Stamp on overloading with judicious use of type signatures...--> subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item]-> subtract_item [] i result = i : result-> subtract_item ((Lr1 rule dot as):items) i@(Lr1 rule' dot' as') result =-> case compare rule' rule of-> LT -> i : result-> GT -> carry_on-> EQ -> case compare dot' dot of-> LT -> i : result-> GT -> carry_on-> EQ -> case NameSet.difference as' as of-> bs | NameSet.null bs -> result-> | otherwise -> (Lr1 rule dot bs) : result-> where-> carry_on = subtract_item items i result--Union two sets of items.--> union_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item]-> union_items is [] = is-> union_items [] is = is-> union_items (i@(Lr1 rule dot as):is) (i'@(Lr1 rule' dot' as'):is') =-> case compare rule rule' of-> LT -> drop_i-> GT -> drop_i'-> EQ -> case compare dot dot' of-> LT -> drop_i-> GT -> drop_i'-> EQ -> (Lr1 rule dot (as `NameSet.union` as')) : union_items is is'-> where-> drop_i = i : union_items is (i':is')-> drop_i' = i' : union_items (i:is) is'--------------------------------------------------------------------------------goto(I,X) function--The input should be the closure of a set of kernel items I together with-a token X (terminal or non-terminal. Output will be the set of kernel-items for the set of items goto(I,X)--> gotoClosure :: Grammar -> Set Lr0Item -> Name -> Set Lr0Item-> gotoClosure gram i x = unionMap fn i-> where-> fn (Lr0 rule_no dot) =-> case findRule gram rule_no dot of-> Just t | x == t -> Set.singleton (Lr0 rule_no (dot+1))-> _ -> Set.empty --------------------------------------------------------------------------------Generating LR0 Item sets--The item sets are generated in much the same way as we find the-closure of a set of items: we use two sets, those which have already-generated more sets, and those which have just been generated. We-keep iterating until the second set is empty.--The addItems function is complicated by the fact that we need to keep-information about which sets were generated by which others.--> type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)])--> genLR0items :: Grammar -> (Name -> RuleList) -> [ItemSetWithGotos]-> genLR0items g precalcClosures-> = fst (mkClosure (\(_old,new) _ -> null new)-> addItems-> (([],startRules)))-> where--> n_starts = length (starts g)-> startRules :: [Set Lr0Item]-> startRules = [ Set.singleton (Lr0 rule 0) | rule <- [0..n_starts] ]--> tokens = non_terminals g ++ terminals g--> addItems :: ([ItemSetWithGotos], [Set Lr0Item])-> -> ([ItemSetWithGotos], [Set Lr0Item])-> -> addItems (oldSets,newSets) = (newOldSets, reverse newNewSets)-> where-> -> newOldSets = oldSets ++ (zip newSets intgotos)--> itemSets = map fst oldSets ++ newSets--First thing to do is for each set in I in newSets, generate goto(I,X)-for each token (terminals and nonterminals) X.--> gotos :: [[(Name,Set Lr0Item)]]-> gotos = map (filter (not . Set.null . snd))-> (map (\i -> let i' = closure0 g precalcClosures i in-> [ (x,gotoClosure g i' x) | x <- tokens ]) newSets)--% This comment causes some problems with Haddock-\begin{code}-{--Next, we assign each new set a number, which is the index of this set-in the list of sets comprising all the sets generated so far plus-those generated in this iteration. We also filter out those sets that-are new, i.e. don't exist in the current list of sets, so that they-can be added.--This comment causes some problem with haddock.-We also have to make sure that there are no duplicate sets in the-*current* batch of goto(I,X) sets, as this could be disastrous. I-think I've squished this one with the '++ reverse newSets' in-numberSets. --numberSets is built this way so we can use it quite neatly with a foldr.-Unfortunately, the code's a little opaque.--}-\end{code}--> numberSets -> :: [(Name,Set Lr0Item)] -> -> (Int,-> [[(Name,Int)]],-> [Set Lr0Item])-> -> (Int, [[(Name,Int)]], [Set Lr0Item])->-> numberSets [] (i,gotos',newSets') = (i,([]:gotos'),newSets')-> numberSets ((x,gotoix):rest) (i,g':gotos',newSets')-> = numberSets rest-> (case indexInto 0 gotoix (itemSets ++ reverse newSets') of-> Just j -> (i, ((x,j):g'):gotos', newSets')-> Nothing -> (i+1,((x,i):g'):gotos', gotoix:newSets'))-> numberSets _ _ = error "genLR0items/numberSets: Unhandled case"--Finally, do some fiddling around to get this all in the form we want.--> intgotos :: [[(Name,Int)]]-> newNewSets :: [Set Lr0Item]-> (_, ([]:intgotos), newNewSets) =-> foldr numberSets (length newOldSets, [[]], []) gotos--> indexInto :: Eq a => Int -> a -> [a] -> Maybe Int-> indexInto _ _ [] = Nothing-> indexInto i x (y:ys) | x == y = Just i-> | otherwise = indexInto (i+1) x ys--------------------------------------------------------------------------------Computing propagation of lookaheads--ToDo: generate this info into an array to be used in the subsequent-calcLookaheads pass.--> propLookaheads -> :: Grammar-> -> [(Set Lr0Item,[(Name,Int)])] -- LR(0) kernel sets-> -> ([Name] -> NameSet) -- First function-> -> (-> [(Int, Lr0Item, NameSet)], -- spontaneous lookaheads-> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads-> )--> propLookaheads gram sets first = (concat s, array (0,length sets - 1) -> [ (a,b) | (a,b) <- p ])-> where--> (s,p) = unzip (zipWith propLASet sets [0..])--> propLASet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([(Int, Lr0Item, NameSet)],(Int,[(Lr0Item, Int, Lr0Item)]))-> propLASet (set,goto) i = (start_spont ++ concat s', (i, concat p'))-> where--> (s',p') = unzip (map propLAItem (Set.toAscList set))--> -- spontaneous EOF lookaheads for each start state & rule...-> start_info :: [(String, Name, Name, Bool)]-> start_info = starts gram --> start_spont :: [(Int, Lr0Item ,NameSet)]-> start_spont = [ (start, (Lr0 start 0), -> NameSet.singleton (startLookahead gram partial))-> | (start, (_,_,_,partial)) <- -> zip [ 0 .. length start_info - 1] start_info]--> propLAItem :: Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)])-> propLAItem item@(Lr0 rule dot) = (spontaneous, propagated)-> where--> j = closure1 gram first [Lr1 rule dot (NameSet.singleton dummyTok)]--> spontaneous :: [(Int, Lr0Item, NameSet)]-> spontaneous = concat [ -> (case findRule gram rule' dot' of-> Nothing -> []-> Just x -> case lookup x goto of-> Nothing -> error "spontaneous"-> Just k ->-> case NameSet.filter (/= dummyTok) ts of-> ts' | NameSet.null ts' -> []-> | otherwise -> [(k, Lr0 rule' (dot' + 1), ts')])-> | (Lr1 rule' dot' ts) <- j ]--> propagated :: [(Lr0Item, Int, Lr0Item)]-> propagated = concat [-> (case findRule gram rule' dot' of-> Nothing -> []-> Just x -> case lookup x goto of-> Nothing -> error "propagated"-> Just k -> [(item, k, Lr0 rule' (dot' + 1))])-> | (Lr1 rule' dot' ts) <- j, dummyTok `elem` (NameSet.toAscList ts) ]--The lookahead for a start rule depends on whether it was declared-with %name or %partial: a %name parser is assumed to parse the whole-input, ending with EOF, whereas a %partial parser may parse only a-part of the input: it accepts when the error token is found.--> startLookahead :: Grammar -> Bool -> Name-> startLookahead gram partial = if partial then errorTok else eof_term gram--------------------------------------------------------------------------------Calculate lookaheads--Special version using a mutable array:--> calcLookaheads-> :: Int -- number of states-> -> [(Int, Lr0Item, NameSet)] -- spontaneous lookaheads-> -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads-> -> Array Int [(Lr0Item, NameSet)]--> calcLookaheads n_states spont prop-> = runST (do-> arr <- newArray (0,n_states) []-> propagate arr (foldr fold_lookahead [] spont)-> freeze arr-> )--> where-> propagate :: STArray s Int [(Lr0Item, NameSet)]-> -> [(Int, Lr0Item, NameSet)] -> ST s ()-> propagate _ [] = return ()-> propagate arr new = do -> let-> items = [ (i,item'',s) | (j,item,s) <- new, -> (item',i,item'') <- prop ! j,-> item == item' ]-> new_new <- get_new arr items []-> add_lookaheads arr new-> propagate arr new_new--This function is needed to merge all the (set_no,item,name) triples-into (set_no, item, set name) triples. It can be removed when we get-the spontaneous lookaheads in the right form to begin with (ToDo).--> add_lookaheads :: STArray s Int [(Lr0Item, NameSet)]-> -> [(Int, Lr0Item, NameSet)]-> -> ST s ()-> add_lookaheads _ [] = return ()-> add_lookaheads arr ((i,item,s) : lookaheads) = do-> las <- readArray arr i-> writeArray arr i (add_lookahead item s las)-> add_lookaheads arr lookaheads--> get_new :: STArray s Int [(Lr0Item, NameSet)]-> -> [(Int, Lr0Item, NameSet)]-> -> [(Int, Lr0Item, NameSet)]-> -> ST s [(Int, Lr0Item, NameSet)]-> get_new _ [] new = return new-> get_new arr (l@(i,_item,_s):las) new = do-> state_las <- readArray arr i-> get_new arr las (get_new' l state_las new)--> add_lookahead :: Lr0Item -> NameSet -> [(Lr0Item,NameSet)] ->-> [(Lr0Item,NameSet)]-> add_lookahead item s [] = [(item,s)]-> add_lookahead item s (m@(item',s') : las)-> | item == item' = (item, s `NameSet.union` s') : las-> | otherwise = m : add_lookahead item s las--> get_new' :: (Int,Lr0Item,NameSet) -> [(Lr0Item,NameSet)] ->-> [(Int,Lr0Item,NameSet)] -> [(Int,Lr0Item,NameSet)]-> get_new' l [] new = l : new-> get_new' l@(i,item,s) ((item',s') : las) new-> | item == item' =-> let s'' = NameSet.filter (\x -> not (NameSet.member x s')) s in-> if NameSet.null s'' then new else-> ((i,item,s''):new)-> | otherwise = -> get_new' l las new--> fold_lookahead :: (Int,Lr0Item,NameSet) -> [(Int,Lr0Item,NameSet)]-> -> [(Int,Lr0Item,NameSet)]-> fold_lookahead l [] = [l]-> fold_lookahead l@(i,item,s) (m@(i',item',s'):las)-> | i == i' && item == item' = (i,item, s `NameSet.union` s'):las-> | i < i' = (i,item,s):m:las-> | otherwise = m : fold_lookahead l las--Normal version:--calcLookaheads- :: Int -- number of states- -> [(Int, Lr0Item, Set Name)] -- spontaneous lookaheads- -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads- -> Array Int [(Lr0Item, Set Name)]--calcLookaheads n_states spont prop- = rebuildArray $ fst (mkClosure (\(_,new) _ -> null new) propagate- ([], foldr addLookahead [] spont))- where-- rebuildArray :: [(Int, Lr0Item, Set Name)] -> Array Int [(Lr0Item, Set Name)]- rebuildArray xs = accumArray (++) [] (0,n_states-1)- [ (a, [(b,c)]) | (a,b,c) <- xs ]-- propagate (las,new) = - let- items = [ (i,item'',s) | (j,item,s) <- new, - (item',i,item'') <- prop ! j,- item == item' ]- new_new = foldr (\i new -> getNew i las new) [] items- new_las = foldr addLookahead las new- in- (new_las, new_new)--addLookahead :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)]- -> [(Int,Lr0Item,Set Name)]-addLookahead l [] = [l]-addLookahead l@(i,item,s) (m@(i',item',s'):las)- | i == i' && item == item' = (i,item, s `Set.union` s'):las- | i < i' = (i,item,s):m:las- | otherwise = m : addLookahead l las--getNew :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)]- -> [(Int,Lr0Item,Set Name)] -> [(Int,Lr0Item,Set Name)]-getNew l [] new = l:new-getNew l@(i,item,s) (m@(i',item',s'):las) new- | i == i' && item == item' = - let s'' = filter (`notElem` s') s in- if null s'' then new else- ((i,item,s''):new)- | i < i' = (i,item,s):new- | otherwise = getNew l las new--------------------------------------------------------------------------------Merge lookaheads--Stick the lookahead info back into the state table.--> mergeLookaheadInfo-> :: Array Int [(Lr0Item, NameSet)] -- lookahead info-> -> [(Set Lr0Item, [(Name,Int)])] -- state table-> -> [ ([Lr1Item], [(Name,Int)]) ]--> mergeLookaheadInfo lookaheads sets-> = zipWith mergeIntoSet sets [0..]-> where--> mergeIntoSet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([Lr1Item], [(Name, Int)])-> mergeIntoSet (items, goto) i-> = (concat (map mergeIntoItem (Set.toAscList items)), goto)-> where--> mergeIntoItem :: Lr0Item -> [Lr1Item]-> mergeIntoItem item@(Lr0 rule dot)-> = [Lr1 rule dot la]-> where la = case [ s | (item',s) <- lookaheads ! i,-> item == item' ] of-> [] -> NameSet.empty-> [x] -> x-> _ -> error "mergIntoItem"--------------------------------------------------------------------------------Generate the goto table--This is pretty straightforward, given all the information we stored-while generating the LR0 sets of items.--Generating the goto table doesn't need lookahead info.--> genGotoTable :: Grammar -> [(Set Lr0Item,[(Name,Int)])] -> GotoTable-> genGotoTable g sets = gotoTable-> where-> Grammar{ first_nonterm = fst_nonterm,-> first_term = fst_term,-> non_terminals = non_terms } = g->-> -- goto array doesn't include %start symbols-> gotoTable = listArray (0,length sets-1)-> [-> (array (fst_nonterm, fst_term-1) [ -> (n, case lookup n goto of-> Nothing -> NoGoto-> Just s -> Goto s)-> | n <- non_terms,-> n >= fst_nonterm, n < fst_term ])-> | (_set,goto) <- sets ]--------------------------------------------------------------------------------Generate the action table--> genActionTable :: Grammar -> ([Name] -> NameSet) ->-> [([Lr1Item],[(Name,Int)])] -> ActionTable-> genActionTable g first sets = actionTable-> where-> Grammar { first_term = fst_term,-> terminals = terms,-> starts = starts',-> priorities = prios } = g--> n_starts = length starts'-> isStartRule rule = rule < n_starts -- a bit hacky, but it'll do for now--> term_lim = (head terms,last terms)-> actionTable = array (0,length sets-1)-> [ (set_no, accumArray res-> LR'Fail term_lim -> (possActions goto set))-> | ((set,goto),set_no) <- zip sets [0..] ]--> possAction goto _set (Lr1 rule pos la) = -> case findRule g rule pos of-> Just t | t >= fst_term || t == errorTok -> -> case lookup t goto of-> Nothing -> []-> Just j ->-> case lookup t prios of-> Nothing -> [ (t,LR'Shift j{-'-} No) ]-> Just p -> [ (t,LR'Shift j{-'-} p) ]-> Nothing-> | isStartRule rule-> -> let (_,_,_,partial) = starts' !! rule in-> [ (startLookahead g partial, LR'Accept{-'-}) ]-> | otherwise -> -> case lookupProdNo g rule of-> (_,_,_,p) -> zip (NameSet.toAscList la) (repeat (LR'Reduce rule p))-> _ -> []--> possActions goto coll = -> (concat [ possAction goto coll item |-> item <- closure1 g first coll ])--These comments are now out of date! /JS--Here's how we resolve conflicts, leaving a complete record of the-conflicting actions in an LR'Multiple structure for later output in-the info file.--Shift/reduce conflicts are always resolved as shift actions, and-reduce/reduce conflicts are resolved as a reduce action using the rule-with the lowest number (i.e. the rule that comes first in the grammar-file.)--NOTES on LR'MustFail: this was introduced as part of the precedence-parsing changes. The problem with LR'Fail is that it is a soft-failure: we sometimes substitute an LR'Fail for an LR'Reduce (eg. when-computing default actions), on the grounds that an LR'Fail in this-state will also be an LR'Fail in the goto state, so we'll fail-eventually. This may not be true with precedence parsing, though. If-there are two non-associative operators together, we must fail at this-point rather than reducing. Hence the use of LR'MustFail.---NOTE: on (LR'Multiple as a) handling- PCC [sep04] has changed this to have the following invariants:- * the winning action appears only once, in the "a" slot- * only reductions appear in the "as" list- * there are no duplications- This removes complications elsewhere, where LR'Multiples were - building up tree structures... --> res LR'Fail x = x-> res x LR'Fail = x-> res LR'MustFail _ = LR'MustFail-> res _ LR'MustFail = LR'MustFail-> res x x' | x == x' = x-> res (LR'Accept) _ = LR'Accept-> res _ (LR'Accept) = LR'Accept--> res (LR'Multiple as x) (LR'Multiple bs x')-> | x == x' = LR'Multiple (nub $ as ++ bs) x-> -- merge dropped reductions for identical action--> res (LR'Multiple as x) (LR'Multiple bs x')-> = case res x x' of -> LR'Multiple cs a-> | a == x -> LR'Multiple (nub $ x' : as ++ bs ++ cs) x-> | a == x' -> LR'Multiple (nub $ x : as ++ bs ++ cs) x'-> | otherwise -> error "failed invariant in resolve"-> -- last means an unexpected change-> other -> other-> -- merge dropped reductions for clashing actions, but only -> -- if they were S/R or R/R--> res a@(LR'Multiple _ _) b = res a (LR'Multiple [] b)-> res a b@(LR'Multiple _ _) = res (LR'Multiple [] a) b -> -- leave cases above to do the appropriate merging--> res a@(LR'Shift {}) b@(LR'Reduce {}) = res b a-> res a@(LR'Reduce _ p) b@(LR'Shift _ p')-> = case (p,p') of-> (No,_) -> LR'Multiple [a] b -- shift wins-> (_,No) -> LR'Multiple [a] b -- shift wins-> (Prio c i, Prio _ j)-> | i < j -> b-> | i > j -> a-> | otherwise ->-> case c of-> LeftAssoc -> a-> RightAssoc -> b-> None -> LR'MustFail-> res a@(LR'Reduce r p) b@(LR'Reduce r' p')-> = case (p,p') of-> (No,_) -> LR'Multiple [a] b -- give to earlier rule?-> (_,No) -> LR'Multiple [a] b-> (Prio _ i, Prio _ j)-> | i < j -> b-> | j > i -> a-> | r < r' -> LR'Multiple [b] a-> | otherwise -> LR'Multiple [a] b-> res _ _ = error "confict in resolve"--------------------------------------------------------------------------------Count the conflicts--> countConflicts :: ActionTable -> (Array Int (Int,Int), (Int,Int))-> countConflicts action-> = (conflictArray, foldr (\(a,b) (c,d) -> (a+c, b+d)) (0,0) conflictList)-> -> where-> -> conflictArray = listArray (Array.bounds action) conflictList-> conflictList = map countConflictsState (assocs action)->-> countConflictsState (_state, actions)-> = foldr countMultiples (0,0) (elems actions)-> where-> countMultiples (LR'Multiple (_:_) (LR'Shift{})) (sr,rr) -> = (sr + 1, rr)-> countMultiples (LR'Multiple (_:_) (LR'Reduce{})) (sr,rr) -> = (sr, rr + 1)-> countMultiples (LR'Multiple _ _) _-> = error "bad conflict representation"-> countMultiples _ c = c---------------------------------------------------------------------------------> findRule :: Grammar -> Int -> Int -> Maybe Name-> findRule g rule dot = -> case lookupProdNo g rule of-> (_,lhs,_,_) -> case drop dot lhs of-> (a:_) -> Just a-> _ -> Nothing+ + + + + + + + + + + + + + +> module LALR +> (genActionTable, genGotoTable, genLR0items, precalcClosure0, +> propLookaheads, calcLookaheads, mergeLookaheadInfo, countConflicts, +> Lr0Item(..), Lr1Item) +> where + + +> import GenUtils +> import Data.Set ( Set ) +> import qualified Data.Set as Set hiding ( Set ) +> import qualified NameSet +> import NameSet ( NameSet ) +> import Grammar + + +> import Control.Monad.ST +> import Data.Array.ST +> import Data.Array as Array +> import Data.List (nub) + + +> unionMap :: (Ord b) => (a -> Set b) -> Set a -> Set b +> unionMap f = Set.fold (Set.union . f) Set.empty + + +> unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet +> unionNameMap f = NameSet.fold (NameSet.union . f) NameSet.empty + + + + + + +> data Lr0Item = Lr0 {-#UNPACK#-}!Int {-#UNPACK#-}!Int -- (rule, dot) +> deriving (Eq,Ord) + + +> data Lr1Item = Lr1 {-#UNPACK#-}!Int {-#UNPACK#-}!Int NameSet -- (rule, dot, lookahead) +> type RuleList = [Lr0Item] + + + + + + + + + + + + + + +> precalcClosure0 :: Grammar -> Name -> RuleList +> precalcClosure0 g = +> \n -> case lookup n info' of +> Nothing -> [] +> Just c -> c +> where +> +> info' :: [(Name, RuleList)] +> info' = map (\(n,rules) -> (n,map (\rule -> Lr0 rule 0) (NameSet.toAscList rules))) info + + +> info :: [(Name, NameSet)] +> info = mkClosure (==) (\f -> map (follow f) f) +> (map (\nt -> (nt,NameSet.fromList (lookupProdsOfName g nt))) nts) + + +> follow :: [(Name, NameSet)] -> (Name, NameSet) -> (Name, NameSet) +> follow f (nt,rules) = (nt, unionNameMap (followNT f) rules `NameSet.union` rules) + + +> followNT :: [(Name, NameSet)] -> Int -> NameSet +> followNT f rule = +> case findRule g rule 0 of +> Just nt | nt >= firstStartTok && nt < fst_term -> +> case lookup nt f of +> Just rs -> rs +> Nothing -> error "followNT" +> _ -> NameSet.empty + + +> nts = non_terminals g +> fst_term = first_term g + + +> closure0 :: Grammar -> (Name -> RuleList) -> Set Lr0Item -> Set Lr0Item +> closure0 g closureOfNT set = Set.fold addRules Set.empty set +> where +> fst_term = first_term g +> addRules rule set' = Set.union (Set.fromList (rule : closureOfRule rule)) set' +> +> closureOfRule (Lr0 rule dot) = +> case findRule g rule dot of +> (Just nt) | nt >= firstStartTok && nt < fst_term +> -> closureOfNT nt +> _ -> [] + + + + + + + + +> closure1 :: Grammar -> ([Name] -> NameSet) -> [Lr1Item] -> [Lr1Item] +> closure1 g first set +> = fst (mkClosure (\(_,new) _ -> null new) addItems ([],set)) +> where +> fst_term = first_term g + + +> addItems :: ([Lr1Item],[Lr1Item]) -> ([Lr1Item],[Lr1Item]) +> addItems (old_items, new_items) = (new_old_items, new_new_items) +> where +> new_old_items = new_items `union_items` old_items +> new_new_items = subtract_items +> (foldr union_items [] (map fn new_items)) +> new_old_items + + +> fn :: Lr1Item -> [Lr1Item] +> fn (Lr1 rule dot as) = +> case lookupProdNo g rule of { (_name,lhs,_,_) -> +> case drop dot lhs of +> (b:beta) | b >= firstStartTok && b < fst_term -> +> let terms = unionNameMap +> (\a -> first (beta ++ [a])) as +> in +> [ (Lr1 rule' 0 terms) | rule' <- lookupProdsOfName g b ] +> _ -> [] +> } + + + + + + +> subtract_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item] +> subtract_items items1 items2 = foldr (subtract_item items2) [] items1 + + + + + + + + + + +> subtract_item :: [Lr1Item] -> Lr1Item -> [Lr1Item] -> [Lr1Item] +> subtract_item [] i result = i : result +> subtract_item ((Lr1 rule dot as):items) i@(Lr1 rule' dot' as') result = +> case compare rule' rule of +> LT -> i : result +> GT -> carry_on +> EQ -> case compare dot' dot of +> LT -> i : result +> GT -> carry_on +> EQ -> case NameSet.difference as' as of +> bs | NameSet.null bs -> result +> | otherwise -> (Lr1 rule dot bs) : result +> where +> carry_on = subtract_item items i result + + + + + + +> union_items :: [Lr1Item] -> [Lr1Item] -> [Lr1Item] +> union_items is [] = is +> union_items [] is = is +> union_items (i@(Lr1 rule dot as):is) (i'@(Lr1 rule' dot' as'):is') = +> case compare rule rule' of +> LT -> drop_i +> GT -> drop_i' +> EQ -> case compare dot dot' of +> LT -> drop_i +> GT -> drop_i' +> EQ -> (Lr1 rule dot (as `NameSet.union` as')) : union_items is is' +> where +> drop_i = i : union_items is (i':is') +> drop_i' = i' : union_items (i:is) is' + + + + + + + + + + + + + + + + +> gotoClosure :: Grammar -> Set Lr0Item -> Name -> Set Lr0Item +> gotoClosure gram i x = unionMap fn i +> where +> fn (Lr0 rule_no dot) = +> case findRule gram rule_no dot of +> Just t | x == t -> Set.singleton (Lr0 rule_no (dot+1)) +> _ -> Set.empty + + + + + + + + + + + + + + + + + + + + + + + + +> type ItemSetWithGotos = (Set Lr0Item, [(Name,Int)]) + + +> genLR0items :: Grammar -> (Name -> RuleList) -> [ItemSetWithGotos] +> genLR0items g precalcClosures +> = fst (mkClosure (\(_old,new) _ -> null new) +> addItems +> (([],startRules))) +> where + + +> n_starts = length (starts g) +> startRules :: [Set Lr0Item] +> startRules = [ Set.singleton (Lr0 rule 0) | rule <- [0..n_starts] ] + + +> tokens = non_terminals g ++ terminals g + + +> addItems :: ([ItemSetWithGotos], [Set Lr0Item]) +> -> ([ItemSetWithGotos], [Set Lr0Item]) +> +> addItems (oldSets,newSets) = (newOldSets, reverse newNewSets) +> where +> +> newOldSets = oldSets ++ (zip newSets intgotos) + + +> itemSets = map fst oldSets ++ newSets + + + + + + + + +> gotos :: [[(Name,Set Lr0Item)]] +> gotos = map (filter (not . Set.null . snd)) +> (map (\i -> let i' = closure0 g precalcClosures i in +> [ (x,gotoClosure g i' x) | x <- tokens ]) newSets) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +> numberSets +> :: [(Name,Set Lr0Item)] +> -> (Int, +> [[(Name,Int)]], +> [Set Lr0Item]) +> -> (Int, [[(Name,Int)]], [Set Lr0Item]) +> +> numberSets [] (i,gotos',newSets') = (i,([]:gotos'),newSets') +> numberSets ((x,gotoix):rest) (i,g':gotos',newSets') +> = numberSets rest +> (case indexInto 0 gotoix (itemSets ++ reverse newSets') of +> Just j -> (i, ((x,j):g'):gotos', newSets') +> Nothing -> (i+1,((x,i):g'):gotos', gotoix:newSets')) +> numberSets _ _ = error "genLR0items/numberSets: Unhandled case" + + + + + + +> intgotos :: [[(Name,Int)]] +> newNewSets :: [Set Lr0Item] +> (_, ([]:intgotos), newNewSets) = +> foldr numberSets (length newOldSets, [[]], []) gotos + + +> indexInto :: Eq a => Int -> a -> [a] -> Maybe Int +> indexInto _ _ [] = Nothing +> indexInto i x (y:ys) | x == y = Just i +> | otherwise = indexInto (i+1) x ys + + + + + + + + + + + + + + +> propLookaheads +> :: Grammar +> -> [(Set Lr0Item,[(Name,Int)])] -- LR(0) kernel sets +> -> ([Name] -> NameSet) -- First function +> -> ( +> [(Int, Lr0Item, NameSet)], -- spontaneous lookaheads +> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads +> ) + + +> propLookaheads gram sets first = (concat s, array (0,length sets - 1) +> [ (a,b) | (a,b) <- p ]) +> where + + +> (s,p) = unzip (zipWith propLASet sets [0..]) + + +> propLASet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([(Int, Lr0Item, NameSet)],(Int,[(Lr0Item, Int, Lr0Item)])) +> propLASet (set,goto) i = (start_spont ++ concat s', (i, concat p')) +> where + + +> (s',p') = unzip (map propLAItem (Set.toAscList set)) + + +> -- spontaneous EOF lookaheads for each start state & rule... +> start_info :: [(String, Name, Name, Bool)] +> start_info = starts gram + + +> start_spont :: [(Int, Lr0Item ,NameSet)] +> start_spont = [ (start, (Lr0 start 0), +> NameSet.singleton (startLookahead gram partial)) +> | (start, (_,_,_,partial)) <- +> zip [ 0 .. length start_info - 1] start_info] + + +> propLAItem :: Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)]) +> propLAItem item@(Lr0 rule dot) = (spontaneous, propagated) +> where + + +> j = closure1 gram first [Lr1 rule dot (NameSet.singleton dummyTok)] + + +> spontaneous :: [(Int, Lr0Item, NameSet)] +> spontaneous = concat [ +> (case findRule gram rule' dot' of +> Nothing -> [] +> Just x -> case lookup x goto of +> Nothing -> error "spontaneous" +> Just k -> +> case NameSet.filter (/= dummyTok) ts of +> ts' | NameSet.null ts' -> [] +> | otherwise -> [(k, Lr0 rule' (dot' + 1), ts')]) +> | (Lr1 rule' dot' ts) <- j ] + + +> propagated :: [(Lr0Item, Int, Lr0Item)] +> propagated = concat [ +> (case findRule gram rule' dot' of +> Nothing -> [] +> Just x -> case lookup x goto of +> Nothing -> error "propagated" +> Just k -> [(item, k, Lr0 rule' (dot' + 1))]) +> | (Lr1 rule' dot' ts) <- j, dummyTok `elem` (NameSet.toAscList ts) ] + + + + + + + + + + + + +> startLookahead :: Grammar -> Bool -> Name +> startLookahead gram partial = if partial then errorTok else eof_term gram + + + + + + + + + + + + +> calcLookaheads +> :: Int -- number of states +> -> [(Int, Lr0Item, NameSet)] -- spontaneous lookaheads +> -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads +> -> Array Int [(Lr0Item, NameSet)] + + +> calcLookaheads n_states spont prop +> = runST (do +> arr <- newArray (0,n_states) [] +> propagate arr (foldr fold_lookahead [] spont) +> freeze arr +> ) + + +> where +> propagate :: STArray s Int [(Lr0Item, NameSet)] +> -> [(Int, Lr0Item, NameSet)] -> ST s () +> propagate _ [] = return () +> propagate arr new = do +> let +> items = [ (i,item'',s) | (j,item,s) <- new, +> (item',i,item'') <- prop ! j, +> item == item' ] +> new_new <- get_new arr items [] +> add_lookaheads arr new +> propagate arr new_new + + + + + + + + + + +> add_lookaheads :: STArray s Int [(Lr0Item, NameSet)] +> -> [(Int, Lr0Item, NameSet)] +> -> ST s () +> add_lookaheads _ [] = return () +> add_lookaheads arr ((i,item,s) : lookaheads) = do +> las <- readArray arr i +> writeArray arr i (add_lookahead item s las) +> add_lookaheads arr lookaheads + + +> get_new :: STArray s Int [(Lr0Item, NameSet)] +> -> [(Int, Lr0Item, NameSet)] +> -> [(Int, Lr0Item, NameSet)] +> -> ST s [(Int, Lr0Item, NameSet)] +> get_new _ [] new = return new +> get_new arr (l@(i,_item,_s):las) new = do +> state_las <- readArray arr i +> get_new arr las (get_new' l state_las new) + + +> add_lookahead :: Lr0Item -> NameSet -> [(Lr0Item,NameSet)] -> +> [(Lr0Item,NameSet)] +> add_lookahead item s [] = [(item,s)] +> add_lookahead item s (m@(item',s') : las) +> | item == item' = (item, s `NameSet.union` s') : las +> | otherwise = m : add_lookahead item s las + + +> get_new' :: (Int,Lr0Item,NameSet) -> [(Lr0Item,NameSet)] -> +> [(Int,Lr0Item,NameSet)] -> [(Int,Lr0Item,NameSet)] +> get_new' l [] new = l : new +> get_new' l@(i,item,s) ((item',s') : las) new +> | item == item' = +> let s'' = NameSet.filter (\x -> not (NameSet.member x s')) s in +> if NameSet.null s'' then new else +> ((i,item,s''):new) +> | otherwise = +> get_new' l las new + + +> fold_lookahead :: (Int,Lr0Item,NameSet) -> [(Int,Lr0Item,NameSet)] +> -> [(Int,Lr0Item,NameSet)] +> fold_lookahead l [] = [l] +> fold_lookahead l@(i,item,s) (m@(i',item',s'):las) +> | i == i' && item == item' = (i,item, s `NameSet.union` s'):las +> | i < i' = (i,item,s):m:las +> | otherwise = m : fold_lookahead l las + + + + + + + + + + + -> [(Int, Lr0Item, Set Name)] -- spontaneous lookaheads + -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads + -> Array Int [(Lr0Item, Set Name)] + + + + + = rebuildArray $ fst (mkClosure (\(_,new) _ -> null new) propagate + + + + + + + rebuildArray :: [(Int, Lr0Item, Set Name)] -> Array Int [(Lr0Item, Set Name)] + + + + + + + + + + + + + + + + + new_new = foldr (\i new -> getNew i las new) [] items + + + + + + + + +addLookahead :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)] + -> [(Int,Lr0Item,Set Name)] + + + + + + + + + + + + +getNew :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)] + -> [(Int,Lr0Item,Set Name)] -> [(Int,Lr0Item,Set Name)] + + + + + + + + + + + + + + + + + + + + + + + + + + + + +> mergeLookaheadInfo +> :: Array Int [(Lr0Item, NameSet)] -- lookahead info +> -> [(Set Lr0Item, [(Name,Int)])] -- state table +> -> [ ([Lr1Item], [(Name,Int)]) ] + + +> mergeLookaheadInfo lookaheads sets +> = zipWith mergeIntoSet sets [0..] +> where + + +> mergeIntoSet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([Lr1Item], [(Name, Int)]) +> mergeIntoSet (items, goto) i +> = (concat (map mergeIntoItem (Set.toAscList items)), goto) +> where + + +> mergeIntoItem :: Lr0Item -> [Lr1Item] +> mergeIntoItem item@(Lr0 rule dot) +> = [Lr1 rule dot la] +> where la = case [ s | (item',s) <- lookaheads ! i, +> item == item' ] of +> [] -> NameSet.empty +> [x] -> x +> _ -> error "mergIntoItem" + + + + + + + + + + + + + + + + + + +> genGotoTable :: Grammar -> [(Set Lr0Item,[(Name,Int)])] -> GotoTable +> genGotoTable g sets = gotoTable +> where +> Grammar{ first_nonterm = fst_nonterm, +> first_term = fst_term, +> non_terminals = non_terms } = g +> +> -- goto array doesn't include %start symbols +> gotoTable = listArray (0,length sets-1) +> [ +> (array (fst_nonterm, fst_term-1) [ +> (n, case lookup n goto of +> Nothing -> NoGoto +> Just s -> Goto s) +> | n <- non_terms, +> n >= fst_nonterm, n < fst_term ]) +> | (_set,goto) <- sets ] + + + + + + + + +> genActionTable :: Grammar -> ([Name] -> NameSet) -> +> [([Lr1Item],[(Name,Int)])] -> ActionTable +> genActionTable g first sets = actionTable +> where +> Grammar { first_term = fst_term, +> terminals = terms, +> starts = starts', +> priorities = prios } = g + + +> n_starts = length starts' +> isStartRule rule = rule < n_starts -- a bit hacky, but it'll do for now + + +> term_lim = (head terms,last terms) +> actionTable = array (0,length sets-1) +> [ (set_no, accumArray res +> LR'Fail term_lim +> (possActions goto set)) +> | ((set,goto),set_no) <- zip sets [0..] ] + + +> possAction goto _set (Lr1 rule pos la) = +> case findRule g rule pos of +> Just t | t >= fst_term || t == errorTok -> +> case lookup t goto of +> Nothing -> [] +> Just j -> +> case lookup t prios of +> Nothing -> [ (t,LR'Shift j{-'-} No) ] +> Just p -> [ (t,LR'Shift j{-'-} p) ] +> Nothing +> | isStartRule rule +> -> let (_,_,_,partial) = starts' !! rule in +> [ (startLookahead g partial, LR'Accept{-'-}) ] +> | otherwise +> -> case lookupProdNo g rule of +> (_,_,_,p) -> zip (NameSet.toAscList la) (repeat (LR'Reduce rule p)) +> _ -> [] + + +> possActions goto coll = +> (concat [ possAction goto coll item | +> item <- closure1 g first coll ]) + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +> res LR'Fail x = x +> res x LR'Fail = x +> res LR'MustFail _ = LR'MustFail +> res _ LR'MustFail = LR'MustFail +> res x x' | x == x' = x +> res (LR'Accept) _ = LR'Accept +> res _ (LR'Accept) = LR'Accept + + +> res (LR'Multiple as x) (LR'Multiple bs x') +> | x == x' = LR'Multiple (nub $ as ++ bs) x +> -- merge dropped reductions for identical action + + +> res (LR'Multiple as x) (LR'Multiple bs x') +> = case res x x' of +> LR'Multiple cs a +> | a == x -> LR'Multiple (nub $ x' : as ++ bs ++ cs) x +> | a == x' -> LR'Multiple (nub $ x : as ++ bs ++ cs) x' +> | otherwise -> error "failed invariant in resolve" +> -- last means an unexpected change +> other -> other +> -- merge dropped reductions for clashing actions, but only +> -- if they were S/R or R/R + + +> res a@(LR'Multiple _ _) b = res a (LR'Multiple [] b) +> res a b@(LR'Multiple _ _) = res (LR'Multiple [] a) b +> -- leave cases above to do the appropriate merging + + +> res a@(LR'Shift {}) b@(LR'Reduce {}) = res b a +> res a@(LR'Reduce _ p) b@(LR'Shift _ p') +> = case (p,p') of +> (No,_) -> LR'Multiple [a] b -- shift wins +> (_,No) -> LR'Multiple [a] b -- shift wins +> (Prio c i, Prio _ j) +> | i < j -> b +> | i > j -> a +> | otherwise -> +> case c of +> LeftAssoc -> a +> RightAssoc -> b +> None -> LR'MustFail +> res a@(LR'Reduce r p) b@(LR'Reduce r' p') +> = case (p,p') of +> (No,_) -> LR'Multiple [a] b -- give to earlier rule? +> (_,No) -> LR'Multiple [a] b +> (Prio _ i, Prio _ j) +> | i < j -> b +> | j > i -> a +> | r < r' -> LR'Multiple [b] a +> | otherwise -> LR'Multiple [a] b +> res _ _ = error "confict in resolve" + + + + + + + + +> countConflicts :: ActionTable -> (Array Int (Int,Int), (Int,Int)) +> countConflicts action +> = (conflictArray, foldr (\(a,b) (c,d) -> (a+c, b+d)) (0,0) conflictList) +> +> where +> +> conflictArray = listArray (Array.bounds action) conflictList +> conflictList = map countConflictsState (assocs action) +> +> countConflictsState (_state, actions) +> = foldr countMultiples (0,0) (elems actions) +> where +> countMultiples (LR'Multiple (_:_) (LR'Shift{})) (sr,rr) +> = (sr + 1, rr) +> countMultiples (LR'Multiple (_:_) (LR'Reduce{})) (sr,rr) +> = (sr, rr + 1) +> countMultiples (LR'Multiple _ _) _ +> = error "bad conflict representation" +> countMultiples _ c = c + + + + + + +> findRule :: Grammar -> Int -> Int -> Maybe Name +> findRule g rule dot = +> case lookupProdNo g rule of +> (_,lhs,_,_) -> case drop dot lhs of +> (a:_) -> Just a +> _ -> Nothing
src/Lexer.lhs view
@@ -1,251 +1,302 @@-------------------------------------------------------------------------------The lexer.--(c) 1993-2001 Andy Gill, Simon Marlow--------------------------------------------------------------------------------> module Lexer (-> Token(..),-> TokenId(..),-> lexer ) where--> import ParseMonad --> import Data.Char ( isSpace, isAlphaNum, isDigit, digitToInt )--> data Token -> = TokenInfo String TokenId-> | TokenNum Int TokenId-> | TokenKW TokenId-> | TokenEOF--> tokenToId :: Token -> TokenId-> tokenToId (TokenInfo _ i) = i-> tokenToId (TokenNum _ i) = i-> tokenToId (TokenKW i) = i-> tokenToId TokenEOF = error "tokenToId TokenEOF"--> instance Eq Token where-> i == i' = tokenToId i == tokenToId i'--> instance Ord Token where-> i <= i' = tokenToId i <= tokenToId i'--> data TokenId -> = TokId -- words and symbols-> | TokSpecId_TokenType -- %tokentype-> | TokSpecId_Token -- %token-> | TokSpecId_Name -- %name-> | TokSpecId_Partial -- %partial-> | TokSpecId_Lexer -- %lexer-> | TokSpecId_ImportedIdentity -- %importedidentity-> | TokSpecId_Monad -- %monad-> | TokSpecId_Nonassoc -- %nonassoc-> | TokSpecId_Left -- %left-> | TokSpecId_Right -- %right-> | TokSpecId_Prec -- %prec-> | TokSpecId_Expect -- %expect-> | TokSpecId_Error -- %error-> | TokSpecId_Attributetype -- %attributetype-> | TokSpecId_Attribute -- %attribute-> | TokCodeQuote -- stuff inside { .. }-> | TokColon -- :-> | TokSemiColon -- ;-> | TokDoubleColon -- ::-> | TokDoublePercent -- %%-> | TokBar -- |-> | TokNum -- Integer-> | TokParenL -- (-> | TokParenR -- )-> | TokComma -- ,-> deriving (Eq,Ord--#ifdef DEBUG--> ,Show--#endif--> )--ToDo: proper text instance here, for use in parser error messages.--> lexer :: (Token -> P a) -> P a-> lexer cont = P lexer'-> where lexer' "" = returnToken cont TokenEOF ""-> lexer' ('-':'-':r) = lexer' (dropWhile (/= '\n') r)-> lexer' ('{':'-':r) = \line -> lexNestedComment line lexer' r line-> lexer' (c:rest) = nextLex cont c rest--> returnToken :: (t -> P a) -> t -> String -> Int -> ParseResult a-> returnToken cont tok = runP (cont tok)--> nextLex :: (Token -> P a) -> Char -> String -> Int -> ParseResult a-> nextLex cont c = case c of-> '\n' -> \rest line -> returnToken lexer cont rest (line+1)-> '%' -> lexPercent cont-> ':' -> lexColon cont-> ';' -> returnToken cont (TokenKW TokSemiColon)--> '|' -> returnToken cont (TokenKW TokBar)-> '\'' -> lexChar cont-> '"'{-"-}-> lexString cont-> '{' -> lexCode cont--> '(' -> returnToken cont (TokenKW TokParenL)-> ')' -> returnToken cont (TokenKW TokParenR)-> ',' -> returnToken cont (TokenKW TokComma)--> _ -> | isSpace c -> runP (lexer cont)-> | c >= 'a' && c <= 'z' -> || c >= 'A' && c <= 'Z' -> lexId cont c-> | isDigit c -> lexNum cont c-> _ -> lexError ("lexical error before `" ++ c : "'")--Percents come in two forms, in pairs, or -followed by a special identifier.--> lexPercent :: (Token -> P a) -> [Char] -> Int -> ParseResult a-> lexPercent cont s = case s of-> '%':rest -> returnToken cont (TokenKW TokDoublePercent) rest-> 't':'o':'k':'e':'n':'t':'y':'p':'e':rest -> -> returnToken cont (TokenKW TokSpecId_TokenType) rest-> 't':'o':'k':'e':'n':rest ->-> returnToken cont (TokenKW TokSpecId_Token) rest-> 'n':'a':'m':'e':rest ->-> returnToken cont (TokenKW TokSpecId_Name) rest-> 'p':'a':'r':'t':'i':'a':'l':rest ->-> returnToken cont (TokenKW TokSpecId_Partial) rest-> 'i':'m':'p':'o':'r':'t':'e':'d':'i':'d':'e':'n':'t':'i':'t':'y':rest ->-> returnToken cont (TokenKW TokSpecId_ImportedIdentity) rest-> 'm':'o':'n':'a':'d':rest ->-> returnToken cont (TokenKW TokSpecId_Monad) rest-> 'l':'e':'x':'e':'r':rest ->-> returnToken cont (TokenKW TokSpecId_Lexer) rest-> 'n':'o':'n':'a':'s':'s':'o':'c':rest ->-> returnToken cont (TokenKW TokSpecId_Nonassoc) rest-> 'l':'e':'f':'t':rest ->-> returnToken cont (TokenKW TokSpecId_Left) rest-> 'r':'i':'g':'h':'t':rest ->-> returnToken cont (TokenKW TokSpecId_Right) rest-> 'p':'r':'e':'c':rest ->-> returnToken cont (TokenKW TokSpecId_Prec) rest-> 'e':'x':'p':'e':'c':'t':rest ->-> returnToken cont (TokenKW TokSpecId_Expect) rest-> 'e':'r':'r':'o':'r':rest ->-> returnToken cont (TokenKW TokSpecId_Error) rest-> 'a':'t':'t':'r':'i':'b':'u':'t':'e':'t':'y':'p':'e':rest ->-> returnToken cont (TokenKW TokSpecId_Attributetype) rest-> 'a':'t':'t':'r':'i':'b':'u':'t':'e':rest ->-> returnToken cont (TokenKW TokSpecId_Attribute) rest-> _ -> lexError ("unrecognised directive: %" ++ -> takeWhile (not.isSpace) s) s--> lexColon :: (Token -> P a) -> [Char] -> Int -> ParseResult a-> lexColon cont (':':rest) = returnToken cont (TokenKW TokDoubleColon) rest-> lexColon cont rest = returnToken cont (TokenKW TokColon) rest--> lexId :: (Token -> P a) -> Char -> String -> Int -> ParseResult a-> lexId cont c rest = -> readId rest (\ ident rest' -> returnToken cont (TokenInfo (c:ident) TokId) rest')--> lexChar :: (Token -> P a) -> String -> Int -> ParseResult a-> lexChar cont rest = lexReadChar rest -> (\ ident -> returnToken cont (TokenInfo ("'" ++ ident ++ "'") TokId))--> lexString :: (Token -> P a) -> String -> Int -> ParseResult a-> lexString cont rest = lexReadString rest -> (\ ident -> returnToken cont (TokenInfo ("\"" ++ ident ++ "\"") TokId))--> lexCode :: (Token -> P a) -> String -> Int -> ParseResult a-> lexCode cont rest = lexReadCode rest (0 :: Integer) "" cont--> lexNum :: (Token -> P a) -> Char -> String -> Int -> ParseResult a-> lexNum cont c rest = -> readNum rest (\ num rest' -> -> returnToken cont (TokenNum (stringToInt (c:num)) TokNum) rest')-> where stringToInt = foldl (\n c' -> digitToInt c' + 10*n) 0--> cleanupCode :: String -> String-> cleanupCode s = -> dropWhile isSpace (reverse (dropWhile isSpace (reverse s)))--This has to match for @}@ that are {\em not} in strings. The code-here is a bit tricky, but should work in most cases.--> lexReadCode :: Num a-> => String -> a -> String -> (Token -> P b) -> Int-> -> ParseResult b-> lexReadCode s n c = case s of-> '\n':r -> \cont l -> lexReadCode r n ('\n':c) cont (l+1)->-> '{' :r -> lexReadCode r (n+1) ('{':c)->-> '}' :r-> | n == 0 -> \cont -> returnToken cont (TokenInfo (-> cleanupCode (reverse c)) TokCodeQuote) r-> | otherwise -> lexReadCode r (n-1) ('}':c)->-> '"'{-"-}:r -> lexReadString r (\ str r' -> -> lexReadCode r' n ('"' : (reverse str) ++ '"' : c))->-> a: '\'':r | isAlphaNum a -> lexReadCode r n ('\'':a:c)->-> '\'' :r -> lexReadSingleChar r (\ str r' -> -> lexReadCode r' n ((reverse str) ++ '\'' : c))->-> ch:r -> lexReadCode r n (ch:c)->-> [] -> \_cont -> lexError "No closing '}' in code segment" []-------------------------------------------------------------------------------Utilities that read the rest of a token.--> readId :: String -> (String -> String -> a) -> a-> readId (c:r) fn | isIdPart c = readId r (fn . (:) c)-> readId r fn = fn [] r--> readNum :: String -> (String -> String -> a) -> a-> readNum (c:r) fn | isDigit c = readNum r (fn . (:) c)-> readNum r fn = fn [] r--> isIdPart :: Char -> Bool-> isIdPart c =-> c >= 'a' && c <= 'z' -> || c >= 'A' && c <= 'Z' -> || c >= '0' && c <= '9' -> || c == '_'--> lexReadSingleChar :: String -> (String -> String -> a) -> a-> lexReadSingleChar (c:'\'':r) fn = fn (c:"'") r-> lexReadSingleChar ('\\':c:'\'':r) fn = fn ('\\':c:"'") r-> lexReadSingleChar r fn = fn "" r--> lexReadChar :: String -> (String -> String -> a) -> a-> lexReadChar ('\'':r) fn = fn "" r-> lexReadChar ('\\':'\'':r) fn = lexReadChar r (fn . (:) '\\' . (:) '\'')-> lexReadChar ('\\':c:r) fn = lexReadChar r (fn . (:) '\\' . (:) c)-> lexReadChar (c:r) fn = lexReadChar r (fn . (:) c)-> lexReadChar [] fn = fn "" []--> lexReadString :: String -> (String -> String -> a) -> a-> lexReadString ('"'{-"-}:r) fn = fn "" r-> lexReadString ('\\':'"':r) fn = lexReadString r (fn . (:) '\\' . (:) '"')-> lexReadString ('\\':c:r) fn = lexReadString r (fn . (:) '\\' . (:) c)-> lexReadString (c:r) fn = lexReadString r (fn . (:) c)-> lexReadString [] fn = fn "" []--> lexError :: String -> String -> Int -> ParseResult a-> lexError err = runP (lineP >>= \l -> fail (show l ++ ": " ++ err ++ "\n"))--> lexNestedComment :: Int -> ([Char] -> Int -> ParseResult a) -> [Char] -> Int-> -> ParseResult a-> lexNestedComment l cont r = -> case r of-> '-':'}':r' -> cont r'-> '{':'-':r' -> \line -> lexNestedComment line -> (\r'' -> lexNestedComment l cont r'') r' line-> '\n':r' -> \line -> lexNestedComment l cont r' (line+1)-> _:r' -> lexNestedComment l cont r'-> "" -> \_ -> lexError "unterminated comment" r l+ + + + + + + + + + + + +> module Lexer ( +> Token(..), +> TokenId(..), +> lexer ) where + + +> import ParseMonad + + +> import Data.Char ( isSpace, isAlphaNum, isDigit, digitToInt ) + + +> data Token +> = TokenInfo String TokenId +> | TokenNum Int TokenId +> | TokenKW TokenId +> | TokenEOF + + +> tokenToId :: Token -> TokenId +> tokenToId (TokenInfo _ i) = i +> tokenToId (TokenNum _ i) = i +> tokenToId (TokenKW i) = i +> tokenToId TokenEOF = error "tokenToId TokenEOF" + + +> instance Eq Token where +> i == i' = tokenToId i == tokenToId i' + + +> instance Ord Token where +> i <= i' = tokenToId i <= tokenToId i' + + +> data TokenId +> = TokId -- words and symbols +> | TokSpecId_TokenType -- %tokentype +> | TokSpecId_Token -- %token +> | TokSpecId_Name -- %name +> | TokSpecId_Partial -- %partial +> | TokSpecId_Lexer -- %lexer +> | TokSpecId_ImportedIdentity -- %importedidentity +> | TokSpecId_Monad -- %monad +> | TokSpecId_Nonassoc -- %nonassoc +> | TokSpecId_Left -- %left +> | TokSpecId_Right -- %right +> | TokSpecId_Prec -- %prec +> | TokSpecId_Expect -- %expect +> | TokSpecId_Error -- %error +> | TokSpecId_Attributetype -- %attributetype +> | TokSpecId_Attribute -- %attribute +> | TokCodeQuote -- stuff inside { .. } +> | TokColon -- : +> | TokSemiColon -- ; +> | TokDoubleColon -- :: +> | TokDoublePercent -- %% +> | TokBar -- | +> | TokNum -- Integer +> | TokParenL -- ( +> | TokParenR -- ) +> | TokComma -- , +> deriving (Eq,Ord + + +#ifdef DEBUG + + +> ,Show + + +#endif + + +> ) + + + + + + +> lexer :: (Token -> P a) -> P a +> lexer cont = P lexer' +> where lexer' "" = returnToken cont TokenEOF "" +> lexer' ('-':'-':r) = lexer' (dropWhile (/= '\n') r) +> lexer' ('{':'-':r) = \line -> lexNestedComment line lexer' r line +> lexer' (c:rest) = nextLex cont c rest + + +> returnToken :: (t -> P a) -> t -> String -> Int -> ParseResult a +> returnToken cont tok = runP (cont tok) + + +> nextLex :: (Token -> P a) -> Char -> String -> Int -> ParseResult a +> nextLex cont c = case c of +> '\n' -> \rest line -> returnToken lexer cont rest (line+1) +> '%' -> lexPercent cont +> ':' -> lexColon cont +> ';' -> returnToken cont (TokenKW TokSemiColon) + + +> '|' -> returnToken cont (TokenKW TokBar) +> '\'' -> lexChar cont +> '"'{-"-}-> lexString cont +> '{' -> lexCode cont + + +> '(' -> returnToken cont (TokenKW TokParenL) +> ')' -> returnToken cont (TokenKW TokParenR) +> ',' -> returnToken cont (TokenKW TokComma) + + +> _ +> | isSpace c -> runP (lexer cont) +> | c >= 'a' && c <= 'z' +> || c >= 'A' && c <= 'Z' -> lexId cont c +> | isDigit c -> lexNum cont c +> _ -> lexError ("lexical error before `" ++ c : "'") + + + + + + + + +> lexPercent :: (Token -> P a) -> [Char] -> Int -> ParseResult a +> lexPercent cont s = case s of +> '%':rest -> returnToken cont (TokenKW TokDoublePercent) rest +> 't':'o':'k':'e':'n':'t':'y':'p':'e':rest -> +> returnToken cont (TokenKW TokSpecId_TokenType) rest +> 't':'o':'k':'e':'n':rest -> +> returnToken cont (TokenKW TokSpecId_Token) rest +> 'n':'a':'m':'e':rest -> +> returnToken cont (TokenKW TokSpecId_Name) rest +> 'p':'a':'r':'t':'i':'a':'l':rest -> +> returnToken cont (TokenKW TokSpecId_Partial) rest +> 'i':'m':'p':'o':'r':'t':'e':'d':'i':'d':'e':'n':'t':'i':'t':'y':rest -> +> returnToken cont (TokenKW TokSpecId_ImportedIdentity) rest +> 'm':'o':'n':'a':'d':rest -> +> returnToken cont (TokenKW TokSpecId_Monad) rest +> 'l':'e':'x':'e':'r':rest -> +> returnToken cont (TokenKW TokSpecId_Lexer) rest +> 'n':'o':'n':'a':'s':'s':'o':'c':rest -> +> returnToken cont (TokenKW TokSpecId_Nonassoc) rest +> 'l':'e':'f':'t':rest -> +> returnToken cont (TokenKW TokSpecId_Left) rest +> 'r':'i':'g':'h':'t':rest -> +> returnToken cont (TokenKW TokSpecId_Right) rest +> 'p':'r':'e':'c':rest -> +> returnToken cont (TokenKW TokSpecId_Prec) rest +> 'e':'x':'p':'e':'c':'t':rest -> +> returnToken cont (TokenKW TokSpecId_Expect) rest +> 'e':'r':'r':'o':'r':rest -> +> returnToken cont (TokenKW TokSpecId_Error) rest +> 'a':'t':'t':'r':'i':'b':'u':'t':'e':'t':'y':'p':'e':rest -> +> returnToken cont (TokenKW TokSpecId_Attributetype) rest +> 'a':'t':'t':'r':'i':'b':'u':'t':'e':rest -> +> returnToken cont (TokenKW TokSpecId_Attribute) rest +> _ -> lexError ("unrecognised directive: %" ++ +> takeWhile (not.isSpace) s) s + + +> lexColon :: (Token -> P a) -> [Char] -> Int -> ParseResult a +> lexColon cont (':':rest) = returnToken cont (TokenKW TokDoubleColon) rest +> lexColon cont rest = returnToken cont (TokenKW TokColon) rest + + +> lexId :: (Token -> P a) -> Char -> String -> Int -> ParseResult a +> lexId cont c rest = +> readId rest (\ ident rest' -> returnToken cont (TokenInfo (c:ident) TokId) rest') + + +> lexChar :: (Token -> P a) -> String -> Int -> ParseResult a +> lexChar cont rest = lexReadChar rest +> (\ ident -> returnToken cont (TokenInfo ("'" ++ ident ++ "'") TokId)) + + +> lexString :: (Token -> P a) -> String -> Int -> ParseResult a +> lexString cont rest = lexReadString rest +> (\ ident -> returnToken cont (TokenInfo ("\"" ++ ident ++ "\"") TokId)) + + +> lexCode :: (Token -> P a) -> String -> Int -> ParseResult a +> lexCode cont rest = lexReadCode rest (0 :: Integer) "" cont + + +> lexNum :: (Token -> P a) -> Char -> String -> Int -> ParseResult a +> lexNum cont c rest = +> readNum rest (\ num rest' -> +> returnToken cont (TokenNum (stringToInt (c:num)) TokNum) rest') +> where stringToInt = foldl (\n c' -> digitToInt c' + 10*n) 0 + + +> cleanupCode :: String -> String +> cleanupCode s = +> dropWhile isSpace (reverse (dropWhile isSpace (reverse s))) + + + + + + + + +> lexReadCode :: Num a +> => String -> a -> String -> (Token -> P b) -> Int +> -> ParseResult b +> lexReadCode s n c = case s of +> '\n':r -> \cont l -> lexReadCode r n ('\n':c) cont (l+1) +> +> '{' :r -> lexReadCode r (n+1) ('{':c) +> +> '}' :r +> | n == 0 -> \cont -> returnToken cont (TokenInfo ( +> cleanupCode (reverse c)) TokCodeQuote) r +> | otherwise -> lexReadCode r (n-1) ('}':c) +> +> '"'{-"-}:r -> lexReadString r (\ str r' -> +> lexReadCode r' n ('"' : (reverse str) ++ '"' : c)) +> +> a: '\'':r | isAlphaNum a -> lexReadCode r n ('\'':a:c) +> +> '\'' :r -> lexReadSingleChar r (\ str r' -> +> lexReadCode r' n ((reverse str) ++ '\'' : c)) +> +> ch:r -> lexReadCode r n (ch:c) +> +> [] -> \_cont -> lexError "No closing '}' in code segment" [] + + + + + + + + +> readId :: String -> (String -> String -> a) -> a +> readId (c:r) fn | isIdPart c = readId r (fn . (:) c) +> readId r fn = fn [] r + + +> readNum :: String -> (String -> String -> a) -> a +> readNum (c:r) fn | isDigit c = readNum r (fn . (:) c) +> readNum r fn = fn [] r + + +> isIdPart :: Char -> Bool +> isIdPart c = +> c >= 'a' && c <= 'z' +> || c >= 'A' && c <= 'Z' +> || c >= '0' && c <= '9' +> || c == '_' + + +> lexReadSingleChar :: String -> (String -> String -> a) -> a +> lexReadSingleChar (c:'\'':r) fn = fn (c:"'") r +> lexReadSingleChar ('\\':c:'\'':r) fn = fn ('\\':c:"'") r +> lexReadSingleChar r fn = fn "" r + + +> lexReadChar :: String -> (String -> String -> a) -> a +> lexReadChar ('\'':r) fn = fn "" r +> lexReadChar ('\\':'\'':r) fn = lexReadChar r (fn . (:) '\\' . (:) '\'') +> lexReadChar ('\\':c:r) fn = lexReadChar r (fn . (:) '\\' . (:) c) +> lexReadChar (c:r) fn = lexReadChar r (fn . (:) c) +> lexReadChar [] fn = fn "" [] + + +> lexReadString :: String -> (String -> String -> a) -> a +> lexReadString ('"'{-"-}:r) fn = fn "" r +> lexReadString ('\\':'"':r) fn = lexReadString r (fn . (:) '\\' . (:) '"') +> lexReadString ('\\':c:r) fn = lexReadString r (fn . (:) '\\' . (:) c) +> lexReadString (c:r) fn = lexReadString r (fn . (:) c) +> lexReadString [] fn = fn "" [] + + +> lexError :: String -> String -> Int -> ParseResult a +> lexError err = runP (lineP >>= \l -> fail (show l ++ ": " ++ err ++ "\n")) + + +> lexNestedComment :: Int -> ([Char] -> Int -> ParseResult a) -> [Char] -> Int +> -> ParseResult a +> lexNestedComment l cont r = +> case r of +> '-':'}':r' -> cont r' +> '{':'-':r' -> \line -> lexNestedComment line +> (\r'' -> lexNestedComment l cont r'') r' line +> '\n':r' -> \line -> lexNestedComment l cont r' (line+1) +> _:r' -> lexNestedComment l cont r' +> "" -> \_ -> lexError "unterminated comment" r l
src/NameSet.hs view
@@ -1,10 +1,10 @@-module NameSet (- NameSet, null, member, empty, singleton,- union, difference, filter, fold,- fromList, toAscList-) where--import Prelude hiding ( null, filter )-import Data.IntSet--type NameSet = IntSet+module NameSet ( + NameSet, null, member, empty, singleton, + union, difference, filter, fold, + fromList, toAscList +) where + +import Prelude hiding ( null, filter ) +import Data.IntSet + +type NameSet = IntSet
src/ParamRules.hs view
@@ -1,92 +1,92 @@-module ParamRules(expand_rules) where--import AbsSyn-import Control.Monad.Writer-import Control.Monad.Error-import Control.Monad.Instances() -- mtl is broken, so we use Either monad-import Data.List(partition,intersperse)-import qualified Data.Set as S-import qualified Data.Map as M -- XXX: Make it work with old GHC.--expand_rules :: [Rule] -> Either String [Rule1]-expand_rules rs = do let (funs,rs1) = split_rules rs- (as,is) <- runM2 (mapM (`inst_rule` []) rs1)- bs <- make_insts funs (S.toList is) S.empty- return (as++bs)--type RuleName = String-type Inst = (RuleName, [RuleName])-type Funs = M.Map RuleName Rule-type Rule1 = (RuleName,[Prod1],Maybe String)-type Prod1 = ([RuleName],String,Int,Maybe String)--inst_name :: Inst -> RuleName-inst_name (f,[]) = f-inst_name (f,xs) = f ++ "(" ++ concat (intersperse "," xs) ++ ")"----- | A renaming substitution used when we instantiate a parameterized rule.-type Subst = [(RuleName,RuleName)]-type M1 = Writer (S.Set Inst)-type M2 = ErrorT String M1---- | Collects the instances arising from a term.-from_term :: Subst -> Term -> M1 RuleName-from_term s (App f []) = return $ case lookup f s of- Just g -> g- Nothing -> f--from_term s (App f ts) = do xs <- from_terms s ts- let i = (f,xs)- tell (S.singleton i)- return $ inst_name i---- | Collects the instances arising from a list of terms.-from_terms :: Subst -> [Term] -> M1 [RuleName]-from_terms s ts = mapM (from_term s) ts---- XXX: perhaps change the line to the line of the instance-inst_prod :: Subst -> Prod -> M1 Prod1-inst_prod s (ts,c,l,p) = do xs <- from_terms s ts- return (xs,c,l,p)--inst_rule :: Rule -> [RuleName] -> M2 Rule1-inst_rule (x,xs,ps,t) ts = do s <- build xs ts []- ps1 <- lift $ mapM (inst_prod s) ps- let y = inst_name (x,ts)- return (y,ps1,t) -- XXX: type?- where build (x':xs') (t':ts') m = build xs' ts' ((x',t'):m)- build [] [] m = return m- build xs' [] _ = err ("Need " ++ show (length xs') ++ " more arguments")- build _ ts' _ = err (show (length ts') ++ " arguments too many.")-- err m = throwError ("In " ++ inst_name (x,ts) ++ ": " ++ m)--make_rule :: Funs -> Inst -> M2 Rule1-make_rule funs (f,xs) =- case M.lookup f funs of- Just r -> inst_rule r xs- Nothing -> throwError ("Undefined rule: " ++ f)--runM2 :: ErrorT e (Writer w) a -> Either e (a, w)-runM2 m = case runWriter (runErrorT m) of- (Left e,_) -> Left e- (Right a,xs) -> Right (a,xs)--make_insts :: Funs -> [Inst] -> S.Set Inst -> Either String [Rule1]-make_insts _ [] _ = return []-make_insts funs is done =- do (as,ws) <- runM2 (mapM (make_rule funs) is)- let done1 = S.union (S.fromList is) done- let is1 = filter (not . (`S.member` done1)) (S.toList ws)- bs <- make_insts funs is1 done1- return (as++bs)---split_rules :: [Rule] -> (Funs,[Rule])-split_rules rs = let (xs,ys) = partition has_args rs- in (M.fromList [ (x,r) | r@(x,_,_,_) <- xs ],ys)- where has_args (_,xs,_,_) = not (null xs)---+module ParamRules(expand_rules) where + +import AbsSyn +import Control.Monad.Writer +import Control.Monad.Error +import Control.Monad.Instances() -- mtl is broken, so we use Either monad +import Data.List(partition,intersperse) +import qualified Data.Set as S +import qualified Data.Map as M -- XXX: Make it work with old GHC. + +expand_rules :: [Rule] -> Either String [Rule1] +expand_rules rs = do let (funs,rs1) = split_rules rs + (as,is) <- runM2 (mapM (`inst_rule` []) rs1) + bs <- make_insts funs (S.toList is) S.empty + return (as++bs) + +type RuleName = String +type Inst = (RuleName, [RuleName]) +type Funs = M.Map RuleName Rule +type Rule1 = (RuleName,[Prod1],Maybe String) +type Prod1 = ([RuleName],String,Int,Maybe String) + +inst_name :: Inst -> RuleName +inst_name (f,[]) = f +inst_name (f,xs) = f ++ "(" ++ concat (intersperse "," xs) ++ ")" + + +-- | A renaming substitution used when we instantiate a parameterized rule. +type Subst = [(RuleName,RuleName)] +type M1 = Writer (S.Set Inst) +type M2 = ErrorT String M1 + +-- | Collects the instances arising from a term. +from_term :: Subst -> Term -> M1 RuleName +from_term s (App f []) = return $ case lookup f s of + Just g -> g + Nothing -> f + +from_term s (App f ts) = do xs <- from_terms s ts + let i = (f,xs) + tell (S.singleton i) + return $ inst_name i + +-- | Collects the instances arising from a list of terms. +from_terms :: Subst -> [Term] -> M1 [RuleName] +from_terms s ts = mapM (from_term s) ts + +-- XXX: perhaps change the line to the line of the instance +inst_prod :: Subst -> Prod -> M1 Prod1 +inst_prod s (ts,c,l,p) = do xs <- from_terms s ts + return (xs,c,l,p) + +inst_rule :: Rule -> [RuleName] -> M2 Rule1 +inst_rule (x,xs,ps,t) ts = do s <- build xs ts [] + ps1 <- lift $ mapM (inst_prod s) ps + let y = inst_name (x,ts) + return (y,ps1,t) -- XXX: type? + where build (x':xs') (t':ts') m = build xs' ts' ((x',t'):m) + build [] [] m = return m + build xs' [] _ = err ("Need " ++ show (length xs') ++ " more arguments") + build _ ts' _ = err (show (length ts') ++ " arguments too many.") + + err m = throwError ("In " ++ inst_name (x,ts) ++ ": " ++ m) + +make_rule :: Funs -> Inst -> M2 Rule1 +make_rule funs (f,xs) = + case M.lookup f funs of + Just r -> inst_rule r xs + Nothing -> throwError ("Undefined rule: " ++ f) + +runM2 :: ErrorT e (Writer w) a -> Either e (a, w) +runM2 m = case runWriter (runErrorT m) of + (Left e,_) -> Left e + (Right a,xs) -> Right (a,xs) + +make_insts :: Funs -> [Inst] -> S.Set Inst -> Either String [Rule1] +make_insts _ [] _ = return [] +make_insts funs is done = + do (as,ws) <- runM2 (mapM (make_rule funs) is) + let done1 = S.union (S.fromList is) done + let is1 = filter (not . (`S.member` done1)) (S.toList ws) + bs <- make_insts funs is1 done1 + return (as++bs) + + +split_rules :: [Rule] -> (Funs,[Rule]) +split_rules rs = let (xs,ys) = partition has_args rs + in (M.fromList [ (x,r) | r@(x,_,_,_) <- xs ],ys) + where has_args (_,xs,_,_) = not (null xs) + + +
src/ParseMonad.lhs view
@@ -1,22 +1,31 @@-------------------------------------------------------------------------------The parser monad.--(c) 2001 Simon Marlow--------------------------------------------------------------------------------> module ParseMonad where--> data ParseResult a = OkP a | FailP String-> newtype P a = P (String -> Int -> ParseResult a)-> runP :: P a -> String -> Int -> ParseResult a-> runP (P f) = f--> lineP :: P Int-> lineP = P $ \_ l -> OkP l--> instance Monad P where-> return m = P $ \ _ _ -> OkP m-> m >>= k = P $ \s l -> case runP m s l of-> OkP a -> runP (k a) s l-> FailP err -> FailP err-> fail s = P $ \ _ _ -> FailP s+ + + + + + + + + + + + +> module ParseMonad where + + +> data ParseResult a = OkP a | FailP String +> newtype P a = P (String -> Int -> ParseResult a) +> runP :: P a -> String -> Int -> ParseResult a +> runP (P f) = f + + +> lineP :: P Int +> lineP = P $ \_ l -> OkP l + + +> instance Monad P where +> return m = P $ \ _ _ -> OkP m +> m >>= k = P $ \s l -> case runP m s l of +> OkP a -> runP (k a) s l +> FailP err -> FailP err +> fail s = P $ \ _ _ -> FailP s
src/Parser.ly view
@@ -1,146 +1,177 @@-------------------------------------------------------------------------------$Id: Parser.ly,v 1.15 2005/01/26 01:10:42 ross Exp $--The parser.--(c) 1993-2000 Andy Gill, Simon Marlow--------------------------------------------------------------------------------> {-> {-# OPTIONS_GHC -w #-}-> module Parser (ourParser,AbsSyn) where-> import ParseMonad-> import AbsSyn-> import Lexer-> }--> %name ourParser-> %tokentype { Token }-> %token-> id { TokenInfo $$ TokId }-> spec_tokentype { TokenKW TokSpecId_TokenType }-> spec_token { TokenKW TokSpecId_Token }-> spec_name { TokenKW TokSpecId_Name }-> spec_partial { TokenKW TokSpecId_Partial }-> spec_lexer { TokenKW TokSpecId_Lexer }-> spec_imported_identity { TokenKW TokSpecId_ImportedIdentity }-> spec_monad { TokenKW TokSpecId_Monad }-> spec_nonassoc { TokenKW TokSpecId_Nonassoc }-> spec_left { TokenKW TokSpecId_Left }-> spec_right { TokenKW TokSpecId_Right }-> spec_prec { TokenKW TokSpecId_Prec }-> spec_expect { TokenKW TokSpecId_Expect }-> spec_error { TokenKW TokSpecId_Error }-> spec_attribute { TokenKW TokSpecId_Attribute }-> spec_attributetype { TokenKW TokSpecId_Attributetype }-> code { TokenInfo $$ TokCodeQuote }-> int { TokenNum $$ TokNum }-> ":" { TokenKW TokColon }-> ";" { TokenKW TokSemiColon }-> "::" { TokenKW TokDoubleColon }-> "%%" { TokenKW TokDoublePercent }-> "|" { TokenKW TokBar }-> "(" { TokenKW TokParenL }-> ")" { TokenKW TokParenR }-> "," { TokenKW TokComma }--> %monad { P }-> %lexer { lexer } { TokenEOF }--> %%--> parser :: { AbsSyn }-> : optCode tokInfos "%%" rules optCode-> { AbsSyn $1 (reverse $2) (reverse $4) $5 }--> rules :: { [Rule] }-> : rules rule { $2 : $1 }-> | rule { [$1] }--> rule :: { Rule }-> : id params "::" code ":" prods { ($1,$2,$6,Just $4) }-> | id params "::" code id ":" prods { ($1,$2,$7,Just $4) }-> | id params ":" prods { ($1,$2,$4,Nothing) }--> params :: { [String] }-> : "(" comma_ids ")" { reverse $2 }-> | {- empty -} { [] }--> comma_ids :: { [String] }-> : id { [$1] }-> | comma_ids "," id { $3 : $1 }--> prods :: { [Prod] }-> : prod "|" prods { $1 : $3 }-> | prod { [$1] }--> prod :: { Prod }-> : terms prec code ";" {% lineP >>= \l -> return ($1,$3,l,$2) }-> | terms prec code {% lineP >>= \l -> return ($1,$3,l,$2) }--> term :: { Term }-> : id { App $1 [] }-> | id "(" comma_terms ")" { App $1 (reverse $3) }--> terms :: { [Term] }-> : terms_rev { reverse $1 }-> | { [] }--> terms_rev :: { [Term] }-> : term { [$1] }-> | terms_rev term { $2 : $1 }--> comma_terms :: { [Term] }-> : term { [$1] }-> | comma_terms "," term { $3 : $1 }--> prec :: { Maybe String }-> : spec_prec id { Just $2 }-> | { Nothing }--> tokInfos :: { [Directive String] } -> : tokInfos tokInfo { $2 : $1 }-> | tokInfo { [$1] }--> tokInfo :: { Directive String } -> : spec_tokentype code { TokenType $2 }-> | spec_token tokenSpecs { TokenSpec $2 }-> | spec_name id optStart { TokenName $2 $3 False }-> | spec_partial id optStart { TokenName $2 $3 True }-> | spec_imported_identity { TokenImportedIdentity }-> | spec_lexer code code { TokenLexer $2 $3 }-> | spec_monad code { TokenMonad "()" $2 ">>=" "return" }-> | spec_monad code code { TokenMonad $2 $3 ">>=" "return" }-> | spec_monad code code code { TokenMonad "()" $2 $3 $4 }-> | spec_monad code code code code { TokenMonad $2 $3 $4 $5 }-> | spec_nonassoc ids { TokenNonassoc $2 }-> | spec_right ids { TokenRight $2 }-> | spec_left ids { TokenLeft $2 }-> | spec_expect int { TokenExpect $2 }-> | spec_error code { TokenError $2 }-> | spec_attributetype code { TokenAttributetype $2 }-> | spec_attribute id code { TokenAttribute $2 $3 }--> optStart :: { Maybe String }-> : id { Just $1 }-> | {- nothing -} { Nothing }--> tokenSpecs :: { [(String,String)] }-> : tokenSpec tokenSpecs { $1:$2 }-> | tokenSpec { [$1] }--> tokenSpec :: { (String,String) }-> : id code { ($1,$2) }--> ids :: { [String] }-> : id ids { $1 : $2 }-> | {- nothing -} { [] }--> optCode :: { Maybe String }-> : code { Just $1 }-> | {- nothing -} { Nothing }--> {-> happyError :: P a-> happyError = lineP >>= \l -> fail (show l ++ ": Parse error\n")-> }+ + + + + + + + + + + + + + + + +> { +> {-# OPTIONS_GHC -w #-} +> module Parser (ourParser,AbsSyn) where +> import ParseMonad +> import AbsSyn +> import Lexer +> } + + +> %name ourParser +> %tokentype { Token } +> %token +> id { TokenInfo $$ TokId } +> spec_tokentype { TokenKW TokSpecId_TokenType } +> spec_token { TokenKW TokSpecId_Token } +> spec_name { TokenKW TokSpecId_Name } +> spec_partial { TokenKW TokSpecId_Partial } +> spec_lexer { TokenKW TokSpecId_Lexer } +> spec_imported_identity { TokenKW TokSpecId_ImportedIdentity } +> spec_monad { TokenKW TokSpecId_Monad } +> spec_nonassoc { TokenKW TokSpecId_Nonassoc } +> spec_left { TokenKW TokSpecId_Left } +> spec_right { TokenKW TokSpecId_Right } +> spec_prec { TokenKW TokSpecId_Prec } +> spec_expect { TokenKW TokSpecId_Expect } +> spec_error { TokenKW TokSpecId_Error } +> spec_attribute { TokenKW TokSpecId_Attribute } +> spec_attributetype { TokenKW TokSpecId_Attributetype } +> code { TokenInfo $$ TokCodeQuote } +> int { TokenNum $$ TokNum } +> ":" { TokenKW TokColon } +> ";" { TokenKW TokSemiColon } +> "::" { TokenKW TokDoubleColon } +> "%%" { TokenKW TokDoublePercent } +> "|" { TokenKW TokBar } +> "(" { TokenKW TokParenL } +> ")" { TokenKW TokParenR } +> "," { TokenKW TokComma } + + +> %monad { P } +> %lexer { lexer } { TokenEOF } + + +> %% + + +> parser :: { AbsSyn } +> : optCode tokInfos "%%" rules optCode +> { AbsSyn $1 (reverse $2) (reverse $4) $5 } + + +> rules :: { [Rule] } +> : rules rule { $2 : $1 } +> | rule { [$1] } + + +> rule :: { Rule } +> : id params "::" code ":" prods { ($1,$2,$6,Just $4) } +> | id params "::" code id ":" prods { ($1,$2,$7,Just $4) } +> | id params ":" prods { ($1,$2,$4,Nothing) } + + +> params :: { [String] } +> : "(" comma_ids ")" { reverse $2 } +> | {- empty -} { [] } + + +> comma_ids :: { [String] } +> : id { [$1] } +> | comma_ids "," id { $3 : $1 } + + +> prods :: { [Prod] } +> : prod "|" prods { $1 : $3 } +> | prod { [$1] } + + +> prod :: { Prod } +> : terms prec code ";" {% lineP >>= \l -> return ($1,$3,l,$2) } +> | terms prec code {% lineP >>= \l -> return ($1,$3,l,$2) } + + +> term :: { Term } +> : id { App $1 [] } +> | id "(" comma_terms ")" { App $1 (reverse $3) } + + +> terms :: { [Term] } +> : terms_rev { reverse $1 } +> | { [] } + + +> terms_rev :: { [Term] } +> : term { [$1] } +> | terms_rev term { $2 : $1 } + + +> comma_terms :: { [Term] } +> : term { [$1] } +> | comma_terms "," term { $3 : $1 } + + +> prec :: { Maybe String } +> : spec_prec id { Just $2 } +> | { Nothing } + + +> tokInfos :: { [Directive String] } +> : tokInfos tokInfo { $2 : $1 } +> | tokInfo { [$1] } + + +> tokInfo :: { Directive String } +> : spec_tokentype code { TokenType $2 } +> | spec_token tokenSpecs { TokenSpec $2 } +> | spec_name id optStart { TokenName $2 $3 False } +> | spec_partial id optStart { TokenName $2 $3 True } +> | spec_imported_identity { TokenImportedIdentity } +> | spec_lexer code code { TokenLexer $2 $3 } +> | spec_monad code { TokenMonad "()" $2 ">>=" "return" } +> | spec_monad code code { TokenMonad $2 $3 ">>=" "return" } +> | spec_monad code code code { TokenMonad "()" $2 $3 $4 } +> | spec_monad code code code code { TokenMonad $2 $3 $4 $5 } +> | spec_nonassoc ids { TokenNonassoc $2 } +> | spec_right ids { TokenRight $2 } +> | spec_left ids { TokenLeft $2 } +> | spec_expect int { TokenExpect $2 } +> | spec_error code { TokenError $2 } +> | spec_attributetype code { TokenAttributetype $2 } +> | spec_attribute id code { TokenAttribute $2 $3 } + + +> optStart :: { Maybe String } +> : id { Just $1 } +> | {- nothing -} { Nothing } + + +> tokenSpecs :: { [(String,String)] } +> : tokenSpec tokenSpecs { $1:$2 } +> | tokenSpec { [$1] } + + +> tokenSpec :: { (String,String) } +> : id code { ($1,$2) } + + +> ids :: { [String] } +> : id ids { $1 : $2 } +> | {- nothing -} { [] } + + +> optCode :: { Maybe String } +> : code { Just $1 } +> | {- nothing -} { Nothing } + + +> { +> happyError :: P a +> happyError = lineP >>= \l -> fail (show l ++ ": Parse error\n") +> }
src/ProduceCode.lhs view
@@ -1,1211 +1,1306 @@-------------------------------------------------------------------------------The code generator.--(c) 1993-2001 Andy Gill, Simon Marlow--------------------------------------------------------------------------------> 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 --%------------------------------------------------------------------------------Produce the complete output file.--> 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--%------------------------------------------------------------------------------Make the abstract syntax type declaration, of the form:--data HappyAbsSyn a t1 .. tn- = HappyTerminal a- | HappyAbsSyn1 t1- ...- | HappyAbsSynn tn--> produceAbsSynDecl --If we're using coercions, we need to generate the injections etc.-- data HappyAbsSyn ti tj tk ... = HappyAbsSyn--(where ti, tj, tk are type variables for the non-terminals which don't- have type signatures).-- happyIn<n> :: ti -> HappyAbsSyn ti tj tk ...- happyIn<n> x = unsafeCoerce# x- {-# INLINE happyIn<n> #-}-- happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn- happyOut<n> x = unsafeCoerce# x- {-# INLINE happyOut<n> #-}--> | coerce -> = let-> happy_item = str "HappyAbsSyn " . str_tyvars-> bhappy_item = brack' happy_item->-> inject n ty-> = mkHappyIn n . str " :: " . type_param n ty-> . str " -> " . bhappy_item . char '\n'-> . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"-> . str "{-# INLINE " . mkHappyIn n . str " #-}"->-> extract n ty-> = mkHappyOut n . str " :: " . bhappy_item-> . str " -> " . type_param n ty . char '\n'-> . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n"-> . str "{-# INLINE " . mkHappyOut n . str " #-}"-> in-> str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below-> . interleave "\n" (map str-> [ "#if __GLASGOW_HASKELL__ >= 607",-> "type HappyAny = Happy_GHC_Exts.Any",-> "#else",-> "type HappyAny = forall a . a",-> "#endif" ])-> . interleave "\n" -> [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ]-> -- token injector-> . str "happyInTok :: " . token . str " -> " . bhappy_item-> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n"-> -- token extractor-> . str "happyOutTok :: " . bhappy_item . str " -> " . token-> . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n"--> . str "\n"--NOTE: in the coerce case we always coerce all the semantic values to-HappyAbsSyn which is declared to be a synonym for Any. This is the-type that GHC officially knows nothing about - it's the same type used-to implement Dynamic. (in GHC 6.6 and older, Any didn't exist, so we-use the closest approximation namely forall a . a). --It's vital that GHC doesn't know anything about this type, because it-will use any knowledge it has to optimise, and if the knowledge is-false then the optimisation may also be false. Previously we used (()--> ()) as the type here, but this led to bogus optimisations (see GHC-ticket #1616).--Also, note that we must use a newtype instead of just a type synonym,-because the otherwise the type arguments to the HappyAbsSyn type-constructor will lose information. See happy/tests/bug001 for an-example where this matters.--... Otherwise, output the declaration in full...--> | 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)--%------------------------------------------------------------------------------Type declarations of the form:--type HappyReduction a b = ....-action_0, action_1 :: Int -> HappyReduction a b -reduction_1, ... :: HappyReduction a b --These are only generated if types for *all* rules are given (and not for array-based parsers -- types aren't as important there).--> 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"--%------------------------------------------------------------------------------Next, the reduction functions. Each one has the following form:--happyReduce_n_m = happyReduce n m reduction where {- reduction (- (HappyAbsSynX | HappyTerminal) happy_var_1 :- ..- (HappyAbsSynX | HappyTerminal) happy_var_q :- happyRest)- = HappyAbsSynY- ( <<user supplied string>> ) : happyRest- ; reduction _ _ = notHappyAtAll n m--where n is the non-terminal number, and m is the rule number.--NOTES on monad productions. These look like-- happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275- happyReduction_275 (happyRest)- = happyThen (code) (\r -> happyReturn (HappyAbsSyn r))--why can't we pass the HappyAbsSyn constructor to happyMonadReduce and-save duplicating the happyThen/happyReturn in each monad production?-Because this would require happyMonadReduce to be polymorphic in the-result type of the monadic action, and since in array-based parsers-the whole thing is one recursive group, we'd need a type signature on-happyMonadReduce to get polymorphic recursion. Sigh.--> 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--%------------------------------------------------------------------------------The token conversion function.--> 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)--Use a variable rather than '_' to replace '$$', so we can use it on-the left hand side of '@'.--> 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--%------------------------------------------------------------------------------Action Tables.--Here we do a bit of trickery and replace the normal default action-(failure) for each state with at least one reduction action. For each-such state, we pick one reduction action to be the default action.-This should make the code smaller without affecting the speed. It-changes the sematics for errors, however; errors could be detected in-a different state now (but they'll still be detected at the same point-in the token stream).--Further notes on default cases:--Default reductions are important when error recovery is considered: we-don't allow reductions whilst in error recovery, so we'd like the-parser to automatically reduce down to a state where the error token-can be shifted before entering error recovery. This is achieved by-using default reductions wherever possible.--One case to consider is:--State 345-- con -> conid . (rule 186)- qconid -> conid . (rule 212)-- error reduce using rule 212- '{' reduce using rule 186- etc.--we should make reduce_212 the default reduction here. So the rules become:-- * if there is a production - error -> reduce_n- then make reduce_n the default action.- * if there is a non-reduce action for the error token, the default action- for this state must be "fail".- * otherwise pick the most popular reduction in this state for the default.- * if there are no reduce actions in this state, then the default- action remains 'enter error recovery'.--This gives us an invariant: there won't ever be a production of the-type 'error -> reduce_n' explicitly in the grammar, which means that-whenever an unexpected token occurs, either the parser will reduce-straight back to a state where the error token can be shifted, or if-none exists, we'll get a parse error. In theory, we won't need the-machinery to discard states in the parser...--> 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--action array indexed by (terminal * last_state) + state--> 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--This lets examples like:-- data HappyAbsSyn t1- = HappyTerminal ( HaskToken )- | HappyAbsSyn1 ( HaskExp )- | HappyAbsSyn2 ( HaskExp )- | HappyAbsSyn3 t1--*share* the defintion for ( HaskExp )-- data HappyAbsSyn t1- = HappyTerminal ( HaskToken )- | HappyAbsSyn1 ( HaskExp )- | HappyAbsSyn3 t1--... cuting down on the work that the type checker has to do.--Note, this *could* introduce lack of polymophism,-for types that have alphas in them. Maybe we should-outlaw them inside { }--> 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"--MonadStuff:-- - with no %monad or %lexer:-- 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-- - with %monad:-- 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-- - with %monad & %lexer:-- happyThen :: CONTEXT => P a -> (a -> P b) -> P b- happyReturn :: CONTEXT => a -> P a- happyThen1 = happyThen- happyReturn1 = happyReturn---> 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"--An error handler specified with %error is passed the current token-when used with %lexer, but happyError (the old way but kept for-compatibility) is not passed the current token.--> 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 ')'---------------------------------------------------------------------------------- Produce the parser entry and exit points--> 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)"--------------------------------------------------------------------------------- Produce attributes declaration for attribute grammars--> 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----------------------------------------------------------------------------------- Strict or non-strict parser--> produceStrict :: Bool -> String -> String-> produceStrict strict-> | strict = str "happySeq = happyDoSeq\n\n"-> | otherwise = str "happySeq = happyDontSeq\n\n"--------------------------------------------------------------------------------Replace all the $n variables with happy_vars, and return a list of all the-vars used in this piece of code.--> 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--See notes under "Action Tables" above for some subtleties in this function.--> 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 ]---------------------------------------------------------------------------------- Generate packed parsing tables.---- happyActOff ! state--- Offset within happyTable of actions for state---- happyGotoOff ! state--- Offset within happyTable of gotos for state---- happyTable--- Combined action/goto table---- happyDefAction ! state--- Default action for state---- happyCheck--- Indicates whether we should use the default action for state----- the table is laid out such that the action for a given state & token--- can be found by:------ off = happyActOff ! state--- off_i = off + token--- check | off_i => 0 = (happyCheck ! off_i) == token--- | otherwise = False--- action | check = happyTable ! off_i--- | otherwise = happyDefAaction ! off_i----- figure out the default action for each state. This will leave some--- states with no *real* actions left.---- for each state with one or more real actions, sort states by--- width/spread of tokens with real actions, then by number of--- elements with actions, so we get the widest/densest states--- first. (I guess the rationale here is that we can use the--- thin/sparse states to fill in the holes later, and also we--- have to do less searching for the more complicated cases).---- try to pair up states with identical sets of real actions.---- try to fit the actions into the check table, using the ordering--- from above.---> 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)--When looking for a free offest in the table, we use the 'check' table-rather than the main table. The check table starts off with (-1) in-every slot, because that's the only thing that doesn't overlap with-any tokens (non-terminals start at 0, terminals start at 1). --Because we use 0 for LR'MustFail as well as LR'Fail, we can't check-for free offsets in the main table because we can't tell whether a-slot is free or not.--> -- 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)---------------------------------------------------------------------------------- Misc.--> 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)---------------------------------------------------------------------------------- Convert an integer to a 16-bit number encoded in \xNN\xNN format suitable--- for placing in a string.--> 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')+ + + + + + + + + + + + +> module ProduceCode (produceParser) where + + +-- > import Paths_happy ( version ) +-- > import Data.Version ( showVersion ) + + +> import Grammar +> import Target ( Target(..) ) +> import GenUtils ( mapDollarDollar, str, char, nl, strspace, +> interleave, interleave', maybestr, +> brack, brack' ) + + +> import Data.Maybe ( isJust, isNothing ) +> import Data.Char +> import Data.List + + +> import Control.Monad.ST +> import Data.Array.ST ( STUArray ) +> import Data.Array.Unboxed ( UArray ) +> import Data.Array.MArray +> import Data.Array.IArray + + + + + + + + +> produceParser :: Grammar -- grammar info +> -> ActionTable -- action table +> -> GotoTable -- goto table +> -> String -- stuff to go at the top +> -> Maybe String -- module header +> -> Maybe String -- module trailer +> -> Target -- type of code required +> -> Bool -- use coercions +> -> Bool -- use ghc extensions +> -> Bool -- strict parser +> -> String + + +> produceParser (Grammar +> { productions = prods +> , non_terminals = nonterms +> , terminals = terms +> , types = nt_types +> , first_nonterm = first_nonterm' +> , eof_term = eof +> , first_term = fst_term +> , lexer = lexer' +> , imported_identity = imported_identity' +> , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return) +> , token_specs = token_rep +> , token_type = token_type' +> , starts = starts' +> , error_handler = error_handler' +> , attributetype = attributetype' +> , attributes = attributes' +> }) +> action goto top_options module_header module_trailer +> target coerce ghc strict +> = ( top_opts +> . maybestr module_header . nl +> . str comment +> -- comment goes *after* the module header, so that we +> -- don't screw up any OPTIONS pragmas in the header. +> . produceAbsSynDecl . nl +> . produceTypes +> . produceActionTable target +> . produceReductions +> . produceTokenConverter . nl +> . produceIdentityStuff +> . produceMonadStuff +> . produceEntries +> . produceStrict strict +> . produceAttributes attributes' attributetype' . nl +> . maybestr module_trailer . nl +> ) "" +> where +> n_starts = length starts' +> token = brack token_type' +> +> nowarn_opts = str "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}" . nl +> +> top_opts = nowarn_opts . +> case top_options of +> "" -> str "" +> _ -> str (unwords [ "{-# OPTIONS" +> , top_options +> , "#-}" +> ]) . nl + + + + + + + + + + + + + + + + + + + + +> produceAbsSynDecl + + + + + + + + + + + + + + + + + happyIn<n> :: ti -> HappyAbsSyn ti tj tk ... + happyIn<n> x = unsafeCoerce# x + {-# INLINE happyIn<n> #-} + + + happyOut<n> :: HappyAbsSyn ti tj tk ... -> tn + happyOut<n> x = unsafeCoerce# x + {-# INLINE happyOut<n> #-} + + +> | coerce +> = let +> happy_item = str "HappyAbsSyn " . str_tyvars +> bhappy_item = brack' happy_item +> +> inject n ty +> = mkHappyIn n . str " :: " . type_param n ty +> . str " -> " . bhappy_item . char '\n' +> . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" +> . str "{-# INLINE " . mkHappyIn n . str " #-}" +> +> extract n ty +> = mkHappyOut n . str " :: " . bhappy_item +> . str " -> " . type_param n ty . char '\n' +> . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" +> . str "{-# INLINE " . mkHappyOut n . str " #-}" +> in +> str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below +> . interleave "\n" (map str +> [ "#if __GLASGOW_HASKELL__ >= 607", +> "type HappyAny = Happy_GHC_Exts.Any", +> "#else", +> "type HappyAny = forall a . a", +> "#endif" ]) +> . interleave "\n" +> [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ] +> -- token injector +> . str "happyInTok :: " . token . str " -> " . bhappy_item +> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n" +> -- token extractor +> . str "happyOutTok :: " . bhappy_item . str " -> " . token +> . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n" + + +> . str "\n" + + + + + + + + + + + + + + + + + + + + +-> ()) as the type here, but this led to bogus optimisations (see GHC +ticket #1616). + + + + + + + + + + + + + + + + +> | otherwise +> = str "data HappyAbsSyn " . str_tyvars +> . str "\n\t= HappyTerminal " . token +> . str "\n\t| HappyErrorToken Int\n" +> . interleave "\n" +> [ str "\t| " . makeAbsSynCon n . strspace . type_param n ty +> | (n, ty) <- assocs nt_types, +> (nt_types_index ! n) == n] + + +> where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ] +> str_tyvars = str (unwords all_tyvars) + + + + + + + + +> produceTypes +> | target == TargetArrayBased = id + + +> | all isJust (elems nt_types) = +> happyReductionDefinition . str "\n\n" +> . interleave' ",\n " +> [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ] +> (assocs action) ] +> . str " :: " . str monad_context . str " => " +> . intMaybeHash . str " -> " . happyReductionValue . str "\n\n" +> . interleave' ",\n " +> [ mkReduceFun i | +> (i,_action) <- zip [ n_starts :: Int .. ] +> (drop n_starts prods) ] +> . str " :: " . str monad_context . str " => " +> . happyReductionValue . str "\n\n" + + +> | otherwise = id + + +> where intMaybeHash | ghc = str "Happy_GHC_Exts.Int#" +> | otherwise = str "Int" +> tokens = +> case lexer' of +> Nothing -> char '[' . token . str "] -> " +> Just _ -> id +> happyReductionDefinition = +> str "{- to allow type-synonyms as our monads (likely\n" +> . str " - with explicitly-specified bind and return)\n" +> . str " - in Haskell98, it seems that with\n" +> . str " - /type M a = .../, then /(HappyReduction M)/\n" +> . str " - is not allowed. But Happy is a\n" +> . str " - code-generator that can just substitute it.\n" +> . str "type HappyReduction m = " +> . happyReduction (str "m") +> . str "\n-}" +> happyReductionValue = +> str "({-" +> . str "HappyReduction " +> . brack monad_tycon +> . str " = -}" +> . happyReduction (brack monad_tycon) +> . str ")" +> happyReduction m = +> str "\n\t " +> . intMaybeHash +> . str " \n\t-> " . token +> . str "\n\t-> HappyState " +> . token +> . str " (HappyStk HappyAbsSyn -> " . tokens . result +> . str ")\n\t" +> . str "-> [HappyState " +> . token +> . str " (HappyStk HappyAbsSyn -> " . tokens . result +> . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> " +> . tokens +> . result +> where result = m . str " HappyAbsSyn" + + + + + + + + + + + + + + + + + + + + + + + ( <<user supplied string>> ) : happyRest + + + + + + + + + + + + + happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275 + + + = happyThen (code) (\r -> happyReturn (HappyAbsSyn r)) + + + + + + + + + + + + + + + + +> produceReductions = +> interleave "\n\n" +> (zipWith produceReduction (drop n_starts prods) [ n_starts .. ]) + + +> produceReduction (nt, toks, (code,vars_used), _) i + + +> | is_monad_prod && (use_monad || imported_identity') +> = mkReductionHdr (showInt lt) monad_reduce +> . char '(' . interleave " `HappyStk`\n\t" tokPatterns +> . str "happyRest) tk\n\t = happyThen (" +> . tokLets (char '(' . str code' . char ')') +> . (if monad_pass_token then str " tk" else id) +> . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))" + + +> | specReduceFun lt +> = mkReductionHdr id ("happySpecReduce_" ++ show lt) +> . interleave "\n\t" tokPatterns +> . str " = " +> . tokLets ( +> this_absSynCon . str "\n\t\t " +> . char '(' . str code' . str "\n\t)" +> ) +> . (if coerce || null toks || null vars_used then +> id +> else +> nl . reductionFun . strspace +> . interleave " " (map str (take (length toks) (repeat "_"))) +> . str " = notHappyAtAll ") + + +> | otherwise +> = mkReductionHdr (showInt lt) "happyReduce" +> . char '(' . interleave " `HappyStk`\n\t" tokPatterns +> . str "happyRest)\n\t = " +> . tokLets +> ( this_absSynCon . str "\n\t\t " +> . char '(' . str code'. str "\n\t) `HappyStk` happyRest" +> ) + + +> where +> (code', is_monad_prod, monad_pass_token, monad_reduce) +> = case code of +> '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce") +> '%':'^':code1 -> (code1, True, True, "happyMonadReduce") +> '%':code1 -> (code1, True, False, "happyMonadReduce") +> _ -> (code, False, False, "") + + +> -- adjust the nonterminal number for the array-based parser +> -- so that nonterminals start at zero. +> adjusted_nt | target == TargetArrayBased = nt - first_nonterm' +> | otherwise = nt +> +> mkReductionHdr lt' s = +> mkReduceFun i . str " = " +> . str s . strspace . lt' . strspace . showInt adjusted_nt +> . strspace . reductionFun . nl +> . reductionFun . strspace +> +> reductionFun = str "happyReduction_" . shows i +> +> tokPatterns +> | coerce = reverse (map mkDummyVar [1 .. length toks]) +> | otherwise = reverse (zipWith tokPattern [1..] toks) +> +> tokPattern n _ | n `notElem` vars_used = char '_' +> tokPattern n t | t >= firstStartTok && t < fst_term +> = if coerce +> then mkHappyVar n +> else brack' ( +> makeAbsSynCon t . str " " . mkHappyVar n +> ) +> tokPattern n t +> = if coerce +> then mkHappyTerminalVar n t +> else str "(HappyTerminal " +> . mkHappyTerminalVar n t +> . char ')' +> +> tokLets code'' +> | coerce && not (null cases) +> = interleave "\n\t" cases +> . code'' . str (take (length cases) (repeat '}')) +> | otherwise = code'' +> +> cases = [ str "case " . extract t . strspace . mkDummyVar n +> . str " of { " . tokPattern n t . str " -> " +> | (n,t) <- zip [1..] toks, +> n `elem` vars_used ] +> +> extract t | t >= firstStartTok && t < fst_term = mkHappyOut t +> | otherwise = str "happyOutTok" +> +> lt = length toks + + +> this_absSynCon | coerce = mkHappyIn nt +> | otherwise = makeAbsSynCon nt + + + + + + + + +> produceTokenConverter +> = case lexer' of { +> +> Nothing -> +> str "happyNewToken action sts stk [] =\n\t" +> . eofAction "notHappyAtAll" +> . str " []\n\n" +> . str "happyNewToken action sts stk (tk:tks) =\n\t" +> . str "let cont i = " . doAction . str " sts stk tks in\n\t" +> . str "case tk of {\n\t" +> . interleave ";\n\t" (map doToken token_rep) +> . str "_ -> happyError' (tk:tks)\n\t" +> . str "}\n\n" +> . str "happyError_ tk tks = happyError' (tk:tks)\n"; + + +> Just (lexer'',eof') -> +> str "happyNewToken action sts stk\n\t= " +> . str lexer'' +> . str "(\\tk -> " +> . str "\n\tlet cont i = " +> . doAction +> . str " sts stk in\n\t" +> . str "case tk of {\n\t" +> . str (eof' ++ " -> ") +> . eofAction "tk" . str ";\n\t" +> . interleave ";\n\t" (map doToken token_rep) +> . str "_ -> happyError' tk\n\t" +> . str "})\n\n" +> . str "happyError_ tk = happyError' tk\n"; +> } + + +> where + + +> eofAction tk = +> (case target of +> TargetArrayBased -> +> str "happyDoAction " . eofTok . strspace . str tk . str " action" +> _ -> str "action " . eofTok . strspace . eofTok +> . strspace . str tk . str " (HappyState action)") +> . str " sts stk" +> eofTok = showInt (tokIndex eof) +> +> doAction = case target of +> TargetArrayBased -> str "happyDoAction i tk action" +> _ -> str "action i i tk (HappyState action)" +> +> doToken (i,tok) +> = str (removeDollarDollar tok) +> . str " -> cont " +> . showInt (tokIndex i) + + + + + + + + +> removeDollarDollar xs = case mapDollarDollar xs of +> Nothing -> xs +> Just fn -> fn "happy_dollar_dollar" + + +> mkHappyTerminalVar :: Int -> Int -> String -> String +> mkHappyTerminalVar i t = +> case tok_str_fn of +> Nothing -> pat +> Just fn -> brack (fn (pat [])) +> where +> tok_str_fn = case lookup t token_rep of +> Nothing -> Nothing +> Just str' -> mapDollarDollar str' +> pat = mkHappyVar i + + +> tokIndex +> = case target of +> TargetHaskell -> id +> TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2 +> -- tokens adjusted to start at zero, see ARRAY_NOTES + + + + + + + + +> produceActionTable TargetHaskell +> = foldr (.) id (map (produceStateFunction goto) (assocs action)) +> +> produceActionTable TargetArrayBased +> = produceActionArray +> . produceReduceArray +> . str "happy_n_terms = " . shows n_terminals . str " :: Int\n" +> . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n" + + +> produceStateFunction goto' (state, acts) +> = foldr (.) id (map produceActions assocs_acts) +> . foldr (.) id (map produceGotos (assocs gotos)) +> . mkActionName state +> . (if ghc +> then str " x = happyTcHack x " +> else str " _ = ") +> . mkAction default_act +> . str "\n\n" +> +> where gotos = goto' ! state +> +> produceActions (_, LR'Fail{-'-}) = id +> produceActions (t, action'@(LR'Reduce{-'-} _ _)) +> | action' == default_act = id +> | otherwise = actionFunction t +> . mkAction action' . str "\n" +> produceActions (t, action') +> = actionFunction t +> . mkAction action' . str "\n" +> +> produceGotos (t, Goto i) +> = actionFunction t +> . str "happyGoto " . mkActionName i . str "\n" +> produceGotos (_, NoGoto) = id +> +> actionFunction t +> = mkActionName state . strspace +> . ('(' :) . showInt t +> . str ") = " +> +> default_act = getDefault assocs_acts +> +> assocs_acts = assocs acts + + + + +> produceActionArray +> | ghc +> = str "happyActOffsets :: HappyAddr\n" +> . str "happyActOffsets = HappyA# \"" --" +> . str (hexChars act_offs) +> . str "\"#\n\n" --" +> +> . str "happyGotoOffsets :: HappyAddr\n" +> . str "happyGotoOffsets = HappyA# \"" --" +> . str (hexChars goto_offs) +> . str "\"#\n\n" --" +> +> . str "happyDefActions :: HappyAddr\n" +> . str "happyDefActions = HappyA# \"" --" +> . str (hexChars defaults) +> . str "\"#\n\n" --" +> +> . str "happyCheck :: HappyAddr\n" +> . str "happyCheck = HappyA# \"" --" +> . str (hexChars check) +> . str "\"#\n\n" --" +> +> . str "happyTable :: HappyAddr\n" +> . str "happyTable = HappyA# \"" --" +> . str (hexChars table) +> . str "\"#\n\n" --" + + +> | otherwise +> = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n" +> . str "happyActOffsets = Happy_Data_Array.listArray (0," +> . shows (n_states) . str ") ([" +> . interleave' "," (map shows act_offs) +> . str "\n\t])\n\n" +> +> . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n" +> . str "happyGotoOffsets = Happy_Data_Array.listArray (0," +> . shows (n_states) . str ") ([" +> . interleave' "," (map shows goto_offs) +> . str "\n\t])\n\n" +> +> . str "happyDefActions :: Happy_Data_Array.Array Int Int\n" +> . str "happyDefActions = Happy_Data_Array.listArray (0," +> . shows (n_states) . str ") ([" +> . interleave' "," (map shows defaults) +> . str "\n\t])\n\n" +> +> . str "happyCheck :: Happy_Data_Array.Array Int Int\n" +> . str "happyCheck = Happy_Data_Array.listArray (0," +> . shows table_size . str ") ([" +> . interleave' "," (map shows check) +> . str "\n\t])\n\n" +> +> . str "happyTable :: Happy_Data_Array.Array Int Int\n" +> . str "happyTable = Happy_Data_Array.listArray (0," +> . shows table_size . str ") ([" +> . interleave' "," (map shows table) +> . str "\n\t])\n\n" +> +> (_, last_state) = bounds action +> n_states = last_state + 1 +> n_terminals = length terms +> n_nonterminals = length nonterms - n_starts -- lose %starts +> +> (act_offs,goto_offs,table,defaults,check) +> = mkTables action goto first_nonterm' fst_term +> n_terminals n_nonterminals n_starts +> +> table_size = length table - 1 +> +> produceReduceArray +> = {- str "happyReduceArr :: Array Int a\n" -} +> str "happyReduceArr = Happy_Data_Array.array (" +> . shows (n_starts :: Int) -- omit the %start reductions +> . str ", " +> . shows n_rules +> . str ") [\n" +> . interleave' ",\n" (map reduceArrElem [n_starts..n_rules]) +> . str "\n\t]\n\n" + + +> n_rules = length prods - 1 :: Int + + +> showInt i | ghc = shows i . showChar '#' +> | otherwise = shows i + + + + + + +> nt_types_index :: Array Int Int +> nt_types_index = array (bounds nt_types) +> [ (a, fn a b) | (a, b) <- assocs nt_types ] +> where +> fn n Nothing = n +> fn _ (Just a) = case lookup a assoc_list of +> Just v -> v +> Nothing -> error ("cant find an item in list") +> assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ] + + +> makeAbsSynCon = mkAbsSynCon nt_types_index + + + + +> produceIdentityStuff | use_monad = id +> | imported_identity' = +> str "type HappyIdentity = Identity\n" +> . str "happyIdentity = Identity\n" +> . str "happyRunIdentity = runIdentity\n\n" +> | otherwise = +> str "newtype HappyIdentity a = HappyIdentity a\n" +> . str "happyIdentity = HappyIdentity\n" +> . str "happyRunIdentity (HappyIdentity a) = a\n\n" +> . str "instance Monad HappyIdentity where\n" +> . str " return = HappyIdentity\n" +> . str " (HappyIdentity p) >>= q = q p\n\n" + + + + + + + + + + + happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b + happyReturn :: () => a -> HappyIdentity a + happyThen1 m k tks = happyThen m (\a -> k a tks) + happyReturn1 = \a tks -> happyReturn a + + + + + + + happyThen :: CONTEXT => P a -> (a -> P b) -> P b + happyReturn :: CONTEXT => a -> P a + happyThen1 m k tks = happyThen m (\a -> k a tks) + happyReturn1 = \a tks -> happyReturn a + + + + + + + happyThen :: CONTEXT => P a -> (a -> P b) -> P b + happyReturn :: CONTEXT => a -> P a + + + + + + + + +> produceMonadStuff = +> let pcont = str monad_context in +> let pty = str monad_tycon in +> str "happyThen :: " . pcont . str " => " . pty +> . str " a -> (a -> " . pty +> . str " b) -> " . pty . str " b\n" +> . str "happyThen = " . brack monad_then . nl +> . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n" +> . str "happyReturn = " . brack monad_return . nl +> . case lexer' of +> Nothing -> +> str "happyThen1 m k tks = (" . str monad_then +> . str ") m (\\a -> k a tks)\n" +> . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n" +> . str "happyReturn1 = \\a tks -> " . brack monad_return +> . str " a\n" +> . str "happyError' :: " . str monad_context . str " => [" +> . token +> . str "] -> " +> . str monad_tycon +> . str " a\n" +> . str "happyError' = " +> . str (if use_monad then "" else "HappyIdentity . ") +> . errorHandler +> . str "\n\n" +> _ -> +> str "happyThen1 = happyThen\n" +> . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n" +> . str "happyReturn1 = happyReturn\n" +> . str "happyError' :: " . str monad_context . str " => " +> . token . str " -> " +> . str monad_tycon +> . str " a\n" +> . str "happyError' tk = " +> . str (if use_monad then "" else "HappyIdentity ") +> . errorHandler . str " tk\n" +> . str "\n" + + + + + + + + + + +> errorHandler = +> case error_handler' of +> Just h -> str h +> Nothing -> case lexer' of +> Nothing -> str "happyError" +> Just _ -> str "(\\token -> happyError)" + + +> reduceArrElem n +> = str "\t(" . shows n . str " , " +> . str "happyReduce_" . shows n . char ')' + + + + + + + + +> produceEntries +> = interleave "\n\n" (map produceEntry (zip starts' [0..])) +> . if null attributes' then id else produceAttrEntries starts' + + +> produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no) +> = (if null attributes' then str name else str "do_" . str name) +> . maybe_tks +> . str " = " +> . str unmonad +> . str "happySomeParser where\n" +> . str " happySomeParser = happyThen (happyParse " +> . case target of +> TargetHaskell -> str "action_" . shows no +> TargetArrayBased +> | ghc -> shows no . str "#" +> | otherwise -> shows no +> . maybe_tks +> . str ") " +> . brack' (if coerce +> then str "\\x -> happyReturn (happyOut" +> . shows accept_nonterm . str " x)" +> else str "\\x -> case x of {HappyAbsSyn" +> . shows (nt_types_index ! accept_nonterm) +> . str " z -> happyReturn z; _other -> notHappyAtAll }" +> ) +> where +> maybe_tks | isNothing lexer' = str " tks" +> | otherwise = id +> unmonad | use_monad = "" +> | otherwise = "happyRunIdentity " + + +> produceAttrEntries starts'' +> = interleave "\n\n" (map f starts'') +> where +> f = case (use_monad,lexer') of +> (True,Just _) -> \(name,_,_,_) -> monadAndLexerAE name +> (True,Nothing) -> \(name,_,_,_) -> monadAE name +> (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer" +> (False,Nothing)-> \(name,_,_,_) -> regularAE name +> +> defaultAttr = fst (head attributes') +> +> monadAndLexerAE name +> = str name . str " = " +> . str "do { " +> . str "f <- do_" . str name . str "; " +> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " +> . str "sequence_ conds; " +> . str "return (". str defaultAttr . str " attrs) }}" +> monadAE name +> = str name . str " toks = " +> . str "do { " +> . str "f <- do_" . str name . str " toks; " +> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " +> . str "sequence_ conds; " +> . str "return (". str defaultAttr . str " attrs) }}" +> regularAE name +> = str name . str " toks = " +> . str "let { " +> . str "f = do_" . str name . str " toks; " +> . str "(conds,attrs) = f happyEmptyAttrs; " +> . str "x = foldr seq attrs conds; " +> . str "} in (". str defaultAttr . str " x)" + + + + + + + + +> produceAttributes :: [(String, String)] -> String -> String -> String +> produceAttributes [] _ = id +> produceAttributes attrs attributeType +> = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl +> . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl + + +> where attributes' = foldl1 (\x y -> x . str ", " . y) $ map formatAttribute attrs +> formatAttribute (ident,typ) = str ident . str " :: " . str typ +> attrsErrors = foldl1 (\x y -> x . str ", " . y) $ map attrError attrs +> attrError (ident,_) = str ident . str " = error \"invalid reference to attribute '" . str ident . str "'\"" +> attrHeader = +> case attributeType of +> [] -> str "HappyAttributes" +> _ -> str attributeType + + + + + + + + + + +> produceStrict :: Bool -> String -> String +> produceStrict strict +> | strict = str "happySeq = happyDoSeq\n\n" +> | otherwise = str "happySeq = happyDontSeq\n\n" + + + + + + + + + + +> actionVal :: LRAction -> Int +> actionVal (LR'Shift state _) = state + 1 +> actionVal (LR'Reduce rule _) = -(rule + 1) +> actionVal LR'Accept = -1 +> actionVal (LR'Multiple _ a) = actionVal a +> actionVal LR'Fail = 0 +> actionVal LR'MustFail = 0 + + +> mkAction :: LRAction -> String -> String +> mkAction (LR'Shift i _) = str "happyShift " . mkActionName i +> mkAction LR'Accept = str "happyAccept" +> mkAction LR'Fail = str "happyFail" +> mkAction LR'MustFail = str "happyFail" +> mkAction (LR'Reduce i _) = str "happyReduce_" . shows i +> mkAction (LR'Multiple _ a) = mkAction a + + +> mkActionName :: Int -> String -> String +> mkActionName i = str "action_" . shows i + + + + + + +> getDefault :: [(Name, LRAction)] -> LRAction +> getDefault actions = +> -- pick out the action for the error token, if any +> case [ act | (e, act) <- actions, e == errorTok ] of +> +> -- use error reduction as the default action, if there is one. +> act@(LR'Reduce _ _) : _ -> act +> act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act +> +> -- if the error token is shifted or otherwise, don't generate +> -- a default action. This is *important*! +> (act : _) | act /= LR'Fail -> LR'Fail +> +> -- no error actions, pick a reduce to be the default. +> _ -> case reduces of +> [] -> LR'Fail +> (act:_) -> act -- pick the first one we see for now +> +> where reduces +> = [ act | (_,act@(LR'Reduce _ _)) <- actions ] +> ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ] + + + + + + +> mkTables +> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int -> +> ([Int] -- happyActOffsets +> ,[Int] -- happyGotoOffsets +> ,[Int] -- happyTable +> ,[Int] -- happyDefAction +> ,[Int] -- happyCheck +> ) +> +> mkTables action goto first_nonterm' fst_term +> n_terminals n_nonterminals n_starts +> = ( elems act_offs, +> elems goto_offs, +> take max_off (elems table), +> def_actions, +> take max_off (elems check) +> ) +> where +> +> (table,check,act_offs,goto_offs,max_off) +> = runST (genTables (length actions) max_token sorted_actions) +> +> -- the maximum token number used in the parser +> max_token = max n_terminals (n_starts+n_nonterminals) - 1 +> +> def_actions = map (\(_,_,def,_,_,_) -> def) actions +> +> actions :: [TableEntry] +> actions = +> [ (ActionEntry, +> state, +> actionVal default_act, +> if null acts'' then 0 +> else fst (last acts'') - fst (head acts''), +> length acts'', +> acts'') +> | (state, acts) <- assocs action, +> let (err:_dummy:vec) = assocs acts +> vec' = drop (n_starts+n_nonterminals) vec +> acts' = filter (notFail) (err:vec') +> default_act = getDefault acts' +> acts'' = mkActVals acts' default_act +> ] +> +> -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0). +> -- (see ARRAY_NOTES) +> adjust token | token == errorTok = 0 +> | otherwise = token - fst_term + 1 +> +> mkActVals assocs' default_act = +> [ (adjust token, actionVal act) +> | (token, act) <- assocs' +> , act /= default_act ] +> +> gotos :: [TableEntry] +> gotos = [ (GotoEntry, +> state, 0, +> if null goto_vals then 0 +> else fst (last goto_vals) - fst (head goto_vals), +> length goto_vals, +> goto_vals +> ) +> | (state, goto_arr) <- assocs goto, +> let goto_vals = mkGotoVals (assocs goto_arr) +> ] +> +> -- adjust nonterminals by -first_nonterm', so they start at zero +> -- (see ARRAY_NOTES) +> mkGotoVals assocs' = +> [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ] +> +> sorted_actions = reverse (sortBy cmp_state (actions++gotos)) +> cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_) +> | width1 < width2 = LT +> | width1 == width2 = compare tally1 tally2 +> | otherwise = GT + + +> data ActionOrGoto = ActionEntry | GotoEntry +> type TableEntry = (ActionOrGoto, +> Int{-stateno-}, +> Int{-default-}, +> Int{-width-}, +> Int{-tally-}, +> [(Int,Int)]) + + +> genTables +> :: Int -- number of actions +> -> Int -- maximum token no. +> -> [TableEntry] -- entries for the table +> -> ST s (UArray Int Int, -- table +> UArray Int Int, -- check +> UArray Int Int, -- action offsets +> UArray Int Int, -- goto offsets +> Int -- highest offset in table +> ) +> +> genTables n_actions max_token entries = do +> +> table <- newArray (0, mAX_TABLE_SIZE) 0 +> check <- newArray (0, mAX_TABLE_SIZE) (-1) +> act_offs <- newArray (0, n_actions) 0 +> goto_offs <- newArray (0, n_actions) 0 +> off_arr <- newArray (-max_token, mAX_TABLE_SIZE) 0 +> +> max_off <- genTables' table check act_offs goto_offs +> off_arr entries max_token +> +> table' <- freeze table +> check' <- freeze check +> act_offs' <- freeze act_offs +> goto_offs' <- freeze goto_offs +> return (table',check',act_offs',goto_offs',max_off+1) + + +> where +> n_states = n_actions - 1 +> mAX_TABLE_SIZE = n_states * (max_token + 1) + + + + +> genTables' +> :: STUArray s Int Int -- table +> -> STUArray s Int Int -- check +> -> STUArray s Int Int -- action offsets +> -> STUArray s Int Int -- goto offsets +> -> STUArray s Int Int -- offset array +> -> [TableEntry] -- entries for the table +> -> Int -- maximum token no. +> -> ST s Int -- highest offset in table +> +> genTables' table check act_offs goto_offs off_arr entries max_token +> = fit_all entries 0 1 +> where +> +> fit_all [] max_off _ = return max_off +> fit_all (s:ss) max_off fst_zero = do +> (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero +> ss' <- same_states s ss off +> writeArray off_arr off 1 +> fit_all ss' new_max_off new_fst_zero +> +> -- try to merge identical states. We only try the next state(s) +> -- in the list, but the list is kind-of sorted so we shouldn't +> -- miss too many. +> same_states _ [] _ = return [] +> same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off +> | acts == acts' = do writeArray (which_off e) no off +> same_states s ss' off +> | otherwise = return ss +> +> which_off ActionEntry = act_offs +> which_off GotoEntry = goto_offs +> +> -- fit a vector into the table. Return the offset of the vector, +> -- the maximum offset used in the table, and the offset of the first +> -- entry in the table (used to speed up the lookups a bit). +> fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero) +> +> fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_)) +> max_off fst_zero = do +> -- start at offset 1 in the table: all the empty states +> -- (states with just a default reduction) are mapped to +> -- offset zero. +> off <- findFreeOffset (-t+fst_zero) check off_arr state +> let new_max_off | furthest_right > max_off = furthest_right +> | otherwise = max_off +> furthest_right = off + max_token +> +> -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do +> +> writeArray (which_off act_or_goto) state_no off +> addState off table check state +> new_fst_zero <- findFstFreeSlot check fst_zero +> return (off, new_max_off, new_fst_zero) + + + + + + + + + + + + + + + + + + + + +> -- Find a valid offset in the table for this state. +> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int +> findFreeOffset off table off_arr state = do +> -- offset 0 isn't allowed +> if off == 0 then try_next else do +> +> -- don't use an offset we've used before +> b <- readArray off_arr off +> if b /= 0 then try_next else do +> +> -- check whether the actions for this state fit in the table +> ok <- fits off state table +> if not ok then try_next else return off +> where +> try_next = findFreeOffset (off+1) table off_arr state + + + + +> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool +> fits _ [] _ = return True +> fits off ((t,_):rest) table = do +> i <- readArray table (off+t) +> if i /= -1 then return False +> else fits off rest table + + +> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] +> -> ST s () +> addState _ _ _ [] = return () +> addState off table check ((t,val):state) = do +> writeArray table (off+t) val +> writeArray check (off+t) t +> addState off table check state + + +> notFail :: (Int, LRAction) -> Bool +> notFail (_, LR'Fail) = False +> notFail _ = True + + +> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int +> findFstFreeSlot table n = do +> i <- readArray table n +> if i == -1 then return n +> else findFstFreeSlot table (n+1) + + + + + + + + +> comment :: String +> comment = +> "-- parser produced by Happy \n\n" + + +> mkAbsSynCon :: Array Int Int -> Int -> String -> String +> mkAbsSynCon fx t = str "HappyAbsSyn" . shows (fx ! t) + + +> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String +> mkHappyVar n = str "happy_var_" . shows n +> mkReduceFun n = str "happyReduce_" . shows n +> mkDummyVar n = str "happy_x_" . shows n + + +> mkHappyIn, mkHappyOut :: Int -> String -> String +> mkHappyIn n = str "happyIn" . shows n +> mkHappyOut n = str "happyOut" . shows n + + +> type_param :: Int -> Maybe String -> ShowS +> type_param n Nothing = char 't' . shows n +> type_param _ (Just ty) = brack ty + + +> specReduceFun :: Int -> Bool +> specReduceFun = (<= 3) + + + + + + + + + + +> hexChars :: [Int] -> String +> hexChars acts = concat (map hexChar acts) + + +> hexChar :: Int -> String +> hexChar i | i < 0 = hexChar (i + 2^16) +> hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256) + + +> toHex :: Int -> String +> toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] + + +> hexDig :: Int -> Char +> hexDig i | i <= 9 = chr (i + ord '0') +> | otherwise = chr (i - 10 + ord 'a')
src/ProduceGLRCode.lhs view
@@ -1,703 +1,898 @@-Module for producing GLR (Tomita) parsing code.-This module is designed as an extension to the Haskell parser generator Happy.--(c) University of Durham, Ben Medlock 2001- -- initial code, for structure parsing -(c) University of Durham, Paul Callaghan 2004- -- extension to semantic rules, and various optimisations-%-------------------------------------------------------------------------------> module ProduceGLRCode ( produceGLRParser-> , DecodeOption(..)-> , FilterOption(..)-> , GhcExts(..)-> , Options-> ) where---- > import Paths_happy ( version )--> import GenUtils ( thd3, mapDollarDollar )-> import GenUtils ( str, char, nl, brack, brack', interleave, maybestr )-> import Grammar-> import System.IO-> import Data.Array-> import Data.Char ( isSpace )-> import Data.List ( nub, (\\), sort )---- > import Data.Version ( showVersion )--%------------------------------------------------------------------------------File and Function Names--> base_template, lib_template :: String -> String-> base_template td = td ++ "/GLR_Base" -- NB Happy uses / too-> lib_template td = td ++ "/GLR_Lib" -- Windows accepts this?------prefix for production names, to avoid name clashes--> prefix :: String-> prefix = "G_"--%------------------------------------------------------------------------------This type represents choice of decoding style for the result--> data DecodeOption-> = TreeDecode -> | LabelDecode------This type represents whether filtering done or not--> data FilterOption-> = NoFiltering-> | UseFiltering------This type represents whether GHC extensions are used or not- - extra values are imports and ghc options reqd--> data GhcExts-> = NoGhcExts-> | UseGhcExts String String -- imports and options------this is where the exts matter--> show_st :: GhcExts -> {-State-}Int -> String-> show_st UseGhcExts{} = (++"#") . show-> show_st NoGhcExts = show-------> type DebugMode = Bool-> type Options = (DecodeOption, FilterOption, GhcExts)---%------------------------------------------------------------------------------Main exported function--> produceGLRParser-> :: FilePath -- Output file name-> -> String -- Templates directory-> -> ActionTable -- LR tables-> -> GotoTable -- LR tables -> -> Maybe String -- Module header-> -> Maybe String -- User-defined stuff (token DT, lexer etc.)-> -> (DebugMode,Options) -- selecting code-gen style-> -> Grammar -- Happy Grammar-> -> IO ()--> produceGLRParser outfilename template_dir action goto header trailer options g-> = do-> let basename = takeWhile (/='.') outfilename-> let tbls = (action,goto)-> (parseName,_,_,_) <- case starts g of-> [s] -> return s-> s:_ -> do -> putStrLn "GLR-Happy doesn't support multiple start points (yet)"-> putStrLn "Defaulting to first start point."-> return s-> [] -> error "produceGLRParser: []"-> mkFiles basename tbls parseName template_dir header trailer options g---%------------------------------------------------------------------------------"mkFiles" generates the files containing the Tomita parsing code.-It produces two files - one for the data (small template), and one for -the driver and data strs (large template).--> mkFiles :: FilePath -- Root of Output file name -> -> (ActionTable-> ,GotoTable) -- LR tables -> -> String -- Start parse function name-> -> String -- Templates directory-> -> Maybe String -- Module header-> -> Maybe String -- User-defined stuff (token DT, lexer etc.)-> -> (DebugMode,Options) -- selecting code-gen style-> -> Grammar -- Happy Grammar-> -> IO ()->-> mkFiles basename tables start templdir header trailer (debug,options) g-> = do-> let debug_ext = if debug then "-debug" else ""-> let (ext,imps,opts) = case thd3 options of -> UseGhcExts is os -> ("-ghc", is, os)-> _ -> ("", "", "")-> base <- readFile (base_template templdir)-> --writeFile (basename ++ ".si") (unlines $ map show sem_info)-> writeFile (basename ++ "Data.hs") (content base opts $ "")--> lib <- readFile (lib_template templdir ++ ext ++ debug_ext)-> writeFile (basename ++ ".hs") (lib_content imps opts lib)-> where-> mod_name = reverse $ takeWhile (`notElem` "\\/") $ reverse basename-> data_mod = mod_name ++ "Data"--> (sem_def, sem_info) = mkGSemType options g-> table_text = mkTbls tables sem_info (thd3 options) g--> header_parts = fmap (span (\x -> take 3 (dropWhile isSpace x) == "{-#") -> . lines) -> header-> -- Split off initial options, if they are present-> -- Assume these options ONLY related to code which is in -> -- parser tail or in sem. rules- -> content base_defs opts -> = str ("{-# OPTIONS " ++ opts ++ " #-}") .nl -> . str (unlines $ maybe [] fst header_parts) .nl-> . nl-> . str (comment "data") .nl .nl-> . str ("module " ++ data_mod ++ " where") .nl --> . nl-> . maybestr (fmap (unlines.snd) header_parts) .nl -> . nl-> . str base_defs .nl-> . nl--> . let count_nls = length . filter (=='\n')-> pre_trailer = maybe 0 count_nls header -- check fmt below-> + count_nls base_defs-> + 10 -- for the other stuff-> post_trailer = pre_trailer + maybe 0 count_nls trailer + 4-> in -> str ("{-# LINE " ++ show pre_trailer ++ " "-> ++ show (basename ++ "Data.hs") ++ "#-}") -> -- This should show a location in basename.y -- but Happy-> -- doesn't pass this info through. But we still avoid being-> -- told a location in GLR_Base! -> . nl-> . nl-> . maybestr trailer -> .nl-> .nl-> . str ("{-# LINE " ++ show post_trailer ++ " "-> ++ show (basename ++ "Data.hs") ++ "#-}") -> . nl-> . nl--> . mkGSymbols g .nl-> . nl-> . sem_def .nl-> . nl-> . mkSemObjects options (monad_sub g) sem_info .nl-> . nl-> . mkDecodeUtils options (monad_sub g) sem_info .nl-> . nl-> . user_def_token_code (token_type g) .nl-> . nl-> . table_text--> lib_content imps opts lib_text-> = let (pre,_drop_me : post) = break (== "fakeimport DATA") $ lines lib_text-> in -> unlines [ "{-# OPTIONS " ++ opts ++ " #-}\n"-> , comment "driver" ++ "\n"-> , "module " ++ mod_name ++ "("-> , case lexer g of -> Nothing -> ""-> Just (lf,_) -> "\t" ++ lf ++ ","-> , "\t" ++ start-> , ""-> , unlines pre-> , imps-> , "import " ++ data_mod-> , start ++ " = glr_parse " -> , "use_filtering = " ++ show use_filtering-> , "top_symbol = " ++ prefix ++ start_prod-> , unlines post-> ]-> start_prod = token_names g ! (let (_,_,i,_) = head $ starts g in i)-> use_filtering = case options of (_, UseFiltering,_) -> True-> _ -> False--> comment :: String -> String-> comment which-> = "-- parser (" ++ which ++ ") produced by Happy (GLR)"---> user_def_token_code :: String -> String -> String-> user_def_token_code tokenType-> = str "type UserDefTok = " . str tokenType . nl-> . str "instance TreeDecode " . brack tokenType . str " where" . nl-> . str "\tdecode_b f (Branch (SemTok t) []) = [happy_return t]" . nl-> . str "instance LabelDecode " . brack tokenType . str " where" . nl-> . str "\tunpack (SemTok t) = t" . nl---%------------------------------------------------------------------------------Formats the tables as code.--> mkTbls :: (ActionTable -- Action table from Happy-> ,GotoTable) -- Goto table from Happy-> -> SemInfo -- info about production mapping-> -> GhcExts -- Use unboxed values?-> -> Grammar -- Happy Grammar-> -> ShowS->-> mkTbls (action,goto) sem_info exts g-> = let gsMap = mkGSymMap g -> semfn_map = mk_semfn_map sem_info-> in -> writeActionTbl action gsMap (semfn_map !) exts g-> . writeGotoTbl goto gsMap exts---%------------------------------------------------------------------------------Create a mapping of Happy grammar symbol integers to the data representation-that will be used for them in the GLR parser.--> mkGSymMap :: Grammar -> [(Name,String)]-> mkGSymMap g-> = [ -- (errorTok, prefix ++ "Error") -> ]-> ++ [ (i, prefix ++ (token_names g) ! i) -> | i <- user_non_terminals g ] -- Non-terminals-> ++ [ (i, "HappyTok (" ++ mkMatch tok ++ ")")-> | (i,tok) <- token_specs g ] -- Tokens (terminals)-> ++ [(eof_term g,"HappyEOF")] -- EOF symbol (internal terminal)-> where-> mkMatch tok = case mapDollarDollar tok of -> Nothing -> tok-> Just fn -> fn "_"--> toGSym :: [(Int, String)] -> Int -> String-> toGSym gsMap i -> = case lookup i gsMap of-> Nothing -> error $ "No representation for symbol " ++ show i-> Just g -> g ---%------------------------------------------------------------------------------Take the ActionTable from Happy and turn it into a String representing a-function that can be included as the action table in the GLR parser.-It also shares identical reduction values as CAFs--> writeActionTbl -> :: ActionTable -> [(Int,String)] -> (Name->String) -> -> GhcExts -> Grammar -> ShowS-> writeActionTbl acTbl gsMap semfn_map exts g-> = interleave "\n" -> $ map str -> $ mkLines ++ [errorLine] ++ mkReductions-> where-> name = "action"-> mkLines = concatMap (mkState) (assocs acTbl)-> errorLine = name ++ " _ _ = Error" -> mkState (i,arr) -> = filter (/="") $ map (mkLine i) (assocs arr)->-> mkLine state (symInt,action)-> | symInt == errorTok -- skip error productions-> = "" -- NB see ProduceCode's handling of these-> | otherwise-> = case action of-> LR'Fail -> ""-> LR'MustFail -> ""-> _ -> unwords [ startLine , mkAct action ]-> where-> startLine -> = unwords [ name , show_st exts state, "(" , getTok , ") =" ]-> getTok = let tok = toGSym gsMap symInt-> in case mapDollarDollar tok of-> Nothing -> tok-> Just f -> f "_"-> mkAct act-> = case act of-> LR'Shift newSt _ -> "Shift " ++ show newSt ++ " []"-> LR'Reduce r _ -> "Reduce " ++ "[" ++ mkRed r ++ "]" -> LR'Accept -> "Accept"-> LR'Multiple rs (LR'Shift st _) -> -> "Shift " ++ show st ++ " " ++ mkReds rs-> LR'Multiple rs r@(LR'Reduce{})-> -> "Reduce " ++ mkReds (r:rs)-> _ -> error "writeActionTbl/mkAct: Unhandled case"-> where-> mkReds rs = "[" ++ tail (concat [ "," ++ mkRed r | LR'Reduce r _ <- rs ]) ++ "]"--> mkRed r = "red_" ++ show r-> mkReductions = [ mkRedDefn p | p@(_,(n,_,_,_)) <- zip [0..] $ productions g -> , n `notElem` start_productions g ]--> mkRedDefn (r, (lhs_id, rhs_ids, (_code,_dollar_vars), _))-> = mkRed r ++ " = ("++ lhs ++ "," ++ show arity ++ " :: Int," ++ sem ++")"-> where-> lhs = toGSym gsMap $ lhs_id-> arity = length rhs_ids-> sem = semfn_map r---%------------------------------------------------------------------------------Do the same with the Happy goto table.--> writeGotoTbl :: GotoTable -> [(Int,String)] -> GhcExts -> ShowS-> writeGotoTbl goTbl gsMap exts-> = interleave "\n" (map str $ filter (not.null) mkLines)-> . str errorLine . nl-> where-> name = "goto"-> errorLine = "goto _ _ = " ++ show_st exts (negate 1) -> mkLines = map mkState (assocs goTbl) ->-> mkState (i,arr) -> = unlines $ filter (/="") $ map (mkLine i) (assocs arr)->-> mkLine state (ntInt,goto)-> = case goto of-> NoGoto -> ""-> Goto st -> unwords [ startLine , show_st exts st ]-> where-> startLine -> = unwords [ name , show_st exts state, getGSym , "=" ]-> getGSym = toGSym gsMap ntInt---%------------------------------------------------------------------------------Create the 'GSymbol' ADT for the symbols in the grammar--> mkGSymbols :: Grammar -> ShowS-> mkGSymbols g -> = str dec -> . str eof-> . str tok -> . interleave "\n" [ str " | " . str prefix . str sym . str " " -> | sym <- syms ] -> . str der -> -- ++ eq_inst-> -- ++ ord_inst-> where-> dec = "data GSymbol"-> eof = " = HappyEOF" -> tok = " | HappyTok {-!Int-} (" ++ token_type g ++ ")"-> der = " deriving (Show,Eq,Ord)"-> syms = [ token_names g ! i | i <- user_non_terminals g ]--NOTES: -Was considering avoiding use of Eq/Ord over tokens, but this then means-hand-coding the Eq/Ord classes since we're over-riding the usual order-except in one case. --maybe possible to form a union and do some juggling, but this isn't that-easy, eg input type of "action". --plus, issues about how token info gets into TreeDecode sem values - which-might be tricky to arrange.-<> eq_inst = "instance Eq GSymbol where" -<> : "\tHappyTok i _ == HappyTok j _ = i == j" -<> : [ "\ti == j = fromEnum i == fromEnum j" ----%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%-Semantic actions on rules.--These are stored in a union type "GSem", and the semantic values are held -on the branches created at the appropriate reduction. --"GSem" type has one constructor per distinct type of semantic action and-pattern of child usage. ---%------------------------------------------------------------------------------Creating a type for storing semantic rules- - also collects information on code structure and constructor names, for- use in later stages.--> type SemInfo -> = [(String, String, [Int], [((Int,Int), ([(Int,String)],String), [Int])])]--> mkGSemType :: Options -> Grammar -> (ShowS, SemInfo)-> mkGSemType (TreeDecode,_,_) g -> = (def, map snd syms)-> where-> mtype s = case monad_sub g of-> Nothing -> s-> Just (ty,_,_) -> ty ++ ' ' : brack s ""--> def = str "data GSem" . nl-> . str " = NoSem" . nl-> . str (" | SemTok (" ++ token_type g ++ ")") . nl-> . interleave "\n" [ str " | " . str sym . str " " -> | sym <- map fst syms ] -> . str "instance Show GSem where" . nl-> . interleave "\n" [ str "\tshow " . str c . str "{} = " . str (show c)-> | (_,c,_,_) <- map snd syms ]--> syms = [ (c_name ++ " (" ++ ty ++ ")", (rty, c_name, mask, prod_info))-> | (i,this@(mask,args,rty)) <- zip [0..] (nub $ map fst info)-> -- find unique types (plus mask)-> , let c_name = "Sem_" ++ show i-> , let mrty = mtype rty-> , let ty = foldr (\l r -> l ++ " -> " ++ r) mrty args --> , let code_info = [ j_code | (that, j_code) <- info, this == that ]-> , let prod_info = [ ((i,k), code, js) -> | (k,code) <- zip [0..] (nub $ map snd code_info)-> , let js = [ j | (j,code2) <- code_info-> , code == code2 ]-> ]-> -- collect specific info about productions with this type-> ]--> info = [ ((var_mask, args, i_ty), (j,(ts_pats,code)))-> | i <- user_non_terminals g -> , let i_ty = typeOf i-> , j <- lookupProdsOfName g i -- all prod numbers-> , let (_,ts,(raw_code,dollar_vars),_) = lookupProdNo g j-> , let var_mask = map (\x -> x - 1) vars_used-> where vars_used = sort $ nub dollar_vars-> , let args = [ typeOf $ ts !! v | v <- var_mask ]-> , let code | all isSpace raw_code = "()"-> | otherwise = raw_code-> , let ts_pats = [ (k+1,c) | k <- var_mask-> , (t,c) <- token_specs g-> , ts !! k == t ]-> ]--> typeOf n | n `elem` terminals g = token_type g-> | otherwise = case types g ! n of-> Nothing -> "()" -- default-> Just t -> t--> -- NB expects that such labels are Showable-> mkGSemType (LabelDecode,_,_) g -> = (def, map snd syms)-> where-> def = str "data GSem" . nl-> . str " = NoSem" . nl-> . str (" | SemTok (" ++ token_type g ++ ")")-> . interleave "\n" [ str " | " . str sym . str " " -> | sym <- map fst syms ] -> . str " deriving (Show)" . nl--> syms = [ (c_name ++ " (" ++ ty ++ ")", (ty, c_name, mask, prod_info))-> | (i,this@(mask,ty)) <- zip [0..] (nub $ map fst info)-> -- find unique types-> , let c_name = "Sem_" ++ show i-> , let code_info = [ j_code | (that, j_code) <- info, this == that ]-> , let prod_info = [ ((i,k), code, js) -> | (k,code) <- zip [0..] (nub $ map snd code_info)-> , let js = [ j | (j,code2) <- code_info-> , code == code2 ]--> ]-> -- collect specific info about productions with this type-> ]--> info = [ ((var_mask,i_ty), (j,(ts_pats,code)))-> | i <- user_non_terminals g-> , let i_ty = typeOf i-> , j <- lookupProdsOfName g i -- all prod numbers-> , let (_,ts,(code,dollar_vars),_) = lookupProdNo g j-> , let var_mask = map (\x -> x - 1) vars_used-> where vars_used = sort $ nub dollar_vars-> , let ts_pats = [ (k+1,c) | k <- var_mask-> , (t,c) <- token_specs g-> , ts !! k == t ]-> ]--> typeOf n = case types g ! n of-> Nothing -> "()" -- default-> Just t -> t---%----------------------------------------Creates the appropriate semantic values.- - for label-decode, these are the code, but abstracted over the child indices- - for tree-decode, these are the code abstracted over the children's values--> mkSemObjects :: Options -> MonadInfo -> SemInfo -> ShowS -> mkSemObjects (LabelDecode,filter_opt,_) _ sem_info-> = interleave "\n" -> $ [ str (mkSemFn_Name ij)-> . str (" ns@(" ++ pat ++ "happy_rest) = ")-> . str (" Branch (" ++ c_name ++ " (" ++ code ++ ")) ")-> . str (nodes filter_opt)-> | (_ty, c_name, mask, prod_info) <- sem_info-> , (ij, (pats,code), _ps) <- prod_info -> , let pat | null mask = ""-> | otherwise = concatMap (\v -> mk_tok_binder pats (v+1) ++ ":")-> [0..maximum mask]--> , let nodes NoFiltering = "ns"-> nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask-> ]-> where-> mk_tok_binder pats v -> = mk_binder (\s -> "(_,_,HappyTok (" ++ s ++ "))") pats v ""---> mkSemObjects (TreeDecode,filter_opt,_) monad_info sem_info-> = interleave "\n" -> $ [ str (mkSemFn_Name ij)-> . str (" ns@(" ++ pat ++ "happy_rest) = ")-> . str (" Branch (" ++ c_name ++ " (" ++ sem ++ ")) ")-> . str (nodes filter_opt)-> | (_ty, c_name, mask, prod_info) <- sem_info-> , (ij, (pats,code), _) <- prod_info -> , let indent c = init $ unlines $ map (replicate 2 '\t'++) $ lines c-> , let mcode = case monad_info of-> Nothing -> code-> Just (_,_,rtn) -> case code of -> '%':code' -> "\n" ++ indent code'-> _ -> rtn ++ " (" ++ code ++ ")"-> , let sem = foldr (\v t -> mk_lambda pats (v + 1) "" ++ t) mcode mask-> , let pat | null mask = ""-> | otherwise = concatMap (\v -> mkHappyVar (v+1) ":")-> [0..maximum mask]-> , let nodes NoFiltering = "ns"-> nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask-> ] --> mk_lambda :: [(Int, String)] -> Int -> String -> String-> mk_lambda pats v-> = (\s -> "\\" ++ s ++ " -> ") . mk_binder id pats v--> mk_binder :: (String -> String) -> [(Int, String)] -> Int -> String -> String-> mk_binder wrap pats v-> = case lookup v pats of-> Nothing -> mkHappyVar v -> Just p -> case mapDollarDollar p of -> Nothing -> wrap . mkHappyVar v . showChar '@' . brack p-> Just fn -> wrap . brack' (fn . mkHappyVar v)-------standardise the naming scheme--> mkSemFn_Name :: (Int, Int) -> String-> mkSemFn_Name (i,j) = "semfn_" ++ show i ++ "_" ++ show j------maps production name to the underlying (possibly shared) semantic function--> mk_semfn_map :: SemInfo -> Array Name String-> mk_semfn_map sem_info-> = array (0,maximum $ map fst prod_map) prod_map-> where -> prod_map = [ (p, mkSemFn_Name ij) -> | (_,_,_,pi') <- sem_info, (ij,_,ps) <- pi', p <- ps ]---%------------------------------------------------------------------------------Create default decoding functions--Idea is that sem rules are stored as functions in the AbsSyn names, and -only unpacked when needed. Using classes here to manage the unpacking. --> mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> ShowS-> mkDecodeUtils (TreeDecode,filter_opt,_) monad_info seminfo-> = interleave "\n" -> $ map str (monad_defs monad_info)-> ++ map mk_inst ty_cs-> where-> ty_cs = [ (ty, [ (c_name, mask)-> | (ty2, c_name, mask, _j_vs) <- seminfo-> , ty2 == ty-> ])-> | ty <- nub [ ty | (ty,_,_,_) <- seminfo ]-> ] -- group by same type--> mk_inst (ty, cs_vs)-> = str ("instance TreeDecode (" ++ ty ++ ") where ") . nl-> . interleave "\n"-> [ char '\t' -> . str ("decode_b f (Branch (" ++ c_name ++ " s)")-> . str (" (" ++ var_pat ++ ")) = ")-> . cross_prod monad_info "s" (nodes filter_opt)-> | (c_name, vs) <- cs_vs -> , let vars = [ "b_" ++ show n | n <- var_range filter_opt vs ]-> , let var_pat = foldr (\l r -> l ++ ":" ++ r) "_" vars-> , let nodes NoFiltering = [ vars !! n | n <- vs ]-> nodes UseFiltering = vars -> ]--> var_range _ [] = []-> var_range NoFiltering vs = [0 .. maximum vs ]-> var_range UseFiltering vs = [0 .. length vs - 1]--> cross_prod Nothing s_var nodes-> = cross_prod_ (char '[' . str s_var . char ']') -> (map str nodes)-> cross_prod (Just (_,_,rtn)) s_var nodes-> = str "map happy_join $ "-> . cross_prod_ (char '[' . str rtn . char ' ' . str s_var . char ']')-> (map str nodes)--> cross_prod_ = foldl (\s a -> brack' -> $ str "cross_fn" -> . char ' ' . s -> . str " $ decode f " -> . a)----> mkDecodeUtils (LabelDecode,_,_) monad_info seminfo-> = interleave "\n" -> $ map str -> $ monad_defs monad_info ++ concatMap (mk_inst) ty_cs-> where-> ty_cs = [ (ty, [ (c_name, mask)-> | (ty2, c_name, mask, _) <- seminfo-> , ty2 == ty-> ])-> | ty <- nub [ ty | (ty,_,_,_) <- seminfo ]-> ] -- group by same type--> mk_inst (ty, cns)-> = ("instance LabelDecode (" ++ ty ++ ") where ")-> : [ "\tunpack (" ++ c_name ++ " s) = s"-> | (c_name, _mask) <- cns ]-------This selects the info used for monadic parser generation--> type MonadInfo = Maybe (String,String,String)-> monad_sub :: Grammar -> MonadInfo-> monad_sub g -> = case monad g of-> (True, _, ty,bd,ret) -> Just (ty,bd,ret)-> _ -> Nothing -> -- TMP: only use monad info if it was user-declared, and ignore ctxt-> -- TMP: otherwise default to non-monadic code-> -- TMP: (NB not sure of consequences of monads-everywhere yet)------ -form the various monad-related defs. --> monad_defs :: MonadInfo -> [String]-> monad_defs Nothing -> = [ "type Decode_Result a = a"-> , "happy_ap = ($)"-> , "happy_return = id"]-> monad_defs (Just (ty,tn,rtn)) -> = [ "happy_join x = (" ++ tn ++ ") x id"-> , "happy_ap f a = (" ++ tn ++ ") f (\\f -> (" ++ tn ++ ") a (\\a -> " ++ rtn ++ "(f a)))"-> , "type Decode_Result a = " ++ brack ty " a"-> , "happy_return = " ++ rtn ++ " :: a -> Decode_Result a"-> ]--%------------------------------------------------------------------------------Util Functions------remove Happy-generated start symbols.--> user_non_terminals :: Grammar -> [Name]-> user_non_terminals g-> = non_terminals g \\ start_productions g--> start_productions :: Grammar -> [Name]-> start_productions g = [ s | (_,s,_,_) <- starts g ]--------> mkHappyVar :: Int -> String -> String-> mkHappyVar n = showString "happy_var_" . shows n--+ + + + + + + + + + + + + + + + + + +> module ProduceGLRCode ( produceGLRParser +> , DecodeOption(..) +> , FilterOption(..) +> , GhcExts(..) +> , Options +> ) where + + +-- > import Paths_happy ( version ) + + +> import GenUtils ( thd3, mapDollarDollar ) +> import GenUtils ( str, char, nl, brack, brack', interleave, maybestr ) +> import Grammar +> import System.IO +> import Data.Array +> import Data.Char ( isSpace ) +> import Data.List ( nub, (\\), sort ) + + +-- > import Data.Version ( showVersion ) + + + + + + + + +> base_template, lib_template :: String -> String +> base_template td = td ++ "/GLR_Base" -- NB Happy uses / too +> lib_template td = td ++ "/GLR_Lib" -- Windows accepts this? + + + + + + + + +> prefix :: String +> prefix = "G_" + + + + + + + + +> data DecodeOption +> = TreeDecode +> | LabelDecode + + + + + + + + +> data FilterOption +> = NoFiltering +> | UseFiltering + + + + + + + + + + +> data GhcExts +> = NoGhcExts +> | UseGhcExts String String -- imports and options + + + + + + + + +> show_st :: GhcExts -> {-State-}Int -> String +> show_st UseGhcExts{} = (++"#") . show +> show_st NoGhcExts = show + + + + + + +> type DebugMode = Bool +> type Options = (DecodeOption, FilterOption, GhcExts) + + + + + + + + + + +> produceGLRParser +> :: FilePath -- Output file name +> -> String -- Templates directory +> -> ActionTable -- LR tables +> -> GotoTable -- LR tables +> -> Maybe String -- Module header +> -> Maybe String -- User-defined stuff (token DT, lexer etc.) +> -> (DebugMode,Options) -- selecting code-gen style +> -> Grammar -- Happy Grammar +> -> IO () + + +> produceGLRParser outfilename template_dir action goto header trailer options g +> = do +> let basename = takeWhile (/='.') outfilename +> let tbls = (action,goto) +> (parseName,_,_,_) <- case starts g of +> [s] -> return s +> s:_ -> do +> putStrLn "GLR-Happy doesn't support multiple start points (yet)" +> putStrLn "Defaulting to first start point." +> return s +> [] -> error "produceGLRParser: []" +> mkFiles basename tbls parseName template_dir header trailer options g + + + + + + + + + + + + + + +> mkFiles :: FilePath -- Root of Output file name +> -> (ActionTable +> ,GotoTable) -- LR tables +> -> String -- Start parse function name +> -> String -- Templates directory +> -> Maybe String -- Module header +> -> Maybe String -- User-defined stuff (token DT, lexer etc.) +> -> (DebugMode,Options) -- selecting code-gen style +> -> Grammar -- Happy Grammar +> -> IO () +> +> mkFiles basename tables start templdir header trailer (debug,options) g +> = do +> let debug_ext = if debug then "-debug" else "" +> let (ext,imps,opts) = case thd3 options of +> UseGhcExts is os -> ("-ghc", is, os) +> _ -> ("", "", "") +> base <- readFile (base_template templdir) +> --writeFile (basename ++ ".si") (unlines $ map show sem_info) +> writeFile (basename ++ "Data.hs") (content base opts $ "") + + +> lib <- readFile (lib_template templdir ++ ext ++ debug_ext) +> writeFile (basename ++ ".hs") (lib_content imps opts lib) +> where +> mod_name = reverse $ takeWhile (`notElem` "\\/") $ reverse basename +> data_mod = mod_name ++ "Data" + + +> (sem_def, sem_info) = mkGSemType options g +> table_text = mkTbls tables sem_info (thd3 options) g + + +> header_parts = fmap (span (\x -> take 3 (dropWhile isSpace x) == "{-#") +> . lines) +> header +> -- Split off initial options, if they are present +> -- Assume these options ONLY related to code which is in +> -- parser tail or in sem. rules + + +> content base_defs opts +> = str ("{-# OPTIONS " ++ opts ++ " #-}") .nl +> . str (unlines $ maybe [] fst header_parts) .nl +> . nl +> . str (comment "data") .nl .nl +> . str ("module " ++ data_mod ++ " where") .nl + + +> . nl +> . maybestr (fmap (unlines.snd) header_parts) .nl +> . nl +> . str base_defs .nl +> . nl + + +> . let count_nls = length . filter (=='\n') +> pre_trailer = maybe 0 count_nls header -- check fmt below +> + count_nls base_defs +> + 10 -- for the other stuff +> post_trailer = pre_trailer + maybe 0 count_nls trailer + 4 +> in +> str ("{-# LINE " ++ show pre_trailer ++ " " +> ++ show (basename ++ "Data.hs") ++ "#-}") +> -- This should show a location in basename.y -- but Happy +> -- doesn't pass this info through. But we still avoid being +> -- told a location in GLR_Base! +> . nl +> . nl +> . maybestr trailer +> .nl +> .nl +> . str ("{-# LINE " ++ show post_trailer ++ " " +> ++ show (basename ++ "Data.hs") ++ "#-}") +> . nl +> . nl + + +> . mkGSymbols g .nl +> . nl +> . sem_def .nl +> . nl +> . mkSemObjects options (monad_sub g) sem_info .nl +> . nl +> . mkDecodeUtils options (monad_sub g) sem_info .nl +> . nl +> . user_def_token_code (token_type g) .nl +> . nl +> . table_text + + +> lib_content imps opts lib_text +> = let (pre,_drop_me : post) = break (== "fakeimport DATA") $ lines lib_text +> in +> unlines [ "{-# OPTIONS " ++ opts ++ " #-}\n" +> , comment "driver" ++ "\n" +> , "module " ++ mod_name ++ "(" +> , case lexer g of +> Nothing -> "" +> Just (lf,_) -> "\t" ++ lf ++ "," +> , "\t" ++ start +> , "" +> , unlines pre +> , imps +> , "import " ++ data_mod +> , start ++ " = glr_parse " +> , "use_filtering = " ++ show use_filtering +> , "top_symbol = " ++ prefix ++ start_prod +> , unlines post +> ] +> start_prod = token_names g ! (let (_,_,i,_) = head $ starts g in i) +> use_filtering = case options of (_, UseFiltering,_) -> True +> _ -> False + + +> comment :: String -> String +> comment which +> = "-- parser (" ++ which ++ ") produced by Happy (GLR)" + + + + +> user_def_token_code :: String -> String -> String +> user_def_token_code tokenType +> = str "type UserDefTok = " . str tokenType . nl +> . str "instance TreeDecode " . brack tokenType . str " where" . nl +> . str "\tdecode_b f (Branch (SemTok t) []) = [happy_return t]" . nl +> . str "instance LabelDecode " . brack tokenType . str " where" . nl +> . str "\tunpack (SemTok t) = t" . nl + + + + + + + + + + +> mkTbls :: (ActionTable -- Action table from Happy +> ,GotoTable) -- Goto table from Happy +> -> SemInfo -- info about production mapping +> -> GhcExts -- Use unboxed values? +> -> Grammar -- Happy Grammar +> -> ShowS +> +> mkTbls (action,goto) sem_info exts g +> = let gsMap = mkGSymMap g +> semfn_map = mk_semfn_map sem_info +> in +> writeActionTbl action gsMap (semfn_map !) exts g +> . writeGotoTbl goto gsMap exts + + + + + + + + + + + + +> mkGSymMap :: Grammar -> [(Name,String)] +> mkGSymMap g +> = [ -- (errorTok, prefix ++ "Error") +> ] +> ++ [ (i, prefix ++ (token_names g) ! i) +> | i <- user_non_terminals g ] -- Non-terminals +> ++ [ (i, "HappyTok (" ++ mkMatch tok ++ ")") +> | (i,tok) <- token_specs g ] -- Tokens (terminals) +> ++ [(eof_term g,"HappyEOF")] -- EOF symbol (internal terminal) +> where +> mkMatch tok = case mapDollarDollar tok of +> Nothing -> tok +> Just fn -> fn "_" + + +> toGSym :: [(Int, String)] -> Int -> String +> toGSym gsMap i +> = case lookup i gsMap of +> Nothing -> error $ "No representation for symbol " ++ show i +> Just g -> g + + + + + + + + + + + + + + +> writeActionTbl +> :: ActionTable -> [(Int,String)] -> (Name->String) +> -> GhcExts -> Grammar -> ShowS +> writeActionTbl acTbl gsMap semfn_map exts g +> = interleave "\n" +> $ map str +> $ mkLines ++ [errorLine] ++ mkReductions +> where +> name = "action" +> mkLines = concatMap (mkState) (assocs acTbl) +> errorLine = name ++ " _ _ = Error" +> mkState (i,arr) +> = filter (/="") $ map (mkLine i) (assocs arr) +> +> mkLine state (symInt,action) +> | symInt == errorTok -- skip error productions +> = "" -- NB see ProduceCode's handling of these +> | otherwise +> = case action of +> LR'Fail -> "" +> LR'MustFail -> "" +> _ -> unwords [ startLine , mkAct action ] +> where +> startLine +> = unwords [ name , show_st exts state, "(" , getTok , ") =" ] +> getTok = let tok = toGSym gsMap symInt +> in case mapDollarDollar tok of +> Nothing -> tok +> Just f -> f "_" +> mkAct act +> = case act of +> LR'Shift newSt _ -> "Shift " ++ show newSt ++ " []" +> LR'Reduce r _ -> "Reduce " ++ "[" ++ mkRed r ++ "]" +> LR'Accept -> "Accept" +> LR'Multiple rs (LR'Shift st _) +> -> "Shift " ++ show st ++ " " ++ mkReds rs +> LR'Multiple rs r@(LR'Reduce{}) +> -> "Reduce " ++ mkReds (r:rs) +> _ -> error "writeActionTbl/mkAct: Unhandled case" +> where +> mkReds rs = "[" ++ tail (concat [ "," ++ mkRed r | LR'Reduce r _ <- rs ]) ++ "]" + + +> mkRed r = "red_" ++ show r +> mkReductions = [ mkRedDefn p | p@(_,(n,_,_,_)) <- zip [0..] $ productions g +> , n `notElem` start_productions g ] + + +> mkRedDefn (r, (lhs_id, rhs_ids, (_code,_dollar_vars), _)) +> = mkRed r ++ " = ("++ lhs ++ "," ++ show arity ++ " :: Int," ++ sem ++")" +> where +> lhs = toGSym gsMap $ lhs_id +> arity = length rhs_ids +> sem = semfn_map r + + + + + + + + + + +> writeGotoTbl :: GotoTable -> [(Int,String)] -> GhcExts -> ShowS +> writeGotoTbl goTbl gsMap exts +> = interleave "\n" (map str $ filter (not.null) mkLines) +> . str errorLine . nl +> where +> name = "goto" +> errorLine = "goto _ _ = " ++ show_st exts (negate 1) +> mkLines = map mkState (assocs goTbl) +> +> mkState (i,arr) +> = unlines $ filter (/="") $ map (mkLine i) (assocs arr) +> +> mkLine state (ntInt,goto) +> = case goto of +> NoGoto -> "" +> Goto st -> unwords [ startLine , show_st exts st ] +> where +> startLine +> = unwords [ name , show_st exts state, getGSym , "=" ] +> getGSym = toGSym gsMap ntInt + + + + + + + + + + +> mkGSymbols :: Grammar -> ShowS +> mkGSymbols g +> = str dec +> . str eof +> . str tok +> . interleave "\n" [ str " | " . str prefix . str sym . str " " +> | sym <- syms ] +> . str der +> -- ++ eq_inst +> -- ++ ord_inst +> where +> dec = "data GSymbol" +> eof = " = HappyEOF" +> tok = " | HappyTok {-!Int-} (" ++ token_type g ++ ")" +> der = " deriving (Show,Eq,Ord)" +> syms = [ token_names g ! i | i <- user_non_terminals g ] + + + + + + + + + + + + + + + + + + + + + + +<> eq_inst = "instance Eq GSymbol where" +<> : "\tHappyTok i _ == HappyTok j _ = i == j" +<> : [ "\ti == j = fromEnum i == fromEnum j" + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +> type SemInfo +> = [(String, String, [Int], [((Int,Int), ([(Int,String)],String), [Int])])] + + +> mkGSemType :: Options -> Grammar -> (ShowS, SemInfo) +> mkGSemType (TreeDecode,_,_) g +> = (def, map snd syms) +> where +> mtype s = case monad_sub g of +> Nothing -> s +> Just (ty,_,_) -> ty ++ ' ' : brack s "" + + +> def = str "data GSem" . nl +> . str " = NoSem" . nl +> . str (" | SemTok (" ++ token_type g ++ ")") . nl +> . interleave "\n" [ str " | " . str sym . str " " +> | sym <- map fst syms ] +> . str "instance Show GSem where" . nl +> . interleave "\n" [ str "\tshow " . str c . str "{} = " . str (show c) +> | (_,c,_,_) <- map snd syms ] + + +> syms = [ (c_name ++ " (" ++ ty ++ ")", (rty, c_name, mask, prod_info)) +> | (i,this@(mask,args,rty)) <- zip [0..] (nub $ map fst info) +> -- find unique types (plus mask) +> , let c_name = "Sem_" ++ show i +> , let mrty = mtype rty +> , let ty = foldr (\l r -> l ++ " -> " ++ r) mrty args + + +> , let code_info = [ j_code | (that, j_code) <- info, this == that ] +> , let prod_info = [ ((i,k), code, js) +> | (k,code) <- zip [0..] (nub $ map snd code_info) +> , let js = [ j | (j,code2) <- code_info +> , code == code2 ] +> ] +> -- collect specific info about productions with this type +> ] + + +> info = [ ((var_mask, args, i_ty), (j,(ts_pats,code))) +> | i <- user_non_terminals g +> , let i_ty = typeOf i +> , j <- lookupProdsOfName g i -- all prod numbers +> , let (_,ts,(raw_code,dollar_vars),_) = lookupProdNo g j +> , let var_mask = map (\x -> x - 1) vars_used +> where vars_used = sort $ nub dollar_vars +> , let args = [ typeOf $ ts !! v | v <- var_mask ] +> , let code | all isSpace raw_code = "()" +> | otherwise = raw_code +> , let ts_pats = [ (k+1,c) | k <- var_mask +> , (t,c) <- token_specs g +> , ts !! k == t ] +> ] + + +> typeOf n | n `elem` terminals g = token_type g +> | otherwise = case types g ! n of +> Nothing -> "()" -- default +> Just t -> t + + +> -- NB expects that such labels are Showable +> mkGSemType (LabelDecode,_,_) g +> = (def, map snd syms) +> where +> def = str "data GSem" . nl +> . str " = NoSem" . nl +> . str (" | SemTok (" ++ token_type g ++ ")") +> . interleave "\n" [ str " | " . str sym . str " " +> | sym <- map fst syms ] +> . str " deriving (Show)" . nl + + +> syms = [ (c_name ++ " (" ++ ty ++ ")", (ty, c_name, mask, prod_info)) +> | (i,this@(mask,ty)) <- zip [0..] (nub $ map fst info) +> -- find unique types +> , let c_name = "Sem_" ++ show i +> , let code_info = [ j_code | (that, j_code) <- info, this == that ] +> , let prod_info = [ ((i,k), code, js) +> | (k,code) <- zip [0..] (nub $ map snd code_info) +> , let js = [ j | (j,code2) <- code_info +> , code == code2 ] + + +> ] +> -- collect specific info about productions with this type +> ] + + +> info = [ ((var_mask,i_ty), (j,(ts_pats,code))) +> | i <- user_non_terminals g +> , let i_ty = typeOf i +> , j <- lookupProdsOfName g i -- all prod numbers +> , let (_,ts,(code,dollar_vars),_) = lookupProdNo g j +> , let var_mask = map (\x -> x - 1) vars_used +> where vars_used = sort $ nub dollar_vars +> , let ts_pats = [ (k+1,c) | k <- var_mask +> , (t,c) <- token_specs g +> , ts !! k == t ] +> ] + + +> typeOf n = case types g ! n of +> Nothing -> "()" -- default +> Just t -> t + + + + + + + + + + + + + + +> mkSemObjects :: Options -> MonadInfo -> SemInfo -> ShowS +> mkSemObjects (LabelDecode,filter_opt,_) _ sem_info +> = interleave "\n" +> $ [ str (mkSemFn_Name ij) +> . str (" ns@(" ++ pat ++ "happy_rest) = ") +> . str (" Branch (" ++ c_name ++ " (" ++ code ++ ")) ") +> . str (nodes filter_opt) +> | (_ty, c_name, mask, prod_info) <- sem_info +> , (ij, (pats,code), _ps) <- prod_info +> , let pat | null mask = "" +> | otherwise = concatMap (\v -> mk_tok_binder pats (v+1) ++ ":") +> [0..maximum mask] + + +> , let nodes NoFiltering = "ns" +> nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask +> ] +> where +> mk_tok_binder pats v +> = mk_binder (\s -> "(_,_,HappyTok (" ++ s ++ "))") pats v "" + + + + +> mkSemObjects (TreeDecode,filter_opt,_) monad_info sem_info +> = interleave "\n" +> $ [ str (mkSemFn_Name ij) +> . str (" ns@(" ++ pat ++ "happy_rest) = ") +> . str (" Branch (" ++ c_name ++ " (" ++ sem ++ ")) ") +> . str (nodes filter_opt) +> | (_ty, c_name, mask, prod_info) <- sem_info +> , (ij, (pats,code), _) <- prod_info +> , let indent c = init $ unlines $ map (replicate 2 '\t'++) $ lines c +> , let mcode = case monad_info of +> Nothing -> code +> Just (_,_,rtn) -> case code of +> '%':code' -> "\n" ++ indent code' +> _ -> rtn ++ " (" ++ code ++ ")" +> , let sem = foldr (\v t -> mk_lambda pats (v + 1) "" ++ t) mcode mask +> , let pat | null mask = "" +> | otherwise = concatMap (\v -> mkHappyVar (v+1) ":") +> [0..maximum mask] +> , let nodes NoFiltering = "ns" +> nodes UseFiltering = "(" ++ foldr (\l -> mkHappyVar (l+1) . showChar ':') "[])" mask +> ] + + +> mk_lambda :: [(Int, String)] -> Int -> String -> String +> mk_lambda pats v +> = (\s -> "\\" ++ s ++ " -> ") . mk_binder id pats v + + +> mk_binder :: (String -> String) -> [(Int, String)] -> Int -> String -> String +> mk_binder wrap pats v +> = case lookup v pats of +> Nothing -> mkHappyVar v +> Just p -> case mapDollarDollar p of +> Nothing -> wrap . mkHappyVar v . showChar '@' . brack p +> Just fn -> wrap . brack' (fn . mkHappyVar v) + + + + + + + + + + +> mkSemFn_Name :: (Int, Int) -> String +> mkSemFn_Name (i,j) = "semfn_" ++ show i ++ "_" ++ show j + + + + + + + + +> mk_semfn_map :: SemInfo -> Array Name String +> mk_semfn_map sem_info +> = array (0,maximum $ map fst prod_map) prod_map +> where +> prod_map = [ (p, mkSemFn_Name ij) +> | (_,_,_,pi') <- sem_info, (ij,_,ps) <- pi', p <- ps ] + + + + + + + + + + + + + + + + +> mkDecodeUtils :: Options -> MonadInfo -> SemInfo -> ShowS +> mkDecodeUtils (TreeDecode,filter_opt,_) monad_info seminfo +> = interleave "\n" +> $ map str (monad_defs monad_info) +> ++ map mk_inst ty_cs +> where +> ty_cs = [ (ty, [ (c_name, mask) +> | (ty2, c_name, mask, _j_vs) <- seminfo +> , ty2 == ty +> ]) +> | ty <- nub [ ty | (ty,_,_,_) <- seminfo ] +> ] -- group by same type + + +> mk_inst (ty, cs_vs) +> = str ("instance TreeDecode (" ++ ty ++ ") where ") . nl +> . interleave "\n" +> [ char '\t' +> . str ("decode_b f (Branch (" ++ c_name ++ " s)") +> . str (" (" ++ var_pat ++ ")) = ") +> . cross_prod monad_info "s" (nodes filter_opt) +> | (c_name, vs) <- cs_vs +> , let vars = [ "b_" ++ show n | n <- var_range filter_opt vs ] +> , let var_pat = foldr (\l r -> l ++ ":" ++ r) "_" vars +> , let nodes NoFiltering = [ vars !! n | n <- vs ] +> nodes UseFiltering = vars +> ] + + +> var_range _ [] = [] +> var_range NoFiltering vs = [0 .. maximum vs ] +> var_range UseFiltering vs = [0 .. length vs - 1] + + +> cross_prod Nothing s_var nodes +> = cross_prod_ (char '[' . str s_var . char ']') +> (map str nodes) +> cross_prod (Just (_,_,rtn)) s_var nodes +> = str "map happy_join $ " +> . cross_prod_ (char '[' . str rtn . char ' ' . str s_var . char ']') +> (map str nodes) + + +> cross_prod_ = foldl (\s a -> brack' +> $ str "cross_fn" +> . char ' ' . s +> . str " $ decode f " +> . a) + + + + + + +> mkDecodeUtils (LabelDecode,_,_) monad_info seminfo +> = interleave "\n" +> $ map str +> $ monad_defs monad_info ++ concatMap (mk_inst) ty_cs +> where +> ty_cs = [ (ty, [ (c_name, mask) +> | (ty2, c_name, mask, _) <- seminfo +> , ty2 == ty +> ]) +> | ty <- nub [ ty | (ty,_,_,_) <- seminfo ] +> ] -- group by same type + + +> mk_inst (ty, cns) +> = ("instance LabelDecode (" ++ ty ++ ") where ") +> : [ "\tunpack (" ++ c_name ++ " s) = s" +> | (c_name, _mask) <- cns ] + + + + + + + + + + +> type MonadInfo = Maybe (String,String,String) +> monad_sub :: Grammar -> MonadInfo +> monad_sub g +> = case monad g of +> (True, _, ty,bd,ret) -> Just (ty,bd,ret) +> _ -> Nothing +> -- TMP: only use monad info if it was user-declared, and ignore ctxt +> -- TMP: otherwise default to non-monadic code +> -- TMP: (NB not sure of consequences of monads-everywhere yet) + + + + + + + + + + +> monad_defs :: MonadInfo -> [String] +> monad_defs Nothing +> = [ "type Decode_Result a = a" +> , "happy_ap = ($)" +> , "happy_return = id"] +> monad_defs (Just (ty,tn,rtn)) +> = [ "happy_join x = (" ++ tn ++ ") x id" +> , "happy_ap f a = (" ++ tn ++ ") f (\\f -> (" ++ tn ++ ") a (\\a -> " ++ rtn ++ "(f a)))" +> , "type Decode_Result a = " ++ brack ty " a" +> , "happy_return = " ++ rtn ++ " :: a -> Decode_Result a" +> ] + + + + + + + + + + + + + + +> user_non_terminals :: Grammar -> [Name] +> user_non_terminals g +> = non_terminals g \\ start_productions g + + +> start_productions :: Grammar -> [Name] +> start_productions g = [ s | (_,s,_,_) <- starts g ] + + + + + + + + +> mkHappyVar :: Int -> String -> String +> mkHappyVar n = showString "happy_var_" . shows n + + +
src/Target.lhs view
@@ -1,13 +1,21 @@-------------------------------------------------------------------------------The target data type.--(c) 1993-2001 Andy Gill, Simon Marlow--------------------------------------------------------------------------------> module Target (Target(..)) where--> data Target-> = TargetHaskell -- functions and things-> | TargetArrayBased -- arrays--> deriving Eq+ + + + + + + + + + + + +> module Target (Target(..)) where + + +> data Target +> = TargetHaskell -- functions and things +> | TargetArrayBased -- arrays + + +> deriving Eq
src/Text/Happy.hs view
@@ -1,171 +1,171 @@-module Text.Happy (runHappy, CLIFlags(..), HappyInfo(..)) where--import ProduceCode-import Parser-import ParseMonad-import AbsSyn-import LALR-import First-import Grammar-import GenUtils-import Target--- import Text.Happy.HappyTemplate-import Data.Array( assocs, elems, (!) )-import Data.List( nub )--data HappyInfo = HappyInfo { unused :: ([Int],[String]), sr :: Int, rr :: Int}- -runHappy :: [CLIFlags]- -> String- -> Either String (String, HappyInfo)-runHappy cli s = - case runP ourParser s 1 of- FailP err -> Left err- OkP abssyn@(AbsSyn _ _ _ tl) -> Right $- case {-# SCC "Mangler" #-} (mangler "" abssyn) of- Failed e -> die (unlines e ++ "\n")- Succeeded g -> let - first = {-# SCC "First" #-} (mkFirst g)- closures = {-# SCC "Closures" #-} (precalcClosure0 g)- sets = {-# SCC "LR0_Sets" #-} (genLR0items g closures)- _lainfo@(spont,prop) = {-# SCC "Prop" #-} (propLookaheads g sets first)- la = {-# SCC "Calc" #-} (calcLookaheads (length sets) spont prop)- items2 = {-# SCC "Merge" #-} (mergeLookaheadInfo la sets)- goto = {-# SCC "Goto" #-} (genGotoTable g sets)- action = {-# SCC "Action" #-} (genActionTable g first items2)- (conflictArray,(sr,rr)) = {-# SCC "Conflict" #-} (countConflicts action)-- reduction_filter | OptGLR `elem` cli = any_reduction- | otherwise = first_reduction- (unused_rules, unused_terminals) - = find_redundancies reduction_filter g action-- target = getTarget cli-- opt_coerce = getCoerce target cli- opt_strict = getStrict cli- opt_ghc = getGhc cli--- -- templ = getTemplate - outfile = produceParser - g- action- goto- (optsToInject target cli)- Nothing- tl- TargetHaskell- opt_coerce- opt_ghc- opt_strict- in- (outfile,HappyInfo (unused_rules, unused_terminals) sr rr)----die :: String -> a-die s = error s--find_redundancies - :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String])-find_redundancies extract_reductions g action_table = - (unused_rules, map (env !) unused_terminals)- where- Grammar { terminals = terms,- token_names = env,- eof_term = eof,- starts = starts',- productions = productions'- } = g-- actions = concat (map assocs (elems action_table))- start_rules = [ 0 .. (length starts' - 1) ]- used_rules = start_rules ++- nub [ r | (_,a) <- actions, r <- extract_reductions a ]- used_tokens = errorTok : eof : - nub [ t | (t,a) <- actions, is_shift a ]- n_prods = length productions'- unused_terminals = filter (`notElem` used_tokens) terms- unused_rules = filter (`notElem` used_rules ) [0..n_prods-1]--is_shift :: LRAction -> Bool-is_shift (LR'Shift _ _) = True-is_shift (LR'Multiple _ LR'Shift{}) = True-is_shift _ = False---- selects what counts as a reduction when calculating used/unused--any_reduction :: LRAction -> [Int]-any_reduction (LR'Reduce r _) = [r] -any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as)-any_reduction _ = []--first_reduction :: LRAction -> [Int]-first_reduction (LR'Reduce r _) = [r] -first_reduction (LR'Multiple _ a) = first_reduction a -- eg R/R conflict-first_reduction _ = []--optsToInject :: Target -> [CLIFlags] -> String-optsToInject tgt cli - | OptGhcTarget `elem` cli = "-fglasgow-exts -cpp"- | tgt == TargetArrayBased = "-cpp"- | OptDebugParser `elem` cli = "-cpp"- | otherwise = ""--optToTarget :: CLIFlags -> Maybe Target-optToTarget OptArrayTarget = Just TargetArrayBased-optToTarget _ = Nothing--data CLIFlags =- DumpVersion- | DumpHelp- | OptInfoFile (Maybe String)- | OptTemplate String- | OptMagicName String-- | OptGhcTarget- | OptArrayTarget- | OptUseCoercions- | OptDebugParser- | OptStrict- | OptOutputFile String- | OptGLR- | OptGLR_Decode- | OptGLR_Filter- deriving Eq---getTarget :: [CLIFlags] -> Target-getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of- (t:ts) | all (==t) ts -> t- [] -> TargetHaskell- _ -> error "getTarget: multiple target options"---- > getTemplate :: IO String -> [CLIFlags] -> IO String--- > getTemplate def cli--- > = case [ s | (OptTemplate s) <- cli ] of--- > [] -> def--- > f:fs -> return (last (f:fs))-{--> getMagicName :: [CLIFlags] -> IO (Maybe String)-> getMagicName cli-> = case [ s | (OptMagicName s) <- cli ] of-> [] -> return Nothing-> f:fs -> return (Just (map toLower (last (f:fs))))--}-getCoerce :: Target -> [CLIFlags] -> Bool-getCoerce _target cli- = if OptUseCoercions `elem` cli - then if OptGhcTarget `elem` cli- then True- else error ("-c/--coerce may only be used " ++- "in conjunction with -g/--ghc\n")- else False--getGhc :: [CLIFlags] -> Bool-getGhc cli = OptGhcTarget `elem` cli--getStrict :: [CLIFlags] -> Bool-getStrict cli = OptStrict `elem` cli-+module Text.Happy (runHappy, CLIFlags(..), HappyInfo(..)) where + +import ProduceCode +import Parser +import ParseMonad +import AbsSyn +import LALR +import First +import Grammar +import GenUtils +import Target +-- import Text.Happy.HappyTemplate +import Data.Array( assocs, elems, (!) ) +import Data.List( nub ) + +data HappyInfo = HappyInfo { unused :: ([Int],[String]), sr :: Int, rr :: Int} + +runHappy :: [CLIFlags] + -> String + -> Either String (String, HappyInfo) +runHappy cli s = + case runP ourParser s 1 of + FailP err -> Left err + OkP abssyn@(AbsSyn _ _ _ tl) -> Right $ + case {-# SCC "Mangler" #-} (mangler "" abssyn) of + Failed e -> die (unlines e ++ "\n") + Succeeded g -> let + first = {-# SCC "First" #-} (mkFirst g) + closures = {-# SCC "Closures" #-} (precalcClosure0 g) + sets = {-# SCC "LR0_Sets" #-} (genLR0items g closures) + _lainfo@(spont,prop) = {-# SCC "Prop" #-} (propLookaheads g sets first) + la = {-# SCC "Calc" #-} (calcLookaheads (length sets) spont prop) + items2 = {-# SCC "Merge" #-} (mergeLookaheadInfo la sets) + goto = {-# SCC "Goto" #-} (genGotoTable g sets) + action = {-# SCC "Action" #-} (genActionTable g first items2) + (conflictArray,(sr,rr)) = {-# SCC "Conflict" #-} (countConflicts action) + + reduction_filter | OptGLR `elem` cli = any_reduction + | otherwise = first_reduction + (unused_rules, unused_terminals) + = find_redundancies reduction_filter g action + + target = getTarget cli + + opt_coerce = getCoerce target cli + opt_strict = getStrict cli + opt_ghc = getGhc cli + + + -- templ = getTemplate + outfile = produceParser + g + action + goto + (optsToInject target cli) + Nothing + tl + TargetHaskell + opt_coerce + opt_ghc + opt_strict + in + (outfile,HappyInfo (unused_rules, unused_terminals) sr rr) + + + +die :: String -> a +die s = error s + +find_redundancies + :: (LRAction -> [Int]) -> Grammar -> ActionTable -> ([Int], [String]) +find_redundancies extract_reductions g action_table = + (unused_rules, map (env !) unused_terminals) + where + Grammar { terminals = terms, + token_names = env, + eof_term = eof, + starts = starts', + productions = productions' + } = g + + actions = concat (map assocs (elems action_table)) + start_rules = [ 0 .. (length starts' - 1) ] + used_rules = start_rules ++ + nub [ r | (_,a) <- actions, r <- extract_reductions a ] + used_tokens = errorTok : eof : + nub [ t | (t,a) <- actions, is_shift a ] + n_prods = length productions' + unused_terminals = filter (`notElem` used_tokens) terms + unused_rules = filter (`notElem` used_rules ) [0..n_prods-1] + +is_shift :: LRAction -> Bool +is_shift (LR'Shift _ _) = True +is_shift (LR'Multiple _ LR'Shift{}) = True +is_shift _ = False + +-- selects what counts as a reduction when calculating used/unused + +any_reduction :: LRAction -> [Int] +any_reduction (LR'Reduce r _) = [r] +any_reduction (LR'Multiple as a) = concatMap any_reduction (a : as) +any_reduction _ = [] + +first_reduction :: LRAction -> [Int] +first_reduction (LR'Reduce r _) = [r] +first_reduction (LR'Multiple _ a) = first_reduction a -- eg R/R conflict +first_reduction _ = [] + +optsToInject :: Target -> [CLIFlags] -> String +optsToInject tgt cli + | OptGhcTarget `elem` cli = "-fglasgow-exts -cpp" + | tgt == TargetArrayBased = "-cpp" + | OptDebugParser `elem` cli = "-cpp" + | otherwise = "" + +optToTarget :: CLIFlags -> Maybe Target +optToTarget OptArrayTarget = Just TargetArrayBased +optToTarget _ = Nothing + +data CLIFlags = + DumpVersion + | DumpHelp + | OptInfoFile (Maybe String) + | OptTemplate String + | OptMagicName String + + | OptGhcTarget + | OptArrayTarget + | OptUseCoercions + | OptDebugParser + | OptStrict + | OptOutputFile String + | OptGLR + | OptGLR_Decode + | OptGLR_Filter + deriving Eq + + +getTarget :: [CLIFlags] -> Target +getTarget cli = case [ t | (Just t) <- map optToTarget cli ] of + (t:ts) | all (==t) ts -> t + [] -> TargetHaskell + _ -> error "getTarget: multiple target options" + +-- > getTemplate :: IO String -> [CLIFlags] -> IO String +-- > getTemplate def cli +-- > = case [ s | (OptTemplate s) <- cli ] of +-- > [] -> def +-- > f:fs -> return (last (f:fs)) +{- +> getMagicName :: [CLIFlags] -> IO (Maybe String) +> getMagicName cli +> = case [ s | (OptMagicName s) <- cli ] of +> [] -> return Nothing +> f:fs -> return (Just (map toLower (last (f:fs)))) +-} +getCoerce :: Target -> [CLIFlags] -> Bool +getCoerce _target cli + = if OptUseCoercions `elem` cli + then if OptGhcTarget `elem` cli + then True + else error ("-c/--coerce may only be used " ++ + "in conjunction with -g/--ghc\n") + else False + +getGhc :: [CLIFlags] -> Bool +getGhc cli = OptGhcTarget `elem` cli + +getStrict :: [CLIFlags] -> Bool +getStrict cli = OptStrict `elem` cli +
src/Text/Happy/HappyTemplate.hs view
@@ -1,206 +1,206 @@-module Text.Happy.HappyTemplate where-happyTemplate =- "{-# LINE 1 \"templates\\GenericTemplate.hs\" #-}\n" ++ - "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "{-# LINE 1 \"<built-in>\" #-}\n" ++ - "{-# LINE 1 \"<command line>\" #-}\n" ++ - "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp \n" ++ - "\n" ++ - "{-# LINE 28 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "{-# LINE 49 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "\n" ++ - "{-# LINE 59 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "\n" ++ - "{-# LINE 68 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "\n" ++ - "infixr 9 `HappyStk`\n" ++ - "data HappyStk a = HappyStk a (HappyStk a)\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- starting the parse\n" ++ - "\n" ++ - "happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Accepting the parse\n" ++ - "\n" ++ - "-- If the current token is (1), it means we've just accepted a partial\n" ++ - "-- parse (a %partial parser). We must ignore the saved token on the top of\n" ++ - "-- the stack in this case.\n" ++ - "happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =\n" ++ - "\thappyReturn1 ans\n" ++ - "happyAccept j tk st sts (HappyStk ans _) = \n" ++ - "\t (happyReturn1 ans)\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Arrays only: do the next action\n" ++ - "\n" ++ - "{-# LINE 155 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- HappyState data type (not arrays)\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "newtype HappyState b c = HappyState\n" ++ - " (Int -> -- token number\n" ++ - " Int -> -- token number (yes, again)\n" ++ - " b -> -- token semantic value\n" ++ - " HappyState b c -> -- current state\n" ++ - " [HappyState b c] -> -- state stack\n" ++ - " c)\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Shifting a token\n" ++ - "\n" ++ - "happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =\n" ++ - " let i = (case x of { HappyErrorToken (i) -> i }) in\n" ++ - "-- trace \"shifting the error token\" $\n" ++ - " new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)\n" ++ - "\n" ++ - "happyShift new_state i tk st sts stk =\n" ++ - " happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)\n" ++ - "\n" ++ - "-- happyReduce is specialised for the common cases.\n" ++ - "\n" ++ - "happySpecReduce_0 i fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk\n" ++ - " = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)\n" ++ - "\n" ++ - "happySpecReduce_1 i fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')\n" ++ - " = let r = fn v1 in\n" ++ - " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ - "\n" ++ - "happySpecReduce_2 i fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')\n" ++ - " = let r = fn v1 v2 in\n" ++ - " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ - "\n" ++ - "happySpecReduce_3 i fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')\n" ++ - " = let r = fn v1 v2 v3 in\n" ++ - " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ - "\n" ++ - "happyReduce k i fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happyReduce k nt fn j tk st sts stk\n" ++ - " = case happyDrop (k - ((1) :: Int)) sts of\n" ++ - "\t sts1@(((st1@(HappyState (action))):(_))) ->\n" ++ - " \tlet r = fn stk in -- it doesn't hurt to always seq here...\n" ++ - " \t\thappyDoSeq r (action nt j tk st1 sts1 r)\n" ++ - "\n" ++ - "happyMonadReduce k nt fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happyMonadReduce k nt fn j tk st sts stk =\n" ++ - " happyThen1 (fn stk tk) (\\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))\n" ++ - " where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))\n" ++ - " drop_stk = happyDropStk k stk\n" ++ - "\n" ++ - "happyMonad2Reduce k nt fn (1) tk st sts stk\n" ++ - " = happyFail (1) tk st sts stk\n" ++ - "happyMonad2Reduce k nt fn j tk st sts stk =\n" ++ - " happyThen1 (fn stk tk) (\\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))\n" ++ - " where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))\n" ++ - " drop_stk = happyDropStk k stk\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - " new_state = action\n" ++ - "\n" ++ - "\n" ++ - "happyDrop (0) l = l\n" ++ - "happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t\n" ++ - "\n" ++ - "happyDropStk (0) l = l\n" ++ - "happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Moving to a new state after a reduction\n" ++ - "\n" ++ - "{-# LINE 253 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "happyGoto action j tk st = action j j tk (HappyState action)\n" ++ - "\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Error recovery ((1) is the error token)\n" ++ - "\n" ++ - "-- parse error if we are in recovery and we fail again\n" ++ - "happyFail (1) tk old_st _ stk =\n" ++ - "--\ttrace \"failing\" $ \n" ++ - " \thappyError_ tk\n" ++ - "\n" ++ - "{- We don't need state discarding for our restricted implementation of\n" ++ - " \"error\". In fact, it can cause some bogus parses, so I've disabled it\n" ++ - " for now --SDM\n" ++ - "\n" ++ - "-- discard a state\n" ++ - "happyFail (1) tk old_st (((HappyState (action))):(sts)) \n" ++ - "\t\t\t\t\t\t(saved_tok `HappyStk` _ `HappyStk` stk) =\n" ++ - "--\ttrace (\"discarding state, depth \" ++ show (length stk)) $\n" ++ - "\taction (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))\n" ++ - "-}\n" ++ - "\n" ++ - "-- Enter error recovery: generate an error token,\n" ++ - "-- save the old token and carry on.\n" ++ - "happyFail i tk (HappyState (action)) sts stk =\n" ++ - "-- trace \"entering error recovery\" $\n" ++ - "\taction (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)\n" ++ - "\n" ++ - "-- Internal happy errors:\\n" ++ - "\n" ++ - "notHappyAtAll = error \"Internal Happy error\\n\"" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Hack to get the typechecker to accept our action functions\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Seq-ing. If the --strict flag is given, then Happy emits \n" ++ - "--\thappySeq = happyDoSeq\n" ++ - "-- otherwise it emits\n" ++ - "-- \thappySeq = happyDontSeq\n" ++ - "\n" ++ - "happyDoSeq, happyDontSeq :: a -> b -> b\n" ++ - "happyDoSeq a b = a `seq` b\n" ++ - "happyDontSeq a b = b\n" ++ - "\n" ++ - "-----------------------------------------------------------------------------\n" ++ - "-- Don't inline any functions from the template. GHC has a nasty habit\n" ++ - "-- of deciding to inline happyGoto everywhere, which increases the size of\n" ++ - "-- the generated parser quite a bit.\n" ++ - "\n" ++ - "{-# LINE 317 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "{-# NOINLINE happyShift #-}\n" ++ - "{-# NOINLINE happySpecReduce_0 #-}\n" ++ - "{-# NOINLINE happySpecReduce_1 #-}\n" ++ - "{-# NOINLINE happySpecReduce_2 #-}\n" ++ - "{-# NOINLINE happySpecReduce_3 #-}\n" ++ - "{-# NOINLINE happyReduce #-}\n" ++ - "{-# NOINLINE happyMonadReduce #-}\n" ++ - "{-# NOINLINE happyGoto #-}\n" ++ - "{-# NOINLINE happyFail #-}\n" ++ - "\n" ++ - "-- end of Happy Template."+module Text.Happy.HappyTemplate where +happyTemplate = + "{-# LINE 1 \"templates\\GenericTemplate.hs\" #-}\n" ++ + "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "{-# LINE 1 \"<built-in>\" #-}\n" ++ + "{-# LINE 1 \"<command line>\" #-}\n" ++ + "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp \n" ++ + "\n" ++ + "{-# LINE 28 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "{-# LINE 49 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "{-# LINE 59 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "{-# LINE 68 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "infixr 9 `HappyStk`\n" ++ + "data HappyStk a = HappyStk a (HappyStk a)\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- starting the parse\n" ++ + "\n" ++ + "happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Accepting the parse\n" ++ + "\n" ++ + "-- If the current token is (1), it means we've just accepted a partial\n" ++ + "-- parse (a %partial parser). We must ignore the saved token on the top of\n" ++ + "-- the stack in this case.\n" ++ + "happyAccept (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =\n" ++ + "\thappyReturn1 ans\n" ++ + "happyAccept j tk st sts (HappyStk ans _) = \n" ++ + "\t (happyReturn1 ans)\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Arrays only: do the next action\n" ++ + "\n" ++ + "{-# LINE 155 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- HappyState data type (not arrays)\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "newtype HappyState b c = HappyState\n" ++ + " (Int -> -- token number\n" ++ + " Int -> -- token number (yes, again)\n" ++ + " b -> -- token semantic value\n" ++ + " HappyState b c -> -- current state\n" ++ + " [HappyState b c] -> -- state stack\n" ++ + " c)\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Shifting a token\n" ++ + "\n" ++ + "happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =\n" ++ + " let i = (case x of { HappyErrorToken (i) -> i }) in\n" ++ + "-- trace \"shifting the error token\" $\n" ++ + " new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)\n" ++ + "\n" ++ + "happyShift new_state i tk st sts stk =\n" ++ + " happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)\n" ++ + "\n" ++ + "-- happyReduce is specialised for the common cases.\n" ++ + "\n" ++ + "happySpecReduce_0 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk\n" ++ + " = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)\n" ++ + "\n" ++ + "happySpecReduce_1 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')\n" ++ + " = let r = fn v1 in\n" ++ + " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ + "\n" ++ + "happySpecReduce_2 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')\n" ++ + " = let r = fn v1 v2 in\n" ++ + " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ + "\n" ++ + "happySpecReduce_3 i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')\n" ++ + " = let r = fn v1 v2 v3 in\n" ++ + " happySeq r (action nt j tk st sts (r `HappyStk` stk'))\n" ++ + "\n" ++ + "happyReduce k i fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happyReduce k nt fn j tk st sts stk\n" ++ + " = case happyDrop (k - ((1) :: Int)) sts of\n" ++ + "\t sts1@(((st1@(HappyState (action))):(_))) ->\n" ++ + " \tlet r = fn stk in -- it doesn't hurt to always seq here...\n" ++ + " \t\thappyDoSeq r (action nt j tk st1 sts1 r)\n" ++ + "\n" ++ + "happyMonadReduce k nt fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happyMonadReduce k nt fn j tk st sts stk =\n" ++ + " happyThen1 (fn stk tk) (\\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))\n" ++ + " where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))\n" ++ + " drop_stk = happyDropStk k stk\n" ++ + "\n" ++ + "happyMonad2Reduce k nt fn (1) tk st sts stk\n" ++ + " = happyFail (1) tk st sts stk\n" ++ + "happyMonad2Reduce k nt fn j tk st sts stk =\n" ++ + " happyThen1 (fn stk tk) (\\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))\n" ++ + " where sts1@(((st1@(HappyState (action))):(_))) = happyDrop k ((st):(sts))\n" ++ + " drop_stk = happyDropStk k stk\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + " new_state = action\n" ++ + "\n" ++ + "\n" ++ + "happyDrop (0) l = l\n" ++ + "happyDrop n ((_):(t)) = happyDrop (n - ((1) :: Int)) t\n" ++ + "\n" ++ + "happyDropStk (0) l = l\n" ++ + "happyDropStk n (x `HappyStk` xs) = happyDropStk (n - ((1)::Int)) xs\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Moving to a new state after a reduction\n" ++ + "\n" ++ + "{-# LINE 253 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "happyGoto action j tk st = action j j tk (HappyState action)\n" ++ + "\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Error recovery ((1) is the error token)\n" ++ + "\n" ++ + "-- parse error if we are in recovery and we fail again\n" ++ + "happyFail (1) tk old_st _ stk =\n" ++ + "--\ttrace \"failing\" $ \n" ++ + " \thappyError_ tk\n" ++ + "\n" ++ + "{- We don't need state discarding for our restricted implementation of\n" ++ + " \"error\". In fact, it can cause some bogus parses, so I've disabled it\n" ++ + " for now --SDM\n" ++ + "\n" ++ + "-- discard a state\n" ++ + "happyFail (1) tk old_st (((HappyState (action))):(sts)) \n" ++ + "\t\t\t\t\t\t(saved_tok `HappyStk` _ `HappyStk` stk) =\n" ++ + "--\ttrace (\"discarding state, depth \" ++ show (length stk)) $\n" ++ + "\taction (1) (1) tk (HappyState (action)) sts ((saved_tok`HappyStk`stk))\n" ++ + "-}\n" ++ + "\n" ++ + "-- Enter error recovery: generate an error token,\n" ++ + "-- save the old token and carry on.\n" ++ + "happyFail i tk (HappyState (action)) sts stk =\n" ++ + "-- trace \"entering error recovery\" $\n" ++ + "\taction (1) (1) tk (HappyState (action)) sts ( (HappyErrorToken (i)) `HappyStk` stk)\n" ++ + "\n" ++ + "-- Internal happy errors:\\n" ++ + "\n" ++ + "notHappyAtAll = error \"Internal Happy error\\n\"" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Hack to get the typechecker to accept our action functions\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Seq-ing. If the --strict flag is given, then Happy emits \n" ++ + "--\thappySeq = happyDoSeq\n" ++ + "-- otherwise it emits\n" ++ + "-- \thappySeq = happyDontSeq\n" ++ + "\n" ++ + "happyDoSeq, happyDontSeq :: a -> b -> b\n" ++ + "happyDoSeq a b = a `seq` b\n" ++ + "happyDontSeq a b = b\n" ++ + "\n" ++ + "-----------------------------------------------------------------------------\n" ++ + "-- Don't inline any functions from the template. GHC has a nasty habit\n" ++ + "-- of deciding to inline happyGoto everywhere, which increases the size of\n" ++ + "-- the generated parser quite a bit.\n" ++ + "\n" ++ + "{-# LINE 317 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ + "{-# NOINLINE happyShift #-}\n" ++ + "{-# NOINLINE happySpecReduce_0 #-}\n" ++ + "{-# NOINLINE happySpecReduce_1 #-}\n" ++ + "{-# NOINLINE happySpecReduce_2 #-}\n" ++ + "{-# NOINLINE happySpecReduce_3 #-}\n" ++ + "{-# NOINLINE happyReduce #-}\n" ++ + "{-# NOINLINE happyMonadReduce #-}\n" ++ + "{-# NOINLINE happyGoto #-}\n" ++ + "{-# NOINLINE happyFail #-}\n" ++ + "\n" ++ + "-- end of Happy Template."