happy-meta 0.2.0.3 → 0.2.0.4
raw patch · 23 files changed
+5792/−5788 lines, 23 filesdep ~haskell-src-metadep ~template-haskellsetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: haskell-src-meta, template-haskell
API changes (from Hackage documentation)
Files
- LICENSE +30/−30
- Setup.hs +2/−2
- dist/build/AttrGrammarParser.hs +6/−4
- dist/build/Parser.hs +6/−4
- happy-meta.cabal +4/−4
- src/AbsSyn.lhs +175/−175
- src/AttrGrammar.lhs +136/−136
- src/AttrGrammarParser.ly +82/−82
- src/First.lhs +88/−88
- src/GenUtils.lhs +288/−288
- src/Grammar.lhs +779/−779
- src/LALR.lhs +909/−909
- src/Lexer.lhs +302/−302
- src/NameSet.hs +10/−10
- src/ParamRules.hs +92/−92
- src/ParseMonad.lhs +31/−31
- src/Parser.ly +177/−177
- src/ProduceCode.lhs +1306/−1306
- src/ProduceGLRCode.lhs +898/−898
- src/Target.lhs +21/−21
- src/Text/Happy.hs +171/−171
- src/Text/Happy/HappyTemplate.hs +206/−206
- src/Text/Happy/Quote.hs +73/−73
LICENSE view
@@ -1,30 +1,30 @@-Copyright (c)2010, Jonas Duregard, Andy Gill, Simon Marlow - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Jonas Duregard nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright (c)2010, Jonas Duregard, Andy Gill, Simon Marlow++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jonas Duregard nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
dist/build/AttrGrammarParser.hs view
@@ -7,7 +7,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.6 +-- parser produced by Happy Version 1.18.9 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -318,7 +318,8 @@ _ -> happyError' tk }) -happyError_ tk = happyError' tk +happyError_ 10# tk = happyError' tk +happyError_ _ tk = happyError' tk happyThen :: () => P a -> (a -> P b) -> P b happyThen = (>>=) @@ -525,9 +526,10 @@ -- Error recovery (0# is the error token) -- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "failing" $ - happyError_ tk + happyError_ i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it
dist/build/Parser.hs view
@@ -8,7 +8,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.6 +-- parser produced by Happy Version 1.18.9 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -705,7 +705,8 @@ _ -> happyError' tk }) -happyError_ tk = happyError' tk +happyError_ 27# tk = happyError' tk +happyError_ _ tk = happyError' tk happyThen :: () => P a -> (a -> P b) -> P b happyThen = (>>=) @@ -912,9 +913,10 @@ -- Error recovery (0# is the error token) -- parse error if we are in recovery and we fail again -happyFail 0# tk old_st _ stk = +happyFail 0# tk old_st _ stk@(x `HappyStk` _) = + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "failing" $ - happyError_ tk + happyError_ i tk {- We don't need state discarding for our restricted implementation of "error". In fact, it can cause some bogus parses, so I've disabled it
happy-meta.cabal view
@@ -1,5 +1,5 @@ Name: happy-meta -Version: 0.2.0.3 +Version: 0.2.0.4 Synopsis: Quasi-quoter for Happy parsers -- Description: License: BSD3 @@ -20,8 +20,8 @@ Text.Happy.Quote Build-depends: - template-haskell >=2.4&&<2.7 - , haskell-src-meta >=0.3&&<1.0 + template-haskell >=2.4&&<2.8 + , haskell-src-meta >=0.5.1.2&&<1.0 , base >= 4.2 && < 5 , array, containers , mtl >= 1.0 @@ -45,4 +45,4 @@ AttrGrammar AttrGrammarParser ParamRules - +
src/AbsSyn.lhs view
@@ -1,175 +1,175 @@- - - - - - - - - - - - - - - - -> 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" +++++++++++++++++> 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,136 +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) - - - - - - - - - - - - - - --- 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 +> 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,82 +1,82 @@- - - - - - - - - - - - -> { -> {-# 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,88 +1,88 @@- - - - - - - - - - - - -> 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 +++++++++++++> 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,288 +1,288 @@- - - - - - - - - - - - -> 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 ')' - - - +++++++++++++> 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,779 +1,779 @@- - - - - - - - - - - - - - - - -> 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) +++++++++++++++++> 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,909 +1,909 @@- - - - - - - - - - - - - - -> 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 +++++++++++++++> 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,302 +1,302 @@- - - - - - - - - - - - -> 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 +++++++++++++> 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, Eq 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,31 +1,31 @@- - - - - - - - - - - - -> 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,177 +1,177 @@- - - - - - - - - - - - - - - - -> { -> {-# 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,1306 +1,1306 @@- - - - - - - - - - - - -> 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') +++++++++++++> 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,898 +1,898 @@- - - - - - - - - - - - - - - - - - -> 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 - - - +++++++++++++++++++> 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,21 +1,21 @@- - - - - - - - - - - - -> 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."
src/Text/Happy/Quote.hs view
@@ -1,73 +1,73 @@-{-#OPTIONS_GHC -fno-warn-missing-fields#-} -module Text.Happy.Quote ( - parseHappy - , parseHappyInfo - , compileHappy - , happy - , HappyStk(..) - , HappyInfo - , happyWarn - ) where - -import Text.Happy(runHappy, HappyInfo(..)) -import Text.Happy.HappyTemplate - -import Language.Haskell.TH.Quote -import Language.Haskell.TH - -import Language.Haskell.Meta - -import Control.Monad(when) -import System.IO(hPutStrLn,stderr) - --- Runtime (The infixr declaration can not be spliced by TH) -data HappyStk a = HappyStk a (HappyStk a) -infixr 9 `HappyStk` - - -type Happy = String - -compileHappy :: Happy -> Q [Dec] -compileHappy = return . either error id . parseDecs - -happy :: QuasiQuoter -happy = QuasiQuoter {quoteExp = happyToExp . parseHappyInfo} -- (error "happy: pattern quoting is not supported") - - -parseHappy :: String -> Happy -parseHappy = fst . parseHappyInfo - -parseHappyInfo :: String -> (Happy,HappyInfo) -parseHappyInfo s = (subst old "" $ code ++ "\n" ++ happyTemplate, info) - where - (code,info) = either error id $ runHappy [] s - old = unlines ["infixr 9 `HappyStk`", - "data HappyStk a = HappyStk a (HappyStk a)"] - -happyWarn :: HappyInfo -> Q () -happyWarn i = do - loc <- location - let warnMsg msg = do - let (row,col) = loc_start loc - (file) = loc_filename loc - runIO $ hPutStrLn stderr $ file ++ ":"++show row++":"++show col++":" - runIO $ hPutStrLn stderr $ " " ++ msg - when (sr i > 0) $ warnMsg $ "Warning: "++show (sr i)++"shift/reduce conflicts" - when (rr i > 0) $ warnMsg $ "Warning: "++show (rr i)++ "reduce/reduce conflicts" - - -happyToExp (code,info) = happyWarn info >> litE (StringL code) - --- optIO (not (null unused_rules)) --- (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) >> --- optIO (not (null unused_terminals)) --- (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) >> - - --- This is some really bad code but it works for this purpose. -subst _ _ [ ] = [] -subst from to xs@(a:as) = - if isPrefixOf from xs - then to ++ drop (length from) xs - else a : subst from to as - where isPrefixOf as bs = and $ zipWith (==) as bs +{-#OPTIONS_GHC -fno-warn-missing-fields#-}+module Text.Happy.Quote (+ parseHappy+ , parseHappyInfo+ , compileHappy+ , happy+ , HappyStk(..)+ , HappyInfo+ , happyWarn+ ) where++import Text.Happy(runHappy, HappyInfo(..))+import Text.Happy.HappyTemplate++import Language.Haskell.TH.Quote+import Language.Haskell.TH++import Language.Haskell.Meta++import Control.Monad(when)+import System.IO(hPutStrLn,stderr)++-- Runtime (The infixr declaration can not be spliced by TH)+data HappyStk a = HappyStk a (HappyStk a)+infixr 9 `HappyStk`+++type Happy = String++compileHappy :: Happy -> Q [Dec]+compileHappy = return . either error id . parseDecs++happy :: QuasiQuoter+happy = QuasiQuoter {quoteExp = happyToExp . parseHappyInfo} -- (error "happy: pattern quoting is not supported") +++parseHappy :: String -> Happy+parseHappy = fst . parseHappyInfo++parseHappyInfo :: String -> (Happy,HappyInfo)+parseHappyInfo s = (subst old "" $ code ++ "\n" ++ happyTemplate, info)+ where+ (code,info) = either error id $ runHappy [] s+ old = unlines ["infixr 9 `HappyStk`",+ "data HappyStk a = HappyStk a (HappyStk a)"]++happyWarn :: HappyInfo -> Q ()+happyWarn i = do+ loc <- location+ let warnMsg msg = do+ let (row,col) = loc_start loc+ (file) = loc_filename loc+ runIO $ hPutStrLn stderr $ file ++ ":"++show row++":"++show col++":"+ runIO $ hPutStrLn stderr $ " " ++ msg+ when (sr i > 0) $ warnMsg $ "Warning: "++show (sr i)++"shift/reduce conflicts"+ when (rr i > 0) $ warnMsg $ "Warning: "++show (rr i)++ "reduce/reduce conflicts"+++happyToExp (code,info) = happyWarn info >> litE (StringL code)++-- optIO (not (null unused_rules))+-- (hPutStrLn stderr ("unused rules: " ++ show (length unused_rules))) >>+-- optIO (not (null unused_terminals))+-- (hPutStrLn stderr ("unused terminals: " ++ show (length unused_terminals))) >>+++-- This is some really bad code but it works for this purpose.+subst _ _ [ ] = []+subst from to xs@(a:as) =+ if isPrefixOf from xs+ then to ++ drop (length from) xs+ else a : subst from to as+ where isPrefixOf as bs = and $ zipWith (==) as bs