diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/dist/build/AttrGrammarParser.hs b/dist/build/AttrGrammarParser.hs --- a/dist/build/AttrGrammarParser.hs +++ b/dist/build/AttrGrammarParser.hs @@ -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 diff --git a/dist/build/Parser.hs b/dist/build/Parser.hs --- a/dist/build/Parser.hs +++ b/dist/build/Parser.hs @@ -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 diff --git a/happy-meta.cabal b/happy-meta.cabal --- a/happy-meta.cabal +++ b/happy-meta.cabal @@ -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 - + diff --git a/src/AbsSyn.lhs b/src/AbsSyn.lhs --- a/src/AbsSyn.lhs +++ b/src/AbsSyn.lhs @@ -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" diff --git a/src/AttrGrammar.lhs b/src/AttrGrammar.lhs --- a/src/AttrGrammar.lhs +++ b/src/AttrGrammar.lhs @@ -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 diff --git a/src/AttrGrammarParser.ly b/src/AttrGrammarParser.ly --- a/src/AttrGrammarParser.ly +++ b/src/AttrGrammarParser.ly @@ -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") +> } diff --git a/src/First.lhs b/src/First.lhs --- a/src/First.lhs +++ b/src/First.lhs @@ -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 diff --git a/src/GenUtils.lhs b/src/GenUtils.lhs --- a/src/GenUtils.lhs +++ b/src/GenUtils.lhs @@ -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 ')' + + + diff --git a/src/Grammar.lhs b/src/Grammar.lhs --- a/src/Grammar.lhs +++ b/src/Grammar.lhs @@ -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) diff --git a/src/LALR.lhs b/src/LALR.lhs --- a/src/LALR.lhs +++ b/src/LALR.lhs @@ -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 diff --git a/src/Lexer.lhs b/src/Lexer.lhs --- a/src/Lexer.lhs +++ b/src/Lexer.lhs @@ -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 diff --git a/src/NameSet.hs b/src/NameSet.hs --- a/src/NameSet.hs +++ b/src/NameSet.hs @@ -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 diff --git a/src/ParamRules.hs b/src/ParamRules.hs --- a/src/ParamRules.hs +++ b/src/ParamRules.hs @@ -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) + + + diff --git a/src/ParseMonad.lhs b/src/ParseMonad.lhs --- a/src/ParseMonad.lhs +++ b/src/ParseMonad.lhs @@ -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 diff --git a/src/Parser.ly b/src/Parser.ly --- a/src/Parser.ly +++ b/src/Parser.ly @@ -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") +> } diff --git a/src/ProduceCode.lhs b/src/ProduceCode.lhs --- a/src/ProduceCode.lhs +++ b/src/ProduceCode.lhs @@ -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 :: ti -> HappyAbsSyn ti tj tk ... - happyIn x = unsafeCoerce# x - {-# INLINE happyIn #-} - - - happyOut :: HappyAbsSyn ti tj tk ... -> tn - happyOut x = unsafeCoerce# x - {-# INLINE happyOut #-} - - -> | coerce -> = let -> happy_item = str "HappyAbsSyn " . str_tyvars -> bhappy_item = brack' happy_item -> -> inject n ty -> = mkHappyIn n . str " :: " . type_param n ty -> . str " -> " . bhappy_item . char '\n' -> . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" -> . str "{-# INLINE " . mkHappyIn n . str " #-}" -> -> extract n ty -> = mkHappyOut n . str " :: " . bhappy_item -> . str " -> " . type_param n ty . char '\n' -> . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" -> . str "{-# INLINE " . mkHappyOut n . str " #-}" -> in -> str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below -> . interleave "\n" (map str -> [ "#if __GLASGOW_HASKELL__ >= 607", -> "type HappyAny = Happy_GHC_Exts.Any", -> "#else", -> "type HappyAny = forall a . a", -> "#endif" ]) -> . interleave "\n" -> [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ] -> -- token injector -> . str "happyInTok :: " . token . str " -> " . bhappy_item -> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n" -> -- token extractor -> . str "happyOutTok :: " . bhappy_item . str " -> " . token -> . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n" - - -> . str "\n" - - - - - - - - - - - - - - - - - - - - --> ()) as the type here, but this led to bogus optimisations (see GHC -ticket #1616). - - - - - - - - - - - - - - - - -> | otherwise -> = str "data HappyAbsSyn " . str_tyvars -> . str "\n\t= HappyTerminal " . token -> . str "\n\t| HappyErrorToken Int\n" -> . interleave "\n" -> [ str "\t| " . makeAbsSynCon n . strspace . type_param n ty -> | (n, ty) <- assocs nt_types, -> (nt_types_index ! n) == n] - - -> where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ] -> str_tyvars = str (unwords all_tyvars) - - - - - - - - -> produceTypes -> | target == TargetArrayBased = id - - -> | all isJust (elems nt_types) = -> happyReductionDefinition . str "\n\n" -> . interleave' ",\n " -> [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ] -> (assocs action) ] -> . str " :: " . str monad_context . str " => " -> . intMaybeHash . str " -> " . happyReductionValue . str "\n\n" -> . interleave' ",\n " -> [ mkReduceFun i | -> (i,_action) <- zip [ n_starts :: Int .. ] -> (drop n_starts prods) ] -> . str " :: " . str monad_context . str " => " -> . happyReductionValue . str "\n\n" - - -> | otherwise = id - - -> where intMaybeHash | ghc = str "Happy_GHC_Exts.Int#" -> | otherwise = str "Int" -> tokens = -> case lexer' of -> Nothing -> char '[' . token . str "] -> " -> Just _ -> id -> happyReductionDefinition = -> str "{- to allow type-synonyms as our monads (likely\n" -> . str " - with explicitly-specified bind and return)\n" -> . str " - in Haskell98, it seems that with\n" -> . str " - /type M a = .../, then /(HappyReduction M)/\n" -> . str " - is not allowed. But Happy is a\n" -> . str " - code-generator that can just substitute it.\n" -> . str "type HappyReduction m = " -> . happyReduction (str "m") -> . str "\n-}" -> happyReductionValue = -> str "({-" -> . str "HappyReduction " -> . brack monad_tycon -> . str " = -}" -> . happyReduction (brack monad_tycon) -> . str ")" -> happyReduction m = -> str "\n\t " -> . intMaybeHash -> . str " \n\t-> " . token -> . str "\n\t-> HappyState " -> . token -> . str " (HappyStk HappyAbsSyn -> " . tokens . result -> . str ")\n\t" -> . str "-> [HappyState " -> . token -> . str " (HappyStk HappyAbsSyn -> " . tokens . result -> . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> " -> . tokens -> . result -> where result = m . str " HappyAbsSyn" - - - - - - - - - - - - - - - - - - - - - - - ( <> ) : happyRest - - - - - - - - - - - - - happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275 - - - = happyThen (code) (\r -> happyReturn (HappyAbsSyn r)) - - - - - - - - - - - - - - - - -> produceReductions = -> interleave "\n\n" -> (zipWith produceReduction (drop n_starts prods) [ n_starts .. ]) - - -> produceReduction (nt, toks, (code,vars_used), _) i - - -> | is_monad_prod && (use_monad || imported_identity') -> = mkReductionHdr (showInt lt) monad_reduce -> . char '(' . interleave " `HappyStk`\n\t" tokPatterns -> . str "happyRest) tk\n\t = happyThen (" -> . tokLets (char '(' . str code' . char ')') -> . (if monad_pass_token then str " tk" else id) -> . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))" - - -> | specReduceFun lt -> = mkReductionHdr id ("happySpecReduce_" ++ show lt) -> . interleave "\n\t" tokPatterns -> . str " = " -> . tokLets ( -> this_absSynCon . str "\n\t\t " -> . char '(' . str code' . str "\n\t)" -> ) -> . (if coerce || null toks || null vars_used then -> id -> else -> nl . reductionFun . strspace -> . interleave " " (map str (take (length toks) (repeat "_"))) -> . str " = notHappyAtAll ") - - -> | otherwise -> = mkReductionHdr (showInt lt) "happyReduce" -> . char '(' . interleave " `HappyStk`\n\t" tokPatterns -> . str "happyRest)\n\t = " -> . tokLets -> ( this_absSynCon . str "\n\t\t " -> . char '(' . str code'. str "\n\t) `HappyStk` happyRest" -> ) - - -> where -> (code', is_monad_prod, monad_pass_token, monad_reduce) -> = case code of -> '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce") -> '%':'^':code1 -> (code1, True, True, "happyMonadReduce") -> '%':code1 -> (code1, True, False, "happyMonadReduce") -> _ -> (code, False, False, "") - - -> -- adjust the nonterminal number for the array-based parser -> -- so that nonterminals start at zero. -> adjusted_nt | target == TargetArrayBased = nt - first_nonterm' -> | otherwise = nt -> -> mkReductionHdr lt' s = -> mkReduceFun i . str " = " -> . str s . strspace . lt' . strspace . showInt adjusted_nt -> . strspace . reductionFun . nl -> . reductionFun . strspace -> -> reductionFun = str "happyReduction_" . shows i -> -> tokPatterns -> | coerce = reverse (map mkDummyVar [1 .. length toks]) -> | otherwise = reverse (zipWith tokPattern [1..] toks) -> -> tokPattern n _ | n `notElem` vars_used = char '_' -> tokPattern n t | t >= firstStartTok && t < fst_term -> = if coerce -> then mkHappyVar n -> else brack' ( -> makeAbsSynCon t . str " " . mkHappyVar n -> ) -> tokPattern n t -> = if coerce -> then mkHappyTerminalVar n t -> else str "(HappyTerminal " -> . mkHappyTerminalVar n t -> . char ')' -> -> tokLets code'' -> | coerce && not (null cases) -> = interleave "\n\t" cases -> . code'' . str (take (length cases) (repeat '}')) -> | otherwise = code'' -> -> cases = [ str "case " . extract t . strspace . mkDummyVar n -> . str " of { " . tokPattern n t . str " -> " -> | (n,t) <- zip [1..] toks, -> n `elem` vars_used ] -> -> extract t | t >= firstStartTok && t < fst_term = mkHappyOut t -> | otherwise = str "happyOutTok" -> -> lt = length toks - - -> this_absSynCon | coerce = mkHappyIn nt -> | otherwise = makeAbsSynCon nt - - - - - - - - -> produceTokenConverter -> = case lexer' of { -> -> Nothing -> -> str "happyNewToken action sts stk [] =\n\t" -> . eofAction "notHappyAtAll" -> . str " []\n\n" -> . str "happyNewToken action sts stk (tk:tks) =\n\t" -> . str "let cont i = " . doAction . str " sts stk tks in\n\t" -> . str "case tk of {\n\t" -> . interleave ";\n\t" (map doToken token_rep) -> . str "_ -> happyError' (tk:tks)\n\t" -> . str "}\n\n" -> . str "happyError_ tk tks = happyError' (tk:tks)\n"; - - -> Just (lexer'',eof') -> -> str "happyNewToken action sts stk\n\t= " -> . str lexer'' -> . str "(\\tk -> " -> . str "\n\tlet cont i = " -> . doAction -> . str " sts stk in\n\t" -> . str "case tk of {\n\t" -> . str (eof' ++ " -> ") -> . eofAction "tk" . str ";\n\t" -> . interleave ";\n\t" (map doToken token_rep) -> . str "_ -> happyError' tk\n\t" -> . str "})\n\n" -> . str "happyError_ tk = happyError' tk\n"; -> } - - -> where - - -> eofAction tk = -> (case target of -> TargetArrayBased -> -> str "happyDoAction " . eofTok . strspace . str tk . str " action" -> _ -> str "action " . eofTok . strspace . eofTok -> . strspace . str tk . str " (HappyState action)") -> . str " sts stk" -> eofTok = showInt (tokIndex eof) -> -> doAction = case target of -> TargetArrayBased -> str "happyDoAction i tk action" -> _ -> str "action i i tk (HappyState action)" -> -> doToken (i,tok) -> = str (removeDollarDollar tok) -> . str " -> cont " -> . showInt (tokIndex i) - - - - - - - - -> removeDollarDollar xs = case mapDollarDollar xs of -> Nothing -> xs -> Just fn -> fn "happy_dollar_dollar" - - -> mkHappyTerminalVar :: Int -> Int -> String -> String -> mkHappyTerminalVar i t = -> case tok_str_fn of -> Nothing -> pat -> Just fn -> brack (fn (pat [])) -> where -> tok_str_fn = case lookup t token_rep of -> Nothing -> Nothing -> Just str' -> mapDollarDollar str' -> pat = mkHappyVar i - - -> tokIndex -> = case target of -> TargetHaskell -> id -> TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2 -> -- tokens adjusted to start at zero, see ARRAY_NOTES - - - - - - - - -> produceActionTable TargetHaskell -> = foldr (.) id (map (produceStateFunction goto) (assocs action)) -> -> produceActionTable TargetArrayBased -> = produceActionArray -> . produceReduceArray -> . str "happy_n_terms = " . shows n_terminals . str " :: Int\n" -> . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n" - - -> produceStateFunction goto' (state, acts) -> = foldr (.) id (map produceActions assocs_acts) -> . foldr (.) id (map produceGotos (assocs gotos)) -> . mkActionName state -> . (if ghc -> then str " x = happyTcHack x " -> else str " _ = ") -> . mkAction default_act -> . str "\n\n" -> -> where gotos = goto' ! state -> -> produceActions (_, LR'Fail{-'-}) = id -> produceActions (t, action'@(LR'Reduce{-'-} _ _)) -> | action' == default_act = id -> | otherwise = actionFunction t -> . mkAction action' . str "\n" -> produceActions (t, action') -> = actionFunction t -> . mkAction action' . str "\n" -> -> produceGotos (t, Goto i) -> = actionFunction t -> . str "happyGoto " . mkActionName i . str "\n" -> produceGotos (_, NoGoto) = id -> -> actionFunction t -> = mkActionName state . strspace -> . ('(' :) . showInt t -> . str ") = " -> -> default_act = getDefault assocs_acts -> -> assocs_acts = assocs acts - - - - -> produceActionArray -> | ghc -> = str "happyActOffsets :: HappyAddr\n" -> . str "happyActOffsets = HappyA# \"" --" -> . str (hexChars act_offs) -> . str "\"#\n\n" --" -> -> . str "happyGotoOffsets :: HappyAddr\n" -> . str "happyGotoOffsets = HappyA# \"" --" -> . str (hexChars goto_offs) -> . str "\"#\n\n" --" -> -> . str "happyDefActions :: HappyAddr\n" -> . str "happyDefActions = HappyA# \"" --" -> . str (hexChars defaults) -> . str "\"#\n\n" --" -> -> . str "happyCheck :: HappyAddr\n" -> . str "happyCheck = HappyA# \"" --" -> . str (hexChars check) -> . str "\"#\n\n" --" -> -> . str "happyTable :: HappyAddr\n" -> . str "happyTable = HappyA# \"" --" -> . str (hexChars table) -> . str "\"#\n\n" --" - - -> | otherwise -> = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n" -> . str "happyActOffsets = Happy_Data_Array.listArray (0," -> . shows (n_states) . str ") ([" -> . interleave' "," (map shows act_offs) -> . str "\n\t])\n\n" -> -> . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n" -> . str "happyGotoOffsets = Happy_Data_Array.listArray (0," -> . shows (n_states) . str ") ([" -> . interleave' "," (map shows goto_offs) -> . str "\n\t])\n\n" -> -> . str "happyDefActions :: Happy_Data_Array.Array Int Int\n" -> . str "happyDefActions = Happy_Data_Array.listArray (0," -> . shows (n_states) . str ") ([" -> . interleave' "," (map shows defaults) -> . str "\n\t])\n\n" -> -> . str "happyCheck :: Happy_Data_Array.Array Int Int\n" -> . str "happyCheck = Happy_Data_Array.listArray (0," -> . shows table_size . str ") ([" -> . interleave' "," (map shows check) -> . str "\n\t])\n\n" -> -> . str "happyTable :: Happy_Data_Array.Array Int Int\n" -> . str "happyTable = Happy_Data_Array.listArray (0," -> . shows table_size . str ") ([" -> . interleave' "," (map shows table) -> . str "\n\t])\n\n" -> -> (_, last_state) = bounds action -> n_states = last_state + 1 -> n_terminals = length terms -> n_nonterminals = length nonterms - n_starts -- lose %starts -> -> (act_offs,goto_offs,table,defaults,check) -> = mkTables action goto first_nonterm' fst_term -> n_terminals n_nonterminals n_starts -> -> table_size = length table - 1 -> -> produceReduceArray -> = {- str "happyReduceArr :: Array Int a\n" -} -> str "happyReduceArr = Happy_Data_Array.array (" -> . shows (n_starts :: Int) -- omit the %start reductions -> . str ", " -> . shows n_rules -> . str ") [\n" -> . interleave' ",\n" (map reduceArrElem [n_starts..n_rules]) -> . str "\n\t]\n\n" - - -> n_rules = length prods - 1 :: Int - - -> showInt i | ghc = shows i . showChar '#' -> | otherwise = shows i - - - - - - -> nt_types_index :: Array Int Int -> nt_types_index = array (bounds nt_types) -> [ (a, fn a b) | (a, b) <- assocs nt_types ] -> where -> fn n Nothing = n -> fn _ (Just a) = case lookup a assoc_list of -> Just v -> v -> Nothing -> error ("cant find an item in list") -> assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ] - - -> makeAbsSynCon = mkAbsSynCon nt_types_index - - - - -> produceIdentityStuff | use_monad = id -> | imported_identity' = -> str "type HappyIdentity = Identity\n" -> . str "happyIdentity = Identity\n" -> . str "happyRunIdentity = runIdentity\n\n" -> | otherwise = -> str "newtype HappyIdentity a = HappyIdentity a\n" -> . str "happyIdentity = HappyIdentity\n" -> . str "happyRunIdentity (HappyIdentity a) = a\n\n" -> . str "instance Monad HappyIdentity where\n" -> . str " return = HappyIdentity\n" -> . str " (HappyIdentity p) >>= q = q p\n\n" - - - - - - - - - - - happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b - happyReturn :: () => a -> HappyIdentity a - happyThen1 m k tks = happyThen m (\a -> k a tks) - happyReturn1 = \a tks -> happyReturn a - - - - - - - happyThen :: CONTEXT => P a -> (a -> P b) -> P b - happyReturn :: CONTEXT => a -> P a - happyThen1 m k tks = happyThen m (\a -> k a tks) - happyReturn1 = \a tks -> happyReturn a - - - - - - - happyThen :: CONTEXT => P a -> (a -> P b) -> P b - happyReturn :: CONTEXT => a -> P a - - - - - - - - -> produceMonadStuff = -> let pcont = str monad_context in -> let pty = str monad_tycon in -> str "happyThen :: " . pcont . str " => " . pty -> . str " a -> (a -> " . pty -> . str " b) -> " . pty . str " b\n" -> . str "happyThen = " . brack monad_then . nl -> . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n" -> . str "happyReturn = " . brack monad_return . nl -> . case lexer' of -> Nothing -> -> str "happyThen1 m k tks = (" . str monad_then -> . str ") m (\\a -> k a tks)\n" -> . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n" -> . str "happyReturn1 = \\a tks -> " . brack monad_return -> . str " a\n" -> . str "happyError' :: " . str monad_context . str " => [" -> . token -> . str "] -> " -> . str monad_tycon -> . str " a\n" -> . str "happyError' = " -> . str (if use_monad then "" else "HappyIdentity . ") -> . errorHandler -> . str "\n\n" -> _ -> -> str "happyThen1 = happyThen\n" -> . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n" -> . str "happyReturn1 = happyReturn\n" -> . str "happyError' :: " . str monad_context . str " => " -> . token . str " -> " -> . str monad_tycon -> . str " a\n" -> . str "happyError' tk = " -> . str (if use_monad then "" else "HappyIdentity ") -> . errorHandler . str " tk\n" -> . str "\n" - - - - - - - - - - -> errorHandler = -> case error_handler' of -> Just h -> str h -> Nothing -> case lexer' of -> Nothing -> str "happyError" -> Just _ -> str "(\\token -> happyError)" - - -> reduceArrElem n -> = str "\t(" . shows n . str " , " -> . str "happyReduce_" . shows n . char ')' - - - - - - - - -> produceEntries -> = interleave "\n\n" (map produceEntry (zip starts' [0..])) -> . if null attributes' then id else produceAttrEntries starts' - - -> produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no) -> = (if null attributes' then str name else str "do_" . str name) -> . maybe_tks -> . str " = " -> . str unmonad -> . str "happySomeParser where\n" -> . str " happySomeParser = happyThen (happyParse " -> . case target of -> TargetHaskell -> str "action_" . shows no -> TargetArrayBased -> | ghc -> shows no . str "#" -> | otherwise -> shows no -> . maybe_tks -> . str ") " -> . brack' (if coerce -> then str "\\x -> happyReturn (happyOut" -> . shows accept_nonterm . str " x)" -> else str "\\x -> case x of {HappyAbsSyn" -> . shows (nt_types_index ! accept_nonterm) -> . str " z -> happyReturn z; _other -> notHappyAtAll }" -> ) -> where -> maybe_tks | isNothing lexer' = str " tks" -> | otherwise = id -> unmonad | use_monad = "" -> | otherwise = "happyRunIdentity " - - -> produceAttrEntries starts'' -> = interleave "\n\n" (map f starts'') -> where -> f = case (use_monad,lexer') of -> (True,Just _) -> \(name,_,_,_) -> monadAndLexerAE name -> (True,Nothing) -> \(name,_,_,_) -> monadAE name -> (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer" -> (False,Nothing)-> \(name,_,_,_) -> regularAE name -> -> defaultAttr = fst (head attributes') -> -> monadAndLexerAE name -> = str name . str " = " -> . str "do { " -> . str "f <- do_" . str name . str "; " -> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " -> . str "sequence_ conds; " -> . str "return (". str defaultAttr . str " attrs) }}" -> monadAE name -> = str name . str " toks = " -> . str "do { " -> . str "f <- do_" . str name . str " toks; " -> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " -> . str "sequence_ conds; " -> . str "return (". str defaultAttr . str " attrs) }}" -> regularAE name -> = str name . str " toks = " -> . str "let { " -> . str "f = do_" . str name . str " toks; " -> . str "(conds,attrs) = f happyEmptyAttrs; " -> . str "x = foldr seq attrs conds; " -> . str "} in (". str defaultAttr . str " x)" - - - - - - - - -> produceAttributes :: [(String, String)] -> String -> String -> String -> produceAttributes [] _ = id -> produceAttributes attrs attributeType -> = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl -> . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl - - -> where attributes' = foldl1 (\x y -> x . str ", " . y) $ map formatAttribute attrs -> formatAttribute (ident,typ) = str ident . str " :: " . str typ -> attrsErrors = foldl1 (\x y -> x . str ", " . y) $ map attrError attrs -> attrError (ident,_) = str ident . str " = error \"invalid reference to attribute '" . str ident . str "'\"" -> attrHeader = -> case attributeType of -> [] -> str "HappyAttributes" -> _ -> str attributeType - - - - - - - - - - -> produceStrict :: Bool -> String -> String -> produceStrict strict -> | strict = str "happySeq = happyDoSeq\n\n" -> | otherwise = str "happySeq = happyDontSeq\n\n" - - - - - - - - - - -> actionVal :: LRAction -> Int -> actionVal (LR'Shift state _) = state + 1 -> actionVal (LR'Reduce rule _) = -(rule + 1) -> actionVal LR'Accept = -1 -> actionVal (LR'Multiple _ a) = actionVal a -> actionVal LR'Fail = 0 -> actionVal LR'MustFail = 0 - - -> mkAction :: LRAction -> String -> String -> mkAction (LR'Shift i _) = str "happyShift " . mkActionName i -> mkAction LR'Accept = str "happyAccept" -> mkAction LR'Fail = str "happyFail" -> mkAction LR'MustFail = str "happyFail" -> mkAction (LR'Reduce i _) = str "happyReduce_" . shows i -> mkAction (LR'Multiple _ a) = mkAction a - - -> mkActionName :: Int -> String -> String -> mkActionName i = str "action_" . shows i - - - - - - -> getDefault :: [(Name, LRAction)] -> LRAction -> getDefault actions = -> -- pick out the action for the error token, if any -> case [ act | (e, act) <- actions, e == errorTok ] of -> -> -- use error reduction as the default action, if there is one. -> act@(LR'Reduce _ _) : _ -> act -> act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act -> -> -- if the error token is shifted or otherwise, don't generate -> -- a default action. This is *important*! -> (act : _) | act /= LR'Fail -> LR'Fail -> -> -- no error actions, pick a reduce to be the default. -> _ -> case reduces of -> [] -> LR'Fail -> (act:_) -> act -- pick the first one we see for now -> -> where reduces -> = [ act | (_,act@(LR'Reduce _ _)) <- actions ] -> ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ] - - - - - - -> mkTables -> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int -> -> ([Int] -- happyActOffsets -> ,[Int] -- happyGotoOffsets -> ,[Int] -- happyTable -> ,[Int] -- happyDefAction -> ,[Int] -- happyCheck -> ) -> -> mkTables action goto first_nonterm' fst_term -> n_terminals n_nonterminals n_starts -> = ( elems act_offs, -> elems goto_offs, -> take max_off (elems table), -> def_actions, -> take max_off (elems check) -> ) -> where -> -> (table,check,act_offs,goto_offs,max_off) -> = runST (genTables (length actions) max_token sorted_actions) -> -> -- the maximum token number used in the parser -> max_token = max n_terminals (n_starts+n_nonterminals) - 1 -> -> def_actions = map (\(_,_,def,_,_,_) -> def) actions -> -> actions :: [TableEntry] -> actions = -> [ (ActionEntry, -> state, -> actionVal default_act, -> if null acts'' then 0 -> else fst (last acts'') - fst (head acts''), -> length acts'', -> acts'') -> | (state, acts) <- assocs action, -> let (err:_dummy:vec) = assocs acts -> vec' = drop (n_starts+n_nonterminals) vec -> acts' = filter (notFail) (err:vec') -> default_act = getDefault acts' -> acts'' = mkActVals acts' default_act -> ] -> -> -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0). -> -- (see ARRAY_NOTES) -> adjust token | token == errorTok = 0 -> | otherwise = token - fst_term + 1 -> -> mkActVals assocs' default_act = -> [ (adjust token, actionVal act) -> | (token, act) <- assocs' -> , act /= default_act ] -> -> gotos :: [TableEntry] -> gotos = [ (GotoEntry, -> state, 0, -> if null goto_vals then 0 -> else fst (last goto_vals) - fst (head goto_vals), -> length goto_vals, -> goto_vals -> ) -> | (state, goto_arr) <- assocs goto, -> let goto_vals = mkGotoVals (assocs goto_arr) -> ] -> -> -- adjust nonterminals by -first_nonterm', so they start at zero -> -- (see ARRAY_NOTES) -> mkGotoVals assocs' = -> [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ] -> -> sorted_actions = reverse (sortBy cmp_state (actions++gotos)) -> cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_) -> | width1 < width2 = LT -> | width1 == width2 = compare tally1 tally2 -> | otherwise = GT - - -> data ActionOrGoto = ActionEntry | GotoEntry -> type TableEntry = (ActionOrGoto, -> Int{-stateno-}, -> Int{-default-}, -> Int{-width-}, -> Int{-tally-}, -> [(Int,Int)]) - - -> genTables -> :: Int -- number of actions -> -> Int -- maximum token no. -> -> [TableEntry] -- entries for the table -> -> ST s (UArray Int Int, -- table -> UArray Int Int, -- check -> UArray Int Int, -- action offsets -> UArray Int Int, -- goto offsets -> Int -- highest offset in table -> ) -> -> genTables n_actions max_token entries = do -> -> table <- newArray (0, mAX_TABLE_SIZE) 0 -> check <- newArray (0, mAX_TABLE_SIZE) (-1) -> act_offs <- newArray (0, n_actions) 0 -> goto_offs <- newArray (0, n_actions) 0 -> off_arr <- newArray (-max_token, mAX_TABLE_SIZE) 0 -> -> max_off <- genTables' table check act_offs goto_offs -> off_arr entries max_token -> -> table' <- freeze table -> check' <- freeze check -> act_offs' <- freeze act_offs -> goto_offs' <- freeze goto_offs -> return (table',check',act_offs',goto_offs',max_off+1) - - -> where -> n_states = n_actions - 1 -> mAX_TABLE_SIZE = n_states * (max_token + 1) - - - - -> genTables' -> :: STUArray s Int Int -- table -> -> STUArray s Int Int -- check -> -> STUArray s Int Int -- action offsets -> -> STUArray s Int Int -- goto offsets -> -> STUArray s Int Int -- offset array -> -> [TableEntry] -- entries for the table -> -> Int -- maximum token no. -> -> ST s Int -- highest offset in table -> -> genTables' table check act_offs goto_offs off_arr entries max_token -> = fit_all entries 0 1 -> where -> -> fit_all [] max_off _ = return max_off -> fit_all (s:ss) max_off fst_zero = do -> (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero -> ss' <- same_states s ss off -> writeArray off_arr off 1 -> fit_all ss' new_max_off new_fst_zero -> -> -- try to merge identical states. We only try the next state(s) -> -- in the list, but the list is kind-of sorted so we shouldn't -> -- miss too many. -> same_states _ [] _ = return [] -> same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off -> | acts == acts' = do writeArray (which_off e) no off -> same_states s ss' off -> | otherwise = return ss -> -> which_off ActionEntry = act_offs -> which_off GotoEntry = goto_offs -> -> -- fit a vector into the table. Return the offset of the vector, -> -- the maximum offset used in the table, and the offset of the first -> -- entry in the table (used to speed up the lookups a bit). -> fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero) -> -> fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_)) -> max_off fst_zero = do -> -- start at offset 1 in the table: all the empty states -> -- (states with just a default reduction) are mapped to -> -- offset zero. -> off <- findFreeOffset (-t+fst_zero) check off_arr state -> let new_max_off | furthest_right > max_off = furthest_right -> | otherwise = max_off -> furthest_right = off + max_token -> -> -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do -> -> writeArray (which_off act_or_goto) state_no off -> addState off table check state -> new_fst_zero <- findFstFreeSlot check fst_zero -> return (off, new_max_off, new_fst_zero) - - - - - - - - - - - - - - - - - - - - -> -- Find a valid offset in the table for this state. -> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int -> findFreeOffset off table off_arr state = do -> -- offset 0 isn't allowed -> if off == 0 then try_next else do -> -> -- don't use an offset we've used before -> b <- readArray off_arr off -> if b /= 0 then try_next else do -> -> -- check whether the actions for this state fit in the table -> ok <- fits off state table -> if not ok then try_next else return off -> where -> try_next = findFreeOffset (off+1) table off_arr state - - - - -> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool -> fits _ [] _ = return True -> fits off ((t,_):rest) table = do -> i <- readArray table (off+t) -> if i /= -1 then return False -> else fits off rest table - - -> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> -> ST s () -> addState _ _ _ [] = return () -> addState off table check ((t,val):state) = do -> writeArray table (off+t) val -> writeArray check (off+t) t -> addState off table check state - - -> notFail :: (Int, LRAction) -> Bool -> notFail (_, LR'Fail) = False -> notFail _ = True - - -> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int -> findFstFreeSlot table n = do -> i <- readArray table n -> if i == -1 then return n -> else findFstFreeSlot table (n+1) - - - - - - - - -> comment :: String -> comment = -> "-- parser produced by Happy \n\n" - - -> mkAbsSynCon :: Array Int Int -> Int -> String -> String -> mkAbsSynCon fx t = str "HappyAbsSyn" . shows (fx ! t) - - -> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String -> mkHappyVar n = str "happy_var_" . shows n -> mkReduceFun n = str "happyReduce_" . shows n -> mkDummyVar n = str "happy_x_" . shows n - - -> mkHappyIn, mkHappyOut :: Int -> String -> String -> mkHappyIn n = str "happyIn" . shows n -> mkHappyOut n = str "happyOut" . shows n - - -> type_param :: Int -> Maybe String -> ShowS -> type_param n Nothing = char 't' . shows n -> type_param _ (Just ty) = brack ty - - -> specReduceFun :: Int -> Bool -> specReduceFun = (<= 3) - - - - - - - - - - -> hexChars :: [Int] -> String -> hexChars acts = concat (map hexChar acts) - - -> hexChar :: Int -> String -> hexChar i | i < 0 = hexChar (i + 2^16) -> hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256) - - -> toHex :: Int -> String -> toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] - - -> hexDig :: Int -> Char -> hexDig i | i <= 9 = chr (i + ord '0') -> | otherwise = chr (i - 10 + ord 'a') + + + + + + + + + + + + +> module ProduceCode (produceParser) where + + +-- > import Paths_happy ( version ) +-- > import Data.Version ( showVersion ) + + +> import Grammar +> import Target ( Target(..) ) +> import GenUtils ( mapDollarDollar, str, char, nl, strspace, +> interleave, interleave', maybestr, +> brack, brack' ) + + +> import Data.Maybe ( isJust, isNothing ) +> import Data.Char +> import Data.List + + +> import Control.Monad.ST +> import Data.Array.ST ( STUArray ) +> import Data.Array.Unboxed ( UArray ) +> import Data.Array.MArray +> import Data.Array.IArray + + + + + + + + +> produceParser :: Grammar -- grammar info +> -> ActionTable -- action table +> -> GotoTable -- goto table +> -> String -- stuff to go at the top +> -> Maybe String -- module header +> -> Maybe String -- module trailer +> -> Target -- type of code required +> -> Bool -- use coercions +> -> Bool -- use ghc extensions +> -> Bool -- strict parser +> -> String + + +> produceParser (Grammar +> { productions = prods +> , non_terminals = nonterms +> , terminals = terms +> , types = nt_types +> , first_nonterm = first_nonterm' +> , eof_term = eof +> , first_term = fst_term +> , lexer = lexer' +> , imported_identity = imported_identity' +> , monad = (use_monad,monad_context,monad_tycon,monad_then,monad_return) +> , token_specs = token_rep +> , token_type = token_type' +> , starts = starts' +> , error_handler = error_handler' +> , attributetype = attributetype' +> , attributes = attributes' +> }) +> action goto top_options module_header module_trailer +> target coerce ghc strict +> = ( top_opts +> . maybestr module_header . nl +> . str comment +> -- comment goes *after* the module header, so that we +> -- don't screw up any OPTIONS pragmas in the header. +> . produceAbsSynDecl . nl +> . produceTypes +> . produceActionTable target +> . produceReductions +> . produceTokenConverter . nl +> . produceIdentityStuff +> . produceMonadStuff +> . produceEntries +> . produceStrict strict +> . produceAttributes attributes' attributetype' . nl +> . maybestr module_trailer . nl +> ) "" +> where +> n_starts = length starts' +> token = brack token_type' +> +> nowarn_opts = str "{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}" . nl +> +> top_opts = nowarn_opts . +> case top_options of +> "" -> str "" +> _ -> str (unwords [ "{-# OPTIONS" +> , top_options +> , "#-}" +> ]) . nl + + + + + + + + + + + + + + + + + + + + +> produceAbsSynDecl + + + + + + + + + + + + + + + + + happyIn :: ti -> HappyAbsSyn ti tj tk ... + happyIn x = unsafeCoerce# x + {-# INLINE happyIn #-} + + + happyOut :: HappyAbsSyn ti tj tk ... -> tn + happyOut x = unsafeCoerce# x + {-# INLINE happyOut #-} + + +> | coerce +> = let +> happy_item = str "HappyAbsSyn " . str_tyvars +> bhappy_item = brack' happy_item +> +> inject n ty +> = mkHappyIn n . str " :: " . type_param n ty +> . str " -> " . bhappy_item . char '\n' +> . mkHappyIn n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" +> . str "{-# INLINE " . mkHappyIn n . str " #-}" +> +> extract n ty +> = mkHappyOut n . str " :: " . bhappy_item +> . str " -> " . type_param n ty . char '\n' +> . mkHappyOut n . str " x = Happy_GHC_Exts.unsafeCoerce# x\n" +> . str "{-# INLINE " . mkHappyOut n . str " #-}" +> in +> str "newtype " . happy_item . str " = HappyAbsSyn HappyAny\n" -- see NOTE below +> . interleave "\n" (map str +> [ "#if __GLASGOW_HASKELL__ >= 607", +> "type HappyAny = Happy_GHC_Exts.Any", +> "#else", +> "type HappyAny = forall a . a", +> "#endif" ]) +> . interleave "\n" +> [ inject n ty . nl . extract n ty | (n,ty) <- assocs nt_types ] +> -- token injector +> . str "happyInTok :: " . token . str " -> " . bhappy_item +> . str "\nhappyInTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyInTok #-}\n" +> -- token extractor +> . str "happyOutTok :: " . bhappy_item . str " -> " . token +> . str "\nhappyOutTok x = Happy_GHC_Exts.unsafeCoerce# x\n{-# INLINE happyOutTok #-}\n" + + +> . str "\n" + + + + + + + + + + + + + + + + + + + + +-> ()) as the type here, but this led to bogus optimisations (see GHC +ticket #1616). + + + + + + + + + + + + + + + + +> | otherwise +> = str "data HappyAbsSyn " . str_tyvars +> . str "\n\t= HappyTerminal " . token +> . str "\n\t| HappyErrorToken Int\n" +> . interleave "\n" +> [ str "\t| " . makeAbsSynCon n . strspace . type_param n ty +> | (n, ty) <- assocs nt_types, +> (nt_types_index ! n) == n] + + +> where all_tyvars = [ 't':show n | (n, Nothing) <- assocs nt_types ] +> str_tyvars = str (unwords all_tyvars) + + + + + + + + +> produceTypes +> | target == TargetArrayBased = id + + +> | all isJust (elems nt_types) = +> happyReductionDefinition . str "\n\n" +> . interleave' ",\n " +> [ mkActionName i | (i,_action') <- zip [ 0 :: Int .. ] +> (assocs action) ] +> . str " :: " . str monad_context . str " => " +> . intMaybeHash . str " -> " . happyReductionValue . str "\n\n" +> . interleave' ",\n " +> [ mkReduceFun i | +> (i,_action) <- zip [ n_starts :: Int .. ] +> (drop n_starts prods) ] +> . str " :: " . str monad_context . str " => " +> . happyReductionValue . str "\n\n" + + +> | otherwise = id + + +> where intMaybeHash | ghc = str "Happy_GHC_Exts.Int#" +> | otherwise = str "Int" +> tokens = +> case lexer' of +> Nothing -> char '[' . token . str "] -> " +> Just _ -> id +> happyReductionDefinition = +> str "{- to allow type-synonyms as our monads (likely\n" +> . str " - with explicitly-specified bind and return)\n" +> . str " - in Haskell98, it seems that with\n" +> . str " - /type M a = .../, then /(HappyReduction M)/\n" +> . str " - is not allowed. But Happy is a\n" +> . str " - code-generator that can just substitute it.\n" +> . str "type HappyReduction m = " +> . happyReduction (str "m") +> . str "\n-}" +> happyReductionValue = +> str "({-" +> . str "HappyReduction " +> . brack monad_tycon +> . str " = -}" +> . happyReduction (brack monad_tycon) +> . str ")" +> happyReduction m = +> str "\n\t " +> . intMaybeHash +> . str " \n\t-> " . token +> . str "\n\t-> HappyState " +> . token +> . str " (HappyStk HappyAbsSyn -> " . tokens . result +> . str ")\n\t" +> . str "-> [HappyState " +> . token +> . str " (HappyStk HappyAbsSyn -> " . tokens . result +> . str ")] \n\t-> HappyStk HappyAbsSyn \n\t-> " +> . tokens +> . result +> where result = m . str " HappyAbsSyn" + + + + + + + + + + + + + + + + + + + + + + + ( <> ) : happyRest + + + + + + + + + + + + + happyReduce_275 = happyMonadReduce 0# 119# happyReduction_275 + + + = happyThen (code) (\r -> happyReturn (HappyAbsSyn r)) + + + + + + + + + + + + + + + + +> produceReductions = +> interleave "\n\n" +> (zipWith produceReduction (drop n_starts prods) [ n_starts .. ]) + + +> produceReduction (nt, toks, (code,vars_used), _) i + + +> | is_monad_prod && (use_monad || imported_identity') +> = mkReductionHdr (showInt lt) monad_reduce +> . char '(' . interleave " `HappyStk`\n\t" tokPatterns +> . str "happyRest) tk\n\t = happyThen (" +> . tokLets (char '(' . str code' . char ')') +> . (if monad_pass_token then str " tk" else id) +> . str "\n\t) (\\r -> happyReturn (" . this_absSynCon . str " r))" + + +> | specReduceFun lt +> = mkReductionHdr id ("happySpecReduce_" ++ show lt) +> . interleave "\n\t" tokPatterns +> . str " = " +> . tokLets ( +> this_absSynCon . str "\n\t\t " +> . char '(' . str code' . str "\n\t)" +> ) +> . (if coerce || null toks || null vars_used then +> id +> else +> nl . reductionFun . strspace +> . interleave " " (map str (take (length toks) (repeat "_"))) +> . str " = notHappyAtAll ") + + +> | otherwise +> = mkReductionHdr (showInt lt) "happyReduce" +> . char '(' . interleave " `HappyStk`\n\t" tokPatterns +> . str "happyRest)\n\t = " +> . tokLets +> ( this_absSynCon . str "\n\t\t " +> . char '(' . str code'. str "\n\t) `HappyStk` happyRest" +> ) + + +> where +> (code', is_monad_prod, monad_pass_token, monad_reduce) +> = case code of +> '%':'%':code1 -> (code1, True, True, "happyMonad2Reduce") +> '%':'^':code1 -> (code1, True, True, "happyMonadReduce") +> '%':code1 -> (code1, True, False, "happyMonadReduce") +> _ -> (code, False, False, "") + + +> -- adjust the nonterminal number for the array-based parser +> -- so that nonterminals start at zero. +> adjusted_nt | target == TargetArrayBased = nt - first_nonterm' +> | otherwise = nt +> +> mkReductionHdr lt' s = +> mkReduceFun i . str " = " +> . str s . strspace . lt' . strspace . showInt adjusted_nt +> . strspace . reductionFun . nl +> . reductionFun . strspace +> +> reductionFun = str "happyReduction_" . shows i +> +> tokPatterns +> | coerce = reverse (map mkDummyVar [1 .. length toks]) +> | otherwise = reverse (zipWith tokPattern [1..] toks) +> +> tokPattern n _ | n `notElem` vars_used = char '_' +> tokPattern n t | t >= firstStartTok && t < fst_term +> = if coerce +> then mkHappyVar n +> else brack' ( +> makeAbsSynCon t . str " " . mkHappyVar n +> ) +> tokPattern n t +> = if coerce +> then mkHappyTerminalVar n t +> else str "(HappyTerminal " +> . mkHappyTerminalVar n t +> . char ')' +> +> tokLets code'' +> | coerce && not (null cases) +> = interleave "\n\t" cases +> . code'' . str (take (length cases) (repeat '}')) +> | otherwise = code'' +> +> cases = [ str "case " . extract t . strspace . mkDummyVar n +> . str " of { " . tokPattern n t . str " -> " +> | (n,t) <- zip [1..] toks, +> n `elem` vars_used ] +> +> extract t | t >= firstStartTok && t < fst_term = mkHappyOut t +> | otherwise = str "happyOutTok" +> +> lt = length toks + + +> this_absSynCon | coerce = mkHappyIn nt +> | otherwise = makeAbsSynCon nt + + + + + + + + +> produceTokenConverter +> = case lexer' of { +> +> Nothing -> +> str "happyNewToken action sts stk [] =\n\t" +> . eofAction "notHappyAtAll" +> . str " []\n\n" +> . str "happyNewToken action sts stk (tk:tks) =\n\t" +> . str "let cont i = " . doAction . str " sts stk tks in\n\t" +> . str "case tk of {\n\t" +> . interleave ";\n\t" (map doToken token_rep) +> . str "_ -> happyError' (tk:tks)\n\t" +> . str "}\n\n" +> . str "happyError_ tk tks = happyError' (tk:tks)\n"; + + +> Just (lexer'',eof') -> +> str "happyNewToken action sts stk\n\t= " +> . str lexer'' +> . str "(\\tk -> " +> . str "\n\tlet cont i = " +> . doAction +> . str " sts stk in\n\t" +> . str "case tk of {\n\t" +> . str (eof' ++ " -> ") +> . eofAction "tk" . str ";\n\t" +> . interleave ";\n\t" (map doToken token_rep) +> . str "_ -> happyError' tk\n\t" +> . str "})\n\n" +> . str "happyError_ tk = happyError' tk\n"; +> } + + +> where + + +> eofAction tk = +> (case target of +> TargetArrayBased -> +> str "happyDoAction " . eofTok . strspace . str tk . str " action" +> _ -> str "action " . eofTok . strspace . eofTok +> . strspace . str tk . str " (HappyState action)") +> . str " sts stk" +> eofTok = showInt (tokIndex eof) +> +> doAction = case target of +> TargetArrayBased -> str "happyDoAction i tk action" +> _ -> str "action i i tk (HappyState action)" +> +> doToken (i,tok) +> = str (removeDollarDollar tok) +> . str " -> cont " +> . showInt (tokIndex i) + + + + + + + + +> removeDollarDollar xs = case mapDollarDollar xs of +> Nothing -> xs +> Just fn -> fn "happy_dollar_dollar" + + +> mkHappyTerminalVar :: Int -> Int -> String -> String +> mkHappyTerminalVar i t = +> case tok_str_fn of +> Nothing -> pat +> Just fn -> brack (fn (pat [])) +> where +> tok_str_fn = case lookup t token_rep of +> Nothing -> Nothing +> Just str' -> mapDollarDollar str' +> pat = mkHappyVar i + + +> tokIndex +> = case target of +> TargetHaskell -> id +> TargetArrayBased -> \i -> i - n_nonterminals - n_starts - 2 +> -- tokens adjusted to start at zero, see ARRAY_NOTES + + + + + + + + +> produceActionTable TargetHaskell +> = foldr (.) id (map (produceStateFunction goto) (assocs action)) +> +> produceActionTable TargetArrayBased +> = produceActionArray +> . produceReduceArray +> . str "happy_n_terms = " . shows n_terminals . str " :: Int\n" +> . str "happy_n_nonterms = " . shows n_nonterminals . str " :: Int\n\n" + + +> produceStateFunction goto' (state, acts) +> = foldr (.) id (map produceActions assocs_acts) +> . foldr (.) id (map produceGotos (assocs gotos)) +> . mkActionName state +> . (if ghc +> then str " x = happyTcHack x " +> else str " _ = ") +> . mkAction default_act +> . str "\n\n" +> +> where gotos = goto' ! state +> +> produceActions (_, LR'Fail{-'-}) = id +> produceActions (t, action'@(LR'Reduce{-'-} _ _)) +> | action' == default_act = id +> | otherwise = actionFunction t +> . mkAction action' . str "\n" +> produceActions (t, action') +> = actionFunction t +> . mkAction action' . str "\n" +> +> produceGotos (t, Goto i) +> = actionFunction t +> . str "happyGoto " . mkActionName i . str "\n" +> produceGotos (_, NoGoto) = id +> +> actionFunction t +> = mkActionName state . strspace +> . ('(' :) . showInt t +> . str ") = " +> +> default_act = getDefault assocs_acts +> +> assocs_acts = assocs acts + + + + +> produceActionArray +> | ghc +> = str "happyActOffsets :: HappyAddr\n" +> . str "happyActOffsets = HappyA# \"" --" +> . str (hexChars act_offs) +> . str "\"#\n\n" --" +> +> . str "happyGotoOffsets :: HappyAddr\n" +> . str "happyGotoOffsets = HappyA# \"" --" +> . str (hexChars goto_offs) +> . str "\"#\n\n" --" +> +> . str "happyDefActions :: HappyAddr\n" +> . str "happyDefActions = HappyA# \"" --" +> . str (hexChars defaults) +> . str "\"#\n\n" --" +> +> . str "happyCheck :: HappyAddr\n" +> . str "happyCheck = HappyA# \"" --" +> . str (hexChars check) +> . str "\"#\n\n" --" +> +> . str "happyTable :: HappyAddr\n" +> . str "happyTable = HappyA# \"" --" +> . str (hexChars table) +> . str "\"#\n\n" --" + + +> | otherwise +> = str "happyActOffsets :: Happy_Data_Array.Array Int Int\n" +> . str "happyActOffsets = Happy_Data_Array.listArray (0," +> . shows (n_states) . str ") ([" +> . interleave' "," (map shows act_offs) +> . str "\n\t])\n\n" +> +> . str "happyGotoOffsets :: Happy_Data_Array.Array Int Int\n" +> . str "happyGotoOffsets = Happy_Data_Array.listArray (0," +> . shows (n_states) . str ") ([" +> . interleave' "," (map shows goto_offs) +> . str "\n\t])\n\n" +> +> . str "happyDefActions :: Happy_Data_Array.Array Int Int\n" +> . str "happyDefActions = Happy_Data_Array.listArray (0," +> . shows (n_states) . str ") ([" +> . interleave' "," (map shows defaults) +> . str "\n\t])\n\n" +> +> . str "happyCheck :: Happy_Data_Array.Array Int Int\n" +> . str "happyCheck = Happy_Data_Array.listArray (0," +> . shows table_size . str ") ([" +> . interleave' "," (map shows check) +> . str "\n\t])\n\n" +> +> . str "happyTable :: Happy_Data_Array.Array Int Int\n" +> . str "happyTable = Happy_Data_Array.listArray (0," +> . shows table_size . str ") ([" +> . interleave' "," (map shows table) +> . str "\n\t])\n\n" +> +> (_, last_state) = bounds action +> n_states = last_state + 1 +> n_terminals = length terms +> n_nonterminals = length nonterms - n_starts -- lose %starts +> +> (act_offs,goto_offs,table,defaults,check) +> = mkTables action goto first_nonterm' fst_term +> n_terminals n_nonterminals n_starts +> +> table_size = length table - 1 +> +> produceReduceArray +> = {- str "happyReduceArr :: Array Int a\n" -} +> str "happyReduceArr = Happy_Data_Array.array (" +> . shows (n_starts :: Int) -- omit the %start reductions +> . str ", " +> . shows n_rules +> . str ") [\n" +> . interleave' ",\n" (map reduceArrElem [n_starts..n_rules]) +> . str "\n\t]\n\n" + + +> n_rules = length prods - 1 :: Int + + +> showInt i | ghc = shows i . showChar '#' +> | otherwise = shows i + + + + + + +> nt_types_index :: Array Int Int +> nt_types_index = array (bounds nt_types) +> [ (a, fn a b) | (a, b) <- assocs nt_types ] +> where +> fn n Nothing = n +> fn _ (Just a) = case lookup a assoc_list of +> Just v -> v +> Nothing -> error ("cant find an item in list") +> assoc_list = [ (b,a) | (a, Just b) <- assocs nt_types ] + + +> makeAbsSynCon = mkAbsSynCon nt_types_index + + + + +> produceIdentityStuff | use_monad = id +> | imported_identity' = +> str "type HappyIdentity = Identity\n" +> . str "happyIdentity = Identity\n" +> . str "happyRunIdentity = runIdentity\n\n" +> | otherwise = +> str "newtype HappyIdentity a = HappyIdentity a\n" +> . str "happyIdentity = HappyIdentity\n" +> . str "happyRunIdentity (HappyIdentity a) = a\n\n" +> . str "instance Monad HappyIdentity where\n" +> . str " return = HappyIdentity\n" +> . str " (HappyIdentity p) >>= q = q p\n\n" + + + + + + + + + + + happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b + happyReturn :: () => a -> HappyIdentity a + happyThen1 m k tks = happyThen m (\a -> k a tks) + happyReturn1 = \a tks -> happyReturn a + + + + + + + happyThen :: CONTEXT => P a -> (a -> P b) -> P b + happyReturn :: CONTEXT => a -> P a + happyThen1 m k tks = happyThen m (\a -> k a tks) + happyReturn1 = \a tks -> happyReturn a + + + + + + + happyThen :: CONTEXT => P a -> (a -> P b) -> P b + happyReturn :: CONTEXT => a -> P a + + + + + + + + +> produceMonadStuff = +> let pcont = str monad_context in +> let pty = str monad_tycon in +> str "happyThen :: " . pcont . str " => " . pty +> . str " a -> (a -> " . pty +> . str " b) -> " . pty . str " b\n" +> . str "happyThen = " . brack monad_then . nl +> . str "happyReturn :: " . pcont . str " => a -> " . pty . str " a\n" +> . str "happyReturn = " . brack monad_return . nl +> . case lexer' of +> Nothing -> +> str "happyThen1 m k tks = (" . str monad_then +> . str ") m (\\a -> k a tks)\n" +> . str "happyReturn1 :: " . pcont . str " => a -> b -> " . pty . str " a\n" +> . str "happyReturn1 = \\a tks -> " . brack monad_return +> . str " a\n" +> . str "happyError' :: " . str monad_context . str " => [" +> . token +> . str "] -> " +> . str monad_tycon +> . str " a\n" +> . str "happyError' = " +> . str (if use_monad then "" else "HappyIdentity . ") +> . errorHandler +> . str "\n\n" +> _ -> +> str "happyThen1 = happyThen\n" +> . str "happyReturn1 :: " . pcont . str " => a -> " . pty . str " a\n" +> . str "happyReturn1 = happyReturn\n" +> . str "happyError' :: " . str monad_context . str " => " +> . token . str " -> " +> . str monad_tycon +> . str " a\n" +> . str "happyError' tk = " +> . str (if use_monad then "" else "HappyIdentity ") +> . errorHandler . str " tk\n" +> . str "\n" + + + + + + + + + + +> errorHandler = +> case error_handler' of +> Just h -> str h +> Nothing -> case lexer' of +> Nothing -> str "happyError" +> Just _ -> str "(\\token -> happyError)" + + +> reduceArrElem n +> = str "\t(" . shows n . str " , " +> . str "happyReduce_" . shows n . char ')' + + + + + + + + +> produceEntries +> = interleave "\n\n" (map produceEntry (zip starts' [0..])) +> . if null attributes' then id else produceAttrEntries starts' + + +> produceEntry ((name, _start_nonterm, accept_nonterm, _partial), no) +> = (if null attributes' then str name else str "do_" . str name) +> . maybe_tks +> . str " = " +> . str unmonad +> . str "happySomeParser where\n" +> . str " happySomeParser = happyThen (happyParse " +> . case target of +> TargetHaskell -> str "action_" . shows no +> TargetArrayBased +> | ghc -> shows no . str "#" +> | otherwise -> shows no +> . maybe_tks +> . str ") " +> . brack' (if coerce +> then str "\\x -> happyReturn (happyOut" +> . shows accept_nonterm . str " x)" +> else str "\\x -> case x of {HappyAbsSyn" +> . shows (nt_types_index ! accept_nonterm) +> . str " z -> happyReturn z; _other -> notHappyAtAll }" +> ) +> where +> maybe_tks | isNothing lexer' = str " tks" +> | otherwise = id +> unmonad | use_monad = "" +> | otherwise = "happyRunIdentity " + + +> produceAttrEntries starts'' +> = interleave "\n\n" (map f starts'') +> where +> f = case (use_monad,lexer') of +> (True,Just _) -> \(name,_,_,_) -> monadAndLexerAE name +> (True,Nothing) -> \(name,_,_,_) -> monadAE name +> (False,Just _) -> error "attribute grammars not supported for non-monadic parsers with %lexer" +> (False,Nothing)-> \(name,_,_,_) -> regularAE name +> +> defaultAttr = fst (head attributes') +> +> monadAndLexerAE name +> = str name . str " = " +> . str "do { " +> . str "f <- do_" . str name . str "; " +> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " +> . str "sequence_ conds; " +> . str "return (". str defaultAttr . str " attrs) }}" +> monadAE name +> = str name . str " toks = " +> . str "do { " +> . str "f <- do_" . str name . str " toks; " +> . str "let { (conds,attrs) = f happyEmptyAttrs } in do { " +> . str "sequence_ conds; " +> . str "return (". str defaultAttr . str " attrs) }}" +> regularAE name +> = str name . str " toks = " +> . str "let { " +> . str "f = do_" . str name . str " toks; " +> . str "(conds,attrs) = f happyEmptyAttrs; " +> . str "x = foldr seq attrs conds; " +> . str "} in (". str defaultAttr . str " x)" + + + + + + + + +> produceAttributes :: [(String, String)] -> String -> String -> String +> produceAttributes [] _ = id +> produceAttributes attrs attributeType +> = str "data " . attrHeader . str " = HappyAttributes {" . attributes' . str "}" . nl +> . str "happyEmptyAttrs = HappyAttributes {" . attrsErrors . str "}" . nl + + +> where attributes' = foldl1 (\x y -> x . str ", " . y) $ map formatAttribute attrs +> formatAttribute (ident,typ) = str ident . str " :: " . str typ +> attrsErrors = foldl1 (\x y -> x . str ", " . y) $ map attrError attrs +> attrError (ident,_) = str ident . str " = error \"invalid reference to attribute '" . str ident . str "'\"" +> attrHeader = +> case attributeType of +> [] -> str "HappyAttributes" +> _ -> str attributeType + + + + + + + + + + +> produceStrict :: Bool -> String -> String +> produceStrict strict +> | strict = str "happySeq = happyDoSeq\n\n" +> | otherwise = str "happySeq = happyDontSeq\n\n" + + + + + + + + + + +> actionVal :: LRAction -> Int +> actionVal (LR'Shift state _) = state + 1 +> actionVal (LR'Reduce rule _) = -(rule + 1) +> actionVal LR'Accept = -1 +> actionVal (LR'Multiple _ a) = actionVal a +> actionVal LR'Fail = 0 +> actionVal LR'MustFail = 0 + + +> mkAction :: LRAction -> String -> String +> mkAction (LR'Shift i _) = str "happyShift " . mkActionName i +> mkAction LR'Accept = str "happyAccept" +> mkAction LR'Fail = str "happyFail" +> mkAction LR'MustFail = str "happyFail" +> mkAction (LR'Reduce i _) = str "happyReduce_" . shows i +> mkAction (LR'Multiple _ a) = mkAction a + + +> mkActionName :: Int -> String -> String +> mkActionName i = str "action_" . shows i + + + + + + +> getDefault :: [(Name, LRAction)] -> LRAction +> getDefault actions = +> -- pick out the action for the error token, if any +> case [ act | (e, act) <- actions, e == errorTok ] of +> +> -- use error reduction as the default action, if there is one. +> act@(LR'Reduce _ _) : _ -> act +> act@(LR'Multiple _ (LR'Reduce _ _)) : _ -> act +> +> -- if the error token is shifted or otherwise, don't generate +> -- a default action. This is *important*! +> (act : _) | act /= LR'Fail -> LR'Fail +> +> -- no error actions, pick a reduce to be the default. +> _ -> case reduces of +> [] -> LR'Fail +> (act:_) -> act -- pick the first one we see for now +> +> where reduces +> = [ act | (_,act@(LR'Reduce _ _)) <- actions ] +> ++ [ act | (_,(LR'Multiple _ act@(LR'Reduce _ _))) <- actions ] + + + + + + +> mkTables +> :: ActionTable -> GotoTable -> Name -> Int -> Int -> Int -> Int -> +> ([Int] -- happyActOffsets +> ,[Int] -- happyGotoOffsets +> ,[Int] -- happyTable +> ,[Int] -- happyDefAction +> ,[Int] -- happyCheck +> ) +> +> mkTables action goto first_nonterm' fst_term +> n_terminals n_nonterminals n_starts +> = ( elems act_offs, +> elems goto_offs, +> take max_off (elems table), +> def_actions, +> take max_off (elems check) +> ) +> where +> +> (table,check,act_offs,goto_offs,max_off) +> = runST (genTables (length actions) max_token sorted_actions) +> +> -- the maximum token number used in the parser +> max_token = max n_terminals (n_starts+n_nonterminals) - 1 +> +> def_actions = map (\(_,_,def,_,_,_) -> def) actions +> +> actions :: [TableEntry] +> actions = +> [ (ActionEntry, +> state, +> actionVal default_act, +> if null acts'' then 0 +> else fst (last acts'') - fst (head acts''), +> length acts'', +> acts'') +> | (state, acts) <- assocs action, +> let (err:_dummy:vec) = assocs acts +> vec' = drop (n_starts+n_nonterminals) vec +> acts' = filter (notFail) (err:vec') +> default_act = getDefault acts' +> acts'' = mkActVals acts' default_act +> ] +> +> -- adjust terminals by -(fst_term+1), so they start at 1 (error is 0). +> -- (see ARRAY_NOTES) +> adjust token | token == errorTok = 0 +> | otherwise = token - fst_term + 1 +> +> mkActVals assocs' default_act = +> [ (adjust token, actionVal act) +> | (token, act) <- assocs' +> , act /= default_act ] +> +> gotos :: [TableEntry] +> gotos = [ (GotoEntry, +> state, 0, +> if null goto_vals then 0 +> else fst (last goto_vals) - fst (head goto_vals), +> length goto_vals, +> goto_vals +> ) +> | (state, goto_arr) <- assocs goto, +> let goto_vals = mkGotoVals (assocs goto_arr) +> ] +> +> -- adjust nonterminals by -first_nonterm', so they start at zero +> -- (see ARRAY_NOTES) +> mkGotoVals assocs' = +> [ (token - first_nonterm', i) | (token, Goto i) <- assocs' ] +> +> sorted_actions = reverse (sortBy cmp_state (actions++gotos)) +> cmp_state (_,_,_,width1,tally1,_) (_,_,_,width2,tally2,_) +> | width1 < width2 = LT +> | width1 == width2 = compare tally1 tally2 +> | otherwise = GT + + +> data ActionOrGoto = ActionEntry | GotoEntry +> type TableEntry = (ActionOrGoto, +> Int{-stateno-}, +> Int{-default-}, +> Int{-width-}, +> Int{-tally-}, +> [(Int,Int)]) + + +> genTables +> :: Int -- number of actions +> -> Int -- maximum token no. +> -> [TableEntry] -- entries for the table +> -> ST s (UArray Int Int, -- table +> UArray Int Int, -- check +> UArray Int Int, -- action offsets +> UArray Int Int, -- goto offsets +> Int -- highest offset in table +> ) +> +> genTables n_actions max_token entries = do +> +> table <- newArray (0, mAX_TABLE_SIZE) 0 +> check <- newArray (0, mAX_TABLE_SIZE) (-1) +> act_offs <- newArray (0, n_actions) 0 +> goto_offs <- newArray (0, n_actions) 0 +> off_arr <- newArray (-max_token, mAX_TABLE_SIZE) 0 +> +> max_off <- genTables' table check act_offs goto_offs +> off_arr entries max_token +> +> table' <- freeze table +> check' <- freeze check +> act_offs' <- freeze act_offs +> goto_offs' <- freeze goto_offs +> return (table',check',act_offs',goto_offs',max_off+1) + + +> where +> n_states = n_actions - 1 +> mAX_TABLE_SIZE = n_states * (max_token + 1) + + + + +> genTables' +> :: STUArray s Int Int -- table +> -> STUArray s Int Int -- check +> -> STUArray s Int Int -- action offsets +> -> STUArray s Int Int -- goto offsets +> -> STUArray s Int Int -- offset array +> -> [TableEntry] -- entries for the table +> -> Int -- maximum token no. +> -> ST s Int -- highest offset in table +> +> genTables' table check act_offs goto_offs off_arr entries max_token +> = fit_all entries 0 1 +> where +> +> fit_all [] max_off _ = return max_off +> fit_all (s:ss) max_off fst_zero = do +> (off, new_max_off, new_fst_zero) <- fit s max_off fst_zero +> ss' <- same_states s ss off +> writeArray off_arr off 1 +> fit_all ss' new_max_off new_fst_zero +> +> -- try to merge identical states. We only try the next state(s) +> -- in the list, but the list is kind-of sorted so we shouldn't +> -- miss too many. +> same_states _ [] _ = return [] +> same_states s@(_,_,_,_,_,acts) ss@((e,no,_,_,_,acts'):ss') off +> | acts == acts' = do writeArray (which_off e) no off +> same_states s ss' off +> | otherwise = return ss +> +> which_off ActionEntry = act_offs +> which_off GotoEntry = goto_offs +> +> -- fit a vector into the table. Return the offset of the vector, +> -- the maximum offset used in the table, and the offset of the first +> -- entry in the table (used to speed up the lookups a bit). +> fit (_,_,_,_,_,[]) max_off fst_zero = return (0,max_off,fst_zero) +> +> fit (act_or_goto, state_no, _deflt, _, _, state@((t,_):_)) +> max_off fst_zero = do +> -- start at offset 1 in the table: all the empty states +> -- (states with just a default reduction) are mapped to +> -- offset zero. +> off <- findFreeOffset (-t+fst_zero) check off_arr state +> let new_max_off | furthest_right > max_off = furthest_right +> | otherwise = max_off +> furthest_right = off + max_token +> +> -- trace ("fit: state " ++ show state_no ++ ", off " ++ show off ++ ", elems " ++ show state) $ do +> +> writeArray (which_off act_or_goto) state_no off +> addState off table check state +> new_fst_zero <- findFstFreeSlot check fst_zero +> return (off, new_max_off, new_fst_zero) + + + + + + + + + + + + + + + + + + + + +> -- Find a valid offset in the table for this state. +> findFreeOffset :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] -> ST s Int +> findFreeOffset off table off_arr state = do +> -- offset 0 isn't allowed +> if off == 0 then try_next else do +> +> -- don't use an offset we've used before +> b <- readArray off_arr off +> if b /= 0 then try_next else do +> +> -- check whether the actions for this state fit in the table +> ok <- fits off state table +> if not ok then try_next else return off +> where +> try_next = findFreeOffset (off+1) table off_arr state + + + + +> fits :: Int -> [(Int,Int)] -> STUArray s Int Int -> ST s Bool +> fits _ [] _ = return True +> fits off ((t,_):rest) table = do +> i <- readArray table (off+t) +> if i /= -1 then return False +> else fits off rest table + + +> addState :: Int -> STUArray s Int Int -> STUArray s Int Int -> [(Int, Int)] +> -> ST s () +> addState _ _ _ [] = return () +> addState off table check ((t,val):state) = do +> writeArray table (off+t) val +> writeArray check (off+t) t +> addState off table check state + + +> notFail :: (Int, LRAction) -> Bool +> notFail (_, LR'Fail) = False +> notFail _ = True + + +> findFstFreeSlot :: STUArray s Int Int -> Int -> ST s Int +> findFstFreeSlot table n = do +> i <- readArray table n +> if i == -1 then return n +> else findFstFreeSlot table (n+1) + + + + + + + + +> comment :: String +> comment = +> "-- parser produced by Happy \n\n" + + +> mkAbsSynCon :: Array Int Int -> Int -> String -> String +> mkAbsSynCon fx t = str "HappyAbsSyn" . shows (fx ! t) + + +> mkHappyVar, mkReduceFun, mkDummyVar :: Int -> String -> String +> mkHappyVar n = str "happy_var_" . shows n +> mkReduceFun n = str "happyReduce_" . shows n +> mkDummyVar n = str "happy_x_" . shows n + + +> mkHappyIn, mkHappyOut :: Int -> String -> String +> mkHappyIn n = str "happyIn" . shows n +> mkHappyOut n = str "happyOut" . shows n + + +> type_param :: Int -> Maybe String -> ShowS +> type_param n Nothing = char 't' . shows n +> type_param _ (Just ty) = brack ty + + +> specReduceFun :: Int -> Bool +> specReduceFun = (<= 3) + + + + + + + + + + +> hexChars :: [Int] -> String +> hexChars acts = concat (map hexChar acts) + + +> hexChar :: Int -> String +> hexChar i | i < 0 = hexChar (i + 2^16) +> hexChar i = toHex (i `mod` 256) ++ toHex (i `div` 256) + + +> toHex :: Int -> String +> toHex i = ['\\','x', hexDig (i `div` 16), hexDig (i `mod` 16)] + + +> hexDig :: Int -> Char +> hexDig i | i <= 9 = chr (i + ord '0') +> | otherwise = chr (i - 10 + ord 'a') diff --git a/src/ProduceGLRCode.lhs b/src/ProduceGLRCode.lhs --- a/src/ProduceGLRCode.lhs +++ b/src/ProduceGLRCode.lhs @@ -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 + + + diff --git a/src/Target.lhs b/src/Target.lhs --- a/src/Target.lhs +++ b/src/Target.lhs @@ -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 diff --git a/src/Text/Happy.hs b/src/Text/Happy.hs --- a/src/Text/Happy.hs +++ b/src/Text/Happy.hs @@ -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 + diff --git a/src/Text/Happy/HappyTemplate.hs b/src/Text/Happy/HappyTemplate.hs --- a/src/Text/Happy/HappyTemplate.hs +++ b/src/Text/Happy/HappyTemplate.hs @@ -1,206 +1,206 @@ -module Text.Happy.HappyTemplate where -happyTemplate = - "{-# LINE 1 \"templates\\GenericTemplate.hs\" #-}\n" ++ - "{-# LINE 1 \"templates\\\\GenericTemplate.hs\" #-}\n" ++ - "{-# LINE 1 \"\" #-}\n" ++ - "{-# LINE 1 \"\" #-}\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 \"\" #-}\n" ++ + "{-# LINE 1 \"\" #-}\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." diff --git a/src/Text/Happy/Quote.hs b/src/Text/Happy/Quote.hs --- a/src/Text/Happy/Quote.hs +++ b/src/Text/Happy/Quote.hs @@ -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