Ebnf2ps (empty) → 1.0.8
raw patch · 23 files changed
+4623/−0 lines, 23 filesdep +arraydep +basedep +containerssetup-changed
Dependencies added: array, base, containers, directory, haskell98, old-time, unix
Files
- Ebnf2ps.cabal +32/−0
- LICENSE +9/−0
- Setup.hs +2/−0
- dist/build/ebnf2ps/ebnf2ps-tmp/Ebnf2psParser.hs +1297/−0
- src/AbstractSyntax.hs +20/−0
- src/Color.hs +133/−0
- src/CommandLine.hs +102/−0
- src/Ebnf2ps.hs +257/−0
- src/Ebnf2psParser.ly +227/−0
- src/EbnfLayout.hs +416/−0
- src/EbnfOutput.hs +166/−0
- src/Fig31Output.hs +277/−0
- src/Fonts.hs +99/−0
- src/GrammarTransform.hs +355/−0
- src/GrammarUnfold.hs +197/−0
- src/IOSupplement.hs +105/−0
- src/Info.hs +46/−0
- src/Lexer.hs +87/−0
- src/ParseAux.hs +235/−0
- src/Parsers.hs +104/−0
- src/PsOutput.hs +358/−0
- src/StringMatch.hs +97/−0
- src/Version.hs +2/−0
+ Ebnf2ps.cabal view
@@ -0,0 +1,32 @@+Name: Ebnf2ps+Version: 1.0.8+Synopsis: Peter's Syntax Diagram Drawing Tool+Homepage: http://www.informatik.uni-freiburg.de/~thiemann/haskell/ebnf2ps/+License: BSD3+License-file: LICENSE+Author: Peter Thiemann <thiemann@acm.org>+Maintainer: Peter Thiemann <thiemann@acm.org>+Category: Language+Build-type: Simple+Cabal-version: >=1.2+Tested-With: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.4, GHC == 7.2.2+Description: Ebnf2ps generates nice looking syntax diagrams in EPS+ and FIG format from EBNF specifications and from yacc,+ bison, and Happy input grammars. The diagrams can be+ immediatedly included in TeX/LaTeX documents and in+ texts created with other popular document preparation+ systems.++Executable ebnf2ps+ Main-is: Ebnf2ps.hs+ Hs-source-dirs: src+ Build-depends: base < 5, containers,+ old-time,+ directory,+ unix, array, haskell98+ Build-tools: happy+ Cc-options: -DAFMPATH=/usr/share/texmf-texlive/fonts/afm+ Other-modules: Parsers, StringMatch, Info, Fonts, IOSupplement,+ EbnfLayout, EbnfOutput, PsOutput, Fig31Output, Version,+ Color, AbstractSyntax, Lexer, GrammarTransform, GrammarUnfold,+ ParseAux, Ebnf2psParser, CommandLine
+ LICENSE view
@@ -0,0 +1,9 @@+Copyright (c) 2008-2012, Peter Thiemann+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 the University of Freiburg nor the names of its 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 HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ dist/build/ebnf2ps/ebnf2ps-tmp/Ebnf2psParser.hs view
@@ -0,0 +1,1297 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+module Ebnf2psParser (theEbnfParser, theHappyParser, theYaccParser) where+import AbstractSyntax+import Lexer+import List+import ParseAux+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.18.6++newtype HappyAbsSyn = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn4 :: ([Production]) -> (HappyAbsSyn )+happyIn4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn4 #-}+happyOut4 :: (HappyAbsSyn ) -> ([Production])+happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut4 #-}+happyIn5 :: ([Production]) -> (HappyAbsSyn )+happyIn5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn5 #-}+happyOut5 :: (HappyAbsSyn ) -> ([Production])+happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut5 #-}+happyIn6 :: ([Production]) -> (HappyAbsSyn )+happyIn6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn6 #-}+happyOut6 :: (HappyAbsSyn ) -> ([Production])+happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut6 #-}+happyIn7 :: (Production) -> (HappyAbsSyn )+happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn7 #-}+happyOut7 :: (HappyAbsSyn ) -> (Production)+happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut7 #-}+happyIn8 :: ([String]) -> (HappyAbsSyn )+happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn8 #-}+happyOut8 :: (HappyAbsSyn ) -> ([String])+happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut8 #-}+happyIn9 :: (String) -> (HappyAbsSyn )+happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn9 #-}+happyOut9 :: (HappyAbsSyn ) -> (String)+happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut9 #-}+happyIn10 :: (Production) -> (HappyAbsSyn )+happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn10 #-}+happyOut10 :: (HappyAbsSyn ) -> (Production)+happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut10 #-}+happyIn11 :: ([Production]) -> (HappyAbsSyn )+happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn11 #-}+happyOut11 :: (HappyAbsSyn ) -> ([Production])+happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut11 #-}+happyIn12 :: (Production) -> (HappyAbsSyn )+happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn12 #-}+happyOut12 :: (HappyAbsSyn ) -> (Production)+happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut12 #-}+happyIn13 :: ([Production]) -> (HappyAbsSyn )+happyIn13 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn13 #-}+happyOut13 :: (HappyAbsSyn ) -> ([Production])+happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut13 #-}+happyIn14 :: (Production) -> (HappyAbsSyn )+happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn14 #-}+happyOut14 :: (HappyAbsSyn ) -> (Production)+happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut14 #-}+happyIn15 :: (Production) -> (HappyAbsSyn )+happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn15 #-}+happyOut15 :: (HappyAbsSyn ) -> (Production)+happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut15 #-}+happyIn16 :: ([Production]) -> (HappyAbsSyn )+happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn16 #-}+happyOut16 :: (HappyAbsSyn ) -> ([Production])+happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut16 #-}+happyIn17 :: ([Production]) -> (HappyAbsSyn )+happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn17 #-}+happyOut17 :: (HappyAbsSyn ) -> ([Production])+happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut17 #-}+happyIn18 :: (Production) -> (HappyAbsSyn )+happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn18 #-}+happyOut18 :: (HappyAbsSyn ) -> (Production)+happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut18 #-}+happyIn19 :: (Production) -> (HappyAbsSyn )+happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn19 #-}+happyOut19 :: (HappyAbsSyn ) -> (Production)+happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut19 #-}+happyIn20 :: ([Production]) -> (HappyAbsSyn )+happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn20 #-}+happyOut20 :: (HappyAbsSyn ) -> ([Production])+happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut20 #-}+happyIn21 :: (Production) -> (HappyAbsSyn )+happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn21 #-}+happyOut21 :: (HappyAbsSyn ) -> (Production)+happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut21 #-}+happyIn22 :: ([Production]) -> (HappyAbsSyn )+happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn22 #-}+happyOut22 :: (HappyAbsSyn ) -> ([Production])+happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut22 #-}+happyIn23 :: (Production) -> (HappyAbsSyn )+happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn23 #-}+happyOut23 :: (HappyAbsSyn ) -> (Production)+happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut23 #-}+happyIn24 :: ([String]) -> (HappyAbsSyn )+happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn24 #-}+happyOut24 :: (HappyAbsSyn ) -> ([String])+happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut24 #-}+happyIn25 :: ([String]) -> (HappyAbsSyn )+happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn25 #-}+happyOut25 :: (HappyAbsSyn ) -> ([String])+happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut25 #-}+happyIn26 :: ([String]) -> (HappyAbsSyn )+happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn26 #-}+happyOut26 :: (HappyAbsSyn ) -> ([String])+happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut26 #-}+happyIn27 :: ([String]) -> (HappyAbsSyn )+happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn27 #-}+happyOut27 :: (HappyAbsSyn ) -> ([String])+happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut27 #-}+happyIn28 :: (()) -> (HappyAbsSyn )+happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn28 #-}+happyOut28 :: (HappyAbsSyn ) -> (())+happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut28 #-}+happyIn29 :: (()) -> (HappyAbsSyn )+happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn29 #-}+happyOut29 :: (HappyAbsSyn ) -> (())+happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut29 #-}+happyIn30 :: (()) -> (HappyAbsSyn )+happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn30 #-}+happyOut30 :: (HappyAbsSyn ) -> (())+happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut30 #-}+happyIn31 :: (()) -> (HappyAbsSyn )+happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn31 #-}+happyOut31 :: (HappyAbsSyn ) -> (())+happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut31 #-}+happyIn32 :: ([Production]) -> (HappyAbsSyn )+happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn32 #-}+happyOut32 :: (HappyAbsSyn ) -> ([Production])+happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut32 #-}+happyIn33 :: ([Production]) -> (HappyAbsSyn )+happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn33 #-}+happyOut33 :: (HappyAbsSyn ) -> ([Production])+happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut33 #-}+happyIn34 :: (Production) -> (HappyAbsSyn )+happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn34 #-}+happyOut34 :: (HappyAbsSyn ) -> (Production)+happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut34 #-}+happyIn35 :: (Production) -> (HappyAbsSyn )+happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn35 #-}+happyOut35 :: (HappyAbsSyn ) -> (Production)+happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut35 #-}+happyIn36 :: ([Production]) -> (HappyAbsSyn )+happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn36 #-}+happyOut36 :: (HappyAbsSyn ) -> ([Production])+happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut36 #-}+happyIn37 :: (()) -> (HappyAbsSyn )+happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn37 #-}+happyOut37 :: (HappyAbsSyn ) -> (())+happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut37 #-}+happyIn38 :: (Production) -> (HappyAbsSyn )+happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn38 #-}+happyOut38 :: (HappyAbsSyn ) -> (Production)+happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut38 #-}+happyIn39 :: (()) -> (HappyAbsSyn )+happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn39 #-}+happyOut39 :: (HappyAbsSyn ) -> (())+happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut39 #-}+happyIn40 :: (()) -> (HappyAbsSyn )+happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn40 #-}+happyOut40 :: (HappyAbsSyn ) -> (())+happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut40 #-}+happyInTok :: (Token') -> (HappyAbsSyn )+happyInTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyInTok #-}+happyOutTok :: (HappyAbsSyn ) -> (Token')+happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOutTok #-}+++happyActOffsets :: HappyAddr+happyActOffsets = HappyA# "\x74\x00\xb3\x00\xab\x00\xa8\x00\xa7\x00\xa9\x00\x00\x00\xac\x00\x00\x00\xa6\x00\x00\x00\xfd\xff\x00\x00\xaa\x00\x00\x00\x9f\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x9d\x00\xfd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\xa2\x00\xa5\x00\x23\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x06\x00\xa0\x00\x9a\x00\x00\x00\x00\x00\x06\x00\x15\x00\x00\x00\x06\x00\x06\x00\x06\x00\x00\x00\x98\x00\x9e\x00\x82\x00\x00\x00\x00\x00\x97\x00\x97\x00\x97\x00\x0c\x00\x0c\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x99\x00\x92\x00\x00\x00\x96\x00\x0b\x00\x0b\x00\x94\x00\x0a\x00\x94\x00\x00\x00\x00\x00\x85\x00\x86\x00\x91\x00\x00\x00\x06\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x90\x00\x8e\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x08\x00\x8b\x00\x00\x00\x8f\x00\x07\x00\x00\x00\x8d\x00\x07\x00\x00\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x93\x00\x00\x00\x46\x00\x00\x00\x0e\x00\x7a\x00\x00\x00\x5b\x00\x00\x00\x73\x00\x00\x00\x59\x00\x00\x00\x28\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x05\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x4a\x00\x00\x00\x75\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x35\x00\x2f\x00\x29\x00\x00\x00\x67\x00\x70\x00\x00\x00\x00\x00\x00\x00\x79\x00\x78\x00\x72\x00\x48\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x77\x00\x76\x00\x6b\x00\x4c\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x31\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\xef\xff\xdf\xff\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x40\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xff\x00\x00\xfc\xff\x00\x00\xfd\xff\x00\x00\xcd\xff\x00\x00\xfe\xff\xfb\xff\xfa\xff\xf6\xff\xf5\xff\x00\x00\xf7\xff\xf9\xff\xc6\xff\x00\x00\xc9\xff\xc7\xff\xc3\xff\xc4\xff\xc2\xff\xc0\xff\xbf\xff\xc1\xff\xc8\xff\xc5\xff\x00\x00\xd6\xff\x00\x00\xad\xff\xbd\xff\x00\x00\xb6\xff\xbc\xff\xbb\xff\xbe\xff\xae\xff\xb6\xff\xce\xff\xd7\xff\x00\x00\xca\xff\xcb\xff\x00\x00\x00\x00\xf4\xff\xf3\xff\xf1\xff\xf0\xff\xee\xff\xeb\xff\x00\x00\x00\x00\x00\x00\xea\xff\xcc\xff\xe4\xff\x00\x00\xd5\xff\xd1\xff\xd4\xff\xd3\xff\x00\x00\xb2\xff\xb2\xff\xb9\xff\xb8\xff\xb7\xff\xb1\xff\x00\x00\x00\x00\xb0\xff\xba\xff\xce\xff\xce\xff\x00\x00\xda\xff\x00\x00\xe5\xff\xe6\xff\x00\x00\x00\x00\x00\x00\xec\xff\x00\x00\xef\xff\x00\x00\xf8\xff\xf2\xff\xed\xff\xe7\xff\xe8\xff\xe9\xff\x00\x00\xe2\xff\xde\xff\x00\x00\xda\xff\xd8\xff\xd9\xff\xd2\xff\xd0\xff\x00\x00\xcf\xff\xb3\xff\xaf\xff\x00\x00\xb5\xff\xdb\xff\xdc\xff\xda\xff\xe3\xff\x00\x00\xda\xff\xe0\xff\xda\xff\xdf\xff\xdd\xff\xb4\xff\xe1\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x04\x00\x23\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x22\x00\x0c\x00\x16\x00\x17\x00\x0c\x00\x0a\x00\x11\x00\x0c\x00\x13\x00\x0c\x00\x19\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x16\x00\x1e\x00\x1f\x00\x10\x00\x18\x00\x19\x00\x05\x00\x24\x00\x15\x00\x03\x00\x09\x00\x05\x00\x0b\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x01\x00\x02\x00\x03\x00\x19\x00\x05\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x12\x00\x13\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x10\x00\x11\x00\x12\x00\x13\x00\x16\x00\x17\x00\x04\x00\x19\x00\x0f\x00\x07\x00\x21\x00\x22\x00\x23\x00\x21\x00\x22\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x19\x00\x1a\x00\x1b\x00\x19\x00\x1a\x00\x1b\x00\x01\x00\x02\x00\x03\x00\x1d\x00\x0b\x00\x1f\x00\x12\x00\x13\x00\x0d\x00\x0e\x00\x18\x00\x19\x00\x19\x00\x0d\x00\x0e\x00\x19\x00\x14\x00\x15\x00\x14\x00\x15\x00\x07\x00\x08\x00\x19\x00\x20\x00\x17\x00\x17\x00\x20\x00\x04\x00\x19\x00\x19\x00\x00\x00\x07\x00\x06\x00\x1c\x00\x0c\x00\x12\x00\x14\x00\x0c\x00\x0b\x00\x06\x00\x04\x00\x0d\x00\x0d\x00\x0c\x00\x06\x00\x04\x00\x0c\x00\x0c\x00\x0b\x00\x06\x00\x04\x00\x07\x00\x04\x00\x0d\x00\x0f\x00\x0a\x00\x09\x00\x04\x00\x04\x00\x0a\x00\x05\x00\x09\x00\x0c\x00\x01\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x19\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x18\x00\x7c\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x0c\x00\x39\x00\x69\x00\x4b\x00\x44\x00\x69\x00\x6d\x00\x4b\x00\x71\x00\x3a\x00\x1f\x00\x20\x00\x0c\x00\x4c\x00\x3b\x00\x4d\x00\x3c\x00\x08\x00\x50\x00\x3d\x00\x6a\x00\x4e\x00\x45\x00\x6a\x00\x45\x00\x4e\x00\x27\x00\x28\x00\x5a\x00\x09\x00\x0a\x00\x26\x00\x29\x00\x5b\x00\x13\x00\x2b\x00\x0f\x00\x2c\x00\x56\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x57\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x58\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x73\x00\x0f\x00\x7d\x00\x65\x00\x66\x00\x67\x00\x78\x00\x65\x00\x66\x00\x67\x00\x7a\x00\x65\x00\x66\x00\x67\x00\x5e\x00\x35\x00\x36\x00\x37\x00\x64\x00\x65\x00\x66\x00\x67\x00\x40\x00\x41\x00\x77\x00\x42\x00\x75\x00\x78\x00\x47\x00\x48\x00\x49\x00\x4e\x00\x48\x00\x49\x00\x5b\x00\x36\x00\x37\x00\x14\x00\x2f\x00\x16\x00\x14\x00\x15\x00\x16\x00\x03\x00\x05\x00\x06\x00\x23\x00\x5f\x00\x24\x00\x72\x00\x67\x00\x54\x00\x3e\x00\x55\x00\x0a\x00\x63\x00\x3d\x00\x3e\x00\x6a\x00\x2d\x00\x21\x00\x20\x00\x21\x00\x53\x00\x54\x00\x4f\x00\x45\x00\x6b\x00\x6d\x00\x46\x00\x11\x00\x50\x00\x51\x00\x03\x00\x7a\x00\x7c\x00\x06\x00\x4d\x00\x62\x00\x63\x00\x0c\x00\x75\x00\x6f\x00\x71\x00\x61\x00\x70\x00\x0c\x00\x6f\x00\x40\x00\x0c\x00\x0c\x00\x5d\x00\x5e\x00\x40\x00\x27\x00\x2d\x00\x31\x00\x32\x00\x23\x00\x2f\x00\x11\x00\x11\x00\x23\x00\x26\x00\x08\x00\x0c\x00\x03\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (1, 82) [+ (1 , happyReduce_1),+ (2 , happyReduce_2),+ (3 , happyReduce_3),+ (4 , happyReduce_4),+ (5 , happyReduce_5),+ (6 , happyReduce_6),+ (7 , happyReduce_7),+ (8 , happyReduce_8),+ (9 , happyReduce_9),+ (10 , happyReduce_10),+ (11 , happyReduce_11),+ (12 , happyReduce_12),+ (13 , happyReduce_13),+ (14 , happyReduce_14),+ (15 , happyReduce_15),+ (16 , happyReduce_16),+ (17 , happyReduce_17),+ (18 , happyReduce_18),+ (19 , happyReduce_19),+ (20 , happyReduce_20),+ (21 , happyReduce_21),+ (22 , happyReduce_22),+ (23 , happyReduce_23),+ (24 , happyReduce_24),+ (25 , happyReduce_25),+ (26 , happyReduce_26),+ (27 , happyReduce_27),+ (28 , happyReduce_28),+ (29 , happyReduce_29),+ (30 , happyReduce_30),+ (31 , happyReduce_31),+ (32 , happyReduce_32),+ (33 , happyReduce_33),+ (34 , happyReduce_34),+ (35 , happyReduce_35),+ (36 , happyReduce_36),+ (37 , happyReduce_37),+ (38 , happyReduce_38),+ (39 , happyReduce_39),+ (40 , happyReduce_40),+ (41 , happyReduce_41),+ (42 , happyReduce_42),+ (43 , happyReduce_43),+ (44 , happyReduce_44),+ (45 , happyReduce_45),+ (46 , happyReduce_46),+ (47 , happyReduce_47),+ (48 , happyReduce_48),+ (49 , happyReduce_49),+ (50 , happyReduce_50),+ (51 , happyReduce_51),+ (52 , happyReduce_52),+ (53 , happyReduce_53),+ (54 , happyReduce_54),+ (55 , happyReduce_55),+ (56 , happyReduce_56),+ (57 , happyReduce_57),+ (58 , happyReduce_58),+ (59 , happyReduce_59),+ (60 , happyReduce_60),+ (61 , happyReduce_61),+ (62 , happyReduce_62),+ (63 , happyReduce_63),+ (64 , happyReduce_64),+ (65 , happyReduce_65),+ (66 , happyReduce_66),+ (67 , happyReduce_67),+ (68 , happyReduce_68),+ (69 , happyReduce_69),+ (70 , happyReduce_70),+ (71 , happyReduce_71),+ (72 , happyReduce_72),+ (73 , happyReduce_73),+ (74 , happyReduce_74),+ (75 , happyReduce_75),+ (76 , happyReduce_76),+ (77 , happyReduce_77),+ (78 , happyReduce_78),+ (79 , happyReduce_79),+ (80 , happyReduce_80),+ (81 , happyReduce_81),+ (82 , happyReduce_82)+ ]++happy_n_terms = 26 :: Int+happy_n_nonterms = 37 :: Int++happyReduce_1 = happySpecReduce_2 0# happyReduction_1+happyReduction_1 happy_x_2+ happy_x_1+ = case happyOut5 happy_x_2 of { happy_var_2 -> + happyIn4+ (happy_var_2+ )}++happyReduce_2 = happySpecReduce_2 0# happyReduction_2+happyReduction_2 happy_x_2+ happy_x_1+ = case happyOut16 happy_x_2 of { happy_var_2 -> + happyIn4+ (happy_var_2+ )}++happyReduce_3 = happySpecReduce_2 0# happyReduction_3+happyReduction_3 happy_x_2+ happy_x_1+ = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn4+ (happy_var_2+ )}++happyReduce_4 = happySpecReduce_1 1# happyReduction_4+happyReduction_4 happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + happyIn5+ (happy_var_1+ )}++happyReduce_5 = happySpecReduce_1 2# happyReduction_5+happyReduction_5 happy_x_1+ = case happyOut7 happy_x_1 of { happy_var_1 -> + happyIn6+ ([happy_var_1]+ )}++happyReduce_6 = happySpecReduce_2 2# happyReduction_6+happyReduction_6 happy_x_2+ happy_x_1+ = case happyOut6 happy_x_1 of { happy_var_1 -> + case happyOut7 happy_x_2 of { happy_var_2 -> + happyIn6+ (happy_var_1 ++ [happy_var_2]+ )}}++happyReduce_7 = happyReduce 5# 3# happyReduction_7+happyReduction_7 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut9 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn7+ (ProdProduction happy_var_1 happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}}++happyReduce_8 = happySpecReduce_1 4# happyReduction_8+happyReduction_8 happy_x_1+ = case happyOutTok happy_x_1 of { (String' happy_var_1) -> + happyIn8+ ([happy_var_1]+ )}++happyReduce_9 = happySpecReduce_0 4# happyReduction_9+happyReduction_9 = happyIn8+ ([]+ )++happyReduce_10 = happySpecReduce_1 5# happyReduction_10+happyReduction_10 happy_x_1+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + happyIn9+ (happy_var_1+ )}++happyReduce_11 = happySpecReduce_1 6# happyReduction_11+happyReduction_11 happy_x_1+ = case happyOut11 happy_x_1 of { happy_var_1 -> + happyIn10+ (ProdTerm happy_var_1+ )}++happyReduce_12 = happySpecReduce_1 7# happyReduction_12+happyReduction_12 happy_x_1+ = case happyOut12 happy_x_1 of { happy_var_1 -> + happyIn11+ ([happy_var_1]+ )}++happyReduce_13 = happySpecReduce_3 7# happyReduction_13+happyReduction_13 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut11 happy_x_1 of { happy_var_1 -> + case happyOut12 happy_x_3 of { happy_var_3 -> + happyIn11+ (happy_var_1 ++ [happy_var_3]+ )}}++happyReduce_14 = happySpecReduce_1 8# happyReduction_14+happyReduction_14 happy_x_1+ = case happyOut13 happy_x_1 of { happy_var_1 -> + happyIn12+ (ProdFactor happy_var_1+ )}++happyReduce_15 = happySpecReduce_1 9# happyReduction_15+happyReduction_15 happy_x_1+ = case happyOut14 happy_x_1 of { happy_var_1 -> + happyIn13+ ([happy_var_1]+ )}++happyReduce_16 = happySpecReduce_2 9# happyReduction_16+happyReduction_16 happy_x_2+ happy_x_1+ = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn13+ (happy_var_1 : happy_var_2+ )}}++happyReduce_17 = happySpecReduce_1 10# happyReduction_17+happyReduction_17 happy_x_1+ = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn14+ (happy_var_1+ )}++happyReduce_18 = happySpecReduce_3 10# happyReduction_18+happyReduction_18 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut15 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + happyIn14+ (ProdRepeatWithAtom happy_var_1 happy_var_3+ )}}++happyReduce_19 = happySpecReduce_2 10# happyReduction_19+happyReduction_19 happy_x_2+ happy_x_1+ = case happyOut15 happy_x_1 of { happy_var_1 -> + happyIn14+ (ProdRepeat1 happy_var_1+ )}++happyReduce_20 = happySpecReduce_1 11# happyReduction_20+happyReduction_20 happy_x_1+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + happyIn15+ (ProdNonterminal happy_var_1+ )}++happyReduce_21 = happySpecReduce_1 11# happyReduction_21+happyReduction_21 happy_x_1+ = case happyOutTok happy_x_1 of { (String' happy_var_1) -> + happyIn15+ (ProdTerminal happy_var_1+ )}++happyReduce_22 = happySpecReduce_3 11# happyReduction_22+happyReduction_22 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15+ (happy_var_2+ )}++happyReduce_23 = happySpecReduce_3 11# happyReduction_23+happyReduction_23 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15+ (ProdOption happy_var_2+ )}++happyReduce_24 = happySpecReduce_3 11# happyReduction_24+happyReduction_24 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut10 happy_x_2 of { happy_var_2 -> + happyIn15+ (ProdRepeat happy_var_2+ )}++happyReduce_25 = happyReduce 5# 12# happyReduction_25+happyReduction_25 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut24 happy_x_2 of { happy_var_2 -> + case happyOut17 happy_x_4 of { happy_var_4 -> + happyIn16+ (happyPrepare happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_26 = happySpecReduce_2 13# happyReduction_26+happyReduction_26 happy_x_2+ happy_x_1+ = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn17+ (happy_var_1 : happy_var_2+ )}}++happyReduce_27 = happySpecReduce_1 13# happyReduction_27+happyReduction_27 happy_x_1+ = case happyOut18 happy_x_1 of { happy_var_1 -> + happyIn17+ ([happy_var_1]+ )}++happyReduce_28 = happyReduce 4# 14# happyReduction_28+happyReduction_28 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + case happyOut19 happy_x_4 of { happy_var_4 -> + happyIn18+ (ProdProduction happy_var_1 [] happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_29 = happySpecReduce_3 14# happyReduction_29+happyReduction_29 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + case happyOut20 happy_x_3 of { happy_var_3 -> + happyIn18+ (ProdProduction happy_var_1 [] (ProdTerm happy_var_3)+ )}}++happyReduce_30 = happySpecReduce_3 15# happyReduction_30+happyReduction_30 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut20 happy_x_3 of { happy_var_3 -> + happyIn19+ (ProdTerm happy_var_3+ )}++happyReduce_31 = happySpecReduce_2 15# happyReduction_31+happyReduction_31 happy_x_2+ happy_x_1+ = case happyOut20 happy_x_2 of { happy_var_2 -> + happyIn19+ (ProdTerm happy_var_2+ )}++happyReduce_32 = happySpecReduce_3 16# happyReduction_32+happyReduction_32 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut21 happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_3 of { happy_var_3 -> + happyIn20+ (happy_var_1 : happy_var_3+ )}}++happyReduce_33 = happySpecReduce_1 16# happyReduction_33+happyReduction_33 happy_x_1+ = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn20+ ([happy_var_1]+ )}++happyReduce_34 = happySpecReduce_3 17# happyReduction_34+happyReduction_34 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut22 happy_x_1 of { happy_var_1 -> + happyIn21+ (ProdFactor happy_var_1+ )}++happyReduce_35 = happySpecReduce_2 17# happyReduction_35+happyReduction_35 happy_x_2+ happy_x_1+ = case happyOut22 happy_x_1 of { happy_var_1 -> + happyIn21+ (ProdFactor happy_var_1+ )}++happyReduce_36 = happySpecReduce_2 18# happyReduction_36+happyReduction_36 happy_x_2+ happy_x_1+ = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut22 happy_x_2 of { happy_var_2 -> + happyIn22+ (happy_var_1 : happy_var_2+ )}}++happyReduce_37 = happySpecReduce_0 18# happyReduction_37+happyReduction_37 = happyIn22+ ([]+ )++happyReduce_38 = happySpecReduce_1 19# happyReduction_38+happyReduction_38 happy_x_1+ = case happyOutTok happy_x_1 of { (String' happy_var_1) -> + happyIn23+ (ProdTerminal happy_var_1+ )}++happyReduce_39 = happySpecReduce_1 19# happyReduction_39+happyReduction_39 happy_x_1+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + happyIn23+ (ProdNonterminal happy_var_1+ )}++happyReduce_40 = happySpecReduce_2 20# happyReduction_40+happyReduction_40 happy_x_2+ happy_x_1+ = case happyOut25 happy_x_1 of { happy_var_1 -> + case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn24+ (happy_var_1 ++ happy_var_2+ )}}++happyReduce_41 = happySpecReduce_1 20# happyReduction_41+happyReduction_41 happy_x_1+ = case happyOut25 happy_x_1 of { happy_var_1 -> + happyIn24+ (happy_var_1+ )}++happyReduce_42 = happySpecReduce_3 21# happyReduction_42+happyReduction_42 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut26 happy_x_3 of { happy_var_3 -> + happyIn25+ (happy_var_3+ )}++happyReduce_43 = happySpecReduce_1 22# happyReduction_43+happyReduction_43 happy_x_1+ = happyIn26+ ([]+ )++happyReduce_44 = happySpecReduce_1 22# happyReduction_44+happyReduction_44 happy_x_1+ = happyIn26+ ([]+ )++happyReduce_45 = happySpecReduce_3 22# happyReduction_45+happyReduction_45 happy_x_3+ happy_x_2+ happy_x_1+ = happyIn26+ ([]+ )++happyReduce_46 = happySpecReduce_1 22# happyReduction_46+happyReduction_46 happy_x_1+ = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn26+ (happy_var_1+ )}++happyReduce_47 = happySpecReduce_3 23# happyReduction_47+happyReduction_47 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn27+ (happy_var_1 : happy_var_3+ )}}++happyReduce_48 = happySpecReduce_3 23# happyReduction_48+happyReduction_48 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn27+ (happy_var_3+ )}++happyReduce_49 = happySpecReduce_0 23# happyReduction_49+happyReduction_49 = happyIn27+ ([]+ )++happyReduce_50 = happySpecReduce_1 24# happyReduction_50+happyReduction_50 happy_x_1+ = happyIn28+ (()+ )++happyReduce_51 = happySpecReduce_0 24# happyReduction_51+happyReduction_51 = happyIn28+ (()+ )++happyReduce_52 = happySpecReduce_3 25# happyReduction_52+happyReduction_52 happy_x_3+ happy_x_2+ happy_x_1+ = happyIn29+ (()+ )++happyReduce_53 = happySpecReduce_2 26# happyReduction_53+happyReduction_53 happy_x_2+ happy_x_1+ = happyIn30+ (()+ )++happyReduce_54 = happySpecReduce_1 26# happyReduction_54+happyReduction_54 happy_x_1+ = happyIn30+ (()+ )++happyReduce_55 = happySpecReduce_1 27# happyReduction_55+happyReduction_55 happy_x_1+ = happyIn31+ (()+ )++happyReduce_56 = happySpecReduce_1 27# happyReduction_56+happyReduction_56 happy_x_1+ = happyIn31+ (()+ )++happyReduce_57 = happySpecReduce_1 27# happyReduction_57+happyReduction_57 happy_x_1+ = happyIn31+ (()+ )++happyReduce_58 = happySpecReduce_1 27# happyReduction_58+happyReduction_58 happy_x_1+ = happyIn31+ (()+ )++happyReduce_59 = happySpecReduce_1 27# happyReduction_59+happyReduction_59 happy_x_1+ = happyIn31+ (()+ )++happyReduce_60 = happySpecReduce_1 27# happyReduction_60+happyReduction_60 happy_x_1+ = happyIn31+ (()+ )++happyReduce_61 = happySpecReduce_1 27# happyReduction_61+happyReduction_61 happy_x_1+ = happyIn31+ (()+ )++happyReduce_62 = happySpecReduce_1 27# happyReduction_62+happyReduction_62 happy_x_1+ = happyIn31+ (()+ )++happyReduce_63 = happySpecReduce_1 27# happyReduction_63+happyReduction_63 happy_x_1+ = happyIn31+ (()+ )++happyReduce_64 = happySpecReduce_1 27# happyReduction_64+happyReduction_64 happy_x_1+ = happyIn31+ (()+ )++happyReduce_65 = happySpecReduce_3 28# happyReduction_65+happyReduction_65 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut33 happy_x_2 of { happy_var_2 -> + happyIn32+ (yaccPrepare happy_var_2+ )}++happyReduce_66 = happySpecReduce_1 29# happyReduction_66+happyReduction_66 happy_x_1+ = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn33+ ([happy_var_1]+ )}++happyReduce_67 = happySpecReduce_2 29# happyReduction_67+happyReduction_67 happy_x_2+ happy_x_1+ = case happyOut33 happy_x_1 of { happy_var_1 -> + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn33+ (happy_var_1 ++ [happy_var_2]+ )}}++happyReduce_68 = happySpecReduce_1 30# happyReduction_68+happyReduction_68 happy_x_1+ = case happyOut35 happy_x_1 of { happy_var_1 -> + happyIn34+ (happy_var_1+ )}++happyReduce_69 = happySpecReduce_3 30# happyReduction_69+happyReduction_69 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn34+ (ProdFactor happy_var_2+ )}++happyReduce_70 = happyReduce 4# 31# happyReduction_70+happyReduction_70 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOutTok happy_x_1 of { (CIdent' happy_var_1) -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn35+ (ProdProduction happy_var_1 [] (ProdTerm [ProdFactor happy_var_3])+ ) `HappyStk` happyRest}}++happyReduce_71 = happySpecReduce_2 32# happyReduction_71+happyReduction_71 happy_x_2+ happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_2 of { happy_var_2 -> + happyIn36+ (happy_var_1 ++ [happy_var_2]+ )}}++happyReduce_72 = happySpecReduce_2 32# happyReduction_72+happyReduction_72 happy_x_2+ happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn36+ (happy_var_1+ )}++happyReduce_73 = happySpecReduce_0 32# happyReduction_73+happyReduction_73 = happyIn36+ ([]+ )++happyReduce_74 = happySpecReduce_3 33# happyReduction_74+happyReduction_74 happy_x_3+ happy_x_2+ happy_x_1+ = happyIn37+ (()+ )++happyReduce_75 = happyReduce 4# 33# happyReduction_75+happyReduction_75 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = happyIn37+ (()+ ) `HappyStk` happyRest++happyReduce_76 = happySpecReduce_2 33# happyReduction_76+happyReduction_76 happy_x_2+ happy_x_1+ = happyIn37+ (()+ )++happyReduce_77 = happySpecReduce_0 33# happyReduction_77+happyReduction_77 = happyIn37+ (()+ )++happyReduce_78 = happySpecReduce_1 34# happyReduction_78+happyReduction_78 happy_x_1+ = case happyOutTok happy_x_1 of { (Ident' happy_var_1) -> + happyIn38+ (ProdTerminal happy_var_1+ )}++happyReduce_79 = happySpecReduce_1 34# happyReduction_79+happyReduction_79 happy_x_1+ = case happyOutTok happy_x_1 of { (String' happy_var_1) -> + happyIn38+ (ProdTerminal happy_var_1+ )}++happyReduce_80 = happySpecReduce_2 35# happyReduction_80+happyReduction_80 happy_x_2+ happy_x_1+ = happyIn39+ (()+ )++happyReduce_81 = happySpecReduce_1 36# happyReduction_81+happyReduction_81 happy_x_1+ = happyIn40+ (()+ )++happyReduce_82 = happySpecReduce_0 36# happyReduction_82+happyReduction_82 = happyIn40+ (()+ )++happyNewToken action sts stk [] =+ happyDoAction 25# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = happyDoAction i tk action sts stk tks in+ case tk of {+ EbnfInput -> cont 1#;+ HappyInput -> cont 2#;+ YaccInput -> cont 3#;+ Ident' happy_dollar_dollar -> cont 4#;+ CIdent' happy_dollar_dollar -> cont 5#;+ SemiColon -> cont 6#;+ Colon -> cont 7#;+ DoubleColon -> cont 8#;+ DoublePercent -> cont 9#;+ Percent -> cont 10#;+ Bar -> cont 11#;+ OpenBrace -> cont 12#;+ ClosingBrace -> cont 13#;+ Dot -> cont 14#;+ Equal -> cont 15#;+ Plus -> cont 16#;+ OpenBrack -> cont 17#;+ ClosingBrack -> cont 18#;+ OpenParen -> cont 19#;+ ClosingParen -> cont 20#;+ Slash -> cont 21#;+ String' happy_dollar_dollar -> cont 22#;+ Symbol' happy_dollar_dollar -> cont 23#;+ Number' _ -> cont 24#;+ _ -> happyError' (tk:tks)+ }++happyError_ tk tks = happyError' (tk:tks)++newtype HappyIdentity a = HappyIdentity a+happyIdentity = HappyIdentity+happyRunIdentity (HappyIdentity a) = a++instance Monad HappyIdentity where+ return = HappyIdentity+ (HappyIdentity p) >>= q = q p++happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b+happyThen = (>>=)+happyReturn :: () => a -> HappyIdentity a+happyReturn = (return)+happyThen1 m k tks = (>>=) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> HappyIdentity a+happyReturn1 = \a tks -> (return) a+happyError' :: () => [(Token')] -> HappyIdentity a+happyError' = HappyIdentity . happyError++ebnf2psParser tks = happyRunIdentity happySomeParser where+ happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut4 x))++happySeq = happyDontSeq+++theEbnfParser = ebnf2psParser . ebnf_postlexer . lexer . uncomment+theHappyParser = ebnf2psParser . happy_postlexer . lexer . unlit+theYaccParser = ebnf2psParser . yacc_postlexer . lexer . yaccpreprocessor+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<built-in>" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp ++{-# LINE 30 "templates/GenericTemplate.hs" #-}+++data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList++++++{-# LINE 51 "templates/GenericTemplate.hs" #-}++{-# LINE 61 "templates/GenericTemplate.hs" #-}++{-# LINE 70 "templates/GenericTemplate.hs" #-}++infixr 9 `HappyStk`+data HappyStk a = HappyStk a (HappyStk a)++-----------------------------------------------------------------------------+-- starting the parse++happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll++-----------------------------------------------------------------------------+-- Accepting the parse++-- If the current token is 0#, it means we've just accepted a partial+-- 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+happyAccept j tk st sts (HappyStk ans _) = + (happyTcHack j (happyTcHack st)) (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++happyDoAction i tk st+ = {- nothing -}+++ case action of+ 0# -> {- nothing -}+ happyFail i tk st+ -1# -> {- nothing -}+ happyAccept i tk st+ n | (n Happy_GHC_Exts.<# (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 -}+++ 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 (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#))+ then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i)+ else False+ (action)+ | check = indexShortOffAddr happyTable off_i+ | otherwise = indexShortOffAddr happyDefActions st++{-# LINE 130 "templates/GenericTemplate.hs" #-}+++indexShortOffAddr (HappyA# arr) off =+ 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#)))+ low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+ off' = off Happy_GHC_Exts.*# 2#++++++data HappyAddr = HappyA# Happy_GHC_Exts.Addr#+++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++{-# LINE 163 "templates/GenericTemplate.hs" #-}++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =+ let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+-- trace "shifting the error token" $+ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_0 nt fn j tk st@((action)) sts stk+ = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn 0# tk st sts stk+ = 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)++happyMonadReduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))+ where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++happyMonad2Reduce k nt fn 0# tk st sts stk+ = happyFail 0# tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))+ where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ drop_stk = happyDropStk k stk++ (off) = indexShortOffAddr happyGotoOffsets st1+ (off_i) = (off Happy_GHC_Exts.+# nt)+ (new_state) = indexShortOffAddr happyTable off_i+++++happyDrop 0# l = l+happyDrop n (HappyCons (_) (t)) = happyDrop (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) t++happyDropStk 0# l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Happy_GHC_Exts.-# (1#::Happy_GHC_Exts.Int#)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction+++happyGoto nt j tk st = + {- nothing -}+ happyDoAction j tk new_state+ where (off) = indexShortOffAddr happyGotoOffsets st+ (off_i) = (off Happy_GHC_Exts.+# nt)+ (new_state) = indexShortOffAddr happyTable off_i+++++-----------------------------------------------------------------------------+-- Error recovery (0# is the error token)++-- parse error if we are in recovery and we fail again+happyFail 0# tk old_st _ stk =+-- trace "failing" $ + happyError_ 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+ for now --SDM++-- 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))+-}++-- 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)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions+++happyTcHack :: Happy_GHC_Exts.Int# -> a -> a+happyTcHack x y = y+{-# INLINE happyTcHack #-}+++-----------------------------------------------------------------------------+-- Seq-ing. If the --strict flag is given, then Happy emits +-- happySeq = happyDoSeq+-- otherwise it emits+-- happySeq = happyDontSeq++happyDoSeq, happyDontSeq :: a -> b -> b+happyDoSeq a b = a `seq` b+happyDontSeq a b = b++-----------------------------------------------------------------------------+-- Don't inline any functions from the template. GHC has a nasty habit+-- of deciding to inline happyGoto everywhere, which increases the size of+-- the generated parser quite a bit.+++{-# NOINLINE happyDoAction #-}+{-# NOINLINE happyTable #-}+{-# NOINLINE happyCheck #-}+{-# NOINLINE happyActOffsets #-}+{-# NOINLINE happyGotoOffsets #-}+{-# NOINLINE happyDefActions #-}++{-# NOINLINE happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
+ src/AbstractSyntax.hs view
@@ -0,0 +1,20 @@+module AbstractSyntax (Production (..)) where+-- Copyright 1994 by Peter Thiemann+-- Last Modified By: M. Walter++data Production+ = ProdFile [Production]+ | ProdProduction String [String] Production -- optional print name+ | ProdTerm [Production] -- an alternative of terms+ | ProdFactor [Production] -- a sequence of factors+ | ProdNonterminal String+ | ProdTerminal String+ | ProdOption Production+ | ProdRepeat Production+ | ProdRepeatWithAtom Production Production+ | ProdRepeat1 Production+ | ProdPlus -- a helper+ | ProdSlash Production -- another helper+ | ProdEmpty+ deriving Eq+
+ src/Color.hs view
@@ -0,0 +1,133 @@+-- -*- Mode: Haskell -*- +-- Copyright 1994 by Peter Thiemann+-- Color.hs --- string converter for colors+-- Author : Peter Thiemann+-- Created On : Thu Dec 2 16:58:33 1993+-- Last Modified By: Peter Thiemann+-- Last Modified On: Fri Dec 3 14:13:34 1993+-- Update Count : 3+-- Status : Unknown, Use with caution!+-- +-- $Locker: $+-- $Log: Color.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.1 1994/03/15 15:34:53 thiemann+-- Initial revision+--+--+-- Last Modified By: M. Walter+++module Color where+-- (Color (..), lookupColor, showsColor, showsAColor, prepareColors)++import Data.Char+import Numeric++type Color = (Int, Int, Int)++noColor :: Color+noColor = (-1, -1, -1)++{-+readColor :: String -> Color+readColor = readColor1 . map toLower++readColor1 :: String -> Color+readColor1 ('b':'l':'a':_) = 0+readColor1 ('b':'l':'u':_) = 1+readColor1 ('g':_) = 2+readColor1 ('c':_) = 3+readColor1 ('r':_) = 4+readColor1 ('m':_) = 5+readColor1 ('y':_) = 6+readColor1 ('w':_) = 7+readColor1 _ = -1+-}+++-- Gofer-like stuff:+ljustify' :: Int -> String -> String+ljustify' n s = s ++ space' (max 0 (n - length 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+-- ++lookupColor :: String -> [(String,(Int,Int,Int))] -> (Int,Int,Int)+lookupColor colorName colorTable =+ head [(r,g,b) | (c,(r,g,b)) <- colorTable, c == map toLower colorName]++showsColor :: Color -> ShowS+showsColor (r,g,b) = showString " (" . shows r . showChar ',' .+ shows g . showChar ',' .+ shows b . showChar ')'+showsAColor :: Color -> String -> ShowS+showsAColor color str = showString ('\t': ljustify' 16 str) . showsColor color . showChar '\n'+++-- Folgendes Stück abgeändert und durch untiges ersetzt, weil \\ nicht +-- verfügbar, V. Wysk:+--+-- prepareColors rgbFile colors = +-- decodeColors (map (map toLower) colors) (fallBackRgb++parsedRgbFile) []+-- where parsedRgbFile = (map parseLine (lines rgbFile))+--+-- decodeColors [] parsedRgbFile decoded = decoded+-- decodeColors clrs [] decoded = [(name,(128,128,128)) | name <- clrs ]++decoded+-- decodeColors clrs ((r,g,b,name):parsedRgbFile) decoded+-- = decodeColors (clrs \\ found) parsedRgbFile (foundDecoded++decoded)+-- where found = [ c | c <- clrs, name == c ]+-- foundDecoded = [ (c,(r,g,b)) | c <- found ]++prepareColors rgbFile colors = + decodeColors (map (map toLower) colors) (fallBackRgb++parsedRgbFile)+ where parsedRgbFile = [parseLine l | l <- lines rgbFile, notComment l]+ notComment ('!':_) = False+ notComment _ = True++decodeColors :: [String] -> [(Int,Int,Int,String)] -> [(String,(Int,Int,Int))] ++decodeColors clrs parsedRgbFile = [ (name,(r,g,b)) | name <- clrs, + (r,g,b,name') <- parsedRgbFile,+ name == name' ]+-- bis hier+++parseLine str = let (r,restr):_ = readDec (skipWhite str)+ (g,restg):_ = readDec (skipWhite restr)+ (b,restb):_ = readDec (skipWhite restg)+ name = map toLower (skipWhite restb)+ in (r,g,b,name)+ where skipWhite = dropWhile isSpace++fallBackRgb :: [(Int,Int,Int,String)]+fallBackRgb = [+ ( 0, 0, 0,"black"),+ ( 0, 0,255,"blue"),+ ( 0,255, 0,"green"),+ ( 0,255,255,"cyan"),+ (255, 0, 0,"red"),+ (255, 0,255,"magenta"),+ (255,255, 0,"yellow"),+ (255,255,255,"white")]++showsPsColor (r,g,b) = showChar ' ' . shows r .+ showChar ' ' . shows g .+ showChar ' ' . shows b .+ showString " scol "++showsFigColor (r,g,b) = showChar ' ' . shows (minPosition 0 (-1,32768*32768)+ [ (x-r)*(x-r) + (y-g)*(y-g) + (z-b)*(z-b) | (x,y,z,_) <- fallBackRgb ])++--+-- find position of minimal element in list+--+minPosition i (pos,min) [] = pos+minPosition i (pos,min) (x:rest) | x < min = minPosition (i+1) (i,x) rest+ | otherwise = minPosition (i+1) (pos,min) rest
+ src/CommandLine.hs view
@@ -0,0 +1,102 @@+module CommandLine (parse_cmds) where+import System.IO+import System.Environment++defaultArgs :: Args+defaultArgs = MkArgs "Times-Roman" 10 "black" "Times-Roman" 10 "black" "white" "black" "Times-Roman" 10 "black" "white" "black" "black" 500 500 30 100 200 "rgb.txt" False False False False True False False False False++usage :: IO ()+usage = putStr "Usage: prog [-titleFont String] [-titleScale Int] [-titleColor String] [-ntFont String] [-ntScale Int] [-ntColor String] [-ntBg String] [-ntBoxColor String] [-tFont String] [-tScale Int] [-tColor String] [-tBg String] [-tBoxColor String] [-lineColor String] [-borderDistX Int] [-borderDistY Int] [-lineWidth Int] [-fatLineWidth Int] [-arrowSize Int] [-rgbFileName String] [-happy] [-yacc] [(+|-)simplify] [(+|-)unfold] [(+|-)ps] [(+|-)fig] [(+|-)ebnf] [-help] [-verbose]\n" ++data Args = MkArgs String Int String String Int String String String String Int String String String String Int Int Int Int Int String Bool Bool Bool Bool Bool Bool Bool Bool Bool deriving ()+type ProgType = String -> Int -> String -> String -> Int -> String -> String -> String -> String -> Int -> String -> String -> String -> String -> Int -> Int -> Int -> Int -> Int -> String -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> [String] -> IO ()++parse_args :: ProgType -> Args -> [String] -> IO ()+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-titleFont":rest)+ = readstring (\str -> parse_args prog (MkArgs str x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-titleScale":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 val x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-titleColor":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 str x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ntFont":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 str x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ntScale":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 val x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ntColor":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 str x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ntBg":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 str x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ntBoxColor":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 str x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-tFont":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 str x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-tScale":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 val x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-tColor":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 str x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-tBg":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 str x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-tBoxColor":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 str x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-lineColor":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 str x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-borderDistX":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 val x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-borderDistY":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 val x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-lineWidth":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 val x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-fatLineWidth":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 val x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-arrowSize":rest)+ = readval reads (\val -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 val x20 x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-rgbFileName":rest)+ = readstring (\str -> parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 str x21 x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-happy":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 True x22 x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-yacc":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 True x23 x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-simplify":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 False x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("+simplify":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 True x24 x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-unfold":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 False x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("+unfold":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 True x25 x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ps":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 False x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("+ps":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 True x26 x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-fig":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 False x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("+fig":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 True x27 x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-ebnf":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 False x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("+ebnf":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 True x28 x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-help":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 True x29)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) ("-verbose":rest)+ = readbool (parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 True)) rest+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) (('-': _) :rest)+ = usage+parse_args prog (MkArgs x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29) rest = prog x1 x2 x3 x4 x5 x6 x7 x8 x9 x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x20 x21 x22 x23 x24 x25 x26 x27 x28 x29 rest++parse_cmds :: ProgType -> IO ()+parse_cmds prog = getArgs >>= parse_args prog defaultArgs++readbool :: ([String] -> IO ()) -> [String] -> IO ()+readbool f = f++readstring :: (String -> [String] -> IO ()) -> [String] -> IO ()+readstring f (str: rest) = f str rest+readstring f [] = usage++readval :: (Read a) => ReadS a -> (a -> [String] -> IO ()) -> [String]+ -> IO ()+readval readsfn f (str: rest)+ = case readsfn str of+ ((val, ""):_) -> f val rest+ _ -> usage
+ src/Ebnf2ps.hs view
@@ -0,0 +1,257 @@+-- -*- Mode: Haskell -*- +-- Copyright © 1994,1998 by Peter Thiemann+-- Ebnf2ps.hs --- the driver module for the syntax diagram generator+-- Author : Peter Thiemann+-- Created On : Fri Aug 27 09:09:15 1993+--++module Main (main)+where++import Version+import IOSupplement+import CommandLine (parse_cmds)+import StringMatch (stringMatch)+import Fonts (FONT, makeFont)+import Ebnf2psParser (theEbnfParser, theHappyParser, theYaccParser)+import AbstractSyntax+import GrammarTransform (simplify, happysimplify, yaccsimplify, happysimplifyExt, yaccsimplifyExt)+import GrammarUnfold (GrammarInfo(..), rawEBNFInput, rawHappyInput, rawYaccInput, getReduces, getRedProds, getEmpties, getProdsInfo)+import EbnfLayout+import Fig31Output (fig31ShowsWrapper)+import PsOutput (psShowsWrapper)+import EbnfOutput (genEbnfFile)+import Defaults (afmPathDefault, ebnfInputDefault, rgbPathDefault)+import PathExpansion (expandPath) +import Color+import Info+import System.Time+import System.Environment+import Control.Monad+import Numeric++--------------------------------------------------------------------------------+main :: IO () +main = parse_cmds program+--------------------------------------------------------------------------------+program + :: String -> Int -> String -- titleFont, titleScale, titleColor+ -> String -> Int -> String -> String -> String -- ntFont, ntScale, ntColor, ntBoxColor+ -> String -> Int -> String -> String -> String -- tFont, tScale, tColor, tBoxColor+ -> String -- lineColor+ -> Int -> Int -- borderDistX, borderDistY+ -> Int -> Int -- lineWidth, fatLineWidth+ -> Int -- arrowSize+ -> String -- rgbFileName+ -> Bool -- happyInput+ -> Bool -- yaccInput+ -> Bool -- +simplify+ -> Bool -- +unfold+ -> Bool -- +ps+ -> Bool -- +fig + -> Bool -- +ebnf+ -> Bool -- help+ -> Bool -- verbose+ -> [String] -> IO ()+program+ titleFontName titleFontScale titleColor+ ntFontName ntFontScale ntColor ntBg ntBoxColor+ tFontName tFontScale tColor tBg tBoxColor+ lineColor + borderDistX borderDistY+ lineWidth fatLineWidth+ arrowSize + rgbFileName+ happyInput+ yaccInput+ doSimplify+ doUnfold+ psOutput + fig31Output+ ebnfOutput+ helpFlag verbose strs+ | helpFlag =+ do progName <- getProgName+ putStrLn ("Ebnf2ps Version " ++version)+ putStrLn ("\nUsage: "++progName++" [options] Grammarfile Nonterminal ... [-- Nonterminal ...]")+ putStr (unlines usageBlurb)+ | length strs < 2 =+ putStrLn "Grammarfile and one Nonterminal required"+ | doUnfold && null unfold_nonterminals = + do putStrLn "Nothing to unfold:"+ putStrLn ("Grammarfile: "++bnfName)+ putStr "Nonterminals: "+ putStr (unlines nonterminals)+ putStrLn ""+ putStr "Unfolded Nonterminals: "+ putStr (unlines unfold_nonterminals)+ putStrLn ""+ | otherwise =+ do ct <- getClockTime+ calt <- toCalendarTime ct+ let dateOutput = calendarTimeToString calt+ putStrLn ("Grammarfile: "++bnfName)+ putStrLn ("doUnfold = "++show doUnfold)+ putStr "Nonterminals: "+ putStrLn (unlines nonterminals)+ putStr "Unfolded Nonterminals: "+ putStrLn (unlines unfold_nonterminals)+ afmPath' <- getPath "AFMPATH" afmPathDefault+ afmPath <- expandPath afmPath'+ titleAFM <- readPathFile afmPath (titleFontName++".afm")+ ntAFM <- readPathFile afmPath (ntFontName++".afm")+ tAFM <- readPathFile afmPath (tFontName++".afm")+ let+ sc = \rgbFileContents ->+ let colorTable = prepareColors rgbFileContents+ [ntColor,tColor,lineColor,ntBoxColor,tBoxColor,ntBg,tBg,titleColor]+ colorInfo@(c1,c2,c3,c4,c5,c6,c7,c8) = (lookupColor ntColor colorTable,+ lookupColor tColor colorTable,+ lookupColor lineColor colorTable,+ lookupColor ntBoxColor colorTable,+ lookupColor tBoxColor colorTable,+ lookupColor ntBg colorTable,+ lookupColor tBg colorTable,+ lookupColor titleColor colorTable)+ info = (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize,+ makeFont titleFontName titleFontScale titleAFM,+ makeFont ntFontName ntFontScale ntAFM,+ makeFont tFontName tFontScale tAFM,+ colorInfo)+ in do+ message ("using colors:\n"+++ (showsAColor c1 "ntColor" .+ showsAColor c2 "tColor" .+ showsAColor c3 "lineColor" . + showsAColor c4 "ntBoxColor" .+ showsAColor c5 "tBoxColor" .+ showsAColor c6 "ntBg" .+ showsAColor c7 "tBg" . + showsAColor c8 "titleColor")+ "from rgbPathDefault: "++show rgbPathDefault)+ inputPath <- getPath "EBNFINPUTS" ebnfInputDefault+ message ("generating nonterminals: "++show nonterminals+++ "\nfrom "++bnfName+++ "\nusing input path "++show inputPath)+ bnfContent <- readPathFile inputPath bnfName+ let theParser | happyInput = theHappyParser+ | yaccInput = theYaccParser+ | otherwise = theEbnfParser+ getInfo | happyInput = rawHappyInput ebnfOutput+ | yaccInput = rawYaccInput ebnfOutput+ | otherwise = rawEBNFInput+ usingInput| happyInput = "happyInput"+ | yaccInput = "yaccInput"+ | otherwise = "ebnfInput"+ rawInput = theParser bnfContent+ grammarinfo = getInfo doSimplify doUnfold unfold_nonterminals rawInput+ prods = getProdsInfo grammarinfo+ message ("using "++usingInput)+ message "empty productions"+ domessages True (getEmpties grammarinfo)+ domessage doUnfold "unfold nonterminals"+ domessages doUnfold (getReduces grammarinfo)+ domessage doUnfold "in productions"+ domessages doUnfold (getRedProds grammarinfo)+ domessage ebnfOutput ("produce EBNF file from "++usingInput)+ writeEbnf bnfName grammarinfo+ message "produce layout and output"+ writeAll outExtension (layoutAll (outWrapper dateOutput) info prods nonterminals)+ + rgbPath <- getPath "RGBPATH" rgbPathDefault+ rgbRead <- readRGBPathFile rgbPath rgbFileName+ case rgbRead of + [] -> message "\nColor database not found, using fall back data" >> sc ""+ _ -> sc rgbRead+ where+ (bnfName, nonterminals, unfold_nonterminals) = matchInput strs+ (outWrapper, outExtension)+ | fig31Output = (const fig31ShowsWrapper, ".fig")+ | otherwise = (psShowsWrapper, ".eps")+ message = domessage True+ domessage flag what = when (verbose && flag) + (putStrLn what)+ domessages flag strs = when (verbose && flag)+ (mapM_ (putStrLn . ('\t':)) strs)+ writeEbnf file grammar_info =+ let fileName = file++".BNF" in+ when ebnfOutput $+ do when verbose (putStrLn ('\t':fileName))+ catch (writeFile fileName (genEbnfFile file grammar_info))+ (\e -> putStrLn ("Problem writing "++fileName))++--------------------------------------------------------------------------------+layoutAll :: WrapperType -> INFO -> [Production] -> [String] -> [(String, String)]+layoutAll wrapper info prods nonterminals =+ [ (ntName, wrapper ntName info (makePictureLayout info prod) "")+ | prod@(ProdProduction ntName ntAliases _) <- prods,+ any (flip stringMatch ntName) nonterminals ]+--------------------------------------------------------------------------------++usageBlurb =+ [ "",+ "where options may be chosen from the following list:",+ "",+ " -titleFont <font>\tPostScript font used for diagrams (default \"Times-Roman\")",+ " -titleScale <int>\tpointsize of typeface for diagrams (default \"10\")",+ " -titleColor <color>\tcolor of typeface for diagrams (default \"black\")",+ " -ntFont <font>\tPostScript font used for nonterminals (default \"Times-Roman\")",+ " -ntScale <int>\tpointsize of typeface for nonterminals (default \"10\")",+ " -ntColor <color>\tcolor of typeface for nonterminals (default \"black\")",+ " -ntBg <color>\tbackground color of typeface for nonterminals (default \"white\")",+ " -ntBoxColor <color>\tused for boxes (nonterminals). Default: \"black\"", + " -tFont <font>\tPostScript font used for terminal strings (default \"Times-Roman\")",+ " -tScale <int>\tpointsize of typeface for terminals (default \"10\")",+ " -tColor <color>\tcolor of typeface for terminals (default \"black\")",+ " -tBg <color>\tbackground color of typeface for terminals (default \"white\")",+ " -tBoxColor <color>\tused for boxes (terminals). Default: \"black\"",+ " -lineColor <color>\tcolor used for connecting lines (default \"black\")",+ " -borderDistX <int>\thorizontal distance of objects from their container (default \"500\")",+ " -borderDistY <int>\tvertical distance of objects from their container (default \"500\")",+ " -lineWidth <int>\tused for connecting lines (default \"30\")",+ " -fatLineWidth <int>\tused for boxes (default \"100\")",+ " -arrowSize <int>\tsize of (invisible) box containing an arrow (default \"200\")",+ " -rgbFileName <filename>\tfile name for color definitions (default \"rgb.txt\")",+ " -happy \taccept happy input format",+ " -yacc \taccept yacc/bison input format",+ " +ps \tproduce encapulated PostScript output (default)",+ " +fig \tproduce fig output (FORMAT 3.1)",+ " +ebnf \tproduce EBNF grammar (\".BNF\") for yacc or happy input format files",+ " +simplify \tsimplify productions (experimental)",+ " +unfold \treplace nonterminals in productions (experimental)",+ " -verbose \tprint some progress messages",+ " -help \tproduces this list",+ "",+ "Happy is a parser generator system (LALR(1)) for Haskell, similar to the tool yacc for C.",+ "Only the first occurrence of an option is recognized.",+ "Environment variables:",+ "",+ " AFMPATH\tsearch path for Adobe Font Metric files",+ " EBNFINPUTS\tsearch path for BNFfiles",+ " RGBPATH\tsearch path for color definitions"+ ]++--------------------------------------------------------------------------------++matchInput :: [String] -> (String, [String], [String])+matchInput (bnfName:more) = (bnfName,nonterminals, red_nonterminals)+ where (nonterminals,red_nonterminals) = f more []+ f [] nts = (nts, [])+ f ("--":rest) nts = (nts, rest)+ f (c:cs) nts = f cs (c:nts)++writeAll ext [] = putStr "\n"+writeAll ext ((ntName, content): more) =+ do catch (writeFile fileName content)+ (\e -> putStr ("Problem writing "++fileName))+ writeNext+ where+ writeNext = writeAll ext more + fileName = ntName ++ ext++--------------------------------------------------------------------------------++str2int :: String -> Int+str2int s = case readDec s of+ [] -> 0+ (x,_):_ -> x
+ src/Ebnf2psParser.ly view
@@ -0,0 +1,227 @@+Ebnf2psParser.ly --- happy grammar for Ebnf2ps input+(1) A happy specification for a grammar in EBNF+(2) A happy specification for the happy input language+(3) A happy specification for the yacc input language+++> {+> module Ebnf2psParser (theEbnfParser, theHappyParser, theYaccParser) where+> import AbstractSyntax+> import Lexer+> import List+> import ParseAux+> }+++> %name ebnf2psParser+> %tokentype { Token' }+> %token+> EBNF { EbnfInput } +> HAPPY { HappyInput }+> YACC { YaccInput }+> id_tok { Ident' $$ }+> cid_tok { CIdent' $$ }+> ";" { SemiColon }+> ":" { Colon }+> "::" { DoubleColon }+> "%%" { DoublePercent }+> "%" { Percent }+> "|" { Bar }+> "{" { OpenBrace }+> "}" { ClosingBrace }+> "." { Dot }+> "=" { Equal }+> "+" { Plus }+> "[" { OpenBrack }+> "]" { ClosingBrack }+> "(" { OpenParen }+> ")" { ClosingParen }+> "/" { Slash }+> any_string { String' $$ }+> any_symbol { Symbol' $$ }+> number { Number' _ }+++> %%++> ebnf2psparse :: { [Production] }+> ebnf2psparse : EBNF ebnfInput { $2 }+> | HAPPY happyInput { $2 }+> | YACC yaccInput { $2 }+++(1) happy specification for a grammar in EBNF++> ebnfInput :: { [Production] }+> ebnfInput : ebnfProductions { $1 }++> ebnfProductions :: { [Production] }+> ebnfProductions : ebnfProduction { [$1] }+> | ebnfProductions ebnfProduction { $1 ++ [$2] }++> ebnfProduction :: { Production }+> ebnfProduction : ebnfNonterminal +> ebnfOptString "=" ebnfTerm ";" { ProdProduction $1 $2 $4 }+ +> ebnfOptString :: { [String] }+> ebnfOptString : any_string { [$1] }+> | { [] }++> ebnfNonterminal :: { String }+> ebnfNonterminal : id_tok { $1 }++> ebnfTerm :: { Production }+> ebnfTerm : ebnfFactors { ProdTerm $1 } ++> ebnfFactors :: { [Production] }+> ebnfFactors : ebnfFactor { [$1] }+> | ebnfFactors "|" ebnfFactor { $1 ++ [$3] }++> ebnfFactor :: { Production }+> ebnfFactor : ebnfExtAtoms { ProdFactor $1 }++> ebnfExtAtoms :: { [Production] }+> ebnfExtAtoms : ebnfExtAtom { [$1] }+> | ebnfExtAtom ebnfExtAtoms { $1 : $2 }++> ebnfExtAtom :: { Production }+> ebnfExtAtom : ebnfAtom { $1 }+> | ebnfAtom "/" ebnfAtom { ProdRepeatWithAtom $1 $3 }+> | ebnfAtom "+" { ProdRepeat1 $1 }++> ebnfAtom :: { Production }+> ebnfAtom : id_tok { ProdNonterminal $1 }+> | any_string { ProdTerminal $1 }+> | "(" ebnfTerm ")" { $2 }+> | "[" ebnfTerm "]" { ProdOption $2 } +> | "{" ebnfTerm "}" { ProdRepeat $2 }++++(2) happy specification for the happy input language++> happyInput :: { [Production] }+> happyInput : happyOptCode +> happyTokInfos +> "%%" +> happyRules +> happyOptCode { happyPrepare $2 $4 }++> happyRules :: { [Production] }+> happyRules : happyRule happyRules { $1 : $2 }+> | happyRule { [$1] }++> happyRule :: { Production }+> happyRule : id_tok "::" happyCode happyHRule { ProdProduction $1 [] $4 }+> | id_tok ":" happyProds { ProdProduction $1 [] (ProdTerm $3) }++> happyHRule :: { Production }+> happyHRule : id_tok ":" happyProds { ProdTerm $3 }+> | ":" happyProds { ProdTerm $2 }++> happyProds :: { [Production] }+> happyProds : happyProd "|" happyProds { $1 : $3 }+> | happyProd { [$1] }++> happyProd :: { Production }+> happyProd : happyProdItems happyCode ";" { ProdFactor $1 }+> | happyProdItems happyCode { ProdFactor $1 }++> happyProdItems :: { [Production] }+> happyProdItems : happyProdItem happyProdItems { $1 : $2 }+> | { [] }++> happyProdItem :: { Production }+> happyProdItem : any_string { ProdTerminal $1 }+> | id_tok { ProdNonterminal $1 }++> happyTokInfos :: { [String] }+> happyTokInfos : happyTokInfo happyTokInfos { $1 ++ $2 }+> | happyTokInfo { $1 }++> happyTokInfo :: { [String] }+> happyTokInfo : "%" id_tok happyTokInfoRest { $3 }++> happyTokInfoRest :: { [String] }+> happyTokInfoRest : happyCode { [] }+> | id_tok { [] }+> | happyCode happyCode happyCode { [] }+> | happyTokenList { $1 } ++> happyTokenList :: { [String] }+> happyTokenList : id_tok happyCode happyTokenList { $1 : $3 }+> | any_string happyCode happyTokenList { $3 }+> | { [] }++here goes happy optCode:++> happyOptCode :: { () }+> happyOptCode : happyCode { () }+> | { () }++> happyCode :: { () }+> happyCode : "{" happyCodeBody "}" { () }++> happyCodeBody :: { () }+> happyCodeBody : happyCodeItem happyCodeBody { () }+> | happyCodeItem { () }++> happyCodeItem :: { () }+> happyCodeItem : any_string { () }+> | id_tok { () }+> | happyCode { () }+> | any_symbol { () }+> | ":" { () }+> | ";" { () }+> | "::" { () }+> | "|" { () }+> | "%%" { () }+> | "%" { () }++++(3) happy specification for the yacc input language ++> yaccInput :: { [Production] }+> yaccInput : "%%" yaccRules yaccEnd { yaccPrepare $2 }++> yaccRules :: { [Production] }+> yaccRules : yaccRhs { [$1] }+> | yaccRules yaccRule { $1 ++ [$2] }++> yaccRule :: { Production }+> yaccRule : yaccRhs { $1 }+> | "|" yaccRbody yaccPrec { ProdFactor $2 }++> yaccRhs :: { Production }+> yaccRhs : cid_tok ":" yaccRbody yaccPrec { ProdProduction $1 [] (ProdTerm [ProdFactor $3]) }++> yaccRbody :: { [Production] }+> yaccRbody : yaccRbody yaccIdent { $1 ++ [$2] }+> | yaccRbody yaccAction { $1 }+> | { [] }++> yaccPrec :: { () }+> yaccPrec : "%" id_tok yaccIdent { () }+> | "%" id_tok yaccIdent yaccAction { () }+> | yaccPrec ";" { () }+> | { () }++> yaccIdent :: { Production }+> yaccIdent : id_tok { ProdTerminal $1 }+> | any_string { ProdTerminal $1 }++> yaccAction :: { () }+> yaccAction : "{" "}" { () }++> yaccEnd :: { () }+> yaccEnd : "%%" { () }+> | { () }++> {++> theEbnfParser = ebnf2psParser . ebnf_postlexer . lexer . uncomment+> theHappyParser = ebnf2psParser . happy_postlexer . lexer . unlit+> theYaccParser = ebnf2psParser . yacc_postlexer . lexer . yaccpreprocessor++> }
+ src/EbnfLayout.hs view
@@ -0,0 +1,416 @@+--------------------------------------------------+-- Copyright 1994 by Peter Thiemann+-- $Log: EbnfLayout.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.4 1994/03/15 15:34:53 thiemann+-- added full color support, XColorDB based+--+-- Revision 1.3 1994/02/18 11:59:29 thiemann+-- save state before adding "withTentacle"+--+-- Revision 1.2 1993/08/31 12:31:32 thiemann+-- reflect changes in type FONT+--+-- Revision 1.1 1993/08/17 12:34:29 thiemann+-- Initial revision+--+-- $Locker: $+-- Last Modified By: M. Walter+--------------------------------------------------+module EbnfLayout where++import AbstractSyntax+import Color+import Fonts (FONT, stringWidth, stringHeight, fontDescender)+import Info+import Data.List++-- all arithmetic is done in 1/100 pt++-- tFont, ntFont, titleFont :: Font+-- arrowSize, lineWidth, fatLineWidth, borderDistY, borderDistX :: Int++-- borderDistX = 500+-- borderDistY = 500+-- lineWidth = 20+-- fatLineWidth = 200+-- arrowSize = 300+-- titleFont = ("Times-Roman", 10)+-- ntFont = ("Times-Roman", 10)+-- tFont = ("Times-Roman", 10)++makePictureLayout :: INFO -> Production -> Container+makePictureLayout+ (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, titleFont, ntFont, tFont,+ (ntColor, tColor, lineColor, ntBoxColor, tBoxColor, ntBgColor, tBgColor, titleClr))+ prod+ = makePicture 0 0 1 prod+ where++ mkTitleNonTerminal :: String -> Int -> Int -> Container+ mkTitleNonTerminal str rx ry = (rx, ry, width, height, 0, AString titleClr titleFont str)+ where + width = stringWidth titleFont str+ height = stringHeight titleFont str++ mkNonTerminal :: String -> Int -> Int -> Container+ mkNonTerminal str rx ry = (rx, ry, width, height, 0, AString ntColor ntFont str)+ where + width = stringWidth ntFont str+ height = stringHeight ntFont str++ mkTerminal :: String -> Int -> Int -> Container+ mkTerminal str rx ry = (rx, ry, width, height, 0, AString tColor tFont str)+ where + width = stringWidth tFont str+ height = stringHeight tFont str++ mkBox :: Int -> Int -> Int -> Int -> Int -> Container -> Container+ mkBox rx ry width height inOutY content+ = (rx, ry, width, height, inOutY, ABox ntBoxColor ntBgColor False content)++ mkRoundBox :: Int -> Int -> Int -> Int -> Int -> Container -> Container+ mkRoundBox rx ry width height inOutY content+ = (rx, ry, width, height, inOutY, ABox tBoxColor tBgColor True content)++ mkLine :: Int -> Int -> Int -> Int -> Container+ mkLine rx ry w h = (rx, ry, w, h, 0, Aline lineColor)++ mkArrow :: Int -> Int -> Int -> Container+ mkArrow rx ry dir = (rx, ry, 0, 0, 0, Arrow lineColor (dir*arrowSize))++ mkTurn :: Int -> Int -> Int -> Int -> TDirection -> Container+ mkTurn rx ry w h t = (rx, ry, w, h, 0, ATurn lineColor t)++ ------------------------------------------------------------------------++ withTentacle :: Int -> Int -> Int -> Production -> Container+ withTentacle rx ry direction prod = + (rx, ry, width, height, inOutY, AComposite [contents, theLine, theArrow])+ where (_, _, width1, height, inOutY, _) = contents+ contents = makePicture rx1 0 direction prod+ width = width1 + borderDistX+ rx1 | direction > 0 = 0+ | otherwise = borderDistX+ theLine | direction > 0 = mkLine width1 inOutY borderDistX 0+ | otherwise = mkLine 0 inOutY borderDistX 0+ theArrow | direction > 0 = mkArrow width inOutY direction+ | otherwise = mkArrow 0 inOutY direction++ makePicture :: Int -> Int -> Int -> Production -> Container++ makePicture rx ry direction (ProdProduction ntName ntAliases ProdEmpty) = + (rx, ry, width, height, 0, AComposite [content])+ where content@(_,_, width2, height2,_,_) = mkTitleNonTerminal str rx2 ry2+ ry1 = fatLineWidth `div` 2+ rx2 = 0+ ry2 = ry1 + distance - fontDescender ntFont+ distance = 2*borderDistY+ width = 2*borderDistX + width2+ height = fatLineWidth + height2 + distance+ str = (case ntAliases of+ [] -> ntName+ newName:_ -> newName)++"\t<empty production>"++ makePicture rx ry direction (ProdProduction ntName ntAliases prod) =+ (rx, ry, width, height, 0, AComposite ([content1, content2]++glue))+ where (_, _, width1, height1, inOutY1, _) = content1+ content1 = withTentacle rx1 ry1 direction prod+ content2@(_,_, width2, height2,_,_) = mkTitleNonTerminal str rx2 ry2+ rx1 = 2*borderDistX+ ry1 = fatLineWidth `div` 2+ rx2 = 0+ ry2 = ry1 + height1 + distance - fontDescender ntFont+ distance = 2*borderDistY+ width = 2*borderDistX + max width1 width2+ height = height1 +fatLineWidth + height2 + distance+ glue = [+ mkLine 0 (ry1 + inOutY1) (2*borderDistX) 0,+ mkArrow rx1 (ry1 + inOutY1) direction]+ str = case ntAliases of+ [] -> ntName+ newName:_ -> newName++ makePicture rx ry direction (ProdTerm [prod]) =+ makePicture rx ry direction prod+ makePicture rx ry direction (ProdTerm prods) =+ (rx, ry, width, height, inOutY, AComposite (newcontents ++ glue))+ where newcontents = zip6 rxs rys widths heights inOutYs gobjs+ (_, _, widths, heights, inOutYs, gobjs) = unzip6 contents+ ncontents = length prods+ -- sadly enough it's not possible to take rxs and rys in place of the fakes!+ fakes = take ncontents (repeat 0)+ contents = zipWith4 makePicture fakes fakes directions prods+ height = sum heights + (ncontents-1) * borderDistY+ maxwidth = maximum widths+ width = maxwidth + 4 * borderDistX+ rxs | direction > 0 = take ncontents (repeat (2 * borderDistX))+ | otherwise = map ((+ (2*borderDistX)) . (maxwidth -)) widths+ rys = tail (scanr f 0 heights) where f h q = h + q + borderDistY+ directions = take ncontents (repeat direction)+ entries = zipWith (+) rys inOutYs -- frame relative Y positions of entries+ firstEntry = entries!!0+ lastEntry = entries!!(ncontents-1)+ middleEntries = init (tail entries)+ inOutY = (firstEntry + lastEntry) `div` 2+ inOutDiff = firstEntry - lastEntry - 2*borderDistY+ glue = fixedglue ++ variableglue+ fixedglue = [+ mkLine 0 inOutY borderDistX 0,+ mkLine (width-borderDistX) inOutY borderDistX 0,+ mkTurn borderDistX (firstEntry - borderDistY) borderDistX borderDistY SE,+ mkTurn borderDistX lastEntry borderDistX borderDistY NE,+ mkLine borderDistX (lastEntry + borderDistY) 0 inOutDiff,+ mkTurn (width-2*borderDistX) (firstEntry - borderDistY) borderDistX borderDistY SW,+ mkTurn (width-2*borderDistX) lastEntry borderDistX borderDistY WN,+ mkLine (width-borderDistX) (lastEntry + borderDistY) 0 inOutDiff] +++ map f middleEntries +++ map g middleEntries+ where f y = mkLine borderDistX y borderDistX 0+ g y = mkLine (width-2*borderDistX) y borderDistX 0+ variableglue | direction > 0 = zipWith g widths entries+ | otherwise = zipWith h widths entries+ where g w y = mkLine (2*borderDistX + w) y (maxwidth - w) 0+ h w y = mkLine (2*borderDistX) y (maxwidth - w) 0+ obsoleteglue =+ map (f (2*borderDistX)) entries+ where f x y = mkArrow x y direction++{- the following works for two terms, both directions+ makePicture rx ry direction (ProdTerm [prod1, prod2])+ | direction > 0 =+ let (_, _, width1, height1, inOutY1, _) = content1+ content1 = makePicture rx1 ry1 direction prod1+ (_, _, width2, height2, inOutY2, _) = content2+ content2 = makePicture rx2 ry2 direction prod2+ rx1 = 2*borderDistX+ rx2 = 2*borderDistX+ ry2 = 0+ ry1 = height2 + borderDistY+ maxwidth = max width1 width2+ width = 4*borderDistX + maxwidth+ height = height2 + borderDistY + height1+ inOutY = (inOutY2 + ry1 + inOutY1) `div` 2+ inOutDiff = ry1 + inOutY1 - inOutY2 - 2*borderDistY+ glue = [+ mkLine 0 inOutY borderDistX 0,+ mkLine (width - borderDistX) inOutY borderDistX 0,+ mkLine borderDistX (ry2 + inOutY2 + borderDistY) 0 inOutDiff,+ mkLine (width - borderDistX) (ry2 + inOutY2 + borderDistY) 0 inOutDiff,+ mkTurn borderDistX (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SE,+ mkTurn borderDistX inOutY2 borderDistX borderDistY NE,+ mkTurn (width - 2*borderDistX) (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SW,+ mkTurn (width - 2*borderDistX) inOutY2 borderDistX borderDistY WN,+ mkLine (rx1 + width1) (ry1 + inOutY1) (maxwidth - width1) 0,+ mkLine (rx2 + width2) (ry2 + inOutY2) (maxwidth - width2) 0]+ in (rx, ry, width, height, inOutY, AComposite ([content1,content2]++glue))+ | otherwise =+ let (_, _, width1, height1, inOutY1, _) = content1+ content1 = makePicture rx1 ry1 direction prod1+ (_, _, width2, height2, inOutY2, _) = content2+ content2 = makePicture rx2 ry2 direction prod2+ maxwidth = max width1 width2+ width = 4*borderDistX + maxwidth+ height = height2 + borderDistY + height1+ inOutY = (inOutY2 + ry1 + inOutY1) `div` 2+ inOutDiff = ry1 + inOutY1 - inOutY2 - 2*borderDistY+ rx1 = 2*borderDistX + (maxwidth - width1)+ rx2 = 2*borderDistX + (maxwidth - width2)+ ry2 = 0+ ry1 = height2 + borderDistY+ glue = [+ mkLine 0 inOutY borderDistX 0,+ mkLine (width - borderDistX) inOutY borderDistX 0,+ mkLine borderDistX (ry2 + inOutY2 + borderDistY) 0 inOutDiff,+ mkLine (width - borderDistX) (ry2 + inOutY2 + borderDistY) 0 inOutDiff,+ mkTurn borderDistX (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SE,+ mkTurn borderDistX inOutY2 borderDistX borderDistY NE,+ mkTurn (width - 2*borderDistX) (ry1 + inOutY1 - borderDistX) borderDistX borderDistY SW,+ mkTurn (width - 2*borderDistX) inOutY2 borderDistX borderDistY WN,+ mkLine (2*borderDistX) (ry1 + inOutY1) (maxwidth - width1) 0,+ mkLine (2*borderDistX) (ry2 + inOutY2) (maxwidth - width2) 0]+ in (rx, ry, width, height, inOutY, AComposite ([content1,content2]++glue))+-}++ makePicture rx ry direction (ProdFactor [prod]) =+ makePicture rx ry direction prod+{-+ makePicture rx ry direction (ProdFactor prods) =+ (rx, ry, width, height, inOutY, AComposite (glue++contents))+ where (_, _, widths, heights, inOutYs, gobjs) = unzip6 contents+ contents = zipWith4 makePicture rxs rys directions prods+ ncontents = length prods+ aboves = zipWith (-) heights inOutYs+ maxIO = maximum inOutYs+ height = maxIO + maximum aboves+ width = sum widths + (ncontents-1)*borderDistX+ inOutY = maxIO+ rxs+ -- = take ncontents [0, 20*borderDistX .. ]+ | direction > 0 = init (scanl f 0 widths)+ | otherwise = tail (scanr f 0 widths)+ where f q w = q + w + borderDistX++ rys =+ take ncontents (repeat 0)+ -- map (inOutY -) inOutYs+ directions = take ncontents (repeat direction)+ glue | direction > 0 = map f (tail rxs)+ | otherwise = map f (init rxs)+ where f x = mkLine (x-borderDistX) inOutY borderDistX 0+-}++ makePicture rx ry direction (ProdFactor [prod1,prod2]) + | direction > 0 =+ let (_, _, width1, height1, inOutY1, _) = content1+ content1 = withTentacle rx1 ry1 direction prod1+ (_, _, width2, height2, inOutY2, _) = content2+ content2 = makePicture rx2 ry2 direction prod2+ rx1 = 0+ rx2 = width1+ width = width1 + width2+ inOutY = max inOutY1 inOutY2+ ry1 = inOutY - inOutY1+ ry2 = inOutY - inOutY2+ height = inOutY + max (height1 - inOutY1) (height2 - inOutY2)+ in (rx, ry, width, height, inOutY, AComposite ([content1,content2]))+ | otherwise =+ let (_, _, width1, height1, inOutY1, _) = content1+ content1 = withTentacle rx1 ry1 direction prod1+ (_, _, width2, height2, inOutY2, _) = content2+ content2 = makePicture rx2 ry2 direction prod2+ rx2 = 0+ rx1 = width2+ width = width1 + width2+ inOutY = max inOutY1 inOutY2+ ry1 = inOutY - inOutY1+ ry2 = inOutY - inOutY2+ height = inOutY + max (height1 - inOutY1) (height2 - inOutY2)+ in (rx, ry, width, height, inOutY, AComposite ([content1,content2]))++ makePicture rx ry direction (ProdFactor (prod:prods)) =+ makePicture rx ry direction (ProdFactor [prod, ProdFactor prods])+-- this is a ghastly hack!++ makePicture rx ry direction (ProdNonterminal str) =+ mkBox rx ry width height inOutY content+ where content@(_,_,width', height',_,_) = mkNonTerminal str rx' ry'+ width = width' + 2*borderDistX + 2*fatLineWidth+ height = height' + borderDistY + 2*fatLineWidth+ rx' = fatLineWidth + borderDistX+ ry' = fatLineWidth + borderDistY `div` 2 - fontDescender ntFont+ inOutY = height `div` 2++ makePicture rx ry direction (ProdTerminal str) =+ mkRoundBox rx ry width height inOutY content+ where content@(_,_,width', height',_,_) = mkTerminal str rx' ry'+ width = width' + 2*borderDistX + 2*fatLineWidth+ height = height' + borderDistY + 2*fatLineWidth+ rx' = fatLineWidth + borderDistX+ ry' = fatLineWidth + borderDistY `div` 2 - fontDescender tFont+ inOutY = height `div` 2++ makePicture rx ry direction (ProdOption prod) =+ (rx, ry, width, height, inOutY, AComposite (content:glue))+ where (_, _, width', height', inOutY', gobj) = content+ content = makePicture rx' ry' direction prod+ width = width' + 6*borderDistX+ height = height' + borderDistY+ rx' = 3*borderDistX+ ry' = borderDistY+ inOutY = 0+ glue = variableglue ++ fixedglue+ fixedglue = [+ mkLine 0 0 width 0,+ mkTurn 0 0 borderDistX bby WN,+ mkTurn borderDistX (inOutY'+borderDistY-bby) borderDistX bby SE,+ mkLine (2*borderDistX) (ry'+inOutY') borderDistX 0,+ mkTurn (width-borderDistX) 0 borderDistX bby NE,+ mkTurn (width-2*borderDistX) (inOutY'+borderDistY-bby) borderDistX bby SW,+ mkLine (width-3*borderDistX) (ry'+inOutY') borderDistX 0,+ mkLine borderDistX bby 0 (inOutY'+borderDistY-2*bby),+ mkLine (width-borderDistX) bby 0 (inOutY'+borderDistY-2*bby)]+ where bby = min borderDistY ((inOutY'+borderDistY) `div` 2)+ variableglue+ | direction > 0 = [mkArrow (3*borderDistX) (ry'+inOutY') direction]+ | otherwise = [mkArrow (width-3*borderDistX) (ry'+inOutY') direction]++ makePicture rx ry direction (ProdRepeat prod) =+ (rx, ry, width, height, inOutY, AComposite (content:glue))+ where (_, _, width', height', inOutY', gobj) = content+ content = makePicture rx' ry' (-direction) prod+ width = width' + 4*borderDistX+ height = height' + borderDistY+ rx' = 2*borderDistX+ ry' = borderDistY+ inOutY = 0+ glue = variableglue ++ fixedglue+ fixedglue = [+ mkLine 0 0 width 0,+ mkTurn borderDistX 0 borderDistX bby NE,+ mkTurn borderDistX (inOutY'+borderDistY-bby) borderDistX bby SE,+ mkTurn (width-2*borderDistX) 0 borderDistX bby WN,+ mkTurn (width-2*borderDistX) (inOutY'+borderDistY-bby) borderDistX bby SW,+ mkLine borderDistX bby 0 (inOutY'+borderDistY-2*bby),+ mkLine (width-borderDistX) bby 0 (inOutY'+borderDistY-2*bby)]+ where bby = min borderDistY ((inOutY'+borderDistY) `div` 2)+ variableglue+ | direction < 0 = [mkArrow (2*borderDistX) (inOutY'+borderDistY) (-direction)]+ | otherwise = [mkArrow (width-2*borderDistX) (inOutY'+borderDistY) (-direction)]+ + makePicture rx ry direction (ProdRepeat1 prod) =+ (rx, ry, width, height, inOutY, AComposite (content:glue))+ where (_, _, width', height', inOutY', gobj) = content+ content = makePicture rx' ry' (direction) prod+ width = width' + 4*borderDistX+ height = height' + borderDistY+ rx' = 2*borderDistX+ ry' = 0+ inOutY = inOutY'+ glue = [+ mkLine 0 inOutY rx' 0,+ mkLine (rx'+width') inOutY rx' 0,+ mkTurn borderDistX inOutY borderDistX borderDistY NE,+ mkTurn borderDistX (height-borderDistY) borderDistX borderDistY SE,+ mkTurn (width-rx') inOutY borderDistX borderDistY WN,+ mkTurn (width-rx') (height-borderDistY) borderDistX borderDistY SW,+ mkLine borderDistX (inOutY+borderDistY) 0 (height'-inOutY'-borderDistY),+ mkLine (width-borderDistX) (inOutY+borderDistY) 0 (height'-inOutY'-borderDistY),+ mkLine rx' height width' 0,+ mkArrow (rx'+width' `div` 2) height (-direction)]+ + makePicture rx ry direction (ProdRepeatWithAtom prod1 prod2) =+ (rx, ry, width, height, inOutY, AComposite (content1:content2:glue))+ where (_, _, width1, height1, inOutY1, _) = content1+ (_, _, width2, height2, inOutY2, _) = content2+ content1 = makePicture rx1 ry1 direction prod1+ content2 = makePicture rx2 ry2 (-direction) prod2+ maxwidth = max width1 width2+ width = maxwidth + 4*borderDistX+ height = height1 + height2 + borderDistY+ adjx1 = (maxwidth - width1) `div` 2+ rx1 = 2*borderDistX + adjx1+ ry1 = 0+ adjx2 = (maxwidth - width2) `div` 2+ rx2 = 2*borderDistX + adjx2+ ry2 = height1 + borderDistY+ inOutY = inOutY1+ glue = variableglue ++ fixedglue+ fixedglue = [+ mkLine 0 inOutY rx1 0,+ mkLine (rx1 + width1) inOutY rx1 0,+ mkLine (2*borderDistX) (ry2+inOutY2) adjx2 0,+ mkLine (2*borderDistX + adjx2 + width2) (ry2+inOutY2) adjx2 0,+ mkTurn borderDistX inOutY borderDistX borderDistY NE,+ mkTurn borderDistX (ry2+inOutY2-borderDistY) borderDistX borderDistY SE,+ mkTurn (rx1+width1+adjx1) inOutY borderDistX borderDistY WN,+ mkTurn (rx1+width1+adjx1) (ry2+inOutY2-borderDistY) borderDistX borderDistY SW,+ mkLine borderDistX (inOutY+borderDistY) 0 (height1-inOutY1 + inOutY2 - borderDistY),+ mkLine (rx1+width1+adjx1+borderDistX) (inOutY+borderDistY) 0 (height1-inOutY1 + inOutY2 - borderDistY)]+ variableglue+ | direction > 0 = [mkArrow (2*borderDistX + adjx2 + width2) (ry2+inOutY2) (-direction)]+ | otherwise = [mkArrow (2*borderDistX + adjx2) (ry2+inOutY2) (-direction)]++
+ src/EbnfOutput.hs view
@@ -0,0 +1,166 @@+-- -*- Mode: Haskell -*- +-- Copyright 1996 by Peter Thiemann+-- EbnfOutput.hs --- produce EBNF output for yacc/happy input+-- Initial revision+--+-- Last Modified By: M. Walter+--++module EbnfOutput (genEbnfFile) where++import Version+import AbstractSyntax+import GrammarUnfold (GrammarInfo(..), + getNonterminals, + getTerminals, + getProdsInfo, + getReduces, + getEmpties)++genEbnfFile :: String -> GrammarInfo -> String+genEbnfFile filename grammarInfo+ = (showsHeader .+ showsTerminals .+ showsNonterminals .+ showsUnfoldNonterminals .+ showsEmptyProds .+ showsProductions+ ) ""+ where+ outFileName = filename ++ ".BNF"+ nonterminals = getNonterminals grammarInfo+ rnonterminals = getReduces grammarInfo+ terminals = getTerminals grammarInfo+ emptyProds = getEmpties grammarInfo+ prods = getProdsInfo grammarInfo+ showsHeader =+ comment "Ebnf Grammar for:" .+ comment filename .+ comment ("generated by Ebnf2ps Version " ++ version) .+ comment "Ebnf2ps -- Automatic Railroad Diagram Drawing" .+ comment "(C) Peter Thiemann, 1996" .+ comment "(thiemann@informatik.uni-tuebingen.de)" .+ comment "Michael Walter" .+ comment "(walterm@informatik.uni-tuebingen.de)" .+ strnewline++ showsTerminals =+ commentHline .+ comment "Terminals" .+ commentHline .+ interleave "" (map showTerminal terminals) .+ strnewline++ showsNonterminals =+ commentHline .+ comment "Nonterminals" .+ commentHline .+ interleave "" (map showNonterminal nonterminals) .+ strnewline++ showsUnfoldNonterminals = + commentHline .+ comment "Nonterminals [+unfold]" .+ commentHline .+ (if null rnonterminals + then comment "\t<none>"+ else interleave "" (map showNonterminal rnonterminals)) .+ strnewline++ showsEmptyProds =+ commentHline .+ comment "Empty Productions" .+ commentHline .+ (if null emptyProds+ then comment "\t<none>" + else interleave "" (map showNonterminal emptyProds)) .+ strnewline++ showsProductions =+ commentHline .+ comment "Productions" .+ commentHline .+ interleave "\n\n" (map showProduction prods) .+ strnewline .+ comment "End of file" .+ comment outFileName ++ showProduction (ProdProduction nt ntAliases p) = showProdProduction nt ntAliases p + showProduction (ProdTerm ps) = showProdTerm ps+ showProduction (ProdFactor ps) = showProdFactor ps+ showProduction (ProdNonterminal nt) = str nt + showProduction (ProdTerminal t) = str "\"" . str (ebnfstr t) . str "\""+ showProduction (ProdOption p) = showProdOption p+ showProduction (ProdRepeat p) = showProdRepeat p+ showProduction (ProdRepeatWithAtom p1 p2) = showProdRepeatWithAtom p1 p2+ showProduction (ProdRepeat1 p) = showProdRepeat1 p+ showProduction ProdPlus = str " +"+ + showProdOption p = str "[" . showProduction p . str "]" + showProdRepeat p = str "{" . showProduction p . str "}"+ showProdRepeat1 p = showProduction p . str " +" + showProdRepeatWithAtom p1 p2 = showProduction p1 . str "/ " . showProduction p2++ showProdProduction nt _ ProdEmpty = + comment nt . + comment "\t= <empty roduction>." + showProdProduction nt ntAliases (ProdTerm [p]) = + comment nt .+ strspace . strspace .+ str nt .+ strnewline .+ strtab .+ str "= " .+ showProduction p . + strnewline .+ strtab .+ str ";"+ showProdProduction nt ntAliases (ProdTerm ps) = + comment nt .+ strspace . strspace .+ str nt .+ strnewline .+ strtab .+ str "= " .+ showTerms ps . + strnewline .+ strtab .+ str ";" + showProdProduction nt ntAliases p = + comment nt .+ strspace . strspace . + str nt . + strnewline .+ strtab .+ str "= " . + showProduction p . + strnewline .+ strtab .+ str ";"+ + showTerminal t = comment ('\t': t)+ showNonterminal nt = comment ('\t': nt)++ showTerms ts = interleave' "\t| " (map (\p -> showProduction p . strnewline) ts)++ showProdTerm [p] = showProduction p + showProdTerm ps = str "(" . interleave' " | " (map showProduction ps) . str ")"++ showProdFactor [p] = showProduction p + showProdFactor ps = interleave' " " (map showProduction ps) +++ebnfstr "" = ""+ebnfstr ('\\':cs) = '\\':'\\': ebnfstr cs+ebnfstr ('"':cs) = '\\':'"': ebnfstr cs+ebnfstr (c:cs) = c: ebnfstr cs++str = showString+strspace = str " "+strnewline = str "\n"+strtab = str "\t"+interleave s = foldr (\a b -> a . str s . b) id+interleave' s = foldr1 (\a b -> a . str s . b) +comment s = str "# " . str s . strnewline+commentHline = str "#----------------------------------------------------------------------\n"+
+ src/Fig31Output.hs view
@@ -0,0 +1,277 @@+-- -*- Mode: Haskell -*- +-- Copyright 1996 by Peter Thiemann+-- Last Modified By: M. Walter+-- $Log: Fig31Output.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- added full color support, XColorDB based+-- made conformant with FIG format 3.1 +--++module Fig31Output (fig31ShowsWrapper) where++import Version+import Fonts (FONT, fontName, fontScale)+import Color+import Info++--------------------------------------------------------------------------------+fig31ShowsWrapper :: WrapperType+fig31ShowsWrapper title+ (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, titleFont, ntFont, tFont, + colorinfo@(c1,c2,c3,c4,c5,c6,c7,c8)) container@(rx, ry, width, height, inOutY, gobj) =+ showString "#FIG 3.1\n" .+ showString "Landscape\nCenter\nInches\n1200 2\n" .+ showString "#Creator: Ebnf2ps (Copyright 1996 by Peter Thiemann / Michael Walter)\n" .+ showString ("#Version: " ++ version ++ "\n") .+ fig31ShowsObjectDefinition colorinfo .+ fig31ShowsContainer rx height container+ where + fig31ShowsObjectDefinition cinfo@(c1,c2,c3,c4,c5,c6,c7,c8) = + showsRGBColorObject cinfo + fig31ShowsContainer ax ay (rx, ry, width, height, inOutY, gobj) =+ case gobj of+ AString color font theString -> + showString "4 " . -- object: TEXT <4>+ showString "0" . -- sub_type : Left justified <0>+ showsfigColor color colorinfo . -- color + showString " 0 " . -- depth: <0>+ showString "0" . -- pen_style (not used)+ showsTrueNum (figFont (fontName font)) . -- font + showsTrueNum (fontScale font) . -- font_size+ showString " 0.0000000 " . -- angle <0.00000>+ showString "4". -- font_flags: Postscript Fonts <4>+ showsFigUnit height . -- height+ showsFigUnit width . -- length+ showsFigUnit ax' . -- x+ showsFigUnit ay' . -- y+ showString (' ':figString theString) -- string[] + ABox color bgcolor rounded content ->+ fig31ShowsContainer ax' ay' content .+ showString "2 " . -- object: POLYLINE <2>+ showsPolySubType rounded "4 " "2 " . -- subject type+ showString "0" . -- line_style+ showsFigNum fatLineWidth . -- thickness+ showsfigColor color colorinfo . -- pen_color+ showsfigColor bgcolor colorinfo . -- fill_color+ showString " 0 " . -- depth+ showString "0 " . -- pen_style+ showString "20 " . -- area_fill+ showString "0.000 " . -- style_val+ showString "0 " . -- join_style (2.1 default)+ showString "0" . -- cap_style (2.1 default)+ (if rounded then showsFigNum (min height width `div` 2)+ else showsFigNum 0) . -- radius+ showString " 0 0 " . -- forward_arrow , backwar_arrow+ showString "5\n" . -- npoints+ showString " " .+ showsFigBox ax' ay' width height .+ showString "\n" -- END of object+ Arrow color size -> + showString "2 " . -- object: POLYLINE <2>+ showString "1 " . -- sub_type <polyline>+ showString "0" . -- line_style <solid>+ showsFigNum lineWidth . -- thickness+ showsfigColor color colorinfo . -- pen_color+ showString " -1" . -- fill_color+ showString " 0 " . -- depth+ showString "0 " . -- pen_style+ showString "-1 " . -- area_fill+ showString "0.000 " . -- style_val+ showString "0 " . -- join_style+ showString "0" . -- cap_style+ showsFigNum (-1) . -- radius+ showString " 1 0 " . -- forward_arrow, backward_arrow+ showString "2\n" . -- npoints+ showString " 0 0" . -- arrow_type, arrow_style+ showsFigNum lineWidth . showString ".00 " . -- arrow_thickness+ showsFigUnit (abs size * 2). showString ".00 ". -- arrow_width+ showsFigUnit (abs size * 2). showString ".00 ". -- arrow_height+ showString "\n " .+ showsFigPoint (ax'- size) ay' .+ showsFigPoint ax' ay' .+ showString "\n" -- END of object+ Aline color ->+ showString "2 " . -- object: POLYLINE <2>+ showString "1 " . -- sub_type <polyline>+ showString "0" . -- line_style <solid>+ showsFigNum lineWidth . -- thickness+ showsfigColor color colorinfo . -- pen_color+ showString " -1" . -- fill_color+ showString " 0 " . -- depth+ showString "0 " . -- pen_style + showString "-1 " . -- area_fill+ showString "0.000 " . -- style_val+ showString "0 " . -- join_style+ showString "0" . -- cap_style (2.1 Butt)+ showsFigNum (-1) . -- radius+ showString " 0 0 " . -- forward_arrow, backward_arrow+ showString "2\n" . -- npoints+ showString " " .+ showsFigPoint ax' ay' .+ showsFigPoint (ax'+width) (ay'-height) .+ showString "\n" -- END of object+ ATurn color dir ->+ showString "3 " . -- object: SPLINE <3>+ showString "0 " . -- sub_type <open spline>+ showString "0" . -- line_style+ showsFigNum lineWidth . -- thickness+ showsfigColor color colorinfo . -- pen_color+ showString " -1" . -- fill_color + showString " 0 " . -- depth+ showString "0 " . -- pen_style+ showString "-1 " . -- area_fill+ showString "0.000 " . -- style_val+ showString "0 " . -- cap_style (2.1 Butt)+ showString "0 0 " . -- forward_arrow, backward_arrow+ showString "3\n" . -- npoints+ showString " " .+ showsIt dir . + showString "\n"+ where showsIt SE = showsFigPoint ax' ay' .+ showsFigPoint ax' (ay'-height) .+ showsFigPoint (ax'+width) (ay'-height)+ showsIt WN = showsFigPoint ax' ay' .+ showsFigPoint (ax'+width) ay' .+ showsFigPoint (ax'+width) (ay'-height) + showsIt SW = showsFigPoint (ax'+width) ay' .+ showsFigPoint (ax'+width) (ay'-height) .+ showsFigPoint ax' (ay'-height)+ showsIt NE = showsFigPoint ax' (ay'-height) .+ showsFigPoint ax' ay' .+ showsFigPoint (ax'+width) ay' + AComposite contents ->+ showString "6" . -- object: COMPOUND+ showsFigPoint (ax'+width) (ay'-height) . -- upperright_corner_(x,y)+ showsFigPoint ax' ay' . -- lowerleft_corner_(x,y)+ showChar '\n' .+ foldr (.) (showString "-6\n") (map (fig31ShowsContainer ax' ay') contents)+ where ax' = ax + rx + ay' = ay - ry++showsfigColor :: Color -> ColorInfo -> ShowS+showsfigColor c (c1,c2,c3,c4,c5,c6,c7,c8)+ | c `eqColor` c1 = showString " 33"+ | c `eqColor` c2 = showString " 34"+ | c `eqColor` c3 = showString " 35"+ | c `eqColor` c4 = showString " 36"+ | c `eqColor` c5 = showString " 37"+ | c `eqColor` c6 = showString " 38"+ | c `eqColor` c7 = showString " 39"+ | c `eqColor` c8 = showString " 40"+ | otherwise = showsFigColor c+ where (r1,g1,b1) `eqColor` (r2,g2,b2) = (r1==r2) && (g1==g2) && (b1==b2)+ +figString ['\\'] = "\\134\\001\n" +figString cs = figString' cs+ where figString' "" = "\\001\n"+ figString' ('\\':cs) = '\\':'\\': figString' cs+ figString' (c:cs) = c:figString' cs++figFont name = lookup figFontList 0+ where+ lookup [] _ = -1+ lookup (font: fonts) n | font == name = n+ | otherwise = lookup fonts (n+1)+++figFontList = [ -- stolen from u_fonts.c+ "Times-Roman",+ "Times-Italic",+ "Times-Bold",+ "Times-BoldItalic",+ "AvantGarde-Book",+ "AvantGarde-BookOblique",+ "AvantGarde-Demi",+ "AvantGarde-DemiOblique",+ "Bookman-Light",+ "Bookman-LightItalic",+ "Bookman-Demi",+ "Bookman-DemiItalic",+ "Courier",+ "Courier-Oblique",+ "Courier-Bold",+ "Courier-BoldOblique",+ "Helvetica",+ "Helvetica-Oblique",+ "Helvetica-Bold",+ "Helvetica-BoldOblique",+ "Helvetica-Narrow",+ "Helvetica-Narrow-Oblique",+ "Helvetica-Narrow-Bold",+ "Helvetica-Narrow-BoldOblique",+ "NewCenturySchlbk-Roman",+ "NewCenturySchlbk-Italic",+ "NewCenturySchlbk-Bold",+ "NewCenturySchlbk-BoldItalic",+ "Palatino-Roman",+ "Palatino-Italic",+ "Palatino-Bold",+ "Palatino-BoldItalic",+ "Symbol",+ "ZapfChancery-MediumItalic",+ "ZapfDingbats"]+++showsFigBox ax1 ay1 width height =+ showsFigPoint ax1 ay1 . + showsFigPoint (ax1+width) ay1 .+ showsFigPoint (ax1+width) (ay1-height) .+ showsFigPoint ax1 (ay1-height) .+ showsFigPoint ax1 ay1 ++ +showsRGBColorObject :: ColorInfo -> ShowS+showsRGBColorObject info@(c1,c2,c3,c4,c5,c6,c7,c8) =+ showsRGBObject 33 c1 . + showsRGBObject 34 c2 .+ showsRGBObject 35 c3 .+ showsRGBObject 36 c4 .+ showsRGBObject 37 c5 .+ showsRGBObject 38 c6 .+ showsRGBObject 39 c7 .+ showsRGBObject 40 c8++showsRGBObject :: Int -> Color -> ShowS+showsRGBObject cno (r,g,b) = + showString "0 " . shows cno . showString " #" . + showsRGB cno r . showsRGB cno g . showsRGB cno b .+ showString "\n"++showsRGB :: Int -> Int -> ShowS+showsRGB cno 0 = showString "00" +showsRGB cno n = let (d1,o1) = n `divMod` 16+ (_,o2) = d1 `divMod` 16+ in f o2 . f o1 + where f 10 = showChar 'a' + f 11 = showChar 'b'+ f 12 = showChar 'c'+ f 13 = showChar 'd'+ f 14 = showChar 'e'+ f 15 = showChar 'f'+ f x = shows x++showsTrueNum :: Int -> ShowS+showsTrueNum x = showChar ' ' . shows x++showsFigNum :: Int -> ShowS+showsFigNum x = showChar ' ' . shows (calcNumUnit x)++showsFigUnit :: Int -> ShowS+showsFigUnit x = showChar ' ' . shows (calcFigUnit x)++calcFigUnit :: Int -> Int+calcFigUnit x = 15*((x*9 + 999) `div` 1000) ++calcNumUnit :: Int -> Int+calcNumUnit x = (x*9 + 999) `div` 1000++showsFigPoint :: Int -> Int -> ShowS+showsFigPoint x y = + showChar ' ' . showsxFigUnit x . showChar ' ' . showsyFigUnit y+ where showsxFigUnit x = shows (calcFigUnit x) -- + 'xfig' offset + showsyFigUnit y = shows (calcFigUnit y) -- - 'xfig' offset ++showsPolySubType True a _ = showString a +showsPolySubType False _ b = showString b
+ src/Fonts.hs view
@@ -0,0 +1,99 @@+--------------------------------------------------------------------------------+-- Copyright 1994 by Peter Thiemann+-- $Log: Fonts.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.1 1993/08/31 12:31:32 thiemann+-- Initial revision+--+-- Revision 1.1 1993/08/31 12:31:32 thiemann+-- Initial revision+--+-- $Locker: $+-- Last Modified By: M. Walter+--------------------------------------------------------------------------------++module Fonts (FONT, makeFont, fontDescender, stringWidth, stringHeight, fontName, fontScale, noFont)+where++import Data.Char+import Numeric++data FONT = FONT String Int Int (String -> Int)++instance Eq FONT where+ (==) (FONT s1 m1 n1 f1) (FONT s2 m2 n2 f2) = s1 == s2 && m1 == m2 && n1 == n2++noFont = FONT "" 0 0 (const 0)++data Afm = Descender Int+ | CharMetric Int Int String Int Int Int Int+-- CharMetric charNo charWX charName llx lly urx ury+-- deriving Text++fontName :: FONT -> String+fontName (FONT name _ _ _) = name++fontScale :: FONT -> Int+fontScale (FONT _ scale _ _) = scale++fontDescender :: FONT -> Int+fontDescender (FONT _ _ theDescender _) = theDescender++stringWidth :: FONT -> String -> Int+stringWidth (FONT _ _ _ theStringWidth) = theStringWidth++stringHeight :: FONT -> String -> Int+stringHeight (FONT _ scale _ _) _ = scale * 100++makeFont :: String -> Int -> String -> FONT+makeFont fontName fontScale fontAfm =+ FONT fontName fontScale theDescender+ ((`div` 10). (* fontScale). getStringWidth parsedAfm)+ where+ parsedAfm = parseAfmFile (lines fontAfm)+ theDescender = getDescender parsedAfm++getStringWidth :: [Afm] -> String -> Int+getStringWidth afms str = sum (map (getCharWidth afms . ord) str)++getCharWidth :: [Afm] -> Int -> Int+getCharWidth (CharMetric charNo charWX charName llx lly urx ury: afms) chNo+ | charNo == chNo = charWX+ | otherwise = getCharWidth afms chNo+getCharWidth (_:afms) chNo = getCharWidth afms chNo+getCharWidth [] chNo = 0++getDescender :: [Afm] -> Int+getDescender (Descender d: _) = d+getDescender (_:rest) = getDescender rest+getDescender [] = 0++--------------------------------------------------------------------------------++parseAfmFile :: [String] -> [Afm]+parseAfmFile [] = []+parseAfmFile (('D':'e':'s':'c':'e':'n':'d':'e':'r':line):lines) =+ Descender descender: parseAfmFile lines+ where (descender,_):_ = readSigned readDec (skipWhite line)+parseAfmFile (('E':'n':'d':'C':'h':'a':'r':'M':'e':'t':'r':'i':'c':'s':_):_) = []+parseAfmFile (('C':' ':line):lines) = CharMetric charNo charWX charName llx lly urx ury:+ parseAfmFile lines+ where (charNo, rest1):_ = readSigned readDec (skipWhite line)+ 'W':'X':rest2 = skipWhiteOrSemi rest1+ (charWX, rest3):_ = readDec (skipWhite rest2)+ 'N':rest4 = skipWhiteOrSemi rest3+ (charName, rest5) = span isAlpha (skipWhite rest4)+ 'B':rest6 = skipWhiteOrSemi rest5+ (llx, rest7):_ = readSigned readDec (skipWhite rest6)+ (lly, rest8):_ = readSigned readDec (skipWhite rest7)+ (urx, rest9):_ = readSigned readDec (skipWhite rest8)+ (ury, _):_ = readSigned readDec (skipWhite rest9)+parseAfmFile (_:lines) = parseAfmFile lines++skipWhite = dropWhile isSpace+skipWhiteOrSemi = dropWhile isSkipChar+isSkipChar c = isSpace c || c == ';'++
+ src/GrammarTransform.hs view
@@ -0,0 +1,355 @@+-- -*- Mode: Haskell -*- +-- Copyright 1994 by Peter Thiemann+-- GrammarTransform.hs --- some transformations on parse trees+-- Author : Peter Thiemann+-- Created On : Thu Oct 21 16:44:17 1993+-- simplifying transformations on grammars++module GrammarTransform + (simplify, + happysimplify, happysimplifyExt, + yaccsimplify, yaccsimplifyExt,+ freents, simp0) +where++import AbstractSyntax+import Data.List+++data RInfo+ = ROk [Production] [Production] Production+ | RKo+++simplify :: [Production] -> [Production]+simplify = map (simplify2' . simplify') . simp3 +happysimplify = simp0 +yaccsimplify = simp0 +happysimplifyExt = (\ p -> (fst p, map (simplify2' . simplify') (snd p))) . (simp0 . simp3o) +yaccsimplifyExt = (\ p -> (fst p, map (simplify2' . simplify') (snd p))) . (simp0 . simp3o) ++++-- simp1 gets the body of a ProdFactor as an argument+-- and provides the transformations+-- beta { X } X gamma ---> beta (X)+ gamma+-- beta X { X } gamma ---> beta (X)+ gamma+-- beta { X Y } X gamma ---> beta (X)/ (Y) gamma+-- beta X { Y X } gamma ---> beta (X)/ (Y) gamma+simp1 [] = []+simp1 [p] = [p]+simp1 (ProdRepeat p:p':prods)+ | p `eqProduction` p' = ProdRepeat1 p: simp1 prods+simp1 (p:ProdRepeat p':prods)+ | p `eqProduction` p' = ProdRepeat1 p: simp1 prods+simp1 (ProdRepeat (ProdFactor [p1, p2]):p:prods)+ | p1 `eqProduction` p = ProdRepeatWithAtom p p2: simp1 prods+simp1 (p:ProdRepeat (ProdFactor [p1, p2]):prods)+ | p `eqProduction` p2 = ProdRepeatWithAtom p p1: simp1 prods+simp1 (p:prods) = p: simp1 prods+++-- simp2'r gets the body of a ProdTerm as an argument+-- and provides the transformations (slow)+-- gamma X | delta X ---> (gamma | delta) X+-- gamma X | X ---> [gamma] X+-- X | gamma X ---> [gamma| X++rightpart2'r [p] x = (x `eqProduction` p, [])+rightpart2'r ps x = + let l = last ps + n = length ps+ in (x `eqProduction` l, init ps)+ +rightParts rest rest' =+ let l' = last rest' + in case (rightpart2'r rest l') of+ (True, front) -> ROk front (init rest') l'+ (False, _) -> RKo+ +simp2'r' term@(ProdTerm prods) = + let res = simplifier term+ in case res of+ (ProdFactor _) -> res+ (ProdTerm ps) -> ProdTerm (simp2'r ps)+ _ -> term++simp2'r (first@(ProdFactor (p:rest)): next@(ProdFactor (p':rest')): more) =+ case (rest, rest') of + ([], []) + | p `eqProduction` p' -> simp2'r (ProdFactor [p]: more)+ | otherwise -> first: simp2'r (next:more)+ ([], _) -> case (rightpart2'r rest' p) of + (True,front) -> simp2'r (ProdFactor [ProdOption (ProdFactor (p':front)), p] : more)+ (False,_) -> first: simp2'r (next:more) + (_, []) -> case (rightpart2'r rest p') of + (True, front) -> simp2'r (ProdFactor [ProdOption (ProdFactor (p:front)),p']: more)+ (False,_) -> first: simp2'r (next:more) + (_, _) -> case (rightParts rest rest') of+ RKo -> first: simp2'r (next: more)+ (ROk front1 front2 l) -> let t = simp2'r' (ProdTerm [ProdFactor (p:front1), ProdFactor (p':front2)])+ in simp2'r (ProdFactor [t,l] : more)+simp2'r [p] = [p]+simp2'r [] = []++ +++-- simp2 gets the body of a ProdTerm as an argument+-- and provides the transformations +-- X gamma | X delta ---> X (gamma | delta)+-- X gamma | X ---> X [ gamma ]+-- X | X gamma ---> X [ gamma ]+getPrefixes ps1@(p1:_:_) ps2@(p2:_:_) firsts + | p1 `eqProduction` p2 = getPrefixes (tail ps1) (tail ps2) (firsts++[p1])+getPrefixes ps1 ps2 firsts = (firsts, ps1, ps2) ++lookahead x more = partition (la x) more+ where la x (ProdFactor (p:_)) = x `eqProduction` p+ la x _ = False+++simplifier term@(ProdTerm [a,b]) = + case (a,b) of+ (ProdFactor [ProdTerm psa@(x:y:_)], ProdFactor [ProdTerm psb@(x':y':_)]) -> ProdTerm (psa++psb)+ (ProdFactor [ProdTerm psa@(x:y:_)], _) -> ProdTerm (psa++[b])+ (_, ProdFactor [ProdTerm psb@(x':y':_)]) -> ProdTerm (a:psb)+ (_,_) -> term +simplifier term = term+ +simp2' term@(ProdTerm prods) = + let res = simplifier term+ in case res of+ (ProdFactor _) -> res+ (ProdTerm ps) -> ProdTerm (simp2 ps)+ _ -> term+ + +simp2 (ProdFactor (p:rest): next@(ProdFactor (p':rest')): more)+ | p `eqProduction` p' = case (rest, rest') of+ ([], []) -> simp2 (ProdFactor [p]: more)+ ([], _) -> case (lookahead p more) of + ([],_) -> simp2 (ProdFactor [p, ProdOption (ProdFactor rest')]: more) + (others,more') -> simp2 ((next:others)++(ProdFactor [p]:more'))+ (_, []) -> simp2 (ProdFactor [p, ProdOption (ProdFactor rest)]: more)+ (_, _) -> let (firsts,rs,rs') = getPrefixes rest rest' [] + pfirsts = p:firsts+ next = simp2' (ProdTerm [ProdFactor rs, ProdFactor rs'])+ in simp2 ((ProdFactor (pfirsts++[next])):more)+ | otherwise = ProdFactor (p:rest): simp2 (ProdFactor (p':rest'):more)+simp2 [p] = [p]+simp2 [] = []+++-- simp3 gets a list of ProdProductions and looks for left and right recursive productions+-- it executes the transformations+-- A -> A gamma_1 | ... | A gamma_k | delta+-- --->+-- A -> delta { gamma_1 | ... | gamma_k }+-- and+-- A -> gamma_1 A | ... | gamma_k A | delta+-- --->+-- A -> { gamma_1 | ... | gamma_k } delta++leftParty nt (ProdTerm ps) = foldr f ([], []) ps+ where f (ProdFactor (ProdNonterminal nt':rest)) (yes, no)+ | nt == nt' = (ProdFactor rest:yes, no)+ f p (yes, no) = (yes, p:no)++simp3'l prod@(ProdProduction nt nts p@(ProdTerm _))+ = case leftParty nt p of+ (lefties@(_:_), others@(_:_)) ->+ ProdProduction nt nts+ (ProdFactor [ProdTerm others, ProdRepeat (ProdTerm lefties)])+ _ -> prod+simp3'l prod = prod++rightParty nt (ProdTerm ps) = foldr f ([], []) ps+ where f (ProdFactor ps) (yes, no)+ | length ps > 1 && rightmost nt ps = (ProdFactor (init ps):yes, no)+ f p (yes, no) = (yes, p:no)++rightmost nt [ProdNonterminal nt'] = nt == nt'+rightmost nt [p] = False+rightmost nt (p:ps) = rightmost nt ps++simp3'r prod@(ProdProduction nt nts p@(ProdTerm _))+ = case rightParty nt p of+ (righties@(_:_), others@(_:_)) ->+ ProdProduction nt nts+ (ProdFactor [ProdRepeat (ProdTerm righties), ProdTerm others])+ _ -> prod+simp3'r prod = prod++simp3 :: [Production] -> [Production]+simp3 = map (simp3'r . simp3'l)++++-- [happyInput && yaccInput]+-- simp0 gets a list of productions and looks for empty productions on the right +-- side of happy rule and provides the transformations+-- N -> X | . ---> N -> [X]. +-- and N -> X1 | X2 | ... | Xk | . ---> N -> [X1| X2 | ... | Xk].++simp0' prod@(ProdProduction nt nts p@(ProdTerm prods)) = + case (partition (\p -> not (p `eqProduction` emptyProd)) prods) of + ([], _) -> ([nt], ProdProduction nt nts ProdEmpty)+ (prods', []) -> ([],prod)+ (prods', (x:_)) -> ([], ProdProduction nt nts (ProdOption (ProdTerm prods')))+ where emptyProd = ProdFactor [] +simp0' prod = ([],prod)++simp0 prods = foldr f ([],[]) (map simp0' prods)+ where f ([],p) (nts,ps) = (nts,p:ps)+ f ([n],p) (nts,ps) = (n:nts,p:ps)++++-- [happyInput && yaccInput]+-- simp3o gets a list of ProdProductions and looks for left and right recursive productions+-- it executes the transformations++simp3o :: [Production] -> [Production]+simp3o = map (simp3o'r . simp3o'l)++-- [simp3o'l]+-- A -> A gamma_1 | ... | A gamma_k | delta --> A -> delta { gamma_1 | ... | gamma_k }+-- A -> A gamma_1 | ... | A gamma_k | 'empty' --> A -> { gamma_1 | ... | gamma_k } +--+-- A -> A gamma_1 | ... | A gamma_k | delta_1 | ... | delta_k | 'empty' +-- --> +-- A -> [delta_1 | ... | delta_k] { gamma_1 | ... | gamma_k }++leftParty' nt (ProdTerm ps) = foldr f ([], [], False) ps+ where f (ProdFactor []) (yes,no,_) = (yes,no,True)+ f (ProdFactor (ProdNonterminal nt':rest)) (yes, no,emptyProds)+ | nt == nt' = (ProdFactor rest:yes, no,emptyProds)+ f p (yes, no,emptyProds) = (yes, p:no,emptyProds)++-- repeatWithAtom'l: X {delta X} --> X / delta+repeatWithAtom'l prod@(ProdFactor [p1,p2]) = + case (p1,p2) of + (front@(ProdTerm [ProdFactor [x]]), ProdRepeat (ProdTerm [ProdFactor p2s@(a:b:_)])) ->+ if (last p2s) `eqProduction` x+ then ProdRepeatWithAtom front (ProdFactor (init p2s))+ else prod+ _ -> prod+repeatWithAtom'l p = p++simp3o'l prod@(ProdProduction nt nts p@(ProdTerm _))+ = case leftParty' nt p of+ (lefties@(_:_), [], _) ->+ ProdProduction nt nts+ (ProdRepeat (ProdTerm lefties))+ (lefties@(_:_), others@(_:_), True) ->+ ProdProduction nt nts+ (ProdFactor [ProdOption (ProdTerm others), ProdRepeat (ProdTerm lefties)])+ (lefties@(_:_), others@(_:_), False) ->+ ProdProduction nt nts+ (repeatWithAtom'l (ProdFactor [ProdTerm others, ProdRepeat (ProdTerm lefties)]))+ _ -> prod+simp3o'l prod = prod++++-- [simp3o'r]+-- A -> gamma_1 A | ... | gamma_k A | delta --> A -> { gamma_1 | ... | gamma_k } delta+-- A -> gamma_1 A | ... | gamma_k A | 'empty' --> A -> { gamma_1 | ... | gamma_k }+-- A -> gamma_1 A | ... | gamma_k A | delta_1 | ... | delta_k | 'empty' +-- --> +-- A -> { gamma_1 | ... | gamma_k } [delta_1 | ... | delta_k]++-- repeatWithAtom'r: {X delta} X --> X / delta+repeatWithAtom'r prod@(ProdFactor [p1,p2]) = + case (p1,p2) of + (ProdRepeat (ProdTerm [ProdFactor p2s@(a:b:_)]), front@(ProdTerm [ProdFactor [x]])) ->+ if a `eqProduction` x+ then ProdRepeatWithAtom front (ProdFactor (tail p2s))+ else prod+ _ -> prod+repeatWithAtom'r p = p++rightParty' nt (ProdTerm ps) = foldr f ([], [], False) ps+ where f (ProdFactor ps) (yes, no, emptyProds)+ | length ps == 0 = (yes,no,True)+ | length ps > 1 && rightmost nt ps = (ProdFactor (init ps):yes, no, emptyProds)+ f p (yes, no,emptyProds) = (yes, p:no,emptyProds)++simp3o'r prod@(ProdProduction nt nts p@(ProdTerm _))+ = case rightParty' nt p of+ (righties@(_:_), [], _) -> + ProdProduction nt nts+ (ProdRepeat (ProdTerm righties))+ (righties@(_:_), others@(_:_), True) ->+ ProdProduction nt nts+ (ProdFactor [ProdRepeat (ProdTerm righties), ProdOption (ProdTerm others)])+ (righties@(_:_), others@(_:_), False) ->+ ProdProduction nt nts+ (repeatWithAtom'r (ProdFactor [ProdRepeat (ProdTerm righties), ProdTerm others]))+ _ -> prod+simp3o'r prod = prod+++-- compute the set of all nonterminals in a Production+freents :: Production -> [String]+freents (ProdTerm prods) = concat (map freents prods)+freents (ProdFactor prods) = concat (map freents prods)+freents (ProdNonterminal s) = [s]+freents (ProdTerminal s) = []+freents (ProdOption p) = freents p+freents (ProdRepeat p) = freents p+freents (ProdRepeat1 p) = freents p+freents (ProdRepeatWithAtom p1 p2) = freents p1 ++ freents p2+freents (ProdPlus) = []+freents (ProdEmpty) = []+freents (ProdSlash p) = freents p+++simplify' (ProdProduction s1 s2 prod) = ProdProduction s1 s2 (simplify' prod)+simplify' (ProdFactor prods) = ProdFactor (simp1 (map simplify' prods)) +simplify' (ProdNonterminal s) = ProdNonterminal s+simplify' (ProdTerminal s) = ProdTerminal s+simplify' (ProdOption prod) = ProdOption (simplify' prod)+simplify' (ProdRepeat prod) = ProdRepeat (simplify' prod)+simplify' (ProdRepeat1 prod) = ProdRepeat1 (simplify' prod)+simplify' (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (simplify' p1) (simplify' p2)+simplify' (ProdPlus) = ProdPlus+simplify' (ProdEmpty) = ProdEmpty+simplify' (ProdSlash prod) = ProdSlash (simplify' prod)+simplify' (ProdTerm prods) = ProdTerm ((simp2 . map simplify') prods) ++simplify2' (ProdProduction s1 s2 prod) = ProdProduction s1 s2 (simplify2' prod)+simplify2' (ProdFactor prods) = ProdFactor (simp1 (map simplify2' prods)) +simplify2' (ProdNonterminal s) = ProdNonterminal s+simplify2' (ProdTerminal s) = ProdTerminal s+simplify2' (ProdOption prod) = ProdOption (simplify2' prod)+simplify2' (ProdRepeat prod) = ProdRepeat (simplify2' prod)+simplify2' (ProdRepeat1 prod) = ProdRepeat1 (simplify2' prod)+simplify2' (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (simplify2' p1) (simplify2' p2)+simplify2' (ProdPlus) = ProdPlus+simplify2' (ProdEmpty) = ProdEmpty+simplify2' (ProdSlash prod) = ProdSlash (simplify2' prod)+simplify2' (ProdTerm prods) = ProdTerm ((simp2'r . map simplify2') prods)+++-- Goferisms:+eqList [] [] = True+eqList (x:xs) (y:ys) = eqProduction x y && eqList xs ys+eqList _ _ = False++eqProduction (ProdFile ps) (ProdFile ps') = eqList ps ps'+eqProduction (ProdProduction str ostr p) (ProdProduction str' ostr' p') = str == str' && ostr == ostr' && eqProduction p p'+eqProduction (ProdTerm ps) (ProdTerm ps') = eqList ps ps'+eqProduction (ProdFactor ps) (ProdFactor ps') = eqList ps ps'+eqProduction (ProdNonterminal str) (ProdNonterminal str') = str == str'+eqProduction (ProdTerminal str) (ProdTerminal str') = str == str'+eqProduction (ProdOption p) (ProdOption p') = eqProduction p p'+eqProduction (ProdRepeat p) (ProdRepeat p') = eqProduction p p'+eqProduction (ProdRepeatWithAtom p1 p2) (ProdRepeatWithAtom p1' p2') = eqProduction p1 p1' && eqProduction p2 p2'+eqProduction (ProdRepeat1 p) (ProdRepeat1 p') = eqProduction p p'+eqProduction (ProdPlus) (ProdPlus) = True+eqProduction (ProdEmpty) (ProdEmpty) = True+eqProduction (ProdSlash p) (ProdSlash p') = eqProduction p p'+eqProduction _ _ = False+
+ src/GrammarUnfold.hs view
@@ -0,0 +1,197 @@+-- -*- Mode: Haskell -*- +-- Copyright © 1996, 1998 by Peter Thiemann+-- GrammarUnfold.hs +-- main functions for ebnfInput, yaccInput and happyInput.+-- Initial revision+-- +-- Last Modified By: M. Walter+--+++module GrammarUnfold (+ GrammarInfo(..),+ rawEBNFInput, rawHappyInput, rawYaccInput,+ getNonterminals, getTerminals, getReduces, getProdsInfo, getEmpties, getRedProds+ ) where+ +import AbstractSyntax+import GrammarTransform +import StringMatch (stringMatch)+import Data.List++import qualified Data.Map (Map, keys, elems, findWithDefault, fromList)++type FiniteMap k x = Data.Map.Map k x+keysFM = Data.Map.keys+eltsFM = Data.Map.elems+listToFM = Data.Map.fromList+lookupWithDefaultFM theMap theDefault theKey = + Data.Map.findWithDefault theDefault theKey theMap++type UnfoldInfo = FiniteMap String Production++disjointLists [] bs = True+disjointLists (a:as) bs | a `elem` bs = False+ | otherwise = disjointLists as bs++type Alphabet = ([String], -- nonterminals + [String]) -- terminals +++data GrammarInfo = GrammarInfo+ [Production] -- all productions + [String] -- Nonterminals+ [String] -- Terminals+ [String] -- Nonterminals (option: +unfold)+ [String] -- Nonterminals with replacements+ [String] -- identifiers of empty productions++----------------------------------------------------------------------------------------------++-- happyInput++rawHappyInput :: Bool -- flag: +ebnf + -> Bool -- flag: +simplify + -> Bool -- flag: +unfold + -> [String] + -> [Production] -> GrammarInfo+rawHappyInput ebnfoutput doSimplify True unfold_nts prods =+ let (nts, prods') = (if doSimplify then happysimplifyExt else happysimplify) prods+ (rnts, names, prods'') = unfoldGrammar unfold_nts prods'+ (nonterminals, terminals) | ebnfoutput = allSymbols prods''+ | otherwise = ([], [])+ in GrammarInfo prods'' nonterminals terminals rnts names nts+ +rawHappyInput ebnfoutput doSimplify False _ prods =+ let (nts ,prods') = (if doSimplify then happysimplifyExt else happysimplify) prods + (nonterminals, terminals) | ebnfoutput = allSymbols prods'+ | otherwise = ([], [])+ in GrammarInfo prods' nonterminals terminals [] [] nts ++++-- yaccInput++rawYaccInput :: Bool -- flag: +ebnf + -> Bool -- flag: +simplify + -> Bool -- flag: +unfold + -> [String] + -> [Production] -> GrammarInfo+rawYaccInput ebnfoutput doSimplify True unfold_nts prods =+ let (nts, prods') = (if doSimplify then yaccsimplifyExt else yaccsimplify) prods+ (rnts, names, prods'') = unfoldGrammar unfold_nts prods'+ ((nonterminals , terminals), oprods) | ebnfoutput = (allSymbols prods'', reverse prods'')+ | otherwise = (([], []), prods'')+ in GrammarInfo oprods nonterminals terminals rnts names nts + +rawYaccInput ebnfoutput doSimplify False _ prods =+ let (nts ,prods') = (if doSimplify then yaccsimplifyExt else yaccsimplify) prods + ((nonterminals, terminals), oprods) | ebnfoutput = (allSymbols prods', reverse prods')+ | otherwise = (([], []), prods')+ in GrammarInfo oprods nonterminals terminals [] [] nts ++++-- ebnfInput++rawEBNFInput :: Bool -- flag: +simplify + -> Bool -- flag: +unfold + -> [String] -> [Production] -> GrammarInfo+rawEBNFInput doSimplify True unfold_nts prods =+ let prods' = if doSimplify then simplify prods else prods+ (rnts, names, prods'') = unfoldGrammar unfold_nts prods'+ in GrammarInfo prods'' [] [] rnts names []+ +rawEBNFInput doSimplify False _ prods = + GrammarInfo (if doSimplify then simplify prods else prods) [] [] [] [] []++--------------------------------------------------------------------------------------------------++unfoldGrammar :: [String] + -> [Production] + -- (nonterminals, nonterminals with a replacement, new productions)+ -> ([String], [String], [Production])+unfoldGrammar [] prods = ([], [], prods)+unfoldGrammar rnts prods = unfoldGrammar' rnts prods+ +unfoldGrammar' :: [String] -> [Production] -> ([String],[String],[Production])+unfoldGrammar' [] prods = ([], [], prods)+unfoldGrammar' rnts prods =+ (keysFM rntsFM, reducedProds, foldr (++) [] [(eltsFM rntsFM), prods', rest])+ where (rntsInfo,reducedProds, prodsToUnfold, rest) = splitInputGrammar rnts prods+ rntsFM = listToFM rntsInfo+ prods' = map (unfoldSimp . unfoldProd []) prodsToUnfold+ + unfoldProd unf (ProdProduction nt ntAliases p) = ProdProduction nt ntAliases (unfoldProd unf p)+ unfoldProd unf (ProdTerm prods) = ProdTerm (map (unfoldProd unf) prods)+ unfoldProd unf (ProdFactor prods) = ProdFactor (map (unfoldProd unf) prods)+ unfoldProd unf p@(ProdNonterminal nt) + | nt `elem` unf = p+ | otherwise = unfoldProd (nt:unf) $ lookupWithDefault p nt rntsFM+ unfoldProd unf (ProdOption p) = ProdOption (unfoldProd unf p)+ unfoldProd unf (ProdRepeat p) = ProdRepeat (unfoldProd unf p)+ unfoldProd unf (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (unfoldProd unf p1) (unfoldProd unf p2)+ unfoldProd unf (ProdRepeat1 p) = ProdRepeat1 (unfoldProd unf p)+ unfoldProd unf (ProdSlash p) = ProdSlash (unfoldProd unf p)+ unfoldProd unf p = p+ + unfoldSimp (ProdProduction nt ntAliases p) = ProdProduction nt ntAliases (unfoldSimp p)+ unfoldSimp (ProdTerm prods) = ProdTerm (map unfoldSimp prods)+ unfoldSimp (ProdFactor prods) = ProdFactor (map unfoldSimp prods)+ unfoldSimp (ProdOption (ProdOption p)) = ProdOption (unfoldSimp p)+ unfoldSimp (ProdOption (ProdRepeat p)) = ProdRepeat (unfoldSimp p)+ unfoldSimp (ProdOption p) = ProdOption (unfoldSimp p)+ unfoldSimp (ProdRepeat (ProdOption p)) = ProdRepeat (unfoldSimp p)+ unfoldSimp (ProdRepeat p) = ProdRepeat (unfoldSimp p)+ unfoldSimp (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (unfoldSimp p1) (unfoldSimp p2)+ unfoldSimp (ProdRepeat1 p) = ProdRepeat1 (unfoldSimp p)+ unfoldSimp (ProdSlash p) = ProdSlash (unfoldSimp p)+ unfoldSimp p = p+ ++lookupWithDefault :: Production -> String -> UnfoldInfo -> Production+lookupWithDefault deflt nt info =+ case (lookupWithDefaultFM info deflt nt) of+ (ProdProduction nt' _ ProdEmpty) -> deflt + (ProdProduction _ _ p) -> p+ p -> p+++splitInputGrammar :: [String] -> [Production] -> ([(String,Production)],[String],[Production],[Production])+splitInputGrammar rnts prods+ = foldr splitGrammar ([],[],[],[]) prods+ where+ splitGrammar prod@(ProdProduction nt _ ProdEmpty) (yes,ps,todo,no) = (yes,ps,todo,prod:no)+ splitGrammar prod@(ProdProduction nt _ p) (yes,ps,todo,no)+ | any (flip stringMatch nt) rnts = ((nt,prod):yes, ps, todo, no)+ | any (\x -> any (flip stringMatch x) rnts) (freents p) = (yes,nt:ps,prod:todo, no)+ | otherwise = (yes, ps, todo, prod:no)+++allSymbols :: [Production] -> Alphabet+allSymbols prodsInput = + (\(nts,ts) -> (nts, nub ts)) $ (foldr f ([],[]) prodsInput)+ where f (ProdProduction nt _ p) (nts, ts) = (nt:nts, (nub (freets p))++ts)+ -- compute the set of all terminals in a Production+ freets (ProdTerm prods) = concat (map freets prods)+ freets (ProdFactor prods) = concat (map freets prods)+ freets (ProdNonterminal s) = []+ freets (ProdTerminal s) = [s]+ freets (ProdOption p) = freets p+ freets (ProdRepeat p) = freets p+ freets (ProdRepeat1 p) = freets p+ freets (ProdRepeatWithAtom p1 p2) = freets p1 ++ freets p2+ freets (ProdPlus) = []+ freets (ProdEmpty) = []+ freets (ProdSlash p) = freets p+ + +getProdsInfo (GrammarInfo prods _ _ _ _ _) = prods+getNonterminals (GrammarInfo _ nts _ _ _ _) = nts+getTerminals (GrammarInfo _ _ ts _ _ _) = ts+getReduces (GrammarInfo _ _ _ rs _ _) = rs+getRedProds (GrammarInfo _ _ _ _ rp _) = rp+getEmpties (GrammarInfo _ _ _ _ _ es) = es++ +
+ src/IOSupplement.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE CPP #-}+-- -*- Mode: Haskell -*- +-- Copyright 1996 by Peter Thiemann+-- IOSupplement.hs --- some enhancements to the IO operations+-- Author : Peter Thiemann+-- Created On : Mon Aug 30 09:41:30 1993+-- Last Modified By: Peter Thiemann+-- Last Modified On: Thu Dec 2 10:37:39 1993+-- Update Count : 13+-- Status : Unknown, Use with caution!+-- +-- $Log: IOSupplement.hs,v $+-- Revision 1.3 1999/08/15 20:28:48 thiemann+-- *** empty log message ***+--+-- Revision 1.2 1999/04/16 07:17:36 thiemann+-- modified for Haskell98+--+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.2 1994/03/15 15:34:53 thiemann+-- generalized readPathFile+--+-- Revision 1.1 1993/08/31 12:31:32 thiemann+-- Initial revision+--++module IOSupplement (getPath, readPathFile, readRGBPathFile)+where++import System.IO+import System.IO.Error+import System.Environment++#ifdef __HBC__+ioError = fail+#endif+--------------------------------------------------------------------------------++getPath :: String -> [String] -> IO [String]+--+-- accepts the name of an environment variable and a [String] of default paths+-- and returns the default or the resulting search path .+getPath envVar dflt =+ catch + ( do path <- getEnv envVar+ return (manglePath path dflt) )+ ( \err -> if (isDoesNotExistError err) + then return dflt+ else ioError err )+++-- mangle a colon separated pathstring with a default path+manglePath :: String -> [String] -> [String]+manglePath "" dflt = dflt+manglePath cs dflt = case span (/= ':') cs of+ ("",':':cs') -> dflt ++ manglePath cs' []+ ("", "") -> dflt+ (path,':':cs') -> path: manglePath cs' dflt+ (path,"") -> [path]++--------------------------------------------------------------------------------++readPathFile :: [String] -> String -> IO String+-- readPathFile searchPath fileName +-- scan searchPath for fileName and read it+-- unless fileName starts with '.' or is absolute (starts with '/')+--+readPathFile _ fileName@('/':_) = readFile fileName +readPathFile _ fileName@('.':_) = readFile fileName +readPathFile [] fileName =+ putStr ("readPathFile failed on : " ++ fileName) >>+ error "Exit Ebnf2ps (C) Peter Thiemann\n"+readPathFile (path: paths) fileName =+ -- putStr ("trying in "++path++" : "++fullName ++"\n") >>+ try (readFile fullName) >>= \ result ->+ case result of+ Left _ -> readPathFile paths fileName+ Right cont -> return cont+ where+ fullName = path ++ '/': fileName++++readRGBPathFile :: [String] -> String -> IO String+-- +readRGBPathFile _ fileName@('/':_) = tryreadFile fileName +readRGBPathFile _ fileName@('.':_) = tryreadFile fileName +readRGBPathFile [] fileName =+ putStr ("readPathFile failed on : " ++ fileName) >> + return ""+readRGBPathFile (path: paths) fileName =+ try (readFile fullName) >>= \ result ->+ case result of+ Left _ -> readRGBPathFile paths fileName + Right cont -> return cont+ where fullName = path ++ '/': fileName++tryreadFile :: String -> IO String+tryreadFile file =+ try (readFile file) >>= \result ->+ return (case result of + Left _ -> ""+ Right str -> str)
+ src/Info.hs view
@@ -0,0 +1,46 @@+-- -*- Mode: Haskell -*- +-- Copyright 1994 by Peter Thiemann+--+-- just a provider of type declarations+-- +-- $Locker: $+-- $Log: Info.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.1 1994/03/15 15:34:53 thiemann+-- Initial revision+--+-- Last Modified By: M. Walter+--+++module Info where++import Color (Color)+import Fonts (FONT)++type ColorInfo = (Color, Color, Color, Color, Color, Color, Color, Color)+type INFO = (Int, Int, Int, Int, Int, FONT, FONT, FONT, ColorInfo)+type WrapperType = String -> INFO -> Container -> ShowS++type Container = (+-- rx, ry origin relative to bounding box+ Int, Int,+-- widht height of content's bounding box+ Int, Int,+-- inOutY relative position of entry/exit point+ Int,+ GObject)++data GObject+ = AString Color FONT String -- AString font theString+ | ABox Color Color Bool Container -- round edges toggle+ | Arrow Color Int -- Arrow size+ | Aline Color -- width height rlineto+ | ATurn Color TDirection -- a turn+ | AComposite [Container]+++data TDirection = SE | SW | WN | NE+
+ src/Lexer.hs view
@@ -0,0 +1,87 @@+module Lexer where+-- Copyright 1994 by Peter Thiemann+-- Last Modified By: M. Walter+--++import Data.Char++------------------------------------------------------------------------------+--NOW the lexer+------------------------------------------------------------------------------++data Token+ = Ident String | Symbol String | String String | Number String++instance Show Token where+ showsPrec n (Ident s) = showChar '[' . showString s . showString "] "+ showsPrec n (Symbol "\n") = showString "\n"+ showsPrec n (Symbol s) = showChar '<' . showString s . showString "> "+ showsPrec n (String s) = showChar '"' . showString s . showString "\" "+ showsPrec n (Number s) = showChar ' ' . showString s . showChar ' ' + showList [] = id+ showList (x:xs) = shows x . showList xs++isIdChar c = isAlpha c || isDigit c || c == '_' || c == '.' -- 1.01++theSymbols = "!@#$%^&*+./<=>?\\|:"+isSymbolChar c = c `elem` theSymbols++lexer :: String -> [Token]+lexer "" = []+lexer ('"':cs) = String (stchars): lexer srest+ where (stchars, srest) = lexString cs+lexer ('\'':cs) = String (oneChar): lexer srest+ where (oneChar, srest) = lexChar cs+lexer ((c@'\n'):cs) = Symbol [c]: lexer cs+lexer (c:cs)+ | isNewline c = Symbol [c]: lexer cs + | isSpace c = lexer cs+ | isDot c = Ident (c:idchars): lexer irest -- 1.01+ | isAlpha c = Ident (c:idchars): lexer irest + | isSymbolChar c = Symbol(c:sychars): lexer srest+ | isDigit c = Number (c:digits): lexer nrest+ | otherwise = Symbol([c]): lexer cs+ where (idchars, irest) = span isIdChar cs+ (sychars, srest) = span isSymbolChar cs+ (digits, nrest) = span isDigit cs+ isNewline c = c == '\n'+ isDot c = c == '.' -- 1.01++-- preprocessor for EBNF style comments+uncomment :: String -> String+uncomment "" = ""+uncomment ('#':cs) = uncomment (dropWhile (/= '\n') cs)+uncomment ('"':cs) = '"':uncommentString cs+uncomment ('\'':cs) = '\'':uncommentChar cs+uncomment (c:cs) = c:uncomment cs++uncommentString "" = ""+uncommentString ('\\':c:cs) = '\\':c:uncommentString cs+uncommentString ('"':cs) = '"':uncomment cs+uncommentString (c:cs) = c:uncommentString cs++uncommentChar "" = ""+uncommentChar ('\\':c:cs) = '\\':c:uncommentChar cs+uncommentChar ('\'':cs) = '"':uncomment cs+uncommentChar (c:cs) = c:uncommentChar cs++-- generic lexers+lexChar ('\\':c:'\'':cs) = ([c], cs)+lexChar (c:'\'':cs) = ([c], cs)+lexChar cs = ([], cs)++lexString ('\\':c:cs) = (c:stchars, srest) where (stchars, srest) = lexString cs+lexString ('"':cs) = ("", cs)+lexString ("") = ("","")+lexString (c:cs) = (c:stchars, srest) where (stchars, srest) = lexString cs++isIdent (Ident _ ) = True+isIdent _ = False++getIdent (Ident s) = s++isString (String _) = True+isString _ = False++getString (String s) = s+
+ src/ParseAux.hs view
@@ -0,0 +1,235 @@+module ParseAux where+import AbstractSyntax+import Lexer+import List+++happyError :: [Token'] -> a+happyError ts = error ("Parse error in " +++ case ts of+ [] -> " at EOF\n"+ _ -> "before\n" ++ showList (take 20 (dropWhile (==Newline) ts)) [] ++ "\n")++-- A preprocessor for literal scripts (slow)+unlit :: String -> String+unlit = unlines . map p . lines+ where p ('>':' ':cs) = cs+ p ('>':'\t':cs) = cs+ p _ = [] ++-- A preprocessor for yacc scripts ++yaccpreprocessor :: String -> String +yaccpreprocessor "" = ""+yaccpreprocessor ('%':'%':cs) = '%':'%': yaccRules cs+yaccpreprocessor ('\n':cs) = '\n':yaccpreprocessor cs+yaccpreprocessor (_:cs) = yaccpreprocessor cs + +yaccRules :: String -> String +yaccRules "" = ""+yaccRules ('/':'*':cs) = yaccRules (dropCComment 0 cs)+yaccRules ('%':'{':cs) = yaccRules (dropCSyntax cs)+yaccRules ('%':'%':cs) = "%%" +yaccRules ('\'':'{':'\'':cs) = '\'':'{':'\'': yaccRules cs+yaccRules ('{':cs) = '{':yaccRules (dropActions 0 cs)+yaccRules (c:cs) = c:yaccRules cs+ +dropCSyntax :: String -> String+dropCSyntax "" = ""+dropCSyntax ('%':'}':cs) = cs+dropCSyntax ('\n':cs) = '\n':dropCSyntax cs+dropCSyntax (c:cs) = dropCSyntax cs+ +dropCComment :: Int -> String -> String+dropCComment _ "" = ""+dropCComment n ('/':'*':cs) = dropCComment (n+1) cs+dropCComment n ('\n':cs) = '\n':dropCComment n cs+dropCComment n ('*':'/':cs) + | n == 0 = cs+ | otherwise = dropCComment (n-1) cs+dropCComment n (c:cs) = dropCComment n cs++ +dropActions :: Int -> String -> String +dropActions _ "" = ""+dropActions n ('"':cs) = dropActions n css where (_,css) = lexString cs+dropActions n ('\'':'{':'\'':cs) = dropActions n cs+dropActions n ('\'':'}':'\'':cs) = dropActions n cs+dropActions n ('{':cs) = dropActions (n+1) cs+dropActions n ('\n':cs) = '\n':dropActions n cs+dropActions n ('}':cs) + | n == 0 = '}':cs+ | otherwise = dropActions (n-1) cs+dropActions n (c:cs) = dropActions n cs +++-- A postprocessor for a grammar in EBNF and a postprocessor to make happy happy++data Token'+ = EbnfInput+ | HappyInput+ | YaccInput+ | Newline+ | Ident' String + | CIdent' String+ | Symbol' String+ | String' String+ | Number' String+ | Percent+ | DoublePercent+ | OpenBrace + | ClosingBrace+ | Bar + | SemiColon + | DoubleColon + | Colon+ | OpenBrack + | ClosingBrack+ | OpenParen + | ClosingParen+ | Dot + | Equal + | Plus + | Slash+ deriving Eq+++instance Show Token' where + showsPrec n (Ident' s) = showChar '[' . showString s . showString "] "+ showsPrec n (CIdent' s) = showChar '/' . showString s . showString "/"+ showsPrec n (Symbol' "\n") = showChar '\n'+ showsPrec n (Symbol' s) = showChar '<' . showString s . showString "> "+ showsPrec n (String' s) = showChar '"' . showString s . showString "\" " + showsPrec n (Number' s) = showChar ' ' . showString s . showChar ' ' + showsPrec n Percent = showString "%"+ showsPrec n DoublePercent = showString "%% "+ showsPrec n OpenBrace = showString "{ "+ showsPrec n ClosingBrace = showString "} "+ showsPrec n OpenBrack = showString "[ "+ showsPrec n ClosingBrack = showString "] "+ showsPrec n OpenParen = showString "( "+ showsPrec n ClosingParen = showString ") "+ showsPrec n Bar = showString "| "+ showsPrec n SemiColon = showString "; "+ showsPrec n DoubleColon = showString ":: "+ showsPrec n Colon = showString ": "+ showsPrec n Dot = showString ". "+ showsPrec n Equal = showString "= "+ showsPrec n Plus = showString "+ "+ showsPrec n Slash = showString "/ "+ showsPrec n Newline = showString "\n"+ showsPrec n YaccInput = showString "\n>>YACC input format<<\n"+ showsPrec n EbnfInput = showString "\n>>EBNF input format<<\n" + showsPrec n HappyInput = showString "\n>>HAPPY input format<<\n" + showList [] = id+ showList (x:xs) = shows x . showList xs+++-- a ebnf postlexer++ebnf_postlexer = \s -> EbnfInput : foldr f [] s+ where f (Symbol "\n") = id --Newline+ f (Symbol "=") = (Equal:)+ f (Symbol ".") = (Dot:)+ f (Symbol "|") = (Bar:)+ f (Symbol "/") = (Slash:)+ f (Symbol "+") = (Plus:)+ f (Symbol "(") = (OpenParen:)+ f (Symbol "[") = (OpenBrack:)+ f (Symbol "{") = (OpenBrace:)+ f (Symbol ")") = (ClosingParen:)+ f (Symbol "]") = (ClosingBrack:)+ f (Symbol "}") = (ClosingBrace:)+ f (Symbol ";") = (SemiColon:)+ f (Symbol s) = (Symbol' s:)+ f (Ident s) = (Ident' s:)+ f (String s) = (String' s:)+ f (Number n) = (Symbol' n:)++-- a happy postlexer++happy_postlexer = \s -> HappyInput : foldr f [] s+ where f (Symbol "\n") = id --Newline+ f (Symbol "%%") = (DoublePercent:)+ f (Symbol "%") = (Percent:)+ f (Symbol "{") = (OpenBrace:)+ f (Symbol "}") = (ClosingBrace:)+ f (Symbol "::") = (DoubleColon:)+ f (Symbol ":") = (Colon:)+ f (Symbol ";") = (SemiColon:)+ f (Symbol "|") = (Bar:)+ f (Symbol s) = (Symbol' s:)+ f (Ident s) = (Ident' s:)+ f (String s) = (String' s:)+ f (Number n) = (Symbol' n:)++-- a yacc postlexer++yacc_postlexer s = YaccInput : f s+ where toSkip [] = False+ toSkip (Symbol "\n":cs') = toSkip cs'+ toSkip (Symbol ":":_) = True+ toSkip (c:_) = False+ f [] = []+ f (Symbol "\n":cs) = f cs -- Newline+ f (Symbol "%":cs) = Percent : f cs+ f (Symbol "%%":cs) = DoublePercent : f cs+ f (Symbol "|":cs) = Bar : f cs+ f (Symbol "{":cs) = OpenBrace : f cs+ f (Symbol "}":cs) = ClosingBrace : f cs+ f (Symbol ";":cs) = SemiColon : f cs+ f (Symbol ":":cs) = Colon : f cs+ f (Symbol c :cs) = (Symbol' c): f cs+ f (String c :cs) = (String' c): f cs+ f (Number c :cs) = (Number' c): f cs+ f (Ident c :cs) | toSkip cs = (CIdent' c): f cs+ | otherwise = (Ident' c): f cs+++happyPrepare terminalsyms = map (happyPrepare' terminalsyms)+happyPrepare' ts (ProdProduction s1 s2 prod) = ProdProduction s1 s2 (happyPrepare' ts prod)+happyPrepare' ts (ProdFactor prods) = ProdFactor (map (happyPrepare' ts) prods)+happyPrepare' ts (ProdTerminal s) = ProdTerminal s+happyPrepare' ts (ProdOption prod) = ProdOption (happyPrepare' ts prod)+happyPrepare' ts (ProdRepeat prod) = ProdRepeat (happyPrepare' ts prod)+happyPrepare' ts (ProdRepeat1 prod) = ProdRepeat1 (happyPrepare' ts prod)+happyPrepare' ts (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (happyPrepare' ts p1) (happyPrepare' ts p2)+happyPrepare' ts (ProdPlus) = ProdPlus+happyPrepare' ts (ProdSlash prod) = ProdSlash (happyPrepare' ts prod)+happyPrepare' ts (ProdTerm prods) = ProdTerm (map (happyPrepare' ts) prods)+happyPrepare' ts (ProdNonterminal s) + | s `elem` ts = ProdTerminal s+ | otherwise = ProdNonterminal s++ +yaccPrepare happyresult =+ [noDup (getNt nt) | nt <- nub nonterminals]+ where (nonterminals, prods) = transform happyresult [] []+ getNt str = [yaccPrepare' nonterminals p | p@(ProdProduction nt _ _) <- prods, str == nt] + transform [] as bs = (as,bs)+ transform ((ProdProduction nt aliases (ProdTerm ps)):pss) as bs =+ transform pss' (nt:as) bs'+ where (factors, pss') = span isProdFactor pss + bs' = bs ++ [ProdProduction nt aliases (ProdTerm ps')]+ ps' = ps ++ factors + noDup [p] = p+ noDup (ProdProduction nt aliases (ProdTerm ps):p':ps') = + ProdProduction nt aliases + (ProdTerm (foldr (\ (ProdProduction _ _ (ProdTerm prods')) ps1 -> ps1++prods') ps (p':ps')))+ isProdFactor p = case p of { ProdFactor _ -> True; _ -> False}++yaccPrepare' nts (ProdProduction s1 s2 prod) = ProdProduction s1 s2 (yaccPrepare' nts prod)+yaccPrepare' nts (ProdFactor prods) = ProdFactor (map (yaccPrepare' nts) prods)+yaccPrepare' nts (ProdTerm prods) = ProdTerm (map (yaccPrepare' nts) prods)+yaccPrepare' nts (ProdOption prod) = ProdOption (yaccPrepare' nts prod)+yaccPrepare' nts (ProdRepeat prod) = ProdRepeat (yaccPrepare' nts prod)+yaccPrepare' nts (ProdRepeat1 prod) = ProdRepeat1 (yaccPrepare' nts prod)+yaccPrepare' nts (ProdRepeatWithAtom p1 p2) = ProdRepeatWithAtom (yaccPrepare' nts p1) (yaccPrepare' nts p2)+yaccPrepare' nts (ProdPlus) = ProdPlus+yaccPrepare' nts (ProdSlash prod) = ProdSlash (yaccPrepare' nts prod)+yaccPrepare' nts (ProdTerminal s) + | s `elem` nts = ProdNonterminal s+ | otherwise = ProdTerminal s+++
+ src/Parsers.hs view
@@ -0,0 +1,104 @@+--------------------------------------------------+-- Copyright 1994 by Peter Thiemann+-- $Log: Parsers.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.3 1994/03/15 15:34:53 thiemann+-- minor revisions+--+--Revision 1.2 1993/08/31 12:31:32 thiemann+--reflect changes in type FONT+--+--Revision 1.1 1993/08/17 12:34:29 thiemann+--Initial revision+--+-- $Locker: $+--------------------------------------------------+module Parsers where++infixl 6 `using`, `using2`+infixr 7 `alt`+infixr 8 `thn`, `xthn`, `thnx` ++type Parser a b = [a] -> [(b, [a])]++succeed :: beta -> Parser alpha beta+succeed value tokens = [(value, tokens)]++-- the parser+-- satisfy p+-- accepts the language { token | p(token) }++satisfy :: (alpha -> Bool) -> Parser alpha alpha+satisfy p [] = []+satisfy p (token:tokens) | p token = succeed token tokens+ | otherwise = []++-- the parser+-- literal word+-- accepts { word }++literal :: Eq alpha => alpha -> Parser alpha alpha+literal token = satisfy (== token)++-- if p1 and p2 are parsers accepting L1 and L2 then+-- then p1 p2+-- accepts L1.L2++thn :: Parser alpha beta -> Parser alpha gamma -> Parser alpha (beta, gamma)+thn p1 p2 =+ concat+ . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> ((v1,v2), tokens2)) (p2 tokens1))+ . p1++thnx :: Parser alpha beta -> Parser alpha gamma -> Parser alpha beta+thnx p1 p2 = + concat+ . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v1, tokens2)) (p2 tokens1))+ . p1++xthn :: Parser alpha beta -> Parser alpha gamma -> Parser alpha gamma+xthn p1 p2 =+ concat+ . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v2, tokens2)) (p2 tokens1))+ . p1+++-- if p1 and p2 are parsers accepting L1 and L2 then+-- alt p1 p2+-- accepts L1 \cup L2++alt :: Parser alpha beta -> Parser alpha beta -> Parser alpha beta+alt p1 p2 tokens = p1 tokens ++ p2 tokens++-- if p1 is a parser then+-- using p1 f+-- is a parser that accepts the same language as p1+-- but mangles the semantic value with f++using :: Parser alpha beta -> (beta -> gamma) -> Parser alpha gamma+using p1 f = map (\ (v, tokens) -> (f v, tokens)) . p1++using2 :: Parser a (b,c) -> (b -> c -> d) -> Parser a d+using2 p f = map ( \((v,w), tokens) -> (f v w, tokens)) . p++-- if p accepts L then plus p accepts L+++plus :: Parser alpha beta -> Parser alpha [beta]+plus p = (p `thn` rpt p) `using2` (:)++-- if p accepts L then rpt p accepts L*++rpt :: Parser alpha beta -> Parser alpha [beta]+rpt p = plus p `alt` succeed []++-- if p accepts L then opt p accepts L?++opt :: Parser alpha beta -> Parser alpha [beta]+opt p = (p `using` \x -> [x]) `alt` succeed []++-- followedBy p1 p2 recognizes L(p1) if followed by a word in L (p2)++followedBy :: Parser a b -> Parser a c -> Parser a b+followedBy p q tks = [(v, rest) | (v, rest) <- p tks, x <- q rest]
+ src/PsOutput.hs view
@@ -0,0 +1,358 @@+--------------------------------------------------+-- Copyright 1994-2000 by Peter Thiemann+--------------------------------------------------++module PsOutput (psShowsWrapper) where++-- import EbnfLayout++import Version+import Fonts (FONT, fontName, fontScale, noFont)+import Color (Color, showsPsColor, noColor)+import Info (Container, GObject (..), TDirection (..), WrapperType)++infixr `comb`++-- psState = (currentColor, currentFont, currentLinewidth)++type PsState = ((Color, FONT, Int), ShowS)+type PsTrafo = PsState -> PsState++type PsState' = (Color, FONT, Int)+type PsTrafo' = PsState' -> PsState+ +initialState :: PsState'+initialState = (noColor, noFont, -1)+ +setColor :: Color -> PsTrafo'+setColor clr st@(clr0, fnt0, lw0)+ | clr == clr0 = (st, id)+ | otherwise = ((clr, fnt0, lw0), showsPsColor clr)+ +setFont :: FONT -> PsTrafo'+setFont font st@(clr0, fnt0, lw0)+ | font == fnt0 = (st, id)+ | otherwise = ((clr0, font, lw0),+ showString ('/':fontName font) . showString " findfont " .+ shows (fontScale font) . showString " scalefont" .+ showString " setfont\n")+ +setLineWidth :: Int -> PsTrafo'+setLineWidth lw st@(clr0, fnt0, lw0)+ | lw == lw0 = (st, id)+ | otherwise = ((clr0, fnt0, lw), showsPsNum lw . showString " slw\n")+ +drawBox :: Bool -> Int -> Int -> Int -> Int -> Int -> Color -> PsTrafo'+drawBox rounded ax ay width height lw clr@(r,g,b) (clr0, fnt0, lw0) = + ((clr0, fnt0, lw),+ showsPsNum ax . showsPsNum ay .+ showsPsNum width . showsPsNum height . showsPsNum lw . showsPsRGB r g b .+ showString (if rounded then " RBox\n" else " Box\n"))+ where showsPsRGB r g b = showChar ' ' . shows r .+ showChar ' ' . shows g .+ showChar ' ' . shows b + +drawString :: Int -> Int -> String -> PsTrafo'+drawString ax ay str (clr0, fnt0, lw0) = + ((clr0, fnt0, lw0),+ showsMoveto ax ay .+ showChar '(' . showString (psString str) . showChar ')' .+ showString " show\n")+ +drawRLine :: Int -> Int -> [(Int, Int)] -> PsTrafo'+drawRLine ax ay rels (clr0, fnt0, lw0) =+ ((clr0, fnt0, lw0),+ showString "n" .+ showsMoveto ax ay .+ foldr (.) (showString " s\n") [ showsRLineto rx ry | (rx, ry) <- rels ])+ +insertShowS :: ShowS -> PsTrafo'+insertShowS shower1 (clr0, fnt0, lw0) = ((clr0, fnt0, lw0), shower1)+ +runTrafo :: PsTrafo' -> ShowS+runTrafo f = shower where+ ((_, _, _), shower) = f initialState+++comb :: PsTrafo' -> PsTrafo' -> PsTrafo'+comb pst1 pst2 st =+ let (r1, shower1) = pst1 st + st2@(r2, shower2) = pst2 r1+ in (r2, (shower1 . shower2))++returnPs :: ShowS -> PsTrafo'+returnPs s = \v -> (v, s)+ +psShowsWrapper :: String -> WrapperType+psShowsWrapper dateOutput title+ (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize, titleFont,ntFont, tFont,+ (ntColor, tColor, lineColor, ntBoxColor, tBoxColor,_,_,_))+ container@(rx, ry, width, height, inOutY, gobj) =+ showString "%!PS-Adobe-2.0 EPSF-2.0" .+ showString ("\n%%Creator: Ebnf2ps Version " ++ version ++ "(C) 1996-2000 by Peter Thiemann") .+ showString ("\n%%CreationDate: " ++ dateOutput) .+ showString "%%DocumentFonts: " .+ showString titleFontName .+ printFonts titleFontName ntFontName tFontName .+ showString "\n%%Title: " . showString title .+ showString "\n%%Pages: 0" .+ showString "\n%%BoundingBox:" . + showsPsNum (psFloor rx) . showsPsNum (psFloor ry) .+ showsPsNum (psCeil (rx+width)) . showsPsNum (psCeil (ry+height)) .+ showString "\n%%EndComments\n" .+ showPsProlog psProlog .+ showString "\n%%EndProlog\n" .+ showString "\n$Ebnf2psBegin\n" .+ runTrafo (psShowsContainer rx ry container) .+ showString "\n$Ebnf2psEnd\n"+ where+ titleFontName = fontName titleFont + ntFontName = fontName ntFont+ tFontName = fontName tFont+ showPsProlog s = foldr1 (\a b -> a . showString "\n" . b) (map showString s)+ printFonts f1 f2 f3 + | f1 == f2 = if f2 == f3 then id else (showChar ' ' . showString f3)+ | otherwise = showChar ' ' . showString f2 . (if f2 == f3 then id else (showChar ' ' . showString f3))+ + psShowsContainer :: Int -> Int -> Container -> PsTrafo'+ psShowsContainer ax ay (rx, ry, width, height, inOutY, gobj) =+ case gobj of+ AString color font theString ->+ setFont font `comb`+ setColor color `comb`+ drawString ax1 ay1 theString + ABox color bgcolor rounded content ->+ setColor color `comb`+ drawBox rounded ax1 ay1 width height fatLineWidth bgcolor `comb`+ psShowsContainer ax1 ay1 content + Arrow color size ->+ setColor color `comb`+ setLineWidth lineWidth `comb`+ drawRLine (ax1-size) (ay1+abs size) [(size, -abs size), (-size, -abs size)] + Aline color ->+ setColor color `comb`+ setLineWidth lineWidth `comb`+ drawRLine ax1 ay1 [(width, height)] + ATurn color dir ->+ setColor color `comb`+ setLineWidth lineWidth `comb`+ returnPs (+ showString "n" .+ showsIt dir .+ showString " s\n") + where+ showsIt SE = showsMoveto ax1 ay1 .+ showsArcto ax1 (ay1+height) (ax1+width) (ay1+height) radius .+ showsLineto (ax1+width) (ay1+height)+ showsIt WN = showsMoveto ax1 ay1 .+ showsArcto (ax1+width) ay1 (ax1+width) (ay1+height) radius .+ showsLineto (ax1+width) (ay1+height)+ showsIt SW = showsMoveto (ax1+width) ay1 .+ showsArcto (ax1+width) (ay1+height) ax1 (ay1+height) radius .+ showsLineto ax1 (ay1+height)+ showsIt NE = showsMoveto (ax1+width) ay1 .+ showsArcto ax1 ay1 ax1 (ay1+height) radius .+ showsLineto ax1 (ay1+height)+ radius = min height width+ AComposite contents ->+ foldr comb (returnPs id) (map (psShowsContainer ax1 ay1) contents)+ where+ ax1 = ax + rx+ ay1 = ay + ry+++-- showsPsColor color = showString " col" . showsColor color+++showsSetlinewidth lineWidth = showsPsNum lineWidth . showString " slw"+ +showsMoveto x y = showsPsXY x y . showString " m"+ +showsLineto x y = showsPsXY x y . showString " l"+ +showsArcto x1 y1 x2 y2 r = showsPsXY x1 y1 . showsPsXY x2 y2 . showsPsNum r .+ showString " apr\n"+ +showsRMoveto x y = showsPsXY x y . showString " rm"+ +showsRLineto x y = showsPsXY x y . showString " rl"+ +showsPsXY x y = showsPsNum x . showsPsNum y+ +showsPsNum :: Int -> ShowS+showsPsNum x = showChar ' ' . shows x100 .+ if x99 == 0 then id+ else showChar '.' . shows x1 . shows x2+ where (x100,x99) = x `divMod` 100+ (x1,x2) = x99 `divMod` 10+ +psFloor, psCeil :: Int -> Int+psFloor x = 100 * (x `div` 100)+psCeil x = 100 * ((x + 99) `div` 100)++-- showsPsInt :: Int -> showS+-- showsPsInt x = showChar ' ' . showInt (x `div` 100)+ +psString "" = ""+psString ('(':cs) = "\\(" ++ psString cs+psString (')':cs) = "\\)" ++ psString cs+psString ('\\':cs)= "\\\\" ++ psString cs+psString ('-':cs) = "\\261" ++ psString cs -- endash looks much nicer+psString (c:cs) = c:psString cs++-- Box: width height linewidth Box -> -+-- draw box at current point++psProlog :: [String]+psProlog = [+ "/$Ebnf2psDict 100 dict def",+ "$Ebnf2psDict begin",+ "/l {lineto} bind def",+ "/m {moveto} bind def",+ "/rl {rlineto} bind def",+ "/rm {rmoveto} bind def",+ "/s {stroke} bind def",+ "/n {newpath} bind def",+ "/gs {gsave} bind def",+ "/gr {grestore} bind def",+ "/clp {closepath} bind def",+ "/slw {setlinewidth} bind def",+ "/graycol {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul",+ "4 -2 roll mul setrgbcolor} bind def",+ "/scol {3 {255 div 3 1 roll} repeat setrgbcolor} bind def",+ " /apr {arcto 4 {pop} repeat} def",+ "/Box {",+ " /bgB exch def",+ " /bgG exch def",+ " /bgR exch def",+ " /linewidth exch def",+ " /height exch def",+ " /width exch def",+ " /lly exch def",+ " /llx exch def",+ " linewidth 2 div dup llx add /llx exch def lly add /lly exch def",+ " /height height linewidth sub def",+ " /width width linewidth sub def",+ " /linewidth0 {clp gsave bgR bgG bgB scol fill grestore} def",+ " /linewidth1 {clp linewidth gsave bgR bgG bgB scol fill grestore slw s} def",+ " n llx lly m",+ " width 0 rl",+ " 0 height rl",+ " width neg 0 rl",+ " 0 height neg rl",+ " linewidth 0 eq {linewidth0} {linewidth1} ifelse",+ "} def",+ "/RBox {",+ " /bgB exch def",+ " /bgG exch def",+ " /bgR exch def",+ " /linewidth exch def",+ " /height exch def",+ " /width exch def",+ " /lly exch def",+ " /llx exch def",+ " linewidth 2 div dup llx add /llx exch def lly add /lly exch def",+ " /height height linewidth sub def",+ " /width width linewidth sub def",+ " /height2 height 2 div def",+ " /width2 width 2 div def",+ " /urx llx width add def",+ " /ury lly height add def",+ " /mmx llx width2 add def",+ " /mmy lly height2 add def",+ " /linewidth0 {clp gsave bgR bgG bgB scol fill grestore} def",+ " /linewidth1 {clp linewidth gsave bgR bgG bgB scol fill grestore slw s} def",+ " /radius width2 height2 ge {height2} {width2} ifelse def",+ " n mmx lly m",+ " urx lly urx mmy radius apr",+ " urx ury mmx ury radius apr",+ " llx ury llx mmy radius apr",+ " llx lly mmx lly radius apr",+ " mmx lly l",+ " linewidth 0 eq {linewidth0} {linewidth1} ifelse",+ "} def",+ "end",+ "/$Ebnf2psBegin {$Ebnf2psDict begin /$Ebnf2psEnteredState save def} def",+ "/$Ebnf2psEnd {$Ebnf2psEnteredState restore end} def\n"]++{-+NOTE: '-cpp is not friendly to "string gaps"' ++psProlog :: String+psProlog = "\+\/$Ebnf2psDict 100 dict def\n\+\$Ebnf2psDict begin\n\+\/l {lineto} bind def\n\+\/m {moveto} bind def\n\+\/rl {rlineto} bind def\n\+\/rm {rmoveto} bind def\n\+\/s {stroke} bind def\n\+\/n {newpath} bind def\n\+\/gs {gsave} bind def\n\+\/gr {grestore} bind def\n\+\/clp {closepath} bind def\n\+\/slw {setlinewidth} bind def\n\+\/graycol {dup dup currentrgbcolor 4 -2 roll mul 4 -2 roll mul\n\+\4 -2 roll mul setrgbcolor} bind def\n\+\/scol {3 {255 div 3 1 roll} repeat setrgbcolor} bind def\n\+\ \+\/apr {arcto 4 {pop} repeat} def\n\+\/Box {\n\+\ /bgB exch def\n\+\ /bgG exch def\n\+\ /bgR exch def\n\+\ /linewidth exch def\n\+\ /height exch def\n\+\ /width exch def\n\+\ /lly exch def\n\+\ /llx exch def\n\+\ linewidth 2 div dup llx add /llx exch def lly add /lly exch def\n\+\ /height height linewidth sub def\n\+\ /width width linewidth sub def\n\+\ /linewidth0 {clp gsave bgR bgG bgB scol fill grestore} def\n\+\ /linewidth1 {clp linewidth gsave bgR bgG bgB scol fill grestore slw s} def\n\+\ \+\ n llx lly m\n\+\ width 0 rl\n\+\ 0 height rl\n\+\ width neg 0 rl\n\+\ 0 height neg rl\n\+\ linewidth 0 eq {linewidth0} {linewidth1} ifelse\n\+\} def\n\+\ \+\/RBox {\n\+\ /bgB exch def\n\+\ /bgG exch def\n\+\ /bgR exch def\n\+\ /linewidth exch def\n\+\ /height exch def\n\+\ /width exch def\n\+\ /lly exch def\n\+\ /llx exch def\n\+\ linewidth 2 div dup llx add /llx exch def lly add /lly exch def\n\+\ /height height linewidth sub def\n\+\ /width width linewidth sub def\n\+\ /height2 height 2 div def\n\+\ /width2 width 2 div def\n\+\ /urx llx width add def\n\+\ /ury lly height add def\n\+\ /mmx llx width2 add def\n\+\ /mmy lly height2 add def\n\+\ /linewidth0 {clp gsave bgR bgG bgB scol fill grestore} def\n\+\ /linewidth1 {clp linewidth gsave bgR bgG bgB scol fill grestore slw s} def\n\+\ /radius width2 height2 ge {height2} {width2} ifelse def\n\+\ \+\ n mmx lly m\n\+\ urx lly urx mmy radius apr\n\+\ urx ury mmx ury radius apr\n\+\ llx ury llx mmy radius apr\n\+\ llx lly mmx lly radius apr\n\+\ mmx lly l\n\+\ linewidth 0 eq {linewidth0} {linewidth1} ifelse\n\+\} def\n\+\end\n\+\/$Ebnf2psBegin {$Ebnf2psDict begin /$Ebnf2psEnteredState save def} def\n\+\/$Ebnf2psEnd {$Ebnf2psEnteredState restore end} def\n\+\\n"+-}+
+ src/StringMatch.hs view
@@ -0,0 +1,97 @@+-- -*- Mode: Haskell -*- +-- Copyright 1994 by Peter Thiemann+-- StringMatch.hs --- translate regular expression into a string match function+-- Author : Peter Thiemann+-- Created On : Thu Dec 23 11:16:26 1993+-- Last Modified By: Peter Thiemann+-- Last Modified On: Thu Dec 23 12:32:39 1993+-- Update Count : 18+-- Status : Unknown, Use with caution!+-- +-- $Locker: $+-- $Log: StringMatch.hs,v $+-- Revision 1.1.1.1 1998/12/09 13:34:08 pjt+-- Imported sources+--+-- Revision 1.1 1994/03/15 15:34:53 thiemann+-- Initial revision+--+-- ++module StringMatch {-(stringMatch)-} where++import Parsers++infixr 8 +.+ , +.. , ..++infixl 7 <<< , <<*+infixr 6 |||++(+.+) = thn+(..+) = xthn+(+..) = thnx+(|||) = alt+(<<<) = using+(<<*) = using2+lit :: Eq a => a -> Parser a a+lit = literal+star = rpt+anyC = satisfy (const True)+butC cs = satisfy (not.(`elem` cs))+noC "" = [("","")]+noC _ = []+unitL = \x -> [x]++--+-- grammar for regular expressions:+--+{-+ Atom = character | "\\" character | "." | "\\(" Regexp "\\) .+ ExtAtom = Atom ["*" | "+" | "?"] .+ Factor = ExtAtom + .+ Regexp = Factor / "\\|" ["$"].+-}++type ParseRegexp = Parser Char String++rrAtom :: Parser Char ParseRegexp+rrAtom =+ lit '\\' ..+ lit '(' ..+ rrRegexp +.. lit '\\' +.. lit ')'+ ||| + ( lit '\\' ..+ butC "|()" <<< lit+ ||| lit '.' <<< const anyC+ ||| butC "\\.$" <<< lit+ ||| lit '$' `followedBy` anyC <<< lit+ ) <<< (<<< unitL)++rrExtAtom :: Parser Char ParseRegexp+rrExtAtom =+ rrAtom +.+ opt (lit '*' <<< const star+ ||| lit '+' <<< const plus+ ||| lit '?' <<< const opt)+ <<< helper+ where+ helper (ea, []) = ea+ helper (ea, [f]) = f ea <<< concat++rrFactor :: Parser Char ParseRegexp+rrFactor =+ plus rrExtAtom <<< foldr (\ p1 p2 -> p1 +.+ p2 <<* (++)) (succeed "")++rrRegexp =+ rrFactor +.+ star (lit '\\' ..+ lit '|' ..+ rrFactor) +.+ opt (lit '$')+ <<< helper+ where+ helper (ef, (efs, [])) = foldl (|||) ef efs +.. star anyC+ helper (ef, (efs, _ )) = foldl (|||) ef efs +.. noC++regexp0 :: Parser Char (Parser Char String)+regexp0 =+ lit '^' ..+ rrRegexp+ ||| rrRegexp+ <<< (\p -> let p' = p ||| anyC ..+ p' in p')++stringMatch :: String -> String -> Bool+stringMatch re subject = wellformed && not (null (filter (null . snd) (match subject)))+ where matches = regexp0 re+ wellformed = not (null matches) && null rest+ (match,rest) = head matches
+ src/Version.hs view
@@ -0,0 +1,2 @@+module Version where+version="1.0.8 (Jun 2010)"