Hello community, here is the log from the commit of package happy for openSUSE:Factory checked in at 2015-05-13 07:12:41 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/happy (Old) and /work/SRC/openSUSE:Factory/.happy.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "happy" Changes: -------- --- /work/SRC/openSUSE:Factory/happy/happy.changes 2015-02-10 20:23:46.000000000 +0100 +++ /work/SRC/openSUSE:Factory/.happy.new/happy.changes 2015-05-13 07:12:42.000000000 +0200 @@ -1,0 +2,5 @@ +Thu Apr 9 16:46:01 UTC 2015 - mimi.vx@gmail.com + +- update to 1.19.5 + +------------------------------------------------------------------- Old: ---- happy-1.19.4.tar.gz New: ---- happy-1.19.5.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ happy.spec ++++++ --- /var/tmp/diff_new_pack.TWwAyN/_old 2015-05-13 07:12:43.000000000 +0200 +++ /var/tmp/diff_new_pack.TWwAyN/_new 2015-05-13 07:12:43.000000000 +0200 @@ -1,7 +1,7 @@ # # spec file for package happy # -# Copyright (c) 2015 SUSE LINUX Products GmbH, Nuernberg, Germany. +# Copyright (c) 2015 SUSE LINUX GmbH, Nuernberg, Germany. # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -20,7 +20,7 @@ %global debug_package %{nil} %bcond_without tests Name: happy -Version: 1.19.4 +Version: 1.19.5 Release: 0 Summary: The LALR(1) Parser Generator for Haskell License: BSD-2-Clause ++++++ happy-1.19.4.tar.gz -> happy-1.19.5.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/CHANGES new/happy-1.19.5/CHANGES --- old/happy-1.19.4/CHANGES 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/CHANGES 2015-01-06 22:04:19.000000000 +0100 @@ -1,4 +1,9 @@ ----------------------------------------------------------------------------- +1.19.5 + * fixes for GHC 7.10 + * Code cleanups (thanks Index Int <vlad.z.4096@gmail.com>) + +----------------------------------------------------------------------------- 1.19.4 * fix for GHC 7.10 (Applicative/Monad, #19, #21) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/README new/happy-1.19.5/README --- old/happy-1.19.4/README 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/README 2015-01-06 22:04:19.000000000 +0100 @@ -11,7 +11,7 @@ Complete documentation can be found in the directory 'doc', in DocBook XML format. To format the documentation, the DocBook-Tools -suite (see http://www.http://sourceware.cygnus.com/docbook-tools/) +suite (see http://sourceware.cygnus.com/docbook-tools/) provides all the bits & pieces you need. Alternatively, pre-formatted documentation is available from Happy's homepage (URL above). diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/dist/build/happy/happy-tmp/AttrGrammarParser.hs new/happy-1.19.5/dist/build/happy/happy-tmp/AttrGrammarParser.hs --- old/happy-1.19.4/dist/build/happy/happy-tmp/AttrGrammarParser.hs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/dist/build/happy/happy-tmp/AttrGrammarParser.hs 2015-01-06 22:04:19.000000000 +0100 @@ -6,8 +6,9 @@ import AttrGrammar import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) --- parser produced by Happy Version 1.19.0 +-- parser produced by Happy Version 1.19.4 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -352,6 +353,7 @@ +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) #define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) @@ -361,7 +363,7 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 46 "templates/GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -370,11 +372,11 @@ -{-# LINE 66 "templates/GenericTemplate.hs" #-} +{-# LINE 67 "templates/GenericTemplate.hs" #-} -{-# LINE 76 "templates/GenericTemplate.hs" #-} +{-# LINE 77 "templates/GenericTemplate.hs" #-} -{-# LINE 85 "templates/GenericTemplate.hs" #-} +{-# LINE 86 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -391,9 +393,9 @@ -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans + happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action @@ -401,35 +403,35 @@ happyDoAction i tk st - = {- nothing -} + = {- nothing -} - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} - happyShift new_state i tk st + happyShift new_state i tk st where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) where off = indexShortOffAddr happyActOffsets st off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) then EQ(indexShortOffAddr happyCheck off_i, i) - else False + else False action | check = indexShortOffAddr happyTable off_i | otherwise = indexShortOffAddr happyDefActions st indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i + Happy_GHC_Exts.narrow16Int# i where i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) @@ -448,7 +450,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 169 "templates/GenericTemplate.hs" #-} +{-# LINE 170 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token @@ -490,9 +492,9 @@ = happyFail 0# tk st sts stk happyReduce k nt fn j tk st sts stk = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) happyMonadReduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk @@ -544,7 +546,7 @@ -- parse error if we are in recovery and we fail again 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" $ +-- trace "failing" $ happyError_ i tk {- We don't need state discarding for our restricted implementation of @@ -553,16 +555,16 @@ -- discard a state happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) -} -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail i tk (action) sts stk = -- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) -- Internal happy errors: @@ -580,9 +582,9 @@ ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq +-- happySeq = happyDoSeq -- otherwise it emits --- happySeq = happyDontSeq +-- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq a b = a `seq` b diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/dist/build/happy/happy-tmp/Parser.hs new/happy-1.19.5/dist/build/happy/happy-tmp/Parser.hs --- old/happy-1.19.4/dist/build/happy/happy-tmp/Parser.hs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/dist/build/happy/happy-tmp/Parser.hs 2015-01-06 22:04:19.000000000 +0100 @@ -7,8 +7,9 @@ import Lexer import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts +import Control.Applicative(Applicative(..)) --- parser produced by Happy Version 1.19.0 +-- parser produced by Happy Version 1.19.4 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -739,6 +740,7 @@ +-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex. #if __GLASGOW_HASKELL__ > 706 #define LT(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.<# m)) :: Bool) #define GTE(n,m) ((Happy_GHC_Exts.tagToEnum# (n Happy_GHC_Exts.>=# m)) :: Bool) @@ -748,7 +750,7 @@ #define GTE(n,m) (n Happy_GHC_Exts.>=# m) #define EQ(n,m) (n Happy_GHC_Exts.==# m) #endif -{-# LINE 45 "templates/GenericTemplate.hs" #-} +{-# LINE 46 "templates/GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -757,11 +759,11 @@ -{-# LINE 66 "templates/GenericTemplate.hs" #-} +{-# LINE 67 "templates/GenericTemplate.hs" #-} -{-# LINE 76 "templates/GenericTemplate.hs" #-} +{-# LINE 77 "templates/GenericTemplate.hs" #-} -{-# LINE 85 "templates/GenericTemplate.hs" #-} +{-# LINE 86 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -778,9 +780,9 @@ -- parse (a %partial parser). We must ignore the saved token on the top of -- the stack in this case. happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) = - happyReturn1 ans + happyReturn1 ans happyAccept j tk st sts (HappyStk ans _) = - (happyTcHack j (happyTcHack st)) (happyReturn1 ans) + (happyTcHack j (happyTcHack st)) (happyReturn1 ans) ----------------------------------------------------------------------------- -- Arrays only: do the next action @@ -788,35 +790,35 @@ happyDoAction i tk st - = {- nothing -} + = {- nothing -} - case action of - 0# -> {- nothing -} - happyFail i tk st - -1# -> {- nothing -} - happyAccept i tk st - n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} + case action of + 0# -> {- nothing -} + happyFail i tk st + -1# -> {- nothing -} + happyAccept i tk st + n | LT(n,(0# :: Happy_GHC_Exts.Int#)) -> {- nothing -} - (happyReduceArr Happy_Data_Array.! rule) i tk st - where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) - n -> {- nothing -} + (happyReduceArr Happy_Data_Array.! rule) i tk st + where rule = (Happy_GHC_Exts.I# ((Happy_GHC_Exts.negateInt# ((n Happy_GHC_Exts.+# (1# :: Happy_GHC_Exts.Int#)))))) + n -> {- nothing -} - happyShift new_state i tk st + happyShift new_state i tk st where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) where off = indexShortOffAddr happyActOffsets st off_i = (off Happy_GHC_Exts.+# i) - check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) + check = if GTE(off_i,(0# :: Happy_GHC_Exts.Int#)) then EQ(indexShortOffAddr happyCheck off_i, i) - else False + else False action | check = indexShortOffAddr happyTable off_i | otherwise = indexShortOffAddr happyDefActions st indexShortOffAddr (HappyA# arr) off = - Happy_GHC_Exts.narrow16Int# i + Happy_GHC_Exts.narrow16Int# i where i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) @@ -835,7 +837,7 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 169 "templates/GenericTemplate.hs" #-} +{-# LINE 170 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token @@ -877,9 +879,9 @@ = happyFail 0# tk st sts stk happyReduce k nt fn j tk st sts stk = case happyDrop (k Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) sts of - sts1@((HappyCons (st1@(action)) (_))) -> - let r = fn stk in -- it doesn't hurt to always seq here... - happyDoSeq r (happyGoto nt j tk st1 sts1 r) + sts1@((HappyCons (st1@(action)) (_))) -> + let r = fn stk in -- it doesn't hurt to always seq here... + happyDoSeq r (happyGoto nt j tk st1 sts1 r) happyMonadReduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk @@ -931,7 +933,7 @@ -- parse error if we are in recovery and we fail again 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" $ +-- trace "failing" $ happyError_ i tk {- We don't need state discarding for our restricted implementation of @@ -940,16 +942,16 @@ -- discard a state happyFail 0# tk old_st (HappyCons ((action)) (sts)) - (saved_tok `HappyStk` _ `HappyStk` stk) = --- trace ("discarding state, depth " ++ show (length stk)) $ - happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) + (saved_tok `HappyStk` _ `HappyStk` stk) = +-- trace ("discarding state, depth " ++ show (length stk)) $ + happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk)) -} -- Enter error recovery: generate an error token, -- save the old token and carry on. happyFail i tk (action) sts stk = -- trace "entering error recovery" $ - happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) + happyDoAction 0# tk action sts ( (Happy_GHC_Exts.unsafeCoerce# (Happy_GHC_Exts.I# (i))) `HappyStk` stk) -- Internal happy errors: @@ -967,9 +969,9 @@ ----------------------------------------------------------------------------- -- Seq-ing. If the --strict flag is given, then Happy emits --- happySeq = happyDoSeq +-- happySeq = happyDoSeq -- otherwise it emits --- happySeq = happyDontSeq +-- happySeq = happyDontSeq happyDoSeq, happyDontSeq :: a -> b -> b happyDoSeq a b = a `seq` b diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/doc/happy.xml new/happy-1.19.5/doc/happy.xml --- old/happy-1.19.4/doc/happy.xml 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/doc/happy.xml 2015-01-06 22:04:19.000000000 +0100 @@ -3970,6 +3970,94 @@ </listitem> </itemizedlist> </sect1> + + <sect1 id="sec-monad-alex"> + <title>Basic monadic Happy use with Alex</title> + <indexterm> + <primary><application>Alex</application></primary> + <secondary>monad</secondary> + </indexterm> + + <para> + <application>Alex</application> lexers are often used by + <application>Happy</application> parsers, for example in + GHC. While many of these applications are quite sophisticated, + it is still quite useful to combine the basic + <application>Happy</application> <literal>%monad</literal> + directive with the <application>Alex</application> + <literal>monad</literal> wrapper. By using monads for both, + the resulting parser and lexer can handle errors far more + gracefully than by throwing an exception. + </para> + + <para> + The most straightforward way to use a monadic + <application>Alex</application> lexer is to simply use the + <literal>Alex</literal> monad as the + <application>Happy</application> monad: + </para> + + <example><title>Lexer.x</title> +<programlisting>{ +module Lexer where +} + +%wrapper "monad" + +tokens :- + ... + +{ +data Token = ... | EOF + deriving (Eq, Show) + +alexEOF = return EOF +}</programlisting></example> + <example><title>Parser.y</title> +<programlisting>{ +module Parser where + +import Lexer +} + +%name pFoo +%tokentype { Token } +%error { parseError } +%monad { Alex } { >>= } { return } +%lexer { lexer } { EOF } + +%token + ... + +%% + ... + +parseError :: Token -> Alex a +parseError _ = do + ((AlexPn _ line column), _, _, _) <- alexGetInput + alexError ("parse error at line " ++ (show line) ++ ", column " ++ (show column)) + +lexer :: (Token -> Alex a) -> Alex a +lexer = (alexMonadScan >>=) +}</programlisting></example> + + <para> + We can then run the finished parser in the + <literal>Alex</literal> monad using + <literal>runAlex</literal>, which returns an + <literal>Either</literal> value rather than throwing an + exception in case of a parse or lexical error: + </para> + +<programlisting> +import qualified Lexer as Lexer +import qualified Parser as Parser + +parseFoo :: String -> Either String Foo +parseFoo s = Lexer.runAlex s Parser.pFoo +</programlisting> + + </sect1> </chapter> <index/> </book> diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/Makefile.defs new/happy-1.19.5/examples/glr/Makefile.defs --- old/happy-1.19.4/examples/glr/Makefile.defs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/Makefile.defs 2015-01-06 22:04:19.000000000 +0100 @@ -1,7 +1,7 @@ .SUFFIXES: .y .hs .exe OPT= -GHC=ghc -I../common -i../common ${OPT} +GHC=ghc -rtsopts -I../common -i../common ${OPT} # -dshow-passes HAPPY=happy diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/bio-eg/Bio.y new/happy-1.19.5/examples/glr/bio-eg/Bio.y --- old/happy-1.19.4/examples/glr/bio-eg/Bio.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/bio-eg/Bio.y 2015-01-06 22:04:19.000000000 +0100 @@ -3,7 +3,7 @@ -- (c) 2004 University of Durham, Julia Fischer -- Portions of the grammar are derived from work by Leung/Mellish/Robertson -import Char +import Data.Char } %tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/bio-eg/Main.lhs new/happy-1.19.5/examples/glr/bio-eg/Main.lhs --- old/happy-1.19.4/examples/glr/bio-eg/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/bio-eg/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import Bio import qualified Data.Map as Map diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/expr-eval/Expr.y new/happy-1.19.5/examples/glr/expr-eval/Expr.y --- old/happy-1.19.4/examples/glr/expr-eval/Expr.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/expr-eval/Expr.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char }
%tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/expr-eval/Main.lhs new/happy-1.19.5/examples/glr/expr-eval/Main.lhs --- old/happy-1.19.4/examples/glr/expr-eval/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/expr-eval/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import Expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/expr-monad/Expr.y new/happy-1.19.5/examples/glr/expr-monad/Expr.y --- old/happy-1.19.4/examples/glr/expr-monad/Expr.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/expr-monad/Expr.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char }
%tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/expr-monad/Main.lhs new/happy-1.19.5/examples/glr/expr-monad/Main.lhs --- old/happy-1.19.4/examples/glr/expr-monad/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/expr-monad/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,6 @@
module Main where -> import System(getArgs) +> import System.IO.Error(catchIOError) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import Expr @@ -16,7 +17,7 @@ putStrLn $ "Ok " ++ show r ++ "\n" ++ unlines (map show $ Map.toList f) let ms = decode (forest_lookup f) r ::[IO Int] -> mapM_ (\ma -> catch ma (_ -> return 0) >>= print) ms +> mapM_ (\ma -> catchIOError ma (_ -> return 0) >>= print) ms toDV $ Map.toList f ParseEOF f -> do putStrLn $ "Premature end of input:\n" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/expr-tree/Expr.y new/happy-1.19.5/examples/glr/expr-tree/Expr.y --- old/happy-1.19.4/examples/glr/expr-tree/Expr.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/expr-tree/Expr.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char import Tree }
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/expr-tree/Main.lhs new/happy-1.19.5/examples/glr/expr-tree/Main.lhs --- old/happy-1.19.4/examples/glr/expr-tree/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/expr-tree/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import Expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/hidden-leftrec/Expr.y new/happy-1.19.5/examples/glr/hidden-leftrec/Expr.y --- old/happy-1.19.4/examples/glr/hidden-leftrec/Expr.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/hidden-leftrec/Expr.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char }
%tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/hidden-leftrec/Main.lhs new/happy-1.19.5/examples/glr/hidden-leftrec/Main.lhs --- old/happy-1.19.4/examples/glr/hidden-leftrec/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/hidden-leftrec/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import Expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/highly-ambiguous/Expr.y new/happy-1.19.5/examples/glr/highly-ambiguous/Expr.y --- old/happy-1.19.4/examples/glr/highly-ambiguous/Expr.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/highly-ambiguous/Expr.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char }
%tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/highly-ambiguous/Main.lhs new/happy-1.19.5/examples/glr/highly-ambiguous/Main.lhs --- old/happy-1.19.4/examples/glr/highly-ambiguous/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/highly-ambiguous/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import Expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/highly-ambiguous/Makefile new/happy-1.19.5/examples/glr/highly-ambiguous/Makefile --- old/happy-1.19.4/examples/glr/highly-ambiguous/Makefile 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/highly-ambiguous/Makefile 2015-01-06 22:04:19.000000000 +0100 @@ -7,7 +7,6 @@ NUM=20 run : expr ./expr +RTS -s -RTS ${NUM} | grep ^Ok
- egrep '' expr.stat > out${NUM}
run30 : make run NUM=30 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/nlp/English.y new/happy-1.19.5/examples/glr/nlp/English.y --- old/happy-1.19.4/examples/glr/nlp/English.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/nlp/English.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char } %tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/nlp/Main.lhs new/happy-1.19.5/examples/glr/nlp/Main.lhs --- old/happy-1.19.4/examples/glr/nlp/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/nlp/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import English diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/packing/Expr.y new/happy-1.19.5/examples/glr/packing/Expr.y --- old/happy-1.19.4/examples/glr/packing/Expr.y 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/packing/Expr.y 2015-01-06 22:04:19.000000000 +0100 @@ -1,6 +1,6 @@ { -- only list imports here -import Char +import Data.Char }
module Main where -> import System(getArgs) +> import System.Environment(getArgs) import Data.Maybe(fromJust) import qualified Data.Map as Map import Expr diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/happy.cabal new/happy-1.19.5/happy.cabal --- old/happy-1.19.4/happy.cabal 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/happy.cabal 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@ name: happy -version: 1.19.4 +version: 1.19.5
%tokentype { Token } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/examples/glr/packing/Main.lhs new/happy-1.19.5/examples/glr/packing/Main.lhs --- old/happy-1.19.4/examples/glr/packing/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/examples/glr/packing/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -1,5 +1,5 @@ license: BSD3 license-file: LICENSE copyright: (c) Andy Gill, Simon Marlow @@ -125,18 +125,16 @@ location: http://github.com/simonmar/happy.git flag small_base - description: Choose the new smaller, split-up base package. + description: Deprecated. Does nothing. executable happy hs-source-dirs: src main-is: Main.lhs - if flag(small_base) - build-depends: base >= 2.1, array, containers - else - build-depends: base >= 1.0 && < 2.1 - - build-depends: base < 5, mtl >= 1.0 + build-depends: base < 5, + array, + containers, + mtl >= 1.0 extensions: CPP, MagicHash, FlexibleContexts ghc-options: -Wall -fno-warn-type-defaults diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/AttrGrammar.lhs new/happy-1.19.5/src/AttrGrammar.lhs --- old/happy-1.19.4/src/AttrGrammar.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/AttrGrammar.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -65,12 +65,12 @@
type Pfunc a = String -> Int -> ParseResult a
agLexAll :: P [AgToken] -> agLexAll = P $ aux [] -> where aux toks [] _ = OkP (reverse toks) +> agLexAll = mkP $ aux [] +> where aux toks [] _ = Right (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 m = mkP $ agLexer' (\x -> runP (m x))
agLexer' :: (AgToken -> Pfunc a) -> Pfunc a agLexer' cont [] = cont AgTok_EOF [] @@ -103,5 +103,5 @@ 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" +> | otherwise = _ -> Left "bad attribute identifier" agLexAttribute cont k rest = cont (k "") rest diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/First.lhs new/happy-1.19.5/src/First.lhs --- old/happy-1.19.4/src/First.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/First.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -15,19 +15,11 @@ \subsection{Utilities}
joinSymSets :: (a -> NameSet) -> [a] -> NameSet -> joinSymSets f = foldr -> (\ h b -> let -> h' = f h -> in -> if incEmpty h' -> then Set.filter (not. isEmpty) h' `Set.union` b -> else h') -> (Set.singleton epsilonTok)
- -Does the Set include the $\epsilon$ symbol ?
- -> incEmpty :: NameSet -> Bool -> incEmpty set = any isEmpty (Set.toAscList set) +> joinSymSets f = foldr go (Set.singleton epsilonTok) . map f +> where +> go h b +> | Set.member epsilonTok h = Set.delete epsilonTok h `Set.union` b +> | otherwise = h
\subsection{Implementation of FIRST} @@ -37,9 +29,7 @@
, lookupProdsOfName = prodsOfName , non_terminals = nts })
-> = joinSymSets (\ h -> case lookup h env of -> Nothing -> Set.singleton h -> Just ix -> ix) +> = joinSymSets (\ h -> maybe (Set.singleton h) id (lookup h env) )
where env = mkClosure (==) (getNext fst_term prodNo prodsOfName) [ (name,Set.empty) | name <- nts ] @@ -50,14 +40,11 @@ [ (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) :-(" +> fn x = maybe (error "attempted FIRST(e) :-(") id (lookup x env)
next :: Name -> NameSet next t | t >= fst_term = Set.singleton t
-> next n = -> foldb Set.union +> next n = Set.unions
[ joinSymSets fn (snd4 (prodNo rl)) | rl <- prodsOfName n ]
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/GenUtils.lhs new/happy-1.19.5/src/GenUtils.lhs --- old/happy-1.19.4/src/GenUtils.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/GenUtils.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -6,28 +6,8 @@
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',
@@ -35,33 +15,11 @@
) where
import Data.Char (isAlphaNum) +> import Data.Ord (comparing) import Data.List -> import Data.Ix ( Ix(..) ) -> import Data.Array ( Array, listArray, array, (!) )
%------------------------------------------------------------------------------ -Here are two defs that everyone seems to define ... -HBC has it in one of its builtin modules - -> mapMaybe :: (a -> Maybe b) -> [a] -> [b] -> mapMaybe _ [] = [] -> mapMaybe f (a:r) = case f a of -> Nothing -> mapMaybe f r -> Just b -> b : mapMaybe f r - -> maybeMap :: (a -> b) -> Maybe a -> Maybe b -> maybeMap f (Just a) = Just (f a) -> maybeMap _ Nothing = Nothing - -> joinMaybe :: (a -> a -> a) -> Maybe a -> Maybe a -> Maybe a -> joinMaybe _ Nothing Nothing = Nothing -> joinMaybe _ (Just g) Nothing = Just g -> joinMaybe _ Nothing (Just g) = Just g -> joinMaybe f (Just g) (Just h) = Just (f g h) - -> data MaybeErr a err = Succeeded a | Failed err deriving (Eq,Show) - @mkClosure@ makes a closure, when given a comparison and iteration loop. Be careful, because if the functional always makes the object different, This will never terminate. @@ -73,107 +31,18 @@
match (_:c) = match c match [] = error "Can't happen: match []"
-> foldb :: (a -> a -> a) -> [a] -> a -> foldb _ [] = error "can't reduce an empty list using foldb" -> foldb _ [x] = x -> foldb f l = foldb f (foldb' l) -> where -> foldb' (x:y:x':y':xs) = f (f x y) (f x' y') : foldb' xs -> foldb' (x:y:xs) = f x y : foldb' xs -> foldb' xs = xs - -> returnMaybe :: a -> Maybe a -> returnMaybe = Just - -> handleMaybe :: Maybe a -> Maybe a -> Maybe a -> handleMaybe m k = case m of -> Nothing -> k -> _ -> m - -> findJust :: (a -> Maybe b) -> [a] -> Maybe b -> findJust f = foldr handleMaybe Nothing . map f - Gofer-like stuff: -> fst3 :: (a, b, c) -> a -> fst3 (a,_,_) = a -> snd3 :: (a, b, c) -> b -> snd3 (_,a,_) = a -> thd3 :: (a, b, c) -> c -> thd3 (_,_,a) = a - -> cjustify, ljustify, rjustify :: Int -> String -> String -> cjustify n s = space halfm ++ s ++ space (m - halfm) -> where m = n - length s -> halfm = m `div` 2 -> ljustify n s = s ++ space (max 0 (n - length s)) -> rjustify n s = space (n - length s) ++ s - -> space :: Int -> String -> space n = copy n ' ' - -> copy :: Int -> a -> [a] -- make list of n copies of x -> copy n x = take n xs where xs = x:xs - -> partition' :: (Eq b) => (a -> b) -> [a] -> [[a]] -> partition' _ [] = [] -> partition' _ [x] = [[x]] -> partition' f (x:x':xs) | f x == f x' -> = tack x (partition' f (x':xs)) -> | otherwise -> = [x] : partition' f (x':xs) - -> tack :: a -> [[a]] -> [[a]] -> tack x xss = (x : head xss) : tail xss -
combinePairs :: (Ord a) => [(a,b)] -> [(a,[b])] combinePairs xs = -> combine [ (a,[b]) | (a,b) <- sortBy (\ (a,_) (b,_) -> compare a b) xs] +> combine [ (a,[b]) | (a,b) <- sortBy (comparing fst) xs] where combine [] = [] combine ((a,b):(c,d):r) | a == c = combine ((a,b++d) : r) combine (a:r) = a : combine r
brack s = str ('(' : s) . char ')' brack' :: (String -> String) -> String -> String brack' s = char '(' . s . char ')'
-> assocMaybeErr :: (Eq a) => [(a,b)] -> a -> MaybeErr b String -> assocMaybeErr env k = case [ val | (key,val) <- env, k == key] of -> [] -> Failed "assoc: " -> (val:_) -> Succeeded val -> - -Now some utilties involving arrays. Here is a version of @elem@ that -uses partial application to optimise lookup. - -> arrElem :: (Ix a, Ord a) => [a] -> a -> Bool -> arrElem obj = \x -> inRange size x && arr ! x -> where -> obj' = sort obj -> size = (head obj',last obj') -> arr = listArray size [ i `elem` obj | i <- range size ] - - -You can use this function to simulate memoisation. For example: - - > fib = memoise (0,100) fib' - > where - > fib' 0 = 0 - > fib' 1 = 0 - > fib' n = fib (n-1) + fib (n-2) - -will give a very efficent variation of the fib function. - - -> memoise :: (Ix a) => (a,a) -> (a -> b) -> a -> b -> memoise bds f = (!) arr -> where arr = array bds [ (t, f t) | t <- range bds ] - -> listArray' :: (Int,Int) -> [a] -> Array Int a -> listArray' (low,up) elems = -> if length elems /= up-low+1 then error "wibble" else -> listArray (low,up) elems - - Replace $$ with an arbitrary string, being careful to avoid ".." and '.'. @@ -220,5 +89,3 @@ - - diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/Grammar.lhs new/happy-1.19.5/src/Grammar.lhs --- old/happy-1.19.4/src/Grammar.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/Grammar.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -7,7 +7,7 @@ Here is our mid-section datatype
module Grammar ( -> Name, isEmpty, +> Name,
Production, Grammar(..), mangler,
@@ -159,10 +159,6 @@
errorTok = 1 epsilonTok = 0
-> isEmpty :: Name -> Bool -> isEmpty n | n == epsilonTok = True -> | otherwise = False - ----------------------------------------------------------------------------- -- The Mangler @@ -174,10 +170,10 @@
addErr :: ErrMsg -> M () addErr e = tell [e]
-> mangler :: FilePath -> AbsSyn -> MaybeErr Grammar [ErrMsg] +> mangler :: FilePath -> AbsSyn -> Either [ErrMsg] Grammar
mangler file abssyn -> | null errs = Succeeded g -> | otherwise = Failed errs +> | null errs = Right g +> | otherwise = Left errs where (g, errs) = runWriter (manglerM file abssyn)
manglerM :: FilePath -> AbsSyn -> M Grammar @@ -325,7 +321,7 @@ lookup_prods _ = error "lookup_prods"
productions' = start_prods ++ concat rules2
-> prod_array = listArray' (0,length productions' - 1) productions' +> prod_array = listArray (0,length productions' - 1) productions' -- in
return (Grammar { @@ -395,9 +391,9 @@ first we need to parse the body of the code block
case runP agParser code 0 of
-> FailP msg -> do addErr ("error in attribute grammar rules: "++msg) -> return ("",[]) -> OkP rules -> +> Left msg -> do addErr ("error in attribute grammar rules: "++msg) +> return ("",[]) +> Right rules -> now we break the rules into three lists, one for synthesized attributes, one for inherited attributes, and one for conditionals diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/Info.lhs new/happy-1.19.5/src/Info.lhs --- old/happy-1.19.4/src/Info.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/Info.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -8,7 +8,7 @@
import Paths_happy ( version ) import LALR ( Lr0Item(..) ) -> import GenUtils ( str, interleave, interleave', ljustify ) +> import GenUtils ( str, interleave, interleave' ) import Data.Set ( Set ) import qualified Data.Set as Set hiding ( Set ) import Grammar @@ -202,6 +202,9 @@ showName = str . nameOf showJName j = str . ljustify j . nameOf
+> ljustify :: Int -> String -> String +> ljustify n s = s ++ replicate (max 0 (n - length s)) ' ' +
ljuststr :: Int -> (String -> String) -> String -> String ljuststr n s = str (ljustify n (s ""))
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/LALR.lhs new/happy-1.19.5/src/LALR.lhs --- old/happy-1.19.4/src/LALR.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/LALR.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -18,16 +18,18 @@
import NameSet ( NameSet ) import Grammar
+> import Control.Monad (guard)
import Control.Monad.ST import Data.Array.ST import Data.Array as Array import Data.List (nub) +> import Data.Maybe (listToMaybe, maybeToList)
unionMap :: (Ord b) => (a -> Set b) -> Set a -> Set b -> unionMap f = Set.fold (Set.union . f) Set.empty +> unionMap f = Set.foldr (Set.union . f) Set.empty
unionNameMap :: (Name -> NameSet) -> NameSet -> NameSet -> unionNameMap f = NameSet.fold (NameSet.union . f) NameSet.empty +> unionNameMap f = NameSet.foldr (NameSet.union . f) NameSet.empty
This means rule $a$, with dot at $b$ (all starting at 0) @@ -45,9 +47,7 @@
precalcClosure0 :: Grammar -> Name -> RuleList precalcClosure0 g = -> \n -> case lookup n info' of -> Nothing -> [] -> Just c -> c +> \n -> maybe [] id (lookup n info') where
info' :: [(Name, RuleList)]
@@ -64,16 +64,14 @@ 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" +> maybe (error "followNT") id (lookup nt f) _ -> 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 +> closure0 g closureOfNT set = Set.foldr addRules Set.empty set where fst_term = first_term g addRules rule set' = Set.union (Set.fromList (rule : closureOfRule rule)) set' @@ -102,16 +100,14 @@ new_old_items
fn :: Lr1Item -> [Lr1Item]
-> fn (Lr1 rule dot as) = -> case lookupProdNo g rule of { (_name,lhs,_,_) -> -> case drop dot lhs of +> fn (Lr1 rule dot as) = 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 ] _ -> []
-> } +> where (_name,lhs,_,_) = lookupProdNo g rule Subtract the first set of items from the second. @@ -184,7 +180,7 @@
genLR0items :: Grammar -> (Name -> RuleList) -> [ItemSetWithGotos] genLR0items g precalcClosures -> = fst (mkClosure ((_old,new) _ -> null new) +> = fst (mkClosure ((_,new) _ -> null new) addItems (([],startRules))) where @@ -289,34 +285,33 @@ start_spont = [ (start, (Lr0 start 0), NameSet.singleton (startLookahead gram partial)) | (start, (_,_,_,partial)) <- -> zip [ 0 .. length start_info - 1] start_info] +> zip [0..] start_info]
propLAItem :: Lr0Item -> ([(Int, Lr0Item, NameSet)], [(Lr0Item, Int, Lr0Item)]) propLAItem item@(Lr0 rule dot) = (spontaneous, propagated) where
+> lookupGoto msg x = maybe (error msg) id (lookup x goto)
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 ] +> spontaneous = do +> (Lr1 rule' dot' ts) <- j +> let ts' = NameSet.delete dummyTok ts +> guard (not $ NameSet.null ts') +> maybeToList $ do r <- findRule gram rule' dot' +> return ( lookupGoto "spontaneous" r +> , Lr0 rule' (dot' + 1) +> , ts' )
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) ] +> propagated = do +> (Lr1 rule' dot' ts) <- j +> guard $ NameSet.member dummyTok ts +> maybeToList $ do r <- findRule gram rule' dot' +> return ( item +> , lookupGoto "propagated" r +> , Lr0 rule' (dot' + 1) ) The lookahead for a start rule depends on whether it was declared with %name or %partial: a %name parser is assumed to parse the whole @@ -338,11 +333,10 @@
-> Array Int [(Lr0Item, NameSet)]
calcLookaheads n_states spont prop -> = runST (do +> = runST $ do arr <- newArray (0,n_states) [] propagate arr (foldr fold_lookahead [] spont) freeze arr -> )
where propagate :: STArray s Int [(Lr0Item, NameSet)] @@ -364,11 +358,9 @@ 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 +> add_lookaheads arr = mapM_ $ (i,item,s) +> -> do las <- readArray arr i +> writeArray arr i (add_lookahead item s las)
get_new :: STArray s Int [(Lr0Item, NameSet)] -> [(Int, Lr0Item, NameSet)] @@ -391,9 +383,8 @@ 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) +> let s'' = s NameSet.\ s' in +> if NameSet.null s'' then new else (i,item,s'') : new | otherwise = get_new' l las new
@@ -405,52 +396,6 @@
| i < i' = (i,item,s):m:las | otherwise = m : fold_lookahead l las
-Normal version: - -calcLookaheads - :: Int -- number of states - -> [(Int, Lr0Item, Set Name)] -- spontaneous lookaheads - -> Array Int [(Lr0Item, Int, Lr0Item)] -- propagated lookaheads - -> Array Int [(Lr0Item, Set Name)] - -calcLookaheads n_states spont prop - = rebuildArray $ fst (mkClosure ((_,new) _ -> null new) propagate - ([], foldr addLookahead [] spont)) - where - - rebuildArray :: [(Int, Lr0Item, Set Name)] -> Array Int [(Lr0Item, Set Name)] - rebuildArray xs = accumArray (++) [] (0,n_states-1) - [ (a, [(b,c)]) | (a,b,c) <- xs ] - - propagate (las,new) = - let - items = [ (i,item'',s) | (j,item,s) <- new, - (item',i,item'') <- prop ! j, - item == item' ] - new_new = foldr (\i new -> getNew i las new) [] items - new_las = foldr addLookahead las new - in - (new_las, new_new) - -addLookahead :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)] - -> [(Int,Lr0Item,Set Name)] -addLookahead l [] = [l] -addLookahead l@(i,item,s) (m@(i',item',s'):las) - | i == i' && item == item' = (i,item, s `Set.union` s'):las - | i < i' = (i,item,s):m:las - | otherwise = m : addLookahead l las - -getNew :: (Int,Lr0Item,Set Name) -> [(Int,Lr0Item,Set Name)] - -> [(Int,Lr0Item,Set Name)] -> [(Int,Lr0Item,Set Name)] -getNew l [] new = l:new -getNew l@(i,item,s) (m@(i',item',s'):las) new - | i == i' && item == item' = - let s'' = filter (`notElem` s') s in - if null s'' then new else - ((i,item,s''):new) - | i < i' = (i,item,s):new - | otherwise = getNew l las new - ----------------------------------------------------------------------------- Merge lookaheads @@ -467,12 +412,11 @@
mergeIntoSet :: (Set Lr0Item, [(Name, Int)]) -> Int -> ([Lr1Item], [(Name, Int)]) mergeIntoSet (items, goto) i
-> = (concat (map mergeIntoItem (Set.toAscList items)), goto) +> = (map mergeIntoItem (Set.toAscList items), goto)
where
-> mergeIntoItem :: Lr0Item -> [Lr1Item] -> mergeIntoItem item@(Lr0 rule dot) -> = [Lr1 rule dot la] +> 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
@@ -498,9 +442,7 @@
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, maybe NoGoto Goto (lookup n goto))
| n <- non_terms, n >= fst_nonterm, n < fst_term ]) | (_set,goto) <- sets ]
@@ -530,24 +472,20 @@
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) ] +> let f j = (t,LR'Shift j p) +> p = maybe No id (lookup t prios) +> in map f $ maybeToList (lookup t goto)
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)) +> (_,_,_,p) -> NameSet.toAscList la `zip` repeat (LR'Reduce rule p)
_ -> []
-> possActions goto coll = -> (concat [ possAction goto coll item | -> item <- closure1 g first coll ]) +> possActions goto coll = do item <- closure1 g first coll +> possAction goto coll item These comments are now out of date! /JS @@ -590,7 +528,7 @@
| x == x' = LR'Multiple (nub $ as ++ bs) x -- merge dropped reductions for identical action
-> res (LR'Multiple as x) (LR'Multiple bs x') +> | otherwise
= case res x x' of LR'Multiple cs a | a == x -> LR'Multiple (nub $ x' : as ++ bs ++ cs) x
@@ -655,8 +593,5 @@ -----------------------------------------------------------------------------
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 +> findRule g rule dot = listToMaybe (drop dot lhs) +> where (_,lhs,_,_) = lookupProdNo g rule diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/Lexer.lhs new/happy-1.19.5/src/Lexer.lhs --- old/happy-1.19.4/src/Lexer.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/Lexer.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -71,7 +71,7 @@ ToDo: proper text instance here, for use in parser error messages.
lexer :: (Token -> P a) -> P a -> lexer cont = P lexer' +> lexer cont = mkP lexer' where lexer' "" = returnToken cont TokenEOF "" lexer' ('-':'-':r) = lexer' (dropWhile (/= '\n') r) lexer' ('{':'-':r) = \line -> lexNestedComment line lexer' r line @@ -218,8 +218,8 @@ || c == '_'
lexReadSingleChar :: String -> (String -> String -> a) -> a -> lexReadSingleChar (c:''':r) fn = fn (c:"'") r 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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/Main.lhs new/happy-1.19.5/src/Main.lhs --- old/happy-1.19.4/src/Main.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/Main.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -12,7 +12,6 @@ import Paths_happy
import ParseMonad -> import GenUtils import AbsSyn import Grammar import Parser @@ -89,14 +88,14 @@ Parse, using bootstrapping parser.
case coerceParser (runP ourParser file 1) of {
-> FailP err -> die (fl_name ++ ':' : err); -> OkP abssyn@(AbsSyn hd _ _ tl) -> +> Left err -> die (fl_name ++ ':' : err); +> Right abssyn@(AbsSyn hd _ _ tl) -> Mangle the syntax into something useful.
case {-# SCC "Mangler" #-} (mangler fl_name abssyn) of {
-> Failed s -> die (unlines s ++ "\n"); -> Succeeded g -> +> Left s -> die (unlines s ++ "\n"); +> Right g -> #ifdef DEBUG @@ -518,7 +517,8 @@
"import qualified Debug.Trace as Happy_Debug_Trace\n"
import_applicative :: String -> import_applicative = "import Control.Applicative(Applicative(..))\n" +> import_applicative = "import Control.Applicative(Applicative(..))\n" ++ +> "import Control.Monad (ap)\n"
------------------------------------------------------------------------------ Extract various command-line options. diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/NameSet.hs new/happy-1.19.5/src/NameSet.hs --- old/happy-1.19.4/src/NameSet.hs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/NameSet.hs 2015-01-06 22:04:19.000000000 +0100 @@ -1,10 +1,8 @@ module NameSet ( - NameSet, null, member, empty, singleton, - union, difference, filter, fold, - fromList, toAscList + NameSet, + module Data.IntSet ) where -import Prelude hiding ( null, filter ) import Data.IntSet type NameSet = IntSet diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/ParseMonad.hs new/happy-1.19.5/src/ParseMonad.hs --- old/happy-1.19.4/src/ParseMonad.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/happy-1.19.5/src/ParseMonad.hs 2015-01-06 22:04:19.000000000 +0100 @@ -0,0 +1,15 @@ +module ParseMonad where + +import Control.Monad.Reader + +type ParseResult = Either String +type P a = ReaderT (String, Int) ParseResult a + +mkP :: (String -> Int -> ParseResult a) -> P a +mkP = ReaderT . uncurry + +runP :: P a -> String -> Int -> ParseResult a +runP f s l = runReaderT f (s, l) + +lineP :: P Int +lineP = asks snd >>= return diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/ParseMonad.lhs new/happy-1.19.5/src/ParseMonad.lhs --- old/happy-1.19.4/src/ParseMonad.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/ParseMonad.lhs 1970-01-01 01:00:00.000000000 +0100 @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------ -The parser monad. - -(c) 2001 Simon Marlow ------------------------------------------------------------------------------ - -> module ParseMonad where - -> data ParseResult a = OkP a | FailP String -> newtype P a = P (String -> Int -> ParseResult a) -> runP :: P a -> String -> Int -> ParseResult a -> runP (P f) = f - -> lineP :: P Int -> lineP = P $ _ l -> OkP l - -> instance Monad P where -> return m = P $ \ _ _ -> OkP m -> m >>= k = P $ \s l -> case runP m s l of -> OkP a -> runP (k a) s l -> FailP err -> FailP err -> fail s = P $ \ _ _ -> FailP s diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/ProduceCode.lhs new/happy-1.19.5/src/ProduceCode.lhs --- old/happy-1.19.4/src/ProduceCode.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/ProduceCode.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -685,8 +685,8 @@
. str "instance Functor HappyIdentity where\n" . str " fmap f (HappyIdentity a) = HappyIdentity (f a)\n\n" . str "instance Applicative HappyIdentity where\n"
-> . str " pure = return\n" -> . str " a <*> b = (fmap id a) <*> b\n" +> . str " pure = return\n" +> . str " (<*>) = ap\n"
. str "instance Monad HappyIdentity where\n" . str " return = HappyIdentity\n" . str " (HappyIdentity p) >>= q = q p\n\n"
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/src/ProduceGLRCode.lhs new/happy-1.19.5/src/ProduceGLRCode.lhs --- old/happy-1.19.4/src/ProduceGLRCode.lhs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/src/ProduceGLRCode.lhs 2015-01-06 22:04:19.000000000 +0100 @@ -15,7 +15,7 @@
) where
import Paths_happy ( version ) -> import GenUtils ( thd3, mapDollarDollar ) +> import GenUtils ( mapDollarDollar ) import GenUtils ( str, char, nl, brack, brack', interleave, maybestr ) import Grammar import Data.Array @@ -118,7 +118,7 @@ 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 +> let (ext,imps,opts) = case ghcExts_opt of UseGhcExts is os -> ("-ghc", is, os) _ -> ("", "", "") base <- readFile (base_template templdir) @@ -128,11 +128,13 @@ lib <- readFile (lib_template templdir ++ ext ++ debug_ext) writeFile (basename ++ ".hs") (lib_content imps opts lib) where +> (_,_,ghcExts_opt) = options
+
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 +> table_text = mkTbls tables sem_info (ghcExts_opt) g
header_parts = fmap (span (\x -> take 3 (dropWhile isSpace x) == "{-#") . lines) @@ -695,6 +697,6 @@
mkHappyVar :: Int -> String -> String -> mkHappyVar n = showString "happy_var_" . shows n +> mkHappyVar n = str "happy_var_" . shows n
diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/happy-1.19.4/templates/GLR_Lib.hs new/happy-1.19.5/templates/GLR_Lib.hs --- old/happy-1.19.4/templates/GLR_Lib.hs 2014-07-07 13:05:53.000000000 +0200 +++ new/happy-1.19.5/templates/GLR_Lib.hs 2015-01-06 22:04:19.000000000 +0100 @@ -40,7 +40,6 @@ where import Data.Char -import System import qualified Data.Map as Map import Control.Monad (foldM)