BNFC 2.6.0.3 → 2.7.0.0
raw patch · 192 files changed
+20677/−19699 lines, 192 filesdep +HUnitdep +QuickCheckdep +deepseqdep −BNFCdep ~basedep ~prettyPVP ok
version bump matches the API change (PVP)
Dependencies added: HUnit, QuickCheck, deepseq, filepath, hspec, temporary
Dependencies removed: BNFC
Dependency ranges changed: base, pretty
API changes (from Hackage documentation)
+ Data.Matrix.Quad: scatterplot :: AbelianGroup t => SomeTri t -> [Char]
+ Data.Matrix.Quad: shiftX :: Shape' s -> [(Int, t, t1)] -> [(Int, t, t1)]
+ Data.Matrix.Quad: shiftY :: Shape' s -> [(t, Int, t1)] -> [(t, Int, t1)]
+ Data.Matrix.Quad: sparse :: AbelianGroup a => Shape' x -> Shape' y -> Mat x y a -> [(Int, Int, a)]
Files
- BNFC.cabal +138/−113
- TODO +112/−0
- dist/build/bnfc/bnfc-tmp/LexBNF.hs +36/−2
- dist/build/bnfc/bnfc-tmp/ParBNF.hs +28/−0
- dist/build/unit-tests/unit-tests-tmp/LexBNF.hs +417/−0
- dist/build/unit-tests/unit-tests-tmp/ParBNF.hs +1733/−0
- runtime/Algebra/RingUtils.hs +2/−2
- runtime/Data/Matrix/Class.hs +10/−10
- runtime/Data/Matrix/Quad.hs +41/−28
- runtime/Parsing/Chart.hs +7/−7
- runtime/Parsing/TestProgram.hs +22/−18
- src/BNFC/Backend/Base.hs +73/−0
- src/BNFC/Backend/C.hs +201/−0
- src/BNFC/Backend/C/CFtoBisonC.hs +276/−0
- src/BNFC/Backend/C/CFtoCAbs.hs +320/−0
- src/BNFC/Backend/C/CFtoCPrinter.hs +644/−0
- src/BNFC/Backend/C/CFtoCSkel.hs +240/−0
- src/BNFC/Backend/C/CFtoFlexC.hs +189/−0
- src/BNFC/Backend/CPP/NoSTL.hs +181/−0
- src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs +351/−0
- src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs +443/−0
- src/BNFC/Backend/CPP/NoSTL/CFtoCPPPrinter.hs +598/−0
- src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs +259/−0
- src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs +191/−0
- src/BNFC/Backend/CPP/NoSTL/RegToFlex.hs +73/−0
- src/BNFC/Backend/CPP/STL.hs +195/−0
- src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs +372/−0
- src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs +148/−0
- src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs +275/−0
- src/BNFC/Backend/CPP/STL/CFtoSTLPrinter.hs +648/−0
- src/BNFC/Backend/CPP/STL/STLUtils.hs +37/−0
- src/BNFC/Backend/CSharp.hs +348/−0
- src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs +277/−0
- src/BNFC/Backend/CSharp/CAbstoCSharpAbstractVisitSkeleton.hs +97/−0
- src/BNFC/Backend/CSharp/CAbstoCSharpVisitSkeleton.hs +118/−0
- src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs +455/−0
- src/BNFC/Backend/CSharp/CFtoGPLEX.hs +221/−0
- src/BNFC/Backend/CSharp/CFtoGPPG.hs +274/−0
- src/BNFC/Backend/CSharp/CSharpUtils.hs +154/−0
- src/BNFC/Backend/CSharp/RegToGPLEX.hs +73/−0
- src/BNFC/Backend/Common/Makefile.hs +26/−0
- src/BNFC/Backend/Common/NamedVariables.hs +146/−0
- src/BNFC/Backend/Common/OOAbstract.hs +129/−0
- src/BNFC/Backend/Common/StrUtils.hs +28/−0
- src/BNFC/Backend/Haskell.hs +278/−0
- src/BNFC/Backend/Haskell/CFtoAbstract.hs +61/−0
- src/BNFC/Backend/Haskell/CFtoAlex.hs +230/−0
- src/BNFC/Backend/Haskell/CFtoAlex2.hs +339/−0
- src/BNFC/Backend/Haskell/CFtoAlex3.hs +363/−0
- src/BNFC/Backend/Haskell/CFtoHappy.hs +277/−0
- src/BNFC/Backend/Haskell/CFtoLayout.hs +270/−0
- src/BNFC/Backend/Haskell/CFtoPrinter.hs +189/−0
- src/BNFC/Backend/Haskell/CFtoTemplate.hs +114/−0
- src/BNFC/Backend/Haskell/HsOpts.hs +78/−0
- src/BNFC/Backend/Haskell/MkErrM.hs +62/−0
- src/BNFC/Backend/Haskell/MkSharedString.hs +67/−0
- src/BNFC/Backend/Haskell/RegToAlex.hs +88/−0
- src/BNFC/Backend/Haskell/ToCNF.hs +224/−0
- src/BNFC/Backend/HaskellGADT.hs +269/−0
- src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs +148/−0
- src/BNFC/Backend/HaskellGADT/CFtoPrinterGADT.hs +167/−0
- src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs +66/−0
- src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs +83/−0
- src/BNFC/Backend/HaskellProfile.hs +208/−0
- src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs +222/−0
- src/BNFC/Backend/Java.hs +251/−0
- src/BNFC/Backend/Java/CFtoAbstractVisitor.hs +60/−0
- src/BNFC/Backend/Java/CFtoAllVisitor.hs +51/−0
- src/BNFC/Backend/Java/CFtoComposVisitor.hs +114/−0
- src/BNFC/Backend/Java/CFtoCup15.hs +273/−0
- src/BNFC/Backend/Java/CFtoFoldVisitor.hs +101/−0
- src/BNFC/Backend/Java/CFtoJLex15.hs +175/−0
- src/BNFC/Backend/Java/CFtoJavaAbs15.hs +257/−0
- src/BNFC/Backend/Java/CFtoJavaPrinter15.hs +361/−0
- src/BNFC/Backend/Java/CFtoVisitSkel15.hs +141/−0
- src/BNFC/Backend/Java/RegToJLex.hs +86/−0
- src/BNFC/Backend/Latex.hs +309/−0
- src/BNFC/Backend/OCaml.hs +165/−0
- src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs +64/−0
- src/BNFC/Backend/OCaml/CFtoOCamlLex.hs +244/−0
- src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs +195/−0
- src/BNFC/Backend/OCaml/CFtoOCamlShow.hs +149/−0
- src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs +73/−0
- src/BNFC/Backend/OCaml/CFtoOCamlTest.hs +70/−0
- src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs +234/−0
- src/BNFC/Backend/OCaml/OCamlUtil.hs +69/−0
- src/BNFC/Backend/Txt2Tag.hs +249/−0
- src/BNFC/Backend/XML.hs +232/−0
- src/BNFC/CF.hs +683/−0
- src/BNFC/GetCF.hs +391/−0
- src/BNFC/MultiView.hs +137/−0
- src/BNFC/Options.hs +279/−0
- src/BNFC/ToCNFCore.hs +288/−0
- src/BNFC/TypeChecker.hs +146/−0
- src/BNFC/Utils.hs +148/−0
- src/BNFC/WarningM.hs +26/−0
- src/CF.hs +0/−605
- src/ErrM.hs +10/−0
- src/GetCF.hs +0/−373
- src/LexBNF.x +2/−1
- src/Main.hs +55/−189
- src/MultiView.hs +0/−137
- src/Options.hs +0/−34
- src/PrintBNF.hs +0/−2
- src/TypeChecker.hs +0/−146
- src/Utils.hs +0/−168
- src/formats/CFtoLatex.hs +0/−276
- src/formats/CFtoTxt.hs +0/−249
- src/formats/NamedVariables.hs +0/−109
- src/formats/OOAbstract.hs +0/−129
- src/formats/c-sharp/CAbstoCSharpAbs.hs +0/−277
- src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs +0/−97
- src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs +0/−118
- src/formats/c-sharp/CFtoCSharpPrinter.hs +0/−455
- src/formats/c-sharp/CFtoGPLEX.hs +0/−221
- src/formats/c-sharp/CFtoGPPG.hs +0/−275
- src/formats/c-sharp/CSharpTop.hs +0/−361
- src/formats/c-sharp/CSharpUtils.hs +0/−154
- src/formats/c-sharp/RegToGPLEX.hs +0/−73
- src/formats/c/CFtoBisonC.hs +0/−275
- src/formats/c/CFtoCAbs.hs +0/−329
- src/formats/c/CFtoCPrinter.hs +0/−654
- src/formats/c/CFtoCSkel.hs +0/−240
- src/formats/c/CFtoFlexC.hs +0/−189
- src/formats/c/CTop.hs +0/−206
- src/formats/cpp/CFtoBison.hs +0/−352
- src/formats/cpp/CFtoCPPAbs.hs +0/−443
- src/formats/cpp/CFtoCPPPrinter.hs +0/−606
- src/formats/cpp/CFtoCVisitSkel.hs +0/−259
- src/formats/cpp/CFtoFlex.hs +0/−191
- src/formats/cpp/CPPTop.hs +0/−201
- src/formats/cpp/RegToFlex.hs +0/−73
- src/formats/cpp_stl/CFtoBisonSTL.hs +0/−374
- src/formats/cpp_stl/CFtoCVisitSkelSTL.hs +0/−148
- src/formats/cpp_stl/CFtoSTLAbs.hs +0/−275
- src/formats/cpp_stl/CFtoSTLPrinter.hs +0/−658
- src/formats/cpp_stl/STLTop.hs +0/−216
- src/formats/cpp_stl/STLUtils.hs +0/−37
- src/formats/f-sharp/FSharpTop.hs +0/−188
- src/formats/haskell-gadt/CFtoAbstractGADT.hs +0/−147
- src/formats/haskell-gadt/CFtoPrinterGADT.hs +0/−167
- src/formats/haskell-gadt/CFtoTemplateGADT.hs +0/−65
- src/formats/haskell-gadt/HaskellGADTCommon.hs +0/−83
- src/formats/haskell-gadt/HaskellTopGADT.hs +0/−309
- src/formats/haskell2/CFtoAbstract.hs +0/−51
- src/formats/haskell2/CFtoAlex.hs +0/−230
- src/formats/haskell2/CFtoAlex2.hs +0/−338
- src/formats/haskell2/CFtoAlex3.hs +0/−356
- src/formats/haskell2/CFtoHappy.hs +0/−278
- src/formats/haskell2/CFtoLayout.hs +0/−270
- src/formats/haskell2/CFtoPrinter.hs +0/−189
- src/formats/haskell2/CFtoTemplate.hs +0/−114
- src/formats/haskell2/HaskellTop.hs +0/−280
- src/formats/haskell2/HsOpts.hs +0/−78
- src/formats/haskell2/MkErrM.hs +0/−51
- src/formats/haskell2/MkSharedString.hs +0/−67
- src/formats/haskell2/RegToAlex.hs +0/−88
- src/formats/haskell2/ToCNF.hs +0/−472
- src/formats/java/CFtoCup.hs +0/−282
- src/formats/java/CFtoJLex.hs +0/−174
- src/formats/java/CFtoJavaAbs.hs +0/−238
- src/formats/java/CFtoJavaPrinter.hs +0/−367
- src/formats/java/CFtoJavaSkeleton.hs +0/−124
- src/formats/java/CFtoVisitSkel.hs +0/−173
- src/formats/java/JavaTop.hs +0/−306
- src/formats/java/RegToJLex.hs +0/−86
- src/formats/java1.5/CFtoAbstractVisitor.hs +0/−60
- src/formats/java1.5/CFtoAllVisitor.hs +0/−51
- src/formats/java1.5/CFtoComposVisitor.hs +0/−117
- src/formats/java1.5/CFtoCup15.hs +0/−274
- src/formats/java1.5/CFtoFoldVisitor.hs +0/−104
- src/formats/java1.5/CFtoJLex15.hs +0/−175
- src/formats/java1.5/CFtoJavaAbs15.hs +0/−263
- src/formats/java1.5/CFtoJavaPrinter15.hs +0/−361
- src/formats/java1.5/CFtoVisitSkel15.hs +0/−141
- src/formats/java1.5/JavaTop15.hs +0/−281
- src/formats/ocaml/CFtoOCamlAbs.hs +0/−63
- src/formats/ocaml/CFtoOCamlLex.hs +0/−230
- src/formats/ocaml/CFtoOCamlPrinter.hs +0/−200
- src/formats/ocaml/CFtoOCamlShow.hs +0/−153
- src/formats/ocaml/CFtoOCamlTemplate.hs +0/−73
- src/formats/ocaml/CFtoOCamlTest.hs +0/−70
- src/formats/ocaml/CFtoOCamlYacc.hs +0/−232
- src/formats/ocaml/OCamlTop.hs +0/−188
- src/formats/ocaml/OCamlUtil.hs +0/−72
- src/formats/profile/CFtoHappyProfile.hs +0/−223
- src/formats/profile/ProfileTop.hs +0/−226
- src/formats/xml/CFtoXML.hs +0/−216
- test/BNFC/Backend/Common/MakefileSpec.hs +24/−0
- test/BNFC/OptionsSpec.hs +127/−0
- test/BNFC/WarningMSpec.hs +28/−0
- test/unit-tests.hs +1/−0
BNFC.cabal view
@@ -1,5 +1,5 @@ Name: BNFC-Version: 2.6.0.3+Version: 2.7.0.0 cabal-version: >= 1.8 build-type: Simple category: Development@@ -22,7 +22,7 @@ a Happy, CUP, or Bison parser generator file, a pretty-printer as a Haskell/Java/C++/C module, a Latex file containing a readable specification of the language.-Extra-source-files: src/BNF.cf+Extra-source-files: src/BNF.cf TODO Library hs-source-dirs: runtime, src@@ -36,125 +36,150 @@ Parsing.TestProgram Executable bnfc- Build-Depends: base>=4.4 && <5, mtl, directory, array, process, containers, pretty >=1.1 && <1.2, BNFC+ Build-Depends:+ base>=4.4 && <5,+ mtl,+ directory,+ array,+ process,+ containers,+ pretty >=1.1 && <1.2,+ filepath,+ deepseq+ build-tools: alex, happy Main-is: Main.hs- HS-source-dirs: src src/formats- src/formats/haskell2- src/formats/haskell-gadt- src/formats/xml- src/formats/profile- src/formats/java- src/formats/java1.5- src/formats/cpp- src/formats/c- src/formats/ocaml- src/formats/cpp_stl- src/formats/c-sharp- src/formats/f-sharp+ HS-source-dirs: src/+ ghc-options: -fwarn-incomplete-patterns Other-modules:+ -- generated by cabal+ Paths_BNFC,+ -- Generated by bnfc LexBNF, ParBNF, AbsBNF, PrintBNF,- Utils,- CF, ErrM,- MultiView,- TypeChecker,- GetCF,- NamedVariables,- OOAbstract,- CFtoLatex,- CFtoXML,- CFtoTxt,- Options,- ToCNF,- -- Haskell- HaskellTop,- RegToAlex,- CFtoTemplate,- CFtoAlex3,- CFtoAlex2,- CFtoAlex,- CFtoHappy,- CFtoPrinter,- CFtoAbstract,- CFtoLayout,- MkErrM,- MkSharedString,- HsOpts,+ -- BNFC core+ BNFC.Utils,+ BNFC.CF,+ BNFC.ToCNFCore,+ BNFC.MultiView,+ BNFC.TypeChecker,+ BNFC.GetCF,+ BNFC.Backend.Base+ BNFC.Backend.Common.Makefile,+ BNFC.Backend.Common.NamedVariables,+ BNFC.Backend.Common.OOAbstract,+ BNFC.Backend.Common.StrUtils,+ BNFC.Options,+ BNFC.WarningM,+ Data.Pair,++ -- Documentation backends+ BNFC.Backend.Latex,+ BNFC.Backend.Txt2Tag,++ -- Haskell backend+ BNFC.Backend.Haskell,+ BNFC.Backend.Haskell.ToCNF,+ BNFC.Backend.Haskell.RegToAlex,+ BNFC.Backend.Haskell.CFtoTemplate,+ BNFC.Backend.Haskell.CFtoAlex3,+ BNFC.Backend.Haskell.CFtoAlex2,+ BNFC.Backend.Haskell.CFtoAlex,+ BNFC.Backend.Haskell.CFtoHappy,+ BNFC.Backend.Haskell.CFtoPrinter,+ BNFC.Backend.Haskell.CFtoAbstract,+ BNFC.Backend.Haskell.CFtoLayout,+ BNFC.Backend.Haskell.MkErrM,+ BNFC.Backend.Haskell.MkSharedString,+ BNFC.Backend.Haskell.HsOpts, -- Profile- ProfileTop,- CFtoHappyProfile,+ BNFC.Backend.HaskellProfile,+ BNFC.Backend.HaskellProfile.CFtoHappyProfile, -- Haskell GADT- HaskellTopGADT,- HaskellGADTCommon,- CFtoPrinterGADT,- CFtoTemplateGADT,- CFtoAbstractGADT,- -- O'Caml- OCamlTop,- OCamlUtil,- CFtoOCamlTest,- CFtoOCamlShow,- CFtoOCamlPrinter,- CFtoOCamlTemplate,- CFtoOCamlAbs,- CFtoOCamlYacc,- CFtoOCamlLex,- -- C- CTop,- CFtoCPrinter,- CFtoCSkel,- CFtoBisonC,- CFtoFlexC,- CFtoCAbs,- CFtoCVisitSkel,- -- C++- CPPTop,- RegToFlex,- CFtoFlex,- CFtoBison,- CFtoCPPPrinter,- CFtoCPPAbs,+ BNFC.Backend.HaskellGADT,+ BNFC.Backend.HaskellGADT.HaskellGADTCommon,+ BNFC.Backend.HaskellGADT.CFtoPrinterGADT,+ BNFC.Backend.HaskellGADT.CFtoTemplateGADT,+ BNFC.Backend.HaskellGADT.CFtoAbstractGADT, - -- C++ STL- CFtoBisonSTL,- CFtoSTLAbs,- STLUtils,- CFtoCVisitSkelSTL,- CFtoSTLPrinter,- STLTop,+ -- O'Caml backend+ BNFC.Backend.OCaml,+ BNFC.Backend.OCaml.OCamlUtil,+ BNFC.Backend.OCaml.CFtoOCamlTest,+ BNFC.Backend.OCaml.CFtoOCamlShow,+ BNFC.Backend.OCaml.CFtoOCamlPrinter,+ BNFC.Backend.OCaml.CFtoOCamlTemplate,+ BNFC.Backend.OCaml.CFtoOCamlAbs,+ BNFC.Backend.OCaml.CFtoOCamlYacc,+ BNFC.Backend.OCaml.CFtoOCamlLex, - -- C#- CSharpTop,- RegToGPLEX,- CFtoGPLEX,- CSharpUtils,- CFtoCSharpPrinter,- CAbstoCSharpAbs,- CAbstoCSharpAbstractVisitSkeleton,- CAbstoCSharpVisitSkeleton,- CFtoGPPG,- -- Java- JavaTop,- RegToJLex,- CFtoCup,- CFtoVisitSkel,- CFtoJavaSkeleton,- CFtoJavaPrinter,- CFtoJavaAbs,- CFtoJLex,- -- Java 1.5- JavaTop15,- CFtoJavaAbs15,- CFtoAllVisitor,- CFtoFoldVisitor,- CFtoAbstractVisitor,- CFtoComposVisitor,- CFtoVisitSkel15,- CFtoJavaPrinter15,- CFtoJLex15,- CFtoCup15,- -- F-sharp- FSharpTop+ -- C backend+ BNFC.Backend.C,+ BNFC.Backend.C.CFtoCPrinter,+ BNFC.Backend.C.CFtoCSkel,+ BNFC.Backend.C.CFtoBisonC,+ BNFC.Backend.C.CFtoFlexC,+ BNFC.Backend.C.CFtoCAbs,+ BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel,++ -- C++ backend+ BNFC.Backend.CPP.NoSTL,+ BNFC.Backend.CPP.NoSTL.RegToFlex,+ BNFC.Backend.CPP.NoSTL.CFtoFlex,+ BNFC.Backend.CPP.NoSTL.CFtoBison,+ BNFC.Backend.CPP.NoSTL.CFtoCPPPrinter,+ BNFC.Backend.CPP.NoSTL.CFtoCPPAbs,++ -- C++ STL backend+ BNFC.Backend.CPP.STL,+ BNFC.Backend.CPP.STL.CFtoBisonSTL,+ BNFC.Backend.CPP.STL.CFtoSTLAbs,+ BNFC.Backend.CPP.STL.STLUtils,+ BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL,+ BNFC.Backend.CPP.STL.CFtoSTLPrinter,++ -- C# backend+ BNFC.Backend.CSharp,+ BNFC.Backend.CSharp.RegToGPLEX,+ BNFC.Backend.CSharp.CFtoGPLEX,+ BNFC.Backend.CSharp.CSharpUtils,+ BNFC.Backend.CSharp.CFtoCSharpPrinter,+ BNFC.Backend.CSharp.CAbstoCSharpAbs,+ BNFC.Backend.CSharp.CAbstoCSharpAbstractVisitSkeleton,+ BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton,+ BNFC.Backend.CSharp.CFtoGPPG,++ -- Java backend+ BNFC.Backend.Java+ BNFC.Backend.Java.CFtoJavaAbs15,+ BNFC.Backend.Java.CFtoAllVisitor,+ BNFC.Backend.Java.CFtoFoldVisitor,+ BNFC.Backend.Java.CFtoAbstractVisitor,+ BNFC.Backend.Java.CFtoComposVisitor,+ BNFC.Backend.Java.CFtoVisitSkel15,+ BNFC.Backend.Java.CFtoJavaPrinter15,+ BNFC.Backend.Java.CFtoJLex15,+ BNFC.Backend.Java.CFtoCup15,+ BNFC.Backend.Java.RegToJLex++ -- XML backend+ BNFC.Backend.XML+++-- --- Testing --------------------------------------------------------------+Test-suite unit-tests+ Type: exitcode-stdio-1.0+ Build-Depends: base>=4 && <5, mtl, directory, array, process, filepath, pretty,+ hspec, QuickCheck >= 2.5, HUnit,+ temporary, containers, deepseq+ Main-is: unit-tests.hs+ HS-source-dirs: src test/+ Other-modules:+ BNFC.Backend.Common.MakefileSpec+ BNFC.OptionsSpec+ BNFC.WarningMSpec+ -- need to be there for alex to work+ LexBNF+ ParBNF
+ TODO view
@@ -0,0 +1,112 @@+Build:+- autoconf+ - verify Alex version.+- tidy up Makefiles a bit+ - and the generated ones too.+ - Use "Makefile" everywhere.+ - follow UNIX conventions...++Functionality:++- Add Bool type.++Bugs:+- Strange unicode space.+- Bison only supports 1 parser per input file.+- Write some clear docs on the Java backend.+- Java backend (and probably others)+ - Need to munge Java keywords like "abstract" "private"+ - Alfa.cf, C.cf fail to compile for this reason.+ - I think I fixed this, but it should be verified (peteg)+ - Add a message on how to run the test file (after a succesful compliation), + e.g. :+ "to run the test, type : java JavaletteLight/Test <filename>"+Compilers:++- write a JavaCup script++Bug Reports:++--------------+> Fail: formats/java/CFtoJavaPrinter.hs:269: Non-exhaustive patterns in function> getCons+ on Prolog.cf+ Reason: No separator for a list. The same happens in C and C++.++> In Skeleton.c the visit-functions for lists has the wrong variable for+> visiting the+> list elements. It says "visitNAME(LISTNAME->LISTNAME)" but it should be+> "visitNAME(LISTNAME->NAME)".+>+> The parse tree printer and pretty printer writes a newline instead of "\n"+> for+> strings.+--------------+Java backend++If a terminal and non-terminal have the same name, there is a name clash in+the generarted .java files.++Solution: don't do this.+See C.cf for an example. Alfa.cf doesn't work either.++- "separator", etc. decs don't play nice.+ - the list stuff is emitted before the top-level non-terminal.+- need to specify which non-terminal is the top-level one.+ - i.e. a "start with" line must be present.+ - BNFC now crashes if you don't specify an "entrypoint" pragma,+ or use more than one.++Somewhere along the line of BNFC/jlex/jcup the BNFC comment-instruction+(comment "/*" "*/" ;) seems to fail. A file containing only an opening+of a comment manages to pass the parser without any trouble.++--------------+Aarne, Java:++ to get "parse successful" is fast, but then it takes+ quite some time to pretty-print++ the parser gets confused with isolatin characters included+ in string literals++Michael:++http://www.cs.princeton.edu/~appel/modern/java/JLex/current/manual.html#SECTION2.2.14++--------------++Antti-Juhani Kaijanaho:++- A token UIdent declaration (see report) causes a mysterious parse+ error at end of file / perhaps conflicts with predefined Ident?+- If I use "\\/" in a production, Happy is unhappy (you use \/ as the+ Happy token)+- You generate Alex 1.x source. Could you make it (optionally?)+ generate Alex 2.x source? <peteg: fixed>++Oh, and bnfc returns an exit code indicating success even when there is+an error.++--------------++Bjorn Bringert:++- Specifying coercions etc. for non-existing categories should+ probably be an error.+- Repeated identical rules should be an error.+- Java CUP back end does not support multiple entrypoints.++--------------++Software versions:++ghc 5.04.x++bison 1.875a+flex 2.5.31++alex 2.0+happy 1.13+++--------------
dist/build/bnfc/bnfc-tmp/LexBNF.hs view
@@ -2,6 +2,7 @@ {-# LINE 3 "src/LexBNF.x" #-} {-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -w #-} module LexBNF where @@ -40,7 +41,7 @@ alex_deflt = AlexA# "\xff\xff\x06\x00\x06\x00\xff\xff\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\x06\x00\x06\x00\x13\x00\x13\x00\x04\x00\x04\x00\xff\xff\x18\x00\xff\xff\x18\x00\x1c\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x06\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"# alex_accept = listArray (0::Int,42) [[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))]]-{-# LINE 37 "src/LexBNF.x" #-}+{-# LINE 38 "src/LexBNF.x" #-} tok f p s = f p s@@ -153,7 +154,7 @@ alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (p, c, bs, s) = c - -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. utf8Encode :: Char -> [Word8] utf8Encode = map fromIntegral . go . ord where@@ -183,6 +184,39 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<command-line>" #-}+++++++# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4++++++++++++++++++++++++# 6 "<command-line>" 2 {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE
dist/build/bnfc/bnfc-tmp/ParBNF.hs view
@@ -1450,6 +1450,34 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "<command-line>" #-}+{-# LINE 8 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4++++++++++++++++++++++++# 8 "<command-line>" 2 {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp
+ dist/build/unit-tests/unit-tests-tmp/LexBNF.hs view
@@ -0,0 +1,417 @@+{-# LANGUAGE CPP,MagicHash #-}+{-# LINE 3 "src/LexBNF.x" #-}++{-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -w #-}+module LexBNF where++++import qualified Data.Bits+import Data.Word (Word8)++#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+import Data.Char (ord)+import Data.Array.Base (unsafeAt)+#else+import Array+import Char (ord)+#endif+#if __GLASGOW_HASKELL__ >= 503+import GHC.Exts+#else+import GlaExts+#endif+alex_base :: AlexAddr+alex_base = AlexA# "\xf8\xff\xff\xff\x49\x00\x00\x00\x1c\x01\x00\x00\xc9\xff\xff\xff\xe0\xff\xff\xff\x9c\x01\x00\x00\x6f\x02\x00\x00\x2d\x00\x00\x00\xef\x02\x00\x00\xef\x03\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\xe0\x04\x00\x00\xdd\x01\x00\x00\x60\x05\x00\x00\x24\x06\x00\x00\x82\x06\x00\x00\x20\x05\x00\x00\x00\x00\x00\x00\x38\x06\x00\x00\xdb\xff\xff\xff\x47\x00\x00\x00\x5a\x00\x00\x00\x38\x07\x00\x00\x39\x07\x00\x00\xfc\x07\x00\x00\xbc\x07\x00\x00\x00\x00\x00\x00\xb2\x08\x00\x00\x85\x09\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\xdc\xff\xff\xff\xdd\xff\xff\xff\x00\x00\x00\x00\xdf\xff\xff\xff\x5e\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x7a\x06\x00\x00\x7c\x00\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA# "\x00\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x23\x00\x27\x00\x17\x00\x1d\x00\x06\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x20\x00\x03\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x23\x00\x23\x00\x23\x00\x23\x00\x23\x00\x21\x00\x23\x00\x00\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x24\x00\x23\x00\x00\x00\x23\x00\x00\x00\x23\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x23\x00\x04\x00\x23\x00\x00\x00\x23\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x22\x00\x23\x00\x23\x00\x02\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x20\x00\x20\x00\x20\x00\x20\x00\x20\x00\x00\x00\x00\x00\x00\x00\x04\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x04\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x28\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x00\x00\x00\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\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\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\x09\x00\x0a\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\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\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\x01\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\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\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\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\x1e\x00\x00\x00\x00\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\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\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\x09\x00\x0a\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\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\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\x1a\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x01\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\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\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\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\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\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\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\x09\x00\x0a\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\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\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\x05\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\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\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\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\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\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\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\x14\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\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\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\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\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\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\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\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x07\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\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\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\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\x00\x00\x00\x00\x0d\x00\x0e\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\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\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\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\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\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\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\x00\x29\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\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\x18\x00\x15\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\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x1b\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\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\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\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x26\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x11\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x18\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x10\x00\x12\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\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\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\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\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\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\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\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\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\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\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\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\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\x00\x00\x00\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\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\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\x1a\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1c\x00\x1b\x00\x05\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x13\x00\x14\x00\x08\x00\x0b\x00\x0b\x00\x0b\x00\x0c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\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\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\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\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\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\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\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\x09\x00\x0a\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\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\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\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\x00\x25\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\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\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\x00\x00\x00\x00\x00\x00\x00\x19\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\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\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"#++alex_check :: AlexAddr+alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3d\x00\x27\x00\x2d\x00\x2d\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x20\x00\x3a\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\x3d\x00\xff\xff\x3f\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x27\x00\x5d\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x5c\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x74\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\x7d\x00\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\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\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\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\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\x5c\x00\x65\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\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xff\xff\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xc2\x00\xc3\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x0a\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\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\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\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\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\xff\xff\xff\xff\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x2d\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\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\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\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\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xf7\x00\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\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\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\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\xff\xff\xff\xff\xff\xff\xc3\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\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\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"#++alex_deflt :: AlexAddr+alex_deflt = AlexA# "\xff\xff\x06\x00\x06\x00\xff\xff\xff\xff\xff\xff\x06\x00\xff\xff\xff\xff\x06\x00\x06\x00\x13\x00\x13\x00\x04\x00\x04\x00\xff\xff\x18\x00\xff\xff\x18\x00\x1c\x00\x1c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1d\x00\x1d\x00\x1d\x00\x06\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"#++alex_accept = listArray (0::Int,42) [[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_8))]]+{-# LINE 38 "src/LexBNF.x" #-}+++tok f p s = f p s++share :: String -> String+share = id++data Tok =+ TS !String !Int -- reserved words and symbols+ | TL !String -- string literals+ | TI !String -- integer literals+ | TV !String -- identifiers+ | TD !String -- double precision float literals+ | TC !String -- character literals++ deriving (Eq,Show,Ord)++data Token = + PT Posn Tok+ | Err Posn+ deriving (Eq,Show,Ord)++tokenPos (PT (Pn _ l _) _ :_) = "line " ++ show l+tokenPos (Err (Pn _ l _) :_) = "line " ++ show l+tokenPos _ = "end of file"++tokenPosn (PT p _) = p+tokenPosn (Err p) = p+tokenLineCol = posLineCol . tokenPosn+posLineCol (Pn _ l c) = (l,c)+mkPosToken t@(PT p _) = (posLineCol p, prToken t)++prToken t = case t of+ PT _ (TS s _) -> s+ PT _ (TL s) -> s+ PT _ (TI s) -> s+ PT _ (TV s) -> s+ PT _ (TD s) -> s+ PT _ (TC s) -> s+++data BTree = N | B String Tok BTree BTree deriving (Show)++eitherResIdent :: (String -> Tok) -> String -> Tok+eitherResIdent tv s = treeFind resWords+ where+ treeFind N = tv s+ treeFind (B a t left right) | s < a = treeFind left+ | s > a = treeFind right+ | s == a = t++resWords = b "digit" 21 (b "=" 11 (b "-" 6 (b "*" 3 (b ")" 2 (b "(" 1 N N) N) (b "," 5 (b "+" 4 N N) N)) (b "::=" 9 (b ":" 8 (b "." 7 N N) N) (b ";" 10 N N))) (b "char" 16 (b "]" 14 (b "[" 13 (b "?" 12 N N) N) (b "_" 15 N N)) (b "define" 19 (b "comment" 18 (b "coercions" 17 N N) N) (b "delimiters" 20 N N)))) (b "separator" 31 (b "letter" 26 (b "internal" 24 (b "eps" 23 (b "entrypoints" 22 N N) N) (b "layout" 25 N N)) (b "position" 29 (b "nonempty" 28 (b "lower" 27 N N) N) (b "rules" 30 N N))) (b "upper" 36 (b "token" 34 (b "terminator" 33 (b "stop" 32 N N) N) (b "toplevel" 35 N N)) (b "|" 39 (b "{" 38 (b "views" 37 N N) N) (b "}" 40 N N))))+ where b s n = let bs = id s+ in B bs (TS bs n)++unescapeInitTail :: String -> String+unescapeInitTail = id . unesc . tail . id where+ unesc s = case s of+ '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs+ '\\':'n':cs -> '\n' : unesc cs+ '\\':'t':cs -> '\t' : unesc cs+ '"':[] -> []+ c:cs -> c : unesc cs+ _ -> []++-------------------------------------------------------------------+-- Alex wrapper code.+-- A modified "posn" wrapper.+-------------------------------------------------------------------++data Posn = Pn !Int !Int !Int+ deriving (Eq, Show,Ord)++alexStartPos :: Posn+alexStartPos = Pn 0 1 1++alexMove :: Posn -> Char -> Posn+alexMove (Pn a l c) '\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)+alexMove (Pn a l c) '\n' = Pn (a+1) (l+1) 1+alexMove (Pn a l c) _ = Pn (a+1) l (c+1)++type Byte = Word8++type AlexInput = (Posn, -- current position,+ Char, -- previous char+ [Byte], -- pending bytes on the current char+ String) -- current input string++tokens :: String -> [Token]+tokens str = go (alexStartPos, '\n', [], str)+ where+ go :: AlexInput -> [Token]+ go inp@(pos, _, _, str) =+ case alexScan inp 0 of+ AlexEOF -> []+ AlexError (pos, _, _, _) -> [Err pos]+ AlexSkip inp' len -> go inp'+ AlexToken inp' len act -> act pos (take len str) : (go inp')++alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)+alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))+alexGetByte (p, _, [], s) =+ case s of+ [] -> Nothing+ (c:s) ->+ let p' = alexMove p c+ (b:bs) = utf8Encode c+ in p' `seq` Just (b, (p', c, bs, s))++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (p, c, bs, s) = c++-- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+utf8Encode :: Char -> [Word8]+utf8Encode = map fromIntegral . go . ord+ where+ go oc+ | oc <= 0x7f = [oc]++ | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)+ , 0x80 + oc Data.Bits..&. 0x3f+ ]++ | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)+ , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+ , 0x80 + oc Data.Bits..&. 0x3f+ ]+ | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)+ , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)+ , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)+ , 0x80 + oc Data.Bits..&. 0x3f+ ]++alex_action_3 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_4 = tok (\p s -> PT p (eitherResIdent (TV . share) s)) +alex_action_5 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s)) +alex_action_6 = tok (\p s -> PT p (TC $ share s)) +alex_action_7 = tok (\p s -> PT p (TI $ share s)) +alex_action_8 = tok (\p s -> PT p (TD $ share s)) +{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<command-line>" #-}+++++++# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4++++++++++++++++++++++++# 6 "<command-line>" 2+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++{-# LINE 37 "templates/GenericTemplate.hs" #-}++{-# LINE 47 "templates/GenericTemplate.hs" #-}+++data AlexAddr = AlexA# Addr#++#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+ narrow16Int# i+ where+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2#+#else+ indexInt16OffAddr# arr off+#endif++++++{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr (AlexA# arr) off = +#ifdef WORDS_BIGENDIAN+ narrow32Int# i+ where+ !i = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+ (b2 `uncheckedShiftL#` 16#) `or#`+ (b1 `uncheckedShiftL#` 8#) `or#` b0)+ !b3 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+ !b2 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+ !b1 = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ !b0 = int2Word# (ord# (indexCharOffAddr# arr off'))+ !off' = off *# 4#+#else+ indexInt32OffAddr# arr off+#endif++++++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+++++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input (I# (sc))+ = alexScanUser undefined input (I# (sc))++alexScanUser user input (I# (sc))+ = case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, input') ->+ case alexGetByte input of+ Nothing -> ++++ AlexEOF+ Just _ ->++++ AlexError input'++ (AlexLastSkip input'' len, _) ->++++ AlexSkip input'' len++ (AlexLastAcc k input''' len, _) ->++++ AlexToken input''' len k+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user orig_input len input s last_acc =+ input `seq` -- strict in the input+ let + new_acc = (check_accs (alex_accept `quickIndex` (I# (s))))+ in+ new_acc `seq`+ case alexGetByte input of+ Nothing -> (new_acc, input)+ Just (c, new_input) -> ++++ let+ (base) = alexIndexInt32OffAddr alex_base s+ ((I# (ord_c))) = fromIntegral c+ (offset) = (base +# ord_c)+ (check) = alexIndexInt16OffAddr alex_check offset+ + (new_s) = if (offset >=# 0#) && (check ==# ord_c)+ then alexIndexInt16OffAddr alex_table offset+ else alexIndexInt16OffAddr alex_deflt s+ in+ case new_s of + -1# -> (new_acc, input)+ -- on an error, we want to keep the input *before* the+ -- character that failed, not after.+ _ -> alex_scan_tkn user orig_input (if c < 0x80 || c >= 0xC0 then (len +# 1#) else len)+ -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+ new_input new_s new_acc++ where+ check_accs [] = last_acc+ check_accs (AlexAcc a : _) = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkip : _) = AlexLastSkip input (I# (len))+ check_accs (AlexAccPred a predx : rest)+ | predx user orig_input (I# (len)) input+ = AlexLastAcc a input (I# (len))+ check_accs (AlexAccSkipPred predx : rest)+ | predx user orig_input (I# (len)) input+ = AlexLastSkip input (I# (len))+ check_accs (_ : rest) = check_accs rest++data AlexLastAcc a+ = AlexNone+ | AlexLastAcc a !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++instance Functor AlexLastAcc where+ fmap f AlexNone = AlexNone+ fmap f (AlexLastAcc x y z) = AlexLastAcc (f x) y z+ fmap f (AlexLastSkip x y) = AlexLastSkip x y++data AlexAcc a user+ = AlexAcc a+ | AlexAccSkip+ | AlexAccPred a (AlexAccPred user)+ | AlexAccSkipPred (AlexAccPred user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user in1 len in2+ = p1 user in1 len in2 && p2 user in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _ +alexPrevCharIs c _ input _ _ = c == alexInputPrevChar input++alexPrevCharMatches f _ input _ _ = f (alexInputPrevChar input)++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _ +alexPrevCharIsOneOf arr _ input _ _ = arr ! alexInputPrevChar input++--alexRightContext :: Int -> AlexAccPred _+alexRightContext (I# (sc)) user _ _ input = + case alex_scan_tkn user input 0# input sc AlexNone of+ (AlexNone, _) -> False+ _ -> True+ -- TODO: there's no need to find the longest+ -- match when checking the right context, just+ -- the first match will do.++-- used by wrappers+iUnbox (I# (i)) = i
+ dist/build/unit-tests/unit-tests-tmp/ParBNF.hs view
@@ -0,0 +1,1733 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS -fglasgow-exts -cpp #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}+module ParBNF where+import AbsBNF+import LexBNF+import ErrM+import qualified Data.Array as Happy_Data_Array+import qualified GHC.Exts as Happy_GHC_Exts++-- parser produced by Happy Version 1.18.10++newtype HappyAbsSyn = HappyAbsSyn HappyAny+#if __GLASGOW_HASKELL__ >= 607+type HappyAny = Happy_GHC_Exts.Any+#else+type HappyAny = forall a . a+#endif+happyIn36 :: (String) -> (HappyAbsSyn )+happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn36 #-}+happyOut36 :: (HappyAbsSyn ) -> (String)+happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut36 #-}+happyIn37 :: (Ident) -> (HappyAbsSyn )+happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn37 #-}+happyOut37 :: (HappyAbsSyn ) -> (Ident)+happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut37 #-}+happyIn38 :: (Integer) -> (HappyAbsSyn )+happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn38 #-}+happyOut38 :: (HappyAbsSyn ) -> (Integer)+happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut38 #-}+happyIn39 :: (Char) -> (HappyAbsSyn )+happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn39 #-}+happyOut39 :: (HappyAbsSyn ) -> (Char)+happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut39 #-}+happyIn40 :: (Double) -> (HappyAbsSyn )+happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn40 #-}+happyOut40 :: (HappyAbsSyn ) -> (Double)+happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut40 #-}+happyIn41 :: (LGrammar) -> (HappyAbsSyn )+happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn41 #-}+happyOut41 :: (HappyAbsSyn ) -> (LGrammar)+happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut41 #-}+happyIn42 :: (LDef) -> (HappyAbsSyn )+happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn42 #-}+happyOut42 :: (HappyAbsSyn ) -> (LDef)+happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut42 #-}+happyIn43 :: ([LDef]) -> (HappyAbsSyn )+happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn43 #-}+happyOut43 :: (HappyAbsSyn ) -> ([LDef])+happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut43 #-}+happyIn44 :: (Grammar) -> (HappyAbsSyn )+happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn44 #-}+happyOut44 :: (HappyAbsSyn ) -> (Grammar)+happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut44 #-}+happyIn45 :: ([Def]) -> (HappyAbsSyn )+happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn45 #-}+happyOut45 :: (HappyAbsSyn ) -> ([Def])+happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut45 #-}+happyIn46 :: ([Item]) -> (HappyAbsSyn )+happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn46 #-}+happyOut46 :: (HappyAbsSyn ) -> ([Item])+happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut46 #-}+happyIn47 :: (Def) -> (HappyAbsSyn )+happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn47 #-}+happyOut47 :: (HappyAbsSyn ) -> (Def)+happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut47 #-}+happyIn48 :: (Item) -> (HappyAbsSyn )+happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn48 #-}+happyOut48 :: (HappyAbsSyn ) -> (Item)+happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut48 #-}+happyIn49 :: (Cat) -> (HappyAbsSyn )+happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn49 #-}+happyOut49 :: (HappyAbsSyn ) -> (Cat)+happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut49 #-}+happyIn50 :: (Label) -> (HappyAbsSyn )+happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn50 #-}+happyOut50 :: (HappyAbsSyn ) -> (Label)+happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut50 #-}+happyIn51 :: (LabelId) -> (HappyAbsSyn )+happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn51 #-}+happyOut51 :: (HappyAbsSyn ) -> (LabelId)+happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut51 #-}+happyIn52 :: (ProfItem) -> (HappyAbsSyn )+happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn52 #-}+happyOut52 :: (HappyAbsSyn ) -> (ProfItem)+happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut52 #-}+happyIn53 :: (IntList) -> (HappyAbsSyn )+happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn53 #-}+happyOut53 :: (HappyAbsSyn ) -> (IntList)+happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut53 #-}+happyIn54 :: ([Integer]) -> (HappyAbsSyn )+happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn54 #-}+happyOut54 :: (HappyAbsSyn ) -> ([Integer])+happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut54 #-}+happyIn55 :: ([IntList]) -> (HappyAbsSyn )+happyIn55 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn55 #-}+happyOut55 :: (HappyAbsSyn ) -> ([IntList])+happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut55 #-}+happyIn56 :: ([ProfItem]) -> (HappyAbsSyn )+happyIn56 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn56 #-}+happyOut56 :: (HappyAbsSyn ) -> ([ProfItem])+happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut56 #-}+happyIn57 :: (Separation) -> (HappyAbsSyn )+happyIn57 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn57 #-}+happyOut57 :: (HappyAbsSyn ) -> (Separation)+happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut57 #-}+happyIn58 :: (Arg) -> (HappyAbsSyn )+happyIn58 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn58 #-}+happyOut58 :: (HappyAbsSyn ) -> (Arg)+happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut58 #-}+happyIn59 :: ([Arg]) -> (HappyAbsSyn )+happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn59 #-}+happyOut59 :: (HappyAbsSyn ) -> ([Arg])+happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut59 #-}+happyIn60 :: (Exp) -> (HappyAbsSyn )+happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn60 #-}+happyOut60 :: (HappyAbsSyn ) -> (Exp)+happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut60 #-}+happyIn61 :: (Exp) -> (HappyAbsSyn )+happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn61 #-}+happyOut61 :: (HappyAbsSyn ) -> (Exp)+happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut61 #-}+happyIn62 :: (Exp) -> (HappyAbsSyn )+happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn62 #-}+happyOut62 :: (HappyAbsSyn ) -> (Exp)+happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut62 #-}+happyIn63 :: ([Exp]) -> (HappyAbsSyn )+happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn63 #-}+happyOut63 :: (HappyAbsSyn ) -> ([Exp])+happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut63 #-}+happyIn64 :: ([Exp]) -> (HappyAbsSyn )+happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn64 #-}+happyOut64 :: (HappyAbsSyn ) -> ([Exp])+happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut64 #-}+happyIn65 :: ([String]) -> (HappyAbsSyn )+happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn65 #-}+happyOut65 :: (HappyAbsSyn ) -> ([String])+happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut65 #-}+happyIn66 :: ([RHS]) -> (HappyAbsSyn )+happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn66 #-}+happyOut66 :: (HappyAbsSyn ) -> ([RHS])+happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut66 #-}+happyIn67 :: (RHS) -> (HappyAbsSyn )+happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn67 #-}+happyOut67 :: (HappyAbsSyn ) -> (RHS)+happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut67 #-}+happyIn68 :: (MinimumSize) -> (HappyAbsSyn )+happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn68 #-}+happyOut68 :: (HappyAbsSyn ) -> (MinimumSize)+happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut68 #-}+happyIn69 :: (Reg) -> (HappyAbsSyn )+happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn69 #-}+happyOut69 :: (HappyAbsSyn ) -> (Reg)+happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut69 #-}+happyIn70 :: (Reg) -> (HappyAbsSyn )+happyIn70 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn70 #-}+happyOut70 :: (HappyAbsSyn ) -> (Reg)+happyOut70 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut70 #-}+happyIn71 :: (Reg) -> (HappyAbsSyn )+happyIn71 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn71 #-}+happyOut71 :: (HappyAbsSyn ) -> (Reg)+happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut71 #-}+happyIn72 :: (Reg) -> (HappyAbsSyn )+happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn72 #-}+happyOut72 :: (HappyAbsSyn ) -> (Reg)+happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut72 #-}+happyIn73 :: ([Ident]) -> (HappyAbsSyn )+happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyIn73 #-}+happyOut73 :: (HappyAbsSyn ) -> ([Ident])+happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x+{-# INLINE happyOut73 #-}+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# "\x62\x00\x62\x00\x62\x00\x7c\x00\x7c\x00\x00\x00\x7c\x00\x5c\x00\x89\x00\x3d\x00\x3d\x00\xdd\x01\xd7\x01\xdc\x01\xd3\x01\xdb\x01\xbe\x00\xda\x01\x00\x00\x08\x00\x08\x00\x08\x00\x08\x00\x08\x00\xd9\x01\x00\x00\x00\x00\xd8\x01\x46\x00\x46\x00\x46\x00\x46\x00\xd6\x01\xd4\x01\x00\x00\xd5\x01\xd2\x01\x00\x00\x00\x00\x36\x00\xd1\x01\x8d\x01\xcf\x01\x46\x00\xce\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x01\x00\x00\x07\x00\xe1\xff\x01\x00\xcd\x01\x00\x00\x5c\x00\xcd\x01\xcd\x01\xcb\x01\xd0\x01\xca\x01\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xc9\x01\xcc\x01\x00\x00\xc6\x01\x08\x00\x08\x00\x00\x00\x00\x00\x00\x00\x08\x00\xc6\x01\xc6\x01\xc6\x01\xc6\x01\xfe\x00\x00\x00\xc6\x01\xc6\x01\xc7\x01\xc7\x01\xc8\x01\xc4\x01\xc5\x01\xc3\x01\xc0\x01\xc2\x01\xc1\x01\xbc\x01\xbc\x01\xbc\x01\x00\x00\xbc\x01\xbf\x01\xbd\x01\x00\x00\xb9\x01\x1f\x00\x00\x00\xb9\x01\x89\x00\x00\x00\xb9\x01\x00\x00\xb9\x01\xbe\x01\xbb\x01\xba\x01\xb8\x01\x89\x00\xb8\x01\x05\x00\x6f\x01\xae\x01\xb5\x01\xb7\x01\xb7\x01\xb3\x01\xf4\xff\xac\x01\xb6\x01\xaa\x01\x00\x00\x50\x00\xb2\x01\xa9\x01\x00\x00\xb1\x01\xa7\x01\x9b\x01\x9b\x01\x00\x00\x00\x00\x7c\x00\x62\x00\x9a\x01\x7c\x00\x00\x00\x46\x00\x89\x00\x89\x00\xaf\x01\x99\x01\x00\x00\x98\x01\x00\x00\xb0\x01\x00\x00\x96\x01\x00\x00\x96\x01\x92\x01\x89\x00\xa8\x01\xb4\x01\x00\x00\x64\x01\x00\x00\x9a\x00\x90\x01\xa4\x01\xa6\x01\xa6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x01\xad\x01\x08\x00\x08\x00\x00\x00\x8b\x01\x00\x00\x26\x01\x46\x00\x00\x00\x00\x00\x00\x00\x88\x01\xa0\x01\xab\x01\x46\x00\x46\x00\x00\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x01\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x01\x00\x00\x00\x00\xa2\x01\x00\x00\x00\x00\xf8\xff\x80\x01\x89\x00\x00\x00\x46\x00\x00\x00\x80\x01\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x01\xbe\x00\x08\x00\x00\x00\xa5\x01\xa1\x01\x97\x01\x00\x00\x5c\x00\x00\x00\x86\x01\x00\x00\x5c\x00\x00\x00\x7a\x01\x95\x01\x9d\x01\x00\x00\x00\x00"#++happyGotoOffsets :: HappyAddr+happyGotoOffsets = HappyA# "\x9e\x00\xbb\x00\xb9\x00\x65\x01\x75\x01\x93\x01\x77\x01\x89\x01\x7e\x01\x79\x01\xcc\x00\x91\x01\x8f\x01\xa0\x00\xe5\x00\x8a\x01\x87\x01\x92\x00\x84\x01\x3b\x01\x40\x01\x45\x01\x11\x01\xeb\x00\x91\x00\x44\x01\x78\x00\x6d\x01\x5b\x00\x17\x00\x42\x00\xb6\x00\x16\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x94\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x01\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\xe6\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x8c\x01\x7b\x01\x83\x01\x00\x00\x00\x00\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x01\x00\x00\x00\x00\x74\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x01\x68\x01\x57\x01\x51\x01\x06\x00\xbd\x00\x6d\x00\x00\x00\x56\x01\x17\x01\xe9\x00\x05\x01\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\xa9\x00\x03\x00\x6e\x01\x00\x00\xae\x00\x24\x01\xfb\x00\x00\x00\x9f\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\xf7\x00\xc5\x00\xab\x00\xc3\x00\xf4\x00\x00\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\xaa\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x01\xe1\x00\x00\x00\x0d\x00\x42\x01\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\x00\x21\x00\x00\x00\x00\x00\x00\x00\x21\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\x3c\x00\xa1\x00\xb5\x00\x00\x00\x1e\x00\x2c\x01\x57\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x16\x01\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x00\x00\xef\xff\x02\x00\x4f\x01\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyDefActions :: HappyAddr+happyDefActions = HappyA# "\xd5\xff\x00\x00\xd5\xff\xd1\xff\xd1\xff\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\xff\xaa\xff\x00\x00\xa5\xff\x00\x00\xa1\xff\x00\x00\x00\x00\x00\x00\x00\x00\x92\xff\x00\x00\xce\xff\xce\xff\x89\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\x75\xff\x00\x00\xdd\xff\x7f\xff\x84\xff\x76\xff\x87\xff\x00\x00\x00\x00\x00\x00\x78\xff\x7c\xff\x80\xff\x7b\xff\x79\xff\x7a\xff\x00\x00\xdb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x8b\xff\x00\x00\x00\x00\x8d\xff\x8f\xff\x00\x00\x98\xff\x9b\xff\x9a\xff\x99\xff\x97\xff\x91\xff\x9e\xff\x9c\xff\x00\x00\x00\x00\x92\xff\xdc\xff\xda\xff\x9b\xff\x94\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa7\xff\x00\x00\x00\x00\xa9\xff\x00\x00\xad\xff\xac\xff\x00\x00\x00\x00\x00\x00\xb4\xff\x00\x00\x00\x00\x00\x00\xb3\xff\x00\x00\xb8\xff\xb9\xff\x00\x00\x00\x00\xbc\xff\x00\x00\xbb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\xff\x89\xff\x00\x00\x00\x00\x00\x00\xd0\xff\x00\x00\xd2\xff\xb4\xff\xd4\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\x00\x00\xd9\xff\xd6\xff\x00\x00\xd5\xff\x00\x00\xd1\xff\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xbd\xff\x00\x00\xc6\xff\x00\x00\xa1\xff\xcb\xff\x00\x00\x00\x00\x00\x00\xb5\xff\xb7\xff\x00\x00\xb2\xff\x00\x00\xad\xff\x00\x00\xaa\xff\xaa\xff\xa6\xff\xa4\xff\xa3\xff\xa0\xff\x93\xff\x00\x00\x00\x00\x00\x00\x92\xff\x9d\xff\x00\x00\xce\xff\x88\xff\x00\x00\x83\xff\x82\xff\x81\xff\x00\x00\x00\x00\x00\x00\x00\x00\x85\xff\x77\xff\x7e\xff\x7d\xff\x86\xff\x8c\xff\x8e\xff\x90\xff\x9f\xff\x95\xff\x96\xff\x00\x00\xa8\xff\xae\xff\xab\xff\xb1\xff\x00\x00\xb6\xff\xba\xff\x00\x00\xc2\xff\xca\xff\x00\x00\x00\x00\x00\x00\xbe\xff\x00\x00\xce\xff\x00\x00\x00\x00\xc8\xff\xcf\xff\x74\xff\xd3\xff\xd7\xff\xc4\xff\xc5\xff\xc1\xff\xc7\xff\x00\x00\xa5\xff\x00\x00\xce\xff\x00\x00\x00\x00\x00\x00\xb0\xff\xcc\xff\xc0\xff\x89\xff\xce\xff\xc9\xff\xc3\xff\xad\xff\x00\x00\x00\x00\xaf\xff"#++happyCheck :: HappyAddr+happyCheck = HappyA# "\xff\xff\x0d\x00\x01\x00\x0b\x00\x01\x00\x01\x00\x01\x00\x01\x00\x27\x00\x01\x00\x03\x00\x04\x00\x0a\x00\x00\x00\x0d\x00\x20\x00\x2f\x00\x10\x00\x0d\x00\x0c\x00\x0f\x00\x0d\x00\x15\x00\x01\x00\x17\x00\x0a\x00\x03\x00\x1a\x00\x1b\x00\x29\x00\x2a\x00\x15\x00\x01\x00\x03\x00\x2a\x00\x2f\x00\x03\x00\x24\x00\x00\x00\x26\x00\x25\x00\x25\x00\x1d\x00\x25\x00\x0d\x00\x2c\x00\x0f\x00\x2a\x00\x2f\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2f\x00\x01\x00\x21\x00\x22\x00\x23\x00\x25\x00\x06\x00\x01\x00\x01\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0d\x00\x23\x00\x03\x00\x10\x00\x01\x00\x03\x00\x2a\x00\x0d\x00\x15\x00\x0f\x00\x17\x00\x00\x00\x02\x00\x1a\x00\x1b\x00\x16\x00\x0d\x00\x02\x00\x05\x00\x10\x00\x00\x00\x08\x00\x03\x00\x24\x00\x15\x00\x26\x00\x17\x00\x03\x00\x12\x00\x1a\x00\x1b\x00\x2c\x00\x01\x00\x12\x00\x23\x00\x21\x00\x2a\x00\x23\x00\x0d\x00\x24\x00\x1d\x00\x26\x00\x00\x00\x11\x00\x0d\x00\x13\x00\x0f\x00\x2c\x00\x11\x00\x12\x00\x13\x00\x14\x00\x21\x00\x16\x00\x23\x00\x18\x00\x19\x00\x21\x00\x01\x00\x23\x00\x1d\x00\x1e\x00\x1f\x00\x0a\x00\x21\x00\x22\x00\x29\x00\x2a\x00\x25\x00\x02\x00\x0d\x00\x1d\x00\x0f\x00\x2a\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x16\x00\x01\x00\x18\x00\x19\x00\x0d\x00\x1f\x00\x12\x00\x1d\x00\x1e\x00\x1f\x00\x02\x00\x21\x00\x22\x00\x01\x00\x01\x00\x00\x00\x02\x00\x05\x00\x06\x00\x07\x00\x2a\x00\x0d\x00\x16\x00\x0b\x00\x01\x00\x00\x00\x0e\x00\x0f\x00\x1d\x00\x06\x00\x07\x00\x03\x00\x12\x00\x2a\x00\x0b\x00\x03\x00\x01\x00\x0e\x00\x0f\x00\x03\x00\x01\x00\x11\x00\x01\x00\x13\x00\x01\x00\x06\x00\x07\x00\x06\x00\x0d\x00\x25\x00\x0b\x00\x02\x00\x0b\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x01\x00\x25\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x21\x00\x22\x00\x23\x00\x24\x00\x0f\x00\x17\x00\x1f\x00\x25\x00\x21\x00\x25\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x11\x00\x00\x00\x13\x00\x18\x00\x19\x00\x1a\x00\x01\x00\x1c\x00\x18\x00\x19\x00\x1a\x00\x0d\x00\x1c\x00\x18\x00\x19\x00\x1a\x00\x01\x00\x1c\x00\x0d\x00\x20\x00\x1a\x00\x1b\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x01\x00\x1a\x00\x1b\x00\x2a\x00\x03\x00\x04\x00\x1a\x00\x1b\x00\x2f\x00\x18\x00\x19\x00\x1a\x00\x0d\x00\x0c\x00\x18\x00\x19\x00\x1a\x00\x0a\x00\x20\x00\x18\x00\x19\x00\x1a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x1e\x00\x1f\x00\x0a\x00\x10\x00\x0a\x00\x00\x00\x01\x00\x14\x00\x01\x00\x18\x00\x19\x00\x1a\x00\x01\x00\x01\x00\x01\x00\x19\x00\x1a\x00\x0c\x00\x0d\x00\x01\x00\x0d\x00\x1a\x00\x1e\x00\x1f\x00\x1e\x00\x1f\x00\x0f\x00\x10\x00\x01\x00\x0b\x00\x00\x00\x14\x00\x0e\x00\x0f\x00\x08\x00\x08\x00\x09\x00\x01\x00\x0b\x00\x0d\x00\x01\x00\x0e\x00\x0f\x00\x01\x00\x01\x00\x09\x00\x01\x00\x0b\x00\x01\x00\x00\x00\x0e\x00\x0f\x00\x09\x00\x01\x00\x0b\x00\x0d\x00\x0b\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x0e\x00\x0f\x00\x00\x00\x01\x00\x0d\x00\x00\x00\x20\x00\x00\x00\x20\x00\x03\x00\x04\x00\x23\x00\x10\x00\x00\x00\x0c\x00\x0d\x00\x14\x00\x29\x00\x0c\x00\x10\x00\x17\x00\x15\x00\x0a\x00\x14\x00\x02\x00\x11\x00\x10\x00\x1c\x00\x0e\x00\x0d\x00\x2b\x00\x05\x00\x02\x00\x09\x00\x29\x00\x0e\x00\x09\x00\x0e\x00\x02\x00\x0e\x00\x02\x00\x28\x00\x0e\x00\x0e\x00\x0d\x00\x29\x00\x01\x00\x0e\x00\x07\x00\x09\x00\x08\x00\xff\xff\x2b\x00\x0a\x00\x2b\x00\xff\xff\x29\x00\x0a\x00\x29\x00\xff\xff\x2a\x00\x2a\x00\x07\x00\x05\x00\x08\x00\x05\x00\x01\x00\x2f\x00\x0e\x00\xff\xff\xff\xff\x05\x00\xff\xff\x22\x00\x2a\x00\x0d\x00\x1c\x00\x08\x00\x05\x00\xff\xff\xff\xff\x2f\x00\x2f\x00\x05\x00\x2f\x00\x01\x00\x2a\x00\x01\x00\x2a\x00\x0d\x00\xff\xff\x2a\x00\x29\x00\x0d\x00\x2a\x00\xff\xff\xff\xff\x2f\x00\xff\xff\xff\xff\x2f\x00\xff\xff\x2b\x00\xff\xff\x2f\x00\x29\x00\xff\xff\x27\x00\x2f\x00\x1c\x00\x2f\x00\xff\xff\x29\x00\x27\x00\x2f\x00\xff\xff\xff\xff\x2f\x00\x29\x00\x2f\x00\xff\xff\x2a\x00\x2f\x00\x29\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2b\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\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#++happyTable :: HappyAddr+happyTable = HappyA# "\x00\x00\x6d\x00\x2c\x00\xea\x00\x23\x00\x23\x00\x66\x00\x23\x00\xb9\x00\x4a\x00\xba\x00\xbb\x00\xf3\x00\x3e\x00\x2d\x00\xf4\x00\xff\xff\x2e\x00\x67\x00\xbc\x00\x68\x00\x4b\x00\x2f\x00\x23\x00\x30\x00\xef\x00\x26\x00\x31\x00\x32\x00\x23\x00\x26\x00\xf1\x00\xa5\x00\x26\x00\x26\x00\xff\xff\x26\x00\x33\x00\xe3\x00\x34\x00\xe0\x00\x8c\x00\xc6\x00\x9b\x00\x67\x00\x35\x00\x68\x00\x26\x00\xff\xff\x23\x00\x26\x00\x4c\x00\x35\x00\x4d\x00\xff\xff\x2c\x00\x27\x00\x36\x00\x29\x00\x24\x00\xc0\x00\x54\x00\x66\x00\x27\x00\x28\x00\x29\x00\xe6\x00\x2d\x00\xb7\x00\x26\x00\x2e\x00\x2c\x00\x26\x00\x26\x00\x67\x00\x2f\x00\x68\x00\x30\x00\x3e\x00\x5f\x00\x31\x00\x32\x00\xae\x00\x2d\x00\x5f\x00\x90\x00\x2e\x00\xe4\x00\x75\xff\x26\x00\x33\x00\x2f\x00\x34\x00\x30\x00\x26\x00\xf6\x00\x31\x00\x32\x00\x35\x00\x66\x00\xce\x00\x35\x00\xc0\x00\x26\x00\x29\x00\x6d\x00\x33\x00\xd9\x00\x34\x00\x3e\x00\x5c\x00\x67\x00\xcb\x00\x68\x00\x35\x00\x73\x00\x74\x00\x75\x00\x76\x00\xc4\x00\x77\x00\x29\x00\x78\x00\x79\x00\x37\x00\x66\x00\x29\x00\x7a\x00\x7b\x00\x7c\x00\x3a\x00\x7d\x00\x7e\x00\x23\x00\x26\x00\x89\x00\x5f\x00\x67\x00\x97\x00\x68\x00\x26\x00\x73\x00\x74\x00\x75\x00\x76\x00\x3e\x00\x77\x00\x54\x00\x78\x00\x79\x00\x6d\x00\x3b\x00\xa8\x00\x7a\x00\x7b\x00\x7c\x00\xd0\x00\x7d\x00\x7e\x00\x83\x00\xda\x00\xe8\x00\x5f\x00\x8a\x00\x84\x00\x8b\x00\x26\x00\xd1\x00\x55\x00\x86\x00\x83\x00\xd5\x00\x71\x00\x69\x00\x3f\x00\x84\x00\xe1\x00\x26\x00\x60\x00\x26\x00\x86\x00\x26\x00\x6a\x00\x71\x00\x69\x00\x26\x00\x83\x00\x5c\x00\x83\x00\xcc\x00\x63\x00\x84\x00\x85\x00\x89\x00\xe7\x00\x87\x00\x86\x00\xd4\x00\x86\x00\x71\x00\x69\x00\x71\x00\x69\x00\x9a\x00\x69\x00\x63\x00\x87\x00\x27\x00\x28\x00\x29\x00\xde\x00\x27\x00\x28\x00\x29\x00\xbe\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x64\x00\xd6\x00\x58\x00\x87\x00\x59\x00\x87\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x6a\x00\x5c\x00\xd7\x00\x5d\x00\x45\x00\x46\x00\x47\x00\x6a\x00\xc7\x00\x45\x00\x46\x00\x47\x00\xd3\x00\xb0\x00\x45\x00\x46\x00\x47\x00\x92\x00\x48\x00\xdc\x00\x93\x00\x4e\x00\xaf\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x6a\x00\x4e\x00\xb4\x00\x26\x00\xba\x00\xbb\x00\x4e\x00\x4f\x00\xff\xff\xf0\x00\x46\x00\x47\x00\xdd\x00\xbc\x00\xc8\x00\x46\x00\x47\x00\x3a\x00\x94\x00\xb1\x00\x46\x00\x47\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x40\x00\x4d\x00\x42\x00\x43\x00\x44\x00\xe5\x00\x3d\x00\x3a\x00\x59\x00\x3a\x00\x6d\x00\x6a\x00\xd1\x00\x6a\x00\x52\x00\x46\x00\x47\x00\x63\x00\x95\x00\x9d\x00\x51\x00\x47\x00\x91\x00\x6f\x00\x63\x00\x9c\x00\x50\x00\xc5\x00\x3d\x00\x3c\x00\x3d\x00\xa2\x00\x59\x00\x63\x00\xe2\x00\x9e\x00\xa3\x00\x71\x00\x69\x00\xa7\x00\x81\x00\x82\x00\x63\x00\x80\x00\xab\x00\x9f\x00\x71\x00\x69\x00\x6a\x00\x63\x00\xdf\x00\x63\x00\x80\x00\x63\x00\xac\x00\x71\x00\x69\x00\x7f\x00\x6a\x00\x80\x00\xa1\x00\x70\x00\x71\x00\x69\x00\x71\x00\x69\x00\x68\x00\x69\x00\x6d\x00\x6a\x00\x6b\x00\xad\x00\x38\x00\xbc\x00\x99\x00\xba\x00\xbb\x00\x9a\x00\x59\x00\xbd\x00\x6e\x00\x6f\x00\xab\x00\x23\x00\xbc\x00\x59\x00\x53\x00\x56\x00\x7e\x00\x5a\x00\xf9\x00\x61\x00\x62\x00\x3a\x00\xf8\x00\xf6\x00\x4c\x00\xee\x00\xef\x00\xf3\x00\x23\x00\xec\x00\xeb\x00\xed\x00\xc2\x00\xc3\x00\xca\x00\xc4\x00\xcb\x00\xce\x00\x5f\x00\x23\x00\x5c\x00\xd3\x00\xd9\x00\xdc\x00\x8e\x00\x00\x00\x4c\x00\x8f\x00\x4c\x00\x00\x00\x23\x00\x91\x00\x23\x00\x00\x00\x26\x00\x26\x00\xa1\x00\xa8\x00\xa7\x00\xaa\x00\x5c\x00\xff\xff\xa6\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x97\x00\x26\x00\xab\x00\x3a\x00\xb3\x00\xb6\x00\x00\x00\x00\x00\xff\xff\xff\xff\x90\x00\xff\xff\x5c\x00\x26\x00\x5c\x00\x26\x00\x5f\x00\x00\x00\x26\x00\x23\x00\x5f\x00\x26\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x4c\x00\x00\x00\xff\xff\x23\x00\x00\x00\xb7\x00\xff\xff\x3a\x00\xff\xff\x00\x00\x23\x00\xb9\x00\xff\xff\x00\x00\x00\x00\xff\xff\x23\x00\xff\xff\x00\x00\x26\x00\xff\xff\x23\x00\x00\x00\x26\x00\x00\x00\x00\x00\x4c\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\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#++happyReduceArr = Happy_Data_Array.array (33, 139) [+ (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),+ (83 , happyReduce_83),+ (84 , happyReduce_84),+ (85 , happyReduce_85),+ (86 , happyReduce_86),+ (87 , happyReduce_87),+ (88 , happyReduce_88),+ (89 , happyReduce_89),+ (90 , happyReduce_90),+ (91 , happyReduce_91),+ (92 , happyReduce_92),+ (93 , happyReduce_93),+ (94 , happyReduce_94),+ (95 , happyReduce_95),+ (96 , happyReduce_96),+ (97 , happyReduce_97),+ (98 , happyReduce_98),+ (99 , happyReduce_99),+ (100 , happyReduce_100),+ (101 , happyReduce_101),+ (102 , happyReduce_102),+ (103 , happyReduce_103),+ (104 , happyReduce_104),+ (105 , happyReduce_105),+ (106 , happyReduce_106),+ (107 , happyReduce_107),+ (108 , happyReduce_108),+ (109 , happyReduce_109),+ (110 , happyReduce_110),+ (111 , happyReduce_111),+ (112 , happyReduce_112),+ (113 , happyReduce_113),+ (114 , happyReduce_114),+ (115 , happyReduce_115),+ (116 , happyReduce_116),+ (117 , happyReduce_117),+ (118 , happyReduce_118),+ (119 , happyReduce_119),+ (120 , happyReduce_120),+ (121 , happyReduce_121),+ (122 , happyReduce_122),+ (123 , happyReduce_123),+ (124 , happyReduce_124),+ (125 , happyReduce_125),+ (126 , happyReduce_126),+ (127 , happyReduce_127),+ (128 , happyReduce_128),+ (129 , happyReduce_129),+ (130 , happyReduce_130),+ (131 , happyReduce_131),+ (132 , happyReduce_132),+ (133 , happyReduce_133),+ (134 , happyReduce_134),+ (135 , happyReduce_135),+ (136 , happyReduce_136),+ (137 , happyReduce_137),+ (138 , happyReduce_138),+ (139 , happyReduce_139)+ ]++happy_n_terms = 48 :: Int+happy_n_nonterms = 38 :: Int++happyReduce_33 = happySpecReduce_1 0# happyReduction_33+happyReduction_33 happy_x_1+ = case happyOutTok happy_x_1 of { (PT _ (TL happy_var_1)) -> + happyIn36+ (happy_var_1+ )}++happyReduce_34 = happySpecReduce_1 1# happyReduction_34+happyReduction_34 happy_x_1+ = case happyOutTok happy_x_1 of { (PT _ (TV happy_var_1)) -> + happyIn37+ (Ident happy_var_1+ )}++happyReduce_35 = happySpecReduce_1 2# happyReduction_35+happyReduction_35 happy_x_1+ = case happyOutTok happy_x_1 of { (PT _ (TI happy_var_1)) -> + happyIn38+ ((read ( happy_var_1)) :: Integer+ )}++happyReduce_36 = happySpecReduce_1 3# happyReduction_36+happyReduction_36 happy_x_1+ = case happyOutTok happy_x_1 of { (PT _ (TC happy_var_1)) -> + happyIn39+ ((read ( happy_var_1)) :: Char+ )}++happyReduce_37 = happySpecReduce_1 4# happyReduction_37+happyReduction_37 happy_x_1+ = case happyOutTok happy_x_1 of { (PT _ (TD happy_var_1)) -> + happyIn40+ ((read ( happy_var_1)) :: Double+ )}++happyReduce_38 = happySpecReduce_1 5# happyReduction_38+happyReduction_38 happy_x_1+ = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn41+ (LGr happy_var_1+ )}++happyReduce_39 = happySpecReduce_1 6# happyReduction_39+happyReduction_39 happy_x_1+ = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn42+ (DefAll happy_var_1+ )}++happyReduce_40 = happySpecReduce_3 6# happyReduction_40+happyReduction_40 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut73 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_3 of { happy_var_3 -> + happyIn42+ (DefSome happy_var_1 happy_var_3+ )}}++happyReduce_41 = happySpecReduce_2 6# happyReduction_41+happyReduction_41 happy_x_2+ happy_x_1+ = case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn42+ (LDefView happy_var_2+ )}++happyReduce_42 = happySpecReduce_0 7# happyReduction_42+happyReduction_42 = happyIn43+ ([]+ )++happyReduce_43 = happySpecReduce_1 7# happyReduction_43+happyReduction_43 happy_x_1+ = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn43+ ((:[]) happy_var_1+ )}++happyReduce_44 = happySpecReduce_3 7# happyReduction_44+happyReduction_44 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut42 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_3 of { happy_var_3 -> + happyIn43+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_45 = happySpecReduce_1 8# happyReduction_45+happyReduction_45 happy_x_1+ = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn44+ (Grammar happy_var_1+ )}++happyReduce_46 = happySpecReduce_0 9# happyReduction_46+happyReduction_46 = happyIn45+ ([]+ )++happyReduce_47 = happySpecReduce_1 9# happyReduction_47+happyReduction_47 happy_x_1+ = case happyOut47 happy_x_1 of { happy_var_1 -> + happyIn45+ ((:[]) happy_var_1+ )}++happyReduce_48 = happySpecReduce_3 9# happyReduction_48+happyReduction_48 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut45 happy_x_3 of { happy_var_3 -> + happyIn45+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_49 = happySpecReduce_0 10# happyReduction_49+happyReduction_49 = happyIn46+ ([]+ )++happyReduce_50 = happySpecReduce_2 10# happyReduction_50+happyReduction_50 happy_x_2+ happy_x_1+ = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn46+ (flip (:) happy_var_1 happy_var_2+ )}}++happyReduce_51 = happyReduce 5# 11# happyReduction_51+happyReduction_51 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut46 happy_x_5 of { happy_var_5 -> + happyIn47+ (Rule happy_var_1 happy_var_3 (reverse happy_var_5)+ ) `HappyStk` happyRest}}}++happyReduce_52 = happySpecReduce_2 11# happyReduction_52+happyReduction_52 happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn47+ (Comment happy_var_2+ )}++happyReduce_53 = happySpecReduce_3 11# happyReduction_53+happyReduction_53 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + happyIn47+ (Comments happy_var_2 happy_var_3+ )}}++happyReduce_54 = happyReduce 6# 11# happyReduction_54+happyReduction_54 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut50 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_4 of { happy_var_4 -> + case happyOut46 happy_x_6 of { happy_var_6 -> + happyIn47+ (Internal happy_var_2 happy_var_4 (reverse happy_var_6)+ ) `HappyStk` happyRest}}}++happyReduce_55 = happySpecReduce_3 11# happyReduction_55+happyReduction_55 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut72 happy_x_3 of { happy_var_3 -> + happyIn47+ (Token happy_var_2 happy_var_3+ )}}++happyReduce_56 = happyReduce 4# 11# happyReduction_56+happyReduction_56 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut37 happy_x_3 of { happy_var_3 -> + case happyOut72 happy_x_4 of { happy_var_4 -> + happyIn47+ (PosToken happy_var_3 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_57 = happySpecReduce_2 11# happyReduction_57+happyReduction_57 happy_x_2+ happy_x_1+ = case happyOut73 happy_x_2 of { happy_var_2 -> + happyIn47+ (Entryp happy_var_2+ )}++happyReduce_58 = happyReduce 4# 11# happyReduction_58+happyReduction_58 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut68 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut36 happy_x_4 of { happy_var_4 -> + happyIn47+ (Separator happy_var_2 happy_var_3 happy_var_4+ ) `HappyStk` happyRest}}}++happyReduce_59 = happyReduce 4# 11# happyReduction_59+happyReduction_59 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut68 happy_x_2 of { happy_var_2 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut36 happy_x_4 of { happy_var_4 -> + happyIn47+ (Terminator happy_var_2 happy_var_3 happy_var_4+ ) `HappyStk` happyRest}}}++happyReduce_60 = happyReduce 6# 11# happyReduction_60+happyReduction_60 (happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut36 happy_x_3 of { happy_var_3 -> + case happyOut36 happy_x_4 of { happy_var_4 -> + case happyOut57 happy_x_5 of { happy_var_5 -> + case happyOut68 happy_x_6 of { happy_var_6 -> + happyIn47+ (Delimiters happy_var_2 happy_var_3 happy_var_4 happy_var_5 happy_var_6+ ) `HappyStk` happyRest}}}}}++happyReduce_61 = happySpecReduce_3 11# happyReduction_61+happyReduction_61 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut38 happy_x_3 of { happy_var_3 -> + happyIn47+ (Coercions happy_var_2 happy_var_3+ )}}++happyReduce_62 = happyReduce 4# 11# happyReduction_62+happyReduction_62 (happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut66 happy_x_4 of { happy_var_4 -> + happyIn47+ (Rules happy_var_2 happy_var_4+ ) `HappyStk` happyRest}}++happyReduce_63 = happyReduce 5# 11# happyReduction_63+happyReduction_63 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut37 happy_x_2 of { happy_var_2 -> + case happyOut59 happy_x_3 of { happy_var_3 -> + case happyOut60 happy_x_5 of { happy_var_5 -> + happyIn47+ (Function happy_var_2 (reverse happy_var_3) happy_var_5+ ) `HappyStk` happyRest}}}++happyReduce_64 = happySpecReduce_2 11# happyReduction_64+happyReduction_64 happy_x_2+ happy_x_1+ = case happyOut65 happy_x_2 of { happy_var_2 -> + happyIn47+ (Layout happy_var_2+ )}++happyReduce_65 = happySpecReduce_3 11# happyReduction_65+happyReduction_65 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut65 happy_x_3 of { happy_var_3 -> + happyIn47+ (LayoutStop happy_var_3+ )}++happyReduce_66 = happySpecReduce_2 11# happyReduction_66+happyReduction_66 happy_x_2+ happy_x_1+ = happyIn47+ (LayoutTop+ )++happyReduce_67 = happySpecReduce_1 12# happyReduction_67+happyReduction_67 happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn48+ (Terminal happy_var_1+ )}++happyReduce_68 = happySpecReduce_1 12# happyReduction_68+happyReduction_68 happy_x_1+ = case happyOut49 happy_x_1 of { happy_var_1 -> + happyIn48+ (NTerminal happy_var_1+ )}++happyReduce_69 = happySpecReduce_3 13# happyReduction_69+happyReduction_69 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut49 happy_x_2 of { happy_var_2 -> + happyIn49+ (ListCat happy_var_2+ )}++happyReduce_70 = happySpecReduce_1 13# happyReduction_70+happyReduction_70 happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn49+ (IdCat happy_var_1+ )}++happyReduce_71 = happySpecReduce_1 14# happyReduction_71+happyReduction_71 happy_x_1+ = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn50+ (LabNoP happy_var_1+ )}++happyReduce_72 = happySpecReduce_2 14# happyReduction_72+happyReduction_72 happy_x_2+ happy_x_1+ = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn50+ (LabP happy_var_1 happy_var_2+ )}}++happyReduce_73 = happySpecReduce_3 14# happyReduction_73+happyReduction_73 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_3 of { happy_var_3 -> + happyIn50+ (LabPF happy_var_1 happy_var_2 happy_var_3+ )}}}++happyReduce_74 = happySpecReduce_2 14# happyReduction_74+happyReduction_74 happy_x_2+ happy_x_1+ = case happyOut51 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_2 of { happy_var_2 -> + happyIn50+ (LabF happy_var_1 happy_var_2+ )}}++happyReduce_75 = happySpecReduce_1 15# happyReduction_75+happyReduction_75 happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn51+ (Id happy_var_1+ )}++happyReduce_76 = happySpecReduce_1 15# happyReduction_76+happyReduction_76 happy_x_1+ = happyIn51+ (Wild+ )++happyReduce_77 = happySpecReduce_2 15# happyReduction_77+happyReduction_77 happy_x_2+ happy_x_1+ = happyIn51+ (ListE+ )++happyReduce_78 = happySpecReduce_3 15# happyReduction_78+happyReduction_78 happy_x_3+ happy_x_2+ happy_x_1+ = happyIn51+ (ListCons+ )++happyReduce_79 = happyReduce 5# 15# happyReduction_79+happyReduction_79 (happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = happyIn51+ (ListOne+ ) `HappyStk` happyRest++happyReduce_80 = happyReduce 9# 16# happyReduction_80+happyReduction_80 (happy_x_9 `HappyStk`+ happy_x_8 `HappyStk`+ happy_x_7 `HappyStk`+ happy_x_6 `HappyStk`+ happy_x_5 `HappyStk`+ happy_x_4 `HappyStk`+ happy_x_3 `HappyStk`+ happy_x_2 `HappyStk`+ happy_x_1 `HappyStk`+ happyRest)+ = case happyOut55 happy_x_3 of { happy_var_3 -> + case happyOut54 happy_x_7 of { happy_var_7 -> + happyIn52+ (ProfIt happy_var_3 happy_var_7+ ) `HappyStk` happyRest}}++happyReduce_81 = happySpecReduce_3 17# happyReduction_81+happyReduction_81 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut54 happy_x_2 of { happy_var_2 -> + happyIn53+ (Ints happy_var_2+ )}++happyReduce_82 = happySpecReduce_0 18# happyReduction_82+happyReduction_82 = happyIn54+ ([]+ )++happyReduce_83 = happySpecReduce_1 18# happyReduction_83+happyReduction_83 happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn54+ ((:[]) happy_var_1+ )}++happyReduce_84 = happySpecReduce_3 18# happyReduction_84+happyReduction_84 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut54 happy_x_3 of { happy_var_3 -> + happyIn54+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_85 = happySpecReduce_0 19# happyReduction_85+happyReduction_85 = happyIn55+ ([]+ )++happyReduce_86 = happySpecReduce_1 19# happyReduction_86+happyReduction_86 happy_x_1+ = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn55+ ((:[]) happy_var_1+ )}++happyReduce_87 = happySpecReduce_3 19# happyReduction_87+happyReduction_87 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn55+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_88 = happySpecReduce_1 20# happyReduction_88+happyReduction_88 happy_x_1+ = case happyOut52 happy_x_1 of { happy_var_1 -> + happyIn56+ ((:[]) happy_var_1+ )}++happyReduce_89 = happySpecReduce_2 20# happyReduction_89+happyReduction_89 happy_x_2+ happy_x_1+ = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn56+ ((:) happy_var_1 happy_var_2+ )}}++happyReduce_90 = happySpecReduce_0 21# happyReduction_90+happyReduction_90 = happyIn57+ (SepNone+ )++happyReduce_91 = happySpecReduce_2 21# happyReduction_91+happyReduction_91 happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn57+ (SepTerm happy_var_2+ )}++happyReduce_92 = happySpecReduce_2 21# happyReduction_92+happyReduction_92 happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn57+ (SepSepar happy_var_2+ )}++happyReduce_93 = happySpecReduce_1 22# happyReduction_93+happyReduction_93 happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn58+ (Arg happy_var_1+ )}++happyReduce_94 = happySpecReduce_0 23# happyReduction_94+happyReduction_94 = happyIn59+ ([]+ )++happyReduce_95 = happySpecReduce_2 23# happyReduction_95+happyReduction_95 happy_x_2+ happy_x_1+ = case happyOut59 happy_x_1 of { happy_var_1 -> + case happyOut58 happy_x_2 of { happy_var_2 -> + happyIn59+ (flip (:) happy_var_1 happy_var_2+ )}}++happyReduce_96 = happySpecReduce_3 24# happyReduction_96+happyReduction_96 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut61 happy_x_1 of { happy_var_1 -> + case happyOut60 happy_x_3 of { happy_var_3 -> + happyIn60+ (Cons happy_var_1 happy_var_3+ )}}++happyReduce_97 = happySpecReduce_1 24# happyReduction_97+happyReduction_97 happy_x_1+ = case happyOut61 happy_x_1 of { happy_var_1 -> + happyIn60+ (happy_var_1+ )}++happyReduce_98 = happySpecReduce_2 25# happyReduction_98+happyReduction_98 happy_x_2+ happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { happy_var_2 -> + happyIn61+ (App happy_var_1 happy_var_2+ )}}++happyReduce_99 = happySpecReduce_1 25# happyReduction_99+happyReduction_99 happy_x_1+ = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn61+ (happy_var_1+ )}++happyReduce_100 = happySpecReduce_1 26# happyReduction_100+happyReduction_100 happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn62+ (Var happy_var_1+ )}++happyReduce_101 = happySpecReduce_1 26# happyReduction_101+happyReduction_101 happy_x_1+ = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn62+ (LitInt happy_var_1+ )}++happyReduce_102 = happySpecReduce_1 26# happyReduction_102+happyReduction_102 happy_x_1+ = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn62+ (LitChar happy_var_1+ )}++happyReduce_103 = happySpecReduce_1 26# happyReduction_103+happyReduction_103 happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn62+ (LitString happy_var_1+ )}++happyReduce_104 = happySpecReduce_1 26# happyReduction_104+happyReduction_104 happy_x_1+ = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn62+ (LitDouble happy_var_1+ )}++happyReduce_105 = happySpecReduce_3 26# happyReduction_105+happyReduction_105 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut64 happy_x_2 of { happy_var_2 -> + happyIn62+ (List happy_var_2+ )}++happyReduce_106 = happySpecReduce_3 26# happyReduction_106+happyReduction_106 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut60 happy_x_2 of { happy_var_2 -> + happyIn62+ (happy_var_2+ )}++happyReduce_107 = happySpecReduce_1 27# happyReduction_107+happyReduction_107 happy_x_1+ = case happyOut62 happy_x_1 of { happy_var_1 -> + happyIn63+ ((:[]) happy_var_1+ )}++happyReduce_108 = happySpecReduce_2 27# happyReduction_108+happyReduction_108 happy_x_2+ happy_x_1+ = case happyOut62 happy_x_1 of { happy_var_1 -> + case happyOut63 happy_x_2 of { happy_var_2 -> + happyIn63+ ((:) happy_var_1 happy_var_2+ )}}++happyReduce_109 = happySpecReduce_0 28# happyReduction_109+happyReduction_109 = happyIn64+ ([]+ )++happyReduce_110 = happySpecReduce_1 28# happyReduction_110+happyReduction_110 happy_x_1+ = case happyOut60 happy_x_1 of { happy_var_1 -> + happyIn64+ ((:[]) happy_var_1+ )}++happyReduce_111 = happySpecReduce_3 28# happyReduction_111+happyReduction_111 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut60 happy_x_1 of { happy_var_1 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + happyIn64+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_112 = happySpecReduce_1 29# happyReduction_112+happyReduction_112 happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + happyIn65+ ((:[]) happy_var_1+ )}++happyReduce_113 = happySpecReduce_3 29# happyReduction_113+happyReduction_113 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut36 happy_x_1 of { happy_var_1 -> + case happyOut65 happy_x_3 of { happy_var_3 -> + happyIn65+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_114 = happySpecReduce_1 30# happyReduction_114+happyReduction_114 happy_x_1+ = case happyOut67 happy_x_1 of { happy_var_1 -> + happyIn66+ ((:[]) happy_var_1+ )}++happyReduce_115 = happySpecReduce_3 30# happyReduction_115+happyReduction_115 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut67 happy_x_1 of { happy_var_1 -> + case happyOut66 happy_x_3 of { happy_var_3 -> + happyIn66+ ((:) happy_var_1 happy_var_3+ )}}++happyReduce_116 = happySpecReduce_1 31# happyReduction_116+happyReduction_116 happy_x_1+ = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn67+ (RHS (reverse happy_var_1)+ )}++happyReduce_117 = happySpecReduce_1 32# happyReduction_117+happyReduction_117 happy_x_1+ = happyIn68+ (MNonempty+ )++happyReduce_118 = happySpecReduce_0 32# happyReduction_118+happyReduction_118 = happyIn68+ (MEmpty+ )++happyReduce_119 = happySpecReduce_2 33# happyReduction_119+happyReduction_119 happy_x_2+ happy_x_1+ = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut71 happy_x_2 of { happy_var_2 -> + happyIn69+ (RSeq happy_var_1 happy_var_2+ )}}++happyReduce_120 = happySpecReduce_1 33# happyReduction_120+happyReduction_120 happy_x_1+ = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn69+ (happy_var_1+ )}++happyReduce_121 = happySpecReduce_3 34# happyReduction_121+happyReduction_121 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut70 happy_x_1 of { happy_var_1 -> + case happyOut69 happy_x_3 of { happy_var_3 -> + happyIn70+ (RAlt happy_var_1 happy_var_3+ )}}++happyReduce_122 = happySpecReduce_3 34# happyReduction_122+happyReduction_122 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut69 happy_x_3 of { happy_var_3 -> + happyIn70+ (RMinus happy_var_1 happy_var_3+ )}}++happyReduce_123 = happySpecReduce_1 34# happyReduction_123+happyReduction_123 happy_x_1+ = case happyOut69 happy_x_1 of { happy_var_1 -> + happyIn70+ (happy_var_1+ )}++happyReduce_124 = happySpecReduce_2 35# happyReduction_124+happyReduction_124 happy_x_2+ happy_x_1+ = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn71+ (RStar happy_var_1+ )}++happyReduce_125 = happySpecReduce_2 35# happyReduction_125+happyReduction_125 happy_x_2+ happy_x_1+ = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn71+ (RPlus happy_var_1+ )}++happyReduce_126 = happySpecReduce_2 35# happyReduction_126+happyReduction_126 happy_x_2+ happy_x_1+ = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn71+ (ROpt happy_var_1+ )}++happyReduce_127 = happySpecReduce_1 35# happyReduction_127+happyReduction_127 happy_x_1+ = happyIn71+ (REps+ )++happyReduce_128 = happySpecReduce_1 35# happyReduction_128+happyReduction_128 happy_x_1+ = case happyOut39 happy_x_1 of { happy_var_1 -> + happyIn71+ (RChar happy_var_1+ )}++happyReduce_129 = happySpecReduce_3 35# happyReduction_129+happyReduction_129 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn71+ (RAlts happy_var_2+ )}++happyReduce_130 = happySpecReduce_3 35# happyReduction_130+happyReduction_130 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn71+ (RSeqs happy_var_2+ )}++happyReduce_131 = happySpecReduce_1 35# happyReduction_131+happyReduction_131 happy_x_1+ = happyIn71+ (RDigit+ )++happyReduce_132 = happySpecReduce_1 35# happyReduction_132+happyReduction_132 happy_x_1+ = happyIn71+ (RLetter+ )++happyReduce_133 = happySpecReduce_1 35# happyReduction_133+happyReduction_133 happy_x_1+ = happyIn71+ (RUpper+ )++happyReduce_134 = happySpecReduce_1 35# happyReduction_134+happyReduction_134 happy_x_1+ = happyIn71+ (RLower+ )++happyReduce_135 = happySpecReduce_1 35# happyReduction_135+happyReduction_135 happy_x_1+ = happyIn71+ (RAny+ )++happyReduce_136 = happySpecReduce_3 35# happyReduction_136+happyReduction_136 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut72 happy_x_2 of { happy_var_2 -> + happyIn71+ (happy_var_2+ )}++happyReduce_137 = happySpecReduce_1 36# happyReduction_137+happyReduction_137 happy_x_1+ = case happyOut70 happy_x_1 of { happy_var_1 -> + happyIn72+ (happy_var_1+ )}++happyReduce_138 = happySpecReduce_1 37# happyReduction_138+happyReduction_138 happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn73+ ((:[]) happy_var_1+ )}++happyReduce_139 = happySpecReduce_3 37# happyReduction_139+happyReduction_139 happy_x_3+ happy_x_2+ happy_x_1+ = case happyOut37 happy_x_1 of { happy_var_1 -> + case happyOut73 happy_x_3 of { happy_var_3 -> + happyIn73+ ((:) happy_var_1 happy_var_3+ )}}++happyNewToken action sts stk [] =+ happyDoAction 47# notHappyAtAll action sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = happyDoAction i tk action sts stk tks in+ case tk of {+ PT _ (TS _ 1) -> cont 1#;+ PT _ (TS _ 2) -> cont 2#;+ PT _ (TS _ 3) -> cont 3#;+ PT _ (TS _ 4) -> cont 4#;+ PT _ (TS _ 5) -> cont 5#;+ PT _ (TS _ 6) -> cont 6#;+ PT _ (TS _ 7) -> cont 7#;+ PT _ (TS _ 8) -> cont 8#;+ PT _ (TS _ 9) -> cont 9#;+ PT _ (TS _ 10) -> cont 10#;+ PT _ (TS _ 11) -> cont 11#;+ PT _ (TS _ 12) -> cont 12#;+ PT _ (TS _ 13) -> cont 13#;+ PT _ (TS _ 14) -> cont 14#;+ PT _ (TS _ 15) -> cont 15#;+ PT _ (TS _ 16) -> cont 16#;+ PT _ (TS _ 17) -> cont 17#;+ PT _ (TS _ 18) -> cont 18#;+ PT _ (TS _ 19) -> cont 19#;+ PT _ (TS _ 20) -> cont 20#;+ PT _ (TS _ 21) -> cont 21#;+ PT _ (TS _ 22) -> cont 22#;+ PT _ (TS _ 23) -> cont 23#;+ PT _ (TS _ 24) -> cont 24#;+ PT _ (TS _ 25) -> cont 25#;+ PT _ (TS _ 26) -> cont 26#;+ PT _ (TS _ 27) -> cont 27#;+ PT _ (TS _ 28) -> cont 28#;+ PT _ (TS _ 29) -> cont 29#;+ PT _ (TS _ 30) -> cont 30#;+ PT _ (TS _ 31) -> cont 31#;+ PT _ (TS _ 32) -> cont 32#;+ PT _ (TS _ 33) -> cont 33#;+ PT _ (TS _ 34) -> cont 34#;+ PT _ (TS _ 35) -> cont 35#;+ PT _ (TS _ 36) -> cont 36#;+ PT _ (TS _ 37) -> cont 37#;+ PT _ (TS _ 38) -> cont 38#;+ PT _ (TS _ 39) -> cont 39#;+ PT _ (TS _ 40) -> cont 40#;+ PT _ (TL happy_dollar_dollar) -> cont 41#;+ PT _ (TV happy_dollar_dollar) -> cont 42#;+ PT _ (TI happy_dollar_dollar) -> cont 43#;+ PT _ (TC happy_dollar_dollar) -> cont 44#;+ PT _ (TD happy_dollar_dollar) -> cont 45#;+ _ -> cont 46#;+ _ -> happyError' (tk:tks)+ }++happyError_ 47# tk tks = happyError' tks+happyError_ _ tk tks = happyError' (tk:tks)++happyThen :: () => Err a -> (a -> Err b) -> Err b+happyThen = (thenM)+happyReturn :: () => a -> Err a+happyReturn = (returnM)+happyThen1 m k tks = (thenM) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> Err a+happyReturn1 = \a tks -> (returnM) a+happyError' :: () => [(Token)] -> Err a+happyError' = happyError++pLGrammar tks = happySomeParser where+ happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut41 x))++pLDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut42 x))++pListLDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse 2# tks) (\x -> happyReturn (happyOut43 x))++pGrammar tks = happySomeParser where+ happySomeParser = happyThen (happyParse 3# tks) (\x -> happyReturn (happyOut44 x))++pListDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse 4# tks) (\x -> happyReturn (happyOut45 x))++pListItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse 5# tks) (\x -> happyReturn (happyOut46 x))++pDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse 6# tks) (\x -> happyReturn (happyOut47 x))++pItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse 7# tks) (\x -> happyReturn (happyOut48 x))++pCat tks = happySomeParser where+ happySomeParser = happyThen (happyParse 8# tks) (\x -> happyReturn (happyOut49 x))++pLabel tks = happySomeParser where+ happySomeParser = happyThen (happyParse 9# tks) (\x -> happyReturn (happyOut50 x))++pLabelId tks = happySomeParser where+ happySomeParser = happyThen (happyParse 10# tks) (\x -> happyReturn (happyOut51 x))++pProfItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse 11# tks) (\x -> happyReturn (happyOut52 x))++pIntList tks = happySomeParser where+ happySomeParser = happyThen (happyParse 12# tks) (\x -> happyReturn (happyOut53 x))++pListInteger tks = happySomeParser where+ happySomeParser = happyThen (happyParse 13# tks) (\x -> happyReturn (happyOut54 x))++pListIntList tks = happySomeParser where+ happySomeParser = happyThen (happyParse 14# tks) (\x -> happyReturn (happyOut55 x))++pListProfItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse 15# tks) (\x -> happyReturn (happyOut56 x))++pSeparation tks = happySomeParser where+ happySomeParser = happyThen (happyParse 16# tks) (\x -> happyReturn (happyOut57 x))++pArg tks = happySomeParser where+ happySomeParser = happyThen (happyParse 17# tks) (\x -> happyReturn (happyOut58 x))++pListArg tks = happySomeParser where+ happySomeParser = happyThen (happyParse 18# tks) (\x -> happyReturn (happyOut59 x))++pExp tks = happySomeParser where+ happySomeParser = happyThen (happyParse 19# tks) (\x -> happyReturn (happyOut60 x))++pExp1 tks = happySomeParser where+ happySomeParser = happyThen (happyParse 20# tks) (\x -> happyReturn (happyOut61 x))++pExp2 tks = happySomeParser where+ happySomeParser = happyThen (happyParse 21# tks) (\x -> happyReturn (happyOut62 x))++pListExp2 tks = happySomeParser where+ happySomeParser = happyThen (happyParse 22# tks) (\x -> happyReturn (happyOut63 x))++pListExp tks = happySomeParser where+ happySomeParser = happyThen (happyParse 23# tks) (\x -> happyReturn (happyOut64 x))++pListString tks = happySomeParser where+ happySomeParser = happyThen (happyParse 24# tks) (\x -> happyReturn (happyOut65 x))++pListRHS tks = happySomeParser where+ happySomeParser = happyThen (happyParse 25# tks) (\x -> happyReturn (happyOut66 x))++pRHS tks = happySomeParser where+ happySomeParser = happyThen (happyParse 26# tks) (\x -> happyReturn (happyOut67 x))++pMinimumSize tks = happySomeParser where+ happySomeParser = happyThen (happyParse 27# tks) (\x -> happyReturn (happyOut68 x))++pReg2 tks = happySomeParser where+ happySomeParser = happyThen (happyParse 28# tks) (\x -> happyReturn (happyOut69 x))++pReg1 tks = happySomeParser where+ happySomeParser = happyThen (happyParse 29# tks) (\x -> happyReturn (happyOut70 x))++pReg3 tks = happySomeParser where+ happySomeParser = happyThen (happyParse 30# tks) (\x -> happyReturn (happyOut71 x))++pReg tks = happySomeParser where+ happySomeParser = happyThen (happyParse 31# tks) (\x -> happyReturn (happyOut72 x))++pListIdent tks = happySomeParser where+ happySomeParser = happyThen (happyParse 32# tks) (\x -> happyReturn (happyOut73 x))++happySeq = happyDontSeq+++returnM :: a -> Err a+returnM = return++thenM :: Err a -> (a -> Err b) -> Err b+thenM = (>>=)++happyError :: [Token] -> Err a+happyError ts =+ Bad $ "syntax error at " ++ tokenPos ts ++ + case ts of+ [] -> []+ [Err _] -> " due to lexer error"+ _ -> " before " ++ unwords (map (id . prToken) (take 4 ts))++myLexer = tokens+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "templates/GenericTemplate.hs" #-}+{-# LINE 1 "<command-line>" #-}+{-# LINE 8 "<command-line>" #-}+# 1 "/usr/include/stdc-predef.h" 1 3 4++# 17 "/usr/include/stdc-predef.h" 3 4++++++++++++++++++++++++# 8 "<command-line>" 2+{-# 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@(x `HappyStk` _) =+ let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+-- trace "failing" $ + happyError_ i tk++{- We don't need state discarding for our restricted implementation of+ "error". In fact, it can cause some bogus parses, so I've disabled it+ 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.
runtime/Algebra/RingUtils.hs view
@@ -34,7 +34,7 @@ isZero x = x == 0 class AbelianGroupZ a => Ring a where- (*) :: a -> a -> a + (*) :: a -> a -> a class (AbelianGroupZ a) => RingP a where mul :: Bool -> a -> a -> Pair a@@ -49,7 +49,7 @@ newtype O f g a = O {fromO :: f (g a)} deriving (AbelianGroup, AbelianGroupZ, Show)- + instance (Functor f,Functor g) => Functor (O f g) where fmap f (O x) = O (fmap (fmap f) x)
runtime/Data/Matrix/Class.hs view
@@ -13,8 +13,8 @@ (f *** g) (x,y) = (f x,g y) -data Dimension - = XD +data Dimension+ = XD | YD deriving (Eq,Show) @@ -49,7 +49,7 @@ extent (O (x :/: y)) = extent x -- union with y glue d (O p) (O q) = O $ glue d <$> p <*> q split d k (O (x :/: y)) = (O $ ax :/: ay, O $ bx :/: by)- where (ax,bx) = split d k x + where (ax,bx) = split d k x (ay,by) = split d k y zeroMatrix x y = O $ pure (zeroMatrix x y) singleton x = O $ pure (singleton x) -- Attention: on both sides always!@@ -60,8 +60,8 @@ (<->) :: (AbelianGroup a, Matrix m) => m a -> m a -> m a (<->) = glue YD- -countColumns, countRows :: Matrix m => m a -> Int ++countColumns, countRows :: Matrix m => m a -> Int countColumns = ext XD . extent countRows = ext YD . extent @@ -73,9 +73,9 @@ lastColumn x = snd . split XD (countColumns x - 1) $ x chopLastRow x = fst . split YD (countRows x - 1) $ x- - - - - +++++
runtime/Data/Matrix/Quad.hs view
@@ -5,22 +5,22 @@ import Prelude () import Data.List (splitAt,intercalate) import Control.Applicative-import Algebra.RingUtils hiding (O)-import Data.Traversable +import Algebra.RingUtils hiding (O,concat)+import Data.Traversable import Data.Foldable data Shape = Bin Shape Shape | Leaf -data Shape' :: Shape -> * where - Bin' :: !Int -> Shape' s -> Shape' s' -> Shape' (Bin s s') +data Shape' :: Shape -> * where+ Bin' :: !Int -> Shape' s -> Shape' s' -> Shape' (Bin s s') Leaf' :: Shape' Leaf -data SomeShape where +data SomeShape where S :: Shape' s -> SomeShape data Mat :: Shape -> Shape -> * -> * where- Quad :: !(Mat x1 y1 a) -> !(Mat x2 y1 a) -> - !(Mat x1 y2 a) -> !(Mat x2 y2 a) -> + Quad :: !(Mat x1 y1 a) -> !(Mat x2 y1 a) ->+ !(Mat x1 y2 a) -> !(Mat x2 y2 a) -> Mat (Bin x1 x2) (Bin y1 y2) a Zero :: Mat x y a One :: !a -> Mat Leaf Leaf a@@ -48,7 +48,7 @@ | otherwise = One x (.+.) :: AbelianGroupZ a => Mat x y a -> Mat x y a -> Mat x y a-Zero .+. x = x +Zero .+. x = x x .+. Zero = x Quad a b c d .+. Quad a' b' c' d' = quad (a .+. a') (b .+. b') (c .+. c') (d .+. d') One x .+. One x' = one (x + x')@@ -72,12 +72,12 @@ Col a b & Row a' b' = quad (a & a') (a & b') (b & a') (b & b') Row a b & Quad a' b' c' d' = row (a & a' + b & c') (a & b' + b & d') Quad a b c d & Col a' c' = col (a & a' + b & c') (c & a' + d & c')- Quad a b c d & Quad a' b' c' d' = + Quad a b c d & Quad a' b' c' d' = quad (a & a' + b & c') (a & b' + b & d') (c & a' + d & c') (c & b' + d & d') x & y = error $ "mult:" ++ intercalate "; " [showR x,showR y]- + -- a variant of traverse. The constraint prevents to just use traverse. trav :: AbelianGroupZ a => Mat y x (Pair a) -> Pair (Mat y x a) trav Zero = pure Zero@@ -94,7 +94,7 @@ where close :: RingP a => Mat x x a -> Mat y x (Pair a) -> Mat y y a -> Pair (Mat y x a) close l Zero r = Zero :/: Zero close Zero x Zero = trav x -- if x = One x', we are in this case- close (Quad a11 a12 Zero a22) (Quad c11 c12 c21 c22) (Quad b11 b12 Zero b22) = quad <$> x11 <*> x12 <*> x21 <*> x22 + close (Quad a11 a12 Zero a22) (Quad c11 c12 c21 c22) (Quad b11 b12 Zero b22) = quad <$> x11 <*> x12 <*> x21 <*> x22 where x21 = close a22 c21 b11 x11 = close a11 (a12 & rightOf x21 + c11) b11 x22 = close a22 (leftOf x21 & b12 + c22) b22@@ -135,11 +135,11 @@ mkSing Leaf' (Bin' _ y1 y2) a = col Zero (mkSing Leaf' y2 a) mkSing (Bin' _ x1 x2) Leaf' a = row (mkSing x1 Leaf' a) Zero -data SomeTri a where +data SomeTri a where T :: Shape' s -> Pair (Mat s s a) -> SomeTri a- -type Q a = SomeTri a - ++type Q a = SomeTri a+ mkUpDiag :: AbelianGroupZ a => [a] -> Shape' s -> Mat s s a mkUpDiag [] Leaf' = Zero mkUpDiag xs (Bin' _ s s') = Quad (mkUpDiag a s) (mkSing s' s c) Zero (mkUpDiag b s')@@ -149,10 +149,10 @@ close p Zero = zero close p (One x) = one <$> x close p (Quad a11 a12 Zero a22) = quad' x11 (closeDisjointP p (leftOf x11) a12 (rightOf x22)) zero x22- where x11 = close (not p) a11 + where x11 = close (not p) a11 x22 = close (not p) a22 -mkTree :: RingP a => [Pair a] -> SomeTri a +mkTree :: RingP a => [Pair a] -> SomeTri a mkTree xs = case mkShape (length xs) of S s -> T s (close True $ mkUpDiag xs s) @@ -161,7 +161,7 @@ mergein :: RingP a => Bool -> SomeTri a -> Pair a -> SomeTri a -> SomeTri a mergein p (T y a) c (T x b) = T (bin' y x) (quad' a (closeDisjointP p (leftOf a) c' (rightOf b)) zero b) where c' = mkSing x y c- + -- | A variant of zipWith on vectors zw :: (AbelianGroup a, AbelianGroup b) => (a -> b -> c) -> Vec y a -> Vec y b -> Vec y c zw f Z Z = Z@@ -176,7 +176,7 @@ lk :: AbelianGroup a => Int -> Shape' x -> Vec x a -> a lk n _ Z = zero lk 0 Leaf' (O x) = x-lk i (Bin' _ s s') (x :! x') +lk i (Bin' _ s s') (x :! x') | i < sz' s = lk i s x | otherwise = lk (i - sz' s) s' x' @@ -190,7 +190,7 @@ -- | Contents of a vector contents :: Shape' x -> Vec x a -> [(Int,a)]-contents s Z = [] +contents s Z = [] contents s (O a) = [(0,a)] contents (Bin' _ s s') (xs :! xs') = contents s xs ++ map (first (+sz' s)) (contents s' xs') @@ -204,11 +204,11 @@ data Path :: Shape -> * where Here :: Path Leaf- Low :: Path s -> Path (Bin s s') - High :: Path s -> Path (Bin s' s) + Low :: Path s -> Path (Bin s s')+ High :: Path s -> Path (Bin s' s) (<||>) :: Maybe (a,Path x) -> Maybe (a,Path x') -> Maybe (a,Path (Bin x x'))-x <||> y = (second High <$> y) <|> (second Low <$> x) +x <||> y = (second High <$> y) <|> (second Low <$> x) -- | What is, and where is the rightmost non-zero element on a given -- line of the matrix?@@ -242,9 +242,9 @@ fromPath :: Shape' y -> Path y -> Int fromPath _ Here = 0 fromPath (Bin' _ s s') (Low x) = fromPath s x-fromPath (Bin' _ s s') (High x) = sz' s + fromPath s' x +fromPath (Bin' _ s s') (High x) = sz' s + fromPath s' x - + root' :: AbelianGroup a => Mat x y a -> a root' Zero = zero root' (One x) = x@@ -258,16 +258,16 @@ square2 x = T (bin' Leaf' Leaf') $ quad' zero (one <$> x) zero zero -square3 p x y = T (bin' (bin' Leaf' Leaf') (Leaf')) +square3 p x y = T (bin' (bin' Leaf' Leaf') (Leaf')) (quad' (quad' zero (one <$> x) zero zero) (Col <$> (one <$> mul p (leftOf x) (rightOf y)) <*> (one <$> y)) zero zero)- + sz' :: Shape' s -> Int sz' Leaf' = 1 sz' (Bin' x l r) = x -- sz' l + sz' r -(|+|) = zipWith (++) +(|+|) = zipWith (++) (-+-) = (++) -- TODO: reimplement using lin'@@ -278,9 +278,22 @@ lin Leaf' (Bin' _ y y') (Col a b) = lin Leaf' y a -+- lin Leaf' y' b lin (Bin' _ x x') Leaf' (Row a b) = (lin x Leaf' a) |+| (lin x' Leaf' b) +sparse :: AbelianGroup a => Shape' x -> Shape' y -> Mat x y a -> [(Int,Int,a)]+sparse x y Zero = []+sparse _ _ (One x) = [(0,0,x)]+sparse (Bin' _ x x') (Bin' _ y y') (Quad a b c d) = sparse x y a ++ shiftX x (sparse x' y b) ++ shiftY y (sparse x y' c) ++ shiftX x (shiftY y(sparse x' y' d))+sparse Leaf' (Bin' _ y y') (Col a b) = sparse Leaf' y a ++ shiftY y (sparse Leaf' y' b)+sparse (Bin' _ x x') Leaf' (Row a b) = sparse x Leaf' a ++ shiftX x (sparse x' Leaf' b)++shiftX x0 as = [(x+sz' x0,y,a) | (x,y,a) <- as]+shiftY y0 as = [(x,y+sz' y0,a) | (x,y,a) <- as]+ fingerprint (T s (m :/: m')) = zipWith (zipWith c) (lin s s m) (lin s s m') where c x y = case (isZero x,isZero y) of (True , True) -> ' ' (True , False) -> '>' (False , True) -> '<' (False , False) -> 'X'++scatterplot (T s (m :/: m')) = concat [show x ++ " " ++ show y ++ "\n" | (x,y,_) <- sparse s s m ++ sparse s s m']+
runtime/Parsing/Chart.hs view
@@ -29,20 +29,20 @@ alts = cycle alt -}- + -- mkTree2 :: (AbelianGroupZ (c a), RingP a, IsChart c) => Bool -> [Pair a] -> c a mkTree2 :: RingP a => Bool -> [Pair a] -> Q.Q a mkTree2 p [] = error "can't parse the empty string, sorry" mkTree2 p [x] = Q.square2 x-mkTree2 p [x,y] = Q.square3 p x y +mkTree2 p [x,y] = Q.square3 p x y mkTree2 p leaves = Q.mergein p (mkTree2 False xs) y (mkTree2 True zs) where (xs,y:zs) = splitAt n2 leaves- n2 = length leaves `div` 2 + n2 = length leaves `div` 2 -- mkTree :: (RingP a, IsChart c) => [Pair a] -> c a-mkTree = mkTree2 False -- mkTreeHelp [False,True] -mkTree' = mkTree2 True -- mkTreeHelp [True,False] +mkTree = mkTree2 False -- mkTreeHelp [False,True]+mkTree' = mkTree2 True -- mkTreeHelp [True,False] type Set a = [a]@@ -65,12 +65,12 @@ "< c blue", "> c red", " c black"- ] ++ + ] ++ xs where width = length h height = length xs -root = Q.root +root = Q.root mergein a c b = Q.mergein a c b single x = Q.single x
runtime/Parsing/TestProgram.hs view
@@ -18,55 +18,59 @@ putStrV v s = if v > 1 then putStrLn s else return () -mainTest :: forall category token. +mainTest :: forall category token. (RingP [(category,Any)], Eq category) => ((category,Any) -> String) -> (Bool -> token -> Pair [(category,Any)]) -> (String -> [token]) ->- (token -> (Int,Int)) -> - (category -> String) -> + (token -> (Int,Int)) ->+ (category -> String) -> (category -> [category]) -> IO ()-mainTest showAst cnfToksToCat myLLexer getTokPos describe follows = +mainTest showAst cnfToksToCat myLLexer getTokPos describe follows = do args <- getArgs case args of- [] -> hGetContents stdin >>= run 2+ [] -> hGetContents stdin >>= run "stdin" 2 "-s":fs -> mapM_ (runFile 0) fs fs -> mapM_ (runFile 2) fs- - where ++ where neighbors a b = b `elem` follows a showResults :: [(category,Any)] -> IO () showResults x = do putStrLn $ show (length x) ++ " results" forM_ x $ \(cat,ast) -> do- putStrLn $ describe cat + putStrLn $ describe cat putStrLn $ showAst (cat,ast)- - runFile v f = putStrLn f >> readFile f >>= run v- run v s = ++ runFile v f = putStrLn f >> readFile f >>= run f v+ run f v s = do case rs of [(_,x,_)] -> showResults x _ -> do let errs = pairs rs- best = minimum $ map quality errs + best = minimum $ map quality errs mapM_ (putStrLn . showErr ts) $ filter (\x -> quality x == best) errs- writeFile "cnf.xpm" (genXPM $ fingerprint chart)+ when (v >= 2) $ do+ writeFile (f ++ ".xpm") (genXPM $ fingerprint chart)+ let scatt = scatterplot chart+ putStrLn $ "Scatterplot data size:" ++ show (length scatt)+ writeFile (f ++ ".data") scatt where ts = myLLexer s- chart = mkTree $ zipWith cnfToksToCat (cycle [False,True]) ts + chart = mkTree $ zipWith cnfToksToCat (cycle [False,True]) ts rs = results chart- + showTokPos :: (Int,Int) -> String showTokPos (l,c) = show l ++ "," ++ show (c-1) showPos :: [token] -> Int -> String showPos ts x = showTokPos (getTokPos $ ts !! x)- - showErr ts ((_,x',p),(_,y',_)) = ++ showErr ts ((_,x',p),(_,y',_)) = showPos ts p ++ ": cannot combine " ++ showBestCat x' ++ " with " ++ showBestCat y' quality (a@(_,x',p),b@(_,y',_)) = (or [ neighbors x y | x <- map fst x', y <- map fst y'], (resSz a) Prelude.+ (resSz b))- + showBestCat ((x,_):_) = describe x
+ src/BNFC/Backend/Base.hs view
@@ -0,0 +1,73 @@+{- Backend base function. Defines the type of the backend and some usefull+ - functions -}+module BNFC.Backend.Base+ ( Backend+ , MkFiles+ , execBackend+ , mkfile+ , liftIO+ , writeFiles+ ) where++import BNFC.Options hiding (Backend)+import BNFC.CF (CF)+import BNFC.Utils (writeFileRep)+import Control.Monad.Writer+import Control.Monad.Trans+import System.Directory (doesDirectoryExist, createDirectoryIfMissing)+import System.FilePath (dropFileName)+++-- import Control.Monad (liftM, when,unless)+-- import Control.Monad.State+-- import Control.Monad.Trans (lift)+-- import Data.Char+-- import Data.List (elemIndex, foldl', sort, intercalate)+-- import Data.Maybe (catMaybes, listToMaybe)+-- import Data.Version ( showVersion )+-- import ErrM+-- import Paths_BNFC ( version )+-- import System.Console.GetOpt+-- import System.FilePath (takeBaseName, takeFileName)+-- import System.IO (stderr, hPutStrLn,hPutStr)+-- import Text.Printf (printf)+--+-- | Define the type of the backend functions+-- For more purity, instead of having each backend writing the generated files to+-- disk, they return a list of pairs containing the (relative) file path and+-- the file content. This allow for 1) easier testing, 2) implement common options+-- like changing the output dir or providing a diff instead of overwritting the+-- files on a highter level and 3) more purity.+--+-- The writer monad provide a more conveignent api to generate the list. Note that we+-- still use the IO monad for now because some backend insist on printing stuff+-- to the screen while generating the files.+type MkFiles a = WriterT [(FilePath, String)] IO a+type Backend = MkFiles ()+++-- | Named after execWriter, this function execute the given backend+-- and returns the generated file paths and contents.+execBackend :: MkFiles () -> IO [(FilePath, String)]+execBackend = execWriterT++-- | A specialized version of tell that adds a file and its content to the+-- list of generated files+mkfile :: FilePath -> String -> MkFiles ()+mkfile path content = tell [(path,content)]++-- | Write a set of files to disk. the first argument is the root directory inside+-- which all the generated files will be written. This root directory+-- should already exits. Sub-directory will be created as needed (ex: if the+-- files contains a a/b/file.txt, `writeFiles` will create+-- the directories `$ROOT/a` and `$ROOT/a/b`)+writeFiles :: FilePath -> MkFiles () -> IO ()+writeFiles root fw = do+ -- First we check that the directory exists+ fb <- execBackend fw+ doesDirectoryExist root >>= flip unless (fail $ root ++ " does not exists")+ mapM_ (uncurry writeFile') fb+ where writeFile' :: FilePath -> String -> IO ()+ writeFile' path content =+ createDirectoryIfMissing True (dropFileName path)+ >> writeFileRep path content
+ src/BNFC/Backend/C.hs view
@@ -0,0 +1,201 @@+{-+ BNF Converter: C Main file+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+module BNFC.Backend.C (makeC) where++import BNFC.Utils+import Control.Monad (unless,when)+import System.Console.GetOpt+import BNFC.CF+import BNFC.Options+import BNFC.Backend.Base+import BNFC.Backend.C.CFtoCAbs+import BNFC.Backend.C.CFtoFlexC+import BNFC.Backend.C.CFtoBisonC+import BNFC.Backend.C.CFtoCSkel+import BNFC.Backend.C.CFtoCPrinter+import Data.Char+import System.Exit (exitFailure)+import qualified BNFC.Backend.Common.Makefile as Makefile++makeC :: SharedOptions -> CF -> MkFiles ()+makeC opts cf = do+ let (hfile, cfile) = cf2CAbs prefix cf+ mkfile "Absyn.h" hfile+ mkfile "Absyn.c" cfile+ let (flex, env) = cf2flex prefix cf+ mkfile (name ++ ".l") flex+ let bison = cf2Bison prefix cf env+ mkfile (name ++ ".y") bison+ let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env+ mkfile "Parser.h" header+ let (skelH, skelC) = cf2CSkel cf+ mkfile "Skeleton.h" skelH+ mkfile "Skeleton.c" skelC+ let (prinH, prinC) = cf2CPrinter cf+ mkfile "Printer.h" prinH+ mkfile "Printer.c" prinC+ mkfile "Test.c" (ctest cf)+ Makefile.mkMakefile opts (makefile name prefix)+ where prefix :: String -- The prefix is a string used by flex and bison+ -- that is prepended to generated function names.+ -- In most cases we want the grammar name as the prefix+ -- but in a few specific cases, this can create clashes+ -- with existing functions+ prefix = if name `elem` ["m","c","re","std","str"]+ then name ++ "_" else name+ name = lang opts+++makefile :: String -> String -> String+makefile name prefix =+ (++) (unlines [ "CC = gcc",+ "CCFLAGS = -g -W -Wall", "",+ "FLEX = flex",+ "FLEX_OPTS = -P" ++ prefix, "",+ "BISON = bison",+ "BISON_OPTS = -t -p" ++ prefix, ""])+ $ Makefile.mkRule ".PHONY" ["clean", "distclean"]+ []+ $ Makefile.mkRule "all" [testName]+ []+ $ Makefile.mkRule "clean" []+ -- peteg: don't nuke what we generated - move that to the "vclean" target.+ [ "rm -f *.o " ++ unwords [ name ++ e | e <- [".aux",".log",".pdf",""]] ]+ $ Makefile.mkRule "distclean" ["clean"] -- FIXME+ [ "rm -f " ++ unwords+ [ "Absyn.c", "Absyn.h", "Test.c", "Parser.c", "Parser.h", "Lexer.c"+ , "Skeleton.c", "Skeleton.h", "Printer.c" ,"Printer.h"+ , name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex "+ , testName, "Makefile" ]]+ $ Makefile.mkRule testName ["Absyn.o", "Lexer.o", "Parser.o", "Printer.o", "Test.o"]+ [ "@echo \"Linking test" ++ name ++ "...\""+ , "${CC} ${CCFLAGS} *.o -o Test" ++ name ]+ $ Makefile.mkRule "Absyn.o" [ "Absyn.c", "Absyn.h"]+ [ "${CC} ${CCFLAGS} -c Absyn.c" ]+ $ Makefile.mkRule "Lexer.c" [ name ++ ".l" ]+ [ "${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l" ]+ $ Makefile.mkRule "Parser.c" [ name ++ ".y" ]+ [ "${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c" ]+ $ Makefile.mkRule "Lexer.o" [ "Lexer.c", "Parser.h" ]+ [ "${CC} ${CCFLAGS} -c Lexer.c " ]+ $ Makefile.mkRule "Parser.o" ["Parser.c", "Absyn.h" ]+ [ "${CC} ${CCFLAGS} -c Parser.c" ]+ $ Makefile.mkRule "Printer.o" [ "Printer.c", "Printer.h", "Absyn.h" ]+ [ "${CC} ${CCFLAGS} -c Printer.c" ]+ $ Makefile.mkRule "Test.o" [ "Test.c", "Parser.h", "Printer.h", "Absyn.h" ]+ [ "${CC} ${CCFLAGS} -c Test.c" ]+ ""+ where testName = "Test" ++ name++ctest :: CF -> String+ctest cf =+ unlines+ [+ "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",+ "/* */",+ "/* This test will parse a file, print the abstract syntax tree, and then */",+ "/* pretty-print the result. */",+ "/* */",+ "/****************************************************************************/",+ "",+ "#include <stdio.h>",+ "#include <stdlib.h>",+ "",+ "#include \"Parser.h\"",+ "#include \"Printer.h\"",+ "#include \"Absyn.h\"",+ "",+ "int main(int argc, char ** argv)",+ "{",+ " FILE *input;",+ " " ++ def ++ " parse_tree;",+ " if (argc > 1) ",+ " {",+ " input = fopen(argv[1], \"r\");",+ " if (!input)",+ " {",+ " fprintf(stderr, \"Error opening input file.\\n\");",+ " exit(1);",+ " }",+ " }",+ " else input = stdin;",+ " /* The default entry point is used. For other options see Parser.h */",+ " parse_tree = p" ++ def ++ "(input);",+ " if (parse_tree)",+ " {",+ " printf(\"\\nParse Succesful!\\n\");",+ " printf(\"\\n[Abstract Syntax]\\n\");",+ " printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));",+ " printf(\"[Linearized Tree]\\n\");",+ " printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));",+ " return 0;",+ " }",+ " return 1;",+ "}",+ ""+ ]+ where+ def = show $ head (allEntryPoints cf)++mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String+mkHeaderFile cf cats eps env = unlines+ [+ "#ifndef PARSER_HEADER_FILE",+ "#define PARSER_HEADER_FILE",+ "",+ "#include \"Absyn.h\"",+ "",+ "typedef union",+ "{",+ " int int_;",+ " char char_;",+ " double double_;",+ " char* string_;",+ (concatMap mkVar cats) ++ "} YYSTYPE;",+ "",+ "#define _ERROR_ 258",+ mkDefines (259::Int) env,+ "extern YYSTYPE yylval;",+ concatMap mkFunc eps,+ "",+ "#endif"+ ]+ where+ mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n"+ mkVar _ = ""+ mkDefines n [] = mkString n+ mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)+ mkString n = if isUsedCat cf catString+ then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)+ else mkChar n+ mkChar n = if isUsedCat cf catChar+ then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)+ else mkInteger n+ mkInteger n = if isUsedCat cf catInteger+ then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)+ else mkDouble n+ mkDouble n = if isUsedCat cf catDouble+ then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)+ else mkIdent n+ mkIdent n = if isUsedCat cf catIdent+ then ("#define _IDENT_ " ++ show n ++ "\n")+ else ""+ mkFunc s | normCat s == s = identCat s ++ " p" ++ identCat s ++ "(FILE *inp);\n"+ mkFunc _ = ""+
+ src/BNFC/Backend/C/CFtoBisonC.hs view
@@ -0,0 +1,276 @@+{-+ BNF Converter: C Bison generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Bison input file.+ Note that because of the way bison stores results+ the programmer can increase performance by limiting+ the number of entry points in their grammar.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 6 August, 2003++ Modified : 6 August, 2003+++ **************************************************************+-}+++module BNFC.Backend.C.CFtoBisonC (cf2Bison) where++import BNFC.CF+import Data.List (intersperse, isPrefixOf)+import BNFC.Backend.Common.NamedVariables hiding (varName)+import Data.Char (toLower)+import BNFC.Utils ((+++), (++++))++--This follows the basic structure of CFtoHappy.++-- Type declarations+type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++--The environment comes from the CFtoFlex+cf2Bison :: String -> CF -> SymEnv -> String+cf2Bison name cf env+ = unlines+ [header name cf,+ union (allCats cf),+ "%token _ERROR_",+ tokens user env,+ declarations cf,+ specialToks cf,+ "%%",+ prRules (rulesForBison cf env)+ ]+ where+ user = fst (unzip (tokenPragmas cf))++header :: String -> CF -> String+header name cf = unlines+ ["/* This Bison file was machine-generated by BNFC */",+ "%{",+ "#include <stdlib.h>",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include \"Absyn.h\"",+ "#define initialize_lexer " ++ name ++ "_initialize_lexer",+ "extern int yyparse(void);",+ "extern int yylex(void);",+ "extern int initialize_lexer(FILE * inp);",+ "void yyerror(const char *str)",+ "{",+ " fprintf(stderr,\"error: %s\\n\",str);",+ "}",+ "",+ -- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug.+ unlines $ map (parseMethod name) (allCatsNorm cf), -- (allEntryPoints cf),+ concatMap reverseList (filter isList (allCats cf)),+ "%}"+ ]++--This generates a parser method for each entry point.+parseMethod :: String -> Cat -> String+parseMethod name cat =+-- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm+-- then ""+-- else+ unlines+ [+ cat' +++ (resultName cat') +++ "= 0;",+ cat' ++ " p" ++ cat' ++ "(FILE *inp)",+ "{",+ " initialize_lexer(inp);",+ " if (yyparse())",+ " { /* Failure */",+ " return 0;",+ " }",+ " else",+ " { /* Success */",+ " return" +++ (resultName cat') ++ ";",+ " }",+ "}"+ ]+ where+ cat' = identCat (normCat cat)++--This method generates list reversal functions for each list type.+reverseList :: Cat -> String+reverseList c = unlines+ [+ c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)",+ "{",+ " " ++ c' +++"prev = 0;",+ " " ++ c' +++"tmp = 0;",+ " while (l)",+ " {",+ " tmp = l->" ++ v ++ ";",+ " l->" ++ v +++ "= prev;",+ " prev = l;",+ " l = tmp;",+ " }",+ " return prev;",+ "}"+ ]+ where+ c' = identCat (normCat c)+ v = (map toLower c') ++ "_"++--The union declaration is special to Bison/Yacc and gives the type of yylval.+--For efficiency, we may want to only include used categories here.+union :: [Cat] -> String+union cats = unlines+ [+ "%union",+ "{",+ " int int_;",+ " char char_;",+ " double double_;",+ " char* string_;",+ concatMap mkPointer cats,+ "}"+ ]+ where --This is a little weird because people can make [Exp2] etc.+ mkPointer s | identCat s /= show s = --list. add it even if it refers to a coercion.+ " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n"+ mkPointer s | normCat s == s = --normal cat+ " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n"+ mkPointer s = ""++--declares non-terminal types.+declarations :: CF -> String+declarations cf = concatMap (typeNT cf) (allCats cf)+ where --don't define internal rules+ typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n"+ typeNT cf nt = ""++--declares terminal types.+tokens :: [UserDef] -> SymEnv -> String+tokens user ts = concatMap (declTok user) ts+ where+ declTok u (s,r) = if elem s (map show u)+ then "%token<string_> " ++ r ++ " /* " ++ s ++ " */\n"+ else "%token " ++ r ++ " /* " ++ s ++ " */\n"++specialToks :: CF -> String+specialToks cf = concat [+ ifC catString "%token<string_> _STRING_\n",+ ifC catChar "%token<char_> _CHAR_\n",+ ifC catInteger "%token<int_> _INTEGER_\n",+ ifC catDouble "%token<double_> _DOUBLE_\n",+ ifC catIdent "%token<string_> _IDENT_\n"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""++--The following functions are a (relatively) straightforward translation+--of the ones in CFtoHappy.hs+rulesForBison :: CF -> SymEnv -> Rules+rulesForBison cf env = map mkOne $ ruleGroups cf where+ mkOne (cat,rules) = constructRule cf env rules cat++-- For every non-terminal, we construct a set of rules.+constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule cf env rules nt = (nt,[(p,(generateAction (identCat (normCat nt)) (ruleName r) b m) +++ result) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf env r])+ where+ ruleName r = case funRule r of+ "(:)" -> identCat nt+ z -> z+ revs = reversibleCats cf+ eps = allEntryPoints cf+ isEntry nt = if elem nt eps then True else False+ result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""++-- Generates a string containing the semantic action.+generateAction :: String -> Fun -> Bool -> [MetaVar] -> Action+generateAction nt f b ms =+ if isCoercion f+ then (unwords ms) ++ ";"+ else if isNilFun f+ then "0;"+ else if isOneFun f+ then concat ["make_", nt, "(", (concat (intersperse ", " ms')), ", 0);"]+ else concat ["make_", normFun f, "(", (concat (intersperse ", " ms')), ");"]+ where+ ms' = if b then reverse ms else ms++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal+generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns cf env r = case rhsRule r of+ [] -> ("/* empty */",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> case lookup (show c) env of+ Just x -> x+ Nothing -> typeName (identCat c)+ Right s -> case lookup s env of+ Just x -> x+ Nothing -> s+ metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]+ revIf c m = if (not (isConsFun (funRule r)) && elem c revs)+ then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")+ else m -- no reversal in the left-recursive Cons rule itself+ revs = reversibleCats cf++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.++prRules :: Rules -> String+prRules [] = []+prRules ((nt, []):rs) = prRules rs --internal rule+prRules ((nt,((p,a):ls)):rs) =+ (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls++--Some helper functions.+resultName :: String -> String+resultName s = "YY_RESULT_" ++ s ++ "_"++-- | slightly stronger than the NamedVariable version.+-- >>> varName (Cat "Abc")+-- "abc_"+varName :: Cat -> String+varName = (++ "_") . map toLower . identCat . normCat++typeName :: String -> String+typeName "Ident" = "_IDENT_"+typeName "String" = "_STRING_"+typeName "Char" = "_CHAR_"+typeName "Integer" = "_INTEGER_"+typeName "Double" = "_DOUBLE_"+typeName x = x
+ src/BNFC/Backend/C/CFtoCAbs.hs view
@@ -0,0 +1,320 @@+{-+ BNF Converter: C Abstract syntax+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C Abstract Syntax+ tree classes. It generates both a Header file+ and an Implementation file, and Appel's C+ method.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 15 September, 2003++ Modified : 15 September, 2003+++ **************************************************************+-}++module BNFC.Backend.C.CFtoCAbs (cf2CAbs) where++import BNFC.CF+import BNFC.Utils((+++),(++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower)+++--The result is two files (.H file, .C file)+cf2CAbs :: String -> CF -> (String, String)+cf2CAbs name cf = (mkHFile cf, mkCFile cf)+++{- **** Header (.H) File Functions **** -}++--Makes the Header file.+mkHFile :: CF -> String+mkHFile cf = unlines+ [+ "#ifndef ABSYN_HEADER",+ "#define ABSYN_HEADER",+ "",+ header,+ prTypeDefs user,+ "/******************** Forward Declarations ********************/\n",+ concatMap prForward classes,+ "",+ "/******************** Abstract Syntax Classes ********************/\n",+ concatMap (prDataH user) (cf2dataLists cf),+ "",+ "#endif"+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/\n"+ rules = getRules cf+ classes = nub (rules ++ getClasses (allCats cf))+ prForward s | not (isCoercion s) = unlines+ [+ "struct " ++ s ++ "_;",+ "typedef struct " ++ s ++ "_ *" ++ s ++ ";"+ ]+ prForward s = ""+ getRules cf = (map testRule (rulesOfCF cf))+ getClasses = map show . filter (\c -> identCat (normCat c) == show c)+ testRule (Rule f c r) =+ if isList c+ then if isConsFun f+ then identCat (normCat c)+ else "_" --ignore this+ else "_"++--Prints struct definitions for all categories.+prDataH :: [UserDef] -> Data -> String+prDataH user (cat, rules) =+ if isList cat+ then unlines+ [+ "struct " ++ c' ++ "_",+ "{",+ " " ++ mem +++ (varName mem) ++ ";",+ " " ++ c' +++ (varName c') ++ ";",+ "};",+ "",+ c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);"+ ]+ else unlines+ [+ "struct " ++ show cat ++ "_",+ "{",+ " enum { " ++ (concat (intersperse ", " (map prKind rules))) ++ " } kind;",+ " union",+ " {",+ concatMap (prUnion user) rules ++ " } u;",+ "};",+ "",+ concatMap (prRuleH user cat) rules+ ]+ where+ c' = identCat (normCat cat)+ mem = identCat (normCatOfList cat)+ prKind (fun, cats) = "is_" ++ normFun fun+ prMember user (fun, []) = ""+ prMember user (fun, cats) = " " ++ (prInstVars user (getVars cats))+ prUnion user (fun, []) = ""+ prUnion user (fun, cats) = " struct { " ++ (prInstVars user (getVars cats)) ++ " } " ++ (memName fun) ++ ";\n"+++--Interface definitions for rules vary on the type of rule.+prRuleH :: [UserDef] -> Cat -> (Fun, [Cat]) -> String+prRuleH user c (fun, cats) =+ if isNilFun fun || isOneFun fun || isConsFun fun+ then "" --these are not represented in the AbSyn+ else --a standard rule+ show c ++ " make_" ++ fun' ++ "(" ++ (prParamsH 0 (getVars cats)) ++ ");\n"+ where+ fun' = normFun fun+ prParamsH :: Int -> [(String, a)] -> String+ prParamsH _ [] = ""+ prParamsH n ((t,_):[]) = t ++ " p" ++ (show n)+ prParamsH n ((t,_):vs) = (t ++ " p" ++ (show n) ++ ", ") ++ (prParamsH (n+1) vs)++--typedefs in the Header make generation much nicer.+prTypeDefs user = unlines+ [+ "/******************** TypeDef Section ********************/",+ "typedef int Integer;",+ "typedef char Char;",+ "typedef double Double;",+ "typedef char* String;",+ "typedef char* Ident;",+ concatMap prUserDef user+ ]+ where+ prUserDef s = "typedef char* " ++ show s ++ ";\n"++--A class's instance variables.+prInstVars :: [UserDef] -> [IVar] -> String+prInstVars _ [] = []+prInstVars user vars@((t,n):[]) =+ t +++ uniques+ where+ (uniques, vs') = prUniques t vars+prInstVars user vars@((t,n):vs) =+ t +++ uniques +++ (prInstVars user vs')+ where+ (uniques, vs') = prUniques t vars++--these functions group the types together nicely+prUniques :: String -> [IVar] -> (String, [IVar])+prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs)+ where+ remType :: String -> [IVar] -> [IVar]+ remType _ [] = []+ remType t ((t2,n):ts) = if t == t2+ then (remType t ts)+ else (t2,n) : (remType t ts)+ prVars (x:[]) vs = case vs !! x of+ (t,n) -> (varName t) ++ (showNum n) ++ ";"+ prVars (x:xs) vs = case vs !! x of+ (t,n) -> (varName t) ++ (showNum n) ++ ", " +++ (prVars xs vs)+++{- **** Implementation (.C) File Functions **** -}++--Makes the .C file+mkCFile :: CF -> String+mkCFile cf = unlines+ [+ header,+ concatMap (prDataC user) (cf2dataLists cf)+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines+ [+ "/* C Abstract Syntax Implementation generated by the BNF Converter. */",+ "",+ "#include <stdio.h>",+ "#include <stdlib.h>",+ "#include \"Absyn.h\"",+ ""+ ]++--This is not represented in the implementation.+--This is not represented in the implementation.+prDataC :: [UserDef] -> Data -> String+prDataC user (cat, rules) = concatMap (prRuleC user cat) rules++--Classes for rules vary based on the type of rule.+prRuleC user c (fun, cats) =+ if isNilFun fun || isOneFun fun+ then "" --these are not represented in the AbSyn+ else if isConsFun fun+ then --this is the linked list case.+ unlines+ [+ "/******************** " ++ c' ++ " ********************/",+ prListFuncs user c',+ ""+ ]+ else --a standard rule+ unlines+ [+ "/******************** " ++ fun' ++ " ********************/",+ prConstructorC user c fun' vs cats,+ ""+ ]+ where+ vs = getVars cats+ fun' = normFun fun+ c' = identCat (normCat c)++--These are all built-in list functions.+--Later we could include things like lookup,insert,delete,etc.+prListFuncs :: [UserDef] -> String -> String+prListFuncs user c = unlines+ [+ c ++ " make_" ++ c ++"(" ++ m ++ " p1" ++ ", " ++ c ++ " p2)",+ "{",+ " " ++ c ++ " tmp = (" ++ c ++ ") malloc(sizeof(*tmp));",+ " if (!tmp)",+ " {",+ " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");",+ " exit(1);",+ " }",+ " tmp->" ++ m' ++ " = " ++ "p1;",+ " tmp->" ++ v ++ " = " ++ "p2;",+ " return tmp;",+ "}"+ ]+ where+ v = (map toLower c) ++ "_"+ m = drop 4 c+ m' = drop 4 v++--The constructor just assigns the parameters to the corresponding instance variables.+prConstructorC :: [UserDef] -> Cat -> String -> [IVar] -> [Cat] -> String+prConstructorC user cat c vs cats =+ unlines+ [+ cat' ++ " make_" ++ c ++"(" ++ (interleave types params) ++ ")",+ "{",+ " " ++ cat' ++ " tmp = (" ++ cat' ++ ") malloc(sizeof(*tmp));",+ " if (!tmp)",+ " {",+ " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");",+ " exit(1);",+ " }",+ " tmp->kind = is_" ++ c ++ ";",+ prAssigns c vs params,+ " return tmp;",+ "}"+ ]+ where+ cat' = identCat (normCat cat)+ (types, params) = unzip (prParams cats (length cats) ((length cats)+1))+ interleave _ [] = []+ interleave (x:[]) (y:[]) = x +++ y+ interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys)++--Prints the constructor's parameters.+prParams :: [Cat] -> Int -> Int -> [(String,String)]+prParams [] _ _ = []+prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n)))+ : (prParams cs (n-1) m)++--Prints the assignments of parameters to instance variables.+--This algorithm peeks ahead in the list so we don't use map or fold+prAssigns :: String -> [IVar] -> [String] -> String+prAssigns _ [] _ = []+prAssigns _ _ [] = []+prAssigns c ((t,n):vs) (p:ps) =+ if n == 1 then+ case findIndices (\x -> case x of (l,r) -> l == t) vs of+ [] -> " tmp->u." ++ c' ++ "_." ++ (varName t) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps)+ z -> " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps)+ else " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps)+ where+ c' = map toLower c++{- **** Helper Functions **** -}++--Checks if something is a basic or user-defined type.+isBasic :: [UserDef] -> Cat -> Bool+isBasic user x =+ if elem x user+ then True+ else case x of+ Cat "Integer" -> True+ Cat "Char" -> True+ Cat "String" -> True+ Cat "Double" -> True+ Cat "Ident" -> True+ _ -> False++memName s = (map toLower s) ++ "_"
+ src/BNFC/Backend/C/CFtoCPrinter.hs view
@@ -0,0 +1,644 @@+{-+ BNF Converter: C Pretty Printer printer+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C Pretty Printer.+ It also generates the "show" method for+ printing an abstract syntax tree.++ The generated files use the Visitor design pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 10 August, 2003++ Modified : 3 September, 2003+ * Added resizable buffers++ **************************************************************+-}++module BNFC.Backend.C.CFtoCPrinter (cf2CPrinter) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.Common.StrUtils (renderCharOrString)+import Data.List+import Data.Char(toLower, toUpper)++--Produces (.h file, .c file)+cf2CPrinter :: CF -> (String, String)+cf2CPrinter cf = (mkHFile cf groups, mkCFile cf groups)+ where+ groups = fixCoercions (ruleGroupsInternals cf)++{- **** Header (.h) File Methods **** -}++--An extremely large function to make the Header File+mkHFile :: CF -> [(Cat,[Rule])] -> String+mkHFile cf groups = unlines+ [+ header,+ concatMap prPrints eps,+ concatMap prPrintDataH groups,+ concatMap prShows eps,+ concatMap prShowDataH groups,+ footer+ ]+ where+ eps = allEntryPoints cf+ prPrints s | normCat s == s = "char* print" ++ s' ++ "(" ++ s' ++ " p);\n"+ where+ s' = identCat s+ prPrints _ = ""+ prShows s | normCat s == s = "char* show" ++ s' ++ "(" ++ s' ++ " p);\n"+ where+ s' = identCat s+ prShows _ = ""+ header = unlines+ [+ "#ifndef PRINTER_HEADER",+ "#define PRINTER_HEADER",+ "",+ "#include \"Absyn.h\"",+ "",+ "/* Certain applications may improve performance by changing the buffer size */",+ "#define BUFFER_INITIAL 2000",+ "/* You may wish to change _L_PAREN or _R_PAREN */",+ "#define _L_PAREN '('",+ "#define _R_PAREN ')'",+ "",+ "/* The following are simple heuristics for rendering terminals */",+ "/* You may wish to change them */",+ "void renderCC(Char c);",+ "void renderCS(String s);",+ "void indent(void);",+ "void backup(void);",+ ""+ ]+ footer = unlines $+ ["void pp" ++ t ++ "(String s, int i);" | t <- tokenNames cf]+ +++ ["void sh" ++ t ++ "(String s);" | t <- tokenNames cf]+ +++ [+ "void ppInteger(Integer n, int i);",+ "void ppDouble(Double d, int i);",+ "void ppChar(Char c, int i);",+ "void ppString(String s, int i);",+ "void ppIdent(String s, int i);",+ "void shInteger(Integer n);",+ "void shDouble(Double d);",+ "void shChar(Char c);",+ "void shString(String s);",+ "void shIdent(String s);",+ "void bufAppendS(const char* s);",+ "void bufAppendC(const char c);",+ "void bufReset(void);",+ "void resizeBuffer(void);",+ "",+ "#endif"+ ]++--Prints all the required method names and their parameters.+prPrintDataH :: (Cat, [Rule]) -> String+prPrintDataH (cat, rules) = concat ["void pp", cl, "(", cl, " p, int i);\n"]+ where+ cl = identCat (normCat cat)++--Prints all the required method names and their parameters.+prShowDataH :: (Cat, [Rule]) -> String+prShowDataH (cat, rules) = concat ["void sh", cl, "(", cl, " p);\n"]+ where+ cl = identCat (normCat cat)++{- **** Implementation (.C) File Methods **** -}++--This makes the .C file by a similar method.+mkCFile :: CF -> [(Cat,[Rule])] -> String+mkCFile cf groups = concat+ [+ header,+ prRender,+ concatMap prPrintFun eps,+ concatMap prShowFun eps,+ concatMap (prPrintData user) groups,+ printBasics,+ printTokens,+ concatMap (prShowData user) groups,+ showBasics,+ showTokens,+ footer+ ]+ where+ eps = allEntryPoints cf+ user = fst (unzip (tokenPragmas cf))+ header = unlines+ [+ "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",+ "",+ "#include \"Printer.h\"",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <stdlib.h>",+ "",+ "int _n_;",+ "char* buf_;",+ "int cur_;",+ "int buf_size;",+ ""+ ]+ printBasics = unlines+ [+ "void ppInteger(Integer n, int i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%d\", n);",+ " bufAppendS(tmp);",+ "}",+ "void ppDouble(Double d, int i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%g\", d);",+ " bufAppendS(tmp);",+ "}",+ "void ppChar(Char c, int i)",+ "{",+ " bufAppendC('\\'');",+ " bufAppendC(c);",+ " bufAppendC('\\'');",+ "}",+ "void ppString(String s, int i)",+ "{",+ " bufAppendC('\\\"');",+ " bufAppendS(s);",+ " bufAppendC('\\\"');",+ "}",+ "void ppIdent(String s, int i)",+ "{",+ " renderS(s);",+ "}",+ ""+ ]+ printTokens = unlines+ [unlines [+ "void pp" ++ t ++ "(String s, int i)",+ "{",+ " renderS(s);",+ "}",+ ""+ ] | t <- tokenNames cf+ ]+ showBasics = unlines+ [+ "void shInteger(Integer i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%d\", i);",+ " bufAppendS(tmp);",+ "}",+ "void shDouble(Double d)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%g\", d);",+ " bufAppendS(tmp);",+ "}",+ "void shChar(Char c)",+ "{",+ " bufAppendC('\\'');",+ " bufAppendC(c);",+ " bufAppendC('\\'');",+ "}",+ "void shString(String s)",+ "{",+ " bufAppendC('\\\"');",+ " bufAppendS(s);",+ " bufAppendC('\\\"');",+ "}",+ "void shIdent(String s)",+ "{",+ " bufAppendC('\\\"');",+ " bufAppendS(s);",+ " bufAppendC('\\\"');",+ "}",+ ""+ ]+ showTokens = unlines+ [unlines [+ "void sh" ++ t ++ "(String s)",+ "{",+ " bufAppendC('\\\"');",+ " bufAppendS(s);",+ " bufAppendC('\\\"');",+ "}",+ ""+ ] | t <- tokenNames cf+ ]+ footer = unlines+ [+ "void bufAppendS(const char* s)",+ "{",+ " int len = strlen(s);",+ " int n;",+ " while (cur_ + len > buf_size)",+ " {",+ " buf_size *= 2; /* Double the buffer size */",+ " resizeBuffer();",+ " }",+ " for(n = 0; n < len; n++)",+ " {",+ " buf_[cur_ + n] = s[n];",+ " }",+ " cur_ += len;",+ " buf_[cur_] = 0;",+ "}",+ "void bufAppendC(const char c)",+ "{",+ " if (cur_ == buf_size)",+ " {",+ " buf_size *= 2; /* Double the buffer size */",+ " resizeBuffer();",+ " }",+ " buf_[cur_] = c;",+ " cur_++;",+ " buf_[cur_] = 0;",+ "}",+ "void bufReset(void)",+ "{",+ " cur_ = 0;",+ " buf_size = BUFFER_INITIAL;",+ " resizeBuffer();",+ " memset(buf_, 0, buf_size);",+ "}",+ "void resizeBuffer(void)",+ "{",+ " char* temp = (char*) malloc(buf_size);",+ " if (!temp)",+ " {",+ " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",+ " exit(1);",+ " }",+ " if (buf_)",+ " {",+ " strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */",+ " free(buf_);",+ " }",+ " buf_ = temp;",+ "}",+ "char *buf_;",+ "int cur_, buf_size;",+ ""+ ]+++{- **** Pretty Printer Methods **** -}++--An entry point to begin printing+prPrintFun :: Cat -> String+prPrintFun ep | normCat ep == ep = unlines+ [+ "char* print" ++ ep' ++ "(" ++ ep' ++ " p)",+ "{",+ " _n_ = 0;",+ " bufReset();",+ " pp" ++ ep' ++ "(p, 0);",+ " return buf_;",+ "}"+ ]+ where+ ep' = identCat ep+prPrintFun _ = ""++--Generates methods for the Pretty Printer+prPrintData :: [UserDef] -> (Cat, [Rule]) -> String+prPrintData user (cat, rules) =+ if isList cat+ then unlines+ [+ "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)",+ "{",+ " while(" ++ vname ++ "!= 0)",+ " {",+ " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)",+ " {",+ visitMember,+ optsep,+ " " ++ vname +++ "= 0;",+ " }",+ " else",+ " {",+ visitMember,+ " render" ++ [sc] ++ "(" ++ sep ++ ");",+ " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",+ " }",+ " }",+ "}",+ ""+ ] --Not a list:+ else unlines+ [+ "void pp" ++ cl ++ "(" ++ cl ++ " _p_, int _i_)",+ "{",+ " switch(_p_->kind)",+ " {",+ concatMap (prPrintRule user) rules,+ " default:",+ " fprintf(stderr, \"Error: bad kind field when printing " ++ show cat ++ "!\\n\");",+ " exit(1);",+ " }",+ "}\n"+ ]+ where+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl+ visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, 0);"+ (sc, sep) = renderCharOrString sep'+ sep' = getCons rules+ optsep = if hasOneFunc rules then "" else " render" ++ [sc] ++ "(" ++ sep ++ ");"++--Pretty Printer methods for a rule.+prPrintRule :: [UserDef] -> Rule -> String+prPrintRule user r@(Rule fun c cats) | not (isCoercion fun) = unlines+ [+ " case is_" ++ fun ++ ":",+ lparen,+ cats',+ rparen,+ " break;\n"+ ]+ where+ p = precRule r+ (lparen, rparen) =+ (" if (_i_ > " ++ (show p) ++ ") renderC(_L_PAREN);",+ " if (_i_ > " ++ (show p) ++ ") renderC(_R_PAREN);")+ cats' = (concatMap (prPrintCat user fun) (zip3 (fixOnes (numVars [] cats)) cats (map getPrec cats)))+ getPrec (Right s) = 0 :: Integer+ getPrec (Left c) = precCat c+prPrintRule _ _ = ""++--This goes on to recurse to the instance variables.+prPrintCat :: [UserDef] -> String -> (Either String String, Either Cat String, Integer) -> String+prPrintCat user fnm (c,o,p) = case c of+ (Right t) -> " render" ++ [sc] ++ "(" ++ t' ++ ");\n"+ where+ (sc,t') = renderCharOrString t+ (Left nt) -> if isBasic user nt+ then " pp" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n"+ else if nt == "#_" --Internal category+ then " /* Internal Category */\n"+ else " pp" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n"+ where+ v = map toLower (normFun fnm)+ o' = case o of+ Right x -> x+ Left x -> identCat (normCat x)++{- **** Abstract Syntax Tree Printer **** -}++--An entry point to begin printing+prShowFun :: Cat -> String+prShowFun ep | normCat ep == ep = unlines+ [+ "char* show" ++ ep' ++ "(" ++ ep' ++ " p)",+ "{",+ " _n_ = 0;",+ " bufReset();",+ " sh" ++ ep' ++ "(p);",+ " return buf_;",+ "}"+ ]+ where+ ep' = identCat ep+prShowFun _ = ""++--This prints the functions for Abstract Syntax tree printing.+prShowData :: [UserDef] -> (Cat, [Rule]) -> String+prShowData user (cat, rules) =+ if isList cat+ then unlines+ [+ "void sh" ++ cl ++ "("++ cl +++ vname ++ ")",+ "{",+ " while(" ++ vname ++ "!= 0)",+ " {",+ " if (" ++ vname ++ "->" ++ vname ++ "_)",+ " {",+ visitMember,+ " bufAppendS(\", \");",+ " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",+ " }",+ " else",+ " {",+ visitMember,+ " " ++ vname ++ " = 0;",+ " }",+ " }",+ "}",+ ""+ ] --Not a list:+ else unlines+ [+ "void sh" ++ cl ++ "(" ++ cl ++ " _p_)",+ "{",+ " switch(_p_->kind)",+ " {",+ concatMap (prShowRule user) rules,+ " default:",+ " fprintf(stderr, \"Error: bad kind field when showing " ++ show cat ++ "!\\n\");",+ " exit(1);",+ " }",+ "}\n"+ ]+ where+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl+ visitMember = " sh" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);"++--Pretty Printer methods for a rule.+prShowRule :: [UserDef] -> Rule -> String+prShowRule user r@(Rule fun c cats) | not (isCoercion fun) = unlines+ [+ " case is_" ++ fun ++ ":",+ lparen,+ " bufAppendS(\"" ++ fun ++ "\");\n",+ optspace,+ cats',+ rparen,+ " break;\n"+ ]+ where+ (optspace, lparen, rparen) = if allTerms cats+ then ("","","")+ else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n")+ cats' = if allTerms cats+ then ""+ else concat (insertSpaces (map (prShowCat user fun) (zip (fixOnes (numVars [] cats)) cats)))+ insertSpaces [] = []+ insertSpaces (x:[]) = [x]+ insertSpaces (x:xs) = if x == ""+ then insertSpaces xs+ else (x : [" bufAppendC(' ');\n"]) ++ (insertSpaces xs)+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+prShowRule _ _ = ""++--This goes on to recurse to the instance variables.+prShowCat :: [UserDef] -> Fun -> (Either String String, Either Cat String) -> String+prShowCat user fnm (c,o) = case c of+ (Right t) -> ""+ (Left nt) -> if isBasic user nt+ then " sh" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"+ else if nt == "#_" --Internal category+ then " /* Internal Category */\n"+ else if ((show $ normCat $ strToCat nt) /= nt)+ then " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"+ else concat+ [+ " bufAppendC('[');\n",+ " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n",+ " bufAppendC(']');\n"+ ]+ where+ v = map toLower (normFun fnm)+ o' = case o of+ Right x -> x+ Left x -> identCat (normCat x)++{- **** Helper Functions Section **** -}+++--Just checks if something is a basic or user-defined type.+--This is because you don't -> a basic non-pointer type.+isBasic :: [UserDef] -> String -> Bool+isBasic user v =+ if elem (init v) user'+ then True+ else if "integer_" `isPrefixOf` v then True+ else if "char_" `isPrefixOf` v then True+ else if "string_" `isPrefixOf` v then True+ else if "double_" `isPrefixOf` v then True+ else if "ident_" `isPrefixOf` v then True+ else False+ where+ user' = map (map toLower . show) user++--The visit-function name of a basic type+basicFunName :: String -> String+basicFunName v =+ if "integer_" `isPrefixOf` v then "Integer"+ else if "char_" `isPrefixOf` v then "Char"+ else if "string_" `isPrefixOf` v then "String"+ else if "double_" `isPrefixOf` v then "Double"+ else if "ident_" `isPrefixOf` v then "Ident"+ else "Ident" --User-defined type++--Just sets the coercion level for parentheses in the Pretty Printer.+setI :: Int -> String+setI n = "_i_ = " ++ (show n) ++ "; "++--An extremely simple renderCer for terminals.+prRender :: String+prRender = unlines+ [+ "/* You may wish to change the renderC functions */",+ "void renderC(Char c)",+ "{",+ " if (c == '{')",+ " {",+ " bufAppendC('\\n');",+ " indent();",+ " bufAppendC(c);",+ " _n_ = _n_ + 2;",+ " bufAppendC('\\n');",+ " indent();",+ " }",+ " else if (c == '(' || c == '[')",+ " bufAppendC(c);",+ " else if (c == ')' || c == ']')",+ " {",+ " backup();",+ " bufAppendC(c);",+ " bufAppendC(' ');",+ " }",+ " else if (c == '}')",+ " {",+ " _n_ = _n_ - 2;",+ " backup();",+ " backup();",+ " bufAppendC(c);",+ " bufAppendC('\\n\');",+ " indent();",+ " }",+ " else if (c == ',')",+ " {",+ " backup();",+ " bufAppendC(c);",+ " bufAppendC(' ');",+ " }",+ " else if (c == ';')",+ " {",+ " backup();",+ " bufAppendC(c);",+ " bufAppendC('\\n');",+ " indent();",+ " }",+ " else if (c == 0) return;",+ " else",+ " {",+ " bufAppendC(c);",+ " bufAppendC(' ');",+ " }",+ "}",+ "void renderS(String s)",+ "{",+ " if(strlen(s) > 0)",+ " {",+ " bufAppendS(s);",+ " bufAppendC(' ');",+ " }",+ "}",+ "void indent(void)",+ "{",+ " int n = _n_;",+ " while (n > 0)",+ " {",+ " bufAppendC(' ');",+ " n--;",+ " }",+ "}",+ "void backup(void)",+ "{",+ " if (buf_[cur_ - 1] == ' ')",+ " {",+ " buf_[cur_ - 1] = 0;",+ " cur_--;",+ " }",+ "}"+ ]
+ src/BNFC/Backend/C/CFtoCSkel.hs view
@@ -0,0 +1,240 @@+{-+ BNF Converter: C Skeleton generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C Skeleton functions.++ The generated files follow Appel's case method.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 9 August, 2003++ Modified : 12 August, 2003+++ **************************************************************+-}++module BNFC.Backend.C.CFtoCSkel (cf2CSkel) where++import BNFC.CF+import BNFC.Utils ( (+++) )+import BNFC.Backend.Common.NamedVariables+import Data.List ( isPrefixOf )+import Data.Char ( toLower, toUpper )++--Produces (.H file, .C file)+cf2CSkel :: CF -> (String, String)+cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups)+ where+ groups = (fixCoercions (ruleGroups cf))+++{- **** Header (.H) File Functions **** -}++--Generates the Header File+mkHFile :: CF -> [(Cat,[Rule])] -> String+mkHFile cf groups = unlines+ [+ header,+ concatMap prDataH groups,+ concatMap prUserH user,+ footer+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines+ [+ "#ifndef SKELETON_HEADER",+ "#define SKELETON_HEADER",+ "/* You might want to change the above name. */",+ "",+ "#include \"Absyn.h\"",+ ""+ ]+ prUserH user = "void visit" ++ u' ++ "(" ++ show user ++ " p);"+ where+ u' = let u = show user in ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.+ footer = unlines+ [+ "void visitIdent(Ident i);",+ "void visitInteger(Integer i);",+ "void visitDouble(Double d);",+ "void visitChar(Char c);",+ "void visitString(String s);",+ "",+ "#endif"+ ]++--Prints out visit functions for a category+prDataH :: (Cat, [Rule]) -> String+prDataH (cat, _rules) =+ if isList cat+ then concat ["void visit", cl, "(", cl, " p);\n"]+ else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n"+ where cl = identCat $ normCat cat++{- **** Implementation (.C) File Functions **** -}++--Makes the .C File+mkCFile :: CF -> [(Cat,[Rule])] -> String+mkCFile cf groups = concat+ [+ header,+ concatMap (prData user) groups,+ concatMap (prUser.show) user,+ footer+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines [+ "/*** BNFC-Generated Visitor Traversal Skeleton. ***/",+ "/* This traverses the abstract syntax tree.",+ " To use, copy Skeleton.h and Skeleton.c to",+ " new files. */",+ "",+ "#include \"Skeleton.h\"",+ ""+ ]+ prUser u = unlines+ [+ "void visit" ++ u' ++ "(" ++ u ++ " p)",+ "{",+ " /* Code for " ++ u ++ " Goes Here */",+ "}"+ ]+ where+ u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.+ footer = unlines+ [+ "void visitIdent(Ident i)",+ "{",+ " /* Code for Ident Goes Here */",+ "}",+ "void visitInteger(Integer i)",+ "{",+ " /* Code for Integer Goes Here */",+ "}",+ "void visitDouble(Double d)",+ "{",+ " /* Code for Double Goes Here */",+ "}",+ "void visitChar(Char c)",+ "{",+ " /* Code for Char Goes Here */",+ "}",+ "void visitString(String s)",+ "{",+ " /* Code for String Goes Here */",+ "}",+ ""+ ]++--Visit functions for a category.+prData :: [UserDef] -> (Cat, [Rule]) -> String+prData user (cat, rules) =+ if isList cat+ then unlines+ [+ "void visit" ++ cl ++ "("++ cl +++ vname ++ ")",+ "{",+ " while(" ++ vname ++ " != 0)",+ " {",+ " /* Code For " ++ cl ++ " Goes Here */",+ " visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);",+ " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",+ " }",+ "}",+ ""+ ]+ -- Not a list:+ else unlines+ [+ "void visit" ++ cl ++ "(" ++ cl ++ " _p_)",+ "{",+ " switch(_p_->kind)",+ " {",+ concatMap (prPrintRule user) rules,+ " default:",+ " fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");",+ " exit(1);",+ " }",+ "}\n"+ ]+ where cl = identCat $ normCat cat+ ecl = identCat $ normCatOfList cat+ vname = map toLower cl+ member = map toLower ecl++-- Visits all the instance variables of a category.+prPrintRule :: [UserDef] -> Rule -> String+prPrintRule user (Rule fun _c cats) | not (isCoercion fun) = unlines+ [+ " case is_" ++ fun ++ ":",+ " /* Code for " ++ fun ++ " Goes Here */",+ cats' ++ " break;"+ ]+ where+ cats' = concatMap (prCat user fun) (zip (fixOnes (numVars [] cats)) cats)+prPrintRule _user (Rule _fun _ _) = ""++-- Prints the actual instance-variable visiting.+prCat :: [UserDef] -> Fun -> (Either String String, Either Cat String) -> String+prCat user fnm (c, o) =+ case c of+ Right {} -> ""+ Left nt ->+ if isBasic user nt+ then " visit" ++ basicFunName nt ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"+ else " visit" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"+ where v = map toLower $ normFun fnm+ o' = case o of+ Right x -> x+ Left x -> identCat $ normCat x++--Just checks if something is a basic or user-defined type.+--This is because you don't -> a basic non-pointer type.+isBasic :: [UserDef] -> String -> Bool+isBasic user v =+ if elem (init v) user'+ then True+ else if "integer_" `isPrefixOf` v then True+ else if "char_" `isPrefixOf` v then True+ else if "string_" `isPrefixOf` v then True+ else if "double_" `isPrefixOf` v then True+ else if "ident_" `isPrefixOf` v then True+ else False+ where+ user' = map (map toLower . show) user++--The visit-function name of a basic type+basicFunName :: String -> String+basicFunName v =+ if "integer_" `isPrefixOf` v then "Integer"+ else if "char_" `isPrefixOf` v then "Char"+ else if "string_" `isPrefixOf` v then "String"+ else if "double_" `isPrefixOf` v then "Double"+ else if "ident_" `isPrefixOf` v then "Ident"+ else (toUpper (head v)) : (init (tail v)) --User-defined type
+ src/BNFC/Backend/C/CFtoFlexC.hs view
@@ -0,0 +1,189 @@+{-+ BNF Converter: C flex generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Flex file. It is+ similar to JLex but with a few peculiarities.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 5 August, 2003++ Modified : 10 August, 2003+++ **************************************************************+-}+module BNFC.Backend.C.CFtoFlexC (cf2flex) where++import BNFC.CF+import BNFC.Backend.CPP.NoSTL.RegToFlex+-- import BNFC.Utils((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List++--The environment must be returned for the parser to use.+cf2flex :: String -> CF -> (String, SymEnv)+cf2flex name cf = (unlines+ [+ prelude name,+ cMacros,+ lexSymbols env,+ restOfFlex cf env'+ ], env')+ where+ env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)+ env' = env ++ (makeSymEnv (tokenNames cf) (length env))+ makeSymEnv [] _ = []+ makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))++prelude :: String -> String+prelude name = unlines+ [+ "/* -*- c -*- This FLex file was machine-generated by the BNF converter */",+ "%option noyywrap",+ "%{",+ "#define yylval " ++ name ++ "lval",+ "#define YY_BUFFER_APPEND " ++ name ++ "_BUFFER_APPEND",+ "#define YY_BUFFER_RESET " ++ name ++ "_BUFFER_RESET",+ "#define initialize_lexer " ++ name ++ "_initialize_lexer",+ "#include <string.h>",+ "#include \"Parser.h\"",+ "#define YY_BUFFER_LENGTH 4096",+ "char YY_PARSED_STRING[YY_BUFFER_LENGTH];",+ "void YY_BUFFER_APPEND(char *s)",+ "{",+ " strcat(YY_PARSED_STRING, s); //Do something better here!",+ "}",+ "void YY_BUFFER_RESET(void)",+ "{",+ " int x;",+ " for(x = 0; x < YY_BUFFER_LENGTH; x++)",+ " YY_PARSED_STRING[x] = 0;",+ "}",+ "",+ "%}"+ ]++--For now all categories are included.+--Optimally only the ones that are used should be generated.+cMacros :: String+cMacros = unlines+ [+ "LETTER [a-zA-Z]",+ "CAPITAL [A-Z]",+ "SMALL [a-z]",+ "DIGIT [0-9]",+ "IDENT [a-zA-Z0-9'_]",+ "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED",+ "%%"+ ]++lexSymbols :: SymEnv -> String+lexSymbols ss = concatMap transSym ss+ where+ transSym (s,r) =+ "<YYINITIAL>\"" ++ s' ++ "\" \t return " ++ r ++ ";\n"+ where+ s' = escapeChars s++restOfFlex :: CF -> SymEnv -> String+restOfFlex cf env = concat+ [+ lexComments (comments cf),+ userDefTokens,+ ifC catString strStates,+ ifC catChar chStates,+ ifC catDouble "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n",+ ifC catInteger "<YYINITIAL>{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n",+ ifC catIdent "<YYINITIAL>{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n"+ , "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",+ "<YYINITIAL>. \t return _ERROR_;\n",+ "%%\n",+ footer+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ printRegFlex exp +++ " \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"+ | (name, exp) <- tokenPragmas cf]+ where+ sName n = case lookup (show n) env of+ Just x -> x+ Nothing -> show n+ strStates = unlines --These handle escaped characters in Strings.+ [+ "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",+ "<STRING>\\\\ \t BEGIN ESCAPED;",+ "<STRING>\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;",+ "<STRING>. \t YY_BUFFER_APPEND(yytext);",+ "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",+ "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",+ "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",+ "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",+ "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" \tBEGIN CHAR;",+ "<CHAR>\\\\ \t BEGIN CHARESC;",+ "<CHAR>[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",+ "<CHARESC>n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;",+ "<CHARESC>t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;",+ "<CHARESC>. \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",+ "<CHAREND>\"'\" \t BEGIN YYINITIAL;"+ ]+ footer = "void initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }"++lexComments :: ([(String, String)], [String]) -> String+lexComments (m,s) =+ (unlines (map lexSingleComment s))+ ++ (unlines (map lexMultiComment m))++lexSingleComment :: String -> String+lexSingleComment c =+ "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n \t /* BNFC single-line comment */;"++--There might be a possible bug here if a language includes 2 multi-line comments.+--They could possibly start a comment with one character and end it with another.+--However this seems rare.+lexMultiComment :: (String, String) -> String+lexMultiComment (b,e) = unlines [+ "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",+ "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",+ "<COMMENT>. \t /* BNFC multi-line comment */;",+ "<COMMENT>[\\n] \t /* BNFC multi-line comment */;"+ ]++lexReserved :: String -> String+lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" \t yylval.string_ = strdup(yytext); return TS;"+++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars [] = []+escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))+escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))+escapeChars (x:xs) = x : (escapeChars xs)
+ src/BNFC/Backend/CPP/NoSTL.hs view
@@ -0,0 +1,181 @@+{-+ BNF Converter: C++ Main file+ Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.CPP.NoSTL (makeCppNoStl) where++import BNFC.Utils+import BNFC.Options+import BNFC.CF+import BNFC.Backend.Base+import BNFC.Backend.CPP.NoSTL.CFtoCPPAbs+import BNFC.Backend.CPP.NoSTL.CFtoFlex+import BNFC.Backend.CPP.NoSTL.CFtoBison+import BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel+import BNFC.Backend.CPP.NoSTL.CFtoCPPPrinter+import Data.Char+import System.Exit (exitFailure)+import Control.Monad (when)+import qualified BNFC.Backend.Common.Makefile as Makefile++makeCppNoStl :: SharedOptions -> CF -> MkFiles ()+makeCppNoStl opts cf = do+ let (hfile, cfile) = cf2CPPAbs name cf+ mkfile "Absyn.H" hfile+ mkfile "Absyn.C" cfile+ let (flex, env) = cf2flex Nothing name cf+ mkfile (name ++ ".l") flex+ let bison = cf2Bison name cf env+ mkfile (name ++ ".y") bison+ let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env+ mkfile "Parser.H" header+ let (skelH, skelC) = cf2CVisitSkel cf+ mkfile "Skeleton.H" skelH+ mkfile "Skeleton.C" skelC+ let (prinH, prinC) = cf2CPPPrinter cf+ mkfile "Printer.H" prinH+ mkfile "Printer.C" prinC+ mkfile "Test.C" (cpptest cf)+ Makefile.mkMakefile opts $ makefile name+ where name = lang opts++makefile :: String -> String+makefile name =+ (++) (unlines [ "CC = g++", "CCFLAGS = -g", "FLEX = flex", "BISON = bison", "" ])+ $ Makefile.mkRule "all" [ "Test" ++ name ]+ []+ $ Makefile.mkRule "clean" []+ -- peteg: don't nuke what we generated - move that to the "vclean" target.+ [ "rm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ]+ $ Makefile.mkRule "distclean" []+ [ "rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H"+ , "rm -f " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux "+ , "rm -f " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ++ " Makefile" ]+ $ Makefile.mkRule ("Test" ++ name) [ "Absyn.o", "Lexer.o", "Parser.o", "Printer.o", "Test.o" ]+ [ "@echo \"Linking Test" ++ name ++ "...\""+ , "${CC} ${CCFLAGS} *.o -o Test" ++ name ]+ $ Makefile.mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Absyn.C" ]+ $ Makefile.mkRule "Lexer.C" [ name ++ ".l" ]+ [ "${FLEX} -oLexer.C " ++ name ++ ".l" ]+ $ Makefile.mkRule "Parser.C" [ name ++ ".y" ]+ [ "${BISON} " ++ name ++ ".y -o Parser.C" ]+ $ Makefile.mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ]+ [ "${CC} ${CCFLAGS} -c Lexer.C " ]+ $ Makefile.mkRule "Parser.o" [ "Parser.C", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Parser.C" ]+ $ Makefile.mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Printer.C" ]+ $ Makefile.mkRule "Test.o" [ "Test.C", "Parser.H", "Printer.H", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Test.C" ]+ ""+++cpptest :: CF -> String+cpptest cf =+ unlines+ [+ "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",+ "/* */",+ "/* This test will parse a file, print the abstract syntax tree, and then */",+ "/* pretty-print the result. */",+ "/* */",+ "/****************************************************************************/",+ "#include <stdio.h>",+ "#include \"Parser.H\"",+ "#include \"Printer.H\"",+ "#include \"Absyn.H\"",+ "",+ "int main(int argc, char ** argv)",+ "{",+ " FILE *input;",+ " if (argc > 1) ",+ " {",+ " input = fopen(argv[1], \"r\");",+ " if (!input)",+ " {",+ " fprintf(stderr, \"Error opening input file.\\n\");",+ " exit(1);",+ " }",+ " }",+ " else input = stdin;",+ " /* The default entry point is used. For other options see Parser.H */",+ " " ++ def ++ " *parse_tree = p" ++ def ++ "(input);",+ " if (parse_tree)",+ " {",+ " printf(\"\\nParse Succesful!\\n\");",+ " printf(\"\\n[Abstract Syntax]\\n\");",+ " ShowAbsyn *s = new ShowAbsyn();",+ " printf(\"%s\\n\\n\", s->show(parse_tree));",+ " printf(\"[Linearized Tree]\\n\");",+ " PrintAbsyn *p = new PrintAbsyn();",+ " printf(\"%s\\n\\n\", p->print(parse_tree));",+ " return 0;",+ " }",+ " return 1;",+ "}",+ ""+ ]+ where+ def = show (head (allEntryPoints cf))++mkHeaderFile cf cats eps env = unlines+ [+ "#ifndef PARSER_HEADER_FILE",+ "#define PARSER_HEADER_FILE",+ "",+ concatMap mkForwardDec cats,+ "typedef union",+ "{",+ " int int_;",+ " char char_;",+ " double double_;",+ " char* string_;",+ (concatMap mkVar cats) ++ "} YYSTYPE;",+ "",+ "#define _ERROR_ 258",+ mkDefines (259 :: Int) env,+ "extern YYSTYPE yylval;",+ concatMap mkFunc eps,+ "",+ "#endif"+ ]+ where+ mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n"+ mkForwardDec _ = ""+ mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n"+ mkVar _ = ""+ mkDefines n [] = mkString n+ mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)+ mkString n = if isUsedCat cf catString+ then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)+ else mkChar n+ mkChar n = if isUsedCat cf catChar+ then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)+ else mkInteger n+ mkInteger n = if isUsedCat cf catInteger+ then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)+ else mkDouble n+ mkDouble n = if isUsedCat cf catDouble+ then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)+ else mkIdent n+ mkIdent n = if isUsedCat cf catIdent+ then ("#define _IDENT_ " ++ show n ++ "\n")+ else ""+ mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n"+ mkFunc _ = ""
+ src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs view
@@ -0,0 +1,351 @@+{-+ BNF Converter: Bison generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ BNF Converter: C++ Bison generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Bison input file.+ Note that because of the way bison stores results+ the programmer can increase performance by limiting+ the number of entry points in their grammar.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 6 August, 2003++ Modified : 6 August, 2003+++ **************************************************************+-}+++module BNFC.Backend.CPP.NoSTL.CFtoBison (cf2Bison) where++import BNFC.CF+import Data.List (intersperse, isPrefixOf, nub)+import BNFC.Backend.Common.NamedVariables hiding (varName)+import Data.Char (toLower,isUpper)+import BNFC.Utils ((+++), (++++))+import BNFC.TypeChecker+import ErrM++--This follows the basic structure of CFtoHappy.++-- Type declarations+type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++--The environment comes from the CFtoFlex+cf2Bison :: String -> CF -> SymEnv -> String+cf2Bison name cf env+ = unlines+ [header name cf,+ union (allCats cf),+ "%token _ERROR_",+ tokens user env,+ declarations cf,+ specialToks cf,+ "%%",+ prRules (rulesForBison name cf env)+ ]+ where+ user = fst (unzip (tokenPragmas cf))++header :: String -> CF -> String+header name cf = unlines+ ["/* This Bison file was machine-generated by BNFC */",+ "%{",+ "#include <stdlib.h>",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <iostream>",+ "#include \"Absyn.H\"",+ "int yyparse(void);",+ "int yylex(void);",+ "int yy_mylinenumber;", --- hack to get line number. AR 2006+ "int initialize_lexer(FILE * inp);",+ "int yywrap(void)",+ "{",+ " return 1;",+ "}",+ "void yyerror(const char *str)",+ "{",+ " std::cout << \"line \" << yy_mylinenumber + 1 << std::endl ;",+ " fprintf(stderr,\"error: %s\\n\",str);",+ "}",+ "",+ definedRules cf,+ unlines $ map (parseMethod name) (allCatsNorm cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.+ concatMap reverseList (filter isList (allCats cf)),+ "%}"+ ]++definedRules :: CF -> String+definedRules cf =+ unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf]+ where+ ctx = buildContext cf++ list = LC (const "[]") (\t -> "List" ++ unBase t)+ where+ unBase (ListT t) = unBase t+ unBase (BaseT x) = show$normCat$strToCat x++ rule f xs e =+ case checkDefinition' list ctx f xs e of+ Bad err -> error $ "Panic! This should have been caught already:\n" ++ err+ Ok (args,(e',t)) -> unlines+ [ cppType t ++ " " ++ f ++ "_ (" +++ concat (intersperse ", " $ map cppArg args) ++ ") {"+ , " return " ++ cppExp e' ++ ";"+ , "}"+ ]+ where++ cppType :: Base -> String+ cppType (ListT (BaseT x)) = "List" ++ show (normCat (strToCat x)) ++ " *"+ cppType (ListT t) = cppType t ++ " *"+ cppType (BaseT x)+ | isToken x ctx = "String"+ | otherwise = show (normCat (strToCat x)) ++ " *"++ cppArg :: (String, Base) -> String+ cppArg (x,t) = cppType t ++ " " ++ x ++ "_"++ cppExp :: Exp -> String+ cppExp (App "[]" []) = "0"+ cppExp (App x [])+ | elem x xs = x ++ "_" -- argument+ cppExp (App t [e])+ | isToken t ctx = cppExp e+ cppExp (App x es)+ | isUpper (head x) = call ("new " ++ x) es+ | otherwise = call (x ++ "_") es+ cppExp (LitInt n) = show n+ cppExp (LitDouble x) = show x+ cppExp (LitChar c) = show c+ cppExp (LitString s) = show s++ call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"+++--This generates a parser method for each entry point.+parseMethod :: String -> Cat -> String+parseMethod name cat =+ -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm+ -- then ""+ -- else+ unlines+ [+ cat' ++ "*" +++ (resultName cat') +++ "= 0;",+ cat' ++"* p" ++ cat' ++ "(FILE *inp)",+ "{",+ " initialize_lexer(inp);",+ " if (yyparse())",+ " { /* Failure */",+ " return 0;",+ " }",+ " else",+ " { /* Success */",+ " return" +++ (resultName cat') ++ ";",+ " }",+ "}"+ ]+ where+ cat' = identCat (normCat cat)++--This method generates list reversal functions for each list type.+reverseList :: Cat -> String+reverseList c = unlines+ [+ c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)",+ "{",+ " " ++ c' +++"*prev = 0;",+ " " ++ c' +++"*tmp = 0;",+ " while (l)",+ " {",+ " tmp = l->" ++ v ++ ";",+ " l->" ++ v +++ "= prev;",+ " prev = l;",+ " l = tmp;",+ " }",+ " return prev;",+ "}"+ ]+ where+ c' = identCat (normCat c)+ v = (map toLower c') ++ "_"++--The union declaration is special to Bison/Yacc and gives the type of yylval.+--For efficiency, we may want to only include used categories here.+union :: [Cat] -> String+union cats = unlines+ [+ "%union",+ "{",+ " int int_;",+ " char char_;",+ " double double_;",+ " char* string_;",+ concatMap mkPointer cats,+ "}"+ ]+ where --This is a little weird because people can make [Exp2] etc.+ mkPointer s | identCat s /= show s = --list. add it even if it refers to a coercion.+ " " ++ identCat (normCat s) ++ "*" +++ varName s ++ ";\n"+ mkPointer s | normCat s == s = --normal cat+ " " ++ identCat (normCat s) ++ "*" +++ varName s ++ ";\n"+ mkPointer s = ""++--declares non-terminal types.+declarations :: CF -> String+declarations cf = concatMap (typeNT cf) (allCats cf)+ where --don't define internal rules+ typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n"+ typeNT cf nt = ""++--declares terminal types.+tokens :: [UserDef] -> SymEnv -> String+tokens user ts = concatMap (declTok user) ts+ where+ declTok u (s,r) = if elem s (map show u)+ then "%token<string_> " ++ r ++ " // " ++ s ++ "\n"+ else "%token " ++ r ++ " // " ++ s ++ "\n"++specialToks :: CF -> String+specialToks cf = concat [+ ifC catString "%token<string_> _STRING_\n",+ ifC catChar "%token<char_> _CHAR_\n",+ ifC catInteger "%token<int_> _INTEGER_\n",+ ifC catDouble "%token<double_> _DOUBLE_\n",+ ifC catIdent "%token<string_> _IDENT_\n"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""++--The following functions are a (relatively) straightforward translation+--of the ones in CFtoHappy.hs+rulesForBison :: String -> CF -> SymEnv -> Rules+rulesForBison name cf env = map mkOne $ ruleGroups cf where+ mkOne (cat,rules) = constructRule cf env rules cat++-- For every non-terminal, we construct a set of rules.+constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf env r])+ where+ ruleName r = case funRule r of+ "(:)" -> identCat nt+ "(:[])" -> identCat nt+ z -> z+ revs = reversibleCats cf+ eps = allEntryPoints cf+ isEntry nt = if elem nt eps then True else False+ result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""++-- Generates a string containing the semantic action.+generateAction :: Fun -> Bool -> [MetaVar] -> Action+generateAction f b ms =+ if isCoercion f+ then (unwords ms) ++ ";"+ else if f == "[]"+ then "0;"+ else if isDefinedRule f+ then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ]+ else concat ["new ", normFun f, "(", (concat (intersperse ", " ms')), ");"]+ where+ ms' = if b then reverse ms else ms++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal+generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns cf env r = case rhsRule r of+ [] -> ("/* empty */",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> case lookup (show c) env of+ Just x -> x+ Nothing -> typeName (identCat c)+ Right s -> case lookup s env of+ Just x -> x+ Nothing -> s+ metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]+ revIf c m = if (not (isConsFun (funRule r)) && elem c revs)+ then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")+ else m -- no reversal in the left-recursive Cons rule itself+ revs = reversibleCats cf++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.++prRules :: Rules -> String+prRules [] = []+prRules ((nt, []):rs) = prRules rs --internal rule+prRules ((nt,((p,a):ls)):rs) =+ (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls++--Some helper functions.+resultName :: String -> String+resultName s = "YY_RESULT_" ++ s ++ "_"++--slightly stronger than the NamedVariable version.+varName :: Cat -> String+varName = (++ "_") . map toLower . identCat . normCat++typeName :: String -> String+typeName "Ident" = "_IDENT_"+typeName "String" = "_STRING_"+typeName "Char" = "_CHAR_"+typeName "Integer" = "_INTEGER_"+typeName "Double" = "_DOUBLE_"+typeName x = x
+ src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs view
@@ -0,0 +1,443 @@+{-+ BNF Converter: C++ abstract syntax generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C++ Abstract Syntax+ tree classes. It generates both a Header file+ and an Implementation file, and uses the Visitor+ design pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 4 August, 2003++ Modified : 22 May, 2004 / Antti-Juhani Kaijanaho+++ **************************************************************+-}++module BNFC.Backend.CPP.NoSTL.CFtoCPPAbs (cf2CPPAbs) where++import BNFC.CF+import BNFC.Utils((+++),(++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower)+++--The result is two files (.H file, .C file)+cf2CPPAbs :: String -> CF -> (String, String)+cf2CPPAbs name cf = (mkHFile cf, mkCFile cf)+++{- **** Header (.H) File Functions **** -}++--Makes the Header file.+mkHFile :: CF -> String+mkHFile cf = unlines+ [+ "#ifndef ABSYN_HEADER",+ "#define ABSYN_HEADER",+ "",+ header,+ prTypeDefs user,+ "/******************** Forward Declarations ********************/\n",+ concatMap prForward classes,+ "",+ prVisitor classes,+ prVisitable,+ "",+ "/******************** Abstract Syntax Classes ********************/\n",+ concatMap (prDataH user) (cf2dataLists cf),+ "",+ "#endif"+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = "//C++ Abstract Syntax Interface generated by the BNF Converter.\n"+ rules = getRules cf+ classes = rules ++ (getClasses (map show $ allCats cf))+ prForward s | isProperLabel s = "class " ++ (show$normCat$strToCat s) ++ ";\n"+ prForward s = ""+ getRules cf = (map testRule (rulesOfCF cf))+ getClasses [] = []+ getClasses (c:cs) =+ if identCat (normCat$strToCat c) /= c+ then getClasses cs+ else if elem c rules+ then getClasses cs+ else c : (getClasses cs)++ testRule (Rule f c r) =+ if isList c+ then if isConsFun f+ then identCat c+ else "_" --ignore this+ else f++--Prints interface classes for all categories.+prDataH :: [UserDef] -> Data -> String+prDataH user (cat, rules) =+ case lookup (show cat) rules of+ Just x -> concatMap (prRuleH user cat) rules+ Nothing -> if isList cat+ then concatMap (prRuleH user cat) rules+ else unlines+ [+ "class" +++ (identCat cat) +++ ": public Visitable {",+ "public:",+ " virtual" +++ (identCat cat) +++ "*clone() const = 0;",+ "};\n",+ concatMap (prRuleH user cat) rules+ ]++--Interface definitions for rules vary on the type of rule.+prRuleH :: [UserDef] -> Cat -> (Fun, [Cat]) -> String+prRuleH user c (fun, cats) =+ if isNilFun fun || isOneFun fun+ then "" --these are not represented in the AbSyn+ else if isConsFun fun+ then --this is the linked list case.+ unlines+ [+ "class" +++ c' +++ ": public Visitable",+ "{",+ " public:",+ prInstVars user vs,+ " " ++ c' ++ "(const" +++ c' +++ "&);",+ " " ++ c' ++ " &operator=(const" +++ c' +++ "&);",+ " " ++ c' ++ "(" ++ (prConstructorH 1 vs) ++ ");",+ " " ++ c' ++ "(" ++ mem +++ memstar ++ "p);",+ prDestructorH c',+ " " ++ c' ++ "* reverse();",+ " " ++ c' ++ "* reverse(" ++ c' ++ " *l);",+ " virtual void accept(Visitor *v);",+ " virtual " ++ c' ++ " *clone() const;",+ " void swap(" ++ c' +++ "&);",+ "};"+ ]+ else --a standard rule+ unlines+ [+ "class" +++ fun' +++ ": public" +++ super,+ "{",+ " public:",+ prInstVars user vs,+ " " ++ fun' ++ "(const" +++ fun' +++ "&);",+ " " ++ fun' ++ " &operator=(const" +++ fun' +++ "&);",+ " " ++ fun' ++ "(" ++ (prConstructorH 1 vs) ++ ");",+ prDestructorH fun',+ " virtual void accept(Visitor *v);",+ " virtual " +++ fun' +++ " *clone() const;",+ " void swap(" ++ fun' +++ "&);",+ "};\n"+ ]+ where+ vs = getVars cats+ fun' = normFun fun+ c' = identCat (normCat c);+ mem = drop 4 c'+ memstar = if isBasic user mem then "" else "*"+ super = if show c == fun then "Visitable" else (identCat c)+ prConstructorH :: Int -> [(String, b)] -> String+ prConstructorH _ [] = ""+ prConstructorH n ((t,_):[]) = t +++ (optstar t) ++ "p" ++ (show n)+ prConstructorH n ((t,_):vs) =( t +++ (optstar t) ++ "p" ++ (show n) ++ ", ") ++ (prConstructorH (n+1) vs)+ prDestructorH n = " ~" ++ n ++ "();"+ optstar x = if isBasic user x+ then ""+ else "*"++prVisitable :: String+prVisitable = unlines+ [+ "class Visitable",+ "{",+ " public:",+ -- all classes with virtual methods require a virtual destructor+ " virtual ~Visitable() {}",+ " virtual void accept(Visitor *v) = 0;",+ "};\n"+ ]++prVisitor :: [String] -> String+prVisitor fs = unlines+ [+ "/******************** Visitor Interfaces ********************/",+ "",+ "class Visitor",+ "{",+ " public:",+ " virtual ~Visitor() {}",+ (concatMap (prVisitFun) fs),+ footer+ ]+ where+ footer = unlines+ [ --later only include used categories+ " virtual void visitInteger(Integer i) = 0;",+ " virtual void visitDouble(Double d) = 0;",+ " virtual void visitChar(Char c) = 0;",+ " virtual void visitString(String s) = 0;",+ "};"+ ]+ prVisitFun f | isProperLabel f =+ " virtual void visit" ++ f' ++ "(" ++ f' ++ " *p) = 0;\n"+ where+ f' = normFun f+ prVisitFun _ = ""++--typedefs in the Header make generation much nicer.+prTypeDefs user = unlines+ [+ "/******************** TypeDef Section ********************/",+ "typedef int Integer;",+ "typedef char Char;",+ "typedef double Double;",+ "typedef char* String;",+ "typedef char* Ident;",+ concatMap prUserDef user+ ]+ where+ prUserDef s = "typedef char* " ++ show s ++ ";\n"++--A class's instance variables.+prInstVars :: [UserDef] -> [IVar] -> String+prInstVars _ [] = []+prInstVars user vars@((t,n):vs) =+ " " ++ t +++ uniques ++ ";" +++++ (prInstVars user vs')+ where+ (uniques, vs') = prUniques t vars+ --these functions group the types together nicely+ prUniques :: String -> [IVar] -> (String, [IVar])+ prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs)+ prVars (x:[]) vs = case vs !! x of+ (t,n) -> ((varLinkName t) ++ (showNum n))+ prVars (x:xs) vs = case vs !! x of+ (t,n) -> ((varLinkName t) ++ (showNum n)) ++ "," ++++ (prVars xs vs)+ varLinkName z = if isBasic user z+ then (map toLower z) ++ "_"+ else "*" ++ (map toLower z) ++ "_"+ remType :: String -> [IVar] -> [IVar]+ remType _ [] = []+ remType t ((t2,n):ts) = if t == t2+ then (remType t ts)+ else (t2,n) : (remType t ts)+++{- **** Implementation (.C) File Functions **** -}++--Makes the .C file+mkCFile :: CF -> String+mkCFile cf = unlines+ [+ header,+ concatMap (prDataC user) (cf2dataLists cf)+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines+ [+ "//C++ Abstract Syntax Implementation generated by the BNF Converter.",+ "#include <algorithm>",+ "#include \"Absyn.H\""+ ]++--This is not represented in the implementation.+prDataC :: [UserDef] -> Data -> String+prDataC user (cat, rules) = concatMap (prRuleC user cat) rules++--Classes for rules vary based on the type of rule.+prRuleC user c (fun, cats) =+ if isNilFun fun || isOneFun fun+ then "" --these are not represented in the AbSyn+ else if isConsFun fun+ then --this is the linked list case.+ unlines+ [+ "/******************** " ++ c' ++ " ********************/",+ prConstructorC user c' vs cats,+ prCopyC user c' vs,+ prDestructorC user c' vs,+ prListFuncs user c',+ prAcceptC c',+ prCloneC user c' vs,+ ""+ ]+ else --a standard rule+ unlines+ [+ "/******************** " ++ fun' ++ " ********************/",+ prConstructorC user fun' vs cats,+ prCopyC user fun' vs,+ prDestructorC user fun' vs,+ prAcceptC fun,+ prCloneC user fun' vs,+ ""+ ]+ where+ vs = getVars cats+ fun' = normFun fun+ c' = identCat (normCat c)++--These are all built-in list functions.+--Later we could include things like lookup,insert,delete,etc.+prListFuncs :: [UserDef] -> String -> String+prListFuncs user c = unlines+ [+ c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)",+ "{",+ " " ++ m' ++ " = p;",+ " " ++ v ++ "= 0;",+ "}",+ c ++ "*" +++ c ++ "::" ++ "reverse()",+ "{",+ " if (" ++ v +++ "== 0) return this;",+ " else",+ " {",+ " " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);",+ " " ++ v +++ "= 0;",+ " return tmp;",+ " }",+ "}",+ "",+ c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)",+ "{",+ " if (" ++ v +++ "== 0)",+ " {",+ " " ++ v +++ "= prev;",+ " return this;",+ " }",+ " else",+ " {",+ " " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);",+ " " ++ v +++ "= prev;",+ " return tmp;",+ " }",+ "}"+ ]+ where+ v = (map toLower c) ++ "_"+ m = drop 4 c+ mstar = if isBasic user m then "" else "*"+ m' = drop 4 v++--The standard accept function for the Visitor pattern+prAcceptC :: String -> String+prAcceptC ty =+ "\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }"++--The constructor just assigns the parameters to the corresponding instance variables.+prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> String+prConstructorC user c vs cats =+ c ++ "::" ++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" ++++ prAssigns vs params ++ "}"+ where+ (types, params) = unzip (prParams cats (length cats) ((length cats)+1))+ interleave _ [] = []+ interleave (x:[]) (y:[]) = x +++ (optstar x) ++ y+ interleave (x:xs) (y:ys) = x +++ (optstar x) ++ y ++ "," +++ (interleave xs ys)+ optstar x = if isBasic user x+ then ""+ else "*"++--Print copy constructor and copy assignment+prCopyC :: [UserDef] -> String -> [IVar] -> String+prCopyC user c vs =+ c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" ++++ concatMap doV vs +++++ "}" +++++ c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" +++++ " " ++ c +++ "tmp(other);" +++++ " swap(tmp);" +++++ " return *this;" +++++ "}" +++++ "void" +++ c ++ "::swap(" ++ c +++ "& other) {" +++++ concatMap swapV vs +++++ "}\n"+ where doV :: IVar -> String+ doV v@(t, _)+ | isBasic user t = " " ++ vn v ++ " = other." ++ vn v ++ ";\n"+ | otherwise = " " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n"+ vn :: IVar -> String+ vn (t, 0) = varName t+ vn (t, n) = varName t ++ show n+ swapV :: IVar -> String+ swapV v = " std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n"++--The cloner makes a new deep copy of the object+prCloneC :: [UserDef] -> String -> [IVar] -> String+prCloneC user c vs =+ c +++ "*" ++ c ++ "::clone() const {" +++++ " return new" +++ c ++ "(*this);\n}"++--The destructor deletes all a class's members.+prDestructorC :: [UserDef] -> String -> [IVar] -> String+prDestructorC user c vs =+ c ++ "::~" ++ c ++"()" +++ "{" ++++ (concatMap prDeletes vs) ++ "}"+ where+ prDeletes :: (String, Int) -> String+ prDeletes (t, n) = if isBasic user t+ then ""+ else if n == 0+ then "delete(" ++ (varName t) ++ "); "+ else "delete(" ++ (varName t) ++ (show n) ++ "); "++--Prints the constructor's parameters.+prParams :: [Cat] -> Int -> Int -> [(String,String)]+prParams [] _ _ = []+prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n)))+ : (prParams cs (n-1) m)++--Prints the assignments of parameters to instance variables.+--This algorithm peeks ahead in the list so we don't use map or fold+prAssigns :: [IVar] -> [String] -> String+prAssigns [] _ = []+prAssigns _ [] = []+prAssigns ((t,n):vs) (p:ps) =+ if n == 1 then+ case findIndices (\x -> case x of (l,r) -> l == t) vs of+ [] -> (varName t) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)+ z -> ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)+ else ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)+++{- **** Helper Functions **** -}++--Checks if something is a basic or user-defined type.+isBasic :: [UserDef] -> String -> Bool+isBasic user x =+ if elem x (map show user)+ then True+ else case x of+ "Integer" -> True+ "Char" -> True+ "String" -> True+ "Double" -> True+ "Ident" -> True+ _ -> False
+ src/BNFC/Backend/CPP/NoSTL/CFtoCPPPrinter.hs view
@@ -0,0 +1,598 @@+{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C++ Pretty Printer.+ It also generates the "show" method for+ printing an abstract syntax tree.++ The generated files use the Visitor design pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 10 August, 2003++ Modified : 3 September, 2003+ * Added resizable buffers++ **************************************************************+-}++module BNFC.Backend.CPP.NoSTL.CFtoCPPPrinter (cf2CPPPrinter) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.Common.StrUtils (renderCharOrString)+import Data.List+import Data.Char(toLower, toUpper)+import Text.PrettyPrint++--Produces (.H file, .C file)+cf2CPPPrinter :: CF -> (String, String)+cf2CPPPrinter cf = (mkHFile cf groups, mkCFile cf groups)+ where+ groups = fixCoercions (ruleGroupsInternals cf)++{- **** Header (.H) File Methods **** -}++--An extremely large function to make the Header File+mkHFile :: CF -> [(Cat,[Rule])] -> String+mkHFile cf groups = unlines+ [+ printHeader,+ concatMap prDataH groups,+ classFooter,+ showHeader,+ concatMap prDataH groups,+ classFooter,+ footer+ ]+ where+ printHeader = unlines+ [+ "#ifndef PRINTER_HEADER",+ "#define PRINTER_HEADER",+ "",+ "#include \"Absyn.H\"",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <stdlib.h>",+ "",+ "/* Certain applications may improve performance by changing the buffer size */",+ "#define BUFFER_INITIAL 2000",+ "/* You may wish to change _L_PAREN or _R_PAREN */",+ "#define _L_PAREN '('",+ "#define _R_PAREN ')'",+ "",+ "class PrintAbsyn : public Visitor",+ "{",+ " protected:",+ " int _n_, _i_;",+ " /* The following are simple heuristics for rendering terminals */",+ " /* You may wish to change them */",+ " void render(Char c);",+ " void render(String s);",+ " void indent(void);",+ " void backup(void);",+ " public:",+ " PrintAbsyn(void);",+ " ~PrintAbsyn(void);",+ " char* print(Visitable* v);"+ ]+ classFooter = unlines+ [+ " void visitInteger(Integer i);",+ " void visitDouble(Double d);",+ " void visitChar(Char c);",+ " void visitString(String s);",+ " void visitIdent(String s);",+ " protected:",+ " void inline bufAppend(const char* s)",+ " {",+ " int len = strlen(s);",+ " while (cur_ + len > buf_size)",+ " {",+ " buf_size *= 2; /* Double the buffer size */",+ " resizeBuffer();",+ " }",+ " for(int n = 0; n < len; n++)",+ " {",+ " buf_[cur_ + n] = s[n];",+ " }",+ " cur_ += len;",+ " buf_[cur_] = 0;",+ " }",+ " void inline bufAppend(const char c)",+ " {",+ " if (cur_ == buf_size)",+ " {",+ " buf_size *= 2; /* Double the buffer size */",+ " resizeBuffer();",+ " }",+ " buf_[cur_] = c;",+ " cur_++;",+ " buf_[cur_] = 0;",+ " }",+ " void inline bufReset(void)",+ " {",+ " cur_ = 0;",+ " buf_size = BUFFER_INITIAL;",+ " resizeBuffer();",+ " memset(buf_, 0, buf_size);",+ " }",+ " void inline resizeBuffer(void)",+ " {",+ " char* temp = (char*) malloc(buf_size);",+ " if (!temp)",+ " {",+ " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",+ " exit(1);",+ " }",+ " if (buf_)",+ " {",+ " strcpy(temp, buf_);",+ " free(buf_);",+ " }",+ " buf_ = temp;",+ " }",+ " char *buf_;",+ " int cur_, buf_size;",+ "};",+ ""+ ]+ showHeader = unlines+ [+ "",+ "class ShowAbsyn : public Visitor",+ "{",+ " public:",+ " ShowAbsyn(void);",+ " ~ShowAbsyn(void);",+ " char* show(Visitable* v);"+ ]+ footer = unlines+ [+ "",+ "#endif"+ ]++--Prints all the required method names and their parameters.+prDataH :: (Cat, [Rule]) -> String+prDataH (cat, rules) =+ if isList cat+ then concat [" void visit", cl, "(", cl, "* p);\n"]+ else abstract ++ (concatMap prRuleH rules)+ where+ cl = identCat (normCat cat)+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n"++--Prints all the methods to visit a rule.+prRuleH :: Rule -> String+prRuleH (Rule fun c cats) | isProperLabel fun = concat+ [" void visit", fun, "(", fun, " *p);\n"]+prRuleH _ = ""++{- **** Implementation (.C) File Methods **** -}++--This makes the .C file by a similar method.+mkCFile :: CF -> [(Cat,[Rule])] -> String+mkCFile cf groups = concat+ [+ header,+ prRender,+ printEntries,+ concatMap (prPrintData user) groups,+ printBasics,+ showEntries,+ concatMap (prShowData user) groups,+ showBasics+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines+ [+ "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",+ "",+ "#include \"Printer.H\"",+ ""+ ]+ printEntries = unlines+ [+ "PrintAbsyn::PrintAbsyn(void)",+ "{",+ " _i_ = 0; _n_ = 0;",+ " buf_ = 0;",+ " bufReset();",+ "}",+ "",+ "PrintAbsyn::~PrintAbsyn(void)",+ "{",+ "}",+ "",+ "char* PrintAbsyn::print(Visitable *v)",+ "{",+ " _i_ = 0; _n_ = 0;",+ " bufReset();",+ " v->accept(this);",+ " return buf_;",+ "}"+ ]+ showEntries = unlines+ [+ "ShowAbsyn::ShowAbsyn(void)",+ "{",+ " buf_ = 0;",+ " bufReset();",+ "}",+ "",+ "ShowAbsyn::~ShowAbsyn(void)",+ "{",+ "}",+ "",+ "char* ShowAbsyn::show(Visitable *v)",+ "{",+ " bufReset();",+ " v->accept(this);",+ " return buf_;",+ "}"+ ]+ printBasics = unlines+ [+ "void PrintAbsyn::visitInteger(Integer i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%d\", i);",+ " bufAppend(tmp);",+ "}",+ "void PrintAbsyn::visitDouble(Double d)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%g\", d);",+ " bufAppend(tmp);",+ "}",+ "void PrintAbsyn::visitChar(Char c)",+ "{",+ " bufAppend('\\'');",+ " bufAppend(c);",+ " bufAppend('\\'');",+ "}",+ "void PrintAbsyn::visitString(String s)",+ "{",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ "void PrintAbsyn::visitIdent(String s)",+ "{",+ " render(s);",+ "}",+ ""+ ]+ showBasics = unlines+ [+ "void ShowAbsyn::visitInteger(Integer i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%d\", i);",+ " bufAppend(tmp);",+ "}",+ "void ShowAbsyn::visitDouble(Double d)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%g\", d);",+ " bufAppend(tmp);",+ "}",+ "void ShowAbsyn::visitChar(Char c)",+ "{",+ " bufAppend('\\'');",+ " bufAppend(c);",+ " bufAppend('\\'');",+ "}",+ "void ShowAbsyn::visitString(String s)",+ "{",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ "void ShowAbsyn::visitIdent(String s)",+ "{",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ ""+ ]++{- **** Pretty Printer Methods **** -}++--Generates methods for the Pretty Printer+prPrintData :: [UserDef] -> (Cat, [Rule]) -> String+prPrintData user (cat, rules) =+ if isList cat+ then unlines+ [+ "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",+ "{",+ " while(" ++ vname ++ "!= 0)",+ " {",+ " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)",+ " {",+ visitMember,+ optsep,+ " " ++ vname +++ "= 0;",+ " }",+ " else",+ " {",+ visitMember,+ " render(" ++ sep ++ ");",+ " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",+ " }",+ " }",+ "}",+ ""+ ] --Not a list:+ else abstract ++ (concatMap (prPrintRule user) rules)+ where+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl ++ "_"+ visitMember = if isBasic user member+ then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"+ else " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ sep = snd (renderCharOrString sep')+ sep' = getCons rules+ optsep = if hasOneFunc rules then "" else (" render(" ++ sep ++ ");")+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n"++--Pretty Printer methods for a rule.+prPrintRule :: [UserDef] -> Rule -> String+prPrintRule user r@(Rule fun c cats) | isProperLabel fun = unlines+ [+ "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",+ "{",+ " int oldi = _i_;",+ lparen,+ cats',+ rparen,+ " _i_ = oldi;",+ "}\n"+ ]+ where+ p = precRule r+ (lparen, rparen) =+ (" if (oldi > " ++ (show p) ++ ") render(_L_PAREN);\n",+ " if (oldi > " ++ (show p) ++ ") render(_R_PAREN);\n")+ cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)))+ fnm = "p" --old names could cause conflicts+ getPrec (Right s) = 0+ getPrec (Left c) = precCat c+prPrintRule _ _ = ""++--This goes on to recurse to the instance variables.+prPrintCat :: [UserDef] -> String -> (Either String String, Integer) -> String+prPrintCat user fnm (c,p) = case c of+ (Right t) -> " render(" ++ t' ++ ");\n"+ where+ t' = snd (renderCharOrString t)+ (Left nt) -> if isBasic user nt+ then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"+ else if "list" `isPrefixOf` nt+ then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}"+ else " " ++ accept ++ "\n"+ where+ accept = if nt == "#_" --Internal category+ then "/* Internal Category */\n"+ else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);"+++{- **** Abstract Syntax Tree Printer **** -}++--This prints the functions for Abstract Syntax tree printing.+prShowData :: [UserDef] -> (Cat, [Rule]) -> String+prShowData user (cat, rules) =+ if isList cat+ then unlines+ [+ "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",+ "{",+ " while(" ++ vname ++ "!= 0)",+ " {",+ " if (" ++ vname ++ "->" ++ vname ++ "_)",+ " {",+ visitMember,+ " bufAppend(\", \");",+ " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",+ " }",+ " else",+ " {",+ visitMember,+ " " ++ vname ++ " = 0;",+ " }",+ " }",+ "}",+ ""+ ] --Not a list:+ else abstract ++ (concatMap (prShowRule user) rules)+ where+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl ++ "_"+ visitMember = if isBasic user member+ then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"+ else " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n"++--This prints all the methods for Abstract Syntax tree rules.+prShowRule :: [UserDef] -> Rule -> String+prShowRule user (Rule fun c cats) | isProperLabel fun = concat+ [+ "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n",+ "{\n",+ lparen,+ " bufAppend(\"" ++ fun ++ "\");\n",+ optspace,+ cats',+ rparen,+ "}\n"+ ]+ where+ (optspace, lparen, rparen) = if allTerms cats+ then ("","","")+ else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n")+ cats' = if allTerms cats+ then ""+ else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats))))+ insertSpaces [] = []+ insertSpaces (x:[]) = [x]+ insertSpaces (x:xs) = if x == ""+ then insertSpaces xs+ else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs)+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+ fnm = "p" --other names could cause conflicts+prShowRule _ _ = ""++--This recurses to the instance variables of a class.+prShowCat :: [UserDef] -> String -> Either String String -> String+prShowCat user fnm c =+ case c of+ (Right t) -> ""+ (Left nt) ->+ if isBasic user nt+ then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"+ else if nt == "#_" --internal category+ then "/* Internal Category */\n"+ else if ((show$normCat$strToCat nt) /= nt)+ then accept+ else concat+ [+ " bufAppend('[');\n",+ " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept,+ " bufAppend(']');\n"+ ]+ where+ accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n"++{- **** Helper Functions Section **** -}+++--Just checks if something is a basic or user-defined type.+--This is because you don't -> a basic non-pointer type.+isBasic :: [UserDef] -> String -> Bool+isBasic user v =+ if elem (init v) user'+ then True+ else if "integer_" `isPrefixOf` v then True+ else if "char_" `isPrefixOf` v then True+ else if "string_" `isPrefixOf` v then True+ else if "double_" `isPrefixOf` v then True+ else if "ident_" `isPrefixOf` v then True+ else False+ where+ user' = map (map toLower.show) user++--The visit-function name of a basic type+funName :: String -> String+funName v =+ if "integer_" `isPrefixOf` v then "Integer"+ else if "char_" `isPrefixOf` v then "Char"+ else if "string_" `isPrefixOf` v then "String"+ else if "double_" `isPrefixOf` v then "Double"+ else if "ident_" `isPrefixOf` v then "Ident"+ else "Ident" --User-defined type++--Just sets the coercion level for parentheses in the Pretty Printer.+setI :: Integer -> String+setI n = "_i_ = " ++ (show n) ++ "; "++--An extremely simple renderer for terminals.+prRender :: String+prRender = unlines+ [+ "//You may wish to change render",+ "void PrintAbsyn::render(Char c)",+ "{",+ " if (c == '{')",+ " {",+ " bufAppend('\\n');",+ " indent();",+ " bufAppend(c);",+ " _n_ = _n_ + 2;",+ " bufAppend('\\n');",+ " indent();",+ " }",+ " else if (c == '(' || c == '[')",+ " bufAppend(c);",+ " else if (c == ')' || c == ']')",+ " {",+ " backup();",+ " bufAppend(c);",+ " bufAppend(' ');",+ " }",+ " else if (c == '}')",+ " {",+ " _n_ = _n_ - 2;",+ " backup();",+ " backup();",+ " bufAppend(c);",+ " bufAppend('\\n\');",+ " indent();",+ " }",+ " else if (c == ',')",+ " {",+ " backup();",+ " bufAppend(c);",+ " bufAppend(' ');",+ " }",+ " else if (c == ';')",+ " {",+ " backup();",+ " bufAppend(c);",+ " bufAppend('\\n');",+ " indent();",+ " }",+ " else if (c == 0) return;",+ " else",+ " {",+ " bufAppend(c);",+ " bufAppend(' ');",+ " }",+ "}",+ "void PrintAbsyn::render(String s)",+ "{",+ " if(strlen(s) > 0)",+ " {",+ " bufAppend(s);",+ " bufAppend(' ');",+ " }",+ "}",+ "void PrintAbsyn::indent()",+ "{",+ " int n = _n_;",+ " while (n > 0)",+ " {",+ " bufAppend(' ');",+ " n--;",+ " }",+ "}",+ "void PrintAbsyn::backup()",+ "{",+ " if (buf_[cur_ - 1] == ' ')",+ " {",+ " buf_[cur_ - 1] = 0;",+ " cur_--;",+ " }",+ "}"+ ]
+ src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs view
@@ -0,0 +1,259 @@+{-+ BNF Converter: C++ Skeleton generation+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C++ Skeleton functions.++ The generated files use the Visitor design pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 9 August, 2003++ Modified : 12 August, 2003+++ **************************************************************+-}++module BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel (cf2CVisitSkel) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper)++--Produces (.H file, .C file)+cf2CVisitSkel :: CF -> (String, String)+cf2CVisitSkel cf = (mkHFile cf groups, mkCFile cf groups)+ where+ groups = fixCoercions (ruleGroups cf)+++{- **** Header (.H) File Functions **** -}++--Generates the Header File+mkHFile :: CF -> [(Cat,[Rule])] -> String+mkHFile cf groups = unlines+ [+ header,+ concatMap prDataH groups,+ concatMap (prUserH.show) user,+ footer+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines+ [+ "#ifndef SKELETON_HEADER",+ "#define SKELETON_HEADER",+ "/* You might want to change the above name. */",+ "",+ "#include \"Absyn.H\"",+ "",+ "class Skeleton : public Visitor",+ "{",+ " public:"+ ]+ prUserH u = " void visit" ++ u' ++ "(" ++ u ++ " p);"+ where+ u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.+ footer = unlines+ [+ " void visitIdent(String s);",+ " void visitInteger(Integer i);",+ " void visitDouble(Double d);",+ " void visitChar(Char c);",+ " void visitString(String s);",+ "};",+ "",+ "#endif"+ ]++--Prints out visit functions for a category+prDataH :: (Cat, [Rule]) -> String+prDataH (cat, rules) =+ if "List" `isPrefixOf` (identCat cat)+ then concat [" void visit", cl, "(", cl, "* ", vname, ");"]+ else abstract ++ (concatMap prRuleH rules)+ where+ cl = identCat (normCat cat)+ vname = map toLower cl+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ "); /* abstract class */\n"++--Visit functions for a rule.+prRuleH :: Rule -> String+prRuleH (Rule fun c cats) | not (isCoercion fun) = concat+ [" void visit", fun, "(", fun, "* ", fnm, ");\n"]+ where+ fnm = map toLower fun+prRuleH _ = ""+++{- **** Implementation (.C) File Functions **** -}++--Makes the .C File+mkCFile :: CF -> [(Cat,[Rule])] -> String+mkCFile cf groups = concat+ [+ header,+ concatMap (prData user) groups,+ concatMap (prUser.show) user,+ footer+ ]+ where+ user = fst (unzip (tokenPragmas cf))+ header = unlines [+ "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",+ "/* This implements the common visitor design pattern.",+ " Note that this method uses Visitor-traversal of lists, so",+ " List->accept() does NOT traverse the list. This allows different",+ " algorithms to use context information differently. */",+ "",+ "#include \"Skeleton.H\"",+ ""+ ]+ prUser x = unlines+ [+ "void Skeleton::visit" ++ x' ++ "(" ++ x ++ " p)",+ "{",+ " /* Code for " ++ x ++ " Goes Here */",+ "}"+ ]+ where+ x' = ((toUpper (head x)) : (map toLower (tail x))) --this is a hack to fix a potential capitalization problem.+ footer = unlines+ [+ "void Skeleton::visitIdent(Ident i)",+ "{",+ " /* Code for Ident Goes Here */",+ "}",+ "void Skeleton::visitInteger(Integer i)",+ "{",+ " /* Code for Integers Goes Here */",+ "}",+ "void Skeleton::visitDouble(Double d)",+ "{",+ " /* Code for Doubles Goes Here */",+ "}",+ "void Skeleton::visitChar(Char c)",+ "{",+ " /* Code for Chars Goes Here */",+ "}",+ "void Skeleton::visitString(String s)",+ "{",+ " /* Code for Strings Goes Here */",+ "}",+ ""+ ]++--Visit functions for a category.+prData :: [UserDef] -> (Cat, [Rule]) -> String+prData user (cat, rules) =+ if "List" `isPrefixOf` (identCat cat)+ then unlines+ [+ "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")",+ "{",+ " while(" ++ vname ++ "!= 0)",+ " {",+ " /* Code For " ++ cl ++ " Goes Here */",+ visitMember,+ " " ++ vname ++ " = " ++ vname ++ "->" ++ vname ++ "_;",+ " }",+ "}",+ ""+ ] --Not a list:+ else abstract ++ (concatMap (prRule user) rules)+ where+ cl = identCat (normCat cat)+ vname = map toLower cl+ ecl = identCat (normCatOfList cat)+ member = map toLower ecl ++ "_"+ visitMember = if isBasic user member+ then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"+ else " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> "void Skeleton::visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ ") {} //abstract class\n\n"++--Visits all the instance variables of a category.+prRule :: [UserDef] -> Rule -> String+prRule user (Rule fun c cats) | not (isCoercion fun) = unlines+ [+ "void Skeleton::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",+ "{",+ " /* Code For " ++ fun ++ " Goes Here */",+ "",+ cats' ++ "}\n"+ ]+ where+ cats' = if allTerms cats+ then ""+ else (concatMap (prCat user fnm) (fixOnes (numVars [] cats)))+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+ fnm = map toLower fun+prRule user _ = ""++--Prints the actual instance-variable visiting.+prCat user fnm c =+ case c of+ (Right t) -> ""+ (Left nt) -> if isBasic user nt+ then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"+ else if "list" `isPrefixOf` nt+ then " if (" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}\n"+ else " " ++ accept ++ "\n"+ where+ accept = fnm ++ "->" ++ nt ++ "->accept(this);"++--Just checks if something is a basic or user-defined type.+--This is because you don't -> a basic non-pointer type.+isBasic :: [UserDef] -> String -> Bool+isBasic user v =+ if elem (init v) user'+ then True+ else if "integer_" `isPrefixOf` v then True+ else if "char_" `isPrefixOf` v then True+ else if "string_" `isPrefixOf` v then True+ else if "double_" `isPrefixOf` v then True+ else if "ident_" `isPrefixOf` v then True+ else False+ where+ user' = map (map toLower.show) user++--The visit-function name of a basic type+funName :: String -> String+funName v =+ if "integer_" `isPrefixOf` v then "Integer"+ else if "char_" `isPrefixOf` v then "Char"+ else if "string_" `isPrefixOf` v then "String"+ else if "double_" `isPrefixOf` v then "Double"+ else if "ident_" `isPrefixOf` v then "Ident"+ else (toUpper (head v)) : (init (tail v)) --User-defined type
+ src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs view
@@ -0,0 +1,191 @@+{-+ BNF Converter: Flex generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Flex file. It is+ similar to JLex but with a few peculiarities.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 5 August, 2003++ Modified : 22 August, 2006 by Aarne Ranta+++ **************************************************************+-}+module BNFC.Backend.CPP.NoSTL.CFtoFlex (cf2flex) where++import BNFC.CF+import BNFC.Backend.CPP.NoSTL.RegToFlex+import BNFC.Utils((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import BNFC.Backend.CPP.STL.STLUtils++--The environment must be returned for the parser to use.+cf2flex :: Maybe String -> String -> CF -> (String, SymEnv)+cf2flex inPackage name cf = (unlines+ [+ prelude inPackage name,+ cMacros,+ lexSymbols env,+ restOfFlex inPackage cf env'+ ], env')+ where+ env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)+ env' = env ++ (makeSymEnv (tokenNames cf) (length env))+ makeSymEnv [] _ = []+ makeSymEnv (s:symbs) n = (s, nsDefine inPackage "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))++prelude :: Maybe String -> String -> String+prelude inPackage name = unlines+ [+ maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage,+ "/* This FLex file was machine-generated by the BNF converter */",+ "%{",+ "#include <string.h>",+ "#include \"Parser.H\"",+ "#define YY_BUFFER_LENGTH 4096",+ "extern int " ++ nsString inPackage ++ "yy_mylinenumber ;", --- hack to get line number. AR 2006+ "static char YY_PARSED_STRING[YY_BUFFER_LENGTH];",+ "static void YY_BUFFER_APPEND(char *s)",+ "{",+ " strcat(YY_PARSED_STRING, s); //Do something better here!",+ "}",+ "static void YY_BUFFER_RESET(void)",+ "{",+ " for(int x = 0; x < YY_BUFFER_LENGTH; x++)",+ " YY_PARSED_STRING[x] = 0;",+ "}",+ "",+ "%}"+ ]++--For now all categories are included.+--Optimally only the ones that are used should be generated.+cMacros :: String+cMacros = unlines+ [+ "LETTER [a-zA-Z]",+ "CAPITAL [A-Z]",+ "SMALL [a-z]",+ "DIGIT [0-9]",+ "IDENT [a-zA-Z0-9'_]",+ "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED",+ "%%"+ ]++lexSymbols :: SymEnv -> String+lexSymbols ss = concatMap transSym ss+ where+ transSym (s,r) =+ "<YYINITIAL>\"" ++ s' ++ "\" \t return " ++ r ++ ";\n"+ where+ s' = escapeChars s++restOfFlex :: Maybe String -> CF -> SymEnv -> String+restOfFlex inPackage cf env = concat+ [+ lexComments inPackage (comments cf),+ userDefTokens,+ ifC catString strStates,+ ifC catChar chStates,+ ifC catDouble ("<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"),+ ifC catInteger ("<YYINITIAL>{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"),+ ifC catIdent ("<YYINITIAL>{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"),+ "\\n ++" ++ ns ++ "yy_mylinenumber ;\n",+ "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",+ "<YYINITIAL>. \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n",+ "%%\n",+ footer+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ ns = nsString inPackage+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ printRegFlex exp +++ " \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"+ | (name, exp) <- tokenPragmas cf]+ where+ sName n = case lookup (show n) env of+ Just x -> x+ Nothing -> (show n)+ strStates = unlines --These handle escaped characters in Strings.+ [+ "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",+ "<STRING>\\\\ \t BEGIN ESCAPED;",+ "<STRING>\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";",+ "<STRING>. \t YY_BUFFER_APPEND(yytext);",+ "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",+ "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",+ "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",+ "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",+ "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" \tBEGIN CHAR;",+ "<CHAR>\\\\ \t BEGIN CHARESC;",+ "<CHAR>[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHARESC>n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHARESC>t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHARESC>. \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",+ "<CHAREND>\"'\" \t BEGIN YYINITIAL;"+ ]+ footer = unlines+ [+ "int " ++ ns ++ "initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }",+ "int yywrap(void) { return 1; }"+ ]+++lexComments :: Maybe String -> ([(String, String)], [String]) -> String+lexComments inPackage (m,s) =+ (unlines (map (lexSingleComment inPackage) s))+ ++ (unlines (map (lexMultiComment inPackage) m))++lexSingleComment :: Maybe String -> String -> String+lexSingleComment inPackage c =+ "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC single-line comment */;"++--There might be a possible bug here if a language includes 2 multi-line comments.+--They could possibly start a comment with one character and end it with another.+--However this seems rare.+lexMultiComment :: Maybe String -> (String, String) -> String+lexMultiComment inPackage (b,e) = unlines [+ "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",+ "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",+ "<COMMENT>. \t /* BNFC multi-line comment */;",+ "<COMMENT>[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;"+ ---- "\\n ++yy_mylinenumber ;"+ ]+++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars [] = []+escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))+escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))+escapeChars (x:xs) = x : (escapeChars xs)
+ src/BNFC/Backend/CPP/NoSTL/RegToFlex.hs view
@@ -0,0 +1,73 @@+module BNFC.Backend.CPP.NoSTL.RegToFlex (printRegFlex) where++-- modified from pretty-printer generated by the BNF converter++import AbsBNF+import Data.Char++-- the top-level printing method+printRegFlex :: Reg -> String+printRegFlex = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend (0::Int) where+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""+ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = [[c]]+ prtList s = map (concat . prt 0) s++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["[^.]"])+ RChar c -> prPrec i 3 (prt 0 [mkEsc [c]])+ RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str))+ RDigit -> prPrec i 3 (concat [["{DIGIT}"]])+ RLetter -> prPrec i 3 (concat [["{LETTER}"]])+ RUpper -> prPrec i 3 (concat [["{CAPITAL}"]])+ RLower -> prPrec i 3 (concat [["{SMALL}"]])+ RAny -> prPrec i 3 (concat [["."]])++-- Handle special characters in regular expressions.+mkEsc :: String -> String+mkEsc = concatMap escChar+ where escChar c+ | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c]+ | otherwise = [c]
+ src/BNFC/Backend/CPP/STL.hs view
@@ -0,0 +1,195 @@+{-+ BNF Converter: C++ Main file+ Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer++ Modified from CPPTop to BNFC.Backend.CPP.STL 2006 by Aarne Ranta.++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.CPP.STL (makeCppStl,) where++import BNFC.Options+import qualified BNFC.Backend.Common.Makefile as Makefile+import BNFC.Backend.Base+import BNFC.Backend.CPP.NoSTL.CFtoFlex+import BNFC.Backend.CPP.STL.CFtoBisonSTL+import BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL+import BNFC.Backend.CPP.STL.CFtoSTLAbs+import BNFC.Backend.CPP.STL.CFtoSTLPrinter+import BNFC.Backend.CPP.STL.STLUtils+import BNFC.CF+import BNFC.Utils+import Control.Monad (unless, when)+import Data.Char+import System.Console.GetOpt+import System.Exit (exitFailure)++makeCppStl :: SharedOptions -> CF -> MkFiles ()+makeCppStl opts cf = do+ let (hfile, cfile) = cf2CPPAbs (linenumbers opts) (inPackage opts) name cf+ mkfile "Absyn.H" hfile+ mkfile "Absyn.C" cfile+ let (flex, env) = cf2flex (inPackage opts) name cf+ mkfile (name ++ ".l") flex+ let bison = cf2Bison (linenumbers opts) (inPackage opts) name cf env+ mkfile (name ++ ".y") bison+ let header = mkHeaderFile (inPackage opts) cf (allCats cf) (allEntryPoints cf) env+ mkfile "Parser.H" header+ let (skelH, skelC) = cf2CVisitSkel (inPackage opts) cf+ mkfile "Skeleton.H" skelH+ mkfile "Skeleton.C" skelC+ let (prinH, prinC) = cf2CPPPrinter (inPackage opts) cf+ mkfile "Printer.H" prinH+ mkfile "Printer.C" prinC+ mkfile "Test.C" (cpptest (inPackage opts) cf)+ Makefile.mkMakefile opts $ makefile name+ where name = lang opts++makefile :: String -> String+makefile name =+ (unlines [ "CC = g++", "CCFLAGS = -g", "FLEX = flex", "BISON = bison" ] ++)+ $ Makefile.mkRule "all" [ "Test" ++ name ]+ []+ $ Makefile.mkRule "clean" []+ -- peteg: don't nuke what we generated - move that to the "vclean" target.+ [ "rm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log "+ , "rm -f " ++ name ++ ".pdf Test" ++ name ]+ $ Makefile.mkRule "distclean" []+ [ " rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ++ " Makefile" ]+ $ Makefile.mkRule ("Test" ++ name) [ "Absyn.o", "Lexer.o",+ "Parser.o", "Printer.o", "Test.o" ]+ [ "@echo \"Linking Test" ++ name ++ "...\""+ , "${CC} ${CCFLAGS} *.o -o Test" ++ name ]+ $ Makefile.mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Absyn.C" ]+ $ Makefile.mkRule "Lexer.C" [ name ++ ".l" ]+ [ "${FLEX} -oLexer.C " ++ name ++ ".l" ]+ $ Makefile.mkRule "Parser.C" [ name ++ ".y" ]+ [ "${BISON} " ++ name ++ ".y -o Parser.C" ]+ $ Makefile.mkRule "Lexer.o" [ "Lexer.C", "Parser.H" ]+ [ "${CC} ${CCFLAGS} -c Lexer.C" ]+ $ Makefile.mkRule "Parser.o" [ "Parser.C", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Parser.C" ]+ $ Makefile.mkRule "Printer.o" [ "Printer.C", "Printer.H", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Printer.C" ]+ $ Makefile.mkRule "Skeleton.o" [ "Skeleton.C", "Skeleton.H", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Skeleton.C" ]+ $ Makefile.mkRule "Test.o" [ "Test.C", "Parser.H", "Printer.H", "Absyn.H" ]+ [ "${CC} ${CCFLAGS} -c Test.C" ]+ ""++cpptest :: Maybe String -> CF -> String+cpptest inPackage cf =+ unlines+ [+ "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",+ "/* */",+ "/* This test will parse a file, print the abstract syntax tree, and then */",+ "/* pretty-print the result. */",+ "/* */",+ "/****************************************************************************/",+ "#include <stdio.h>",+ "#include \"Parser.H\"",+ "#include \"Printer.H\"",+ "#include \"Absyn.H\"",+ "",+ "int main(int argc, char ** argv)",+ "{",+ " FILE *input;",+ " if (argc > 1) ",+ " {",+ " input = fopen(argv[1], \"r\");",+ " if (!input)",+ " {",+ " fprintf(stderr, \"Error opening input file.\\n\");",+ " exit(1);",+ " }",+ " }",+ " else input = stdin;",+ " /* The default entry point is used. For other options see Parser.H */",+ " " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);",+ " if (parse_tree)",+ " {",+ " printf(\"\\nParse Succesful!\\n\");",+ " printf(\"\\n[Abstract Syntax]\\n\");",+ " " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();",+ " printf(\"%s\\n\\n\", s->show(parse_tree));",+ " printf(\"[Linearized Tree]\\n\");",+ " " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();",+ " printf(\"%s\\n\\n\", p->print(parse_tree));",+ " return 0;",+ " }",+ " return 1;",+ "}",+ ""+ ]+ where+ def = show (head (allEntryPoints cf))+ scope = nsScope inPackage++mkHeaderFile inPackage cf cats eps env = unlines+ [+ "#ifndef " ++ hdef,+ "#define " ++ hdef,+ "",+ "#include<vector>",+ "#include<string>",+ "",+ nsStart inPackage,+ concatMap mkForwardDec cats,+ "typedef union",+ "{",+ " int int_;",+ " char char_;",+ " double double_;",+ " char* string_;",+ (concatMap mkVar cats) ++ "} YYSTYPE;",+ "",+ concatMap mkFuncs eps,+ nsEnd inPackage,+ "",+ "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258",+ mkDefines (259 :: Int) env,+ "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;",+ "",+ "#endif"+ ]+ where+ hdef = nsDefine inPackage "PARSER_HEADER_FILE"+ mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n"+ mkForwardDec _ = ""+ mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n"+ mkVar _ = ""+ mkDefines n [] = mkString n+ mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv)+ mkString n = if isUsedCat cf catString+ then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)+ else mkChar n+ mkChar n = if isUsedCat cf catChar+ then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)+ else mkInteger n+ mkInteger n = if isUsedCat cf catInteger+ then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)+ else mkDouble n+ mkDouble n = if isUsedCat cf catDouble+ then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)+ else mkIdent n+ mkIdent n = if isUsedCat cf catIdent+ then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n")+ else ""+ mkFuncs s | normCat s == s = identCat s ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);\n" +++ identCat s ++ "*" +++ "p" ++ identCat s ++ "(const char *str);\n"+ mkFuncs _ = ""
+ src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs view
@@ -0,0 +1,372 @@+{-+ BNF Converter: C++ Bison generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Bison input file using+ STL. The main difference to CFtoBison is in handling+ lists: by using std::vector and push_back, our rules+ for reverting lists are the opposite to linked lists.+ Note that because of the way bison stores results+ the programmer can increase performance by limiting+ the number of entry points in their grammar.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 6 August, 2003++ Modified : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se)+++ **************************************************************+-}+++module BNFC.Backend.CPP.STL.CFtoBisonSTL (cf2Bison) where++import BNFC.CF+import Data.List (intersperse, isPrefixOf, nub)+import BNFC.Backend.Common.NamedVariables hiding (varName)+import Data.Char (toLower,isUpper,isDigit)+import BNFC.Utils ((+++), (++++))+import BNFC.TypeChecker+import ErrM+import BNFC.Backend.CPP.STL.STLUtils++--This follows the basic structure of CFtoHappy.++-- Type declarations+type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++--The environment comes from the CFtoFlex+cf2Bison :: Bool -> Maybe String -> String -> CF -> SymEnv -> String+cf2Bison ln inPackage name cf env+ = unlines+ [header inPackage name cf,+ union inPackage (positionCats cf ++ allCats cf),+ maybe "" (\ns -> "%name-prefix=\"" ++ ns ++ "yy\"") inPackage,+ "%token _ERROR_",+ tokens user env,+ declarations cf,+ specialToks cf,+ "%%",+ prRules (rulesForBison ln inPackage name cf env)+ ]+ where+ user = fst (unzip (tokenPragmas cf))+++positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))++header :: Maybe String -> String -> CF -> String+header inPackage name cf = unlines+ ["/* This Bison file was machine-generated by BNFC */",+ "%{",+ "#include <stdlib.h>",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <iostream>",+ "#include <algorithm>",+ "#include \"Absyn.H\"",+ "typedef struct yy_buffer_state *YY_BUFFER_STATE;",+ "int yyparse(void);",+ "int yylex(void);",+ "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);",+ "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);",+ "int " ++ ns ++ "yy_mylinenumber;", --- hack to get line number. AR 2006+ "int " ++ ns ++ "initialize_lexer(FILE * inp);",+ "int " ++ ns ++ "yywrap(void)",+ "{",+ " return 1;",+ "}",+ "void " ++ ns ++ "yyerror(const char *str)",+ "{",+ " std::cout << \"line \" << " ++ ns ++ "yy_mylinenumber << std::endl ;",+ " fprintf(stderr,\"error: %s\\n\",str);",+ "}",+ "",+ definedRules cf,+ nsStart inPackage,+ unlines $ map (parseMethod inPackage name) (allCatsNorm cf ++ positionCats cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.+ nsEnd inPackage,+ "%}"+ ]+ where+ ns = nsString inPackage++definedRules :: CF -> String+definedRules cf =+ unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]+ where+ ctx = buildContext cf++ list = LC (const "[]") (\t -> "List" ++ unBase t)+ where+ unBase (ListT t) = unBase t+ unBase (BaseT x) = show $ normCat $ strToCat x++ rule f xs e =+ case checkDefinition' list ctx f xs e of+ Bad err -> error $ "Panic! This should have been caught already:\n" ++ err+ Ok (args,(e',t)) -> unlines+ [ cppType t ++ " " ++ f ++ "_ (" +++ concat (intersperse ", " $ map cppArg args) ++ ") {"+ , " return " ++ cppExp e' ++ ";"+ , "}"+ ]+ where++ cppType :: Base -> String+ cppType (ListT (BaseT x)) = "List" ++ show (normCat $ strToCat x) ++ " *"+ cppType (ListT t) = cppType t ++ " *"+ cppType (BaseT x)+ | isToken x ctx = "String"+ | otherwise = (show $ normCat $ strToCat x) ++ " *"++ cppArg :: (String, Base) -> String+ cppArg (x,t) = cppType t ++ " " ++ x ++ "_"++ cppExp :: Exp -> String+ cppExp (App "[]" []) = "0"+ cppExp (App x [])+ | elem x xs = x ++ "_" -- argument+ cppExp (App t [e])+ | isToken t ctx = cppExp e+ cppExp (App x es)+ | isUpper (head x) = call ("new " ++ x) es+ | otherwise = call (x ++ "_") es+ cppExp (LitInt n) = show n+ cppExp (LitDouble x) = show x+ cppExp (LitChar c) = show c+ cppExp (LitString s) = show s++ call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"+++--This generates a parser method for each entry point.+parseMethod :: Maybe String -> String -> Cat -> String+parseMethod inPackage name cat =+ -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm+ -- then ""+ -- else+ unlines+ [+ "static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;",+ cat' ++"* p" ++ cat' ++ "(FILE *inp)",+ "{",+ " " ++ ns ++ "yy_mylinenumber = 1;", -- O.F.+ " " ++ ns ++ "initialize_lexer(inp);",+ " if (yyparse())",+ " { /* Failure */",+ " return 0;",+ " }",+ " else",+ " { /* Success */",+ " return" +++ (resultName cat') ++ ";",+ " }",+ "}",+ cat' ++"* p" ++ cat' ++ "(const char *str)",+ "{",+ " YY_BUFFER_STATE buf;",+ " int result;",+ " " ++ ns ++ "yy_mylinenumber = 1;",+ " " ++ ns ++ "initialize_lexer(0);",+ " buf = " ++ ns ++ "yy_scan_string(str);",+ " result = yyparse();",+ " " ++ ns ++ "yy_delete_buffer(buf);",+ " if (result)",+ " { /* Failure */",+ " return 0;",+ " }",+ " else",+ " { /* Success */",+ " return" +++ (resultName cat') ++ ";",+ " }",+ "}"+ ]+ where+ cat' = identCat (normCat cat)+ ns = nsString inPackage+++--The union declaration is special to Bison/Yacc and gives the type of yylval.+--For efficiency, we may want to only include used categories here.+union :: Maybe String -> [Cat] -> String+union inPackage cats = unlines+ [+ "%union",+ "{",+ " int int_;",+ " char char_;",+ " double double_;",+ " char* string_;",+ concatMap mkPointer cats,+ "}"+ ]+ where --This is a little weird because people can make [Exp2] etc.+ mkPointer s | identCat s /= show s = --list. add it even if it refers to a coercion.+ " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName s) ++ ";\n"+ mkPointer s | normCat s == s = --normal cat+ " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName s) ++ ";\n"+ mkPointer s = ""+ scope = nsScope inPackage++--declares non-terminal types.+declarations :: CF -> String+declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf)+ where --don't define internal rules+ typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName nt) ++ "> " ++ (identCat nt) ++ "\n"+ typeNT cf nt = ""++--declares terminal types.+tokens :: [UserDef] -> SymEnv -> String+tokens user ts = concatMap (declTok user) ts+ where+ declTok u (s,r) = if elem s (map show u)+ then "%token<string_> " ++ r ++ " // " ++ s ++ "\n"+ else "%token " ++ r ++ " // " ++ s ++ "\n"++specialToks :: CF -> String+specialToks cf = concat [+ ifC catString "%token<string_> _STRING_\n",+ ifC catChar "%token<char_> _CHAR_\n",+ ifC catInteger "%token<int_> _INTEGER_\n",+ ifC catDouble "%token<double_> _DOUBLE_\n",+ ifC catIdent "%token<string_> _IDENT_\n"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""++--The following functions are a (relatively) straightforward translation+--of the ones in CFtoHappy.hs+rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules+rulesForBison ln inPackage name cf env = (map mkOne $ ruleGroups cf) ++ posRules where+ mkOne (cat,rules) = constructRule ln inPackage cf env rules cat+ posRules = map mkPos $ positionCats cf+ mkPos cat = (cat, [(maybe (show cat) id (lookup (show cat) env),+ "$$ = new " ++ show cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" +++ show cat ++ "_= $$ ;")])++-- For every non-terminal, we construct a set of rules.+constructRule ::+ Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule ln inPackage cf env rules nt =+ (nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf env r b])+ where+ ruleName r = case funRule r of+ ---- "(:)" -> identCat nt+ ---- "(:[])" -> identCat nt+ z -> z+ revs = reversibleCats cf+ eps = allEntryPoints cf+ isEntry nt = if elem nt eps then True else False+ result = if isEntry nt then (nsScope inPackage ++ resultName (identCat (normCat nt))) ++ "= $$;" else ""++-- Generates a string containing the semantic action.+generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action+generateAction ln inPackage cat f b mbs =+ reverses +++ if isCoercion f+ then "$$ = " ++ (unwords ms) ++ ";"+ else if (f == "[]")+ then concat ["$$ = ","new ", scope, identCatV cat, "();"]+ else if (f == "(:[])")+ then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"]+ else if (f == "(:)" && b)+ then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;"+ else if (f == "(:)")+ then lastms ++ "->push_back(" ++ head ms ++ ") ; $$ = " ++ lastms ++ " ;" ---- not left rec+ else if isDefinedRule f+ then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms, ");" ]+ else concat+ ["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms)), ");" ++ addLn ln]+ where+ ms = map fst mbs+ lastms = last ms+ addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else "" -- O.F.+ identCatV = identCat . normCat+ reverses = unwords [+ "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" |+ (m,True) <- mbs]+ scope = nsScope inPackage++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal+generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])+generatePatterns cf env r revv = case rhsRule r of+ [] -> ("/* empty */",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> case lookup (show c) env of+ Just x | not (isPositionCat cf c) -> x+ _ -> typeName (identCat c)+ Right s -> case lookup s env of+ Just x -> x+ Nothing -> s+ metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]++ -- notice: reversibility with push_back vectors is the opposite+ -- of right-recursive lists!+ revert c = (isList c) &&+ not (isConsFun (funRule r)) && notElem c revs+ revs = reversibleCats cf++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.++prRules :: Rules -> String+prRules [] = []+prRules ((nt, []):rs) = prRules rs --internal rule+prRules ((nt,((p,a):ls)):rs) =+ (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls++--Some helper functions.+resultName :: String -> String+resultName s = "YY_RESULT_" ++ s ++ "_"++--slightly stronger than the NamedVariable version.+varName :: Cat -> String+varName = (++ "_") . map toLower . identCat . normCat++typeName :: String -> String+typeName "Ident" = "_IDENT_"+typeName "String" = "_STRING_"+typeName "Char" = "_CHAR_"+typeName "Integer" = "_INTEGER_"+typeName "Double" = "_DOUBLE_"+typeName x = x++
+ src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs view
@@ -0,0 +1,148 @@+{-+ BNF Converter: C++ Skeleton generation+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C++ Skeleton functions.++ The generated files use the Visitor design pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 9 August, 2003++ Modified : 29 August, 2006 Aarne Ranta+++ **************************************************************+-}++module BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL (cf2CVisitSkel) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper)+import BNFC.Backend.Common.OOAbstract+import BNFC.Backend.CPP.STL.STLUtils++--Produces (.H file, .C file)+cf2CVisitSkel :: Maybe String -> CF -> (String, String)+cf2CVisitSkel inPackage cf = (mkHFile inPackage cab, mkCFile inPackage cab)+ where+ cab = cf2cabs cf++-- **** Header (.H) File Functions ****++--Generates the Header File+mkHFile :: Maybe String -> CAbs -> String+mkHFile inPackage cf = unlines [+ "#ifndef " ++ hdef,+ "#define " ++ hdef,+ "/* You might want to change the above name. */",+ "",+ "#include \"Absyn.H\"",+ "",+ nsStart inPackage,+ "class Skeleton : public Visitor",+ "{",+ "public:",+ unlines [" void visit" ++ b ++ "(" ++ b ++ "* p);" |+ b <- classes, notElem b (defineds cf)],+ unlines [" void visit" ++ show b ++ "(" ++ show b ++ " x);" | b <- basics],+ "};",+ nsEnd inPackage,+ "",+ "#endif"+ ]+ where+ hdef = nsDefine inPackage "SKELETON_HEADER"+ classes = allClasses cf+ basics = tokentypes cf ++ map fst basetypes+++-- **** Implementation (.C) File Functions ****++--Makes the .C File+mkCFile :: Maybe String -> CAbs -> String+mkCFile inPackage cf = unlines [+ headerC,+ nsStart inPackage,+ unlines [+ "void Skeleton::visit" ++ t ++ "(" +++ t ++ "* t) {} //abstract class" | t <- absclasses cf],+ unlines [prCon r | (_,rs) <- signatures cf, r <- rs],+ unlines [prList cb | cb <- listtypes cf],+ unlines [prBasic b | b <- tokentypes cf ++ map fst basetypes],+ nsEnd inPackage+ ]++headerC = unlines [+ "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",+ "/* This implements the common visitor design pattern.",+ " Note that this method uses Visitor-traversal of lists, so",+ " List->accept() does NOT traverse the list. This allows different",+ " algorithms to use context information differently. */",+ "",+ "#include \"Skeleton.H\"",+ ""+ ]++prBasic c = unlines [+ "void Skeleton::visit" ++ c ++ "(" ++ c ++ " x)",+ "{",+ " /* Code for " ++ c ++ " Goes Here */",+ "}"+ ]++prList (cl,b) = unlines [+ "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")",+ "{",+ " for ("++ cl ++"::iterator i = " +++ vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",+ " {",+ if b+ then " (*i)->accept(this);"+ else " visit" ++ drop 4 cl ++ "(*i) ;",+ " }",+ "}"+ ]+ where+ vname = map toLower cl++prCon fcs@(f,cs) = unlines [+ "void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")",+ "{",+ " /* Code For " ++ f ++ " Goes Here */",+ "",+ unlines [" " ++ visitArg c | c <- cs],+ "}"+ ]+ where+ v = map toLower f+ visitArg (cat,isPt,var) =+ if isPt+ then (v ++ "->" ++ var ++ "->accept(this);")+ else ("visit" ++ cat ++ "(" ++ v ++ "->" ++ var ++ ");")+
+ src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs view
@@ -0,0 +1,275 @@+{-+ BNF Converter: C++ abstract syntax generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C++ Abstract Syntax+ tree classes. It generates both a Header file+ and an Implementation file, and uses the Visitor+ design pattern. It uses STL (Standard Template Library).++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 4 August, 2003++ Modified : 22 May, 2004 / Antti-Juhani Kaijanaho+ 29 August, 2006 / Aarne Ranta++ **************************************************************+-}++module BNFC.Backend.CPP.STL.CFtoSTLAbs (cf2CPPAbs) where++import BNFC.Backend.Common.OOAbstract+import BNFC.CF+import BNFC.Utils((+++),(++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower)+import BNFC.Backend.CPP.STL.STLUtils++--The result is two files (.H file, .C file)++cf2CPPAbs :: Bool -> Maybe String -> String -> CF -> (String, String)+cf2CPPAbs ln inPackage name cf = (mkHFile ln inPackage cab, mkCFile inPackage cab)+ where+ cab = cf2cabs cf+++-- **** Header (.H) File Functions **** --++--Makes the Header file.+mkHFile :: Bool -> Maybe String -> CAbs -> String+mkHFile ln inPackage cf = unlines+ [+ "#ifndef " ++ hdef,+ "#define " ++ hdef,+ "",+ "#include<string>",+ "#include<vector>",+ "",+ "//C++ Abstract Syntax Interface generated by the BNF Converter.",+ nsStart inPackage,+ "/******************** TypeDef Section ********************/",+ "",+ unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes],+ "",+ unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf],+ "",+ "/******************** Forward Declarations ********************/",+ "",+ unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)],+ "",+ "/******************** Visitor Interfaces ********************/",+ prVisitor cf,+ "",+ prVisitable,+ "",+ "/******************** Abstract Syntax Classes ********************/",+ "",+ unlines [prAbs ln c | c <- absclasses cf],+ "",+ unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs],+ "",+ unlines [prList c | c <- listtypes cf],+ nsEnd inPackage,+ "#endif"+ ]+ where+ classes = allClasses cf+ hdef = nsDefine inPackage "ABSYN_HEADER"++-- auxiliaries++prVisitable :: String+prVisitable = unlines [+ "class Visitable",+ "{",+ " public:",+ -- all classes with virtual methods require a virtual destructor+ " virtual ~Visitable() {}",+ " virtual void accept(Visitor *v) = 0;",+ "};"+ ]++prVisitor :: CAbs -> String+prVisitor cf = unlines [+ "class Visitor",+ "{",+ "public:",+ " virtual ~Visitor() {}",+ unlines+ [" virtual void visit"++c++"("++c++" *p) = 0;" | c <- allClasses cf,+ notElem c (defineds cf)],+ "",+ unlines+ [" virtual void visit"++c++"(" ++c++" x) = 0;" | c <- allNonClasses cf],+ "};"+ ]++prAbs :: Bool -> String -> String+prAbs ln c = unlines [+ "class " ++ c ++ " : public Visitable",+ "{",+ "public:",+ " virtual " ++ c ++ " *clone() const = 0;",+ if ln then " int line_number;" else "",+ "};"+ ]++prCon :: (String, CAbsRule) -> String+prCon (c,(f,cs)) = unlines [+ "class " ++f++ " : public " ++ c,+ "{",+ "public:",+ unlines+ [" "++ typ +++ pointerIf st var ++ ";" | (typ,st,var) <- cs],+ " " ++ f ++ "(const " ++ f ++ " &);",+ " " ++ f ++ " &operator=(const " ++f++ " &);",+ " " ++ f ++ "(" ++ conargs ++ ");",+ -- Typ *p1, PIdent *p2, ListStm *p3);+ " ~" ++f ++ "();",+ " virtual void accept(Visitor *v);",+ " virtual " ++f++ " *clone() const;",+ " void swap(" ++f++ " &);",+ "};"+ ]+ where+ conargs = concat $ intersperse ", "+ [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]]++prList :: (String,Bool) -> String+prList (c,b) = unlines [+ "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">",+ "{",+ "public:",+ " virtual void accept(Visitor *v);",+ " virtual " ++ c ++ " *clone() const;",+ "};"+ ]+ where+ bas = drop 4 c ++ -- drop List+ if b then "*" else ""+++-- **** Implementation (.C) File Functions **** --++mkCFile :: Maybe String -> CAbs -> String+mkCFile inPackage cf = unlines $ [+ "//C++ Abstract Syntax Implementation generated by the BNF Converter.",+ "#include <algorithm>",+ "#include <string>",+ "#include <iostream>",+ "#include <vector>",+ "#include \"Absyn.H\"",+ nsStart inPackage,+ unlines [prConC r | (_,rs) <- signatures cf, r <- rs],+ unlines [prListC c | (c,_) <- listtypes cf],+ nsEnd inPackage+ ]++prConC :: CAbsRule -> String+prConC fcs@(f,cs) = unlines [+ "/******************** " ++ f ++ " ********************/",+ prConstructorC fcs,+ prCopyC fcs,+ prDestructorC fcs,+ prAcceptC f,+ prCloneC f,+ ""+ ]++prListC :: String -> String+prListC c = unlines [+ "/******************** " ++ c ++ " ********************/",+ "",+ prAcceptC c,+ "",+ prCloneC c+ ]+++--The standard accept function for the Visitor pattern+prAcceptC :: String -> String+prAcceptC ty = unlines [+ "void " ++ ty ++ "::accept(Visitor *v)",+ "{",+ " v->visit" ++ ty ++ "(this);",+ "}"+ ]++--The cloner makes a new deep copy of the object+prCloneC :: String -> String+prCloneC c = unlines [+ c +++ "*" ++ c ++ "::clone() const",+ "{",+ " return new" +++ c ++ "(*this);",+ "}"+ ]++--The constructor assigns the parameters to the corresponding instance variables.+prConstructorC :: CAbsRule -> String+prConstructorC (f,cs) = unlines [+ f ++ "::" ++ f ++ "(" ++ conargs ++ ")",+ "{",+ unlines [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs],+ "}"+ ]+ where+ cvs = [c | (_,_,c) <- cs]+ pvs = ["p" ++ show i | ((x,st,_),i) <- zip cs [1..]]+ conargs = concat $ intersperse ", "+ [x +++ pointerIf st v | ((x,st,_),v) <- zip cs pvs]+++--Copy constructor and copy assignment+prCopyC :: CAbsRule -> String+prCopyC (c,cs) = unlines [+ c ++ "::" ++ c ++ "(const" +++ c +++ "& other)",+ "{",+ unlines [" " ++ cv ++ " = other." ++ cloneIf st cv ++ ";" | (_,st,cv) <- cs],+ "}",+ "",+ c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other)",+ "{",+ " " ++ c +++ "tmp(other);",+ " swap(tmp);",+ " return *this;",+ "}",+ "",+ "void" +++ c ++ "::swap(" ++ c +++ "& other)",+ "{",+ unlines [" std::swap(" ++ cv ++ ", other." ++ cv ++ ");" | (_,_,cv) <- cs],+ "}"+ ]+ where+ cloneIf st cv = if st then (cv ++ "->clone()") else cv++--The destructor deletes all a class's members.+prDestructorC :: CAbsRule -> String+prDestructorC (c,cs) = unlines [+ c ++ "::~" ++ c ++"()",+ "{",+ unlines [" delete(" ++ cv ++ ");" | (_,isPointer,cv) <- cs, isPointer],+ "}"+ ]
+ src/BNFC/Backend/CPP/STL/CFtoSTLPrinter.hs view
@@ -0,0 +1,648 @@+{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C++ Pretty Printer.+ It also generates the "show" method for+ printing an abstract syntax tree.++ The generated files use the Visitor design pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 10 August, 2003++ Modified : 3 September, 2003+ * Added resizable buffers++ **************************************************************+-}++module BNFC.Backend.CPP.STL.CFtoSTLPrinter (cf2CPPPrinter) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.Common.StrUtils (renderCharOrString)+import Data.List+import Data.Char(toLower, toUpper)+import BNFC.Backend.CPP.STL.STLUtils++--Produces (.H file, .C file)+cf2CPPPrinter :: Maybe String -> CF -> (String, String)+cf2CPPPrinter inPackage cf = (mkHFile inPackage cf groups, mkCFile inPackage cf groups)+ where+ groups = positionRules cf ++ (fixCoercions (ruleGroupsInternals cf))++positionRules :: CF -> [(Cat,[Rule])]+positionRules cf =+ [(cat,[Rule (show cat) cat [Left catString, Left catInteger]]) |+ cat <- filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))]++{- **** Header (.H) File Methods **** -}++--An extremely large function to make the Header File+mkHFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String+mkHFile inPackage cf groups = unlines+ [+ printHeader,+ concatMap prDataH groups,+ classFooter,+ showHeader,+ concatMap prDataH groups,+ classFooter,+ footer+ ]+ where+ printHeader = unlines+ [+ "#ifndef " ++ hdef,+ "#define " ++ hdef,+ "",+ "#include \"Absyn.H\"",+ "#include <stdio.h>",+ "#include <string.h>",+ "#include <stdlib.h>",+ "",+ nsStart inPackage,+ "/* Certain applications may improve performance by changing the buffer size */",+ "#define " ++ nsDefine inPackage "BUFFER_INITIAL" ++ " 2000",+ "/* You may wish to change _L_PAREN or _R_PAREN */",+ "#define " ++ nsDefine inPackage "_L_PAREN" ++ " '('",+ "#define " ++ nsDefine inPackage "_R_PAREN" ++ " ')'",+ "",+ "class PrintAbsyn : public Visitor",+ "{",+ " protected:",+ " int _n_, _i_;",+ " /* The following are simple heuristics for rendering terminals */",+ " /* You may wish to change them */",+ " void render(Char c);",+ " void render(String s);",+ " void indent(void);",+ " void backup(void);",+ " public:",+ " PrintAbsyn(void);",+ " ~PrintAbsyn(void);",+ " char* print(Visitable* v);"+ ]+ hdef = nsDefine inPackage "PRINTER_HEADER"+ classFooter = unlines $+ [+ " void visitInteger(Integer i);",+ " void visitDouble(Double d);",+ " void visitChar(Char c);",+ " void visitString(String s);",+ " void visitIdent(String s);"+ ] ++ [" void visit" ++ t ++ "(String s);" | t <- tokenNames cf] +++ [+ " protected:",+ " void inline bufAppend(const char* s)",+ " {",+ " int len = strlen(s);",+ " while (cur_ + len > buf_size)",+ " {",+ " buf_size *= 2; /* Double the buffer size */",+ " resizeBuffer();",+ " }",+ " for(int n = 0; n < len; n++)",+ " {",+ " buf_[cur_ + n] = s[n];",+ " }",+ " cur_ += len;",+ " buf_[cur_] = 0;",+ " }",+ " void inline bufAppend(const char c)",+ " {",+ " if (cur_ == buf_size)",+ " {",+ " buf_size *= 2; /* Double the buffer size */",+ " resizeBuffer();",+ " }",+ " buf_[cur_] = c;",+ " cur_++;",+ " buf_[cur_] = 0;",+ " }",+ " void inline bufReset(void)",+ " {",+ " cur_ = 0;",+ " buf_size = " ++ nsDefine inPackage "BUFFER_INITIAL" ++ ";",+ " resizeBuffer();",+ " memset(buf_, 0, buf_size);",+ " }",+ " void inline resizeBuffer(void)",+ " {",+ " char* temp = (char*) malloc(buf_size);",+ " if (!temp)",+ " {",+ " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",+ " exit(1);",+ " }",+ " if (buf_)",+ " {",+ " strcpy(temp, buf_);",+ " free(buf_);",+ " }",+ " buf_ = temp;",+ " }",+ " char *buf_;",+ " int cur_, buf_size;",+ "};",+ ""+ ]+ showHeader = unlines+ [+ "",+ "class ShowAbsyn : public Visitor",+ "{",+ " public:",+ " ShowAbsyn(void);",+ " ~ShowAbsyn(void);",+ " char* show(Visitable* v);"+ ]+ footer = unlines+ [+ nsEnd inPackage,+ "",+ "#endif"+ ]++--Prints all the required method names and their parameters.+prDataH :: (Cat, [Rule]) -> String+prDataH (cat, rules) =+ if isList cat+ then concat [" void visit", cl, "(", cl, "* p);\n"]+ else abstract ++ (concatMap prRuleH rules)+ where+ cl = identCat (normCat cat)+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n"++--Prints all the methods to visit a rule.+prRuleH :: Rule -> String+prRuleH (Rule fun c cats) | isProperLabel fun = concat+ [" void visit", fun, "(", fun, " *p);\n"]+prRuleH _ = ""++{- **** Implementation (.C) File Methods **** -}++--This makes the .C file by a similar method.+mkCFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String+mkCFile inPackage cf groups = concat+ [+ header,+ nsStart inPackage ++ "\n",+ prRender,+ printEntries,+ concatMap (prPrintData inPackage cf user) groups,+ printBasics,+ printTokens,+ showEntries,+ concatMap (prShowData user) groups,+ showBasics,+ showTokens,+ nsEnd inPackage ++ "\n"+ ]+ where+ user0 = fst (unzip (tokenPragmas cf))+ (userPos,user) = partition (isPositionCat cf) user0+ header = unlines+ [+ "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",+ "",+ "#include <string>",+ "#include \"Printer.H\"",+ ""+ ]+ printEntries = unlines+ [+ "PrintAbsyn::PrintAbsyn(void)",+ "{",+ " _i_ = 0; _n_ = 0;",+ " buf_ = 0;",+ " bufReset();",+ "}",+ "",+ "PrintAbsyn::~PrintAbsyn(void)",+ "{",+ "}",+ "",+ "char* PrintAbsyn::print(Visitable *v)",+ "{",+ " _i_ = 0; _n_ = 0;",+ " bufReset();",+ " v->accept(this);",+ " return buf_;",+ "}"+ ]+ showEntries = unlines+ [+ "ShowAbsyn::ShowAbsyn(void)",+ "{",+ " buf_ = 0;",+ " bufReset();",+ "}",+ "",+ "ShowAbsyn::~ShowAbsyn(void)",+ "{",+ "}",+ "",+ "char* ShowAbsyn::show(Visitable *v)",+ "{",+ " bufReset();",+ " v->accept(this);",+ " return buf_;",+ "}"+ ]+ printBasics = unlines+ [+ "void PrintAbsyn::visitInteger(Integer i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%d\", i);",+ " bufAppend(tmp);",+ "}",+ "void PrintAbsyn::visitDouble(Double d)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%g\", d);",+ " bufAppend(tmp);",+ "}",+ "void PrintAbsyn::visitChar(Char c)",+ "{",+ " bufAppend('\\'');",+ " bufAppend(c);",+ " bufAppend('\\'');",+ "}",+ "void PrintAbsyn::visitString(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ "void PrintAbsyn::visitIdent(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " render(s);",+ "}",+ ""+ ]++ printTokens = unlines+ [unlines [+ "void PrintAbsyn::visit" ++ t ++ "(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " render(s);",+ "}",+ ""+ ] | t <- tokenNames cf+ ]++ showBasics = unlines+ [+ "void ShowAbsyn::visitInteger(Integer i)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%d\", i);",+ " bufAppend(tmp);",+ "}",+ "void ShowAbsyn::visitDouble(Double d)",+ "{",+ " char tmp[16];",+ " sprintf(tmp, \"%g\", d);",+ " bufAppend(tmp);",+ "}",+ "void ShowAbsyn::visitChar(Char c)",+ "{",+ " bufAppend('\\'');",+ " bufAppend(c);",+ " bufAppend('\\'');",+ "}",+ "void ShowAbsyn::visitString(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ "void ShowAbsyn::visitIdent(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ ""+ ]++ showTokens = unlines+ [unlines [+ "void ShowAbsyn::visit" ++ t ++ "(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " bufAppend('\\\"');",+ " bufAppend(s);",+ " bufAppend('\\\"');",+ "}",+ ""+ ] | t <- tokenNames cf+ ]+++{- **** Pretty Printer Methods **** -}++--Generates methods for the Pretty Printer+prPrintData :: Maybe String -> CF -> [UserDef] -> (Cat, [Rule]) -> String+prPrintData inPackage cf user (cat, rules) =+ if isList cat+ then unlines+ [+ "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",+ "{",+ " for ("++ cl ++"::const_iterator i = " +++ vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",+ " {",+ if isBase user vname+ then " visit" ++ baseName cl ++ "(*i) ;"+ else " (*i)->accept(this);",+ optsep,+ " }",+ "}",+ ""+ ] --Not a list:+ -- a position token+ else if isPositionCat cf cat then unlines [+ "void PrintAbsyn::visit" ++ show cat ++ "(" ++ show cat ++ "* p)",+ "{",+ " visitIdent(p->string_);",+ "}"+ ]+ else abstract ++ (concatMap (prPrintRule inPackage user) rules)+ where+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl ++ "_"+ visitMember = if isBasic user member+ then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"+ else " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ sep = snd (renderCharOrString sep')+ sep' = getCons rules+ optsep =+ (if hasOneFunc rules+ then " if (i != " ++ vname ++ "->end() - 1) "+ else " "+ ) ++ "render(" ++ sep ++ ");"+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n"++--Pretty Printer methods for a rule.+prPrintRule :: Maybe String -> [UserDef] -> Rule -> String+prPrintRule inPackage user r@(Rule fun c cats) | isProperLabel fun = unlines+ [+ "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",+ "{",+ " int oldi = _i_;",+ lparen,+ cats',+ rparen,+ " _i_ = oldi;",+ "}\n"+ ]+ where+ p = precRule r+ (lparen, rparen) =+ (" if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n",+ " if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n")+ cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)))+ fnm = "p" --old names could cause conflicts+ getPrec (Right s) = 0+ getPrec (Left c) = precCat c+prPrintRule _ _ _ = ""++--This goes on to recurse to the instance variables.+prPrintCat :: [UserDef] -> String -> (Either String String, Integer) -> String+prPrintCat user fnm (c,p) = case c of+ (Right t) -> " render(" ++ t' ++ ");\n"+ where+ t' = snd (renderCharOrString t)+ (Left nt) -> if isBasic user nt+ then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"+ else if "list" `isPrefixOf` nt+ then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}"+ else " " ++ accept ++ "\n"+ where+ accept = if nt == "#_" --Internal category+ then "/* Internal Category */\n"+ else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);"++{- **** Abstract Syntax Tree Printer **** -}++--This prints the functions for Abstract Syntax tree printing.+prShowData :: [UserDef] -> (Cat, [Rule]) -> String+prShowData user (cat, rules) =+ if isList cat+ then unlines+ [+ "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",+ "{",+ " for ("++ cl ++"::const_iterator i = " +++ vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",+ " {",+ if isBase user vname+ then " visit" ++ baseName cl ++ "(*i) ;"+ else " (*i)->accept(this);",+ " if (i != " ++ vname ++ "->end() - 1) bufAppend(\", \");",+ " }",+ "}",+ ""+ ] --Not a list:+ else abstract ++ (concatMap (prShowRule user) rules)+ where+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl ++ "_"+ visitMember = if isBasic user member+ then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"+ else " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ abstract = case lookupRule (show cat) rules of+ Just x -> ""+ Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n"++--This prints all the methods for Abstract Syntax tree rules.+prShowRule :: [UserDef] -> Rule -> String+prShowRule user (Rule fun c cats) | isProperLabel fun = concat+ [+ "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n",+ "{\n",+ lparen,+ " bufAppend(\"" ++ fun ++ "\");\n",+ optspace,+ cats',+ rparen,+ "}\n"+ ]+ where+ (optspace, lparen, rparen) = if allTerms cats+ then ("","","")+ else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n")+ cats' = if allTerms cats+ then ""+ else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats))))+ insertSpaces [] = []+ insertSpaces (x:[]) = [x]+ insertSpaces (x:xs) = if x == ""+ then insertSpaces xs+ else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs)+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+ fnm = "p" --other names could cause conflicts+prShowRule _ _ = ""++--This recurses to the instance variables of a class.+prShowCat :: [UserDef] -> String -> Either String String -> String+prShowCat user fnm c =+ case c of+ (Right t) -> ""+ (Left nt) ->+ if isBasic user nt+ then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"+ else if nt == "#_" --internal category+ then "/* Internal Category */\n"+ else if ((show $normCat$strToCat nt) /= nt)+ then accept+ else concat+ [+ " bufAppend('[');\n",+ " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept,+ " bufAppend(']');\n"+ ]+ where+ accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n"++{- **** Helper Functions Section **** -}+++--Just checks if something is a basic or user-defined type.+--This is because you don't -> a basic non-pointer type.+isBasic :: [UserDef] -> String -> Bool+isBasic user v =+ if elem (init v) user'+ then True+ else if "integer_" `isPrefixOf` v then True+ else if "char_" `isPrefixOf` v then True+ else if "string_" `isPrefixOf` v then True+ else if "double_" `isPrefixOf` v then True+ else if "ident_" `isPrefixOf` v then True+ else False+ where+ user' = map (map toLower.show) user++-- from listident to ident_+isBase user vn = isBasic user (baseName vn ++ "_")+-- from ListIdent to Ident+baseName cl = drop 4 cl+++--The visit-function name of a basic type+funName :: String -> String+funName v =+ if "integer_" `isPrefixOf` v then "Integer"+ else if "char_" `isPrefixOf` v then "Char"+ else if "string_" `isPrefixOf` v then "String"+ else if "double_" `isPrefixOf` v then "Double"+ else if "ident_" `isPrefixOf` v then "Ident"+ else "Ident" --User-defined type++--Just sets the coercion level for parentheses in the Pretty Printer.+setI :: Integer -> String+setI n = "_i_ = " ++ (show n) ++ "; "++--An extremely simple renderer for terminals.+prRender :: String+prRender = unlines+ [+ "//You may wish to change render",+ "void PrintAbsyn::render(Char c)",+ "{",+ " if (c == '{')",+ " {",+ " bufAppend('\\n');",+ " indent();",+ " bufAppend(c);",+ " _n_ = _n_ + 2;",+ " bufAppend('\\n');",+ " indent();",+ " }",+ " else if (c == '(' || c == '[')",+ " bufAppend(c);",+ " else if (c == ')' || c == ']')",+ " {",+ " backup();",+ " bufAppend(c);",+ " bufAppend(' ');",+ " }",+ " else if (c == '}')",+ " {",+ " _n_ = _n_ - 2;",+ " backup();",+ " backup();",+ " bufAppend(c);",+ " bufAppend('\\n\');",+ " indent();",+ " }",+ " else if (c == ',')",+ " {",+ " backup();",+ " bufAppend(c);",+ " bufAppend(' ');",+ " }",+ " else if (c == ';')",+ " {",+ " backup();",+ " bufAppend(c);",+ " bufAppend('\\n');",+ " indent();",+ " }",+ " else if (c == 0) return;",+ " else",+ " {",+ " bufAppend(c);",+ " bufAppend(' ');",+ " }",+ "}",+ "void PrintAbsyn::render(String s_)",+ "{",+ " const char *s = s_.c_str() ;",+ " if(strlen(s) > 0)",+ " {",+ " bufAppend(s);",+ " bufAppend(' ');",+ " }",+ "}",+ "void PrintAbsyn::indent()",+ "{",+ " int n = _n_;",+ " while (n > 0)",+ " {",+ " bufAppend(' ');",+ " n--;",+ " }",+ "}",+ "void PrintAbsyn::backup()",+ "{",+ " if (buf_[cur_ - 1] == ' ')",+ " {",+ " buf_[cur_ - 1] = 0;",+ " cur_--;",+ " }",+ "}"+ ]
+ src/BNFC/Backend/CPP/STL/STLUtils.hs view
@@ -0,0 +1,37 @@+{-+ BNF Converter: C++ common functions+ Copyright (C) 2008 Author: Martin Ejdestig++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.CPP.STL.STLUtils where++import Data.Char++nsDefine :: Maybe String -> String -> String+nsDefine inPackage h = maybe h (\ns -> map toUpper ns ++ "_" ++ h) inPackage++nsStart :: Maybe String -> String+nsStart inPackage = maybe "" (\ns -> "namespace " ++ ns ++ "\n{") inPackage++nsEnd :: Maybe String -> String+nsEnd inPackage = maybe "" (\ns -> "}") inPackage++nsScope :: Maybe String -> String+nsScope inPackage = maybe "" (\ns -> ns ++ "::") inPackage++nsString :: Maybe String -> String+nsString inPackage = maybe "" id inPackage
+ src/BNFC/Backend/CSharp.hs view
@@ -0,0 +1,348 @@+{-+ BNF Converter: C# Main file+ Copyright (C) 2006-2007 Author: Johan Broberg++ Modified from STLTop 2006.++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+{-+ **************************************************************+ BNF Converter Module++ Description : C# Main file++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 20 November, 2006++ Modified : 8 January, 2007 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp (makeCSharp) where++import BNFC.Utils+import BNFC.CF+import BNFC.Options+import BNFC.Backend.Common.OOAbstract+import BNFC.Backend.Common.Makefile+import BNFC.Backend.Base+import BNFC.Backend.CSharp.CAbstoCSharpAbs+import BNFC.Backend.CSharp.CFtoGPLEX+import BNFC.Backend.CSharp.CFtoGPPG+import BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton+import BNFC.Backend.CSharp.CAbstoCSharpAbstractVisitSkeleton+import BNFC.Backend.CSharp.CFtoCSharpPrinter+import BNFC.Backend.CSharp.CSharpUtils+import Data.Char+import System.Exit (exitFailure)+import System.Environment (getEnv)+import System.Directory+import System.IO+import System.IO.Error (catchIOError)+import System.Process+import Data.Maybe+import Data.Char+import Control.Monad.ST+import Control.Monad (when)+import qualified BNFC.Backend.Common.Makefile as Makefile+import System.FilePath ((<.>),takeFileName)+-- Control.Monad.State++makeCSharp :: SharedOptions -> CF -> MkFiles ()+makeCSharp opts cf = do+ let namespace = fromMaybe (lang opts) maybenamespace+ cabs = cf2cabs cf+ absyn = cabs2csharpabs namespace cabs wcfSupport+ (gplex, env) = cf2gplex namespace cf+ gppg = cf2gppg namespace cf env+ skeleton = cabs2csharpvisitskeleton namespace cabs+ absSkeleton = cabs2csharpAbstractVisitSkeleton namespace cabs+ printer = cf2csharpprinter namespace cf+ mkfile "Absyn.cs" absyn+ mkfile (namespace ++ ".l") gplex+ liftIO $ putStrLn " (Tested with GPLEX RC1)"+ mkfile (namespace ++ ".y") gppg+ liftIO $ putStrLn " (Tested with GPPG 1.0)"+ mkfile "AbstractVisitSkeleton.cs" absSkeleton+ mkfile "VisitSkeleton.cs" skeleton+ mkfile "Printer.cs" printer+ mkfile "Test.cs" (csharptest namespace cf)+ when vsfiles (writeVisualStudioFiles namespace)+ when makefile (writeMakefile opts namespace)+ where makefile = isJust $ make opts+ vsfiles = visualStudio opts+ wcfSupport = wcf opts+ maybenamespace = inPackage opts++writeMakefile :: SharedOptions -> Namespace -> MkFiles ()+writeMakefile opts namespace = do+ mkMakefile opts makefile+ liftIO $ putStrLn ""+ liftIO $ putStrLn "-----------------------------------------------------------------------------"+ liftIO $ putStrLn "Generated Makefile, which uses mono. You may want to modify the paths to"+ liftIO $ putStrLn "GPLEX and GPPG - unless you are sure that they are globally accessible (the"+ liftIO $ putStrLn "default commands are \"mono gplex.exe\" and \"mono gppg.exe\", respectively."+ liftIO $ putStrLn "The Makefile assumes that ShiftReduceParser.dll is located in ./bin and that"+ liftIO $ putStrLn "is also where test.exe will be generated."+ liftIO $ putStrLn "-----------------------------------------------------------------------------"+ liftIO $ putStrLn ""+ where+ makefile =+ (unlines [ "MONO = mono", "MONOC = gmcs"+ , "MONOCFLAGS = -optimize -reference:${PARSERREF}"+ , "GPLEX = ${MONO} gplex.exe", "GPPG = ${MONO} gppg.exe"+ , "PARSERREF = bin/ShiftReduceParser.dll"+ -- Apparently GPLEX outputs filenames in+ -- lowercase, so scanner.cs is supposed to be like that!+ , "CSFILES = Absyn.cs Parser.cs Printer.cs scanner.cs Test.cs VisitSkeleton.cs" ] ++)+ $ Makefile.mkRule "all" [ "test" ]+ []+ $ Makefile.mkRule "clean" []+ -- peteg: don't nuke what we generated - move that to the "vclean" target.+ [ "rm -f " ++ namespace ++ ".pdf test" ]+ $ Makefile.mkRule "distclean" [ "clean" ]+ [ "rm -f ${CSFILES}"+ , "rm -f " ++ unwords [namespace <.> ext | ext <- [ "l","y","tex" ]]+ , "rm -f Makefile" ]+ $ Makefile.mkRule "test" [ "Parser.cs", "Scanner.cs" ]+ [ "@echo \"Compiling test...\""+ , "${MONOC} ${MONOCFLAGS} -out:bin/test.exe ${CSFILES}" ]+ $ Makefile.mkRule "Scanner.cs" [ namespace <.> "l" ]+ [ "${GPLEX} /out:Scanner.cs " ++ namespace <.> "l" ]+ $ Makefile.mkRule "Parser.cs" [ namespace <.> "y" ]+ [ "${GPPG} /gplex " ++ namespace <.> "y > Parser.cs" ]+ ""++writeVisualStudioFiles :: Namespace -> MkFiles ()+writeVisualStudioFiles namespace = do+ guid <- projectguid+ mkfile (namespace ++ ".csproj") (csproj guid)+ mkfile (namespace ++ ".sln") (sln guid)+ mkfile "run-gp.bat" batchfile+ liftIO $ putStrLn ""+ liftIO $ putStrLn "-----------------------------------------------------------------------------"+ liftIO $ putStrLn "Visual Studio solution (.sln) and project (.csproj) files were written."+ liftIO $ putStrLn "The project file has a reference to GPLEX/GPPG's ShiftReduceParser. You will"+ liftIO $ putStrLn "have to either copy this file to bin\\ShiftReduceParser.dll or change the"+ liftIO $ putStrLn "reference so that it points to the right location (you can do this from"+ liftIO $ putStrLn "within Visual Studio)."+ liftIO $ putStrLn "Additionally, the project includes Parser.cs and Scanner.cs. These have not"+ liftIO $ putStrLn "been generated yet. You can use the run-gp.bat file to generate them, but"+ liftIO $ putStrLn "note that it requires gppg and gplex to be in your PATH."+ liftIO $ putStrLn "-----------------------------------------------------------------------------"+ liftIO $ putStrLn ""+ where+ batchfile = unlines [+ "@echo off",+ "gppg /gplex " ++ namespace ++ ".y > Parser.cs",+ "gplex /verbose /out:Scanner.cs " ++ namespace ++ ".l"+ ]+ sln guid = unlines [+ "Microsoft Visual Studio Solution File, Format Version 9.00",+ "# Visual Studio 2005",+ "Project(\"{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}\") = \"" ++ namespace ++ "\", \"" ++ namespace ++ ".csproj\", \"" ++ guid ++ "\"",+ "EndProject",+ "Global",+ " GlobalSection(SolutionConfigurationPlatforms) = preSolution",+ " Debug|Any CPU = Debug|Any CPU",+ " Release|Any CPU = Release|Any CPU",+ " EndGlobalSection",+ " GlobalSection(ProjectConfigurationPlatforms) = postSolution",+ " " ++ guid ++ ".Debug|Any CPU.ActiveCfg = Debug|Any CPU",+ " " ++ guid ++ ".Debug|Any CPU.Build.0 = Debug|Any CPU",+ " " ++ guid ++ ".Release|Any CPU.ActiveCfg = Release|Any CPU",+ " " ++ guid ++ ".Release|Any CPU.Build.0 = Release|Any CPU",+ " EndGlobalSection",+ " GlobalSection(SolutionProperties) = preSolution",+ " HideSolutionNode = FALSE",+ " EndGlobalSection",+ "EndGlobal"+ ]+ csproj guid = unlines [+ "<?xml version=\"1.0\" encoding=\"utf-8\"?>",+ "<Project DefaultTargets=\"Build\" xmlns=\"http://schemas.microsoft.com/developer/msbuild/2003\">",+ " <PropertyGroup>",+ " <Configuration Condition=\" '$(Configuration)' == '' \">Debug</Configuration>",+ " <Platform Condition=\" '$(Platform)' == '' \">AnyCPU</Platform>",+ " <ProductVersion>8.0.50727</ProductVersion>",+ " <SchemaVersion>2.0</SchemaVersion>",+ " <ProjectGuid>" ++ guid ++ "</ProjectGuid>",+ " <OutputType>Library</OutputType>",+ " <AppDesignerFolder>Properties</AppDesignerFolder>",+ " <RootNamespace>" ++ namespace ++ "</RootNamespace>",+ " <AssemblyName>" ++ namespace ++ "</AssemblyName>",+ " <StartupObject>",+ " </StartupObject>",+ " </PropertyGroup>",+ " <PropertyGroup Condition=\" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' \">",+ " <DebugSymbols>true</DebugSymbols>",+ " <DebugType>full</DebugType>",+ " <Optimize>false</Optimize>",+ " <OutputPath>bin\\Debug\\</OutputPath>",+ " <DefineConstants>DEBUG;TRACE</DefineConstants>",+ " <ErrorReport>prompt</ErrorReport>",+ " <WarningLevel>4</WarningLevel>",+ " </PropertyGroup>",+ " <PropertyGroup Condition=\" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' \">",+ " <DebugType>pdbonly</DebugType>",+ " <Optimize>true</Optimize>",+ " <OutputPath>bin\\Release\\</OutputPath>",+ " <DefineConstants>TRACE</DefineConstants>",+ " <ErrorReport>prompt</ErrorReport>",+ " <WarningLevel>4</WarningLevel>",+ " </PropertyGroup>",+ " <Import Project=\"$(MSBuildBinPath)\\Microsoft.CSharp.targets\" />",+ " <!-- To modify your build process, add your task inside one of the targets below and uncomment it. ",+ " Other similar extension points exist, see Microsoft.Common.targets.",+ " <Target Name=\"BeforeBuild\">",+ " </Target>",+ " <Target Name=\"AfterBuild\">",+ " </Target>",+ " -->",+ " <ItemGroup>",+ " <Compile Include=\"AbstractVisitSkeleton.cs\" />",+ " <Compile Include=\"Absyn.cs\" />",+ " <Compile Include=\"Parser.cs\" />",+ " <Compile Include=\"Printer.cs\" />",+ " <Compile Include=\"Scanner.cs\" />",+ " <Compile Include=\"Test.cs\" />",+ " <Compile Include=\"VisitSkeleton.cs\" />",+ " </ItemGroup>",+ " <ItemGroup>",+ " <Reference Include=\"ShiftReduceParser, Version=0.0.0.0, Culture=neutral, processorArchitecture=MSIL\">",+ " <SpecificVersion>False</SpecificVersion>",+ " <HintPath>bin\\ShiftReduceParser.dll</HintPath>",+ " </Reference>",+ " </ItemGroup>",+ " <ItemGroup>",+ " <None Include=\"" ++ namespace ++ ".cf\" />",+ " <None Include=\"" ++ namespace ++ ".l\" />",+ " <None Include=\"" ++ namespace ++ ".y\" />",+ " <None Include=\"" ++ namespace ++ ".tex\" />",+ " <None Include=\"run-gp.bat\" />",+ " </ItemGroup>",+ " <PropertyGroup>",+ " <PreBuildEvent>",+ " </PreBuildEvent>",+ " </PropertyGroup>",+ "</Project>"+ ]++csharptest :: Namespace -> CF -> String+csharptest namespace cf = unlines [+ "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",+ "/* */",+ "/* This test will parse a file, print the abstract syntax tree, and then */",+ "/* pretty-print the result. */",+ "/* */",+ "/****************************************************************************/",+ "using System;",+ "using System.IO;",+ "using " ++ namespace ++ ".Absyn;",+ "",+ "namespace " ++ namespace,+ "{",+ " public class Test",+ " {",+ " public static void Main(string[] args)",+ " {",+ " if (args.Length > 0)",+ " {",+ " Stream stream = File.OpenRead(args[0]);",+ " /* The default entry point is used. For other options see class Parser */",+ " Parser parser = new Parser();",+ " Scanner scanner = Scanner.CreateScanner(stream);",+ " // Uncomment to enable trace information:",+ " // parser.Trace shows what the parser is doing",+ " // parser.Trace = true;",+ " // scanner.Trace prints the tokens as they are parsed, one token per line",+ " // scanner.Trace = true;",+ " parser.scanner = scanner;",+ " try",+ " {",+ " " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();",+ " if (parse_tree != null)",+ " {",+ " Console.Out.WriteLine(\"Parse Successful!\");",+ " Console.Out.WriteLine(\"\");",+ " Console.Out.WriteLine(\"[Abstract Syntax]\");",+ " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));",+ " Console.Out.WriteLine(\"\");",+ " Console.Out.WriteLine(\"[Linearized Tree]\");",+ " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));",+ " }",+ " else",+ " {",+ " Console.Out.WriteLine(\"Parse NOT Successful!\");",+ " }",+ " }",+ " catch(Exception e)",+ " {",+ " Console.Out.WriteLine(\"Parse NOT Successful:\");",+ " Console.Out.WriteLine(e.Message);",+ " Console.Out.WriteLine(\"\");",+ " Console.Out.WriteLine(\"Stack Trace:\");",+ " Console.Out.WriteLine(e.StackTrace);",+ " }",+ " }",+ " else",+ " {",+ " Console.Out.WriteLine(\"You must specify a filename!\");",+ " }",+ " }",+ " }",+ "}"+ ]+ where+ def = show (head (allEntryPoints cf))++filepathtonamespace :: FilePath -> Namespace+filepathtonamespace file = take (length file - 3) (takeFileName file)++projectguid :: MkFiles String+projectguid = do+ maybeFilePath <- findDirectory+ guid <- maybe getBadGUID getGoodGUID maybeFilePath+ return guid+ where+ getBadGUID :: MkFiles String+ getBadGUID = do+ liftIO $ putStrLn "-----------------------------------------------------------------------------"+ liftIO $ putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!"+ liftIO $ putStrLn "You might want to put this tool in your PATH."+ liftIO $ putStrLn "-----------------------------------------------------------------------------"+ return "{00000000-0000-0000-0000-000000000000}"+ getGoodGUID :: FilePath -> MkFiles String+ getGoodGUID filepath = liftIO $ do+ let filepath' = "\"" ++ filepath ++ "\""+ (hIn, hOut, hErr, processHandle) <- runInteractiveCommand filepath'+ guid <- hGetLine hOut+ return ('{' : init guid ++ "}")+ findDirectory :: MkFiles (Maybe FilePath)+ findDirectory = liftIO $ do+ -- This works with Visual Studio 2005.+ -- We will probably have to be modify this to include another environment variable name for Orcas.+ -- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?)+ toolpath <- catchIOError (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools")+ exists <- doesDirectoryExist toolpath+ if exists+ then return (Just (toolpath ++ "\\uuidgen.exe"))+ -- this handles the case when the user was clever enough to add the directory to his/her PATH+ else findExecutable "uuidgen.exe"
+ src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs view
@@ -0,0 +1,277 @@+{-+ BNF Converter: C# Abstract Syntax Generator+ Copyright (C) 2006-2007 Author: Johan Broberg++ Modified from CFtoSTLAbs++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C# Abstract Syntax+ tree classes. It uses the Visitor design+ pattern.++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 22 November, 2006++ Modified : 21 January, 2007 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CAbstoCSharpAbs (cabs2csharpabs) where++import BNFC.Backend.Common.OOAbstract+import BNFC.CF+import BNFC.Utils((+++),(++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower)+import Data.Maybe+import BNFC.Backend.CSharp.CSharpUtils++--The result is one file (.cs)++cabs2csharpabs :: Namespace -> CAbs -> Bool -> String+cabs2csharpabs namespace cabs useWCF = unlinesInline [+ "//C# Abstract Syntax Interface generated by the BNF Converter.",+ -- imports+ "using System;",+ if useWCF then "using System.Runtime.Serialization;" else "",+ "using System.Collections.Generic;",+ "namespace " ++ namespace ++ ".Absyn",+ "{",+ " #region Token Classes",+ prTokenBaseType useWCF,+ unlinesInlineMap (prToken namespace useWCF) (tokentypes cabs),+ " #endregion",+ " ",+ " #region Abstract Syntax Classes",+ unlinesInlineMap (prAbs namespace useWCF) abstractclasses,+ " ",+ unlinesInlineMap (prCon namespace useWCF) (flattenSignatures cabs),+ " ",+ " #region Lists",+ unlinesInlineMap (prList namespace) (listtypes cabs),+ " #endregion",+ " #endregion",+ "}"+ ]+ where+ -- an abstract class is a category which does not contain rules+ abstractclasses = [ (cat, (map fst cabsrules)) | (cat, cabsrules) <- signatures cabs, cat `notElem` (map fst cabsrules) ]++-- auxiliaries++prDataContract :: Bool -> [String] -> String+prDataContract False _ = ""+prDataContract True [] = " [DataContract]"+prDataContract True funs = unlinesInline [+ prDataContract True [],+ unlinesInline $ map prDataContract' funs+ ]+ where+ prDataContract' :: String -> String+ prDataContract' fun = " [KnownType(typeof(" ++ fun ++ "))]"++prDataMember :: Bool -> String+prDataMember False = ""+prDataMember True = " [DataMember]"++prTokenBaseType :: Bool -> String+prTokenBaseType useWCF = unlinesInline [+ prDataContract useWCF [],+ " public class TokenBaseType",+ " {",+ prDataMember useWCF,+ " private string str;",+ " ",+ " public TokenBaseType(string str)",+ " {",+ " this.str = str;",+ " }",+ " ",+ " public override string ToString()",+ " {",+ " return this.str;",+ " }",+ " }",+ " "+ ]++prToken :: Namespace -> Bool -> String -> String+prToken namespace useWCF name = unlinesInline [+ prDataContract useWCF [],+ " public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType",+ " {",+ " public " ++ name ++ "(string str) : base(str)",+ " {",+ " }",+ prAccept namespace name Nothing,+ prVisitor namespace [name],+ prEquals namespace name ["ToString()"],+ prHashCode namespace name ["ToString()"],+ " }"+ ]++prAbs :: Namespace -> Bool -> (String, [String]) -> String+prAbs namespace useWCF (cat, funs) = unlinesInline [+ prDataContract useWCF funs,+ " public abstract class " ++ cat,+ " {",+ " public abstract R Accept<R,A>(" ++ identifier namespace cat ++ ".Visitor<R,A> v, A arg);",+ prVisitor namespace funs,+ " }"+ ]++prVisitor :: Namespace -> [String] -> String+prVisitor namespace funs = unlinesInline [+ " ",+ " public interface Visitor<R,A>",+ " {",+ unlinesInline (map prVisitFun funs),+ " }"+ ]+ where+ prVisitFun f = " R Visit(" ++ identifier namespace f ++ " p, A arg);"++prCon :: Namespace -> Bool -> (String,CSharpAbsRule) -> String+prCon namespace useWCF (c,(f,cs)) = unlinesInline [+ prDataContract useWCF [],+ " public class " ++ f ++ ext,+ " {",+ -- Instance variables+ unlines [prInstVar typ var | (typ,_,var,_) <- cs],+ prConstructor namespace (f,cs),+ unlinesInline [prProperty typ var prop | (typ,_,var,prop) <- cs],+ prEquals namespace f propnames,+ prHashCode namespace f propnames,+ -- print Accept method, override keyword needed for classes inheriting an abstract class+ prAccept namespace c (if isAlsoCategory f c then Nothing else (Just " override")),+ -- if this label is also a category, we need to print the Visitor interface+ -- (if not, it was already printed in the abstract class)+ if isAlsoCategory f c then prVisitor namespace [c] else "",+ " }"+ ]+ where+ -- This handles the case where a LBNF label is the same as the category.+ ext = if isAlsoCategory f c then "" else " : " ++ identifier namespace (identCat $ strToCat c)+ propnames = [prop | (_, _, _, prop) <- cs]+ prInstVar typ var = unlinesInline [+ " private " ++ identifier namespace (typename typ) +++ var ++ ";"+ ]+ prProperty typ var prop = unlinesInline [+ " ",+ prDataMember useWCF,+ " public " ++ identifier namespace (typename typ) +++ prop,+ " {",+ " get",+ " {",+ " return this." ++ var ++ ";",+ " }",+ " set",+ " {",+ " this." ++ var ++ " = value;",+ " }",+ " }"+ ]++-- Creates the Equals() methods+prEquals :: Namespace -> Fun -> [String] -> String+prEquals namespace c vars = unlinesInline [+ " ",+ " public override bool Equals(Object obj)",+ " {",+ " if(this == obj)",+ " {",+ " return true;",+ " }",+ " if(obj is " ++ identifier namespace c ++ ")",+ " {",+ " return this.Equals((" ++ identifier namespace c ++ ")obj);",+ " }",+ " return base.Equals(obj);",+ " }",+ " ",+ " public bool Equals(" ++ identifier namespace c ++ " obj)",+ " {",+ " if(this == obj)",+ " {",+ " return true;",+ " }",+ " return " ++ prEqualsVars vars ++ ";",+ " }"+ ]+ where+ prEqualsVars [] = "true"+ prEqualsVars vs = concat $ intersperse " && " $ map equalVar vs+ equalVar v = "this." ++ v ++ ".Equals(obj." ++ v ++ ")"++-- Creates the GetHashCode() method.+prHashCode :: Namespace -> Fun -> [String] -> String+prHashCode namespace c vars = unlinesInline [+ " ",+ " public override int GetHashCode()",+ " {",+ " return " ++ prHashVars vars ++ ";",+ " }"+ ]+ where+ aPrime = 37+ prHashVars [] = show aPrime+ prHashVars (v:vs) = prHashVars' (hashVar v) vs+ prHashVars' r [] = r+ prHashVars' r (v:vs) = prHashVars' (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashVar v) vs+ hashVar var = "this." ++ var ++ ".GetHashCode()"++prList :: Namespace -> (String,Bool) -> String+prList namespace (c,_) = unlinesInline [+ " public class " ++ c ++ " : List<" ++ identifier namespace (typename bas) ++ ">",+ " {",+ " }"+ ]+ where+ bas = drop 4 c -- drop List++-- The standard Accept method for the Visitor pattern+prAccept :: Namespace -> String -> Maybe String -> String+prAccept namespace cat maybeOverride = unlinesInline [+ " ",+ " public" ++ fromMaybe "" maybeOverride ++ " R Accept<R,A>(" ++ identifier namespace cat ++ ".Visitor<R,A> visitor, A arg)",+ " {",+ " return visitor.Visit(this, arg);",+ " }"+ ]++-- The constructor assigns the parameters to the corresponding instance variables.+prConstructor :: Namespace -> CSharpAbsRule -> String+prConstructor namespace (f,cs) = unlinesInline [+ " public " ++ f ++ "(" ++ conargs ++ ")",+ " {",+ unlinesInline [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs],+ " }"+ ]+ where+ cvs = [c | (_,_,c,_) <- cs]+ pvs = ["p" ++ show i | ((x,st,_,_),i) <- zip cs [1..]]+ conargs = concat $ intersperse ", "+ [identifier namespace (typename x) +++ v | ((x,_,_,_),v) <- zip cs pvs]
+ src/BNFC/Backend/CSharp/CAbstoCSharpAbstractVisitSkeleton.hs view
@@ -0,0 +1,97 @@+{-+ BNF Converter: C# Abstract Visit Skeleton Generator++ Copyright (C) 2006 Author: Johan Broberg++ Modified from BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates an Abstract Visit Skeleton for C#.+ This can be useful if you often make changes to your+ grammar and want to keep your own changes (not having to+ merge with the new visit skeleton each time), while still+ getting compile errors if your code is no longer correct.+ The generated file uses the Visitor design pattern.++ This could have been generated from within+ CAbstoVisitSkeleton, but that would have made it more+ difficult to actually use it (and the visit skeleton).++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 19 December, 2006++ Modified : 19 December, 2006 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CAbstoCSharpAbstractVisitSkeleton (cabs2csharpAbstractVisitSkeleton) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import BNFC.Backend.Common.OOAbstract hiding (basetypes)+import BNFC.Backend.CSharp.CSharpUtils+import BNFC.Backend.CSharp.CAbstoCSharpAbs++--Produces .cs file+cabs2csharpAbstractVisitSkeleton :: Namespace -> CAbs -> String+cabs2csharpAbstractVisitSkeleton namespace cabs = unlines [+ "/*** BNFC-Generated Abstract Visitor Design Pattern Skeleton. ***/",+ "/* This implements the common visitor design pattern.",+ " Replace the R and A parameters with the desired return",+ " and context types.*/",+ "",+ "namespace " ++ namespace ++ ".VisitSkeleton",+ "{",+ " #region Classes",+ unlinesInlineMap (prCon namespace) (signatures cabs),+ " #endregion",+ " ",+ " #region Token types",+ unlinesInlineMap (prBasic namespace) (tokentypes cabs),+ " #endregion",+ "}"+ ]++prBasic namespace c = unlinesInline [+ " public abstract class Abstract" ++ c ++ "Visitor<R,A> : " ++ identifier namespace c ++ ".Visitor<R,A>",+ " {",+ " public abstract R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg);",+ " }"+ ]++prCon :: Namespace -> (String, [CAbsRule]) -> String+prCon namespace (c,fs) = unlinesInline [+ " public abstract class Abstract" ++ c ++ "Visitor<R,A> : " ++ identifier namespace c ++ ".Visitor<R,A>",+ " {",+ unlinesInlineMap (prVisit namespace) fs,+ " }"+ ]++prVisit :: Namespace -> (Fun, [(String, Bool, String)]) -> String+prVisit namespace (f,cs) = unlinesInline [+ " public abstract R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg);"+ ]
+ src/BNFC/Backend/CSharp/CAbstoCSharpVisitSkeleton.hs view
@@ -0,0 +1,118 @@+{-+ BNF Converter: C# Visit Skeleton Generator++ Copyright (C) 2006 Author: Johan Broberg++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C# Visit Skeleton.+ The generated file uses the Visitor design pattern.++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 30 November, 2006++ Modified : 21 January, 2007 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CAbstoCSharpVisitSkeleton (cabs2csharpvisitskeleton) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import BNFC.Backend.Common.OOAbstract hiding (basetypes)+import BNFC.Backend.CSharp.CSharpUtils+import BNFC.Backend.CSharp.CAbstoCSharpAbs++--Produces .cs file+cabs2csharpvisitskeleton :: Namespace -> CAbs -> String+cabs2csharpvisitskeleton namespace cabs = unlines [+ "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",+ "/* This implements the common visitor design pattern. To make sure that",+ " compile errors occur when code in the Visitor don't match the abstract",+ " syntaxt, the \"abstract visit skeleton\" is used.",+ " ",+ " Replace the R and A parameters with the desired return",+ " and context types.*/",+ "",+ "namespace " ++ namespace ++ ".VisitSkeleton",+ "{",+ " #region Classes",+ unlinesInlineMap (prCon namespace) (signatures cabs),+ " #endregion",+ " ",+ " #region Token types",+ unlinesInlineMap (prBasic namespace) (tokentypes cabs),+ " #endregion",+ "}"+ ]++prBasic namespace c = unlinesInline [+ " public class " ++ c ++ "Visitor<R,A> : Abstract" ++ c ++ "Visitor<R,A>",+ " {",+ " public override R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg)",+ " {",+ " /* Code for " ++ c ++ " Goes Here */",+ " return default(R);",+ " }",+ " }"+ ]++prCon :: Namespace -> (String, [CAbsRule]) -> String+prCon namespace (c,fs) = unlinesInline [+ " public class " ++ c ++ "Visitor<R,A> : Abstract" ++ c ++ "Visitor<R,A>",+ " {",+ unlinesInlineMap (prVisit namespace) (map cabsrule2csharpabsrule fs),+ " }"+ ]+++prVisit :: Namespace -> CSharpAbsRule -> String+prVisit namespace (f,cs) = unlinesInline [+ " public override R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg)",+ " {",+ " /* Code For " ++ f ++ " Goes Here */",+ unlinesInline $ map (prVisitArg namespace (varname f)) cs,+ " return default(R);",+ " }"+ ]++prVisitArg :: Namespace -> String -> (String, Bool, VariableName, PropertyName) -> String+prVisitArg namespace vname (cat, isPt, var, prop)+ | cat `elem` (map fst basetypes) = " // " ++ vname ++ "." ++ prop+ -- var /= "list_" is a dummy fix to make sure that a category named "List" doesn't get interpreted as a List.+ -- this isn't very good though, and should be fixed somehow.+ | "list" `isPrefixOf` var && var /= "list_" = listAccept+ | otherwise = " " ++ vname ++ "." ++ prop ++ ".Accept(new " ++ cat ++ "Visitor<R,A>(), arg);"+ where+ listtype = typename (drop 4 cat)+ listAccept = unlinesInline [+ " foreach(" ++ identifier namespace listtype ++ " x in " ++ vname ++ "." ++ prop ++ ")",+ " {",+ if listtype `notElem` (map snd basetypes)+ then " x.Accept(new " ++ listtype ++ "Visitor<R,A>(), arg);"+ else " // x",+ " }"+ ]
+ src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs view
@@ -0,0 +1,455 @@+{-+ BNF Converter: C# Pretty Printer Generator+ Copyright (C) 2006 Author: Johan Broberg++ Modified from CFtoSTLPrinter++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the C# Pretty Printer.+ It also generates the "show" method for+ printing an abstract syntax tree.++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 26 November, 2006++ Modified : 21 January, 2007 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CFtoCSharpPrinter (cf2csharpprinter) where++import BNFC.CF+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper, isSpace)+import Data.Maybe+import BNFC.Backend.CSharp.CSharpUtils++--Produces .cs file+cf2csharpprinter :: Namespace -> CF -> String+cf2csharpprinter namespace cf = unlinesInline [+ header namespace cf,+ " ",+ entrypoints namespace cf,+ " ",+ " #region (Internal) Print Methods",+ unlinesInlineMap (prData namespace user) groups,+ " #endregion",+ " ",+ " #region (Internal) Show Methods",+ unlinesInlineMap (shData namespace user) groups,+ " #endregion",+ " }",+ " #endregion",+ "}"+ ]+ where+ groups = fixCoercions (ruleGroupsInternals cf)+ user = [n | (n,_) <- tokenPragmas cf]++header :: Namespace -> CF -> String+header namespace cf = unlinesInline [+ "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",+ " ",+ -- imports+ "using System;",+ "using System.Text; // for StringBuilder",+ "using " ++ namespace ++ ".Absyn;",+ " ",+ "namespace " ++ namespace,+ "{",+ " #region Pretty-printer class",+ " public class PrettyPrinter",+ " {",+ " #region Misc rendering functions",+ " // You may wish to change these:",+ " private const int BUFFER_INITIAL_CAPACITY = 2000;",+ " private const string LEFT_PARENTHESIS = \"(\";",+ " private const string RIGHT_PARENTHESIS = \")\";",+ " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",+ " ",+ " private static int _n_ = 0;",+ " private static StringBuilder buffer = new StringBuilder(BUFFER_INITIAL_CAPACITY);",+ " ",+ " //You may wish to change render",+ " private static void Render(String s)",+ " {",+ " if(s == \"{\")",+ " {",+ " buffer.Append(\"\\n\");",+ " Indent();",+ " buffer.Append(s);",+ " _n_ = _n_ + 2;",+ " buffer.Append(\"\\n\");",+ " Indent();",+ " }",+ " else if(s == \"(\" || s == \"[\")",+ " buffer.Append(s);",+ " else if(s == \")\" || s == \"]\")",+ " {",+ " Backup();",+ " buffer.Append(s);",+ " buffer.Append(\" \");",+ " }",+ " else if(s == \"}\")",+ " {",+ " _n_ = _n_ - 2;",+ " Backup();",+ " Backup();",+ " buffer.Append(s);",+ " buffer.Append(\"\\n\");",+ " Indent();",+ " }",+ " else if(s == \",\")",+ " {",+ " Backup();",+ " buffer.Append(s);",+ " buffer.Append(\" \");",+ " }",+ " else if(s == \";\")",+ " {",+ " Backup();",+ " buffer.Append(s);",+ " buffer.Append(\"\\n\");",+ " Indent();",+ " }",+ " else if(s == \"\") return;",+ " else",+ " {",+ " // Make sure escaped characters are printed properly!",+ " if(s.StartsWith(\"\\\"\") && s.EndsWith(\"\\\"\"))",+ " {",+ " buffer.Append('\"');",+ " StringBuilder sb = new StringBuilder(s);",+ " // Remove enclosing citation marks",+ " sb.Remove(0,1);",+ " sb.Remove(sb.Length-1,1);",+ " // Note: we have to replace backslashes first! (otherwise it will \"double-escape\" the other escapes)",+ " sb.Replace(\"\\\\\", \"\\\\\\\\\");",+ " sb.Replace(\"\\n\", \"\\\\n\");",+ " sb.Replace(\"\\t\", \"\\\\t\");",+ " sb.Replace(\"\\\"\", \"\\\\\\\"\");",+ " buffer.Append(sb.ToString());",+ " buffer.Append('\"');",+ " }",+ " else",+ " {",+ " buffer.Append(s);",+ " }",+ " buffer.Append(\" \");",+ " }",+ " }",+ " ",+ " private static void PrintInternal(int n, int _i_)",+ " {",+ " buffer.Append(n.ToString(InvariantFormatInfo));",+ " buffer.Append(' ');",+ " }",+ " ",+ " private static void PrintInternal(double d, int _i_)",+ " {",+ " buffer.Append(d.ToString(InvariantFormatInfo));",+ " buffer.Append(' ');",+ " }",+ " ",+ " private static void PrintInternal(string s, int _i_)",+ " {",+ " Render(s);",+ " }",+ " ",+ " private static void PrintInternal(char c, int _i_)",+ " {",+ " PrintQuoted(c);",+ " }",+ " ",+ unlinesInlineMap (prToken namespace) (tokenNames cf),+ " ",+ " private static void ShowInternal(int n)",+ " {",+ " Render(n.ToString(InvariantFormatInfo));",+ " }",+ " ",+ " private static void ShowInternal(double d)",+ " {",+ " Render(d.ToString(InvariantFormatInfo));",+ " }",+ " ",+ " private static void ShowInternal(char c)",+ " {",+ " PrintQuoted(c);",+ " }",+ " ",+ " private static void ShowInternal(string s)",+ " {",+ " PrintQuoted(s);",+ " }",+ " ",+ unlinesInlineMap (shToken namespace) (tokenNames cf),+ " ",+ " private static void PrintQuoted(string s)",+ " {",+ " Render(\"\\\"\" + s + \"\\\"\");",+ " }",+ " ",+ " private static void PrintQuoted(char c)",+ " {",+ " // Makes sure the character is escaped properly before printing it.",+ " string str = c.ToString();",+ " if(c == '\\n') str = \"\\\\n\";",+ " if(c == '\\t') str = \"\\\\t\";",+ " Render(\"'\" + str + \"'\");",+ " }",+ " ",+ " private static void Indent()",+ " {",+ " int n = _n_;",+ " while (n > 0)",+ " {",+ " buffer.Append(' ');",+ " n--;",+ " }",+ " }",+ " ",+ " private static void Backup()",+ " {",+ " if(buffer[buffer.Length - 1] == ' ')",+ " {",+ " buffer.Length = buffer.Length - 1;",+ " }",+ " }",+ " ",+ " private static void Trim()",+ " {",+ " while(buffer.Length > 0 && buffer[0] == ' ')",+ " buffer.Remove(0, 1); ",+ " while(buffer.Length > 0 && buffer[buffer.Length-1] == ' ')",+ " buffer.Remove(buffer.Length-1, 1);",+ " }",+ " ",+ " private static string GetAndReset()",+ " {",+ " Trim();",+ " string strReturn = buffer.ToString();",+ " Reset();",+ " return strReturn;",+ " }",+ " ",+ " private static void Reset()",+ " {",+ " buffer.Remove(0, buffer.Length);",+ " }",+ " #endregion"+ ]++prToken :: Namespace -> String -> String+prToken namespace token = unlinesInline [+ " private static void PrintInternal(" ++ identifier namespace token ++ " token, int _i_)",+ " {",+ " buffer.Append('\\\"');",+ " buffer.Append(token.ToString());",+ " buffer.Append('\\\"');",+ " }"+ ]++shToken :: Namespace -> String -> String+shToken namespace token = unlinesInline [+ " private static void ShowInternal(" ++ identifier namespace token ++ " token)",+ " {",+ " Render(token.ToString());",+ " }"+ ]++entrypoints :: Namespace -> CF -> String+entrypoints namespace cf = unlinesInline [+ " #region Print Entry Points",+ unlinesInlineMap prEntryPoint (allCats cf),+ " #endregion",+ " ",+ " #region Show Entry Points",+ unlinesInlineMap shEntryPoint (allCats cf),+ " #endregion"+ ]+ where+ prEntryPoint cat | (normCat cat) == cat = unlinesInline [+ " public static string Print(" ++ identifier namespace (identCat cat) ++ " cat)",+ " {",+ " PrintInternal(cat, 0);",+ " return GetAndReset();",+ " }"+ ]+ prEntryPoint _ = ""+ shEntryPoint cat | (normCat cat) == cat = unlinesInline [+ " public static String Show(" ++ identifier namespace (identCat cat) ++ " cat)",+ " {",+ " ShowInternal(cat);",+ " return GetAndReset();",+ " }"+ ]+ shEntryPoint _ = ""++prData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String+prData namespace user (cat, rules)+ -- list+ | isList cat = unlinesInline [+ " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)",+ " {",+ (prList user cat rules),+ " }"+ ]+ -- not a list+ | otherwise = unlinesInline [+ " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)",+ " {",+ -- first rule starts with "if", the rest of them start with "else if".+ -- this isn't very pretty, but does the job and produces nice code.+ prRule namespace Nothing firstRule,+ unlinesInline $ map (prRule namespace (Just "else ")) otherRules,+ " }"+ ]+ where+ -- Removes the rules at the beginning of the list which won't be used by the prRule function.+ rules' = dropWhile (\r -> isCoercion (funRule r) || isDefinedRule (funRule r)) rules+ firstRule = head rules'+ otherRules = tail rules'++prRule :: Namespace -> Maybe String -> Rule -> String+prRule namespace maybeElse r@(Rule fun _c cats)+ | not (isCoercion fun || isDefinedRule fun) = unlinesInline [+ " " ++ fromMaybe "" maybeElse ++ "if(p is " ++ identifier namespace fun ++ ")",+ " {",+ " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;",+ " if(_i_ > " ++ (show p) ++ ") Render(LEFT_PARENTHESIS);",+ cats',+ " if(_i_ > " ++ (show p) ++ ") Render(RIGHT_PARENTHESIS);",+ " }"+ ]+ where+ p = precRule r+ cats' = case cats of+ [] -> ""+ _ -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats))+ fnm = '_' : map toLower fun++ getPrec (Right {}) = 0+ getPrec (Left c) = precCat c+prRule _nm _ _ = ""++prList :: [UserDef] -> Cat -> [Rule] -> String+prList user c rules = unlinesInline [+ " for(int i=0; i < p.Count; i++)",+ " {",+ " PrintInternal(p[i], 0);",+ " if(i < p.Count - 1)",+ " {",+ " Render(\"" ++ escapeChars sep ++ "\");",+ " }",+ " else",+ " {",+ " Render(\"" ++ optsep ++ "\");",+ " }",+ " }"+ ]+ where+ et = typename (show$ normCatOfList c)+ sep = getCons rules+ optsep = if hasOneFunc rules then "" else escapeChars sep++prCat fnm (c, p) =+ case c of+ Right t -> " Render(\"" ++ escapeChars t ++ "\");"+ Left nt+ | "string" `isPrefixOf` nt -> " PrintQuoted(" ++ fnm ++ "." ++ nt ++ ");"+ | isInternalVar nt -> ""+ | otherwise -> " PrintInternal(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");"+++--The following methods generate the Show function.++shData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String+shData namespace user (cat, rules)+ | isList cat = unlinesInline [+ " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)",+ " {",+ (shList user cat rules),+ " }"+ ]+ | otherwise = unlinesInline [+ " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)",+ " {",+ unlinesInline $ map (shRule namespace) rules,+ " }"+ ]++shRule :: Namespace -> Rule -> String+shRule namespace (Rule fun _c cats)+ | not (isCoercion fun || isDefinedRule fun) = unlinesInline [+ " if(p is " ++ identifier namespace fun ++ ")",+ " {",+ " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;",+ lparen,+ " Render(\"" ++ (escapeChars fun) ++ "\");",+ cats',+ rparen,+ " }"+ ]+ where+ cats' | allTerms cats = ""+ | otherwise = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats))+ lparen | allTerms cats = ""+ | otherwise = " Render(\"(\");"+ rparen | allTerms cats = ""+ | otherwise = " Render(\")\");"+ allTerms [] = True+ allTerms ((Left {}):_) = False+ allTerms (_:zs) = allTerms zs+ fnm = '_' : map toLower fun+shRule _nm _ = ""++shList :: [UserDef] -> Cat -> [Rule] -> String+shList user c _rules = unlinesInline [+ " for(int i=0; i < p.Count; i++)",+ " {",+ " ShowInternal(p[i]);",+ " if(i < p.Count - 1)",+ " Render(\",\");",+ " }"+ ]+ where+ et = typename (show $ normCatOfList c)++shCat fnm c =+ case c of+ Right {} -> ""+ Left nt+ | "list" `isPrefixOf` nt -> unlinesInline [+ " Render(\"[\");",+ " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");",+ " Render(\"]\");"+ ]+ | isInternalVar nt -> ""+ | otherwise -> " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");"++isInternalVar x = x == show InternalCat ++ "_"
+ src/BNFC/Backend/CSharp/CFtoGPLEX.hs view
@@ -0,0 +1,221 @@+{-+ BNF Converter: C# GPLEX Generator+ Copyright (C) 2006 Author: Johan Broberg++ Modified from CFtoFlex++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the GPLEX file.++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 23 November, 2006++ Modified : 17 December, 2006 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CFtoGPLEX (cf2gplex) where++import BNFC.CF+import BNFC.Backend.CSharp.RegToGPLEX+import BNFC.Utils((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import BNFC.Backend.CSharp.CSharpUtils++--The environment must be returned for the parser to use.+cf2gplex :: Namespace -> CF -> (String, SymEnv)+cf2gplex namespace cf = (unlines [+ prelude namespace,+ cMacros,+ prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'),+ "%%"+ ], env')+ where+ env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)+ env' = env ++ (makeSymEnv (tokenNames cf) (length env))+ -- GPPG doesn't seem to like tokens beginning with an underscore, so they (the underscores, nothing else) have been removed.+ makeSymEnv [] _ = []+ makeSymEnv (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))++prelude :: Namespace -> String+prelude namespace = unlines [+ "/* This GPLex file was machine-generated by the BNF converter */",+ "",+ "%namespace " ++ namespace,+ "",+ "%{",+ " /// <summary>",+ " /// Buffer for escaped characters in strings.",+ " /// </summary>",+ " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();",+ "",+ " /// <summary>",+ " /// Change to enable output - useful for debugging purposes",+ " /// </summary>",+ " public bool Trace = false;",+ "",+ " /// <summary>",+ " /// Culture-independent IFormatProvider for numbers. ",+ " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.",+ " /// </summary>",+ " /// <remarks>",+ " /// This should be used when parsing numbers. Otherwise the parser might fail: ",+ " /// culture en-US uses a dot as decimal separator, while for example sv-SE uses a comma. ",+ " /// BNFC uses dot as decimal separator for Double values, so if your culture is sv-SE ",+ " /// the parse will fail if this InvariantInfo isn't used.",+ " /// </remarks>",+ " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",+ "",+ " /// <summary>",+ " /// Convenience method to create scanner AND initialize it correctly.",+ " /// As long as you don't want to enable trace output, this is all you ",+ " /// need to call and give to the parser to be able to parse.",+ " /// </summary>",+ " public static Scanner CreateScanner(Stream stream)",+ " {",+ " Scanner scanner = new Scanner(stream);",+ " scanner.Begin();",+ " return scanner;",+ " }",+ "",+ " /// <summary>",+ " /// Sets the scanner to the correct initial state (YYINITIAL). ",+ " /// You should call this method prior to calling parser.Parse().",+ " /// </summary>",+ " public void Begin()",+ " {",+ " BEGIN(YYINITIAL);",+ " }",+ "",+ " /// <summary>",+ " /// Convenience method to \"reset\" the buffer for escaped characters in strings.",+ " /// </summary>",+ " private void BufferReset()",+ " {",+ " this.strBuffer = new System.Text.StringBuilder();",+ " }",+ "",+ "%}",+ ""+ ]++--For now all categories are included.+--Optimally only the ones that are used should be generated.+cMacros :: String+cMacros = unlines+ [+ "alpha [a-zA-Z]",+ "alphaCapital [A-Z]",+ "alphaSmall [a-z]",+ "digit [0-9]",+ "ident [a-zA-Z0-9'_]",+ -- start states, must be defined one at a time+ "%s YYINITIAL",+ "%s COMMENT",+ "%s CHAR",+ "%s CHARESC",+ "%s CHAREND",+ "%s STRING",+ "%s ESCAPED",+ "%%"+ ]++lexSymbols :: SymEnv -> [(String, String)]+lexSymbols ss = map transSym ss+ where+ transSym (s,r) =+ ("<YYINITIAL>\"" ++ s' ++ "\"" , "if(Trace) System.Console.Error.WriteLine(yytext); return (int)Tokens." ++ r ++ ";")+ where+ s' = escapeChars s++gplex :: Namespace -> CF -> SymEnv -> [(String, String)]+gplex namespace cf env = concat [+ lexComments (comments cf),+ userDefTokens,+ ifC catString strStates,+ ifC catChar charStates,+ ifC catDouble [("<YYINITIAL>{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")],+ ifC catInteger [("<YYINITIAL>{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")],+ ifC catIdent [("<YYINITIAL>{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")],+ [("<YYINITIAL>[ \\t\\r\\n\\f]" , "/* ignore white space. */;")],+ [("<YYINITIAL>." , "return (int)Tokens.error;")]+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else []+ userDefTokens = map tokenline (tokenPragmas cf)+ where+ tokenline (name, exp) = ("<YYINITIAL>" ++ printRegGPLEX exp , action name)+ action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName (show$normCat n) ++ " = new " ++ identifier namespace (show n) ++ "(yytext); return (int)Tokens." ++ sName n ++ ";"+ sName n = case lookup (show n) env of+ Just x -> x+ Nothing -> show n+ -- These handle escaped characters in Strings.+ strStates = [+ ("<YYINITIAL>\"\\\"\"" , "BEGIN(STRING);"),+ ("<STRING>\\\\" , "BEGIN(ESCAPED);"),+ ("<STRING>\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"),+ ("<STRING>." , "this.strBuffer.Append(yytext);"),+ ("<ESCAPED>n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"),+ ("<ESCAPED>\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"),+ ("<ESCAPED>\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"),+ ("<ESCAPED>t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"),+ ("<ESCAPED>." , "this.strBuffer.Append(yytext); BEGIN(STRING);")+ ]+ -- These handle escaped characters in Chars.+ charStates = [+ ("<YYINITIAL>\"'\"" , "BEGIN(CHAR);"),+ ("<CHAR>\\\\" , "BEGIN(CHARESC);"),+ ("<CHAR>[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),+ ("<CHARESC>n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"),+ ("<CHARESC>t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"),+ ("<CHARESC>." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),+ ("<CHAREND>\"'\"" , "BEGIN(YYINITIAL);")+ ]++lexComments :: ([(String, String)], [String]) -> [(String, String)]+lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m)++lexSingleComment :: String -> (String, String)+lexSingleComment c =+ ("<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n" , "/* BNFC single-line comment */;")++--There might be a possible bug here if a language includes 2 multi-line comments.+--They could possibly start a comment with one character and end it with another.+--However this seems rare.+lexMultiComment :: (String, String) -> [(String, String)]+lexMultiComment (b,e) = [+ ("<YYINITIAL>\"" ++ b ++ "\"" , "BEGIN(COMMENT);"),+ ("<COMMENT>\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"),+ ("<COMMENT>." , "/* BNFC multi-line comment */;"),+ ("<COMMENT>[\\n]" , "/* BNFC multi-line comment */;")+ ]++-- Used to print the lexer rules; makes sure that all rules are equally indented, to make the GPLEX file a little more readable.+prettyprinter :: [(String, String)] -> String+prettyprinter xs = unlines $ map prettyprinter' xs+ where+ padlength = 1 + (last $ sort $ map length $ map fst xs)+ prettyprinter' (x, y) = x ++ replicate (padlength - length x) ' ' ++ y
+ src/BNFC/Backend/CSharp/CFtoGPPG.hs view
@@ -0,0 +1,274 @@+{-+ BNF Converter: C# GPPG Generator+ Copyright (C) 2006 Author: Johan Broberg++ Modified from CFtoBisonSTL.++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the GPPG input file.++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 24 November, 2006++ Modified : 17 December, 2006 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CFtoGPPG (cf2gppg) where++import BNFC.CF+import Data.List (intersperse, isPrefixOf)+import BNFC.Backend.Common.NamedVariables hiding (varName)+import Data.Char (toLower,isUpper,isDigit)+import BNFC.Utils ((+++), (++++))+import BNFC.TypeChecker+import ErrM+import BNFC.Backend.Common.OOAbstract hiding (basetypes)+import BNFC.Backend.CSharp.CSharpUtils++--This follows the basic structure of CFtoHappy.++-- Type declarations+type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++--The environment comes from the CFtoGPLEX+cf2gppg :: Namespace -> CF -> SymEnv -> String+cf2gppg namespace cf env = unlines [+ header namespace cf,+ union namespace (positionCats cf ++ allCats cf ++ map strToCat (tokentypes (cf2cabs cf))),+ tokens user env,+ declarations cf,+ "",+ specialToks cf,+ "",+ "%%",+ prRules (rulesForGPPG namespace cf env)+ ]+ where+ user = fst (unzip (tokenPragmas cf))++positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))++header :: Namespace -> CF -> String+header namespace cf = unlines [+ "/* This GPPG file was machine-generated by BNFC */",+ "",+ "%namespace " ++ namespace,+ "%{",+ definedRules namespace cf,+ unlinesInline $ map (parseMethod namespace) (allCatsNorm cf ++ positionCats cf),+ "%}"+ ]++definedRules :: Namespace -> CF -> String+definedRules namespace cf = unlinesInline [+ if null [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]+ then ""+ else error "Defined rules are not yet available in C# mode!"+ ]+ where+ ctx = buildContext cf++ list = LC (const "[]") (\t -> "List" ++ unBase t)+ where+ unBase (ListT t) = unBase t+ unBase (BaseT x) = show$normCat$strToCat x++ rule f xs e =+ case checkDefinition' list ctx f xs e of+ Bad err -> error $ "Panic! This should have been caught already:\n" ++ err+ Ok (args,(e',t)) -> unlinesInline [+ "Defined Rule goes here"+ ]++--This generates a parser method for each entry point.+parseMethod :: Namespace -> Cat -> String+parseMethod namespace cat = unlinesInline [+ " " ++ returntype +++ returnvar ++ " = null;",+ " public " ++ returntype ++ " Parse" ++ cat' ++ "()",+ " {",+ " if(this.Parse())",+ " {",+ " return " ++ returnvar ++ ";",+ " }",+ " else",+ " {",+ " throw new Exception(\"Could not parse input stream!\");",+ " }",+ " }",+ " "+ ]+ where+ cat' = identCat (normCat cat)+ returntype = identifier namespace cat'+ returnvar = resultName cat'++--The union declaration is special to GPPG/GPLEX and gives the type of yylval.+--For efficiency, we may want to only include used categories here.+union :: Namespace -> [Cat] -> String+union namespace cats = unlines $ filter (\x -> x /= "\n") [+ "%union",+ "{",+ " public int int_;",+ " public char char_;",+ " public double double_;",+ " public string string_;",+ unlinesInline $ map catline cats,+ "}"+ ]+ where --This is a little weird because people can make [Exp2] etc.+ catline cat | (identCat cat /= show cat) || ((normCat cat) == cat) =+ " public " ++ identifier namespace (identCat (normCat cat)) +++ (varName (show$normCat cat)) ++ ";"+ catline cat = ""++--declares non-terminal types.+declarations :: CF -> String+declarations cf = unlinesInline $ map (typeNT cf) (positionCats cf ++ allCats cf)+ where --don't define internal rules+ typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (show$normCat nt)) ++ "> " ++ (show$normCat nt)+ typeNT cf nt = ""++--declares terminal types.+tokens :: [UserDef] -> SymEnv -> String+tokens user ts = concatMap (declTok user) ts+ where+ declTok u (s,r) = if elem s (map show u)+ then "%token<" ++ varName (show$normCat$strToCat s) ++ "> " ++ r ++ " // " ++ show s ++ "\n"+ else "%token " ++ r ++ " // " ++ show s ++ "\n"++specialToks :: CF -> String+specialToks cf = unlinesInline [+ ifC catString "%token<string_> STRING_",+ ifC catChar "%token<char_> CHAR_",+ ifC catInteger "%token<int_> INTEGER_",+ ifC catDouble "%token<double_> DOUBLE_",+ ifC catIdent "%token<string_> IDENT_"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""++--The following functions are a (relatively) straightforward translation+--of the ones in CFtoHappy.hs+rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules+rulesForGPPG namespace cf env = (map mkOne $ ruleGroups cf) ++ posRules where+ mkOne (cat,rules) = constructRule namespace cf env rules cat+ posRules = map mkPos $ positionCats cf+ mkPos cat = (cat, [(maybe (show cat) id (lookup (show cat) env),+ "$$ = new " ++ show cat ++ "($1);")])++-- For every non-terminal, we construct a set of rules.+constructRule :: Namespace ->+ CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule namespace cf env rules nt =+ (nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf env r b])+ where+ ruleName r = case funRule r of+ ---- "(:)" -> identCat nt+ ---- "(:[])" -> identCat nt+ z -> z+ revs = reversibleCats cf+ eps = allEntryPoints cf+ isEntry nt = if elem nt eps then True else False+ result = if isEntry nt then (resultName (identCat (normCat nt))) ++ "= $$;" else ""++-- Generates a string containing the semantic action.+-- This was copied from CFtoCup15, with only a few small modifications+generateAction :: Namespace -> NonTerminal -> Fun -> Bool -> [(MetaVar, Bool)]+ -> Action+generateAction namespace nt f rev mbs+ | isNilFun f = "$$ = new " ++ identifier namespace c ++ "();"+ | isOneFun f = "$$ = new " ++ identifier namespace c ++ "(); $$.Add(" ++ p_1 ++ ");"+ | isConsFun f && not rev = "$$ = " ++ p_2 ++ "; " ++ p_2 ++ ".Insert(0, " ++ p_1 ++ ");"+ | isConsFun f && rev = "$$ = " ++ p_1 ++ "; " ++ p_1 ++ ".Add(" ++ p_2 ++ ");"+ | isCoercion f = "$$ = " ++ p_1 ++ ";"+ | isDefinedRule f = "$$ = " ++ f ++ "_" ++ "(" ++ concat (intersperse "," ms) ++ ");"+ | otherwise = "$$ = new " ++ identifier namespace c ++ "(" ++ concat (intersperse "," ms) ++ ");"+ where+ c = if isNilFun f || isOneFun f || isConsFun f+ then identCat (normCat nt) else f+ ms = map fst mbs+ p_1 = ms!!0+ p_2 = ms!!1+++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal+generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])+generatePatterns cf env r revv = case rhsRule r of+ [] -> ("/* empty */",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> case lookup (show c) env of+ -- This used to be x, but that didn't work if we had a symbol "String" in env, and tried to use a normal String - it would use the symbol...+ Just x | not (isPositionCat cf c) && (show c) `notElem` (map fst basetypes) -> x+ _ -> typeName (identCat c)+ Right s -> case lookup s env of+ Just x -> x+ Nothing -> s+ metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]++ -- notice: reversibility with push_back vectors is the opposite+ -- of right-recursive lists!+ revert c = (isList c) &&+ not (isConsFun (funRule r)) && notElem c revs+ revs = reversibleCats cf++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.++prRules :: Rules -> String+prRules [] = []+prRules ((nt, []):rs) = prRules rs --internal rule+prRules ((nt,((p,a):ls)):rs) =+ (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls++--Some helper functions.+resultName :: String -> String+resultName s = "YY_RESULT_" ++ s ++ "_"++--slightly stronger than the NamedVariable version.+varName :: String -> String+varName s = (map toLower (identCat $ strToCat s)) ++ "_"++typeName :: String -> String+typeName "Ident" = "IDENT_"+typeName "String" = "STRING_"+typeName "Char" = "CHAR_"+typeName "Integer" = "INTEGER_"+typeName "Double" = "DOUBLE_"+typeName x = x
+ src/BNFC/Backend/CSharp/CSharpUtils.hs view
@@ -0,0 +1,154 @@+{-+ BNF Converter: Utility Functions for C#+ Copyright (C) 2006 Author: Johan Broberg++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module provides utility functions for the+ C# format.++ Author : Johan Broberg (johan@pontemonti.com)++ License : GPL (GNU General Public License)++ Created : 23 November, 2006++ Modified : 21 January, 2007 by Johan Broberg++ **************************************************************+-}++module BNFC.Backend.CSharp.CSharpUtils where++import BNFC.CF+import Control.Monad.ST+-- Control.Monad.State+import Data.Char (toLower)+import Data.Maybe+import Data.List+import BNFC.Backend.Common.OOAbstract hiding (basetypes)++type Namespace = String++--The visit-function name of a basic type+visitFunName :: String -> String+visitFunName v =+ if "integer_" `isPrefixOf` v then "Integer"+ else if "char_" `isPrefixOf` v then "Char"+ else if "string_" `isPrefixOf` v then "String"+ else if "double_" `isPrefixOf` v then "Double"+ else if "ident_" `isPrefixOf` v then "Ident"+ else "Ident" --User-defined type++isUserDefined :: String -> Bool+isUserDefined v = v `notElem` (map classVar (map fst basetypes))++basetypes = [+ ("Integer","int"),+ ("Char", "char"),+ ("Double", "double"),+ ("String", "string"),+ ("Ident", "string")+ ]++typename :: String -> String+typename name+ | name == "Char" = "char"+ | name == "Double" = "double"+ | name == "Ident" = "string"+ | name == "Integer" = "int"+ | name == "String" = "string"+ | otherwise = name++-- Creates a variable name.+-- To make sure that no reserved keyword is generated, an underscore is added at the end. Not very pretty, but effective.+varname :: String -> String+varname name = (map toLower name) ++ "_"++-- Given a variable name (in an abstract syntax class), returns ".ToString()" if the name doesn't match one of the basetypes.+toString :: String -> String+toString v = if isUserDefined v then ".ToString()" else ""++-- Prepends namespace ".Absyn." to typ unless it is one of the basetypes+identifier :: Namespace -> String -> String+identifier namespace typ+ | typ `elem` (map snd basetypes) = typ+ | otherwise = namespace ++ ".Absyn." ++ typ++-- Removes empty lines, and removes the line-break at the end.+-- This can be useful if you want to use unlines "inside" unlines and don't want a whole lot of "useless" line-breaks.+unlinesInline :: [String] -> String+unlinesInline xs = concat $ intersperse "\n" $ filter (\x -> x /= "") xs++unlinesInlineMap :: (a -> String) -> [a] -> String+unlinesInlineMap fun xs = unlinesInline $ intersperse " " $ filter (\x -> x /= "") $ map fun xs++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars [] = []+escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))+escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))+escapeChars (x:xs) = x : (escapeChars xs)++isAlsoCategory :: Fun -> String -> Bool+isAlsoCategory f c = f == c++flattenSignatures :: CAbs -> [(String, CSharpAbsRule)]+flattenSignatures cabs = [(c,r) | (c,rs) <- signatures cabs, r <- map cabsrule2csharpabsrule rs]++type VariableName = String+type PropertyName = String++-- Just like CAbsRule in OOAbstract, except this also has PropertyName.+-- (valcat,(constr,args)), True = is class (not basic), class variable stored+type CSharpAbsRule = (Fun,[(String,Bool,VariableName,PropertyName)])++cabsrule2csharpabsrule :: CAbsRule -> CSharpAbsRule+cabsrule2csharpabsrule (f, cabsrule) = (f, addPropertyNames cabsrule)++-- This generates names for properties. It's done the same way as generation of variable names in OOAbstract->cf2cabs+-- A property name uses the same casing as its category, but has an underscore at the end+addPropertyNames :: [(String, Bool, String)] -> [(String, Bool, VariableName, PropertyName)]+addPropertyNames cs = [(c,b,v,p) | ((c,b,v),p) <- zip cs (properties [] (map propertyName [c | (c,_,_) <- cs]))]+ --- creating new names is quadratic, but parameter lists are short+ --- this should conform with Michael's naming+ where+ properties seen vv = case vv of+ [] -> vv+ v:vs -> case length (filter (==v) seen) of+ 0 | elem v vs -> (v ++ "1"): properties (v:seen) vs+ 0 -> v : properties (v:seen) vs+ n -> (v ++ show (n+1)) : properties (v:seen) vs++propertyName :: String -> PropertyName+propertyName c = c ++ "_"++-- Given a rule's definition, it goes through and nicely the properties by type.+-- Does the same thing as numVars in NamedVariables, except the varName part+numProps :: [(String, Int)] -> [Either Cat b] -> [Either String b]+numProps _env [] = []+numProps env ((Right f) : fs) = (Right f) : (numProps env fs)+numProps env ((Left f) : fs) =+ case lookup f' env of+ Nothing -> (Left f') : (numProps ((f',1):env) fs)+ Just n -> (Left $ f' ++ (show $ n + 1)) : (numProps ((f',n+1):env) fs)+ where+ f' = propertyName (identCat (normCat f))+
+ src/BNFC/Backend/CSharp/RegToGPLEX.hs view
@@ -0,0 +1,73 @@+module BNFC.Backend.CSharp.RegToGPLEX (printRegGPLEX) where++-- modified from RegToFlex++import AbsBNF+import Data.Char++-- the top-level printing method+printRegGPLEX :: Reg -> String+printRegGPLEX = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend (0::Int) where+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""+ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = [[c]]+ prtList s = map (concat . prt 0) s++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["[^.]"])+ RChar c -> prPrec i 3 (prt 0 [mkEsc [c]])+ RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str))+ RDigit -> prPrec i 3 (concat [["{digit}"]])+ RLetter -> prPrec i 3 (concat [["{alpha}"]])+ RUpper -> prPrec i 3 (concat [["{alphaCapital}"]])+ RLower -> prPrec i 3 (concat [["{alphaSmall}"]])+ RAny -> prPrec i 3 (concat [["."]])++-- Handle special characters in regular expressions.+mkEsc :: String -> String+mkEsc = concatMap escChar+ where escChar c+ | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c]+ | otherwise = [c]
+ src/BNFC/Backend/Common/Makefile.hs view
@@ -0,0 +1,26 @@+module BNFC.Backend.Common.Makefile where++import Text.Printf+import Text.Show (ShowS) -- Efficient string concatenation+import System.FilePath (replaceExtension)++import BNFC.Options (SharedOptions(..))+import BNFC.Backend.Base (mkfile, Backend)++type Makefile = ShowS+++mkRule :: String -- ^ The target name+ -> [String] -- ^ Dependencies+ -> [String] -- ^ Recipe+ -> Makefile+mkRule target deps recipe = (++) $ unlines $+ [ unwords (printf "%s:" target:deps) ]+ ++ map (printf "\t%s") recipe+ ++ [""]++-- | Create the Makefile file using the name specified in the option+-- record.+mkMakefile :: SharedOptions -> String -> Backend+mkMakefile Options {make = Nothing} _ = return ()+mkMakefile Options {make = Just makefile} content = mkfile makefile content
+ src/BNFC/Backend/Common/NamedVariables.hs view
@@ -0,0 +1,146 @@++{-+ BNF Converter: Named instance variables+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++{-+ **************************************************************+ BNF Converter Module++ Description : This module provides support for languages which need+ named instance variables. (IE Java, C, C++) It provides+ a data type to represent the name mapping and utility+ functions to work with it.++ Variables are grouped and numbered in a nice way.++ Author : Michael Pellauer (pellauer@cs.chalmers.se)++ **************************************************************++The idea of this module is the following (if I got it correctly):++In some target languages (e.g. java or C) you need to create a variable name+for each non terminal in a given rule. For instance, the following rules:+> SomeFunction. A ::= B C D ;+could be represented in C by a structure like:++@+struct A {+ B b_;+ C c_;+ D d_;+}+@+(note that this is not exactly the representation produced by bnfc)++but if there is several non terminal of the same category, we need to number+them. Eg:+> SomeFunction. A = B B ;++Should become something like:+@+struct A {+ B b_1, b_2;+}+@++This is what this module does.++-}++module BNFC.Backend.Common.NamedVariables where++import BNFC.CF+import Data.Char (toLower)+import Data.List (nub)++type IVar = (String, Int)+--The type of an instance variable+--and a # unique to that type++type UserDef = Cat --user-defined types+++--A symbol-mapping environment.+type SymEnv = [(String, String)]++-- | Converts a list of categories into their types to be used as instance+-- variables. If a category appears only once, it is given the number 0,+-- if it appears more than once, its occurrences are numbered from 1. ex:+--+-- >>> getVars [Cat "A", Cat "B", Cat "A"]+-- [("A",1),("B",0),("A",2)]+--+getVars :: [Cat] -> [IVar]+getVars [] = []+getVars cs = foldl addVar [] (map identCat cs)+ where+ addVar vs c = addVar' vs 0 c+ addVar' [] n c = [(c, n)]+ addVar' (i@(t,x):is) n c =+ if c == t+ then if x == 0+ then (t, 1) : (addVar' is 2 c)+ else i : (addVar' is (x+1) c)+ else i : (addVar' is n c)++--Given a rule's definition, it goes through and nicely the variables by type.+numVars :: [(String, Int)] -> [Either Cat b] -> [Either String b]+numVars _env [] = []+numVars env ((Right f) : fs) = (Right f) : (numVars env fs)+numVars env ((Left f) : fs) =+ case lookup f' env of+ Nothing -> (Left f') : (numVars ((f',1):env) fs)+ Just n -> (Left $ f' ++ (show $ n + 1)) : (numVars ((f',n+1):env) fs)+ where+ f' = varName (identCat (normCat f))++--This makes numbers a little nicer.+--If there's only one variable of a type we drop the redundant _1 label.+--(Actually here we add _1 labels to variables that need it, but the effect+-- is the same.)+fixOnes :: Eq b => [Either String b] -> [Either String b]+fixOnes [] = []+fixOnes ((Right f): fs) = (Right f) : (fixOnes fs)+fixOnes ((Left f) : fs) =+ if elem (Left (f ++ "2")) fs+ then (Left (f ++ "1")) : (fixOnes fs)+ else (Left f) : (fixOnes fs)++--This fixes the problem with coercions.+fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])]+fixCoercions rs = nub (fixAll rs rs)+ where+ fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule]+ fixCoercion _ [] = []+ fixCoercion cat ((c,rules):cats) = if (normCat c) == (normCat cat)+ then rules ++ (fixCoercion cat cats)+ else fixCoercion cat cats+ fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]+ fixAll _ [] = []+ fixAll top ((cat,rules):cats) = if isCoercion (show cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!+ then fixAll top cats+ else (normCat cat, fixCoercion cat top) : (fixAll top cats)++--A generic variable name for C-like languages.+varName c = (map toLower c) ++ "_"++--this makes var names a little cleaner.+showNum n = if n == 0 then [] else (show n)
+ src/BNFC/Backend/Common/OOAbstract.hs view
@@ -0,0 +1,129 @@+{-+ BNF Converter: Datastructure for object-oriented abstract syntax generators+ Copyright (C) 2006 Author: Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module defines a data structure that is+ used for generating abstract syntax in cpp_stl.+ It should be used in other STL modules as well,+ and could be used for object-oriented languages+ in general, to avoid duplicated work.++ Author : Aarne Ranta (aarne@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 29 August, 2006++ Modified : 29 August, 2006 / Aarne Ranta+++ **************************************************************+-}++module BNFC.Backend.Common.OOAbstract where++import BNFC.CF+import BNFC.Utils((+++),(++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower)++-- A datastructure more appropriate than CF++data CAbs = CAbs {+ tokentypes :: [String], -- user non-position token types+ listtypes :: [(String,Bool)], -- list types used, whether of classes+ absclasses :: [String], -- grammar-def cats, normalized names+ conclasses :: [Fun], -- constructors, except list ones+ signatures :: [(String,[CAbsRule])], -- rules for each class, incl. pos tokens+ postokens :: [String], -- position token types+ defineds :: [Fun] -- defined (non-)constructors+ }++-- (valcat,(constr,args)), True = is class (not basic), class variable stored+type CAbsRule = (Fun,[(String,Bool,String)])++-- all those names that denote classes in C+++allClasses :: CAbs -> [String]+allClasses ca =+ absclasses ca ++ conclasses ca ++ map fst (listtypes ca) ++ postokens ca++-- all those names that denote non-class types in C+++allNonClasses :: CAbs -> [String]+allNonClasses ca =+ map fst basetypes ++ tokentypes ca++cf2cabs :: CF -> CAbs+cf2cabs cf = CAbs {+ tokentypes = toks,+ listtypes = [(c, snd (status (drop 4 c))) | -- remove "List" from "ListC"+ c <- map (identCat . normCat) lists],+ absclasses = nub $ map (show.normCat) cats,+ conclasses = [f | Just f <- map testRule (rulesOfCF cf)],+ signatures = posdata ++ map normSig (cf2data cf),+ postokens = map show pos,+ defineds = defs+ }+ where+ (pos,base) = partition (isPositionCat cf) $ fst (unzip (tokenPragmas cf))+ (lists,cats) = partition isList $ allCats cf+ toks = map (show.normCat) base+ testRule (Rule f c r)+ | isList c = Nothing+ | f == "_" = Nothing+ | otherwise = Just f+ normSig (c,fcs) =+ (identCat c,[(f, classVars (map (status . identCat) cs)) | (f,cs) <- fcs])+ posdata =+ [("Visitable", -- to give superclass+ [(show c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos]+ status cat = (cat, notElem cat (map fst basetypes ++ toks))+ defs = [f | FunDef f _ _ <- pragmasOfCF cf]++ classVars :: [(String,Bool)] -> [(String,Bool,String)]+ classVars cs =+ [(c,b,s) | ((c,b),s) <- zip cs (vars [] (map (classVar . fst) cs))]+ --- creating new names is quadratic, but parameter lists are short+ --- this should conform with Michael's naming+ vars seen vv = case vv of+ [] -> vv+ v:vs -> case length (filter (==v) seen) of+ 0 | elem v vs -> (v ++ "1"): vars (v:seen) vs+ 0 -> v : vars (v:seen) vs+ n -> (v ++ show (n+1)) : vars (v:seen) vs++basetypes = [+ ("Integer","int"),+ ("Char", "char"),+ ("Double", "double"),+ ("String", "std::string"),+ ("Ident", "std::string")+ ]++isBaseType :: CAbs -> String -> Bool+isBaseType cf c = elem c $ tokentypes cf ++ map fst basetypes++classVar :: String -> String+classVar c = map toLower c ++ "_"++pointerIf :: Bool -> String -> String+pointerIf b v = if b then "*" ++ v else v
+ src/BNFC/Backend/Common/StrUtils.hs view
@@ -0,0 +1,28 @@+module BNFC.Backend.Common.StrUtils where++-- | Function that, given an input string, renders it either as a char (if+-- it has legth 1) or a string. It should also excape characters correctly.+-- The first returned value is the 'type' of the string: either C for char+-- or S for string. (used in the C printer to choose the right rendering+-- function)+-- e.g.+-- >>> renderCharOrString "a"+-- ('C',"'a'")+-- >>> renderCharOrString "abc"+-- ('S',"\"abc\"")+-- >>> renderCharOrString "'"+-- ('C',"'\\''")+-- >>> renderCharOrString "\"\\'"+-- ('S',"\"\\\"\\\\'\"")+renderCharOrString :: String -> (Char, String)+renderCharOrString [char] = ('C', show char) -- using show shoud quote '+renderCharOrString s =('S', "\"" ++ escapeChars s ++ "\"")++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars [] = []+escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))+escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))+escapeChars (x:xs) = x : (escapeChars xs)++
+ src/BNFC/Backend/Haskell.hs view
@@ -0,0 +1,278 @@+{-+ BNF Converter: Haskell main file+ Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Haskell (makeHaskell, AlexVersion(..), makefile) where++++-- import BNFC.Utils+import BNFC.Options hiding (Backend)+import BNFC.CF+import BNFC.Backend.Base+import BNFC.Backend.Haskell.CFtoHappy+import BNFC.Backend.Haskell.CFtoAlex+import BNFC.Backend.Haskell.CFtoAlex2+import BNFC.Backend.Haskell.CFtoAlex3+import BNFC.Backend.Txt2Tag+import BNFC.Backend.Haskell.CFtoAbstract+import BNFC.Backend.Haskell.CFtoTemplate+import BNFC.Backend.Haskell.CFtoPrinter+import BNFC.Backend.Haskell.CFtoLayout+import BNFC.Backend.XML+import BNFC.Backend.Haskell.HsOpts+import BNFC.Backend.Haskell.ToCNF as ToCNF+import BNFC.Backend.Haskell.MkErrM+import BNFC.Backend.Haskell.MkSharedString+import BNFC.Utils+import qualified BNFC.Backend.Common.Makefile as Makefile++import Data.Char+import Data.Maybe (fromMaybe,maybe)+import System.Exit (exitFailure)+import System.FilePath (pathSeparator,(</>))+import Control.Monad(when,unless)+import System.FilePath (takeFileName)+import Text.Printf (printf)++-- naming conventions+++++makeHaskell :: SharedOptions -> CF -> Backend+makeHaskell opts cf = do+ let absMod = absFileM opts+ lexMod = alexFileM opts+ parMod = happyFileM opts+ prMod = printerFileM opts+ layMod = layoutFileM opts+ errMod = errFileM opts+ shareMod = shareFileM opts+ do+ let dir = codeDir opts+ mkfile (absFile opts) $ cf2Abstract (byteStrings opts) (ghcExtensions opts) absMod cf+ case alexMode opts of+ Alex1 -> do+ mkfile (alexFile opts) $ cf2alex lexMod errMod cf+ liftIO $ printf "Use Alex 1.1 to compile %s.\n" (alexFile opts)+ Alex2 -> do+ mkfile (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf+ liftIO $ printf "Use Alex 2.0 to compile %s.\n" (alexFile opts)+ Alex3 -> do+ mkfile (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf+ liftIO $ printf "Use Alex 3.0 to compile %s.\n" (alexFile opts)+ unless (cnf opts) $ do + mkfile (happyFile opts) $+ cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf+ liftIO $ printf "%s Tested with Happy 1.15\n" (happyFile opts)+ mkfile (tFile opts) $ testfile opts cf+ mkfile (txtFile opts) $ cfToTxt (lang opts) cf+ mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf+ mkfile (printerFile opts) $ cf2Printer (byteStrings opts) prMod absMod cf+ when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf+ mkfile (errFile opts) $ errM errMod cf+ when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf+ Makefile.mkMakefile opts $ makefile opts+ case xml opts of+ 2 -> makeXML opts True cf+ 1 -> makeXML opts False cf+ _ -> return ()+ when (cnf opts) $ do+ mkfile (cnfTablesFile opts) $ ToCNF.generate opts cf+ mkfile "TestCNF.hs" $ ToCNF.genTestFile opts cf+ mkfile "BenchCNF.hs" $ ToCNF.genBenchmark opts++codeDir :: Options -> FilePath+codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)+ dir = if inDir opts then lang opts else ""+ sep = if null pref || null dir then "" else [pathSeparator]+ in pref ++ sep ++ dir++makefile :: Options -> String+makefile opts = makeA where+ glr_params = if glr opts == GLR then "--glr --decode " else ""+ dir = let d = codeDir opts in if null d then "" else d ++ [pathSeparator]+ cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")"+ makeA = Makefile.mkRule "all" []+ ([ "happy -gca " ++ glr_params ++ happyFile opts | not (cnf opts) ] +++ [ "alex -g " ++ alexFile opts ] +++ [ if cnf opts + then "ghc --make TestCNF.hs"+ else "ghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts])+ $ Makefile.mkRule "clean" []+ [ "-rm -f " ++ unwords+ (map (dir++) [ "*.log", "*.aux", "*.hi", "*.o", "*.dvi" ])+ , "-rm -f " ++ psFile opts ]+ $ Makefile.mkRule "distclean" ["clean"]+ [ "-rm -f " ++ unwords+ [ mkFile withLang "Doc" "*" opts+ , mkFile withLang "Lex" "*" opts+ , mkFile withLang "Par" "*" opts+ , mkFile withLang "Layout" "*" opts+ , mkFile withLang "Skel" "*" opts+ , mkFile withLang "Print" "*" opts+ , mkFile withLang "Test" "*" opts+ , mkFile withLang "Abs" "*" opts+ , mkFile withLang "Test" "" opts+ , mkFile noLang "ErrM" "*" opts+ , mkFile noLang "SharedString" "*" opts+ , mkFile withLang "ComposOp" "*" opts+ , dir ++ lang opts ++ ".dtd"+ , mkFile withLang "XML" "*" opts+ , "Makefile*" ]+ , if null dir then "" else "\t-rmdir -p " ++ dir ]+ ""++testfile :: Options -> CF -> String+testfile opts cf+ = let lay = hasLayout cf+ use_xml = xml opts > 0+ xpr = if use_xml then "XPrint a, " else ""+ use_glr = glr opts == GLR+ if_glr s = if use_glr then s else ""+ firstParser = if use_glr then "the_parser" else parserName+ parserName = 'p' : topType+ topType = show (firstEntry cf)+ in unlines+ ["-- automatically generated by BNF Converter",+ "module Main where\n",+ "",+ "import System.IO ( stdin, hGetContents )",+ "import System.Environment ( getArgs, getProgName )",+ "import System.Exit ( exitFailure, exitSuccess )",+ "",+ "import " ++ alexFileM opts,+ "import " ++ happyFileM opts,+ "import " ++ templateFileM opts,+ "import " ++ printerFileM opts,+ "import " ++ absFileM opts,+ if lay then "import " ++ layoutFileM opts else "",+ if use_xml then "import " ++ xmlFileM opts else "",+ if_glr "import qualified Data.Map(Map, lookup, toList)",+ if_glr "import Data.Maybe(fromJust)",+ "import " ++ errFileM opts,+ "",+ if use_glr+ then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"+ else "type ParseFun a = [Token] -> Err a",+ "",+ "myLLexer = " ++ if lay then "resolveLayout True . myLexer"+ else "myLexer",+ "",+ "type Verbosity = Int",+ "",+ "putStrV :: Verbosity -> String -> IO ()",+ "putStrV v s = if v > 1 then putStrLn s else return ()",+ "",+ "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()",+ "runFile v p f = putStrLn f >> readFile f >>= run v p",+ "",+ "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()",+ if use_glr then run_glr else run_std use_xml,+ "",+ "showTree :: (Show a, Print a) => Int -> a -> IO ()",+ "showTree v tree",+ " = do",+ " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree",+ " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree",+ "",+ "main :: IO ()",+ "main = do args <- getArgs",+ " case args of",+ " [] -> hGetContents stdin >>= run 2 " ++ firstParser,+ " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",+ " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",+ "",+ if_glr $ "the_parser :: ParseFun " ++ topType,+ if_glr $ "the_parser = lift_parser " ++ parserName,+ if_glr $ "",+ if_glr $ lift_parser+ ]++run_std xml+ = unlines+ [ "run v p s = let ts = myLLexer s in case p ts of"+ , " Bad s -> do putStrLn \"\\nParse Failed...\\n\""+ , " putStrV v \"Tokens:\""+ , " putStrV v $ show ts"+ , " putStrLn s"+ , " exitFailure"+ , " Ok tree -> do putStrLn \"\\nParse Successful!\""+ , " showTree v tree"+ , if xml then+ " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"+ else ""+ , " exitSuccess"+ ]++run_glr+ = unlines+ [ "run v p s"+ , " = let ts = map (:[]) $ myLLexer s"+ , " (raw_output, simple_output) = p ts in"+ , " case simple_output of"+ , " GLR_Fail major minor -> do"+ , " putStrLn major"+ , " putStrV v minor"+ , " GLR_Result df trees -> do"+ , " putStrLn \"\\nParse Successful!\""+ , " case trees of"+ , " [] -> error \"No results but parse succeeded?\""+ , " [Ok x] -> showTree v x"+ , " xs@(_:_) -> showSeveralTrees v xs"+ , " where"+ , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()"+ , " showSeveralTrees v trees"+ , " = sequence_ "+ , " [ do putStrV v (replicate 40 '-')"+ , " putStrV v $ \"Parse number: \" ++ show n"+ , " showTree v t"+ , " | (Ok t,n) <- zip trees [1..]"+ , " ]"+ ]+++lift_parser+ = unlines+ [ "type Forest = Data.Map.Map ForestId [Branch] -- omitted in ParX export."+ , "data GLR_Output a"+ , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]"+ , " , semantic_result :: [a]"+ , " }"+ , " | GLR_Fail { main_message :: String"+ , " , extra_info :: String"+ , " }"+ , ""+ , "lift_parser"+ , " :: (TreeDecode a, Show a, Print a)"+ , " => ([[Token]] -> GLRResult) -> ParseFun a"+ , "lift_parser parser ts"+ , " = let result = parser ts in"+ , " (\\o -> (result, o)) $"+ , " case result of"+ , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\""+ , " (\"Tokens: \" ++ show ts)"+ , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\""+ , " (\"Partial forest:\\n\""+ , " ++ unlines (map show $ Data.Map.toList f))"+ , " ParseOK r f -> let find f = fromJust . ((flip Data.Map.lookup) f)"+ , " dec_fn f = decode (find f) r"+ , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)"+ ]+
+ src/BNFC/Backend/Haskell/CFtoAbstract.hs view
@@ -0,0 +1,61 @@+{- + BNF Converter: Abstract syntax Generator + Copyright (C) 2004 Author: Markus Forberg + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract) where + +import BNFC.CF +import BNFC.Utils((+++),(++++),prParenth) +import Data.List(intersperse,intercalate) + +-- to produce a Haskell module +cf2Abstract :: Bool -> Bool -> String -> CF -> String +cf2Abstract byteStrings ghcExtensions name cf = unlines $ + (if ghcExtensions then "{-# LANGUAGE DeriveDataTypeable #-}" else "") : + (if ghcExtensions then "{-# LANGUAGE DeriveGeneric #-}" else "") : + ("module "++name +++ "where\n") : + "-- Haskell module generated by the BNF converter\n" : + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "") : + (if ghcExtensions then "import Data.Data (Data,Typeable)" else "") : + (if ghcExtensions then "import GHC.Generics (Generic)" else "") : + (map (prSpecialData byteStrings cf derivingClasses) (specialCats cf) ++ map (prData derivingClasses) (cf2data cf)) + where + derivingClasses = prParenth . intercalate "," $ concat + [ ["Eq","Ord","Show","Read"] + , (if ghcExtensions then ["Data","Typeable","Generic"] else []) + ] + +prData :: String -> Data -> String +prData derivingClasses (cat,rules) = + "data" +++ show cat +++ "=\n " ++ + concat (intersperse "\n | " (map prRule rules)) ++++ + " deriving" +++ derivingClasses ++ "\n" + where + prRule (fun,cats) = unwords (fun:map show cats) + +prSpecialData :: Bool -> CF -> String -> Cat -> String +prSpecialData byteStrings cf derivingClasses cat = + unwords [ "newtype", show cat, "=", show cat, contentSpec byteStrings cf cat + , "deriving", derivingClasses ] + +contentSpec :: Bool -> CF -> Cat -> String +contentSpec byteStrings cf cat = if isPositionCat cf cat then "((Int,Int),"++stringType++")" else stringType + where + stringType + | byteStrings = "BS.ByteString" + | otherwise = "String"
+ src/BNFC/Backend/Haskell/CFtoAlex.hs view
@@ -0,0 +1,230 @@+{-+ BNF Converter: Alex 1.1 Generator+ Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++module BNFC.Backend.Haskell.CFtoAlex (cf2alex) where++import BNFC.CF+import BNFC.Backend.Haskell.RegToAlex+import Data.List++cf2alex :: String -> String -> CF -> String+cf2alex name errMod cf = unlines $ concat $ intersperse [""] [+ prelude name errMod,+ cMacros,+ rMacros cf,+ restOfAlex cf+ ]++prelude :: String -> String -> [String]+prelude name errMod = [+ "-- This Alex file was machine-generated by the BNF converter",+ "%{",+ "module " ++ name ++ " where",+ "",+ "import Alex",+ "import " ++ errMod,+ "%}"+ ]+{- ----+cf2alex :: String -> CF -> String+cf2alex name cf = unlines $ concat $ intersperse [""] [+ prelude name,+ cMacros,+ rMacros cf,+ restOfAlex cf+ ]++prelude :: String -> [String]+prelude name = [+ "-- This Alex file was machine-generated by the BNF converter",+ "%{",+ "module Lex" ++ name ++ " where",+ "",+ "import Alex",+ "import ErrM",+ "%}"+ ]+-}+cMacros :: [String]+cMacros = [+ "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter",+ "{ ^c = [A-Z^192-^221] # [^215]} -- capital isolatin1 letter",+ "{ ^s = [a-z^222-^255] # [^247]} -- small isolatin1 letter",+ "{ ^d = [0-9] } -- digit",+ "{ ^i = [^l^d^'^_] } -- identifier character",+ "{ ^u = [^0-^255] } -- universal: any character"+ ]++rMacros :: CF -> [String]+rMacros cf =+ let symbs = symbols cf+ in+ (if null symbs then [] else [+ "{ %s = -- reserved words consisting of special symbols",+ " " ++ unwords (intersperse "|" (map mkEsc symbs)),+ "}"+ ])+ where+ mkEsc = unwords . map ( f . (:[]))+ f s = if all isSpec s then '^':s else s+ isSpec = flip elem "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\""++restOfAlex :: CF -> [String]+restOfAlex cf = [+ "\"tokens_lx\"/\"tokens_acts\":-",+ lexComments (comments cf),+ "<> ::= ^w+",+ pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002++ userDefTokenTypes,+ identAndRes,++ ifC catString "<string> ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" +++ "%{ string p = PT p . TL . unescapeInitTail %}",+ ifC catChar "<char> ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}",+ ifC catInteger "<int> ::= ^d+ %{ int p = PT p . TI %}",+ ifC catDouble+ "<double> ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double p = PT p . TD %}",+ "",+ "%{ ",+ "",+ "data Tok =",+ " TS String -- reserved words",+ " | TL String -- string literals",+ " | TI String -- integer literals",+ " | TV String -- identifiers",+ " | TD String -- double precision float literals",+ " | TC String -- character literals",+ userDefTokenConstrs,+ " deriving (Eq,Show)",+ "",+ "data Token = ",+ " PT Posn Tok",+ " | Err Posn",+ " deriving Show",+ "",+ "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",+ "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",+ "tokenPos _ = \"end of file\"",+ "",+ "posLineCol (Pn _ l c) = (l,c)",+ "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",+ "",+ "prToken t = case t of",+ " PT _ (TS s) -> s",+ " PT _ (TI s) -> s",+ " PT _ (TV s) -> s",+ " PT _ (TD s) -> s",+ " PT _ (TC s) -> s",+ userDefTokenPrint,+ " _ -> show t",+ "",+ "tokens:: String -> [Token]",+ "tokens inp = scan tokens_scan inp",+ "",+ "tokens_scan:: Scan Token",+ "tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx",+ " where",+ " stop_act p \"\" = []",+ " stop_act p inp = [Err p]",+ "",+ "eitherResIdent :: (String -> Tok) -> String -> Tok",+ "eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where",+ " isResWord s = isInTree s $",+ " " ++ (show $ sorted2tree $ sort resws),+ "",+ "data BTree = N | B String BTree BTree deriving (Show)",+ "",+ "isInTree :: String -> BTree -> Bool",+ "isInTree x tree = case tree of",+ " N -> False",+ " B a left right",+ " | x < a -> isInTree x left",+ " | x > a -> isInTree x right",+ " | x == a -> True",+ "",+ "unescapeInitTail :: String -> String",+ "unescapeInitTail = unesc . tail where",+ " unesc s = case s of",+ " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",+ " '\\\\':'n':cs -> '\\n' : unesc cs",+ " '\\\\':'t':cs -> '\\t' : unesc cs",+ " '\"':[] -> []",+ " c:cs -> c : unesc cs",+ " _ -> []",+ "%}"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ lexComments ([],[]) = []+ lexComments (xs,s1:ys) = "<> ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys)+ lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $+ [+ "<> ::= ",+ ('^':l1:' ':'^':l2:" ([^u # ^"),+ (l2:"] | ^"),+ (r1:" [^u # ^"),+ (r2:"])* (^"),+ (r1:")+ ^"),+ (r2:"\n"),+ lexComments (xs,[])+ ]+ lexComments ((_:xs),[]) = lexComments (xs,[])+--- lexComments (xs,(_:ys)) = lexComments (xs,ys)+ pTSpec ([],[]) = ""+ pTSpec xp =+ "<pTSpec> ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}"+ aux (xs,[]) = " %s "+ aux ([],ys) = " %r "+ aux (xs,ys) = " %s | %r "+ resWs =+ "[" ++ concat (intersperse "," [show s | s <- resws]) ++ "]"+ --- show s can be strange for isolatin1 characters+ --- precompile to search tree!++ userDefTokenTypes = unlines $+ ["<mk_" ++ show name ++ "> ::= " ++ printRegAlex exp +++ "%{ mk_" ++ show name ++ " p = PT p . eitherResIdent T_" ++ show name ++ " %}"+ | (name,exp) <- tokenPragmas cf]+ userDefTokenConstrs = unlines $+ [" | T_" ++ name ++ " String" | name <- tokenNames cf]+ userDefTokenPrint = unlines $+ [" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]++ identAndRes = --This has to be there for Reserved Words. Michael+ "<ident> ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}"+ --ifC "Ident" "<ident> ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}"++ resws = reservedWords cf++data BTree = N | B String BTree BTree deriving (Show)++isInTree :: String -> BTree -> Bool+isInTree x tree = case tree of+ N -> False+ B a left right+ | x < a -> isInTree x left+ | x > a -> isInTree x right+ | x == a -> True++sorted2tree :: [String] -> BTree+sorted2tree [] = N+sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where+ (t1,(x:t2)) = splitAt (length xs `div` 2) xs
+ src/BNFC/Backend/Haskell/CFtoAlex2.hs view
@@ -0,0 +1,339 @@+{-+ BNF Converter: Alex 2.0 Generator+ Copyright (C) 2004 Author: Peter Gammie++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-------------------------------------------------------------------+-- |+-- Module : BNFC.Backend.Haskell.CFtoAlex2+-- Copyright : (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se+-- License : GPL (see COPYING for details)+--+-- Maintainer : {markus,aarne} at cs dot chalmers dot se+-- Stability : alpha+-- Portability : Haskell98+--+-- Hacked version of @BNFC.Backend.Haskell.CFtoAlex@ to cope with Alex2.+--+-------------------------------------------------------------------+module BNFC.Backend.Haskell.CFtoAlex2 (cf2alex2) where++import BNFC.CF+import Data.List++-- For RegToAlex, see below.+import AbsBNF+import Data.Char++cf2alex2 :: String -> String -> String -> Bool -> Bool -> CF -> String+cf2alex2 name errMod shareMod shareStrings byteStrings cf =+ unlines $ concat $ intersperse [""] [+ prelude name errMod shareMod shareStrings byteStrings,+ cMacros,+ rMacros cf,+ restOfAlex shareMod shareStrings byteStrings cf+ ]++prelude :: String -> String -> String -> Bool -> Bool -> [String]+prelude name errMod shareMod shareStrings byteStrings = [+ "-- -*- haskell -*-",+ "-- This Alex file was machine-generated by the BNF converter",+ "{",+ "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}",+ "module " ++ name ++ " where",+ "",+ -- "import " ++ errMod,+ if shareStrings then "import " ++ shareMod else "",+ if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",+ "}",+ ""+ ]++cMacros :: [String]+cMacros = [+ "$l = [a-zA-Z\\192 - \\255] # [\\215 \\247] -- isolatin1 letter FIXME",+ "$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter FIXME",+ "$s = [a-z\\222-\\255] # [\\247] -- small isolatin1 letter FIXME",+ "$d = [0-9] -- digit",+ "$i = [$l $d _ '] -- identifier character",+ "$u = [\\0-\\255] -- universal: any character"+ ]++rMacros :: CF -> [String]+rMacros cf =+ let symbs = symbols cf+ in+ (if null symbs then [] else [+ "@rsyms = -- symbols and non-identifier-like reserved words",+ " " ++ unwords (intersperse "|" (map mkEsc symbs))+ ])+ where+ mkEsc = unwords . esc+ esc s = if null a then rest else show a : rest+ where (a,r) = span isAlphaNum s+ rest = case r of+ [] -> []+ (c:xs) -> s : esc xs+ where s = if isPrint c then ['\\',c]+ else '\\':show (ord c)++restOfAlex :: String -> Bool -> Bool -> CF -> [String]+restOfAlex shareMod shareStrings byteStrings cf = [+ ":-",+ lexComments (comments cf),+ "$white+ ;",+ pTSpec (symbols cf),++ userDefTokenTypes,+ ident,++ ifC catString ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" +++ "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"),+ ifC catChar "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }",+ ifC catInteger "$d+ { tok (\\p s -> PT p (TI $ share s)) }",+ ifC catDouble "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }",+ "",+ "{",+ "",+ "tok f p s = f p s",+ "",+ "share :: "++stringType++" -> "++stringType,+ "share = " ++ if shareStrings then "shareString" else "id",+ "",+ "data Tok =",+ " TS !"++stringType++" !Int -- reserved words and symbols",+ " | TL !"++stringType++" -- string literals",+ " | TI !"++stringType++" -- integer literals",+ " | TV !"++stringType++" -- identifiers",+ " | TD !"++stringType++" -- double precision float literals",+ " | TC !"++stringType++" -- character literals",+ userDefTokenConstrs,+ " deriving (Eq,Show,Ord)",+ "",+ "data Token = ",+ " PT Posn Tok",+ " | Err Posn",+ " deriving (Eq,Show,Ord)",+ "",+ "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",+ "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",+ "tokenPos _ = \"end of file\"",+ "",+ "posLineCol (Pn _ l c) = (l,c)",+ "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",+ "",+ "prToken t = case t of",+ " PT _ (TS s _) -> s",+ " PT _ (TL s) -> s",+ " PT _ (TI s) -> s",+ " PT _ (TV s) -> s",+ " PT _ (TD s) -> s",+ " PT _ (TC s) -> s",+ userDefTokenPrint,+ "",+ "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",+ "",+ "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",+ "eitherResIdent tv s = treeFind resWords",+ " where",+ " treeFind N = tv s",+ " treeFind (B a t left right) | s < a = treeFind left",+ " | s > a = treeFind right",+ " | s == a = t",+ "",+ "resWords = " ++ (show $ sorted2tree $ zip (sort resws) [1..]),+ " where b s n = let bs = "++stringPack++" s",+ " in B bs (TS bs n)",+ "",+ "unescapeInitTail :: "++stringType++" -> "++stringType++"",+ "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",+ " unesc s = case s of",+ " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",+ " '\\\\':'n':cs -> '\\n' : unesc cs",+ " '\\\\':'t':cs -> '\\t' : unesc cs",+ " '\"':[] -> []",+ " c:cs -> c : unesc cs",+ " _ -> []",+ "",+ "-------------------------------------------------------------------",+ "-- Alex wrapper code.",+ "-- A modified \"posn\" wrapper.",+ "-------------------------------------------------------------------",+ "",+ "data Posn = Pn !Int !Int !Int",+ " deriving (Eq, Show,Ord)",+ "",+ "alexStartPos :: Posn",+ "alexStartPos = Pn 0 1 1",+ "",+ "alexMove :: Posn -> Char -> Posn",+ "alexMove (Pn a l c) '\\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)",+ "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1) 1",+ "alexMove (Pn a l c) _ = Pn (a+1) l (c+1)",+ "",+ "type AlexInput = (Posn, -- current position,",+ " Char, -- previous char",+ " "++stringType++") -- current input string",+ "",+ "tokens :: "++stringType++" -> [Token]",+ "tokens str = go (alexStartPos, '\\n', str)",+ " where",+ " go :: AlexInput -> [Token]",+ " go inp@(pos, _, str) =",+ " case alexScan inp 0 of",+ " AlexEOF -> []",+ " AlexError (pos, _, _) -> [Err pos]",+ " AlexSkip inp' len -> go inp'",+ " AlexToken inp' len act -> act pos ("++stringTake++" len str) : (go inp')",+ "",+ "alexGetChar :: AlexInput -> Maybe (Char,AlexInput)",+ "alexGetChar (p, _, s) =",+ " case "++stringUncons++" s of",+ " "++stringNilP++" -> Nothing",+ " "++stringConsP++" ->",+ " let p' = alexMove p c",+ " in p' `seq` Just (c, (p', c, s))",+ "",+ "alexInputPrevChar :: AlexInput -> Char",+ "alexInputPrevChar (p, c, s) = c",+ "}"+ ]+ where+ (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP)+ | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")+ | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" )++ ifC cat s = if isUsedCat cf cat then s else ""+ lexComments ([],[]) = []+ lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys)+ lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $+ [+ ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape?+ (r1:"] | \\"),+ (r1:"+ [$u # [\\"),+ (r1:" \\"),+ (r2:"]])* (\""),+ (r1:"\")+ \""),+ (r2:"\" ; \n"),+ lexComments (xs, [])+ ]+ lexComments ((_:xs),[]) = lexComments (xs,[])+--- lexComments (xs,(_:ys)) = lexComments (xs,ys)++ -- tokens consisting of special symbols+ pTSpec [] = ""+ pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"++ userDefTokenTypes = unlines $+ [printRegAlex exp +++ " { tok (\\p s -> PT p (eitherResIdent (T_" ++ show name ++ " . share) s)) }"+ | (name,exp) <- tokenPragmas cf]+ userDefTokenConstrs = unlines $+ [" | T_" ++ name ++ " !"++stringType | name <- tokenNames cf]+ userDefTokenPrint = unlines $+ [" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]++ ident =+ "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"+ --ifC "Ident" "<ident> ::= ^l ^i* { ident p = PT p . eitherResIdent TV }"++ resws = reservedWords cf ++ symbols cf+++data BTree = N | B String Int BTree BTree++instance Show BTree where+ showsPrec _ N = showString "N"+ showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '+ . showsPrec 1 l . showChar ' '+ . showsPrec 1 r)+ where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f++sorted2tree :: [(String,Int)] -> BTree+sorted2tree [] = N+sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where+ (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs+++-------------------------------------------------------------------+-- Inlined version of @BNFC.Backend.Haskell.RegToAlex@.+-- Syntax has changed...+-------------------------------------------------------------------++-- modified from pretty-printer generated by the BNF converter++-- the top-level printing method+printRegAlex :: Reg -> String+printRegAlex = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend 0+ where rend :: Int -> [String] -> String+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""++ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ " " ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]]+ prtList s = map (concat . prt 0) s++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["()"])+ RChar c -> prPrec i 3 (concat [prt 0 c])+ RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) str))+ RDigit -> prPrec i 3 (concat [["$d"]])+ RLetter -> prPrec i 3 (concat [["$l"]])+ RUpper -> prPrec i 3 (concat [["$c"]])+ RLower -> prPrec i 3 (concat [["$s"]])+ RAny -> prPrec i 3 (concat [["$u"]])
+ src/BNFC/Backend/Haskell/CFtoAlex3.hs view
@@ -0,0 +1,363 @@+{-+ BNF Converter: Alex 3.0 Generator+ Copyright (C) 2012 Author: Antti-Juhani Kaijanaho+ Copyright (C) 2004 Author: Peter Gammie+ (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Haskell.CFtoAlex3 (cf2alex3) where++import BNFC.CF+import Data.List++-- For BNFC.Backend.Haskell.RegToAlex, see below.+import AbsBNF+import Data.Char++cf2alex3 :: String -> String -> String -> Bool -> Bool -> CF -> String+cf2alex3 name errMod shareMod shareStrings byteStrings cf =+ unlines $ concat $ intersperse [""] [+ prelude name errMod shareMod shareStrings byteStrings,+ cMacros,+ rMacros cf,+ restOfAlex shareMod shareStrings byteStrings cf+ ]++prelude :: String -> String -> String -> Bool -> Bool -> [String]+prelude name errMod shareMod shareStrings byteStrings = [+ "-- -*- haskell -*-",+ "-- This Alex file was machine-generated by the BNF converter",+ "{",+ "{-# OPTIONS -fno-warn-incomplete-patterns #-}",+ "{-# OPTIONS_GHC -w #-}",+ "module " ++ name ++ " where",+ "",+ -- "import " ++ errMod,+ if shareStrings then "import " ++ shareMod else "",+ if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",+ "import qualified Data.Bits",+ "import Data.Word (Word8)",+ "}",+ ""+ ]++cMacros :: [String]+cMacros = [+ "$l = [a-zA-Z\\192 - \\255] # [\\215 \\247] -- isolatin1 letter FIXME",+ "$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter FIXME",+ "$s = [a-z\\222-\\255] # [\\247] -- small isolatin1 letter FIXME",+ "$d = [0-9] -- digit",+ "$i = [$l $d _ '] -- identifier character",+ "$u = [\\0-\\255] -- universal: any character"+ ]++rMacros :: CF -> [String]+rMacros cf =+ let symbs = symbols cf+ in+ (if null symbs then [] else [+ "@rsyms = -- symbols and non-identifier-like reserved words",+ " " ++ unwords (intersperse "|" (map mkEsc symbs))+ ])+ where+ mkEsc = unwords . esc+ esc s = if null a then rest else show a : rest+ where (a,r) = span isAlphaNum s+ rest = case r of+ [] -> []+ (c:xs) -> s : esc xs+ where s = if isPrint c then ['\\',c]+ else '\\':show (ord c)++restOfAlex :: String -> Bool -> Bool -> CF -> [String]+restOfAlex shareMod shareStrings byteStrings cf = [+ ":-",+ lexComments (comments cf),+ "$white+ ;",+ pTSpec (symbols cf),++ userDefTokenTypes,+ ident,++ ifC catString ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" +++ "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"),+ ifC catChar "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }",+ ifC catInteger "$d+ { tok (\\p s -> PT p (TI $ share s)) }",+ ifC catDouble "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }",+ "",+ "{",+ "",+ "tok f p s = f p s",+ "",+ "share :: "++stringType++" -> "++stringType,+ "share = " ++ if shareStrings then "shareString" else "id",+ "",+ "data Tok =",+ " TS !"++stringType++" !Int -- reserved words and symbols",+ " | TL !"++stringType++" -- string literals",+ " | TI !"++stringType++" -- integer literals",+ " | TV !"++stringType++" -- identifiers",+ " | TD !"++stringType++" -- double precision float literals",+ " | TC !"++stringType++" -- character literals",+ userDefTokenConstrs,+ " deriving (Eq,Show,Ord)",+ "",+ "data Token = ",+ " PT Posn Tok",+ " | Err Posn",+ " deriving (Eq,Show,Ord)",+ "",+ "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l",+ "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l",+ "tokenPos _ = \"end of file\"",+ "",+ "tokenPosn (PT p _) = p",+ "tokenPosn (Err p) = p",+ "tokenLineCol = posLineCol . tokenPosn",+ "posLineCol (Pn _ l c) = (l,c)",+ "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",+ "",+ "prToken t = case t of",+ " PT _ (TS s _) -> s",+ " PT _ (TL s) -> s",+ " PT _ (TI s) -> s",+ " PT _ (TV s) -> s",+ " PT _ (TD s) -> s",+ " PT _ (TC s) -> s",+ userDefTokenPrint,+ "",+ "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",+ "",+ "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",+ "eitherResIdent tv s = treeFind resWords",+ " where",+ " treeFind N = tv s",+ " treeFind (B a t left right) | s < a = treeFind left",+ " | s > a = treeFind right",+ " | s == a = t",+ "",+ "resWords = " ++ (show $ sorted2tree $ cfTokens $ cf),+ " where b s n = let bs = "++stringPack++" s",+ " in B bs (TS bs n)",+ "",+ "unescapeInitTail :: "++stringType++" -> "++stringType++"",+ "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",+ " unesc s = case s of",+ " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",+ " '\\\\':'n':cs -> '\\n' : unesc cs",+ " '\\\\':'t':cs -> '\\t' : unesc cs",+ " '\"':[] -> []",+ " c:cs -> c : unesc cs",+ " _ -> []",+ "",+ "-------------------------------------------------------------------",+ "-- Alex wrapper code.",+ "-- A modified \"posn\" wrapper.",+ "-------------------------------------------------------------------",+ "",+ "data Posn = Pn !Int !Int !Int",+ " deriving (Eq, Show,Ord)",+ "",+ "alexStartPos :: Posn",+ "alexStartPos = Pn 0 1 1",+ "",+ "alexMove :: Posn -> Char -> Posn",+ "alexMove (Pn a l c) '\\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)",+ "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1) 1",+ "alexMove (Pn a l c) _ = Pn (a+1) l (c+1)",+ "",+ "type Byte = Word8",+ "",+ "type AlexInput = (Posn, -- current position,",+ " Char, -- previous char",+ " [Byte], -- pending bytes on the current char",+ " "++stringType++") -- current input string",+ "",+ "tokens :: "++stringType++" -> [Token]",+ "tokens str = go (alexStartPos, '\\n', [], str)",+ " where",+ " go :: AlexInput -> [Token]",+ " go inp@(pos, _, _, str) =",+ " case alexScan inp 0 of",+ " AlexEOF -> []",+ " AlexError (pos, _, _, _) -> [Err pos]",+ " AlexSkip inp' len -> go inp'",+ " AlexToken inp' len act -> act pos ("++stringTake++" len str) : (go inp')",+ "",+ "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)",+ "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))",+ "alexGetByte (p, _, [], s) =",+ " case "++stringUncons++" s of",+ " "++stringNilP++" -> Nothing",+ " "++stringConsP++" ->",+ " let p' = alexMove p c",+ " (b:bs) = utf8Encode c",+ " in p' `seq` Just (b, (p', c, bs, s))",+ "",+ "alexInputPrevChar :: AlexInput -> Char",+ "alexInputPrevChar (p, c, bs, s) = c",+ "",+ " -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.",+ "utf8Encode :: Char -> [Word8]",+ "utf8Encode = map fromIntegral . go . ord",+ " where",+ " go oc",+ " | oc <= 0x7f = [oc]",+ "",+ " | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)",+ " , 0x80 + oc Data.Bits..&. 0x3f",+ " ]",+ "",+ " | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)",+ " , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",+ " , 0x80 + oc Data.Bits..&. 0x3f",+ " ]",+ " | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)",+ " , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)",+ " , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",+ " , 0x80 + oc Data.Bits..&. 0x3f",+ " ]",+ "}"+ ]+ where+ (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP)+ | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")+ | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" )++ ifC cat s = if isUsedCat cf cat then s else ""+ lexComments ([],[]) = []+ lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys)+ lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $+ [+ ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape?+ (r1:"] | \\"),+ (r1:"+ [$u # [\\"),+ (r1:" \\"),+ (r2:"]])* (\""),+ (r1:"\")+ \""),+ (r2:"\" ; \n"),+ lexComments (xs, [])+ ]+ lexComments ((_:xs),[]) = lexComments (xs,[])+--- lexComments (xs,(_:ys)) = lexComments (xs,ys)++ -- tokens consisting of special symbols+ pTSpec [] = ""+ pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"++ userDefTokenTypes = unlines $+ [printRegAlex exp +++ " { tok (\\p s -> PT p (eitherResIdent (T_" ++ show name ++ " . share) s)) }"+ | (name,exp) <- tokenPragmas cf]+ userDefTokenConstrs = unlines $+ [" | T_" ++ name ++ " !"++stringType | name <- tokenNames cf]+ userDefTokenPrint = unlines $+ [" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]++ ident =+ "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"+ --ifC "Ident" "<ident> ::= ^l ^i* { ident p = PT p . eitherResIdent TV }"+++data BTree = N | B String Int BTree BTree++instance Show BTree where+ showsPrec _ N = showString "N"+ showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '+ . showsPrec 1 l . showChar ' '+ . showsPrec 1 r)+ where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f++sorted2tree :: [(String,Int)] -> BTree+sorted2tree [] = N+sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where+ (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs+++-------------------------------------------------------------------+-- Inlined version of @BNFC.Backend.Haskell.RegToAlex@.+-- Syntax has changed...+-------------------------------------------------------------------++-- modified from pretty-printer generated by the BNF converter++-- the top-level printing method+printRegAlex :: Reg -> String+printRegAlex = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend 0+ where rend :: Int -> [String] -> String+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""++ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ " " ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = case c of+ '\n' -> ["\\n"]+ '\t' -> ["\\t"]+ c | isAlphaNum c -> [[c]] + c | isPrint c -> ['\\':[c]]+ c | otherwise -> ['\\':show (ord c)]+ prtList s = map (concat . prt 0) s++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["()"])+ RChar c -> prPrec i 3 (concat [prt 0 c])+ RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) str))+ RDigit -> prPrec i 3 (concat [["$d"]])+ RLetter -> prPrec i 3 (concat [["$l"]])+ RUpper -> prPrec i 3 (concat [["$c"]])+ RLower -> prPrec i 3 (concat [["$s"]])+ RAny -> prPrec i 3 (concat [["$u"]])
+ src/BNFC/Backend/Haskell/CFtoHappy.hs view
@@ -0,0 +1,277 @@+{-+ BNF Converter: Happy Generator+ Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Haskell.CFtoHappy+ (+ cf2HappyS -- cf2HappyS :: CF -> CFCat -> String+ )+ where++import BNFC.CF+--import Lexer+import Data.List (intersperse, sort)+import Data.Char+import BNFC.Options (HappyMode(..))+-- Type declarations++type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++-- default naming++moduleName = "HappyParser"+tokenName = "Token"++-- Happy mode++++cf2HappyS :: String -> String -> String -> String -> HappyMode -> Bool -> CF -> String+---- cf2HappyS :: String -> CF -> String+cf2HappyS = cf2Happy++-- The main function, that given a CF and a CFCat to parse according to,+-- generates a happy module.+cf2Happy name absName lexName errName mode byteStrings cf+ = unlines+ [header name absName lexName errName mode byteStrings,+ declarations mode (allEntryPoints cf),+ tokens (cfTokens cf),+ specialToks cf,+ delimiter,+ specialRules byteStrings cf,+ prRules (rulesForHappy cf),+ finalize byteStrings cf]++-- construct the header.+header :: String -> String -> String -> String -> HappyMode -> Bool -> String+header modName absName lexName errName mode byteStrings = unlines+ ["-- This Happy file was machine-generated by the BNF converter",+ "{",+ "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}",+ case mode of+ Standard -> "module " ++ modName ++ " where"+ GLR -> "-- module name filled in by Happy",+ "import " ++ absName,+ "import " ++ lexName,+ "import " ++ errName,+ if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",+ "}"+ ]++{- ----+cf2Happy :: String -> CF -> String+cf2Happy name cf+ = unlines+ [header name,+ declarations (allEntryPoints cf),+ tokens (cfTokens cf),+ specialToks cf,+ delimiter,+ specialRules cf,+ prRules (rulesForHappy cf),+ finalize cf]++-- construct the header.+header :: String -> String+header name = unlines+ ["-- This Happy file was machine-generated by the BNF converter",+ "{",+ "module Par" ++ name ++ " where",+ "import Abs"++name,+ "import Lex"++name,+ "import ErrM",+ "}"+ ]+-}++-- The declarations of a happy file.+declarations :: HappyMode -> [Cat] -> String+declarations mode ns = unlines+ [generateP ns,+ case mode of+ Standard -> "-- no lexer declaration"+ GLR -> "%lexer { myLexer } { Err _ }",+ "%monad { Err } { thenM } { returnM }",+ "%tokentype { " ++ tokenName ++ " }"]+ where generateP [] = []+ generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns]+ where n' = identCat n++-- The useless delimiter symbol.+delimiter :: String+delimiter = "\n%%\n"++-- Generate the list of tokens and their identifiers.+tokens :: [(String,Int)] -> String+tokens toks = "%token \n" ++ prTokens toks+ where prTokens [] = []+ prTokens ((t,k):tk) = " " ++ (convert t) +++ " { " ++ oneTok t k ++ " }\n" +++ prTokens tk+ oneTok t k = "PT _ (TS _ " ++ show k ++ ")"++-- Happy doesn't allow characters such as åäö to occur in the happy file. This+-- is however not a restriction, just a naming paradigm in the happy source file.+convert :: String -> String+convert "\\" = concat ['\'':"\\\\","\'"]+convert xs = concat ['\'':(escape xs),"\'"]+ where escape [] = []+ escape ('\'':xs) = '\\':'\'':escape xs+ escape (x:xs) = x:escape xs++rulesForHappy :: CF -> Rules+rulesForHappy cf = map mkOne $ ruleGroups cf where+ mkOne (cat,rules) = constructRule cf rules cat++-- For every non-terminal, we construct a set of rules. A rule is a sequence of+-- terminals and non-terminals, and an action to be performed+-- As an optimization, a pair of list rules [C] ::= "" | C k [C]+-- is left-recursivized into [C] ::= "" | [C] C k.+-- This could be generalized to cover other forms of list rules.+constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf r])+ where+ revF b r = if b then ("flip " ++ funRule r) else (underscore $ funRule r)+ revs = reversibleCats cf+ underscore f | isDefinedRule f = f ++ "_"+ | otherwise = f++-- Generates a string containing the semantic action.+-- An action can for example be: Sum $1 $2, that is, construct an AST+-- with the constructor Sum applied to the two metavariables $1 and $2.+generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action+generateAction nt f ms = unwords $ (if isCoercion f then [] else [f]) ++ ms++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal++generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])+generatePatterns cf r = case rhsRule r of+ [] -> ("{- empty -}",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> identCat c+ Right s -> convert s+ metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]+ revIf c m = if (not (isConsFun (funRule r)) && elem c revs)+ then ("(reverse " ++ m ++ ")")+ else m -- no reversal in the left-recursive Cons rule itself+ revs = reversibleCats cf++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.++prRules :: Rules -> String+prRules = unlines . map prOne+ where+ prOne (nt,[]) = [] -- nt has only internal use+ prOne (nt,((p,a):ls)) =+ unwords [nt', "::", "{", show $ normCat nt, "}\n" +++ nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n"+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) =+ unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls++-- Finally, some haskell code.++finalize :: Bool -> CF -> String+finalize byteStrings cf = unlines $+ [+ "{",+ "\nreturnM :: a -> Err a",+ "returnM = return",+ "\nthenM :: Err a -> (a -> Err b) -> Err b",+ "thenM = (>>=)",+ "\nhappyError :: [" ++ tokenName ++ "] -> Err a",+ "happyError ts =",+ " Bad $ \"syntax error at \" ++ tokenPos ts ++ ",+ " case ts of",+ " [] -> []",+ " [Err _] -> \" due to lexer error\"",+ " _ -> \" before \" ++ unwords (map ("++stringUnpack++" . prToken) (take 4 ts))",+ "",+ "myLexer = tokens"+ ] ++ definedRules cf ++ [ "}" ]+ where+ stringUnpack+ | byteStrings = "BS.unpack"+ | otherwise = "id"+++definedRules cf = [ mkDef f xs e | FunDef f xs e <- pragmasOfCF cf ]+ where+ mkDef f xs e = unwords $ (f ++ "_") : xs' ++ ["=", show e']+ where+ xs' = map (++"_") xs+ e' = underscore e+ underscore (App x es)+ | isLower $ head x = App (x ++ "_") $ map underscore es+ | otherwise = App x $ map underscore es+ underscore e = e++-- aarne's modifs 8/1/2002:+-- Markus's modifs 11/02/2002++-- GF literals+specialToks :: CF -> String+specialToks cf = unlines $+ (map aux (literals cf))+ ++ ["L_err { _ }"]+ where aux cat =+ case show cat of+ "Ident" -> "L_ident { PT _ (TV $$) }"+ "String" -> "L_quoted { PT _ (TL $$) }"+ "Integer" -> "L_integ { PT _ (TI $$) }"+ "Double" -> "L_doubl { PT _ (TD $$) }"+ "Char" -> "L_charac { PT _ (TC $$) }"+ own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }"+ where+ posn = if isPositionCat cf cat then "_" else "$$"++specialRules :: Bool -> CF -> String+specialRules byteStrings cf = unlines $+ map aux (literals cf)+ where+ aux cat =+ case show cat of+ "Ident" -> "Ident :: { Ident } : L_ident { Ident $1 }"+ "String" -> "String :: { String } : L_quoted { "++stringUnpack++" $1 }"+ "Integer" -> "Integer :: { Integer } : L_integ { (read ("++stringUnpack++" $1)) :: Integer }"+ "Double" -> "Double :: { Double } : L_doubl { (read ("++stringUnpack++" $1)) :: Double }"+ "Char" -> "Char :: { Char } : L_charac { (read ("++stringUnpack++" $1)) :: Char }"+ own -> own ++ " :: { " ++ own ++ "} : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}"+ -- PCC: take "own" as type name? (manual says newtype)+ where+ posn = if isPositionCat cf cat then "mkPosToken " else ""++ stringUnpack+ | byteStrings = "BS.unpack"+ | otherwise = ""+
+ src/BNFC/Backend/Haskell/CFtoLayout.hs view
@@ -0,0 +1,270 @@+{-+ BNF Converter: Layout handling Generator+ Copyright (C) 2004 Author: Aarne Ranta+ Copyright (C) 2005 Bjorn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Haskell.CFtoLayout where++import Data.List (sort)+import BNFC.CF++layoutOpen = "{"+layoutClose = "}"+layoutSep = ";"++cf2Layout :: Bool -> Bool -> String -> String -> CF -> String+cf2Layout alex1 inDir layName lexName cf =+ let+ (top,lay,stop) = layoutPragmas cf+ in unlines $ [+ "module " ++ layName ++ " where",+ "",+ "import " ++ lexName,+ if alex1 then "import Alex" else "",+ "",+ "import Data.Maybe (isNothing, fromJust)",+ "",+ "-- Generated by the BNF Converter",+ "",+ "-- local parameters",+ "",+ "topLayout = " ++ show top,+ "layoutWords = " ++ show lay,+ "layoutStopWords = " ++ show stop,+ "",+ "-- layout separators",+ "",+ "layoutOpen = " ++ show layoutOpen,+ "layoutClose = " ++ show layoutClose,+ "layoutSep = " ++ show layoutSep,+ "",+ "-- | Replace layout syntax with explicit layout tokens.",+ "resolveLayout :: Bool -- ^ Whether to use top-level layout.",+ " -> [Token] -> [Token]",+ "resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]",+ " where",+ " -- Do top-level layout if the function parameter and the grammar say so.",+ " tl = tp && topLayout",+ "",+ " res :: Maybe Token -- ^ The previous token, if any.",+ " -> [Block] -- ^ A stack of layout blocks.",+ " -> [Token] -> [Token]",+ "",+ " -- The stack should never be empty.",+ " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts",+ "",+ " res _ st (t0:ts)",+ " -- We found an open brace in the input,",+ " -- put an explicit layout block on the stack.",+ " -- This is done even if there was no layout word,",+ " -- to keep opening and closing braces.",+ " | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts",+ "",+ " res _ st (t0:ts)",+ " -- Start a new layout block if the first token is a layout word",+ " | isLayout t0 =",+ " case ts of",+ " -- Explicit layout, just move on. The case above",+ " -- will push an explicit layout block.",+ " t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts",+ " -- at end of file, the start column doesn't matter",+ " _ -> let col = if null ts then column t0 else column (head ts)",+ " -- insert an open brace after the layout word",+ " b:ts' = addToken (nextPos t0) layoutOpen ts",+ " -- save the start column",+ " st' = Implicit col:st ",+ " in moveAlong st' [t0,b] ts'",+ "",+ " -- If we encounter a closing brace, exit the first explicit layout block.",+ " | isLayoutClose t0 = ",+ " let st' = drop 1 (dropWhile isImplicit st)",+ " in if null st' ",+ " then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ",+ " ++ show (line t0) ++ \",\" ++ show (column t0) ",+ " ++ \") without an explicit layout block.\"",+ " else moveAlong st' [t0] ts",+ "",+ " -- We are in an implicit layout block",+ " res pt st@(Implicit n:ns) (t0:ts)",+ "",+ " -- End of implicit block by a layout stop word",+ " | isStop t0 = ",+ " -- Exit the current block and all implicit blocks ",+ " -- more indented than the current token",+ " let (ebs,ns') = span (`moreIndent` column t0) ns",+ " moreIndent (Implicit x) y = x > y",+ " moreIndent Explicit _ = False",+ " -- the number of blocks exited",+ " b = 1 + length ebs",+ " bs = replicate b layoutClose",+ " -- Insert closing braces after the previous token.",+ " (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)",+ " in moveAlong ns' ts1 ts2",+ "",+ " -- End of an implicit layout block",+ " | newLine && column t0 < n = ",+ " -- Insert a closing brace after the previous token.",+ " let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)",+ " -- Repeat, with the current block removed from the stack",+ " in moveAlong ns [b] (t0':ts')",+ "",+ " -- Encounted a new line in an implicit layout block.",+ " | newLine && column t0 == n = ",+ " -- Insert a semicolon after the previous token.",+ " -- unless we are the beginning of the file,",+ " -- or the previous token is a semicolon or open brace.",+ " if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) ",+ " then moveAlong st [t0] ts",+ " else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)",+ " in moveAlong st [b,t0'] ts'",+ " where newLine = case pt of",+ " Nothing -> True",+ " Just t -> line t /= line t0",+ "",+ " -- Nothing to see here, move along.",+ " res _ st (t:ts) = moveAlong st [t] ts",+ "",+ " -- At EOF: skip explicit blocks.",+ " res (Just t) (Explicit:bs) [] | null bs = []",+ " | otherwise = res (Just t) bs []",+ "",+ " -- If we are using top-level layout, insert a semicolon after",+ " -- the last token, if there isn't one already",+ " res (Just t) [Implicit n] []",+ " | isTokenIn [layoutSep] t = []",+ " | otherwise = addToken (nextPos t) layoutSep []",+ "",+ " -- At EOF in an implicit, non-top-level block: close the block",+ " res (Just t) (Implicit n:bs) [] =",+ " let c = addToken (nextPos t) layoutClose []",+ " in moveAlong bs c []",+ "",+ " -- This should only happen if the input is empty.",+ " res Nothing st [] = []",+ "",+ " -- | Move on to the next token.",+ " moveAlong :: [Block] -- ^ The layout stack.",+ " -> [Token] -- ^ Any tokens just processed.",+ " -> [Token] -- ^ the rest of the tokens.",+ " -> [Token]",+ " moveAlong st [] ts = error $ \"Layout error: moveAlong got [] as old tokens\"",+ " moveAlong st ot ts = ot ++ res (Just $ last ot) st ts",+ "",+ "data Block = Implicit Int -- ^ An implicit layout block with its start column.",+ " | Explicit ",+ " deriving Show",+ "",+ "type Position = Posn",+ "",+ "-- | Check if s block is implicit.",+ "isImplicit :: Block -> Bool",+ "isImplicit (Implicit _) = True",+ "isImplicit _ = False",+ "",+ "-- | Insert a number of tokens at the begninning of a list of tokens.",+ "addTokens :: Position -- ^ Position of the first new token.",+ " -> [String] -- ^ Token symbols.",+ " -> [Token] -- ^ The rest of the tokens. These will have their",+ " -- positions updated to make room for the new tokens .",+ " -> [Token] ",+ "addTokens p ss ts = foldr (addToken p) ts ss",+ "",+ "-- | Insert a new symbol token at the begninning of a list of tokens.",+ "addToken :: Position -- ^ Position of the new token.",+ " -> String -- ^ Symbol in the new token.",+ " -> [Token] -- ^ The rest of the tokens. These will have their",+ " -- positions updated to make room for the new token.", " -> [Token]",+ "addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts",+ "",+ "-- | Get the position immediately to the right of the given token.",+ "-- If no token is given, gets the first position in the file.",+ "afterPrev :: Maybe Token -> Position",+ "afterPrev = maybe (Pn 0 1 1) nextPos",+ "",+ "-- | Get the position immediately to the right of the given token.",+ "nextPos :: Token -> Position ",+ "nextPos t = Pn (g + s) l (c + s + 1) ",+ " where Pn g l c = position t",+ " s = tokenLength t",+ "",+ "-- | Add to the global and column positions of a token.",+ "-- The column position is only changed if the token is on",+ "-- the same line as the given position.",+ "incrGlobal :: Position -- ^ If the token is on the same line",+ " -- as this position, update the column position.",+ " -> Int -- ^ Number of characters to add to the position.",+ " -> Token -> Token",+ "incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =",+ " if l /= l0 then PT (Pn (g + i) l c) t",+ " else PT (Pn (g + i) l (c + i)) t",+ "incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p",+ "",+ "-- | Create a symbol token.",+ "sToken :: Position -> String -> Token",+ "sToken p s = PT p (TS s i)",+ " where",+ " i = case s of"] +++ [ " " ++ show s ++ " -> " ++ show i+ | (s, i) <- zip resws [1..]+ ] +++ [" _ -> error $ \"not a reserved word: \" ++ show s",+ "",+ "-- | Get the position of a token.",+ "position :: Token -> Position",+ "position t = case t of",+ " PT p _ -> p",+ " Err p -> p",+ "",+ "-- | Get the line number of a token.",+ "line :: Token -> Int",+ "line t = case position t of Pn _ l _ -> l",+ "",+ "-- | Get the column number of a token.",+ "column :: Token -> Int",+ "column t = case position t of Pn _ _ c -> c",+ "",+ "-- | Check if a token is one of the given symbols.",+ "isTokenIn :: [String] -> Token -> Bool",+ "isTokenIn ts t = case t of",+ " PT _ (TS r _) | elem r ts -> True",+ " _ -> False",+ "",+ "-- | Check if a word is a layout start token.",+ "isLayout :: Token -> Bool",+ "isLayout = isTokenIn layoutWords",+ "",+ "-- | Check if a token is a layout stop token.",+ "isStop :: Token -> Bool",+ "isStop = isTokenIn layoutStopWords",+ "",+ "-- | Check if a token is the layout open token.",+ "isLayoutOpen :: Token -> Bool",+ "isLayoutOpen = isTokenIn [layoutOpen]",+ "",+ "-- | Check if a token is the layout close token.",+ "isLayoutClose :: Token -> Bool",+ "isLayoutClose = isTokenIn [layoutClose]",+ "",+ "-- | Get the number of characters in the token.",+ "tokenLength :: Token -> Int",+ "tokenLength t = length $ prToken t",++ ""+ ]+ where+ resws = sort (reservedWords cf ++ symbols cf)
+ src/BNFC/Backend/Haskell/CFtoPrinter.hs view
@@ -0,0 +1,189 @@+{-+ BNF Converter: Pretty-printer generator+ Copyright (C) 2004 Author: Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Haskell.CFtoPrinter (cf2Printer) where++import BNFC.CF+import BNFC.Utils+import BNFC.Backend.Haskell.CFtoTemplate+import Data.List (intersperse)+import Data.Char(toLower)++-- derive pretty-printer from a BNF grammar. AR 15/2/2002+cf2Printer :: Bool -> String -> String -> CF -> String+cf2Printer byteStrings name absMod cf = unlines [+ prologue byteStrings name absMod,+ integerRule cf,+ doubleRule cf,+ if hasIdent cf then identRule byteStrings cf else "",+ unlines [ownPrintRule byteStrings cf own | (own,_) <- tokenPragmas cf],+ rules cf+ ]+++prologue :: Bool -> String -> String -> String+prologue byteStrings name absMod = unlines [+ "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}",+ "module " ++ name +++ "where\n",+ "-- pretty-printer generated by the BNF converter\n",+ "import " ++ absMod,+ "import Data.Char",+ (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""),+ "",+ "-- the top-level printing method",+ "printTree :: Print a => a -> String",+ "printTree = render . prt 0",+ "",+ "type Doc = [ShowS] -> [ShowS]",+ "",+ "doc :: ShowS -> Doc",+ "doc = (:)",+ "",+ "render :: Doc -> String",+ "render d = rend 0 (map ($ \"\") $ d []) \"\" where",+ " rend i ss = case ss of",+ " \"[\" :ts -> showChar '[' . rend i ts",+ " \"(\" :ts -> showChar '(' . rend i ts",+ " \"{\" :ts -> showChar '{' . new (i+1) . rend (i+1) ts",+ " \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts",+ " \"}\" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts",+ " \";\" :ts -> showChar ';' . new i . rend i ts",+ " t : \",\" :ts -> showString t . space \",\" . rend i ts",+ " t : \")\" :ts -> showString t . showChar ')' . rend i ts",+ " t : \"]\" :ts -> showString t . showChar ']' . rend i ts",+ " t :ts -> space t . rend i ts",+ " _ -> id",+ " new i = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace",+ " space t = showString t . (\\s -> if null s then \"\" else (' ':s))",+ "",+ "parenth :: Doc -> Doc",+ "parenth ss = doc (showChar '(') . ss . doc (showChar ')')",+ "",+ "concatS :: [ShowS] -> ShowS",+ "concatS = foldr (.) id",+ "",+ "concatD :: [Doc] -> Doc",+ "concatD = foldr (.) id",+ "",+ "replicateS :: Int -> ShowS -> ShowS",+ "replicateS n f = concatS (replicate n f)",+ "",+ "-- the printer class does the job",+ "class Print a where",+ " prt :: Int -> a -> Doc",+ " prtList :: [a] -> Doc",+ " prtList = concatD . map (prt 0)",+ "",+ "instance Print a => Print [a] where",+ " prt _ = prtList",+ "",+ "instance Print Char where",+ " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')",+ " prtList s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')",+ "",+ "mkEsc :: Char -> Char -> ShowS",+ "mkEsc q s = case s of",+ " _ | s == q -> showChar '\\\\' . showChar s",+ " '\\\\'-> showString \"\\\\\\\\\"",+ " '\\n' -> showString \"\\\\n\"",+ " '\\t' -> showString \"\\\\t\"",+ " _ -> showChar s",+ "",+ "prPrec :: Int -> Int -> Doc -> Doc",+ "prPrec i j = if j<i then parenth else id",+ ""+ ]++integerRule cf = showsPrintRule cf "Integer"+doubleRule cf = showsPrintRule cf "Double"++showsPrintRule cf t = unlines $ [+ "instance Print " ++ t ++ " where",+ " prt _ x = doc (shows x)",+ ifList cf (Cat t)+ ]++identRule byteStrings cf = ownPrintRule byteStrings cf catIdent++ownPrintRule byteStrings cf own = unlines $ [+ "instance Print " ++ show own ++ " where",+ " prt _ (" ++ show own ++ posn ++ ") = doc (showString ("++stringUnpack++" i))",+ ifList cf own+ ]+ where+ posn = if isPositionCat cf own then " (_,i)" else " i"++ stringUnpack | byteStrings = "BS.unpack"+ | otherwise = ""++-- copy and paste from BNFC.Backend.Haskell.CFtoTemplate++rules :: CF -> String+rules cf = unlines $+ map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf+ where+ toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)+ names [] _ = []+ names (x:xs) n+ | elem x xs = (x ++ show n) : names xs (n+1)+ | otherwise = x : names xs n+ var (ListCat c) = var c ++ "s"+ var (Cat "Ident") = "id"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var xs = map toLower $ show xs+ checkRes s+ | elem s reservedHaskell = s ++ "'"+ | otherwise = s+ reservedHaskell = ["case","class","data","default","deriving","do","else","if",+ "import","in","infix","infixl","infixr","instance","let","module",+ "newtype","of","then","type","where","as","qualified","hiding"]+ ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)++--- case_fun :: Cat -> [(Constructor,Rule)] -> String+case_fun cat xs = unlines [+ "instance Print" +++ show cat +++ "where",+ " prt i" +++ "e = case e of",+ unlines $ map (\ ((c,xx),r) ->+ " " ++ c +++ unwords xx +++ "->" ++++ "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs+ ]++ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where+ nil cat = [" [] -> " ++ mkRhs [] its |+ Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]+ one cat = [" [x] -> " ++ mkRhs ["x"] its |+ Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]+ cons cat = [" x:xs -> " ++ mkRhs ["x","xs"] its |+ Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]+ mkListRule [] = ""+ mkListRule rs = unlines $ (" prtList" +++ "es = case es of"):rs+++mkRhs args its =+ "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])"+ where+ mk args (Left InternalCat : items) = mk args items+ mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items+ mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items+ mk _ _ = []+ prt c = "prt" +++ show (precCat c)+
+ src/BNFC/Backend/Haskell/CFtoTemplate.hs view
@@ -0,0 +1,114 @@+{-+ BNF Converter: Template Generator+ Copyright (C) 2004 Author: Markus Forberg++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++module BNFC.Backend.Haskell.CFtoTemplate (+ cf2Template+ ) where++import BNFC.CF+import Data.Char+import Data.List (delete)++type ModuleName = String+type Constructor = String++cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String+cf2Template skelName absName errName cf = unlines+ [+ "module "++ skelName ++ " where\n",+ "-- Haskell module generated by the BNF converter\n",+ "import " ++ absName,+ "import " ++ errName,+ "type Result = Err String\n",+ "failure :: Show a => a -> Result",+ "failure x = Bad $ \"Undefined case: \" ++ show x\n",+ unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf+ ]+ where toArgs [] = []+ toArgs ((cons,args):xs)+ = (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs+ names _ [] _ = []+ names b (x:xs) n+ | elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1)+ | otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n)+{-+ toArgs ((cons,args):xs)+ = (cons ++ " " ++ names (map (checkRes . var) args) (0 :: Int)) : toArgs xs+ names [] _ = []+ names (x:xs) n+ | elem x xs = (x ++ show n) ++ " " ++ names xs (n+1)+ | otherwise = x ++ " " ++ names xs n+-}+ var (ListCat c) = var c ++ "s"+ var (Cat "Ident") = "id"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var xs = map toLower (show xs)+ checkRes s+ | elem s reservedHaskell = s ++ "'"+ | otherwise = s+ reservedHaskell = ["case","class","data","default","deriving","do","else","if",+ "import","in","infix","infixl","infixr","instance","let","module",+ "newtype","of","then","type","where","as","qualified","hiding"]++{- ----+cf2Template :: ModuleName -> CF -> String+cf2Template name cf = unlines+ [+ "module Skel"++ name ++ " where\n",+ "-- Haskell module generated by the BNF converter\n",+ "import Abs" ++ name,+ "import ErrM",+ "type Result = Err String\n",+ "failure :: Show a => a -> Result",+ "failure x = Bad $ \"Undefined case: \" ++ show x\n",+ unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf+ ]+ where toArgs [] = []+ toArgs ((cons,args):xs)+ = (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs+ names _ [] _ = []+ names b (x:xs) n+ | elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1)+ | otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n)+ var ('[':xs) = var (init xs) ++ "s"+ var "Ident" = "id"+ var "Integer" = "n"+ var "String" = "str"+ var "Char" = "c"+ var "Double" = "d"+ var xs = map toLower xs+ checkRes s+ | elem s reservedHaskell = s ++ "'"+ | otherwise = s+ reservedHaskell = ["case","class","data","default","deriving","do","else","if",+ "import","in","infix","infixl","infixr","instance","let","module",+ "newtype","of","then","type","where","as","qualified","hiding"]+-}++case_fun :: Cat -> [Constructor] -> String+case_fun cat xs =+ unlines $+ ["trans" ++ cat' ++ " :: " ++ cat' ++ " -> Result",+ "trans" ++ cat' ++ " x = case x of",+ unlines $ map (\s -> " " ++ s ++ " -> " ++ "failure x") xs]+ where cat' = show cat
+ src/BNFC/Backend/Haskell/HsOpts.hs view
@@ -0,0 +1,78 @@+module BNFC.Backend.Haskell.HsOpts where++import BNFC.Utils+import BNFC.Options+import System.FilePath (pathSeparator)++type Options = SharedOptions++alex1 opts = alexMode opts == Alex1++absFile, absFileM, alexFile, alexFileM, dviFile,+ composOpFile, composOpFileM,+ gfAbs, gfConc,+ happyFile, happyFileM,+ latexFile, errFile, errFileM,+ templateFile, templateFileM,+ printerFile, printerFileM,+ layoutFile, layoutFileM,+ psFile, tFile, tFileM :: Options -> String+absFile = mkFile withLangAbs "Abs" "hs"+absFileM = mkMod withLangAbs "Abs"+alexFile = mkFile withLang "Lex" "x"+alexFileM = mkMod withLang "Lex"+happyFile = mkFile withLang "Par" "y"+happyFileM = mkMod withLang "Par"+latexFile = mkFile withLang "Doc" "tex"+txtFile = mkFile withLang "Doc" "txt"+templateFile = mkFile withLang "Skel" "hs"+templateFileM = mkMod withLang "Skel"+printerFile = mkFile withLang "Print" "hs"+printerFileM = mkMod withLang "Print"+dviFile = mkFile withLang "Doc" "dvi"+psFile = mkFile withLang "Doc" "ps"+gfAbs = mkFile withLangAbs "" "Abs.gf"+gfConc = mkFile withLang "" "Conc.gf"+tFile = mkFile withLang "Test" "hs"+tFileM = mkMod withLang "Test"+errFile = mkFile noLang "ErrM" "hs"+errFileM = mkMod noLang "ErrM"+shareFile = mkFile noLang "SharedString" "hs"+shareFileM = mkMod noLang "SharedString"+layoutFileM = mkMod withLang "Layout"+layoutFile = mkFile withLang "Layout" "hs"+cnfTablesFile = mkFile withLang "CnfTables" "hs"+cnfTablesFileM= mkMod withLang "CnfTables"+xmlFile = mkFile withLang "XML" "hs"+xmlFileM = mkMod withLang "XML"+composOpFile = mkFile noLang "ComposOp" "hs"+composOpFileM = mkMod noLang "ComposOp"+++noLang :: Options -> String -> String+noLang _ name = name++withLang :: Options -> String -> String+withLang opts name = name ++ lang opts++withLangAbs :: Options -> String -> String+withLangAbs opts name = postp $ name ++ lang opts+ where+ postp nam = nam -- if multi opts then takeWhile (/='_') nam else nam++pkgToDir :: String -> FilePath+pkgToDir s = replace '.' pathSeparator s+++mkMod :: (Options -> String -> String) -> String -> Options -> String+mkMod addLang name opts =+ pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name+ where pref = maybe "" (++".") (inPackage opts)++mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath+mkFile addLang name ext opts =+ pref ++ if inDir opts+ then lang opts ++ [pathSeparator] ++ name ++ ext'+ else addLang opts name ++ if null ext then "" else ext'+ where pref = maybe "" (\p->pkgToDir p++[pathSeparator]) (inPackage opts)+ ext' = if null ext then "" else "." ++ ext
+ src/BNFC/Backend/Haskell/MkErrM.hs view
@@ -0,0 +1,62 @@+{-+ BNF Converter: Haskell error monad+ Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie,+ Aarne Ranta, Björn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+module BNFC.Backend.Haskell.MkErrM where++errM :: String -> b -> String+errM errMod _ = unlines+ [+ "-- BNF Converter: Error Monad",+ "-- Copyright (C) 2004 Author: Aarne Ranta",+ "",+ "-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.",+ "module " ++ errMod ++ " where",+ "",+ "-- the Error monad: like Maybe type with error msgs",+ "",+ "import Control.Monad (MonadPlus(..), liftM)",+ "import Control.Applicative (Applicative(..), Alternative(..))",+ "",+ "data Err a = Ok a | Bad String",+ " deriving (Read, Show, Eq, Ord)",+ "",+ "instance Monad Err where",+ " return = Ok",+ " fail = Bad",+ " Ok a >>= f = f a",+ " Bad s >>= f = Bad s",+ "",+ "instance Applicative Err where",+ " pure = Ok",+ " (Bad s) <*> _ = Bad s",+ " (Ok f) <*> o = liftM f o",+ "",+ "",+ "instance Functor Err where",+ " fmap = liftM",+ "",+ "instance MonadPlus Err where",+ " mzero = Bad \"Err.mzero\"",+ " mplus (Bad _) y = y",+ " mplus x _ = x",+ "",+ "instance Alternative Err where",+ " empty = mzero",+ " (<|>) = mplus"+ ]
@@ -0,0 +1,67 @@+{-+ BNF Converter: Haskell string sharing+ Copyright (C) 2004-2007 Author: Björn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+module BNFC.Backend.Haskell.MkSharedString where++sharedString :: String -> Bool -> b -> String+sharedString shareMod byteString _ = unlines $+ if byteString+ then+ [+ "module " ++ shareMod ++ " (shareString) where",+ "",+ "import Data.Map as M",+ "import Data.IORef",+ "import qualified Data.ByteString.Char8 as BS",+ "import System.IO.Unsafe (unsafePerformIO)",+ "",+ "{-# NOINLINE stringPoolRef #-}",+ "stringPoolRef :: IORef (M.Map BS.ByteString BS.ByteString)",+ "stringPoolRef = unsafePerformIO $ newIORef M.empty",+ "",+ "{-# NOINLINE shareString #-}",+ "shareString :: BS.ByteString -> BS.ByteString",+ "shareString s = unsafePerformIO $ do",+ " stringPool <- readIORef stringPoolRef",+ " case M.lookup s stringPool of",+ " Just s' -> return s'",+ " Nothing -> do let s' = BS.copy s",+ " writeIORef stringPoolRef $! M.insert s' s' stringPool",+ " return s'"+ ]+ else+ [+ "module " ++ shareMod ++ " (shareString) where",+ "",+ "import Data.HashTable as H",+ "import System.IO.Unsafe (unsafePerformIO)",+ "",+ "{-# NOINLINE stringPool #-}",+ "stringPool :: HashTable String String",+ "stringPool = unsafePerformIO $ new (==) hashString",+ "",+ "{-# NOINLINE shareString #-}",+ "shareString :: String -> String",+ "shareString s = unsafePerformIO $ do",+ " mv <- H.lookup stringPool s",+ " case mv of",+ " Just s' -> return s'",+ " Nothing -> do",+ " H.insert stringPool s s",+ " return s"+ ]
+ src/BNFC/Backend/Haskell/RegToAlex.hs view
@@ -0,0 +1,88 @@+{-+ BNF Converter: Regular expression pretty printer+ Copyright (C) 2004 Author: BNF Converter, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Haskell.RegToAlex (printRegAlex) where++-- modified from pretty-printer generated by the BNF converter++import AbsBNF+import Data.Char++-- the top-level printing method+printRegAlex :: Reg -> String+printRegAlex = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend (0::Int) where+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""+ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ " " ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = if isAlphaNum c then [[c]] else ['^':[c]]+ prtList s = map (concat . prt 0) s++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["$"])+ RChar c -> prPrec i 3 (concat [prt 0 c])+ RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) str))+ RDigit -> prPrec i 3 (concat [["^d"]])+ RLetter -> prPrec i 3 (concat [["^l"]])+ RUpper -> prPrec i 3 (concat [["^c"]])+ RLower -> prPrec i 3 (concat [["^s"]])+ RAny -> prPrec i 3 (concat [["^u"]])+++
+ src/BNFC/Backend/Haskell/ToCNF.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-+ Copyright (C) 2012 Authors:+ Jean-Philippe Bernardy.++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-# LANGUAGE OverloadedStrings #-}++module BNFC.Backend.Haskell.ToCNF (generate, genTestFile, genBenchmark) where++{-++Construction of CYK tables. The algorithm follows:++Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient+Yet Presentable Version of the CYK Algorithm", Informatica Didactica++-}+import BNFC.ToCNFCore+import BNFC.CF hiding (App,Exp)+import BNFC.Backend.Haskell.HsOpts+import Control.Monad.RWS+import Control.Applicative hiding (Const)+import qualified Data.Map as M+import Data.List (nub,intercalate,sortBy,sort)+import Data.Maybe (maybeToList)+import Data.Function (on)+import Data.Char (isAlphaNum,ord)+import Data.String+import Data.Pair+import Text.PrettyPrint.HughesPJ hiding (first,(<>))++-- Code generation++incomment x = "{-" <> x <> "-}"++generate opts cf0 = render $ vcat [header opts+ ,genShowFunction cf0+ ,genCatTags cf1+ ,genDesc cf1 descriptions+ ,genNeighborSet neighbors+ ,genCombTable units (onRules (filter (not . isUnitRule)) cf)+ ,genTokTable units cf+ ,incomment $ vcat+ ["Normalised grammar:"+ ,text $ show cf+ ,"Unit relation:"+ ,prettyUnitSet units+ ]+ ]+ where (cf1,cf,units,descriptions,neighbors) = toCNF cf0++class Pretty a where+ pretty :: a -> Doc++instance (Pretty k, Pretty v) => Pretty (Set k v) where+ pretty s = sep [pretty k <> " --> " <> pretty v | (k,x) <- M.assocs s, v <- x]++instance Pretty (Either Cat String) where+ pretty (Left x) = text $ show x+ pretty (Right x) = quotes $ text x++instance Pretty String where+ pretty = text++prettyUnitSet units = vcat [prettyExp f <> " : " <> catTag cat <> " --> " <> text (show cat') | (cat,x) <- M.assocs units, (f,cat') <- x]++header opts+ = vcat ["{-# LANGUAGE MagicHash, FlexibleInstances #-}"+ ,"module " <> text (cnfTablesFileM opts) <> " where"+ ,"import GHC.Prim"+ ,"import GHC.Exts"+ ,"import Control.Applicative hiding (Const)"+ ,"import Algebra.RingUtils"+ ,"import Parsing.Chart ()"+ ,"import " <> text (absFileM opts)+ ,"import " <> text (alexFileM opts)+ ,"import " <> text ( printerFileM opts)+ ,"readInteger :: String -> Integer"+ ,"readInteger = read"+ ,"readDouble :: String -> Double"+ ,"readDouble = read"+ ,"instance RingP [(CATEGORY,Any)] where"+ ," mul p a b = trav [map (app tx ty) l :/: map (app tx ty) r | (x,tx) <- a, (y,ty) <- b, let l:/:r = combine p x y]"+ ," where trav :: [Pair [a]] -> Pair [a]"+ ," trav [] = pure []"+ ," trav (x:xs) = (++) <$> x <*> trav xs"+ ," app tx ty (z,f) = (z, f tx ty)"+ ]++genShowFunction cf = hang "showAst (cat,ast) = case cat of " 6+ (vcat [catTag (Left cat) <> " -> printTree ((unsafeCoerce# ast)::" <> text (show cat) <> ")"+ | cat <- filter isDataCat $ allCats cf] $$+ "_ -> \"Unprintable category\"")+++genCatTags :: CFG Exp -> Doc+genCatTags cf = "data CATEGORY = " <> punctuate' "|" (map catTag (allSyms cf)) $$+ " deriving (Eq,Ord,Show)"++genDesc :: CFG Exp -> CatDescriptions -> Doc+genDesc cf descs = vcat ["describe " <> catTag s <> " = " <> text (show (descOf s)) | s <- allSyms cf]+ where descOf :: Either Cat String -> String+ descOf (Right x) = "token " <> x+ descOf (Left x) = maybe (show x) render $ M.lookup x descs++genCombTable :: UnitRel Cat -> CFG Exp -> Doc+genCombTable units cf =+ "combine :: Bool -> CATEGORY -> CATEGORY -> Pair [(CATEGORY, Any -> Any -> Any)]"+ $$ genCombine units cf+ $$ "combine _ _ _ = pure []"++allSyms :: CFG Exp -> [Either Cat String]+allSyms cf = map Left (allCats cf ++ literals cf) ++ map (Right . fst) (cfTokens cf)+++ppPair (x,y) = parens $ x <> comma <> " " <> y++unsafeCoerce' = app' (Con "unsafeCoerce#")+++prettyPair (x :/: y) = sep [x,":/:",y]+prettyListFun xs = parens $ sep (map (<> "$") xs) <> "[]"+++genCombine :: UnitRel Cat -> CFG Exp -> Doc+genCombine units cf = vcat $ map genEntry $ group' $ map (alt units) (rulesOfCF cf)+ where genEntry :: ((RHSEl,RHSEl),[(Cat,Exp)]) -> Doc+ genEntry ((r1,r2),cs) = "combine p " <> catTag r1 <> " " <> catTag r2 <> " = " <> prettyPair (genList <$> splitOptim (Left . fst) cf cs)+ mkLam body = "\\x y -> " <> body+ genList xs = prettyListFun [p (ppPair (catTag . Left $ x, mkLam . prettyExp . unsafeCoerce' $ y)) | ((x,y),p) <- xs]++alt :: UnitRel Cat -> Rul Exp -> ((RHSEl,RHSEl),[(Cat,Exp)])+alt units (Rule f c [r1,r2]) = ((r1,r2),initial:others)+ where initial = (c, f `appMany` args)+ others = [(c', f' `app'` (f `appMany` args)) | (f',c') <- lookupMulti (Left c) units]+ args = map (unsafeCoerce' . Con) $ ["x"|isCat r1]++["y"|isCat r2]++++genTokTable :: UnitRel Cat -> CFG Exp -> Doc+genTokTable units cf = "tokenToCats :: Bool -> Token -> Pair [(CATEGORY,Any)]" $$+ vcat (map (genSpecEntry cf units) (tokInfo cf)) $$+ vcat (map (genTokEntry cf units) (cfTokens cf)) $$+ "tokenToCats p t = error (\"unknown token: \" ++ show t)"++tokInfo cf = (catChar,"TC",Con "head"):+ (catString,"TL",Id):+ (catInteger,"TI",Con "readInteger"):+ (catDouble,"TD",Con "readDouble"):+ [(catIdent,"TV",Con "Ident")|hasIdent cf] +++ [(t,"T_" <> text (show t),(Con (show t))) | (t,_) <- tokenPragmas cf]++genTokCommon cf xs = prettyPair (gen <$> splitOptim fst cf xs)+ where gen ys = prettyListFun [p (ppPair (catTag x,y)) | ((x,y),p) <- ys]++genSpecEntry cf units (tokName,constrName,fun) = "tokenToCats p (PT (Pn _ l c) (" <> constrName <> " x)) = " <> genTokCommon cf xs+ where xs = map (second (prettyExp . (\f -> unsafeCoerce' (f `app'` tokArgs)))) $+ (Left tokName, fun) : [(Left c,f `after` fun) | (f,c) <- lookupMulti (Left tokName) units]+ tokArgs | isPositionCat cf tokName = Con "((l,c),x)"+ | otherwise = Con "x"++genTokEntry cf units (tok,x) =+ " -- " <> text tok $$+ "tokenToCats p (PT posn (TS _ " <> int x <> ")) = " <> genTokCommon cf xs+ where xs = (Right tok, tokVal) :+ [(Left c,prettyExp (unsafeCoerce' f)) | (f,c) <- lookupMulti (Right tok) units]+ tokVal = "error" <> (text $ show $ "cannot access value of token: " ++ tok)++ppList = brackets . punctuate' ", "++genNeighborSet ns = vcat+ ["neighbors " <> catTag x <> " = " <> ppList (map catTag y)+ | (x,y) <- ns] $$+ "neighbors _ = []"++------------------------+-- Test file generation++genTestFile opts cf = render $ vcat+ ["module Main where"+ ,"import " <> text ( alexFileM opts)+ ,"import " <> text ( cnfTablesFileM opts)+ ,"import Parsing.TestProgram"+ ,"main = mainTest showAst tokenToCats tokens tokenLineCol describe neighbors"]+++genBenchmark opts = render $ vcat+ ["import System.Environment ( getArgs )"+ ,"import "<> text ( alexFileM opts) <> " as Lexer"+ ,"import "<> text ( cnfTablesFileM opts) <> " as Parser"+ ,"import GHC.Exts"+ ,"import Parsing.Chart"+ ,"import Criterion.Main"+ ,"import Algebra.RingUtils"+ ,"import Control.Applicative"+ ,"type T = [(CATEGORY,Any)]"+ ,"pLGrammar :: [Pair T] -> MT2 T"+ ,"pLGrammar = mkTree"+ ,"main = do"+ ," f:_ <- getArgs"+ ," s <- readFile f"+ ," let ts = zipWith tokenToCats (cycle [False,True]) (Lexer.tokens s)"+ ," (ts1,x:ts2) = splitAt (length ts `div` 2) ts"+ ," cs = [mkTree ts1,mkTree' ts2]"+ ," work [c1,c2] = show $ map fst $ root $ mergein False c1 x c2"+ ," defaultMain [bench f $ nf work cs] -- note the hack!!!"+ ]++
+ src/BNFC/Backend/HaskellGADT.hs view
@@ -0,0 +1,269 @@+{-+ BNF Converter: Haskell main file+ Copyright (C) 2004-2005 Author: Markus Forberg, Peter Gammie,+ Aarne Ranta, Björn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.HaskellGADT (makeHaskellGadt) where++++-- import Utils+import BNFC.Options+import BNFC.Backend.Base hiding (Backend)+import BNFC.Backend.Haskell.HsOpts+import BNFC.CF+import BNFC.Backend.Base+import BNFC.Backend.Haskell.CFtoHappy+import BNFC.Backend.Haskell.CFtoAlex+import BNFC.Backend.Haskell.CFtoAlex2+import BNFC.Backend.Haskell.CFtoAlex3+import BNFC.Backend.Haskell(AlexVersion(..))+import BNFC.Backend.HaskellGADT.CFtoAbstractGADT+import BNFC.Backend.HaskellGADT.CFtoTemplateGADT+import BNFC.Backend.HaskellGADT.CFtoPrinterGADT+import BNFC.Backend.Haskell.CFtoLayout+import BNFC.Backend.XML+import BNFC.Backend.Haskell.MkErrM+import BNFC.Backend.Haskell.MkSharedString+import BNFC.Utils+import qualified BNFC.Backend.Common.Makefile as Makefile+import qualified BNFC.Backend.Haskell as Haskell++import Data.Char+import Data.Maybe (fromMaybe,maybe)+import System.Exit (exitFailure)+import System.FilePath (pathSeparator)+import Control.Monad(when)+++makeHaskellGadt :: SharedOptions -> CF -> MkFiles ()+makeHaskellGadt opts cf = do+ let absMod = absFileM opts+ composOpMod = composOpFileM opts+ lexMod = alexFileM opts+ parMod = happyFileM opts+ prMod = printerFileM opts+ layMod = layoutFileM opts+ errMod = errFileM opts+ shareMod = shareFileM opts+ do+ let dir = codeDir opts+ mkfile (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod+ mkfile (composOpFile opts) $ composOp composOpMod+ case alexMode opts of+ Alex1 -> do+ mkfile (alexFile opts) $ cf2alex lexMod errMod cf+ liftIO $ putStrLn " (Use Alex 1.1 to compile.)"+ Alex2 -> do+ mkfile (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf+ liftIO $ putStrLn " (Use Alex 2.0 to compile.)"+ Alex3 -> do+ mkfile (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf+ liftIO $ putStrLn " (Use Alex 3.0 to compile.)"+ mkfile (happyFile opts) $+ cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf+ liftIO $ putStrLn " (Tested with Happy 1.15)"+ mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf+ mkfile (printerFile opts) $ cf2Printer prMod absMod cf+ when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alexMode opts == Alex1) (inDir opts) layMod lexMod cf+ mkfile (tFile opts) $ testfile opts cf+ mkfile (errFile opts) $ errM errMod cf+ when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf+ Makefile.mkMakefile opts $ makefile opts+ case xml opts of+ 2 -> makeXML opts True cf+ 1 -> makeXML opts False cf+ _ -> return ()++codeDir :: Options -> FilePath+codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)+ dir = if inDir opts then lang opts else ""+ sep = if null pref || null dir then "" else [pathSeparator]+ in pref ++ sep ++ dir++makefile :: Options -> String+makefile = Haskell.makefile++testfile :: Options -> CF -> String+testfile opts cf+ = let lay = hasLayout cf+ use_xml = xml opts > 0+ xpr = if use_xml then "XPrint a, " else ""+ use_glr = glr opts == GLR+ if_glr s = if use_glr then s else ""+ firstParser = if use_glr then "the_parser" else parserName+ parserName = 'p' : topType+ topType = show (firstEntry cf)+ in unlines+ ["-- automatically generated by BNF Converter",+ "module Main where\n",+ "",+ "import System.IO ( stdin, hGetContents )",+ "import System.Environment ( getArgs, getProgName )",+ "",+ "import " ++ alexFileM opts,+ "import " ++ happyFileM opts,+ "import " ++ templateFileM opts,+ "import " ++ printerFileM opts,+ "import " ++ absFileM opts,+ if lay then ("import " ++ layoutFileM opts) else "",+ if use_xml then ("import " ++ xmlFileM opts) else "",+ if_glr "import qualified Data.Map(Map, lookup, toList)",+ if_glr "import Data.Maybe(fromJust)",+ "import " ++ errFileM opts,+ "",+ if use_glr+ then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"+ else "type ParseFun a = [Token] -> Err a",+ "",+ "myLLexer = " ++ if lay then "resolveLayout True . myLexer"+ else "myLexer",+ "",+ "type Verbosity = Int",+ "",+ "putStrV :: Verbosity -> String -> IO ()",+ "putStrV v s = if v > 1 then putStrLn s else return ()",+ "",+ "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()",+ "runFile v p f = putStrLn f >> readFile f >>= run v p",+ "",+ "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()",+ if use_glr then run_glr else run_std use_xml,+ "",+ "showTree :: (Show a, Print a) => Int -> a -> IO ()",+ "showTree v tree",+ " = do",+ " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree",+ " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree",+ "",+ "main :: IO ()",+ "main = do args <- getArgs",+ " case args of",+ " [] -> hGetContents stdin >>= run 2 " ++ firstParser,+ " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",+ " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",+ "",+ if_glr $ "the_parser :: ParseFun " ++ topType,+ if_glr $ "the_parser = lift_parser " ++ parserName,+ if_glr $ "",+ if_glr $ lift_parser+ ]++run_std xml+ = unlines+ [ "run v p s = let ts = myLLexer s in case p ts of"+ , " Bad s -> do putStrLn \"\\nParse Failed...\\n\""+ , " putStrV v \"Tokens:\""+ , " putStrV v $ show ts"+ , " putStrLn s"+ , " Ok tree -> do putStrLn \"\\nParse Successful!\""+ , " showTree v tree"+ , if xml then+ " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"+ else ""+ ]++run_glr+ = unlines+ [ "run v p s"+ , " = let ts = map (:[]) $ myLLexer s"+ , " (raw_output, simple_output) = p ts in"+ , " case simple_output of"+ , " GLR_Fail major minor -> do"+ , " putStrLn major"+ , " putStrV v minor"+ , " GLR_Result df trees -> do"+ , " putStrLn \"\\nParse Successful!\""+ , " case trees of"+ , " [] -> error \"No results but parse succeeded?\""+ , " [Ok x] -> showTree v x"+ , " xs@(_:_) -> showSeveralTrees v xs"+ , " where"+ , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()"+ , " showSeveralTrees v trees"+ , " = sequence_ "+ , " [ do putStrV v (replicate 40 '-')"+ , " putStrV v $ \"Parse number: \" ++ show n"+ , " showTree v t"+ , " | (Ok t,n) <- zip trees [1..]"+ , " ]"+ ]+++lift_parser+ = unlines+ [ "type Forest = Data.Map.Map ForestId [Branch] -- omitted in ParX export."+ , "data GLR_Output a"+ , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]"+ , " , semantic_result :: [a]"+ , " }"+ , " | GLR_Fail { main_message :: String"+ , " , extra_info :: String"+ , " }"+ , ""+ , "lift_parser"+ , " :: (TreeDecode a, Show a, Print a)"+ , " => ([[Token]] -> GLRResult) -> ParseFun a"+ , "lift_parser parser ts"+ , " = let result = parser ts in"+ , " (\\o -> (result, o)) $"+ , " case result of"+ , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\""+ , " (\"Tokens: \" ++ show ts)"+ , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\""+ , " (\"Partial forest:\\n\""+ , " ++ unlines (map show $ Data.Map.toList f))"+ , " ParseOK r f -> let find f = fromJust . ((flip Data.Map.lookup) f)"+ , " dec_fn f = decode (find f) r"+ , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)"+ ]++composOp :: String -> String+composOp composOpMod = unlines+ [+ "{-# LANGUAGE Rank2Types, PolyKinds #-}",+ "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,",+ " composOpMPlus,composOpFold) where",+ "",+ "import Control.Monad.Identity",+ "import Data.Monoid",+ "",+ "class Compos t where",+ " compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)",+ " -> (forall a. t a -> m (t a)) -> t c -> m (t c)",+ "",+ "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",+ "composOp f = runIdentity . composOpM (Identity . f)",+ "",+ "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",+ "composOpM = compos return ap",+ "",+ "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",+ "composOpM_ = composOpFold (return ()) (>>)",+ "",+ "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",+ "composOpMonoid = composOpFold mempty mappend",+ "",+ "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",+ "composOpMPlus = composOpFold mzero mplus",+ "",+ "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b",+ "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)",+ "",+ "newtype C b a = C { unC :: b }"+ ]
+ src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs view
@@ -0,0 +1,148 @@+{- + BNF Converter: GADT Abstract syntax Generator + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module BNFC.Backend.HaskellGADT.CFtoAbstractGADT (cf2Abstract) where + +import BNFC.CF +import BNFC.Utils((+++),(++++)) +import Data.List(intersperse,intercalate,nub) + +import BNFC.Backend.HaskellGADT.HaskellGADTCommon + +import Data.Maybe (catMaybes) + +-- to produce a Haskell module +cf2Abstract :: Bool -> String -> CF -> String -> String +cf2Abstract byteStrings name cf composOpMod = unlines $ [ + "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}", + "module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where", + "", + "import " ++ composOpMod, + "", + "import Data.Monoid (mappend)", + (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), + "", + "-- Haskell module generated by the BNF converter", + ""] + ++ prDummyTypes cf + ++ [""] + ++ prTreeType byteStrings cf + ++ [""] + ++ prCompos cf + ++ [""] + ++ prShow cf + ++ [""] + ++ prEq cf + ++ [""] + ++ prOrd cf + where exports = ["Tree(..)"] + ++ getTreeCats cf + ++ ["johnMajorEq"] + ++ ["module " ++ composOpMod] + +getTreeCats :: CF -> [String] +getTreeCats cf = nub $ map show $ filter (not . isList) $ map consCat $ cf2cons cf + +prDummyTypes :: CF -> [String] +prDummyTypes cf = [prDummyData] ++ map prDummyType cats + where + cats = getTreeCats cf + prDummyData = "data Tag =" +++ intercalate " | " (map mkRealType cats) + prDummyType cat = "type" +++ cat +++ "= Tree" +++ mkRealType cat + +mkRealType :: String -> String +mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already + +prTreeType :: Bool -> CF -> [String] +prTreeType byteStrings cf = ["data Tree :: Tag -> * where"] ++ map ((" "++) . prTreeCons) (cf2cons cf) + where + prTreeCons c + | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType (show cat) + | otherwise = fun +++ "::" +++ concat [show c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType (show cat) + where (cat,fun) = (consCat c, consFun c) + stringType + | byteStrings = "BS.ByteString" + | otherwise = "String" + +prCompos :: CF -> [String] +prCompos cf = + ["instance Compos Tree where", + " compos r a f t = case t of"] + ++ map (" "++) (concatMap prComposCons cs + ++ if not (all isRecursive cs) then ["_ -> r t"] else []) + where + cs = cf2cons cf + prComposCons c + | isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c] + | otherwise = [] + isRecursive c = any (isTreeType cf) (map fst (consVars c)) + rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c)) + where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var + | isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var + | otherwise = "`a`" +++ "f" +++ var + +prShow :: CF -> [String] +prShow cf = ["instance Show (Tree c) where", + " showsPrec n t = case t of"] + ++ map (" "++) (map prShowCons cs) + ++ [" where opar n = if n > 0 then showChar '(' else id", + " cpar n = if n > 0 then showChar ')' else id"] + where + cs = cf2cons cf + prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun + | otherwise = fun +++ unwords (map snd vars) +++ "->" + +++ "opar n . showString" +++ show fun + +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars] + +++ ". cpar n" + where (fun, vars) = (consFun c, consVars c) + +prEq :: CF -> [String] +prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq", + "", + "johnMajorEq :: Tree a -> Tree b -> Bool"] + ++ map (prEqCons) (cf2cons cf) + ++ ["johnMajorEq _ _ = False"] + where prEqCons c + | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True" + | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")" + +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" + +++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars') + where (fun, vars) = (consFun c, map snd (consVars c)) + vars' = map (++"_") vars + +prOrd :: CF -> [String] +prOrd cf = ["instance Ord (Tree c) where", + " compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++ + ["index :: Tree c -> Int"] ++ + zipWith (\ c i -> mkIndex c i) cs [0..] ++ + ["compareSame :: Tree c -> Tree c -> Ordering"] ++ + map mkCompareSame cs ++ + ["compareSame x y = error \"BNFC error:\" compareSame"] + where cs = cf2cons cf + mkCompareSame c + | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ" + | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")" + +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" + +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc + where (fun, vars) = (consFun c, map snd (consVars c)) + vars' = map (++"_") vars + cc = zipWith (\x y -> "compare"+++x+++y) vars vars' + mkIndex c i = "index" +++ "(" ++ consFun c + +++ unwords (replicate (length (consVars c)) "_") ++ ")" + +++ "=" +++ show i
+ src/BNFC/Backend/HaskellGADT/CFtoPrinterGADT.hs view
@@ -0,0 +1,167 @@+{-+ BNF Converter: GADT Pretty-printer generator+ Copyright (C) 2004-2005 Author: Aarne Ranta, Björn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.HaskellGADT.CFtoPrinterGADT (cf2Printer) where++import BNFC.CF+import BNFC.Utils+import BNFC.Backend.Haskell.CFtoTemplate+import Data.List (intersperse)+import Data.Char(toLower)++import BNFC.Backend.HaskellGADT.HaskellGADTCommon++-- derive pretty-printer from a BNF grammar. AR 15/2/2002+cf2Printer :: String -> String -> CF -> String+cf2Printer name absMod cf = unlines $ [+ prologue name absMod,+ integerRule cf,+ doubleRule cf]+ ++ prPrt cf+ ++ [""]+ ++ concatMap (prPrtList cf) (filter isList (allCats cf))++prologue :: String -> String -> String+prologue name absMod = unlines [+ "{-# LANGUAGE GADTs, TypeSynonymInstances, FlexibleInstances #-}",+ "module " ++ name +++ "where\n",+ "-- pretty-printer generated by the BNF converter\n",+ "import " ++ absMod,+ "import Data.Char",+ "import Data.List (intersperse)",+ "",+ "-- the top-level printing method",+ "printTree :: Print a => a -> String",+ "printTree = render . prt 0",+ "",+ "type Doc = [ShowS] -> [ShowS]",+ "",+ "doc :: ShowS -> Doc",+ "doc = (:)",+ "",+ "render :: Doc -> String",+ "render d = rend 0 (map ($ \"\") $ d []) \"\" where",+ " rend i ss = case ss of",+ " \"[\" :ts -> showChar '[' . rend i ts",+ " \"(\" :ts -> showChar '(' . rend i ts",+ " \"{\" :ts -> showChar '{' . new (i+1) . rend (i+1) ts",+ " \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts",+ " \"}\" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts",+ " \";\" :ts -> showChar ';' . new i . rend i ts",+ " t : \",\" :ts -> showString t . space \",\" . rend i ts",+ " t : \")\" :ts -> showString t . showChar ')' . rend i ts",+ " t : \"]\" :ts -> showString t . showChar ']' . rend i ts",+ " t :ts -> space t . rend i ts",+ " _ -> id",+ " new i = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace",+ " space t = showString t . (\\s -> if null s then \"\" else (' ':s))",+ "",+ "parenth :: Doc -> Doc",+ "parenth ss = doc (showChar '(') . ss . doc (showChar ')')",+ "",+ "concatS :: [ShowS] -> ShowS",+ "concatS = foldr (.) id",+ "",+ "concatD :: [Doc] -> Doc",+ "concatD = foldr (.) id",+ "",+ "unwordsD :: [Doc] -> Doc",+ "unwordsD = concatD . intersperse (doc (showChar ' '))",+ "",+ "replicateS :: Int -> ShowS -> ShowS",+ "replicateS n f = concatS (replicate n f)",+ "",+ "-- the printer class does the job",+ "class Print a where",+ " prt :: Int -> a -> Doc",+ "",+ "instance Print Char where",+ " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')",+ "",+ "instance Print String where",+ " prt _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')",+ "",+ "mkEsc :: Char -> Char -> ShowS",+ "mkEsc q s = case s of",+ " _ | s == q -> showChar '\\\\' . showChar s",+ " '\\\\'-> showString \"\\\\\\\\\"",+ " '\\n' -> showString \"\\\\n\"",+ " '\\t' -> showString \"\\\\t\"",+ " _ -> showChar s",+ "",+ "prPrec :: Int -> Int -> Doc -> Doc",+ "prPrec i j = if j<i then parenth else id",+ ""+ ]++integerRule cf = showsPrintRule cf "Integer"+doubleRule cf = showsPrintRule cf "Double"++showsPrintRule cf t = unlines $ [+ "instance Print " ++ t ++ " where",+ " prt _ x = doc (shows x)",+ ""]++ownPrintRule cf own = unlines $ [+ "instance Print " ++ show own ++ " where",+ " prt _ (" ++ show own ++ posn ++ ") = doc (showString i)",+ ""] ++ ifList cf own+ where+ posn = if isPositionCat cf own then " (_,i)" else " i"++ifList :: CF -> Cat -> [String]+ifList cf cat = prPrtList cf (ListCat cat) -- FIXME: hackish++prPrt :: CF -> [String]+prPrt cf = ["instance Print (Tree c) where",+ " prt _i e = case e of"+ ] ++ map prPrtCons (cf2cons cf)+ where+ prPrtCons c = " " ++ consFun c +++ unwords (vars c) +++ "->" ++++ "prPrec _i" +++ show (consPrec c) +++ rhs+ -- for token rules, just print the string argument unquoted+ where rhs | isToken c = let [v] = vars c in "(doc (showString " ++ v ++ "))"+ | otherwise = mkRhs (vars c) (consRhs c)+ vars = map snd . consVars+ isToken c = consCat c `elem` specialCats cf++prPrtList :: CF -> Cat -> [String]+prPrtList cf cat = mkListRule (nil ++ one ++ cons)+ where+ nil = [" [] -> " ++ mkRhs [] its |+ Rule f _ its <- rules, isNilFun f]+ one = [" [x] -> " ++ mkRhs ["x"] its |+ Rule f _ its <- rules, isOneFun f]+ cons = [" x:xs -> " ++ mkRhs ["x","xs"] its |+ Rule f _ its <- rules, isConsFun f]+ mkListRule [] = []+ mkListRule rs = ["instance Print" +++ show (normCat cat) +++ "where",+ " prt _" +++ "es = case es of"] ++ rs+ rules = rulesForCat cf cat++mkRhs :: [String] -> [Either Cat String] -> String+mkRhs args its =+ "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])"+ where+ mk args (Left InternalCat : items) = mk args items+ mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items+ mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items+ mk _ _ = []+ prt c = "prt" +++ show (precCat c)+
+ src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs view
@@ -0,0 +1,66 @@+{-+ BNF Converter: GADT Template Generator+ Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++module BNFC.Backend.HaskellGADT.CFtoTemplateGADT (+ cf2Template+ ) where++import BNFC.CF+import BNFC.Utils((+++))+import Data.List (delete,groupBy)++import BNFC.Backend.HaskellGADT.HaskellGADTCommon++type ModuleName = String++cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String+cf2Template skelName absName errName cf = unlines $+ [+ "{-# LANGUAGE GADTs #-}",+ "module "++ skelName ++ " where",+ "",+ "-- Haskell module generated by the BNF converter",+ "",+ "import " ++ absName,+ "import " ++ errName,+ "type Result = Err String\n",+ "failure :: Show a => a -> Result",+ "failure x = Bad $ \"Undefined case: \" ++ show x",+ "",+ "transTree :: Tree c -> Result",+ "transTree t = case t of"]+ ++ map prConsCase (cf2cons cf)+ ++ [""]+ ++ concatMap ((++[""]) . uncurry prCatTrans) (catCons cf)++prConsCase :: Constructor -> String+prConsCase c =+ " " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t"++catCons :: CF -> [(Cat,[Constructor])]+catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf]++catEq :: Constructor -> Constructor -> Bool+catEq c1 c2 = consCat c1 == consCat c2++prCatTrans :: Cat -> [Constructor] -> [String]+prCatTrans cat cs = ["trans" ++ show cat +++ "::" +++ show cat +++ "-> Result",+ "trans" ++ show cat +++ "t = case t of"]+ ++ map prConsCase cs
+ src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs view
@@ -0,0 +1,83 @@+{- + BNF Converter: Haskell GADT back-end common stuff + Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-} + +module BNFC.Backend.HaskellGADT.HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where + +import BNFC.CF + +import Data.Char + +data Constructor = Constructor { + consCat :: Cat, + consFun :: Fun, + consPrec :: Integer, + consVars :: [(Cat,String)], + consRhs :: [Either Cat String] + } + +-- | Get category, function, and rhs categories paired with variable names. +cf2cons :: CF -> [Constructor] +cf2cons cf = [ Constructor { consCat = cat, + consFun = fun, + consPrec = precFun cf fun, + consVars = zip cats (mkVars cats), + consRhs = rhsFun cf fun} + | (cat,rules) <- cf2data cf, (fun,cats) <- rules] + ++ [ Constructor { consCat = cat, + consFun = show cat, + consPrec = 0, + consVars = [(Cat "String","str")], + consRhs = [Left (Cat "String")]} + | cat <- specialCats cf] + where mkVars cats = mkUnique (map catToVar cats) (0 :: Int) + mkUnique [] _ = [] + mkUnique (x:xs) n | elem x xs || n > 0 = (x ++ show n) : mkUnique xs (n+1) + | otherwise = x : mkUnique xs n + +-- | Make a variable name for a category. +catToVar :: Cat -> String +catToVar = checkRes . var + where var (ListCat cat) = var cat ++ "s" + var (Cat "Ident") = "i" + var (Cat "Integer") = "n" + var (Cat "String") = "str" + var (Cat "Char") = "c" + var (Cat "Double") = "d" + var xs = map toLower $show xs + checkRes s | elem s reservedHaskell = s ++ "'" + | otherwise = s + reservedHaskell = ["case","class","data","default","deriving","do","else","if", + "import","in","infix","infixl","infixr","instance","let","module", + "newtype","of","then","type","where","as","qualified","hiding"] + +-- | Get the rule for a function. +ruleFun :: CF -> Fun -> Rule +ruleFun cf f = head $ filter (\r -> funRule r == f) $ rulesOfCF cf + +-- | Get the precedence of a function. +precFun :: CF -> Fun -> Integer +precFun cf f = precRule $ ruleFun cf f + +-- | Get the RHS of a function +rhsFun :: CF -> Fun -> [Either Cat String] +rhsFun cf f = rhsRule $ ruleFun cf f + +isTreeType :: CF -> Cat -> Bool +isTreeType cf c | isList c = isTreeType cf (catOfList c) + | otherwise = c `elem` (allCats cf ++ specialCats cf)
+ src/BNFC/Backend/HaskellProfile.hs view
@@ -0,0 +1,208 @@+{-+ BNF Converter: Haskell main file+ Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.HaskellProfile (makeHaskellProfile) where++-- import Utils+import BNFC.CF+import BNFC.Options+import BNFC.Backend.HaskellProfile.CFtoHappyProfile+import BNFC.Backend.Haskell.CFtoAlex+import BNFC.Backend.Haskell.CFtoAlex2+import BNFC.Backend.Haskell.MkErrM+import BNFC.Utils++import Data.Char+import Data.Maybe (isJust)+import System.Exit(exitFailure)+import Control.Monad(when)++-- naming conventions++nameMod :: String -> Bool -> String -> FilePath+nameMod name inDir lang =+ if inDir+ then lang ++ "." ++ name+ else name ++ lang++nameFile :: String -> String -> Bool -> String -> FilePath+nameFile name ext inDir lang =+ if inDir+ then lang ++ "/" ++ name ++ "." ++ ext+ else name ++ lang ++ "." ++ ext++absFile, absFileM, alexFile, alexFileM, gfAbs, gfConc, happyFile, happyFileM,+ errFile, errFileM, templateFile, templateFileM, printerFile, printerFileM,+ layoutFile, layoutFileM, tFile, tFileM, mFile :: Bool -> String -> FilePath+absFile = nameFile "Abs" "hs"+absFileM = nameMod "Abs"+alexFile = nameFile "Lex" "x"+alexFileM = nameMod "Lex"+happyFile = nameFile "Par" "y"+happyFileM = nameMod "Par"+templateFile = nameFile "Skel" "hs"+templateFileM = nameMod "Skel"+printerFile = nameFile "Print" "hs"+printerFileM = nameMod "Print"+gfAbs = nameFile "" "Abs.gf"+gfConc = nameFile "" "Conc.gf"+tFile = nameFile "Test" "hs"+tFileM = nameMod "Test"+mFile inDir n = if inDir then n ++ "/" ++ "Makefile" else "Makefile"+errFile b n = if b then n ++ "/" ++ "ErrM.hs" else "ErrM.hs"+errFileM b n = if b then n ++ "." ++ "ErrM" else "ErrM"+layoutFileM = nameMod "Layout"+xmlFileM = nameMod "XML"+layoutFile = nameFile "Layout" "hs"++makeHaskellProfile :: SharedOptions -> CFP -> IO ()+makeHaskellProfile opts cfp = do+ let absMod = absFileM (inDir opts) name+ lexMod = alexFileM (inDir opts) name+ parMod = happyFileM (inDir opts) name+ prMod = printerFileM (inDir opts) name+ layMod = layoutFileM (inDir opts) name+ tplMod = templateFileM (inDir opts) name+ errMod = errFileM (inDir opts) name+ let cf = cfp2cf cfp+ do+ when (inDir opts) (prepareDir name)+---- writeFileRep (absFile (inDir opts) name) $ cf2Abstract (absFileM (inDir opts) name) cf+ if (alexMode opts == Alex1) then do+ writeFileRep (alexFile (inDir opts) name) $ cf2alex lexMod errMod cf+ putStrLn " (Use Alex 1.1 to compile.)"+ else do+ writeFileRep (alexFile (inDir opts) name) $ cf2alex2 lexMod errMod "" False False cf+ putStrLn " (Use Alex 2.0 to compile.)"+ writeFileRep (happyFile (inDir opts) name) $+ cf2HappyProfileS parMod absMod lexMod errMod cfp+ putStrLn " (Tested with Happy 1.13)"+---- writeFileRep (templateFile (inDir opts) name) $+---- cf2Template tplMod absMod errMod cf+---- writeFileRep (printerFile (inDir opts) name) $ cf2Printer prMod absMod cf+---- if hasLayout cf then+---- writeFileRep (layoutFile (inDir opts) name) $ cf2Layout alex1 (inDir opts) layMod lexMod cf+---- else return ()+ writeFileRep (tFile (inDir opts) name) $ testfile (inDir opts) name (xml opts>0) cf+ writeFileRep (errFile (inDir opts) name) $ errM errMod cf+ if (isJust $ make opts)+ then (writeFileRep (mFile (inDir opts) name) $ makefile (inDir opts) name)+ else return ()+---- case xml of+---- 2 -> makeXML name True cf+---- 1 -> makeXML name False cf+---- _ -> return ()+ where name = lang opts++makefile :: Bool -> String -> String+makefile inDir name = makeA where+ name' = if inDir then "" else name -- Makefile is inDir+ ghcCommand = "ghc --make "++ tFile inDir name ++ " -o " +++ if inDir then name ++ "/" ++ "Test" else "Test" ++ name+ makeA = unlines+ [+ "all:",+ "\thappy -gca " ++ happyFile False name',+ "\talex " ++ alexFile False name',+ "\t" ++ if inDir then+ "(" ++ "cd ..; " ++ ghcCommand ++ ")"+ else ghcCommand,+ "clean:",+ "\t rm -f *.hi *.o",+ "distclean: " ++ if inDir then "" else "clean",+ if inDir then+ "\t rm -rf ../" ++ name -- erase this directory!+ else+ "\t rm -f " ++ unwords [+ "Doc" ++ name ++ ".*",+ "Lex" ++ name ++ ".*",+ "Par" ++ name ++ ".*",+---- "Layout" ++ name ++ ".*",+---- "Skel" ++ name ++ ".*",+---- "Print" ++ name ++ ".*",+ "Test" ++ name ++ ".*",+---- "Abs" ++ name ++ ".*",+ "Test" ++ name,+ "ErrM.*",+---- name ++ ".dtd",+---- "XML" ++ name ++ ".*",+ "Makefile*"+ ]+ ]+++testfile :: Bool -> String -> Bool -> CF -> String+testfile inDir name xml cf = makeA where++ makeA = let lay = hasLayout cf+ xpr = if xml then "XPrint a, " else ""+ in unlines+ ["-- automatically generated by BNF Converter",+ "module Main where\n",+ "",+ "import Trees",+ "import Profile",+ "import System.IO ( stdin, hGetContents )",+ "import System.Environment ( getArgs, getProgName )",+ "",+ "import " ++ alexFileM inDir name,+ "import " ++ happyFileM inDir name,+---- "import " ++ templateFileM inDir name,+---- "import " ++ printerFileM inDir name,+---- "import " ++ absFileM inDir name,+---- if lay then ("import " ++ layoutFileM inDir name) else "",+---- if xml then ("import " ++ xmlFileM inDir name) else "",+ "import " ++ errFileM inDir name,+ "",+ "type ParseFun = [Token] -> Err CFTree",+ "",+ "myLLexer = " ++ if lay then "resolveLayout True . myLexer"+ else "myLexer",+ "",+ "runFile :: ParseFun -> FilePath -> IO ()",+ "runFile p f = readFile f >>= run p",+ "",+ "run :: ParseFun -> String -> IO ()",+ "run p s = do",+ " let ts = myLLexer s",+ " let etree = p ts",+ " case etree of",+ " Ok tree -> do",+ " case postParse tree of",+ " Bad s -> do",+ " putStrLn \"\\nParse Failed... CFTree:\\n\"",+ " putStrLn $ prCFTree tree",+ " putStrLn s",+ " Ok tree -> do",+ " putStrLn \"\\nParse Successful!\"",+ " putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree",+ " Bad s -> do",+ " putStrLn s",+ " putStrLn \"\\nParse failed... tokenization:\"",+ " print ts",+ "",+ "main :: IO ()",+ "main = do args <- getArgs",+ " case args of",+ " [] -> hGetContents stdin >>= run " ++ firstParser,+ " [f] -> runFile " ++ firstParser ++ " f",+ " _ -> do progName <- getProgName",+ " putStrLn $ progName ++ \": excess arguments.\""+ ]+ where firstParser = 'p' : show (firstEntry cf)
+ src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs view
@@ -0,0 +1,222 @@+{-+ BNF Converter: Happy Generator+ Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.HaskellProfile.CFtoHappyProfile+ (+ cf2HappyProfileS+ )+ where++import BNFC.CF+--import Lexer+import Data.List (intersperse)+import Data.Char++-- Type declarations++type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++-- default naming++moduleName = "HappyParser"+tokenName = "Token"++-- The main function, that given a CF and a CFCat to parse according to,+-- generates a happy module.+cf2HappyProfileS :: String -> String -> String -> String -> CFP -> String+cf2HappyProfileS = cf2Happy++cf2Happy :: String -> String -> String -> String -> CFP -> String+cf2Happy name absName lexName errName cf+ = unlines+ [header name absName lexName errName,+ declarations (allEntryPointsP cf),+ tokens (symbols cf ++ reservedWords cf),+ specialToks cf,+ delimiter,+ specialRules cf,+ prRules (rulesForHappy cf),+ finalize cf]++-- construct the header.+header :: String -> String -> String -> String -> String+header modName absName lexName errName = unlines+ ["-- This Happy file was machine-generated by the BNF converter",+ "{",+ "module " ++ modName ++ " where",+---- "import " ++ absName,+ "import Trees",+ "import " ++ lexName,+ "import " ++ errName,+ "}"+ ]+++-- The declarations of a happy file.+declarations :: [Cat] -> String+declarations ns = unlines+ [generateP ns,+ "%monad { Err } { thenM } { returnM }",+ "%tokentype { " ++ tokenName ++ " }"]+ where generateP [] = []+ generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns]+ where n' = identCat n++-- The useless delimiter symbol.+delimiter :: String+delimiter = "\n%%\n"++-- Generate the list of tokens and their identifiers.+tokens :: [String] -> String+tokens toks = "%token \n" ++ prTokens toks+ where prTokens [] = []+ prTokens (t:tk) = " " ++ (convert t) +++ " { " ++ oneTok t ++ " }\n" +++ prTokens tk+ oneTok t = "PT _ (TS " ++ show t ++ ")"++-- Happy doesn't allow characters such as åäö to occur in the happy file. This+-- is however not a restriction, just a naming paradigm in the happy source file.+convert :: String -> String+convert "\\" = concat ['\'':"\\\\","\'"]+convert xs = concat ['\'':(escape xs),"\'"]+ where escape [] = []+ escape ('\'':xs) = '\\':'\'':escape xs+ escape (x:xs) = x:escape xs++rulesForHappy :: CFP -> Rules+rulesForHappy cf = map mkOne $ ruleGroupsP cf where+ mkOne (cat,rules) = constructRule cf rules cat++-- For every non-terminal, we construct a set of rules. A rule is a sequence of+-- terminals and non-terminals, and an action to be performed+-- As an optimization, a pair of list rules [C] ::= "" | C k [C]+-- is left-recursivized into [C] ::= "" | [C] C k.+-- This could be generalized to cover other forms of list rules.+constructRule :: CFP -> [RuleP] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRuleP r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf r])+ where+ ---- left rec optimization does not work yet+ revF b r = ---- if b then ("flip " ++ funRuleP r) else (funRuleP r)+ funRule r+ revs = reversibleCats cf++-- Generates a string containing the semantic action.+-- An action can for example be: Sum $1 $2, that is, construct an AST+-- with the constructor Sum applied to the two metavariables $1 and $2.+generateAction :: NonTerminal -> FunP -> [MetaVar] -> Action+generateAction nt f@(_,(h,p)) ms = unwords $ (if isCoercion h then args else (fun ++ mss))+ where+ fun = ["mkFunTree",show h,show p]+ mss = ["["] ++ intersperse "," ms ++ ["]"]+ args = intersperse "," ms++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal++generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar])+generatePatterns cf r = case rhsRule r of+ [] -> ("{- empty -}",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> identCat c+ Right s -> convert s+ metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]+ revIf c m = if (not (isConsFun (funRuleP r)) && elem c revs)+ then ("(reverse " ++ m ++ ")")+ else m -- no reversal in the left-recursive Cons rule itself+ revs = reversibleCats cf++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.++prRules :: Rules -> String+prRules = unlines . map prOne+ where+ prOne (nt,[]) = [] -- nt has only internal use+ prOne (nt,((p,a):ls)) =+ unwords [nt', "::", "{", "CFTree", "}\n" +++ nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n"+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) =+ unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls++-- Finally, some haskell code.++finalize :: CFP -> String+finalize cf = unlines+ [+ "{",+ "\nreturnM :: a -> Err a",+ "returnM = return",+ "\nthenM :: Err a -> (a -> Err b) -> Err b",+ "thenM = (>>=)",+ "\nhappyError :: [" ++ tokenName ++ "] -> Err a",+ "happyError ts =",+ " Bad $ \"syntax error at \" ++ tokenPos ts ++ " +++ "if null ts then [] else " +++ "(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))",+ "\nmyLexer = tokens",+ "}"+ ]++-- aarne's modifs 8/1/2002:+-- Markus's modifs 11/02/2002++-- GF literals+specialToks :: CFP -> String+specialToks cf = unlines $+ (map aux (literals cf))+ ++ ["L_err { _ }"]+ where aux cat =+ case cat of+ Cat "Ident" -> "L_ident { PT _ (TV $$) }"+ Cat "String" -> "L_quoted { PT _ (TL $$) }"+ Cat "Integer" -> "L_integ { PT _ (TI $$) }"+ Cat "Double" -> "L_doubl { PT _ (TD $$) }"+ Cat "Char" -> "L_charac { PT _ (TC $$) }"+ own -> "L_" ++ show own ++ " { PT _ (T_" ++ show own ++ " " ++ posn ++ ") }"+ where+ posn = if isPositionCat cf cat then "_" else "$$"++specialRules :: CFP -> String+specialRules cf = unlines $+ map aux (literals cf)+ where+ aux cat =+ case cat of+ Cat "Ident" -> "Ident : L_ident { mkAtTree (AV (Ident $1)) }"+ Cat "String" -> "String : L_quoted { mkAtTree (AS $1) }"+ Cat "Integer" -> "Integer : L_integ { mkAtTree (AI ((read $1) :: Integer)) }"+ Cat "Double" -> "Double : L_doubl { (read $1) :: Double }" ----+ Cat "Char" -> "Char : L_charac { (read $1) :: Char }" ----+ own -> show own ++ " : L_" ++ show own ++ " { " ++ show own ++ " ("++ posn ++ "$1)}"+ where+ posn = if isPositionCat cf cat then "mkPosToken " else ""
+ src/BNFC/Backend/Java.hs view
@@ -0,0 +1,251 @@+{-+ BNF Converter: Java Top File+ Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie,+ Michael Pellauer, Bjorn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-------------------------------------------------------------------+-- |+-- Module : JavaTop+-- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg, bringert} at cs dot chalmers dot se+-- License : GPL (see COPYING for details)+--+-- Maintainer : {markus, aarne} at cs dot chalmers dot se+-- Stability : alpha+-- Portability : Haskell98+--+-- Top-level for the Java back end.+--+-- > $Id: JavaTop15.hs,v 1.12 2007/01/08 18:20:23 aarne Exp $+-------------------------------------------------------------------++module BNFC.Backend.Java ( makeJava ) where++-------------------------------------------------------------------+-- Dependencies.+-------------------------------------------------------------------+import System.Directory ( createDirectory )+import System.IO.Error ( isAlreadyExistsError )+import System.Exit ( exitFailure )+import System.FilePath (pathSeparator)+import BNFC.Utils+import BNFC.CF+import BNFC.Options as Options+import BNFC.Backend.Base+import BNFC.Backend.Java.CFtoCup15 ( cf2Cup )+import BNFC.Backend.Java.CFtoJLex15+import BNFC.Backend.Java.CFtoJavaAbs15 ( cf2JavaAbs )+import BNFC.Backend.Java.CFtoJavaPrinter15+import BNFC.Backend.Java.CFtoVisitSkel15+import BNFC.Backend.Java.CFtoComposVisitor+import BNFC.Backend.Java.CFtoAbstractVisitor+import BNFC.Backend.Java.CFtoFoldVisitor+import BNFC.Backend.Java.CFtoAllVisitor+import Data.Char+import Data.List(intersperse)+import qualified BNFC.Backend.Common.Makefile as Makefile+-------------------------------------------------------------------+-- | Build the Java output.+-- FIXME: get everything to put the files in the right places.+-- Adapt Makefile to do the business.+-------------------------------------------------------------------+makeJava :: SharedOptions -> CF -> MkFiles ()+makeJava options cf =+ do -- Create the package directories if necessary.+ let packageBase = case inPackage of+ Nothing -> name+ Just p -> p ++ "." ++ name+ packageAbsyn = packageBase ++ "." ++ "Absyn"+ dirBase = pkgToDir packageBase+ dirAbsyn = pkgToDir packageAbsyn+ let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf+ absynBaseNames = map fst absynFiles+ absynFileNames = map (dirAbsyn ++) absynBaseNames+ absynFuns = [ f | (_,ps) <- cf2data cf, (f,_) <- ps ]+ let writeAbsyn (filename, contents) =+ mkfile (dirAbsyn ++ filename ++ ".java") contents+ mapM writeAbsyn absynFiles+ mkfile (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf+ mkfile (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf+ mkfile (dirBase ++ "ComposVisitor.java") $ cf2ComposVisitor packageBase packageAbsyn cf+ mkfile (dirBase ++ "AbstractVisitor.java") $ cf2AbstractVisitor packageBase packageAbsyn cf+ mkfile (dirBase ++ "FoldVisitor.java") $ cf2FoldVisitor packageBase packageAbsyn cf+ mkfile (dirBase ++ "AllVisitor.java") $ cf2AllVisitor packageBase packageAbsyn cf+ mkfile (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf+--- mkfile ("Test" ++ name) $ "java " ++ dirBase ++ "Test $(1)"+ let (lex, env) = cf2jlex packageBase packageAbsyn cf+ mkfile (dirBase ++ "Yylex") lex+ liftIO $ putStrLn " (Tested with JLex 1.2.6.)"+ mkfile (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env+ -- FIXME: put in a doc directory?+ liftIO $ putStrLn $ " (Parser created for category " ++ show (firstEntry cf) ++ ")"+ liftIO $ putStrLn " (Tested with CUP 0.10k)"+ Makefile.mkMakefile options $ makefile name dirBase dirAbsyn absynFileNames+ where+ remDups [] = []+ remDups ((a,b):as) = case lookup a as of+ Just {} -> remDups as+ Nothing -> (a, b) : (remDups as)++ pkgToDir :: String -> FilePath+ pkgToDir s = replace '.' pathSeparator s ++ [pathSeparator]+ make = Options.make options+ inPackage = Options.inPackage options+ name = Options.lang options++-- FIXME get filenames right.+-- FIXME It's almost certainly better to just feed all the Java source+-- files to javac in one go.+-- Replace with an ANT script?+makefile :: String -> FilePath -> FilePath -> [String] -> String+makefile name dirBase dirAbsyn absynFileNames =+ (++) (unlines [ "JAVAC = javac",+ "JAVAC_FLAGS = -sourcepath .", "",+ "JAVA = java",+ "JAVA_FLAGS =", "",+ "CUP = java_cup.Main",+ "CUPFLAGS = -nopositions -expect 100", "",+ "JLEX = JLex.Main", "" ])+ $ Makefile.mkRule "all" [ "test" ]+ []+ $ Makefile.mkRule "test" ("absyn":(map (dirBase ++) [ "Yylex.class",+ "PrettyPrinter.class",+ "Test.class",+ "ComposVisitor.class",+ "AbstractVisitor.class",+ "FoldVisitor.class",+ "AllVisitor.class",+ "parser.class",+ "sym.class",+ "Test.class"]))+ []+ $ Makefile.mkRule ".PHONY" ["absyn"]+ []+ $ Makefile.mkRule "%.class" [ "%.java" ]+ [ "${JAVAC} ${JAVAC_FLAGS} $^" ]+ $ Makefile.mkRule "absyn" [absynJavaSrc]+ [ "${JAVAC} ${JAVAC_FLAGS} $^" ]+ $ Makefile.mkRule (dirBase ++ "Yylex.java") [ dirBase ++ "Yylex" ]+ [ "${JAVA} ${JAVA_FLAGS} ${JLEX} " ++ dirBase ++ "Yylex" ]+ $ Makefile.mkRule (dirBase ++ "sym.java " ++ dirBase ++ "parser.java")+ [ dirBase ++ name ++ ".cup" ]+ [ "${JAVA} ${JAVA_FLAGS} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup"+ , "mv sym.java parser.java " ++ dirBase ]+ $ Makefile.mkRule (dirBase ++ "Yylex.class") [ dirBase ++ "Yylex.java",+ dirBase ++ "sym.java" ]+ []+ $ Makefile.mkRule (dirBase ++ "sym.class") [ dirBase ++ "sym.java" ]+ []+ $ Makefile.mkRule (dirBase ++ "parser.class") [ dirBase ++ "parser.java"+ , dirBase ++ "sym.java" ]+ []+ $ Makefile.mkRule (dirBase ++ "PrettyPrinter.class")+ [ dirBase ++ "PrettyPrinter.java" ]+ []+-- FIXME+ $ Makefile.mkRule "clean" []+ [ "rm -f " ++ dirAbsyn ++ "*.class" ++ " " ++ dirBase ++ "*.class"+ , "rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class" ]+ $ Makefile.mkRule "distclean" [ "vclean" ]+ []+ $ Makefile.mkRule "vclean" []+ [ " rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass+ , " rm -f " ++ dirAbsyn ++ "*.class"+-- , "rm -f " ++ "Test" ++ name+ , " rmdir " ++ dirAbsyn+ , " rm -f " ++ unwords (map (dirBase ++) [+ "Yylex",+ name ++ ".cup",+ "Yylex.java",+ "VisitSkel.java",+ "ComposVisitor.java",+ "AbstractVisitor.java",+ "FoldVisitor.java",+ "AllVisitor.java",+ "PrettyPrinter.java",+ "Skeleton.java",+ "Test.java",+ "sym.java",+ "parser.java",+ "*.class"])+ , "rm -f Makefile"+ , "rmdir -p " ++ dirBase ]+ ""+ where absynJavaSrc = unwords (map (++ ".java") absynFileNames)+ absynJavaClass = unwords (map (++ ".class") absynFileNames)++javaTest :: String -> String -> CF -> String+javaTest packageBase packageAbsyn cf =+ unlines+ [+ "package" +++ packageBase ++ ";",+ "import java_cup.runtime.*;",+ "import" +++ packageBase ++ ".*;",+ "import" +++ packageAbsyn ++ ".*;",+ "import java.io.*;",+ "",+ "public class Test",+ "{",+ " public static void main(String args[]) throws Exception",+ " {",+ " Yylex l = null;",+ " parser p;",+ " try",+ " {",+ " if (args.length == 0) l = new Yylex(System.in);",+ " else l = new Yylex(new FileReader(args[0]));",+ " }",+ " catch(FileNotFoundException e)",+ " {",+ " System.err.println(\"Error: File not found: \" + args[0]);",+ " System.exit(1);",+ " }",+ " p = new parser(l);",+ " /* The default parser is the first-defined entry point. */",+ " /* You may want to change this. Other options are: */",+ " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */",+ " try",+ " {",+ " " ++ packageAbsyn ++ "." ++ show def +++ "parse_tree = p.p"+ ++ show def ++ "();",+ " System.out.println();",+ " System.out.println(\"Parse Succesful!\");",+ " System.out.println();",+ " System.out.println(\"[Abstract Syntax]\");",+ " System.out.println();",+ " System.out.println(PrettyPrinter.show(parse_tree));",+ " System.out.println();",+ " System.out.println(\"[Linearized Tree]\");",+ " System.out.println();",+ " System.out.println(PrettyPrinter.print(parse_tree));",+ " }",+ " catch(Throwable e)",+ " {",+ " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");",+ " System.err.println(\" \" + e.getMessage());",+ " System.exit(1);",+ " }",+ " }",+ "}"+ ]+ where eps = allEntryPoints cf+ def = head eps+ showOpts [] = []++ showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)]+ showOpts (x:xs) = if normCat x /= x then (showOpts xs)+ else ('p' : (identCat x)) : (showOpts xs)
+ src/BNFC/Backend/Java/CFtoAbstractVisitor.hs view
@@ -0,0 +1,60 @@+{-+ BNF Converter: Java 1.5 Abstract Vistor generator+ Copyright (C) 2006 Bjorn Bringert+ Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Java.CFtoAbstractVisitor (cf2AbstractVisitor) where++import BNFC.CF+import BNFC.Backend.Java.CFtoJavaAbs15 (typename)+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper, isDigit)++cf2AbstractVisitor :: String -> String -> CF -> String+cf2AbstractVisitor packageBase packageAbsyn cf =+ unlines [+ "package" +++ packageBase ++ ";",+ "import" +++ packageAbsyn ++ ".*;",+ "/** BNFC-Generated Abstract Visitor */",+ "public class AbstractVisitor<R,A> implements AllVisitor<R,A> {",+ concatMap (prData packageAbsyn user) groups,+ "}"]+ where+ user = fst (unzip (tokenPragmas cf))+ groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]++--Traverses a category based on its type.+prData :: String -> [UserDef] -> (Cat, [Rule]) -> String+prData packageAbsyn user (cat, rules) =+ unlines $ ["/* " ++ identCat cat ++ " */"]+ ++ map (prRule packageAbsyn user cat) rules+ ++ [" public R visitDefault(" ++ q ++ " p, A arg) {",+ " throw new IllegalArgumentException(this.getClass().getName() + \": \" + p);",+ " }"]+ where q = packageAbsyn ++ "." ++ identCat cat++--traverses a standard rule.+prRule :: String -> [UserDef] -> Cat -> Rule -> String+prRule packageAbsyn user cat (Rule fun _ cats)+ | not (isCoercion fun || isDefinedRule fun) =+ " public R visit(" ++ cls ++ " p, A arg) { return visitDefault(p, arg); }"+ where cls = packageAbsyn ++ "." ++ fun+prRule _ _ _ _ = ""+
+ src/BNFC/Backend/Java/CFtoAllVisitor.hs view
@@ -0,0 +1,51 @@+{-+ BNF Converter: Java 1.5 All Visitor generator+ Copyright (C) 2006 Bjorn Bringert+ Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Java.CFtoAllVisitor (cf2AllVisitor) where++import BNFC.CF+import BNFC.Backend.Java.CFtoJavaAbs15 (typename)+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper, isDigit)++cf2AllVisitor :: String -> String -> CF -> String+cf2AllVisitor packageBase packageAbsyn cf =+ unlines [+ "package" +++ packageBase ++ ";",+ "",+ "import" +++ packageAbsyn ++ ".*;",+ "",+ "/** BNFC-Generated All Visitor */",+ "public interface AllVisitor<R,A> extends",+ concat $ intersperse ",\n" $ map (" "++) is,+ "{}"]+ where+ groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]+ is = map (prInterface packageAbsyn) groups+ header = unlines [++ ]++prInterface :: String -> (Cat, [Rule]) -> String+prInterface packageAbsyn (cat, rules) =+ q ++ ".Visitor<R,A>"+ where q = packageAbsyn ++ "." ++ identCat cat
+ src/BNFC/Backend/Java/CFtoComposVisitor.hs view
@@ -0,0 +1,114 @@+{-+ BNF Converter: Java 1.5 Compositional Vistor generator+ Copyright (C) 2006 Bjorn Bringert+ Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Java.CFtoComposVisitor (cf2ComposVisitor) where++import BNFC.CF+import BNFC.Backend.Java.CFtoJavaAbs15 (typename)+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper, isDigit)++cf2ComposVisitor :: String -> String -> CF -> String+cf2ComposVisitor packageBase packageAbsyn cf =+ concat [+ header,+ concatMap (prData packageAbsyn user) groups,+ "}"]+ where+ user = fst (unzip (tokenPragmas cf))+ groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]+ is = map (prInterface packageAbsyn) groups+ header = unlines [+ "package" +++ packageBase ++ ";",+ "import" +++ packageAbsyn ++ ".*;",+ "/** BNFC-Generated Composition Visitor",+ "*/",+ "",+ "public class ComposVisitor<A> implements",+ concat $ intersperse ",\n" $ map (" "++) is,+ "{"+ ]+++prInterface :: String -> (Cat, [Rule]) -> String+prInterface packageAbsyn (cat, rules) =+ q ++ ".Visitor<" ++ q ++ ",A>"+ where q = packageAbsyn ++ "." ++ identCat cat++commaList :: [String] -> String+commaList = concat . intersperse ", "++--Traverses a category based on its type.+prData :: String -> [UserDef] -> (Cat, [Rule]) -> String+prData packageAbsyn user (cat, rules) =+ unlines [+ "/* " ++ identCat cat ++ " */",+ concatMap (prRule packageAbsyn user cat) rules+ ]+--traverses a standard rule.+prRule :: String -> [UserDef] -> Cat -> Rule -> String+prRule packageAbsyn user cat (Rule fun _ cats)+ | not (isCoercion fun || isDefinedRule fun) = unlines+ [+ " public " ++ identCat cat ++ " visit(" ++ cls ++ " p, A arg)",+ " {",+ unlines (map (" "++) visitVars),+ " return new " ++ cls ++ "(" ++ commaList children ++ ");",+ " }"+ ]+ where+ cats' = if allTerms cats+ then []+ else [ (c,v) |+ (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= InternalCat ]+ cls = packageAbsyn ++ "." ++ fun+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+ children = map snd cats'+ visitVars = concatMap (uncurry (prCat user)) cats'+prRule _ _ _ _ = ""++--Traverses a class's instance variables.+prCat :: [UserDef]+ -> Cat -- ^ Variable category+ -> String -- ^ Variable name+ -> [String] -- ^ Code for visiting the variable+prCat user cat nt+ | isBasicType user varType || (isList cat && isBasicType user et) = [decl var]+ | isList cat = listAccept+ | otherwise = [decl (var ++ ".accept(this, arg)")]+ where+ var = "p." ++ nt+ varType = typename (identCat (normCat cat)) user+ accept = var ++ ".accept(this, arg);"+ et = typename (show$normCatOfList cat) user+ decl v = varType +++ nt +++ "=" +++ v ++ ";"+ listAccept = [decl ("new"+++varType++"()"),+ "for (" ++ et ++ " x : " ++ var ++ ") {",+ " " ++ nt ++ ".add(x.accept(this,arg));",+ "}"]++--Just checks if something is a basic or user-defined type.+isBasicType :: [UserDef] -> String -> Bool+isBasicType user v = v `elem` (map show user ++ ["Integer","Character","String","Double"])+
+ src/BNFC/Backend/Java/CFtoCup15.hs view
@@ -0,0 +1,273 @@+{-+ BNF Converter: Java 1.5 Cup Generator+ Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer,+ Bjorn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the CUP input file. It+ follows the same basic structure of CFtoHappy.++ Author : Michael Pellauer (pellauer@cs.chalmers.se),+ Bjorn Bringert (bringert@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 26 April, 2003++ Modified : 5 Aug, 2004+++ **************************************************************+-}+module BNFC.Backend.Java.CFtoCup15 ( cf2Cup ) where++import BNFC.CF+import Data.List (intersperse, isPrefixOf)+import BNFC.Backend.Common.NamedVariables+import BNFC.Utils ( (+++) )+import BNFC.TypeChecker -- We need to (re-)typecheck to figure out list instances in+ -- defined rules.+import ErrM++import Data.Char++-- Type declarations+type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++--The environment comes from the CFtoJLex+cf2Cup :: String -> String -> CF -> SymEnv -> String+cf2Cup packageBase packageAbsyn cf env = unlines+ [+ header,+ declarations packageAbsyn (allCats cf),+ tokens env,+ specialToks cf,+ specialRules cf,+ prEntryPoint cf,+ prRules (rulesForCup packageAbsyn cf env)+ ]+ where+ header :: String+ header = unlines+ ["// -*- Java -*- This Cup file was machine-generated by BNFC",+ "package" +++ packageBase ++ ";",+ "",+ "parser code {:",+ parseMethod packageAbsyn (firstEntry cf),+ "public <B,A extends java.util.LinkedList<? super B>> A cons_(B x, A xs) { xs.addFirst(x); return xs; }",+ definedRules packageAbsyn cf,+ -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf),+ "public void syntax_error(java_cup.runtime.Symbol cur_token)",+ "{",+ "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);",+ "}",+ "",+ "public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception",+ "{",+ "\tthrow new Exception(\"Unrecoverable Syntax Error\");",+ "}",+ "",+ ":}"+ ]++definedRules :: String -> CF -> String+definedRules packageAbsyn cf =+ unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]+ where+ ctx = buildContext cf++ list = LC (\t -> "List" ++ unBase t) (const "cons")+ where+ unBase (ListT t) = unBase t+ unBase (BaseT x) = show$normCat$strToCat x++ rule f xs e =+ case checkDefinition' list ctx f xs e of+ Bad err -> error $ "Panic! This should have been caught already:\n" ++ err+ Ok (args,(e',t)) -> unlines+ [ "public " ++ javaType t ++ " " ++ f ++ "_ (" +++ concat (intersperse ", " $ map javaArg args) ++ ") {"+ , " return " ++ javaExp e' ++ ";"+ , "}"+ ]+ where++ javaType :: Base -> String+ javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ (show$normCat$strToCat x)+ javaType (ListT t) = javaType t+ javaType (BaseT x)+ | isToken x ctx = "String"+ | otherwise = packageAbsyn ++ "." ++ (show$normCat$strToCat x)++ javaArg :: (String, Base) -> String+ javaArg (x,t) = javaType t ++ " " ++ x ++ "_"++ javaExp :: Exp -> String+ javaExp (App "null" []) = "null"+ javaExp (App x [])+ | elem x xs = x ++ "_" -- argument+ javaExp (App t [e])+ | isToken t ctx = call ("new String") [e]+ javaExp (App x es)+ | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es+ | otherwise = call (x ++ "_") es+ javaExp (LitInt n) = "new Integer(" ++ show n ++ ")"+ javaExp (LitDouble x) = "new Double(" ++ show x ++ ")"+ javaExp (LitChar c) = "new Character(" ++ show c ++ ")"+ javaExp (LitString s) = "new String(" ++ show s ++ ")"++ call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")"+++-- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.+prEntryPoint :: CF -> String+prEntryPoint cf = unlines ["", "start with " ++ show (firstEntry cf) ++ ";", ""]+-- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""]+-- eps -> error $ "FIXME multiple entry points." ++ show eps++--This generates a parser method for each entry point.+parseMethod :: String -> Cat -> String+parseMethod packageAbsyn cat =+ if normCat cat /= cat+ then ""+ else unlines+ [+ " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()"+ ++ " throws Exception",+ " {",+ "\tjava_cup.runtime.Symbol res = parse();",+ "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;",+ " }"+ ]+ where cat' = identCat (normCat cat)++--non-terminal types+declarations :: String -> [Cat] -> String+declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns)+ where+ typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "."+ ++ identCat (normCat nt) +++ identCat nt ++ ";"++--terminal types+tokens :: SymEnv -> String+tokens ts = unlines (map declTok ts)+ where+ declTok (s,r) = "terminal" +++ r ++ "; // " ++ s++specialToks :: CF -> String+specialToks cf = unlines [+ ifC catString "terminal String _STRING_;",+ ifC catChar "terminal Character _CHAR_;",+ ifC catInteger "terminal Integer _INTEGER_;",+ ifC catDouble "terminal Double _DOUBLE_;",+ ifC catIdent "terminal String _IDENT_;"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""++-- This handles user defined tokens+-- FIXME+specialRules:: CF -> String+specialRules cf =+ unlines ["terminal String " ++ name ++ ";" | name <- tokenNames cf]++--The following functions are a (relatively) straightforward translation+--of the ones in CFtoHappy.hs+rulesForCup :: String -> CF -> SymEnv -> Rules+rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where+ mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat++-- For every non-terminal, we construct a set of rules. A rule is a sequence of+-- terminals and non-terminals, and an action to be performed.+constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule packageAbsyn cf env rules nt =+ (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b)+ | r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True, revSepListRule r0)+ else (False, r0)+ (p,m) = generatePatterns cf env r])+ where+ revM False m = m+ revM True [h,t] = [t,h]+ revs = reversibleCats cf++-- Generates a string containing the semantic action.+generateAction :: String -> NonTerminal -> Fun -> [MetaVar]+ -> Bool -- ^ Whether the list should be reversed or not.+ -- Only used if this is a list rule.+ -> Action+generateAction packageAbsyn nt f ms rev+ | isNilFun f = "RESULT = new " ++ c ++ "();"+ | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");"+ | isConsFun f = "RESULT = " ++ p_2 ++ "; "+ ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");"+ | isCoercion f = "RESULT = " ++ p_1 ++ ";"+ | isDefinedRule f = "RESULT = parser." ++ f ++ "_"+ ++ "(" ++ concat (intersperse "," ms) ++ ");"+ | otherwise = "RESULT = new " ++ c+ ++ "(" ++ concat (intersperse "," ms) ++ ");"+ where+ c = packageAbsyn ++ "." +++ if isNilFun f || isOneFun f || isConsFun f+ then identCat (normCat nt) else f+ p_1 = ms!!0+ p_2 = ms!!1+ add = if rev then "addLast" else "addFirst"++-- Generate patterns and a set of metavariables indicating+-- where in the pattern the non-terminal+generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns cf env r = case rhsRule r of+ [] -> (" /* empty */ ",[])+ its -> (mkIt env 1 its, metas its)+ where+ mkIt _env _n [] = []+ mkIt env n (i:is) = case i of+ Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is)+ where+ c' = case c of+ Cat "Ident" -> "_IDENT_"+ Cat "Integer" -> "_INTEGER_"+ Cat "Char" -> "_CHAR_"+ Cat "Double" -> "_DOUBLE_"+ Cat "String" -> "_STRING_"+ _ -> identCat c+ Right s -> case (lookup s env) of+ (Just x) -> x +++ (mkIt env (n+1) is)+ (Nothing) -> (mkIt env n is)+ metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its]++-- We have now constructed the patterns and actions,+-- so the only thing left is to merge them into one string.+prRules :: Rules -> String+prRules [] = []+prRules ((nt, []):rs) = prRules rs --internal rule+prRules ((nt,((p,a):ls)):rs) =+ (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs+ where+ nt' = identCat nt+ pr [] = []+ pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls+
+ src/BNFC/Backend/Java/CFtoFoldVisitor.hs view
@@ -0,0 +1,101 @@+{-+ BNF Converter: Java 1.5 Fold Vistor generator+ Copyright (C) 2006 Bjorn Bringert+ Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Java.CFtoFoldVisitor (cf2FoldVisitor) where++import BNFC.CF+import BNFC.Backend.Java.CFtoJavaAbs15 (typename)+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper, isDigit)++cf2FoldVisitor :: String -> String -> CF -> String+cf2FoldVisitor packageBase packageAbsyn cf =+ unlines+ ["package" +++ packageBase ++ ";",+ "",+ "import" +++ packageAbsyn ++ ".*;",+ "import java.util.Collections;",+ "import java.util.List;",+ "import java.util.ArrayList;",+ "",+ "/** BNFC-Generated Fold Visitor */",+ "public abstract class FoldVisitor<R,A> implements AllVisitor<R,A> {",+ " public abstract R leaf(A arg);",+ " public abstract R combine(R x, R y, A arg);",+ "",+ concatMap (prData packageAbsyn user) groups,+ "}"]+ where+ user = fst (unzip (tokenPragmas cf))+ groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]++--Traverses a category based on its type.+prData :: String -> [UserDef] -> (Cat, [Rule]) -> String+prData packageAbsyn user (cat, rules) =+ unlines [+ "/* " ++ identCat cat ++ " */",+ concatMap (prRule packageAbsyn user cat) rules+ ]++--traverses a standard rule.+prRule :: String -> [UserDef] -> Cat -> Rule -> String+prRule packageAbsyn user cat (Rule fun _ cats)+ | not (isCoercion fun || isDefinedRule fun) = unlines $+ [" public R visit(" ++ cls ++ " p, A arg) {",+ " R r = leaf(arg);"]+ ++ map (" "++) visitVars+ ++ [" return r;",+ " }"]+ where+ cats' = if allTerms cats+ then []+ else [ (c,v) |+ (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= InternalCat ]+ cls = packageAbsyn ++ "." ++ fun+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+ children = map snd cats'+ visitVars = concatMap (uncurry (prCat user)) cats'+prRule _ _ _ _ = ""++--Traverses a class's instance variables.+prCat :: [UserDef]+ -> Cat -- ^ Variable category+ -> String -- ^ Variable name+ -> [String] -- ^ Code for visiting the variable+prCat user cat nt+ | isBasicType user varType || (isList cat && isBasicType user et) = []+ | isList cat = listAccept+ | otherwise = ["r = combine(" ++ var ++ ".accept(this, arg), r, arg);"]+ where+ var = "p." ++ nt+ varType = typename (identCat (normCat cat)) user+ et = typename (show$normCatOfList cat) user+ listAccept = ["for (" ++ et ++ " x : " ++ var ++ ") {",+ " r = combine(x.accept(this,arg), r, arg);",+ "}"]++--Just checks if something is a basic or user-defined type.+isBasicType :: [UserDef] -> String -> Bool+isBasicType user v = v `elem` (map show user ++ ["Integer","Character","String","Double"])+
+ src/BNFC/Backend/Java/CFtoJLex15.hs view
@@ -0,0 +1,175 @@+{-+ BNF Converter: Java JLex generator+ Copyright (C) 2004 Author: Michael Pellauer++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the JLex input file. This+ file is quite different than Alex or Flex.++ Author : Michael Pellauer (pellauer@cs.chalmers.se),+ Bjorn Bringert (bringert@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 25 April, 2003++ Modified : 4 Nov, 2004+++ **************************************************************+-}++module BNFC.Backend.Java.CFtoJLex15 ( cf2jlex ) where++import BNFC.CF+import BNFC.Backend.Java.RegToJLex+import BNFC.Utils ( (+++) )+import BNFC.Backend.Common.NamedVariables+import Data.List++--The environment must be returned for the parser to use.+cf2jlex :: String -> String -> CF -> (String, SymEnv)+cf2jlex packageBase packageAbsyn cf = (unlines $ concat $+ [+ prelude packageBase packageAbsyn,+ cMacros,+ lexSymbols env,+ restOfJLex cf+ ], env)+ where+ env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)+ makeSymEnv [] _ = []+ makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))++prelude :: String -> String -> [String]+prelude packageBase packageAbsyn =+ [+ "// This JLex file was machine-generated by the BNF converter",+ "package" +++ packageBase ++ ";",+ "",+ "import java_cup.runtime.*;",+ "%%",+ "%cup",+ "%unicode",+ "%line",+ "%public",+ "%{",+ " String pstring = new String();",+ " public int line_num() { return (yyline+1); }",+ " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }",+ "%}"+ ]++--For now all categories are included.+--Optimally only the ones that are used should be generated.+cMacros :: [String]+cMacros = [+ "LETTER = ({CAPITAL}|{SMALL})",+ "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]",+ "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]",+ "DIGIT = [0-9]",+ "IDENT = ({LETTER}|{DIGIT}|['_])",+ "%state COMMENT",+ "%state CHAR",+ "%state CHARESC",+ "%state CHAREND",+ "%state STRING",+ "%state ESCAPED",+ "%%"+ ]++lexSymbols :: SymEnv -> [String]+lexSymbols ss = map transSym ss+ where+ transSym (s,r) =+ "<YYINITIAL>" ++ (escapeChars s) ++ " { return new Symbol(sym."+ ++ r ++ "); }"++restOfJLex :: CF -> [String]+restOfJLex cf =+ [+ lexComments (comments cf),+ userDefTokens,+ ifC catString strStates,+ ifC catChar chStates,+ ifC catDouble "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }",+ ifC catInteger "<YYINITIAL>{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }",+ ifC catIdent "<YYINITIAL>{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }"+ , "<YYINITIAL>[ \\t\\r\\n\\f] { /* ignore white space. */ }"+ ]+ where+ ifC cat s = if isUsedCat cf cat then s else ""+ userDefTokens = unlines $+ ["<YYINITIAL>" ++ printRegJLex exp ++++ "{ return new Symbol(sym." ++ show name ++ ", yytext().intern()); }"+ | (name, exp) <- tokenPragmas cf]+ strStates = unlines --These handle escaped characters in Strings.+ [+ "<YYINITIAL>\"\\\"\" { yybegin(STRING); }",+ "<STRING>\\\\ { yybegin(ESCAPED); }",+ "<STRING>\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }",+ "<STRING>. { pstring += yytext(); }",+ "<ESCAPED>n { pstring += \"\\n\"; yybegin(STRING); }",+ "<ESCAPED>\\\" { pstring += \"\\\"\"; yybegin(STRING); }",+ "<ESCAPED>\\\\ { pstring += \"\\\\\"; yybegin(STRING); }",+ "<ESCAPED>t { pstring += \"\\t\"; yybegin(STRING); }",+ "<ESCAPED>. { pstring += yytext(); yybegin(STRING); }"+ ]+ chStates = unlines --These handle escaped characters in Chars.+ [+ "<YYINITIAL>\"'\" { yybegin(CHAR); }",+ "<CHAR>\\\\ { yybegin(CHARESC); }",+ "<CHAR>[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",+ "<CHARESC>n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }",+ "<CHARESC>t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }",+ "<CHARESC>. { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",+ "<CHAREND>\"'\" {yybegin(YYINITIAL);}"+ ]+++++lexComments :: ([(String, String)], [String]) -> String+lexComments (m,s) =+ (unlines (map lexSingleComment s))+ ++ (unlines (map lexMultiComment m))++lexSingleComment :: String -> String+lexSingleComment c =+ "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }"++--There might be a possible bug here if a language includes 2 multi-line comments.+--They could possibly start a comment with one character and end it with another.+--However this seems rare.+lexMultiComment :: (String, String) -> String+lexMultiComment (b,e) = unlines [+ "<YYINITIAL>\"" ++ b ++ "\" { yybegin(COMMENT); }",+ "<COMMENT>\"" ++ e ++ "\" { yybegin(YYINITIAL); }",+ "<COMMENT>. { }",+ "<COMMENT>[\\n] { }"+ ]++-- lexReserved :: String -> String+-- lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }"++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars = concatMap escapeChar
+ src/BNFC/Backend/Java/CFtoJavaAbs15.hs view
@@ -0,0 +1,257 @@+{-+ BNF Converter: Java 1.5 Abstract Syntax+ Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Java Abstract Syntax+ It uses the BNFC.Backend.Common.NamedVariables module for variable+ naming. It returns a list of file names, and the+ contents to be written into that file. (In Java+ public classes must go in their own file.)++ The generated classes also support the Visitor+ Design Pattern.++ Author : Michael Pellauer (pellauer@cs.chalmers.se),+ Bjorn Bringert (bringert@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 24 April, 2003++ Modified : 16 June, 2004+++ **************************************************************+-}++module BNFC.Backend.Java.CFtoJavaAbs15 (cf2JavaAbs, typename) where++import BNFC.CF+import BNFC.Utils((+++),(++++))+import BNFC.Backend.Common.NamedVariables hiding (IVar, getVars, varName)+import Data.List+import Data.Char(toLower, isDigit)+import Data.Maybe(catMaybes,fromMaybe)++--Produces abstract data types in Java.+--These follow Appel's "non-object oriented" version.+--They also allow users to use the Visitor design pattern.++type IVar = (String, Int, String)+--The type of an instance variable+--a # unique to that type+--and an optional name (handles typedefs).++--The result is a list of files which must be written to disk.+--The tuple is (FileName, FileContents)+cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)]+cf2JavaAbs packageBase packageAbsyn cf =+ concatMap (prData header packageAbsyn user) rules+ where+ header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n"+ user = [n | (n,_) <- tokenPragmas cf]+ rules = [ (normCat c,fs) | (c,fs) <- cf2dataLists cf]++--Generates a (possibly abstract) category class, and classes for all its rules.+prData :: String -> String -> [UserDef] -> Data ->[(String, String)]+prData header packageAbsyn user (cat, rules) =+ categoryClass ++ (catMaybes $ map (prRule header packageAbsyn funs user cat) rules)+ where+ funs = map fst rules+ categoryClass+ | show cat `elem` funs = [] -- the catgory is also a function, skip abstract class+ | otherwise = [(identCat cat, header +++++ unlines [+ "public abstract class" +++ cls+ +++ "implements java.io.Serializable {",+ " public abstract <R,A> R accept("+ ++ cls ++ ".Visitor<R,A> v, A arg);",+ prVisitor packageAbsyn funs,+ "}"+ ])]+ where cls = identCat cat++prVisitor :: String -> [String] -> String+prVisitor packageAbsyn funs =+ unlines [+ " public interface Visitor <R,A> {",+ unlines (map prVisitFun funs),+ " }"+ ]+ where+ prVisitFun f = " public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);"++--Generates classes for a rule, depending on what type of rule it is.+prRule :: String -- ^ Header+ -> String -- ^ Abstract syntax package name+ -> [String] -- ^ Names of all constructors in the category+ -> [UserDef] -> Cat -> (Fun, [Cat]) -> Maybe (String, String)+prRule h packageAbsyn funs user c (fun, cats) =+ if isNilFun fun || isOneFun fun+ then Nothing --these are not represented in the AbSyn+ else if isConsFun fun+ then Just $ (fun', --this is the linked list case.+ unlines+ [+ h,+ "public class" +++ fun' +++ "extends java.util.LinkedList<"++ et ++"> {",+ "}"+ ])+ else Just $ (fun, --a standard rule+ unlines+ [+ h,+ "public class" +++ fun ++ ext +++ "{",+ (prInstVars vs),+ prConstructor fun user vs cats,+ prAccept packageAbsyn c fun,+ prEquals packageAbsyn fun vs,+ prHashCode packageAbsyn fun vs,+ if isAlsoCategory then prVisitor packageAbsyn funs else "",+ "}"+ ])+ where+ vs = getVars cats user+ fun' = identCat (normCat c)+ isAlsoCategory = fun == show c+ --This handles the case where a LBNF label is the same as the category.+ ext = if isAlsoCategory then "" else " extends" +++ (identCat c)+ et = typename (show $ normCatOfList c) user+++--The standard accept function for the Visitor pattern+prAccept :: String -> Cat -> String -> String+prAccept pack cat _ = "\n public <R,A> R accept(" ++ pack ++ "." ++ show cat+ ++ ".Visitor<R,A> v, A arg) { return v.visit(this, arg); }\n"++-- Creates the equals() method.+prEquals :: String -> String -> [IVar] -> String+prEquals pack fun vs =+ unlines $ map (" "++) $ ["public boolean equals(Object o) {",+ " if (this == o) return true;",+ " if (o instanceof " ++ fqn ++ ") {"]+ ++ (if null vs+ then [" return true;"]+ else [" " ++ fqn +++ "x = ("++fqn++")o;",+ " return " ++ checkKids ++ ";"]) +++ [" }",+ " return false;",+ "}"]+ where+ fqn = pack++"."++fun+ checkKids = concat $ intersperse " && " $ map checkKid vs+ checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")"+ where v = iVarName iv++-- Creates the equals() method.+prHashCode :: String -> String -> [IVar] -> String+prHashCode pack fun vs =+ unlines $ map (" "++) ["public int hashCode() {",+ " return " ++ hashKids vs ++ ";",+ "}"+ ]+ where+ aPrime = 37+ hashKids [] = show aPrime+ hashKids (v:vs) = hashKids_ (hashKid v) vs+ hashKids_ r [] = r+ hashKids_ r (v:vs) = hashKids_ (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v) vs+ hashKid iv = "this." ++ iVarName iv ++ ".hashCode()"+++--A class's instance variables.+prInstVars :: [IVar] -> String+prInstVars [] = []+prInstVars vars@((t,n,nm):vs) =+ " public" +++ "final" +++ t +++ uniques ++ ";" +++++ (prInstVars vs')+ where+ (uniques, vs') = prUniques t vars+ --these functions group the types together nicely+ prUniques :: String -> [IVar] -> (String, [IVar])+ prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs)+ prVars (x:[]) vs = iVarName (vs!!x)+ prVars (x:xs) vs = iVarName (vs!!x) ++ "," +++ prVars xs vs+ remType :: String -> [IVar] -> [IVar]+ remType _ [] = []+ remType t ((t2,n,nm):ts) = if t == t2+ then (remType t ts)+ else (t2,n,nm) : (remType t ts)++iVarName :: IVar -> String+iVarName (t,n,nm) = varName nm ++ showNum n++--The constructor just assigns the parameters to the corresponding instance variables.+prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String+prConstructor c u vs cats =+ " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" ++++ prAssigns vs params ++ "}"+ where+ (types, params) = unzip (prParams cats u (length cats) ((length cats)+1))+ interleave _ [] = []+ interleave (x:[]) (y:[]) = x +++ y+ interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys)++--Prints the parameters to the constructors.+prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)]+prParams [] _ _ _ = []+prParams (c:cs) u n m = (typename (identCat c) u,"p" ++ (show (m-n)))+ : (prParams cs u (n-1) m)++--This algorithm peeks ahead in the list so we don't use map or fold+prAssigns :: [IVar] -> [String] -> String+prAssigns [] _ = []+prAssigns _ [] = []+prAssigns ((t,n,nm):vs) (p:ps) =+ if n == 1 then+ case findIndices (\x -> case x of (l,r,_) -> l == t) vs of+ [] -> (varName nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)+ z -> ((varName nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)+ else ((varName nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)++-- Different than the standard BNFC.Backend.Common.NamedVariables version+-- because of the user-defined types.+getVars :: [Cat] -> [UserDef] -> [IVar]+getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs)+ where+ addVar is c = (c', n, c):is+ where c' = typename c user+ n = maximum (1:[n'+1 | (t,n',c'') <- is, c'' == c])+ singleToZero is = [(t,n',nm) | (t,n,nm) <- is,+ let n' = if length [n | (_,_,n) <- is, n == nm] == 1+ then 0 else n]+ hasType t (t',_,_) = t == t'++varName :: String -- ^ category name+ -> String -- ^ Variable name+varName c = (map toLower c) ++ "_"++--This makes up for the fact that there's no typedef in Java+typename :: String -> [UserDef] -> String+typename t user =+ if t == "Ident"+ then "String"+ else if t == "Char"+ then "Character"+ else if elem t (map show user)+ then "String"+ else t
+ src/BNFC/Backend/Java/CFtoJavaPrinter15.hs view
@@ -0,0 +1,361 @@+{-+ BNF Converter: Java Pretty Printer generator+ Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates the Java Pretty Printer+ class. In addition, since there's no good way+ to display a class heirarchy (toString() doesn't+ count) in Java, it generates a method that+ displays the Abstract Syntax in a way similar+ to Haskell.++ This uses Appel's method and may serve as a+ useful example to those who wish to use it.++ Author : Michael Pellauer (pellauer@cs.chalmers.se),+ Bjorn Bringert (bringert@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 24 April, 2003++ Modified : 9 Aug, 2004++ Added string buffer for efficiency (Michael, August 03)+ **************************************************************+-}+module BNFC.Backend.Java.CFtoJavaPrinter15 ( cf2JavaPrinter ) where++import BNFC.Backend.Java.CFtoJavaAbs15++import BNFC.CF+import BNFC.Backend.Common.NamedVariables+import BNFC.Utils ( (+++) )+import Data.List+import Data.Char ( toLower, isSpace )++--Produces the PrettyPrinter class.+--It will generate two methods "print" and "show"+--print is the actual pretty printer for linearization.+--show produces a Haskell-style syntax that can be extremely useful+--especially for testing parser correctness.++cf2JavaPrinter :: String -> String -> CF -> String+cf2JavaPrinter packageBase packageAbsyn cf =+ unlines+ [+ header,+ prEntryPoints packageAbsyn cf,+ unlines (map (prData packageAbsyn user) groups),+ unlines (map (shData packageAbsyn user) groups),+ footer+ ]+ where+ user = [n | (n,_) <- tokenPragmas cf]+ groups = fixCoercions (ruleGroupsInternals cf)+ header = unlines [+ "package" +++ packageBase ++ ";",+ "import" +++ packageAbsyn ++ ".*;",+ "",+ "public class PrettyPrinter",+ "{",+ " //For certain applications increasing the initial size of the buffer may improve performance.",+ " private static final int INITIAL_BUFFER_SIZE = 128;",+ " //You may wish to change the parentheses used in precedence.",+ " private static final String _L_PAREN = new String(\"(\");",+ " private static final String _R_PAREN = new String(\")\");",+ prRender+ ]+ footer = unlines [ --later only include used categories+ " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }",+ " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }",+ " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }",+ " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }",+ " private static void sh(Integer n) { render(n.toString()); }",+ " private static void sh(Double d) { render(d.toString()); }",+ " private static void sh(Character c) { render(c.toString()); }",+ " private static void sh(String s) { printQuoted(s); }",+ " private static void printQuoted(String s) { render(\"\\\"\" + s + \"\\\"\"); }",+ " private static void indent()",+ " {",+ " int n = _n_;",+ " while (n > 0)",+ " {",+ " buf_.append(\" \");",+ " n--;",+ " }",+ " }",+ " private static void backup()",+ " {",+ " if (buf_.charAt(buf_.length() - 1) == ' ') {",+ " buf_.setLength(buf_.length() - 1);",+ " }",+ " }",+ " private static void trim()",+ " {",+ " while (buf_.length() > 0 && buf_.charAt(0) == ' ')",+ " buf_.deleteCharAt(0); ",+ " while (buf_.length() > 0 && buf_.charAt(buf_.length()-1) == ' ')",+ " buf_.deleteCharAt(buf_.length()-1);",+ " }",+ " private static int _n_ = 0;",+ " private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);",+ "}"+ ]++--An extremely simple renderer for terminals.+prRender :: String+prRender = unlines+ [+ " //You may wish to change render",+ " private static void render(String s)",+ " {",+ " if (s.equals(\"{\"))",+ " {",+ " buf_.append(\"\\n\");",+ " indent();",+ " buf_.append(s);",+ " _n_ = _n_ + 2;",+ " buf_.append(\"\\n\");",+ " indent();",+ " }",+ " else if (s.equals(\"(\") || s.equals(\"[\"))",+ " buf_.append(s);",+ " else if (s.equals(\")\") || s.equals(\"]\"))",+ " {",+ " backup();",+ " buf_.append(s);",+ " buf_.append(\" \");",+ " }",+ " else if (s.equals(\"}\"))",+ " {",+ " _n_ = _n_ - 2;",+ " backup();",+ " backup();",+ " buf_.append(s);",+ " buf_.append(\"\\n\");",+ " indent();",+ " }",+ " else if (s.equals(\",\"))",+ " {",+ " backup();",+ " buf_.append(s);",+ " buf_.append(\" \");",+ " }",+ " else if (s.equals(\";\"))",+ " {",+ " backup();",+ " buf_.append(s);",+ " buf_.append(\"\\n\");",+ " indent();",+ " }",+ " else if (s.equals(\"\")) return;",+ " else",+ " {",+ " buf_.append(s);",+ " buf_.append(\" \");",+ " }",+ " }"+ ]++prEntryPoints :: String -> CF -> String+prEntryPoints packageAbsyn cf =+ msg ++ concat (map prEntryPoint (allCats cf)) ++ msg2+ where+ msg = " // print and show methods are defined for each category.\n"+ msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n"+ prEntryPoint cat | (normCat cat) == cat = unlines+ [+ " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",+ " {",+ " pp(foo, 0);",+ " trim();",+ " String temp = buf_.toString();",+ " buf_.delete(0,buf_.length());",+ " return temp;",+ " }",+ " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",+ " {",+ " sh(foo);",+ " String temp = buf_.toString();",+ " buf_.delete(0,buf_.length());",+ " return temp;",+ " }"+ ]+ where+ cat' = identCat cat+ prEntryPoint _ = ""++prData :: String -> [UserDef] -> (Cat, [Rule]) -> String+prData packageAbsyn user (cat, rules) =+ if isList cat+ then unlines+ [+ " private static void pp(" ++ packageAbsyn ++ "."+ ++ identCat (normCat cat) +++ "foo, int _i_)",+ " {",+ (prList user cat rules) ++ " }"+ ]+ else unlines --not a list+ [+ " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)",+ " {",+ (concat (addElse $ map (prRule packageAbsyn) rules)) ++ " }"+ ]+ where addElse = map (" "++). intersperse "else " . filter (not . null) . map (dropWhile isSpace)++prRule :: String -> Rule -> String+prRule packageAbsyn r@(Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = concat+ [+ " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n",+ " {\n",+ " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("+ ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n",+ lparen,+ cats',+ rparen,+ " }\n"+ ]+ where+ p = precRule r+ (lparen, rparen) =+ (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n",+ " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n")+ cats' = case cats of+ [] -> ""+ _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))+ fnm = '_' : map toLower fun++ getPrec (Right {}) = 0+ getPrec (Left c) = precCat c++prRule _nm _ = ""++prList :: [UserDef] -> Cat -> [Rule] -> String+prList user c rules = unlines+ [+ " for (java.util.Iterator<" ++ et+ ++ "> it = foo.iterator(); it.hasNext();)",+ " {",+ " pp(it.next(), 0);",+ " if (it.hasNext()) {",+ " render(\"" ++ sep ++ "\");",+ " } else {",+ " render(\"" ++ optsep ++ "\");",+ " }",+ " }"+ ]+ where+ et = typename (show $ normCatOfList c) user+ sep = escapeChars $ getCons rules+ optsep = if hasOneFunc rules then "" else sep++prCat fnm (c, p) =+ case c of+ Right t -> " render(\"" ++ escapeChars t ++ "\");\n"+ Left nt | "string" `isPrefixOf` nt+ -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n"+ | isInternalVar nt -> ""+ | otherwise+ -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n"++--The following methods generate the Show function.++shData :: String -> [UserDef] -> (Cat, [Rule]) -> String+shData packageAbsyn user (cat, rules) =+ if isList cat+ then unlines+ [+ " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",+ " {",+ (shList user cat rules) ++ " }"+ ]+ else unlines+ [+ " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",+ " {",+ (concat (map (shRule packageAbsyn) rules)) ++ " }"+ ]++shRule :: String -> Rule -> String+shRule packageAbsyn (Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = unlines+ [+ " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")",+ " {",+ " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("+ ++ packageAbsyn ++ "." ++ fun ++ ") foo;",+ members ++ " }"+ ]+ where+ members = concat+ [+ lparen,+ " render(\"" ++ (escapeChars fun) ++ "\");\n",+ cats',+ rparen+ ]+ cats' = if allTerms cats+ then ""+ else (concat (map (shCat fnm) (fixOnes (numVars [] cats))))+ (lparen, rparen) =+ if allTerms cats+ then ("","")+ else (" render(\"(\");\n"," render(\")\");\n")+ allTerms [] = True+ allTerms ((Left {}):_) = False+ allTerms (_:zs) = allTerms zs+ fnm = '_' : map toLower fun+shRule _nm _ = ""++shList :: [UserDef] -> Cat -> [Rule] -> String+shList user c _rules = unlines+ [+ " for (java.util.Iterator<" ++ et+ ++ "> it = foo.iterator(); it.hasNext();)",+ " {",+ " sh(it.next());",+ " if (it.hasNext())",+ " render(\",\");",+ " }"+ ]+ where+ et = typename (show $ normCatOfList c) user++shCat fnm c =+ case c of+ Right {} -> ""+ Left nt | "list" `isPrefixOf` nt+ -> unlines [" render(\"[\");",+ " sh(" ++ fnm ++ "." ++ nt ++ ");",+ " render(\"]\");"]+ | isInternalVar nt -> ""+ | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n"++--Helper function that escapes characters in strings+escapeChars :: String -> String+escapeChars [] = []+escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))+escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))+escapeChars (x:xs) = x : (escapeChars xs)++isInternalVar x = x == show InternalCat ++ "_"
+ src/BNFC/Backend/Java/CFtoVisitSkel15.hs view
@@ -0,0 +1,141 @@+{-+ BNF Converter: Java Vistor skeleton generator+ Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-+ **************************************************************+ BNF Converter Module++ Description : This module generates a Skeleton function+ which uses the Visitor Design Pattern, which+ users may find more familiar than Appel's+ method.++ Author : Michael Pellauer (pellauer@cs.chalmers.se),+ Bjorn Bringert (bringert@cs.chalmers.se)++ License : GPL (GNU General Public License)++ Created : 4 August, 2003++ Modified : 16 June, 2004+++ **************************************************************+-}+module BNFC.Backend.Java.CFtoVisitSkel15 (cf2VisitSkel) where++import BNFC.CF+import BNFC.Backend.Java.CFtoJavaAbs15 (typename)+import BNFC.Utils ((+++), (++++))+import BNFC.Backend.Common.NamedVariables+import Data.List+import Data.Char(toLower, toUpper, isDigit)++--Produces a Skeleton using the Visitor Design Pattern.+--Thus the user can choose which Skeleton to use.++cf2VisitSkel :: String -> String -> CF -> String+cf2VisitSkel packageBase packageAbsyn cf =+ concat [+ header,+-- " // NOT IMPLEMENTED for java1.5\n",+ concatMap (prData packageAbsyn user) groups,+ "}"]+ where+ user = fst (unzip (tokenPragmas cf))+ groups = fixCoercions (ruleGroups cf)+ header = unlines [+ "package" +++ packageBase ++ ";",+ "import" +++ packageAbsyn ++ ".*;",+ "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",+ "/* This implements the common visitor design pattern.",+ " Tests show it to be slightly less efficient than the",+ " instanceof method, but easier to use. ",+ " Replace the R and A parameters with the desired return",+ " and context types.*/",+ "",+ "public class VisitSkel",+ "{"+ ]+++--Traverses a category based on its type.+prData :: String -> [UserDef] -> (Cat, [Rule]) -> String+prData packageAbsyn user (cat, rules) =+ if isList cat+ then ""+ else unlines [" public class " ++ identCat cat ++ "Visitor<R,A> implements "+ ++ identCat cat ++ ".Visitor<R,A>",+ " {",+ concatMap (prRule packageAbsyn user) rules,+ " }"+ ]++--traverses a standard rule.+prRule :: String -> [UserDef] -> Rule -> String+prRule packageAbsyn user (Rule fun c cats) | not (isCoercion fun || isDefinedRule fun) = unlines+ [+ " public R visit(" ++ packageAbsyn ++ "." ++ fun ++ " p, A arg)",+ " {",+ " /* Code For " ++ fun ++ " Goes Here */",+ "",+ concatMap (uncurry (prCat user)) cats',+ " return null;",+ " }"+ ]+ where+ cats' = if allTerms cats+ then []+ else [ (c,v) |+ (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)) ]+ allTerms [] = True+ allTerms ((Left z):zs) = False+ allTerms (z:zs) = allTerms zs+prRule user nm _ = ""++--Traverses a class's instance variables.+prCat :: [UserDef]+ -> Cat -- ^ Variable category+ -> String -- ^ Variable name+ -> String -- ^ Code for visiting the variable+prCat user cat nt | isBasic user nt = " //" ++ var ++ ";\n"+ | "list" `isPrefixOf` nt = listAccept+ | otherwise = " " ++ accept ++ "\n"+ where+ var = "p." ++ nt+ varType = typename (identCat (normCat cat)) user+ accept = var ++ ".accept(new " ++ varType ++ "Visitor<R,A>(), arg);"+ et = typename (show $normCatOfList cat) user+ listAccept = unlines [" for (" ++ et ++ " x : " ++ var ++ ") {",+ " }"]++--Just checks if something is a basic or user-defined type.+--This is because you don't -> a basic non-pointer type.+isBasic :: [UserDef] -> String -> Bool+isBasic user v =+ if elem (init v) user'+ then True+ else if "integer_" `isPrefixOf` v then True+ else if "char_" `isPrefixOf` v then True+ else if "string_" `isPrefixOf` v then True+ else if "double_" `isPrefixOf` v then True+ else if "ident_" `isPrefixOf` v then True+ else False+ where+ user' = map (map toLower.show) user
+ src/BNFC/Backend/Java/RegToJLex.hs view
@@ -0,0 +1,86 @@+module BNFC.Backend.Java.RegToJLex (printRegJLex, escapeChar) where++-- modified from pretty-printer generated by the BNF converter++import AbsBNF+import Data.Char++-- the top-level printing method+printRegJLex :: Reg -> String+printRegJLex = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend (0 :: Int) where+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""+ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = [escapeChar c]+ prtList s = map (concat . prt 0) s++escapeChar :: Char -> String+escapeChar '^' = "\\x5E" -- special case, since \^ is a control character escape+escapeChar x | x `elem` jlexReserved = '\\' : [x]+escapeChar x = [x]++-- Characters that must be escaped in JLex regular expressions+jlexReserved :: [Char]+jlexReserved = ['?', '*', '+', '|', '(', ')', '^', '$', '.', '[', ']', '{', '}', '"', '\\']++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])++ -- JLex does not support set difference+ --RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RMinus reg0 REps -> prt i reg0 -- REps is identity for set difference+ RMinus RAny reg@(RChar _) -> prPrec i 3 (concat [["[^"],prt 0 reg,["]"]])+ RMinus RAny (RAlts str) -> prPrec i 3 (concat [["[^"],prt 0 str,["]"]])+ -- FIXME: maybe we could add cases for char - RDigit, RLetter etc.+ RMinus reg0 reg -> error $ "JLex does not support general set difference"++ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["[^.]"])+ RChar c -> prPrec i 3 (concat [prt 0 c])+ RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) str))+ RDigit -> prPrec i 3 (concat [["{DIGIT}"]])+ RLetter -> prPrec i 3 (concat [["{LETTER}"]])+ RUpper -> prPrec i 3 (concat [["{CAPITAL}"]])+ RLower -> prPrec i 3 (concat [["{SMALL}"]])+ RAny -> prPrec i 3 (concat [["."]])+++
+ src/BNFC/Backend/Latex.hs view
@@ -0,0 +1,309 @@+{-+ BNF Converter: Latex Generator+ Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+module BNFC.Backend.Latex where++import AbsBNF (Reg (..))+import BNFC.Options hiding (Backend)+import BNFC.Backend.Base+import BNFC.Backend.Common.Makefile as Makefile+import BNFC.CF+import BNFC.GetCF+import BNFC.Utils+import Control.Monad (unless,when)+import Data.List (nub,intersperse)+import System.Console.GetOpt+import System.Exit (exitSuccess)+import System.FilePath ((<.>),replaceExtension, takeBaseName)+import Text.Printf++makeLatex :: SharedOptions -> CF -> Backend+makeLatex opts cf = do+ let texfile = name <.> "tex"+ mkfile texfile (cfToLatex name cf)+ Makefile.mkMakefile opts (makefile texfile)+ where name = lang opts++cfToLatex :: String -> CF -> String+cfToLatex name cf = unlines [+ "\\batchmode",+ beginDocument name,+ macros,+ introduction,+ prtTerminals name cf,+ prtBNF name cf,+ endDocument+ ]+++makefile_ = makefile+makefile :: String -> String+makefile texfile =+ Makefile.mkRule "all" [pdffile]+ []+ $ Makefile.mkRule pdffile [texfile]+ [ printf "pdflatex %s" texfile ]+ $ Makefile.mkRule "clean" []+ [ unwords [ "-rm", pdffile, auxfile, logfile ]]+ $ Makefile.mkRule "cleanall" ["clean"]+ [ "-rm Makefile " ++ texfile ]+ ""+ where pdffile = replaceExtension texfile "pdf"+ auxfile = replaceExtension texfile "aux"+ logfile = replaceExtension texfile "log"++introduction :: String+introduction = concat+ [+ "\nThis document was automatically generated by ",+ "the {\\em BNF-Converter}.",+ " It was generated together with the lexer, the parser, and the",+ " abstract syntax module, which guarantees that the document",+ " matches with the implementation of the language (provided no",+ " hand-hacking has taken place).\n"+ ]++prtTerminals :: String -> CF -> String+prtTerminals name cf = unlines [+ "\\section*{The lexical structure of " ++ name ++ "}",+ identSection cf,+ "\\subsection*{Literals}",+ prtLiterals name cf,+ unlines (map prtOwnToken (tokenPragmas cf)),+ "\\subsection*{Reserved words and symbols}",+ prtReserved name cf,+ prtSymb name cf,+ "\\subsection*{Comments}",+ prtComments $ comments cf+ ]++identSection cf = if not (hasIdent cf) then [] else+ unlines [+ "\\subsection*{Identifiers}",+ prtIdentifiers+ ]++prtIdentifiers :: String+prtIdentifiers = unlines+ [+ "Identifiers \\nonterminal{Ident} are unquoted strings beginning with a letter,",+ "followed by any combination of letters, digits, and the characters {\\tt \\_ '},",+ "reserved words excluded."+ ]++prtLiterals :: String -> CF -> String+prtLiterals name cf =+ unlines $ map stringLit $+ filter (`notElem` [Cat "Ident"]) $+ literals cf++stringLit :: Cat -> String+stringLit cat = unlines $ case cat of+ Cat "Char" -> ["Character literals \\nonterminal{Char}\\ have the form",+ "\\terminal{'}$c$\\terminal{'}, where $c$ is any single character.",+ ""+ ]+ Cat "String" -> ["String literals \\nonterminal{String}\\ have the form",+ "\\terminal{\"}$x$\\terminal{\"}, where $x$ is any sequence of any characters",+ "except \\terminal{\"}\\ unless preceded by \\verb6\\6.",+ ""]+ Cat "Integer" -> ["Integer literals \\nonterminal{Int}\\ are nonempty sequences of digits.",+ ""]+ Cat "Double" -> ["Double-precision float literals \\nonterminal{Double}\\ have the structure",+ "indicated by the regular expression" ++++ "$\\nonterminal{digit}+ \\mbox{{\\it `.'}} \\nonterminal{digit}+ (\\mbox{{\\it `e'}} \\mbox{{\\it `-'}}? \\nonterminal{digit}+)?$ i.e.\\",+ "two sequences of digits separated by a decimal point, optionally",+ "followed by an unsigned or negative exponent.",+ ""]+ _ -> []++prtOwnToken (name,reg) = unlines+ [ show name +++ "literals are recognized by the regular expression",+ "\\(" +++ latexRegExp reg +++ "\\)"+ ]++prtComments :: ([(String,String)],[String]) -> String+prtComments (xs,ys) = concat+ [+ if (null ys) then+ "There are no single-line comments in the grammar. \\\\"+ else+ "Single-line comments begin with " ++ sing ++". \\\\",+ if (null xs) then+ "There are no multiple-line comments in the grammar."+ else+ "Multiple-line comments are enclosed with " ++ mult ++"."+ ]+ where+ sing = concat $ intersperse ", " $ map (symbol.prt) ys+ mult = concat $ intersperse ", " $+ map (\(x,y) -> (symbol (prt x))+ ++ " and " +++ (symbol (prt y))) xs++prtSymb :: String -> CF -> String+prtSymb name cf = case symbols cf of+ [] -> "\nThere are no symbols in " ++ name ++ ".\\\\\n"+ xs -> "The symbols used in " ++ name ++ " are the following: \\\\\n"+ +++ (tabular 3 $ three $ map (symbol.prt) xs)++prtReserved :: String -> CF -> String+prtReserved name cf = case reservedWords cf of+ [] -> stringRes name +++ "\nThere are no reserved words in " ++ name ++ ".\\\\\n"+ xs -> stringRes name +++ (tabular 3 $ three $ map (reserved.prt) xs)++stringRes :: String -> String+stringRes name = concat+ ["The set of reserved words is the set of terminals ",+ "appearing in the grammar. Those reserved words ",+ "that consist of non-letter characters are called symbols, and ",+ "they are treated in a different way from those that ",+ "are similar to identifiers. The lexer ",+ "follows rules familiar from languages ",+ "like Haskell, C, and Java, including longest match ",+ "and spacing conventions.",+ "\n\n",+ "The reserved words used in " ++ name ++ " are the following: \\\\\n"]++three :: [String] -> [[String]]+three [] = []+three [x] = [[x,[],[]]]+three [x,y] = [[x,y,[]]]+three (x:y:z:xs) = [x,y,z] : three xs++prtBNF :: String -> CF -> String+prtBNF name cf = unlines [+ "\\section*{The syntactic structure of " ++ name ++"}",+ "Non-terminals are enclosed between $\\langle$ and $\\rangle$. ",+ "The symbols " ++ arrow ++ " (production), " +++ delimiter ++" (union) ",+ "and " ++ empty ++ " (empty rule) belong to the BNF notation. ",+ "All other symbols are terminals.\\\\",+ prtRules (ruleGroups cf)+ ]++prtRules :: [(Cat,[Rule])] -> String+prtRules [] = []+prtRules ((c,[]):xs)+ = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs+prtRules ((c,(r:rs)):xs)+ = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] +++ [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) +++ prtRules xs++prtSymbols :: [Either Cat String] -> String+prtSymbols [] = empty+prtSymbols xs = foldr (+++) [] (map p xs)+ where p (Left r) = nonterminal r --- (prt r)+ p (Right r) = terminal (prt r)+++prt :: String -> String+prt = concatMap escape+ where escape '\\' = "$\\backslash$"+ escape '~' = "\\~{}"+ escape '^' = "{\\textasciicircum}"+ escape c | c `elem` "$&%#_{}" = ['\\', c]+ escape c | c `elem` "+=|<>-" = "{$" ++ [c] ++ "$}"+ escape c = [c]++macros :: String+macros =+ "\\newcommand{\\emptyP}{\\mbox{$\\epsilon$}}" +++++ "\\newcommand{\\terminal}[1]{\\mbox{{\\texttt {#1}}}}" +++++ "\\newcommand{\\nonterminal}[1]{\\mbox{$\\langle \\mbox{{\\sl #1 }} \\! \\rangle$}}" +++++ "\\newcommand{\\arrow}{\\mbox{::=}}" +++++ "\\newcommand{\\delimit}{\\mbox{$|$}}" +++++ "\\newcommand{\\reserved}[1]{\\mbox{{\\texttt {#1}}}}" +++++ "\\newcommand{\\literal}[1]{\\mbox{{\\texttt {#1}}}}" +++++ "\\newcommand{\\symb}[1]{\\mbox{{\\texttt {#1}}}}"++reserved :: String -> String+reserved s = "{\\reserved{" ++ s ++ "}}"++literal :: String -> String+literal s = "{\\literal{" ++ s ++ "}}"++empty :: String+empty = "{\\emptyP}"++symbol :: String -> String+symbol s = "{\\symb{" ++ s ++ "}}"++tabular :: Int -> [[String]] -> String+tabular n xs = "\n\\begin{tabular}{" ++ concat (replicate n "l") ++ "}\n" +++ concat (map (\(a:as) -> foldr (+++) "\\\\\n" (a:(map ('&':) as))) xs) +++ "\\end{tabular}\\\\\n"++terminal :: String -> String+terminal s = "{\\terminal{" ++ s ++ "}}"++nonterminal :: Cat -> String+nonterminal s = "{\\nonterminal{" ++ mkId (identCat s) ++ "}}" where+ mkId = map mk+ mk c = case c of+ '_' -> '-' ---+ _ -> c+++arrow :: String+arrow = " {\\arrow} "++delimiter :: String+delimiter = " {\\delimit} "++beginDocument :: String -> String+beginDocument name =+ "%This Latex file is machine-generated by the BNF-converter\n" +++++ "\\documentclass[a4paper,11pt]{article}" +++++ "\\author{BNF-converter}" +++++ "\\title{The Language " ++ name ++ "}" +++++ -- "\\usepackage{isolatin1}" +++++ "\\setlength{\\parindent}{0mm}" +++++ "\\setlength{\\parskip}{1mm}" +++++ "\\begin{document}\n" +++++ "\\maketitle\n"++endDocument :: String+endDocument =+ "\n\\end{document}\n"++latexRegExp :: Reg -> String+latexRegExp = rex (0 :: Int) where+ rex i e = case e of+ RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg+ RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "\\mid" +++ rex 1 reg+ RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg+ RStar reg -> rex 3 reg ++ "*"+ RPlus reg -> rex 3 reg ++ "+"+ ROpt reg -> rex 3 reg ++ "?"+ REps -> "\\epsilon"+ RChar c -> "\\mbox{`" ++ prt [c] ++ "'}"+ RAlts str -> "[" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "]"+ RSeqs str -> "\\{" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "\\}"+ RDigit -> "{\\nonterminal{digit}}"+ RLetter -> "{\\nonterminal{letter}}"+ RUpper -> "{\\nonterminal{upper}}"+ RLower -> "{\\nonterminal{lower}}"+ RAny -> "{\\nonterminal{anychar}}"+ ifPar i j s = if i > j then "(" ++ s ++ ")" else s
+ src/BNFC/Backend/OCaml.hs view
@@ -0,0 +1,165 @@+{-+ BNF Converter: OCaml main file+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-- based on BNFC Haskell backend+++module BNFC.Backend.OCaml (makeOCaml) where++import BNFC.CF+import BNFC.Backend.Base hiding (Backend)+import BNFC.Backend.Common.Makefile+import BNFC.Backend.OCaml.CFtoOCamlYacc+import BNFC.Backend.OCaml.CFtoOCamlLex+import BNFC.Backend.OCaml.CFtoOCamlAbs+import BNFC.Backend.OCaml.CFtoOCamlTemplate+import BNFC.Backend.OCaml.CFtoOCamlPrinter+import BNFC.Backend.OCaml.CFtoOCamlShow+import BNFC.Backend.OCaml.CFtoOCamlTest+import BNFC.Backend.XML+import BNFC.Utils+import System.FilePath (takeFileName)+import BNFC.Options++import Data.Char+import Data.Maybe (fromMaybe,maybe)+import System.Exit (exitFailure)+import System.FilePath (pathSeparator, (</>))+import Control.Monad(when)++-- naming conventions++noLang :: SharedOptions -> String -> String+noLang _ name = name++withLang :: SharedOptions -> String -> String+withLang opts name = name ++ lang opts++mkMod :: (SharedOptions -> String -> String) -> String -> SharedOptions -> String+mkMod addLang name opts =+ pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name+ where pref = maybe "" (++".") (inPackage opts)++mkFile :: (SharedOptions -> String -> String) -> String -> String -> SharedOptions -> FilePath+mkFile addLang name ext opts =+ pref ++ if inDir opts+ then lang opts </> name ++ ext'+ else addLang opts name ++ if null ext then "" else ext'+ where pref = maybe "" (\p->pkgToDir p </> "") (inPackage opts)+ ext' = if null ext then "" else "." ++ ext++absFile, absFileM, ocamllexFile, ocamllexFileM,+ ocamlyaccFile, ocamlyaccFileM,+ utilFile, utilFileM,+ templateFile, templateFileM,+ printerFile, printerFileM,+ tFile, tFileM :: SharedOptions -> String+absFile = mkFile withLang "Abs" "ml"+absFileM = mkMod withLang "Abs"+ocamllexFile = mkFile withLang "Lex" "mll"+ocamllexFileM = mkMod withLang "Lex"+ocamlyaccFile = mkFile withLang "Par" "mly"+ocamlyaccFileM = mkMod withLang "Par"+templateFile = mkFile withLang "Skel" "ml"+templateFileM = mkMod withLang "Skel"+printerFile = mkFile withLang "Print" "ml"+printerFileM = mkMod withLang "Print"+showFile = mkFile withLang "Show" "ml"+showFileM = mkMod withLang "Show"+tFile = mkFile withLang "Test" "ml"+tFileM = mkMod withLang "Test"+utilFile = mkFile noLang "BNFC_Util" "ml"+utilFileM = mkMod noLang "BNFC_Util"+xmlFileM = mkMod withLang "XML"++makeOCaml :: SharedOptions -> CF -> MkFiles ()+makeOCaml opts cf = do+ let absMod = absFileM opts+ lexMod = ocamllexFileM opts+ parMod = ocamlyaccFileM opts+ prMod = printerFileM opts+ showMod = showFileM opts+-- layMod = layoutFileM opts+ utilMod = utilFileM opts+ do+ let dir = codeDir opts+ mkfile (absFile opts) $ cf2Abstract absMod cf+ mkfile (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf+ mkfile (ocamlyaccFile opts) $+ cf2ocamlyacc parMod absMod lexMod cf+ mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod cf+ mkfile (printerFile opts) $ cf2Printer prMod absMod cf+ mkfile (showFile opts) $ cf2show showMod absMod cf+ mkfile (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf+ mkfile (utilFile opts) $ utilM+ mkMakefile opts $ makefile opts+ case xml opts of+ 2 -> makeXML opts True cf+ 1 -> makeXML opts False cf+ _ -> return ()++pkgToDir :: String -> FilePath+pkgToDir s = replace '.' pathSeparator s++codeDir :: SharedOptions -> FilePath+codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)+ dir = if inDir opts then lang opts else ""+ sep = if null pref || null dir then "" else [pathSeparator]+ in pref ++ sep ++ dir++makefile :: SharedOptions -> String+makefile opts =+ mkRule "all" []+ [ "ocamlyacc " ++ ocamlyaccFile opts+ , "ocamllex " ++ ocamllexFile opts+ , "ocamlc -o " ++ mkFile withLang "Test" "" opts ++++ utilFile opts ++++ absFile opts +++ templateFile opts ++++ showFile opts +++ printerFile opts ++++ mkFile withLang "Par" "mli" opts ++++ mkFile withLang "Par" "ml" opts ++++ mkFile withLang "Lex" "ml" opts ++++ tFile opts ]+ $ mkRule "clean" []+ [ "-rm -f " ++ unwords (map (dir++) [ "*.cmi", "*.cmo", "*.o" ]) ]+ $ mkRule "distclean" ["clean"]+ [ "-rm -f " ++ unwords [ mkFile withLang "Lex" "*" opts,+ mkFile withLang "Par" "*" opts,+ mkFile withLang "Layout" "*" opts,+ mkFile withLang "Skel" "*" opts,+ mkFile withLang "Print" "*" opts,+ mkFile withLang "Show" "*" opts,+ mkFile withLang "Test" "*" opts,+ mkFile withLang "Abs" "*" opts,+ mkFile withLang "Test" "" opts,+ utilFile opts,+ "Makefile*" ]]+ ""+ where dir = let d = codeDir opts in if null d then "" else d ++ [pathSeparator]++utilM :: String+utilM = unlines+ ["(* automatically generated by BNFC *)",+ "",+ "open Lexing",+ "",+ "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)",+ "exception Parse_error of Lexing.position * Lexing.position"+ ]+
+ src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs view
@@ -0,0 +1,64 @@+{-+ BNF Converter: OCaml Abstract Syntax Generator+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-- based on BNFC Haskell backend++module BNFC.Backend.OCaml.CFtoOCamlAbs (cf2Abstract) where++import BNFC.CF+import BNFC.Utils((+++),(++++))+import Data.List(intersperse)+import BNFC.Backend.OCaml.OCamlUtil++-- to produce an OCaml module+cf2Abstract :: String -> CF -> String+cf2Abstract name cf = unlines $+ "(* OCaml module generated by the BNF converter *)\n\n" :+ mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf))++-- allow mutual recursion so that we do not have to sort the type definitions in+-- dependency order+mutualRecDefs :: [String] -> [String]+mutualRecDefs ss = case ss of+ [] -> []+ [x] -> ["type" +++ x]+ x:xs -> ("type" +++ x) : map ("and" +++) xs++++prData :: Data -> String+prData (cat,rules) =+ fixType cat +++ "=\n " +++ concat (intersperse "\n | " (map prRule rules)) +++ "\n"++prRule (fun,[]) = fun+prRule (fun,cats) = fun +++ "of" +++ mkTupleType cats++mkTupleType [c] = fixType c+mkTupleType (c:cs) = fixType c +++ "*" +++ mkTupleType cs++prSpecialData :: CF -> Cat -> String+prSpecialData cf cat = fixType cat +++ "=" +++ show cat +++ "of" +++ contentSpec cf cat++-- unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"]++contentSpec :: CF -> Cat -> String+contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String"+ if isPositionCat cf cat then "((int * int) * string)" else "string"
+ src/BNFC/Backend/OCaml/CFtoOCamlLex.hs view
@@ -0,0 +1,244 @@+{-+ BNF Converter: ocamllex Generator+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++-- based on BNFC Haskell backend++module BNFC.Backend.OCaml.CFtoOCamlLex (cf2ocamllex) where++import Data.List+import Data.Char++import BNFC.CF+import AbsBNF+import BNFC.Backend.OCaml.CFtoOCamlYacc (terminal)+import BNFC.Utils ((+++))++cf2ocamllex :: String -> String -> CF -> String+cf2ocamllex name parserMod cf =+ unlines $ concat $ intersperse [""] [+ header parserMod cf,+ definitions cf,+ let r = rules cf in case r of+ [] -> []+ x:xs -> ("rule" +++ x) : map ("and" +++) xs+ ]++header :: String -> CF -> [String]+header parserMod cf = [+ "(* This ocamllex file was machine-generated by the BNF converter *)",+ "{",+ "open " ++ parserMod,+ "open Lexing",+ "",+ hashtables cf,+ "",+ "let unescapeInitTail (s:string) : string =",+ " let rec unesc s = match s with",+ " '\\\\'::c::cs when List.mem c ['\\\"'; '\\\\'; '\\\''] -> c :: unesc cs",+ " | '\\\\'::'n'::cs -> '\\n' :: unesc cs",+ " | '\\\\'::'t'::cs -> '\\t' :: unesc cs",+ " | '\\\"'::[] -> []",+ " | c::cs -> c :: unesc cs",+ " | _ -> []",+ " (* explode/implode from caml FAQ *)",+ " in let explode (s : string) : char list =",+ " let rec exp i l =",+ " if i < 0 then l else exp (i - 1) (s.[i] :: l) in",+ " exp (String.length s - 1) []",+ " in let implode (l : char list) : string =",+ " let res = String.create (List.length l) in",+ " let rec imp i = function",+ " | [] -> res",+ " | c :: l -> res.[i] <- c; imp (i + 1) l in",+ " imp 0 l",+ " in implode (unesc (List.tl (explode s)))",+ "",+ "let incr_lineno (lexbuf:Lexing.lexbuf) : unit =",+ " let pos = lexbuf.lex_curr_p in",+ " lexbuf.lex_curr_p <- { pos with",+ " pos_lnum = pos.pos_lnum + 1;",+ " pos_bol = pos.pos_cnum;",+ " }",+ "}"+ ]++-- | set up hashtables for reserved symbols and words+hashtables :: CF -> String+hashtables cf = ht "symbol_table" (symbols cf ) ++ "\n" +++ ht "resword_table" (reservedWords cf)+ where ht table syms | length syms == 0 = ""+ ht table syms = unlines [+ "let" +++ table +++ "= Hashtbl.create " ++ show (length syms),+ "let _ = List.iter (fun (kwd, tok) -> Hashtbl.add" +++ table+ +++ "kwd tok)",+ " [" ++ concat (intersperse ";" keyvals) ++ "]"+ ]+ where keyvals = map (\(x,y) -> "(" ++ x ++ ", " ++ y ++ ")")+ (zip (map show syms) (map (terminal cf) syms))++++definitions :: CF -> [String]+definitions cf = concat [+ cMacros,+ rMacros cf,+ uMacros cf+ ]+++cMacros :: [String]+cMacros = [+ "let l = ['a'-'z' 'A'-'Z' '\\192' - '\\255'] # ['\\215' '\\247'] (* isolatin1 letter FIXME *)",+ "let c = ['A'-'Z' '\\192'-'\\221'] # ['\\215'] (* capital isolatin1 letter FIXME *)",+ "let s = ['a'-'z' '\\222'-'\\255'] # ['\\247'] (* small isolatin1 letter FIXME *)",+ "let d = ['0'-'9'] (* digit *)",+ "let i = l | d | ['_' '\\''] (* identifier character *)",+ "let u = ['\\000'-'\\255'] (* universal: any character *)"+ ]++rMacros :: CF -> [String]+rMacros cf =+ let symbs = symbols cf+ in+ (if null symbs then [] else [+ "let rsyms = (* reserved words consisting of special symbols *)",+ " " ++ unwords (intersperse "|" (map mkEsc symbs))+ ])+ where+ mkEsc s = "\"" ++ concat (map f s) ++ "\""+ f x = if x `elem` ['"','\\'] then "\\" ++ [x] else [x]++-- user macros, derived from the user-defined tokens+uMacros :: CF -> [String]+uMacros cf = ["let " ++ name ++ " = " ++ rep | (name, rep, _) <- userTokens cf]++-- returns the tuple of (reg_name, reg_representation, token_name)+userTokens :: CF -> [(String, String, String)]+userTokens cf =+ let regName = map toLower . show in+ [(regName name, printRegOCaml reg, show name) | (name, reg) <- tokenPragmas cf]+ ++rules :: CF -> [String]+rules cf = oneRule $ concat [+ lexComments (comments cf),+ ["l i* " ++ case reservedWords cf of+ [] -> "{let id = lexeme lexbuf in TOK_Ident id}"+ _ -> "{let id = lexeme lexbuf in try Hashtbl.find resword_table id with Not_found -> TOK_Ident id}"+ ],+ if null (symbols cf) then []+ else ["rsyms {let id = lexeme lexbuf in try Hashtbl.find symbol_table id with Not_found -> failwith (\"internal lexer error: reserved symbol \" ^ id ^ \" not found in hashtable\")}"],+ ["d+ {let i = lexeme lexbuf in TOK_Integer (int_of_string i)}"],+ ["d+ '.' d+ ('e' ('-')? d+)? {let f = lexeme lexbuf in TOK_Double (float_of_string f)}"],+ ["'\\\"' ((u # ['\\\"' '\\\\' '\\n']) | ('\\\\' ('\\\"' | '\\\\' | '\\\'' | 'n' | 't')))* '\\\"' {let s = lexeme lexbuf in TOK_String (unescapeInitTail s)}"],+ ["'\\'' ((u # ['\\\'' '\\\\']) | ('\\\\' ('\\\\' | '\\\'' | 'n' | 't'))) '\\\'' {let s = lexeme lexbuf in TOK_Char s.[1]}"],+ userTokenRules,+ ["[' ' '\\t'] {token lexbuf}"],+ ["'\\n' {incr_lineno lexbuf; token lexbuf}"],+ ["eof { TOK_EOF }"]+ ]+ where+ oneRule xs = ["token = \n parse " ++ concat (intersperse "\n | " xs)]+ lexComments ([],[]) = []+ lexComments (xs,s1:ys) = ('\"' : s1 ++ "\"" +++ " (_ # '\\n')* { token lexbuf } (* Toss single line comments *)") :+ lexComments (xs, ys)+ lexComments (([l1,l2],[r1,r2]):xs,[]) = (concat $+ [+ ('\"':l1:l2:"\" ((u # ['"), -- FIXME quotes or escape?+ (l2:"']) | '"),+ (r1:"' (u # ['"),+ (r2:"']))* ('"),+ (r1:"')+ '"),+ (r2:"' { token lexbuf } \n")+ ]) :+ lexComments (xs, [])+ lexComments ((_:xs),[]) = lexComments (xs,[])+ userTokenRules = [ name ++ " as x { TOK_" ++ token ++ " x }" | (name, _, token) <- userTokens cf]+ +++-------------------------------------------------------------------+-- Modified from the inlined version of @RegToAlex@.+-------------------------------------------------------------------++-- modified from pretty-printer generated by the BNF converter++-- the top-level printing method+printRegOCaml :: Reg -> String+printRegOCaml = render . prt 0++-- you may want to change render and parenth++render :: [String] -> String+render = rend 0+ where rend :: Int -> [String] -> String+ rend i ss = case ss of+ "[" :ts -> cons "[" $ rend i ts+ "(" :ts -> cons "(" $ rend i ts+ t : "," :ts -> cons t $ space "," $ rend i ts+ t : ")" :ts -> cons t $ cons ")" $ rend i ts+ t : "]" :ts -> cons t $ cons "]" $ rend i ts+ t :ts -> space t $ rend i ts+ _ -> ""++ cons s t = s ++ t+ new i s = s+ space t s = if null s then t else t ++ " " ++ s++parenth :: [String] -> [String]+parenth ss = ["("] ++ ss ++ [")"]++-- the printer class does the job+class Print a where+ prt :: Int -> a -> [String]+ prtList :: [a] -> [String]+ prtList = concat . map (prt 0)++instance Print a => Print [a] where+ prt _ = prtList++instance Print Char where+ prt _ c = [show c] -- if isAlphaNum c then [[c]] else ['\\':[c]]+ prtList s = [show s] -- map (concat . prt 0) s++prPrec :: Int -> Int -> [String] -> [String]+prPrec i j = if j<i then parenth else id++instance Print Ident where+ prt _ (Ident i) = [i]++instance Print Reg where+ prt i e = case e of+ RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])+ RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])+ RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])+ RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])+ ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])+ REps -> prPrec i 3 (["\"\""]) -- special construct for eps in ocamllex?+ RChar c -> prPrec i 3 (concat [prt 0 c])+ RAlts str -> prPrec i 3 (concat [["["], [concatMap show str], ["]"]])+ RSeqs str -> prPrec i 2 (concat (map (prt 0) str))+ RDigit -> prPrec i 3 (concat [["d"]])+ RLetter -> prPrec i 3 (concat [["l"]])+ RUpper -> prPrec i 3 (concat [["c"]])+ RLower -> prPrec i 3 (concat [["s"]])+ RAny -> prPrec i 3 (concat [["u"]])
+ src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs view
@@ -0,0 +1,195 @@+{-+ BNF Converter: Pretty-printer generator+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-- based on BNFC Haskell backend++module BNFC.Backend.OCaml.CFtoOCamlPrinter (cf2Printer) where++import BNFC.CF+import BNFC.Utils+import BNFC.Backend.Haskell.CFtoTemplate+import Data.List (intersperse)+import Data.Char(toLower,isDigit)+import BNFC.Backend.OCaml.OCamlUtil++-- derive pretty-printer from a BNF grammar. AR 15/2/2002+cf2Printer :: String -> String -> CF -> String+cf2Printer name absMod cf = unlines [+ prologue name absMod,+ charRule cf,+ integerRule cf,+ doubleRule cf,+ stringRule cf,+ if hasIdent cf then identRule cf else "",+ unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],+ rules cf+ ]+++prologue :: String -> String -> String+prologue name absMod = unlines [+ "(* pretty-printer generated by the BNF converter *)\n",+ "open " ++ absMod,+ "open Printf",+ "",+ "(* We use string buffers for efficient string concatenation.",+ " A document takes a buffer and an indentation, has side effects on the buffer",+ " and returns a new indentation. The indentation argument indicates the level",+ " of indentation to be used if a new line has to be started (because of what is",+ " already in the buffer) *)",+ "type doc = Buffer.t -> int -> int",+ "",+ "let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ",+ " let buffer_init_size = 16 (* you may want to change this *)",+ " in let buffer = Buffer.create buffer_init_size",+ " in ",+ " let _ = printer 0 tree buffer 0 in (* discard return value *)",+ " Buffer.contents buffer",+ "",+ "let indent_width = 4",+ "",+ "let indent (i: int) : string = ",+ " let s = String.make (i+1) ' ' in",+ " String.set s 0 '\\n';",+ " s",+ "",+ "(* this render function is written for C-style languages, you may want to change it *)",+ "let render (s : string) : doc = fun buf i -> ",+ " (* invariant: last char of the buffer is never whitespace *)",+ " let n = Buffer.length buf in",+ " let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in",+ " let whitespace = match last with",+ " None -> \"\" ",+ " | Some '{' -> indent i",+ " | Some '}' -> (match s with",+ " \";\" -> \"\"",+ " | _ -> indent i)",+ " | Some ';' -> indent i",+ " | (Some '[') | (Some '(') -> \"\"",+ " | Some _ -> (match s with",+ " \",\" | \")\" | \"]\" -> \"\"",+ " | _ -> \" \") in",+ " let newindent = match s with",+ " \"{\" -> i + indent_width",+ " | \"}\" -> i - indent_width",+ " | _ -> i in",+ " Buffer.add_string buf whitespace;",+ " Buffer.add_string buf s;",+ " newindent",+ "",+ "let emptyDoc : doc = fun buf i -> i",+ "",+ "let concatD (ds : doc list) : doc = fun buf i -> ",+ " List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds",+ "",+ "let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]",+ "",+ "let prPrec (i:int) (j:int) (d:doc) : doc = if j<i then parenth d else d",+ ""+ ]++charRule cf = unlines [+ "let rec prtChar (_:int) (c:char) : doc = render (\"'\" ^ Char.escaped c ^ \"'\")",+ ifList cf (Cat "Char"),+ ""+ ]++integerRule cf = unlines [+ "let rec prtInt (_:int) (i:int) : doc = render (string_of_int i)",+ ifList cf (Cat "Integer"),+ ""+ ]++doubleRule cf = unlines [+ "let rec prtFloat (_:int) (f:float) : doc = render (sprintf \"%f\" f)",+ ifList cf (Cat "Double"),+ ""+ ]++stringRule cf = unlines [+ "let rec prtString (_:int) (s:string) : doc = render (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",+ ifList cf (Cat "String"),+ ""+ ]++identRule cf = ownPrintRule cf (Cat "Ident")++ownPrintRule cf own = unlines $ [+ "let rec" +++ prtFun own +++ "_ (" ++ show own ++ posn ++ ") : doc = render i",+ ifList cf own+ ]+ where+ posn = if isPositionCat cf own then " (_,i)" else " i"++-- copy and paste from CFtoTemplate++rules :: CF -> String+rules cf = unlines $ mutualDefs $+ map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf+ where+ toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)+ names [] _ = []+ names (x:xs) n+ | elem x xs = (x ++ show n) : names xs (n+1)+ | otherwise = x : names xs n+ var (ListCat c) = var c ++ "s"+ var (Cat "Ident") = "id"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var xs = map toLower (show xs)+ checkRes s+ | elem s reservedOCaml = s ++ "'"+ | otherwise = s+ ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)++--- case_fun :: Cat -> [(Constructor,Rule)] -> String+case_fun cat xs = unlines [+-- "instance Print" +++ cat +++ "where",+ prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with",+ unlines $ insertBar $ map (\ ((c,xx),r) ->+ " " ++ c +++ mkTuple xx +++ "->" ++++ "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs+ ]++ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where+ nil cat = [" [] -> " ++ mkRhs [] its |+ Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]+ one cat = [" | [x] -> " ++ mkRhs ["x"] its |+ Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]+ cons cat = [" | x::xs -> " ++ mkRhs ["x","xs"] its |+ Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]+ mkListRule [] = ""+ mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs+++mkRhs args its =+ "(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])"+ where+ mk args (Left InternalCat : items) = mk args items+ mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items+ mk args (Right s : items) = ("render " ++ show s) : mk args items+ mk _ _ = []+ prt c = prtFun c +++ show (precCat c)++prtFun :: Cat -> String+prtFun (ListCat c) = prtFun c ++ "ListBNFC"+prtFun c = "prt" ++ fixTypeUpper (normCat c)+
+ src/BNFC/Backend/OCaml/CFtoOCamlShow.hs view
@@ -0,0 +1,149 @@+{-+ BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...)+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-- there is no "deriving Show" in OCaml, although there are solutions based+-- on camlp4. Here we generate our own "show module".+++module BNFC.Backend.OCaml.CFtoOCamlShow (cf2show) where++import BNFC.CF+import BNFC.Utils+import BNFC.Backend.Haskell.CFtoTemplate+import Data.List (intersperse)+import Data.Char(toLower,isDigit)+import BNFC.Backend.OCaml.OCamlUtil++cf2show :: String -> String -> CF -> String+cf2show name absMod cf = unlines [+ prologue name absMod,+ integerRule cf,+ doubleRule cf,+ if hasIdent cf then identRule cf else "",+ unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],+ rules cf+ ]+++prologue :: String -> String -> String+prologue name absMod = unlines [+ "(* show functions generated by the BNF converter *)\n",+ "open " ++ absMod,+ "",+ "(* use string buffers for efficient string concatenations *)",+ "type showable = Buffer.t -> unit",+ "",+ "let show (s : showable) : string = ",+ " let init_size = 16 in (* you may want to adjust this *)",+ " let b = Buffer.create init_size in",+ " s b;",+ " Buffer.contents b",+ " ",+ "let emptyS : showable = fun buf -> ()",+ "",+ "let c2s (c:char) : showable = fun buf -> Buffer.add_char buf c",+ "let s2s (s:string) : showable = fun buf -> Buffer.add_string buf s",+ "",+ "let ( >> ) (s1 : showable) (s2 : showable) : showable = fun buf -> s1 buf; s2 buf",+ "",+ "let showChar (c:char) : showable = fun buf -> ",+ " Buffer.add_string buf (\"'\" ^ Char.escaped c ^ \"'\")",+ "",+ "let showString (s:string) : showable = fun buf -> ",+ " Buffer.add_string buf (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",+ "",+ "let showList (showFun : 'a -> showable) (xs : 'a list) : showable = fun buf -> ",+ " let rec f ys = match ys with",+ " [] -> ()",+ " | [y] -> showFun y buf",+ " | y::ys -> showFun y buf; Buffer.add_string buf \"; \"; f ys ",+ " in",+ " Buffer.add_char buf '[';",+ " f xs;",+ " Buffer.add_char buf ']'",+ ""+ ]++integerRule cf = "let showInt (i:int) : showable = s2s (string_of_int i)"++doubleRule cf = "let showFloat (f:float) : showable = s2s (string_of_float f)"+++identRule cf = ownPrintRule cf (Cat "Ident")++ownPrintRule cf own = unlines $ [+ "let rec" +++ showsFun own +++ "(" ++ show own ++ posn ++ ") : showable = s2s \""+ ++ show own ++ " \" >> showString i"+ ]+ where+ posn = if isPositionCat cf own then " (_,i)" else " i"++-- copy and paste from CFtoTemplate++rules :: CF -> String+rules cf = unlines $ mutualDefs $+ map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf -- ++ ifList cf s+ where+ toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)),+ ruleOf cons)+ names [] _ = []+ names (x:xs) n+ | elem x xs = (x ++ show n) : names xs (n+1)+ | otherwise = x : names xs n+ var (ListCat c) = var c ++ "s"+ var (Cat "Ident") = "id"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var cat = map toLower (show cat)+ checkRes s+ | elem s reservedOCaml = s ++ "'"+ | otherwise = s+ ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)++--- case_fun :: Cat -> [(Constructor,Rule)] -> String+case_fun cat xs = unlines [+-- "instance Print" +++ cat +++ "where",+ showsFun cat +++ "(e:" ++ fixType cat ++ ") : showable = match e with",+ unlines $ insertBar $ map (\ ((c,xx),r) ->+ " " ++ c +++ mkTuple xx +++ "->" ++++ "s2s" +++ show c ++++ case mkRhs xx (snd r) of {[] -> []; str -> ">> c2s ' ' >> " ++ str}+ )+ xs+ ]+++mkRhs args its =+ case unwords (intersperse " >> s2s \", \" >> " (mk args its)) of+ [] -> ""+ str -> "c2s '(' >> " ++ str ++ " >> c2s ')'"+ where+ mk args (Left InternalCat : items) = mk args items+ mk (arg:args) (Left c : items) = (showsFun c +++ arg) : mk args items+ mk args (Right s : items) = mk args items+ mk _ _ = []+ prt c = showsFun c +++ show (precCat c)++showsFun :: Cat -> String+showsFun c = case c of+ ListCat t -> "showList" +++ showsFun t+ _ -> "show" ++ (fixTypeUpper $ normCat c)+
+ src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs view
@@ -0,0 +1,73 @@+{-+ BNF Converter: Template Generator+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-- based on BNFC Haskell backend+++module BNFC.Backend.OCaml.CFtoOCamlTemplate (+ cf2Template+ ) where++import BNFC.CF+import Data.Char+import Data.List (delete)+import BNFC.Utils((+++))+import BNFC.Backend.OCaml.OCamlUtil+++type ModuleName = String+type Constructor = String++cf2Template :: ModuleName -> ModuleName -> CF -> String+cf2Template skelName absName cf = unlines+ [+ "module "++ skelName ++ " = struct\n",+ "(* OCaml module generated by the BNF converter *)\n",+ "open " ++ absName ++ "\n",+ "type result = string\n",+ "let failure x = failwith \"Undefined case.\" (* x discarded *)\n",+ unlines $ mutualDefs $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf,+ "end"+ ]+ where toArgs [] = []+ toArgs ((cons,args):xs)+ = (cons ++ " " ++ (mkTuple $ names (map (checkRes . var) args) (0 :: Int))) : toArgs xs+ names :: [String] -> Int -> [String]+ names [] _ = []+ names (x:xs) n+ | elem x xs = (x ++ show n) : names xs (n+1)+ | otherwise = x : names xs n+ var (ListCat c) = var c ++ "s"+ var (Cat "Ident") = "id"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var cat = map toLower (show cat)+ checkRes s+ | elem s reservedOCaml = s ++ "'"+ | otherwise = s+++case_fun :: Cat -> [Constructor] -> String+case_fun cat xs =+ unlines $+ ["trans" ++ show cat ++ " (x : " ++ fixType cat ++ ") : result = match x with",+ unlines $ insertBar $ map (\s -> s ++ " -> " ++ "failure x") xs]+
+ src/BNFC/Backend/OCaml/CFtoOCamlTest.hs view
@@ -0,0 +1,70 @@+{-+ BNF Converter: Generate main/test module for OCaml+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.OCaml.CFtoOCamlTest where++import BNFC.CF+import BNFC.Utils+import BNFC.Backend.OCaml.OCamlUtil++ocamlTestfile :: String -> String -> String -> String -> String -> CF -> String+ocamlTestfile absM lexM parM printM showM cf =+ let+ lexerName = lexM ++ ".token"+ parserName = parM ++ ".p" ++ topTypeC+ printerName = printM ++ ".printTree " ++ printM ++ ".prt" ++ topTypeC+ showFun = "(fun x -> " ++ showM ++ ".show (" ++ showM ++ ".show" +++ topTypeC ++ " x))"+ topTypeC = fixTypeUpper (firstEntry cf)+ topType = absM ++ "." ++ fixType (firstEntry cf)+ in unlines [+ "(* automatically generated by the BNF Converter *)",+ "",+ "open Lexing",+ "",+ "let parse (c : in_channel) : " ++ topType ++ " = ",+ " " ++ parserName +++ lexerName +++ "(Lexing.from_channel c)",+ ";;",+ "",+ "let showTree (t : " ++ topType ++ ") : string = ",+ " \"[Abstract syntax]\\n\\n\" ^ " ++ showFun +++ "t" ++ " ^ \"\\n\\n\" ^",+ " \"[Linearized tree]\\n\\n\" ^ " ++ printerName +++ "t" ++ " ^ \"\\n\"",+ ";;",+ "",+ "let main () =",+ " let channel =",+ " if Array.length Sys.argv > 1 then",+ " open_in Sys.argv.(1)",+ " else",+ " stdin",+ " in",+ " try",+ " print_string (showTree (parse channel));",+ " flush stdout",+ " with BNFC_Util.Parse_error (start_pos, end_pos) ->", -- " ++ parM ++ ".+ " Printf.printf \"Parse error at %d.%d-%d.%d\\n\"",+ " start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)",+ " end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);",+ ";;",+ "",+ "main ();;",+ ""+ ]++
+ src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs view
@@ -0,0 +1,234 @@+{-+ BNF Converter: ocamlyacc Generator+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++-- based on BNFC Haskell backend+++module BNFC.Backend.OCaml.CFtoOCamlYacc+ (+ cf2ocamlyacc, terminal+ )+ where++import BNFC.CF+import Data.List (intersperse,nub)+import Data.Char++import BNFC.Utils ((+++))+import BNFC.Backend.OCaml.OCamlUtil++-- Type declarations++type Rules = [(NonTerminal,[(Pattern,Action)])]+type Pattern = String+type Action = String+type MetaVar = String++-- default naming+++tokenName = "Token"++++-- The main function, that given a CF+-- generates a ocamlyacc module.+cf2ocamlyacc :: String -> String -> String -> CF -> String+cf2ocamlyacc name absName lexName cf+ = unlines+ [header name absName lexName,+ declarations absName cf,+ "%%",+ rules cf+ ]+++header :: String -> String -> String -> String+header modName absName lexName = unlines+ ["/* This ocamlyacc file was machine-generated by the BNF converter */",+ "%{",+ "open " ++ absName,+ "open Lexing",+ "%}"+ ]+++declarations :: String -> CF -> String+declarations absName cf = unlines+ [tokens (symbols cf) (reservedWords cf),+ specialTokens cf,+ entryPoints absName cf+ ]++tokens :: [String] -> [String] -> String+tokens symbols reswords = unlines+ [+ if (length reswords) > 0+ then "%token" +++ concat (intersperse " " (map ("TOK_" ++) reswords))+ else ""+ ,+ concatMap (\(s,n) -> "\n%token SYMB" ++ (show n) +++ "/*" +++ s +++ "*/")+ (zip symbols [1..])+ ]++-- | map a CF terminal into a ocamlyacc token+terminal :: CF -> String -> String+terminal cf s | s `elem` reservedWords cf = "TOK_" ++ s+terminal cf s = case lookup s (zip (symbols cf) [1..]) of+ Just i -> "SYMB" ++ show i+ Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF."+++-- | map a CF nonterminal into a ocamlyacc symbol+nonterminal :: Cat -> String+nonterminal c = map spaceToUnderscore (fixType c)+ where spaceToUnderscore ' ' = '_'+ spaceToUnderscore x = x++specialTokens :: CF -> String+specialTokens cf = unlines ("%token TOK_EOF" : map aux (nub $ ["Ident","String","Integer","Double","Char"] ++ map show (literals cf)))+ where aux cat = "%token" +++ (case cat of+ "Ident" -> "<string>"+ "String" -> "<string>"+ "Integer" -> "<int>"+ "Double" -> "<float>"+ "Char" -> "<char>"+ own -> "<string>" )+ +++ "TOK_" ++ cat+++entryPoints :: String -> CF -> String+entryPoints absName cf = unlines $+ ("%start" ++++ concat (intersperse " " (map epName eps)))+ :+ (map typing eps)+ where eps = (nub $ map normCat (allEntryPoints cf))+ typing :: Cat -> String+ typing c = "%type" +++ "<" ++ qualify c ++ ">" +++ epName c+ qualify c = if c `elem` [ Cat "Integer", Cat "Double", Cat "Char",+ Cat "String", ListCat (Cat "Integer"),+ ListCat (Cat "Double"),+ ListCat (Cat "Char"),+ ListCat (Cat "String") ]+ then fixType c+ else absName ++ "." ++ fixType c++epName :: Cat -> String+epName c = "p" ++ capitalize (nonterminal c)+ where capitalize s = case s of+ [] -> []+ c:cs -> toUpper c : cs++entryPointRules :: CF -> String+entryPointRules cf = unlines $ map mkRule (nub $ map normCat (allEntryPoints cf))+ where+ mkRule :: Cat -> String+ mkRule s = unlines [+ epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }",+ " | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };"+ ]++rules :: CF -> String+rules cf = unlines [+ entryPointRules cf,+ (unlines $ map (prOne . mkOne) (ruleGroups cf)),+ specialRules cf+ ]+ where+ mkOne (cat,rules) = constructRule cf rules cat+ prOne (nt,[]) = [] -- nt has only internal use+ prOne (nt,((p,a):ls)) =+ unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n"+ where+ nt' = nonterminal nt+ pr [] = []+ pr ((p,a):ls) =+ unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls++++-- For every non-terminal, we construct a set of rules. A rule is a sequence of+-- terminals and non-terminals, and an action to be performed+-- As an optimization, a pair of list rules [C] ::= "" | C k [C]+-- is left-recursivized into [C] ::= "" | [C] C k.+-- This could be generalized to cover other forms of list rules.+constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule cf rules nt = (nt,[(p,generateAction nt (funRule r) (mkFlip b m)) |+ r0 <- rules,+ let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs+ then (True,revSepListRule r0)+ else (False,r0),+ let (p,m) = generatePatterns cf r])+ where+ revs = reversibleCats cf+ mkFlip doit xs = case xs of+ a:b:rest | doit -> b:a:rest+ _ -> xs++++-- Generates a string containing the semantic action.+-- An action can for example be: Sum $1 $2, that is, construct an AST+-- with the constructor Sum applied to the two metavariables $1 and $2.+generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action+generateAction nt f ms = (if isCoercion f then "" else f') +++ mkTuple ms+ where f' = case f of -- ocaml cons is somehow not a standard infix oper, right?+ "(:[])" -> "(fun x -> [x])"+ "(:)" -> "(fun (x,xs) -> x::xs)"+ _ -> f+++generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])+generatePatterns cf r = case rhsRule r of+ [] -> ("/* empty */",[])+ its -> (unwords (map mkIt its), metas its)+ where+ mkIt i = case i of+ Left c -> nonterminal c+ Right s -> terminal cf s+ metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]+ revIf c m = if (not (isConsFun (funRule r)) && elem c revs)+ then ("(List.rev " ++ m ++ ")")+ else m -- no reversal in the left-recursive Cons rule itself+ revs = reversibleCats cf++++++specialRules :: CF -> String+specialRules cf = unlines $+ map aux (literals cf)+ where+ aux cat =+ case cat of+ Cat "Ident" -> "ident : TOK_Ident { Ident $1 };"+ Cat "String" -> "string : TOK_String { $1 };"+ Cat "Integer" -> "int : TOK_Integer { $1 };"+ Cat "Double" -> "float : TOK_Double { $1 };"+ Cat "Char" -> "char : TOK_Char { $1 };"+ own -> (fixType own) ++ " : TOK_" ++ show own +++ " { " ++ show own ++ " ("++ posn ++ "$1)};"+ -- PCC: take "own" as type name? (manual says newtype)+ where -- ignore position categories for now+ posn = "" -- if isPositionCat cf cat then "mkPosToken " else ""+++
+ src/BNFC/Backend/OCaml/OCamlUtil.hs view
@@ -0,0 +1,69 @@+{-+ BNF Converter: OCaml backend utility module+ Copyright (C) 2005 Author: Kristofer Johannisson++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.OCaml.OCamlUtil where++import BNFC.CF+import BNFC.Utils+import Data.Char (toLower, toUpper)++-- Translate Haskell types to OCaml types+-- Note: OCaml (data-)types start with lowercase letter+fixType :: Cat -> String+fixType (ListCat c) = fixType c +++ "list"+fixType (Cat "Integer") = "int"+fixType (Cat "Double") = "float"+fixType cat = let c:cs = show cat in+ let ls = toLower c : cs in+ if (elem ls reservedOCaml) then (ls ++ "T") else ls++-- as fixType, but leave first character in upper case+fixTypeUpper :: Cat -> String+fixTypeUpper c = case fixType c of+ [] -> []+ c:cs -> toUpper c : cs+++reservedOCaml :: [String]+reservedOCaml = [+ "and","as","assert","asr","begin","class",+ "constraint","do","done","downto","else","end",+ "exception","external","false","for","fun","function",+ "functor","if","in","include","inherit","initializer",+ "land","lazy","let","list","lor","lsl","lsr",+ "lxor","match","method","mod","module","mutable",+ "new","object","of","open","or","private",+ "rec","sig","struct","then","to","true",+ "try","type","val","virtual","when","while","with"]++mkTuple :: [String] -> String+mkTuple [] = ""+mkTuple [x] = x+mkTuple (x:xs) = "(" ++ foldl (\acc e -> acc ++ "," +++ e) x xs ++ ")"++insertBar :: [String] -> [String]+insertBar [] = []+insertBar [x] = [" " ++ x]+insertBar (x:xs) = (" " ++ x ) : map (" | " ++) xs++mutualDefs :: [String] -> [String]+mutualDefs defs = case defs of+ [] -> []+ [d] -> ["let rec" +++ d]+ d:ds -> ("let rec" +++ d) : map ("and" +++) ds
+ src/BNFC/Backend/Txt2Tag.hs view
@@ -0,0 +1,249 @@+{-+ BNF Converter: Latex Generator+ Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.Txt2Tag (cfToTxt)where++import BNFC.CF+import AbsBNF (Reg (..))+import BNFC.Utils+import Data.List (nub,intersperse)++cfToTxt :: String -> CF -> String+cfToTxt name cf = unlines [+ beginDocument name,+ introduction,+ prtTerminals name cf,+ prtBNF name cf+ ]++introduction :: String+introduction = concat+ [+ "\nThis document was automatically generated by ",+ "the //BNF-Converter//.",+ " It was generated together with the lexer, the parser, and the",+ " abstract syntax module, which guarantees that the document",+ " matches with the implementation of the language (provided no",+ " hand-hacking has taken place).\n"+ ]++prtTerminals :: String -> CF -> String+prtTerminals name cf = unlines [+ "==The lexical structure of " ++ name ++ "==",+ identSection cf,+ "===Literals===",+ prtLiterals name cf,+ unlines (map prtOwnToken (tokenPragmas cf)),+ "===Reserved words and symbols===",+ prtReserved name cf,+ prtSymb name cf,+ "===Comments===",+ prtComments $ comments cf+ ]++identSection cf = if not (hasIdent cf) then [] else+ unlines [+ "===Identifiers===",+ prtIdentifiers+ ]++prtIdentifiers :: String+prtIdentifiers = unlines+ [+ "Identifiers //Ident// are unquoted strings beginning with a letter,",+ "followed by any combination of letters, digits, and the characters ``_ '``",+ "reserved words excluded."+ ]++prtLiterals :: String -> CF -> String+prtLiterals name cf =+ unlines $ map stringLit $+ filter (`notElem` [Cat "Ident"]) $+ literals cf++stringLit :: Cat -> String+stringLit cat = unlines $ case (show cat) of+ "Char" -> ["Character literals //Char// have the form",+ "``'``//c//``'``, where //c// is any single character.",+ ""+ ]+ "String" -> ["String literals //String// have the form",+ "``\"``//x//``\"``}, where //x// is any sequence of any characters",+ "except ``\"`` unless preceded by ``\\``.",+ ""]+ "Integer" -> ["Integer literals //Integer// are nonempty sequences of digits.",+ ""]+ "Double" -> ["Double-precision float literals //Double// have the structure",+ "indicated by the regular expression" ++++ "``digit+ '.' digit+ ('e' ('-')? digit+)?`` i.e.\\",+ "two sequences of digits separated by a decimal point, optionally",+ "followed by an unsigned or negative exponent.",+ ""]+ _ -> []++prtOwnToken (name,reg) = unlines+ [show name +++ "literals are recognized by the regular expression",+ "```" +++ latexRegExp reg +++ "```"+ ]++prtComments :: ([(String,String)],[String]) -> String+prtComments (xs,ys) = concat+ [+ if (null ys) then+ "There are no single-line comments in the grammar."+ else+ "Single-line comments begin with " ++ sing ++".",+ if (null xs) then+ "There are no multiple-line comments in the grammar."+ else+ "Multiple-line comments are enclosed with " ++ mult ++"."+ ]+ where+ sing = concat $ intersperse ", " $ map (symbol.prt) ys+ mult = concat $ intersperse ", " $+ map (\(x,y) -> (symbol (prt x))+ ++ " and " +++ (symbol (prt y))) xs++prtSymb :: String -> CF -> String+prtSymb name cf = case symbols cf of+ [] -> "\nThere are no symbols in " ++ name ++ ".\n"+ xs -> "The symbols used in " ++ name ++ " are the following:\n"+ +++ (tabular 4 $ three $ map (symbol.prt) xs)++prtReserved :: String -> CF -> String+prtReserved name cf = case reservedWords cf of+ [] -> stringRes name +++ "\nThere are no reserved words in " ++ name ++ ".\n"+ xs -> stringRes name +++ (tabular 4 $ three $ map quote xs)++stringRes :: String -> String+stringRes name = concat+ ["The set of reserved words is the set of terminals ",+ "appearing in the grammar. Those reserved words ",+ "that consist of non-letter characters are called symbols, and ",+ "they are treated in a different way from those that ",+ "are similar to identifiers. The lexer ",+ "follows rules familiar from languages ",+ "like Haskell, C, and Java, including longest match ",+ "and spacing conventions.",+ "\n\n",+ "The reserved words used in " ++ name ++ " are the following:\n"]++three :: [String] -> [[String]]+three [] = []+three [x] = [[x,[],[],[]]]+three [x,y] = [[x,y,[],[]]]+three [x,y,z] = [[x,y,z,[]]]+three (x:y:z:u:xs) = [x,y,z,u] : three xs++prtBNF :: String -> CF -> String+prtBNF name cf = unlines [+ "==The syntactic structure of " ++ name ++"==",+ "Non-terminals are enclosed between < and >. ",+ "The symbols " ++ arrow ++ " (production), " +++ delimiter ++" (union) ",+ "and " ++ empty ++ " (empty rule) belong to the BNF notation. ",+ "All other symbols are terminals.",+ "",+ prtRules (ruleGroups cf)+ ]++prtRules :: [(Cat,[Rule])] -> String+prtRules [] = []+prtRules ((c,[]):xs)+ = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs+prtRules ((c,(r:rs)):xs)+ = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] +++ [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) +++ --- "\n\n" ++ --- with empty lines good for latex, bad for html+ prtRules xs++prtSymbols :: [Either Cat String] -> String+prtSymbols [] = empty+prtSymbols xs = foldr (+++) [] (map p xs)+ where p (Left r) = nonterminal r+ p (Right r) = terminal r++prt :: String -> String+prt s = s++reserved :: String -> String+reserved s = "{\\reserved{" ++ s ++ "}}"++literal :: String -> String+literal s = "{\\literal{" ++ s ++ "}}"++empty :: String+empty = "**eps**"++symbol :: String -> String+symbol s = s++tabular :: Int -> [[String]] -> String+tabular n xs = unlines [unwords (intersperse "|" (" " : x)) | x <- xs]++terminal :: String -> String+terminal s = "``" ++ s ++ "``"++nonterminal :: Cat -> String+nonterminal s = "//" ++ show s ++ "//"++arrow :: String+arrow = "->"++delimiter :: String+delimiter = " **|** "++beginDocument :: String -> String+beginDocument name = unlines [+ "The Language " ++ name,+ "BNF Converter",+ "",+ "",+ "%This txt2tags file is machine-generated by the BNF-converter",+ "%Process by txt2tags to generate html or latex",+ ""+ ]++latexRegExp :: Reg -> String+latexRegExp = quote . rex (0 :: Int) where+ rex i e = case e of+ RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg+ RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "|" +++ rex 1 reg+ RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg+ RStar reg -> rex 3 reg ++ "*"+ RPlus reg -> rex 3 reg ++ "+"+ ROpt reg -> rex 3 reg ++ "?"+ REps -> "eps"+ RChar c -> "'" ++ [c] ++ "'"+ RAlts str -> "[\"" ++ str ++ "\"]"+ RSeqs str -> "{\"" ++ str ++ "\"}"+ RDigit -> "digit"+ RLetter -> "letter"+ RUpper -> "upper"+ RLower -> "lower"+ RAny -> "char"+ ifPar i j s = if i > j then "(" ++ s ++ ")" else s++quote s = "``" ++ s ++ "``"
+ src/BNFC/Backend/XML.hs view
@@ -0,0 +1,232 @@+{-+ BNF Converter: XML generator+ Copyright (C) 2004 Author: Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Backend.XML ---- (cf2DTD, cf2XML)+ where++import BNFC.CF+import BNFC.Utils+import BNFC.Backend.Base+import BNFC.Options hiding (Backend)+import BNFC.Backend.Haskell.CFtoTemplate ()+import BNFC.Backend.Haskell.HsOpts (xmlFile, xmlFileM, absFileM)+import Data.List (intersperse, nub, intercalate)+import Data.Char(toLower)++type Coding = Bool ---- change to at least three values++makeXML :: SharedOptions -> Coding -> CF -> Backend+makeXML opts typ cf = do+ let name = lang opts+ mkfile (name ++ ".dtd") $ cf2DTD typ name cf+ let absmod = "XML" ++ name+ mkfile (xmlFile opts) $ cf2XMLPrinter typ opts absmod cf++-- derive a DTD from a BNF grammar. AR 21/8/2004+cf2DTD :: Coding -> String -> CF -> String+cf2DTD typ name cf = unlines [+ tag ("?xml version=\"1.0\" standalone=\"yes\"?"),+ "<!DOCTYPE " ++ name ++ " [",+ elemEmp "Integer",+ elemEmp "Double",+ elemEmp "String",+ if hasIdent cf then elemEmp "Ident" else "",+ unlines [elemEmp own | own <- tokenNames cf],+ unlines (map (elemData typ cf) (cf2data cf)),+ "]>"+ ]++-- | >>> tag "test"+-- "<test>"+tag :: String -> String+tag s = "<" ++ s ++ ">"++element :: String -> [String] -> String+element t ts =+ tag ("!ELEMENT " ++ t ++ " " ++ alts ts)++attlist t a =+ tag ("!ATTLIST " ++ t ++ " " ++ a ++ " CDATA #REQUIRED")+elemAtt t a ts = element t ts ++++ attlist t a+elemt t = elemAtt t "name"++elemc :: Cat -> [(Fun, String)] -> String+elemc cat fs = unlines $ element (show cat) (map snd fs) : [element f [] | (f,_) <- fs]++elemEmp :: String -> String+elemEmp t = elemAtt t "value" []++alts :: [String] -> String+alts ts =+ if null ts then "EMPTY" else parenth (unwords (intersperse "|" ts))+++-- choose between these two encodings:++elemData b = if b then elemDataConstr else elemDataNotyp+efunDef b = if b then efunDefConstr else efunDefNotyp+endtagDef b = if b then endtagDefConstr else endtagDefNotyp++-- coding 0: ---- not finished+-- to show both types and constructors as tags;+-- lengthy, but validation guarantees type correctness+-- flag -xmlt+elemDataConstrs cf (cat,fcs) = elemc cat ([(f,rhsCat cf f cs) | (f,cs) <- fcs])+efunDefConstrs = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"+endtagDefConstrs = "endtag f c = tag (\"/\" ++ c)"++-- coding 1:+-- to show constructors as empty tags;+-- shorter than 0, but validation still guarantees type correctness+-- flag -xmlt+elemDataConstr cf (cat,fcs) = elemc cat ([(f,rhsCat cf f cs) | (f,cs) <- fcs])+efunDefConstr = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"+endtagDefConstr = "endtag f c = tag (\"/\" ++ c)"++-- coding 2:+-- constructors as tags, no types.+-- clumsy DTD, but nice trees. Validation guarantees type correctness+-- flag -xml+elemDataNotyp cf (cat,fcs) = unlines [element f [rhsCatNot cf cs] | (f,cs) <- fcs]+efunDefNotyp = "elemFun i t x = [replicate (i+i) ' ' ++ tag x]"+endtagDefNotyp = "endtag f c = tag (\"/\" ++ f)"+++-- to show constructors as attributes;+-- nice, but validation does not guarantee type correctness.+-- Therefore rejected.+-- elemDataAttr cf (cat,fcs) = elemt cat (nub [rhsCat cf cs | (_,cs) <- fcs])+-- efunDefAttr = "elemFun i t x = [replicate (i+i) ' ' ++ tag (t ++ \" name = \" ++ x)]"++rhsCat :: CF -> Fun -> [Cat] -> String+rhsCat cf fun cs = parenth (intercalate ", " (fun:map (symbCat cf) cs))+rhsCatNot cf cs = if null cs then "EMPTY" else concat (intersperse ", " (map (symbCatNot cf) cs))++symbCat cf c+ | isList c = show (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+"+ | otherwise = show c++symbCatNot cf c+ | isList c = funs (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+"+ | otherwise = funs c+ where+ funs k = case lookup k (cf2data cf) of+ Just [] -> "EMPTY"+ Just fcs -> parenth $ unwords $ intersperse "|" $ map fst fcs+ _ -> parenth (show k) ----++parenth s = "(" ++ s ++ ")"++-- derive an XML printer from a BNF grammar+cf2XMLPrinter :: Bool -> SharedOptions -> String -> CF -> String+cf2XMLPrinter typ opts absMod cf = unlines [+ prologue typ opts absMod,+ integerRule cf,+ doubleRule cf,+ stringRule cf,+ if hasIdent cf then identRule cf else "",+ unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],+ rules cf+ ]+++prologue :: Bool -> SharedOptions -> String -> String+prologue b opts absMod = unlines [+ "module " ++ xmlFileM opts +++ "where\n",+ "-- pretty-printer generated by the BNF converter\n",+ "import " ++ absFileM opts,+ "import Data.Char",+ "",+ "-- the top-level printing method",+ "printXML :: XPrint a => a -> String",+ "printXML = render . prt 0",+ "",+ "render = unlines",+ "",+ "-- the printer class does the job",+ "class XPrint a where",+ " prt :: Int -> a -> [String]",+ " prtList :: Int -> [a] -> [String]",+ " prtList i = concat . map (prt i)",+ "",+ "instance XPrint a => XPrint [a] where",+ " prt = prtList",+ "",+ "tag t = \"<\" ++ t ++ \">\"",+ "etag t = \"<\" ++ t ++ \"/>\"",+ "elemTok i t x = [replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ show x ++ \" /\")]",+ "elemTokS i t x = elemTok i t (show x)",+ efunDef b,+ endtagDef b,+ ""+ ]++integerRule cf = showsPrintRule cf "Integer"+doubleRule cf = showsPrintRule cf "Double"+stringRule cf = showsPrintRule cf "Char" ++++ " prtList i xs = elemTok i \"String\" xs"++showsPrintRule cf t = unlines $ [+ "instance XPrint " ++ t ++ " where",+ " prt i x = elemTokS i" +++ "\"" ++ t ++ "\"" +++ "x"+ ]++identRule cf = ownPrintRule cf (Cat "Ident")++ownPrintRule cf cat = unlines $ [+ "instance XPrint " ++ show cat ++ " where",+ " prt i (" ++ show cat ++ posn ++ ") = elemTok i" +++ "\"" ++ show cat ++ "\"" +++ "x"+ ]+ where+ posn = if isPositionCat cf cat then " (_,x)" else " x"++rules :: CF -> String+rules cf = unlines $+ map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf+ where+ toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)+ names [] _ = []+ names (x:xs) n+ | elem x xs = (x ++ show n) : names xs (n+1)+ | otherwise = x : names xs n+ var (ListCat c) = var c ++ "s"+ var (Cat "Ident") = "id"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var cat = map toLower (show cat)+ checkRes s+ | elem s reservedHaskell = s ++ "'"+ | otherwise = s+ reservedHaskell = ["case","class","data","default","deriving","do","else","if",+ "import","in","infix","infixl","infixr","instance","let","module",+ "newtype","of","then","type","where","as","qualified","hiding"]+ ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)++--- case_fun :: Cat -> [(Constructor,Rule)] -> String+case_fun cat xs = unlines [+ "instance XPrint" +++ show cat +++ "where",+ " prt i" +++ "e = case e of",+ unlines $ map (\ ((c,xx),r) ->+ " " ++ c +++ unwords xx +++ "-> concat $ " ++++ "elemFun i \"" ++ show cat ++ "\" \"" ++ c ++ "\"" ++++ unwords [": prt (i+1)" +++ x | x <- xx] +++ ":" ++++ "[[replicate (i+i) ' ' ++ endtag \"" ++ c ++ "\" \"" ++ show cat ++ "\"]]"+ ) xs+ ]
+ src/BNFC/CF.hs view
@@ -0,0 +1,683 @@+{-# LANGUAGE PatternGuards, DeriveFunctor #-}+{-+ BNF Converter: Abstract syntax+ Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.CF (+ -- Types.+ CF,+ CFG(..), pragmasOfCF, -- ...+ Rule, Rul(..), lookupRule,+ Pragma(..),+ Exp(..),+ Literal,+ Symbol,+ KeyWord,+ Cat(..), strToCat,+ catString, catInteger, catDouble, catChar, catIdent,+ NonTerminal,+ Fun,+ Tree(..),+ prTree, -- print an abstract syntax tree+ Data, -- describes the abstract syntax of a grammar+ cf2data, -- translates a grammar to a Data object.+ cf2dataLists, -- translates to a Data with List categories included.+ -- Literal categories, constants,+ firstCat, -- the first value category in the grammar.+ firstEntry, -- the first entry or the first value category+ specialCats, -- ident+ specialCatsP, -- all literals+ specialData, -- special data+ isCoercion, -- wildcards in grammar (avoid syntactic clutter)+ isDefinedRule, -- defined rules (allows syntactic sugar)+ isProperLabel, -- not coercion or defined rule+ allCats, -- all categories of a grammar+ allCatsNorm,+ allCatsIdNorm,+ allEntryPoints,+ reservedWords,+ cfTokens,+ symbols,+ literals,+ reversibleCats,+ findAllReversibleCats, -- find all reversible categories+ identCat, -- transforms '[C]' to ListC (others, unchanged).+ isParsable,+ rulesOfCF, -- All rules of a grammar.+ rulesForCat, -- rules for a given category+ ruleGroups, -- Categories are grouped with their rules.+ ruleGroupsInternals, --As above, but includes internal cats.+ notUniqueNames, -- list of not unique names (replaces the following 2)+-- notUniqueFuns, -- Returns a list of function labels that are not unique.+-- badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence.+ isList, -- Checks if a category is a list category.+ -- Information functions for list functions.+ isNilFun, -- empty list function? ([])+ isOneFun, -- one element list function? (:[])+ hasOneFunc,+ getCons,+ isConsFun, -- constructor function? (:)+ isNilCons, -- either three of above?+ isEmptyListCat, -- checks if the list permits []+ revSepListRule, -- reverse a rule, if it is of form C t [C].+ normCat,+ isDataCat,+ normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C+ catOfList,+ comments, -- translates the pragmas into two list containing the s./m. comments+ tokenPragmas, -- get the user-defined regular expression tokens+ tokenNames, -- get the names of all user-defined tokens+ precCat, -- get the precendence level of a Cat C1 => 1, C => 0+ precLevels, -- get all precendence levels in the grammar, sorted in increasing order.+ precRule, -- get the precendence level of the value category of a rule.+ precCF, -- Check if the CF consists of precendence levels.+ isUsedCat,+ isPositionCat,+ hasIdent,+ hasLayout,+ layoutPragmas,+ normFun,++ CFP, -- CF with profiles+ RuleP,+ FunP,+ Prof,+ cf2cfpRule,+ cf2cfp,+ cfp2cf,+ trivialProf,+ rulesOfCFP,+ funRuleP, ruleGroupsP, allCatsP, allEntryPointsP+ ) where++import BNFC.Utils (prParenth,(+++))+import Data.List (nub, intersperse, partition, sort, group, intercalate, find)+import Data.Char+import AbsBNF (Reg())+import ParBNF (pCat)+import LexBNF (tokens)+import qualified AbsBNF+import ErrM++-- | A context free grammar consists of a set of rules and some extended+-- information (e.g. pragmas, literals, symbols, keywords)+type CF = CFG Fun++-- | A rule consists of a function name, a main category and a sequence of+-- terminals and non-terminals.+-- function_name . Main_Cat ::= sequence+type Rule = Rul Fun++-- | Polymorphic rule type for common type signatures for CF and CFP+data Rul function = Rule { funRule :: function+ -- ^ The function (semantic action) of a+ -- rule. In order to be able to generate+ -- data types this must be a constructor+ -- (or an identity function).+ , valCat :: Cat -- ^ The value category+ , rhsRule :: [Either Cat String]+ -- ^ The list of Terminals/NonTerminals in+ -- the right-hand-side of a rule.+ }+ deriving (Eq,Functor)++instance (Show function) => Show (Rul function) where+ show (Rule f cat rhs) =+ unwords (show f : "." : show cat : "::=" : map (either show id) rhs)++-- | Polymorphic CFG type for common type signatures for CF and CFP+newtype CFG function = CFG { unCFG :: (Exts,[Rul function]) }+ deriving (Functor)+++instance (Show function) => Show (CFG function) where+ show (CFG (_,rules)) = unlines $ map show rules++type Exts = ([Pragma],Info)++-- | Info is information extracted from the CF, for easy access.+-- Literals - Char, String, Ident, Integer, Double+-- Strings are quoted strings, and Ident are unquoted.+-- Symbols - symbols in the grammar, e.g. “*”, '->'.+-- KeyWord - reserved words, e.g. 'if' 'while'+type Info = ([Literal],[Symbol],[KeyWord],[Cat])++-- Expressions for function definitions+data Exp = App String [Exp]+ | LitInt Integer+ | LitDouble Double+ | LitChar Char+ | LitString String+ deriving (Eq)++instance Show Exp where+ showsPrec p e =+ case listView e of+ Right es ->+ showString "["+ . foldr (.) id (intersperse (showString ", ") $ map shows es)+ . showString "]"+ Left (App x []) -> showString x+ Left (App "(:)" [e1,e2]) ->+ showParen (p>0)+ $ showsPrec 1 e1+ . showString " : "+ . shows e2+ Left (App x es) ->+ showParen (p>1)+ $ foldr (.) id+ $ intersperse (showString " ")+ $ showString x : map (showsPrec 2) es+ Left (LitInt n) -> shows n+ Left (LitDouble x) -> shows x+ Left (LitChar c) -> shows c+ Left (LitString s) -> shows s+ where+ listView (App "[]" []) = Right []+ listView (App "(:)" [e1,e2])+ | Right es <- listView e2 = Right $ e1:es+ listView e = Left e++-- | Pragmas+data Pragma = CommentS String -- ^ for single line comments+ | CommentM (String,String) -- ^ for multiple-line comments.+ | TokenReg String Bool Reg -- ^ for tokens+ | EntryPoints [Cat]+ | Layout [String]+ | LayoutStop [String]+ | LayoutTop+ | FunDef String [String] Exp+ -- ...+ deriving (Show)++-- | User-defined regular expression tokens+tokenPragmas :: CFG f -> [(Cat,Reg)]+tokenPragmas cf = [(Cat name,exp) | TokenReg name _ exp <- pragmasOfCF cf]++-- | The names of all user-defined tokens+tokenNames :: CFG f -> [String]+tokenNames cf = map (show.fst) (tokenPragmas cf)++layoutPragmas :: CF -> (Bool,[String],[String])+layoutPragmas cf = let ps = pragmasOfCF cf in (+ not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level+ concat [ss | Layout ss <- ps], -- layout-block starting words+ concat [ss | LayoutStop ss <- ps] -- layout-block ending words+ )++hasLayout :: CF -> Bool+hasLayout cf = case layoutPragmas cf of+ (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only++-- | Literal: Char, String, Ident, Integer, Double+type Literal = Cat+type Symbol = String+type KeyWord = String++-- | Categories are the Non-terminals of the grammar.+data Cat = InternalCat -- | Internal category, inserted in 1st+ -- position in "internal" rules,+ -- essentially ensuring that they are+ -- never parsed.+ | Cat String+ | ListCat Cat+ | CoercCat String Integer+ deriving (Eq, Ord)+-- An alias for Cat used in many backends:+type NonTerminal = Cat++-- | Show instance for category symbols+-- >>> show (Cat "Def")+-- "Def"+-- >>> show (ListCat (Cat "Thing"))+-- "[Thing]"+-- >>> show (CoercCat "Expr" 3)+-- "Expr3"+-- >>> show (ListCat (CoercCat "Expr" 2))+-- "[Expr2]"+instance Show Cat where+ show InternalCat = "#"+ show (Cat s) = s+ show (ListCat c) = "[" ++ show c ++ "]"+ show (CoercCat s i) = s ++ show i++-- | Reads a string into a category. This should only needs to handle+-- the case of simple categories (with or without coercion) since list+-- categories are parsed in the grammar already. To be on the safe side here,+-- we still call the parser function that parses categries.+-- >>> strToCat "Abc" == Cat "Abc"+-- True+-- >>> strToCat "Abc123" == CoercCat "Abc" 123+-- True+-- >>> strToCat "[Expr2]" == ListCat (CoercCat "Expr" 2)+-- True+strToCat :: String -> Cat+strToCat "#" = InternalCat+strToCat s =+ case pCat (tokens s) of+ Ok c -> cat2cat c+ Bad e -> Cat s -- error $ "Error parsing cat " ++ s ++ " (" ++ e ++ ")"+ -- Might be one of the "Internal cat" which are not+ -- really parsable...+ where cat2cat (AbsBNF.IdCat (AbsBNF.Ident s)) =+ case span isDigit (reverse s) of+ ([],c') -> Cat (reverse c')+ (d,c') -> CoercCat (reverse c') (read (reverse d))+ cat2cat (AbsBNF.ListCat c) = ListCat (cat2cat c)++-- Build-in categories contants+catString, catInteger, catDouble, catChar, catIdent :: Cat+catString = Cat "String"+catInteger = Cat "Integer"+catDouble = Cat "Double"+catChar = Cat "Char"+catIdent = Cat "Ident"++-- | Fun is the function name of a rule.+type Fun = String+-- | Either Cat or Fun+type Name = String++-- | Abstract syntax tree.+newtype Tree = Tree (Fun,[Tree])++-- | The abstract syntax of a grammar.+type Data = (Cat, [(Fun,[Cat])])++-- | firstCat returns the first Category appearing in the grammar.+firstCat :: CF -> Cat+firstCat = valCat . head . rulesOfCF++firstEntry :: CF -> Cat+firstEntry cf = case allEntryPoints cf of+ (x:_) -> x+ _ -> firstCat cf++rulesOfCF :: CFG f -> [Rul f]+rulesOfCFP :: CFP -> [RuleP]+infoOfCF :: CFG f -> Info+pragmasOfCF :: CFG f -> [Pragma]++rulesOfCF = snd . unCFG+rulesOfCFP = rulesOfCF+infoOfCF = snd . fst . unCFG+pragmasOfCF = fst . fst . unCFG++-- aggressively ban nonunique names (AR 31/5/2012)++notUniqueNames :: [Name] -> CF -> [Fun]+notUniqueNames reserved cf = [head xs | xs <- xss, length xs > 1] where+ xss = group (sort names)+ names = reserved ++ allCatsIdNorm cf ++ allFuns cf+ allFuns g = [ f | f <- map funRule (rulesOfCF g), not (isNilCons f || isCoercion f)]++{-# DEPRECATED notUniqueFuns "obsolete" #-}+notUniqueFuns :: CF -> [Fun]+notUniqueFuns cf = let xss = group $ sort [ f | f <- map funRule (rulesOfCF cf),+ not (isNilCons f || isCoercion f)]+ in [ head xs | xs <- xss, length xs > 1]++badInheritence :: CF -> [Cat]+badInheritence cf = concatMap checkGroup (ruleGroups cf)+ where+ checkGroup (cat, rs) = if length rs <= 1+ then []+ else case lookupRule (show cat) rs of+ Nothing -> []+ Just x -> [cat]++-- extract the comment pragmas.+commentPragmas :: [Pragma] -> [Pragma]+commentPragmas = filter isComment+ where isComment (CommentS _) = True+ isComment (CommentM _) = True+ isComment _ = False++lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat String])+lookupRule f = lookup f . map unRule+ where unRule (Rule f c rhs) = (f,(c,rhs))++-- | Returns all normal rules that constructs the given Cat.+rulesForCat :: CF -> Cat -> [Rule]+rulesForCat cf cat = [r | r <- rulesOfCF cf, isParsable r, valCat r == cat]++-- | As rulesForCat, but this version doesn't exclude internal rules.+rulesForCat' :: CF -> Cat -> [Rule]+rulesForCat' cf cat = [r | r <- rulesOfCF cf, valCat r == cat]++-- | Get all categories of a grammar. (No Cat w/o production returned; No duplicates)+allCats :: CFG f -> [Cat]+allCats = nub . map valCat . rulesOfCF++-- | Gets all normalized identified Categories+allCatsIdNorm :: CF -> [String]+allCatsIdNorm = nub . map (identCat . normCat) . allCats++-- | Get all normalized Cat+allCatsNorm :: CF -> [Cat]+allCatsNorm = nub . map normCat . allCats++-- | Is the category is used on an rhs?+isUsedCat :: CFG f -> Cat -> Bool+isUsedCat cf cat = cat `elem` [c | r <- rulesOfCF cf, Left c <- rhsRule r]++-- | Group all categories with their rules.+ruleGroups :: CF -> [(Cat,[Rule])]+ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf]++-- | Group all categories with their rules including internal rules.+ruleGroupsInternals :: CF -> [(Cat,[Rule])]+ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf]++-- | Get all literals of a grammar. (e.g. String, Double)+literals :: CFG f -> [Cat]+literals cf = lits ++ owns+ where+ (lits,_,_,_) = infoOfCF cf+ owns = map fst (tokenPragmas cf)++-- | Get all symbols+symbols :: CFG f -> [String]+symbols cf = syms+ where (_,syms,_,_) = infoOfCF cf++-- | Get the keywords of a grammar.+reservedWords :: CFG f -> [String]+reservedWords cf = sort keywords+ where (_,_,keywords,_) = infoOfCF cf++-- | Canonical, numbered list of symbols and reserved words. (These do+-- not end up in the AST.)+cfTokens :: CFG f -> [(String,Int)]+cfTokens cf = zip (sort (symbols cf ++ reservedWords cf)) [1..]+-- NOTE: some backends (incl. Haskell) assume that this list is sorted.++-- | Categories that is left-recursive transformable.+reversibleCats :: CFG f -> [Cat]+reversibleCats cf = cats+ where (_,_,_,cats) = infoOfCF cf++-- | Comments can be defined by the 'comment' pragma+comments :: CF -> ([(String,String)],[String])+comments cf = case commentPragmas (pragmasOfCF cf) of+ xs -> ([p | CommentM p <- xs],+ [s | CommentS s <- xs])++-- built-in categories (corresponds to lexer)++-- | Whether the grammar uses the predefined Ident type.+hasIdent :: CFG f -> Bool+hasIdent cf = isUsedCat cf catIdent+++-- these need new datatypes++-- | Categories corresponding to tokens. These end up in the+-- AST. (unlike tokens returned by 'cfTokens')+specialCats :: CF -> [Cat]+specialCats cf = (if hasIdent cf then (Cat "Ident":) else id) (map fst (tokenPragmas cf))++-- the parser needs these+specialCatsP :: [Cat]+specialCatsP = map Cat $ words "Ident Integer String Char Double"++-- to print parse trees+prTree :: Tree -> String+prTree (Tree (fun,[])) = fun+prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where+ pr2 t@(Tree (_,ts)) = (if null ts then id else prParenth) (prTree t)++-- abstract syntax trees: data type definitions++cf2data' :: (Cat -> Bool) -> CF -> [Data]+cf2data' predicate cf =+ [(cat, nub (map mkData [r | r <- rulesOfCF cf,+ let f = funRule r,+ not (isDefinedRule f),+ not (isCoercion f), eqCat cat (valCat r)]))+ | cat <- filter predicate (allCats cf)]+ where+ mkData (Rule f _ its) = (f,[normCat c | Left c <- its, c /= InternalCat])++cf2data :: CF -> [Data]+cf2data = cf2data' isDataCat++-- | Does the category correspond to a data type?+isDataCat :: Cat -> Bool+isDataCat c = isDataOrListCat c && not (isList c)++isDataOrListCat :: Cat -> Bool+isDataOrListCat (CoercCat _ _) = False+isDataOrListCat (Cat ('@':_)) = False+isDataOrListCat _ = True++cf2dataLists :: CF -> [Data]+cf2dataLists = cf2data' isDataOrListCat++specialData :: CF -> [Data]+specialData cf = [(c,[(show c,[Cat "String"])]) | c <- specialCats cf] where+++-- to deal with coercions++-- the Haskell convention: the wildcard _ is not a constructor++-- | Is this function just a coercion? (Ie. the identity)+isCoercion :: Fun -> Bool+isCoercion = (== "_") -- perhaps this should be changed to "id"?++isDefinedRule :: Fun -> Bool+isDefinedRule (x:_) = isLower x+isDefinedRule [] = error "isDefinedRule: empty function name"++isProperLabel :: Fun -> Bool+isProperLabel f = not (isCoercion f || isDefinedRule f)++-- | Categories C1, C2,... (one digit in end) are variants of C. This function+-- returns true if two category are variants of the same abstract category.+-- E.g.+--+-- >>> eqCat (Cat "Abc") (Cat "Abc")+-- True+-- >>> eqCat (CoercCat "Abc" 3) (CoercCat "Abc" 5)+-- True+-- >>> eqCat (CoercCat "Acb" 4) (CoercCat "Abc" 4)+-- False+-- >>> eqCat (Cat "Abc") (CoercCat "Abc" 44)+-- True+eqCat :: Cat -> Cat -> Bool+eqCat (CoercCat c1 _) (CoercCat c2 _) = c1 == c2+eqCat (Cat c1 ) (CoercCat c2 _) = c1 == c2+eqCat (CoercCat c1 _) (Cat c2) = c1 == c2+eqCat c1 c2 = c1 == c2++++-- | Removes precendence information. C1 => C, [C2] => [C]+normCat :: Cat -> Cat+normCat (ListCat c) = ListCat (normCat c)+normCat (CoercCat c _) = Cat c+normCat c = c++normCatOfList :: Cat -> Cat+normCatOfList = normCat . catOfList++-- | When given a list Cat, i.e. '[C]', it removes the square+-- brackets, and adds the prefix List, i.e. 'ListC'. (for Happy and+-- Latex)+-- >>> identCat (ListCat (Cat "C")) -- [C]+-- "ListC"+-- >>> identCat (CoercCat "C" 3)+-- "C3"+identCat :: Cat -> String+identCat (ListCat c) = "List" ++ identCat c+identCat c = show c++-- | FIXME: This is a copy of the old normCat function that some backend use+-- on Fun. Now that the type of Cat has changed, this is no longer possible+-- so this is added for those odd cases. It should be verified if this is+-- really necessary.+normFun :: Fun -> Fun+normFun f = case f of+ '[':cs -> "[" ++ norm (init cs) ++ "]"+ _ -> norm f+ where norm = reverse . dropWhile isDigit . reverse+++-- | Checks if the rule is parsable.+isParsable :: Rul f -> Bool+isParsable (Rule _ _ (Left c:_)) = c /= InternalCat+isParsable _ = True++isList :: Cat -> Bool+isList (ListCat _) = True+isList _ = False+++-- | Unwraps the list constructor from the category name. Eg. [C1] => C1+-- E.g.+-- >>> catOfList (ListCat (Cat "A"))+-- A+-- >>> catOfList (Cat "B")+-- B+catOfList :: Cat -> Cat+catOfList (ListCat c) = c+catOfList c = c++isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: Fun -> Bool+isNilCons f = isNilFun f || isOneFun f || isConsFun f || isConcatFun f+isNilFun f = f == "[]"+isOneFun f = f == "(:[])"+isConsFun f = f == "(:)"+isConcatFun f = f == "(++)"++-- | Checks if the list has a non-empty rule.+hasOneFunc :: [Rule] -> Bool+hasOneFunc = any (isOneFun . funRule)++-- | Gets the separator for a list.+getCons :: [Rule] -> String+getCons rs = case find (isConsFun . funRule) rs of+ Just (Rule _ _ cats) -> seper cats+ Nothing -> error $ "getCons: no construction function found in "+ ++ intercalate ", " (map (show . funRule) rs)+ where+ seper [] = []+ seper (Right x:xs) = x+ seper (Left x:xs) = seper xs+++isEmptyListCat :: CF -> Cat -> Bool+isEmptyListCat cf c = elem "[]" $ map funRule $ rulesForCat' cf c++isNonterm = either (const True) (const False)++-- used in Happy to parse lists of form 'C t [C]' in reverse order+-- applies only if the [] rule has no terminals+revSepListRule :: Rul f -> Rul f+revSepListRule (Rule f c ts) = Rule f c (xs : x : sep) where+ (x,sep,xs) = (head ts, init (tail ts), last ts)+-- invariant: test in findAllReversibleCats have been performed++findAllReversibleCats :: CF -> [Cat]+findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where+ isRev c rs = case rs of+ [r1,r2] | isList c -> if isConsFun (funRule r2)+ then tryRev r2 r1+ else isConsFun (funRule r1) && tryRev r1 r2+ _ -> False+ tryRev (Rule f _ ts@(x:_:xs)) r = isEmptyNilRule r &&+ isConsFun f && isNonterm x && isNonterm (last ts)+ tryRev _ _ = False++isEmptyNilRule (Rule f _ ts) = isNilFun f && null ts++-- | Returns the precedence of a category symbol.+-- E.g.+--+-- >>> precCat (Cat "Abc")+-- 0+--+-- >>> precCat (CoercCat "Abc" 4)+-- 4+--+-- But!+-- >>> precCat (ListCat (CoercCat "Abc" 2))+-- 0+precCat :: Cat -> Integer+precCat (CoercCat _ i) = i+precCat _ = 0++precRule :: Rule -> Integer+precRule = precCat . valCat++precLevels :: CF -> [Integer]+precLevels cf = sort $ nub [ precCat c | c <- allCats cf]++precCF :: CF -> Bool+precCF cf = length (precLevels cf) > 1+++-- | Does the category have a position stored in AST?+isPositionCat :: CFG f -> Cat -> Bool+isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, Cat name == cat]+++-- | Grammar with permutation profile à la GF. AR 22/9/2004+type CFP = CFG FunP -- (Exts,[RuleP])+type FunP = (Fun,Prof)+type RuleP = Rul FunP -- (FunP, (Cat, [Either Cat String]))++-- | Pair of: the original function name, profile+type Prof = (Fun, [([[Int]],[Int])])++cf2cfp :: CF -> CFP+cf2cfp (CFG (es,rs)) = CFG (es, map cf2cfpRule rs)++cf2cfpRule :: Rule -> RuleP+cf2cfpRule (Rule f c its) = Rule (f, (f, trivialProf its)) c its++cfp2cf :: CFP -> CF+cfp2cf = fmap fst++trivialProf :: [Either Cat String] -> [([[Int]],[Int])]+trivialProf its = [([],[i]) | (i,_) <- zip [0..] [c | Left c <- its]]++{-# DEPRECATED rulesOfCFP, allCatsP, allEntryPointsP "Use the version without P postfix instead" #-}++funRuleP :: RuleP -> Fun+funRuleP = fst . funRule++ruleGroupsP :: CFP -> [(Cat,[RuleP])]+ruleGroupsP cf = [(c, rulesForCatP cf c) | c <- allCatsP cf]++rulesForCatP :: CFP -> Cat -> [RuleP]+rulesForCatP cf cat = [r | r <- rulesOfCFP cf, isParsable r, valCat r == cat]++allCatsP :: CFP -> [Cat]+allCatsP = allCats+++-- | Categories that are entry points to the parser+allEntryPoints :: CFG f -> [Cat]+allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of+ [] -> allCats cf+ cs -> cs++allEntryPointsP :: CFP -> [Cat]+allEntryPointsP = allEntryPoints
+ src/BNFC/GetCF.hs view
@@ -0,0 +1,391 @@+{-+ BNF Converter: Abstract syntax+ Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++module BNFC.GetCF(parseCF, parseCFP) where++import Control.Monad ( when )++import BNFC.CF+import BNFC.Utils+import ParBNF+import Data.List(nub,partition)+import qualified AbsBNF as Abs+import Data.Maybe (catMaybes)+import Data.Either (partitionEithers)+import ErrM+import Data.Char+import BNFC.TypeChecker+import BNFC.Options+import Data.List (isPrefixOf)++parseCF :: SharedOptions -> Target -> String -> IO CF+parseCF opts t s = parseCFP opts t s >>= return . cfp2cf++parseCFP :: SharedOptions -> Target -> String -> IO CFP+parseCFP opts target content = do+ let (cfp,msgs1) = getCFP (cnf opts) content+ cf = cfp2cf cfp+ msgs2 = case checkDefinitions cf of+ Bad err -> [err]+ Ok () -> []+ msgs3 = checkTokens cf+ msg = msgs1++msgs2 -- ++ msgs3 -- in a future version+ ret = cfp++ let reserved = [lang opts | target == TargetJava ]++ case filter (not . isDefinedRule) $ notUniqueNames reserved cf of+ ns@(_:_)+ | not (target `elem` [TargetHaskell,TargetHaskellGadt,TargetOCaml]) -> do+ fail $ "ERROR: names not unique: " ++ unwords ns+ ns -> do+ case ns of+ _:_ -> do+ putStrLn $ "Warning: names not unique: " ++ unwords ns+ putStrLn "This can be an error in other back ends."+ _ -> return ()+ putStrLn $ unlines msgs3+ if not (null msg) then do+ fail $ unlines msg+ else do+ putStrLn $ show (length (rulesOfCF cf)) +++ "rules accepted\n"+ let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2]+ if null c3s then return () else do+ putStrLn+ "Warning: comment delimiters longer than 2 characters ignored in Haskell:"+ mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s]+ return cfp++{-+ case filter (not . isDefinedRule) $ notUniqueFuns cf of+ [] -> case (badInheritence cf) of+ [] -> return (ret,True)+ xs -> do+ putStrLn "Warning :"+ putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs+ putStrLn $ " These categories have more than one Label, yet one of these"+ putStrLn $ " Labels has the same name as the Category. This will almost"+ putStrLn $ " certainly cause problems in languages other than Haskell.\n"+ return (ret,True)+ xs -> do+ putStrLn $ "Warning :"+ putStrLn $ " Non-unique label name(s) : " ++ unwords xs+ putStrLn $ " There may be problems with the pretty-printer.\n"+ case (badInheritence cf) of+ [] -> return (ret,True)+ xs -> do+ putStrLn $ "Warning :"+ putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs+ putStrLn $ " These categories have more than one Label, yet one of these"+ putStrLn $ " Labels has the same name as the Category. This will almost"+ putStrLn $ " certainly cause problems in languages other than Haskell.\n"+ return (ret,True)+-}++nilCFP :: CFP+nilCFP = CFG (([],([],[],[],[])),[])++getCFP :: Bool -> String -> (CFP,[String])+getCFP cnf s = case pGrammar . myLexer $ s of+ Bad s -> (nilCFP,[s])+ Ok (Abs.Grammar defs0) -> (cf0,msgs)+ where (pragma,rules0) = partitionEithers $ concatMap transDef $ defs+ (defs,inlineDelims) = if cnf then (defs0,id) else removeDelims defs0+ rules = inlineDelims rules0+ msgs = catMaybes $ map (checkRule (cfp2cf cf0)) (rulesOfCF cf0)+ cf0 = revs srt+ srt = let literals = nub [lit | xs <- map rhsRule rules,+ Left lit <- xs,+ elem lit specialCatsP]+ (symbols,keywords) = partition notIdent reservedWords+ notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s+ isIdentRest c = isAlphaNum c || c == '_' || c == '\''+ reservedWords = nub [t | r <- rules, Right t <- rhsRule r]+ in CFG((pragma,(literals,symbols,keywords,[])),rules)+ revs cf1@(CFG((pragma,(literals,symbols,keywords,_)),rules)) =+ CFG((pragma,(literals,symbols,keywords,findAllReversibleCats (cfp2cf cf1))),rules)++removeDelims :: [Abs.Def] -> ([Abs.Def], [RuleP] -> [RuleP])+removeDelims xs = (ys ++ map delimToSep ds,+ foldr (.) id [map (inlineDelim' d) | d <- ds])+ where+ (ds,ys) = partition isDelim xs+ isDelim (Abs.Delimiters _ _ _ _ _) = True+ isDelim _ = False+ + inlineDelim :: Abs.Def -> Either Cat String -> [Either Cat String]+ inlineDelim (Abs.Delimiters cat open close separ sz) (Left c)+ | c == ListCat (transCat cat) = [Right open, Left c, Right close]+ inlineDelim _ x = [x]+ + inlineDelim' :: Abs.Def -> RuleP -> RuleP+ inlineDelim' d@(Abs.Delimiters cat _ _ _ _) r@(Rule f c rhs) + | c == ListCat (transCat cat) = r+ | otherwise = Rule f c (concatMap (inlineDelim d) rhs)+++ delimToSep (Abs.Delimiters cat open close (Abs.SepTerm s) sz) = Abs.Terminator sz cat s+ delimToSep (Abs.Delimiters cat open close (Abs.SepSepar s) sz) = Abs.Separator sz cat s+ delimToSep (Abs.Delimiters cat open close (Abs.SepNone ) sz) = Abs.Terminator sz cat ""+ delimToSep x = x+ +transDef :: Abs.Def -> [Either Pragma RuleP]+transDef x = case x of+ Abs.Rule label cat items ->+ [Right $ Rule (transLabel label) (transCat cat) (map transItem items)]+ Abs.Comment str -> [Left $ CommentS str]+ Abs.Comments str0 str -> [Left $ CommentM (str0,str)]+ Abs.Token ident reg -> [Left $ TokenReg (transIdent ident) False reg]+ Abs.PosToken ident reg -> [Left $ TokenReg (transIdent ident) True reg]+ Abs.Entryp idents -> [Left $ EntryPoints (map (strToCat .transIdent) idents)]+ Abs.Internal label cat items ->+ [Right $ Rule (transLabel label) (transCat cat) (Left InternalCat:(map transItem items))]+ Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str+ Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str+ Abs.Delimiters a b c d e -> map (Right . cf2cfpRule) $ delimiterRules a b c d e+ Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int+ Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs+ Abs.Layout ss -> [Left $ Layout ss]+ Abs.LayoutStop ss -> [Left $ LayoutStop ss]+ Abs.LayoutTop -> [Left $ LayoutTop]+ Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)]++delimiterRules :: Abs.Cat -> String -> String -> Abs.Separation -> Abs.MinimumSize -> [Rule]+delimiterRules a0 l r (Abs.SepTerm "") size = delimiterRules a0 l r Abs.SepNone size+delimiterRules a0 l r (Abs.SepSepar "") size = delimiterRules a0 l r Abs.SepNone size+delimiterRules a0 l r sep size = [+ -- recognizing a single element+ Rule "(:[])" (strToCat a') (Left a : termin), -- optional terminator/separator++ -- glueing two sublists+ Rule "(++)" (strToCat a') [Left (strToCat a'), Left (strToCat a')],++ -- starting on either side with a delimiter+ Rule "[]" (strToCat c) [Right l],+ Rule (if optFinal then "(:[])" else+ "[]")+ (strToCat d) ([Left a | optFinal] ++ [Right r]),++ -- gathering chains+ Rule "(++)" (strToCat c) [Left (strToCat c), Left (strToCat a')],+ Rule "(++)" (strToCat d) [Left (strToCat a'), Left (strToCat d)],++ -- finally, put together left and right chains+ Rule "(++)" as [Left (strToCat c),Left (strToCat d)]] ++ [+ -- special rule for the empty list if necessary+ Rule "[]" as [Right l,Right r] | optEmpty]+ where a = transCat a0+ as = ListCat a+ a' = '@':'@':(show a)+ c = '@':'{':(show a)+ d = '@':'}':(show a)+ -- optionally separated concat. of x and y categories.+ x // y = (Left x :+ [Right t | Abs.SepSepar t <- [sep]] +++ [Left y ])+ termin = case sep of+ Abs.SepSepar t -> [Right t]+ Abs.SepTerm t -> [Right t]+ _ -> []+ optFinal = case (sep,size) of+ (Abs.SepSepar t,_) -> True+ (Abs.SepTerm _,Abs.MNonempty) -> True+ (Abs.SepNone,Abs.MNonempty) -> True+ _ -> False+ optEmpty = case sep of+ Abs.SepSepar _ -> size == Abs.MEmpty+ _ -> False+++separationRules :: Abs.Cat -> Abs.Separation -> Abs.MinimumSize -> [Rule]+separationRules c Abs.SepNone size = terminatorRules size c ""+separationRules c (Abs.SepTerm t) size = terminatorRules size c t+separationRules c (Abs.SepSepar t) size = separatorRules size c t+++separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]+separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [+ Rule "(:[])" cs [Left c'],+ Rule "(:)" cs [Left c', Right s, Left cs]+ ]+ where+ c' = transCat c+ cs = ListCat c'+ ifEmpty rs = if (size == Abs.MNonempty)+ then rs+ else Rule "[]" cs [] : rs++terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]+terminatorRules size c s = [+ ifEmpty,+ Rule "(:)" cs (Left c' : s' [Left cs])+ ]+ where+ c' = transCat c+ cs = ListCat c'+ s' its = if null s then its else (Right s : its)+ ifEmpty = if (size == Abs.MNonempty)+ then Rule "(:[])" cs ([Left c'] ++ if null s then [] else [Right s])+ else Rule "[]" cs []++coercionRules :: Abs.Ident -> Integer -> [Rule]+coercionRules (Abs.Ident c) n =+ Rule "_" (Cat c) [Left (CoercCat c 1)] :+ [Rule "_" (CoercCat c (i-1)) [Left (CoercCat c i)] | i <- [2..n]] +++ [Rule "_" (CoercCat c n) [Right "(", Left (Cat c), Right ")"]]++ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule]+ebnfRules (Abs.Ident c) rhss =+ [Rule (mkFun k c its) (strToCat c) (map transItem its)+ | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss]+ where+ mkFun k c i = case i of+ [Abs.Terminal s] -> c' ++ "_" ++ mkName k s+ [Abs.NTerminal n] -> c' ++ identCat (transCat n)+ _ -> c' ++ "_" ++ show k+ c' = c --- normCat c+ mkName k s = if all (\c -> isAlphaNum c || elem c "_'") s+ then s else show k++transItem :: Abs.Item -> Either Cat String+transItem x = case x of+ Abs.Terminal str -> Right str+ Abs.NTerminal cat -> Left (transCat cat)++transCat :: Abs.Cat -> Cat+transCat x = case x of+ Abs.ListCat cat -> ListCat (transCat cat)+ Abs.IdCat (Abs.Ident c) -> strToCat c++transLabel :: Abs.Label -> (Fun,Prof)+transLabel y = case y of+ Abs.LabNoP f -> let g = transLabelId f in (g,(g,[])) ---- should be Nothing+ Abs.LabP f p -> let g = transLabelId f in (g,(g, map transProf p))+ Abs.LabPF f g p -> (transLabelId f,(transLabelId g, map transProf p))+ Abs.LabF f g -> (transLabelId f,(transLabelId g, []))+ where+ transLabelId x = case x of+ Abs.Id id -> transIdent id+ Abs.Wild -> "_"+ Abs.ListE -> "[]"+ Abs.ListCons -> "(:)"+ Abs.ListOne -> "(:[])"+ transProf (Abs.ProfIt bss as) =+ ([map fromInteger bs | Abs.Ints bs <- bss], map fromInteger as)++transIdent :: Abs.Ident -> String+transIdent x = case x of+ Abs.Ident str -> str++transArg :: Abs.Arg -> String+transArg (Abs.Arg x) = transIdent x++transExp :: Abs.Exp -> Exp+transExp e = case e of+ Abs.App x es -> App (transIdent x) (map transExp es)+ Abs.Var x -> App (transIdent x) []+ Abs.Cons e1 e2 -> cons e1 (transExp e2)+ Abs.List es -> foldr cons nil es+ Abs.LitInt x -> LitInt x+ Abs.LitDouble x -> LitDouble x+ Abs.LitChar x -> LitChar x+ Abs.LitString x -> LitString x+ where+ cons e1 e2 = App "(:)" [transExp e1, e2]+ nil = App "[]" []++--------------------------------------------------------------------------------++--checkTokens :: CFG f -> [String]+checkTokens cf =+ if null ns+ then []+ else ["Warning : ", -- change to error in a future version+ " The following tokens accept the empty string: ",+ " "++unwords ns,+ " This is error-prone and will not be supported in the future."]+ where+ ns = map (show.fst) . filter (nullable.snd) $ tokenPragmas cf++-- | Check if a regular expression is nullable (accepts the empty string)+nullable :: Abs.Reg -> Bool+nullable r =+ case r of+ Abs.RSeq r1 r2 -> nullable r1 && nullable r2+ Abs.RAlt r1 r2 -> nullable r1 || nullable r2+ Abs.RMinus r1 r2 -> nullable r1 && not (nullable r2)+ Abs.RStar _ -> True+ Abs.RPlus r1 -> nullable r1+ Abs.ROpt _ -> True+ Abs.REps -> True+ Abs.RChar _ -> False+ Abs.RAlts _ -> False+ Abs.RSeqs s -> null s+ Abs.RDigit -> False+ Abs.RLetter -> False+ Abs.RUpper -> False+ Abs.RLower -> False+ Abs.RAny -> False+++-- we should actually check that+-- (1) coercions are always between variants+-- (2) no other digits are used++checkRule :: CF -> RuleP -> Maybe String+checkRule cf (Rule _ (Cat ('@':_)) rhs) = Nothing -- Generated by a pragma; it's a trusted category+checkRule cf (Rule (f,_) cat rhs)+ | badCoercion = Just $ "Bad coercion in rule" +++ s+ | badNil = Just $ "Bad empty list rule" +++ s+ | badOne = Just $ "Bad one-element list rule" +++ s+ | badCons = Just $ "Bad list construction rule" +++ s+ | badList = Just $ "Bad list formation rule" +++ s+ | badSpecial = Just $ "Bad special category rule" +++ s+ | badTypeName = Just $ "Bad type name" +++ unwords (map show badtypes) +++ "in" +++ s+ | badFunName = Just $ "Bad constructor name" +++ f +++ "in" +++ s+ | badMissing = Just $ "No production for" +++ unwords missing +++ ", appearing in rule" +++ s+ | otherwise = Nothing+ where+ s = f ++ "." +++ show cat +++ "::=" +++ unwords (map (either show show) rhs) -- Todo: consider using the show instance of Rule+ c = normCat cat+ cs = [normCat c | Left c <- rhs]+ badCoercion = isCoercion f && not ([c] == cs) + badNil = isNilFun f && not (isList c && null cs)+ badOne = isOneFun f && not (isList c && cs == [catOfList c])+ badCons = isConsFun f && not (isList c && cs == [catOfList c, c])+ badList = isList c &&+ not (isCoercion f || isNilCons f)+ badSpecial = elem c specialCatsP && not (isCoercion f)++ badMissing = not (null missing)+ missing = filter nodef [show c | Left c <- rhs]+ nodef t = notElem t defineds+ defineds =+ show InternalCat : tokenNames cf ++ (map show specialCatsP) ++ map (show . valCat) (rulesOfCF cf)+ badTypeName = not (null badtypes)+ badtypes = filter isBadType $ cat : [c | Left c <- rhs]+ isBadType (ListCat c) = isBadType c+ isBadType InternalCat = False+ isBadType (CoercCat c _) = isBadCatName c+ isBadType (Cat s) = isBadCatName s+ isBadCatName s = not (isUpper (head s) || s == show InternalCat || (head s == '@'))+ badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-}+ || isCoercion f || isNilCons f)
+ src/BNFC/MultiView.hs view
@@ -0,0 +1,137 @@+{-+ BNF Converter: Abstract syntax+ Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}+++module BNFC.MultiView where++import System.Directory ( doesFileExist, renameFile )++import qualified BNFC.CF as CF+import BNFC.Utils+import ParBNF+import PrintBNF+import Data.List(nub,partition)+import AbsBNF+-- import LexBNF+import ErrM+import Data.Char+import BNFC.TypeChecker++preprocessMCF :: FilePath -> IO ([FilePath],String)+preprocessMCF f = do+ s <- readFile f+ gr <- case pLGrammar $ myLexer s of+ Ok g -> return g+ Bad s -> error s+ let name = takeWhile (/='.') f+ let grs = extract name gr+ let entryp = entrypoint gr+ mapM_ writeCF grs+ return $ (map fst grs,entryp)++extract :: String -> LGrammar -> [(FilePath, Grammar)]+extract name (LGr ldefs) =+ [(file lang,Grammar [unldef ldef | ldef <- ldefs, isFor lang ldef]) |+ lang <- views]+ where+ views = [lang | LDefView langs <- ldefs, Ident lang <- langs]+ isFor lang ldef = case ldef of+ DefAll _ -> True+ DefSome ids _ -> elem (Ident lang) ids+ _ -> False+ unldef ldef = case ldef of+ DefAll d -> d+ DefSome _ d -> d+ file lang = name ++ "_" ++ lang ++ ".cf"++--- the entrypoint is the same for all languages - could be different++entrypoint :: LGrammar -> String+entrypoint (LGr rs0) = head $+ [c | Entryp (Ident c:_) <- rs] +++ [c | Rule _ (IdCat (Ident c)) _ <- rs]+ where+ rs = concatMap getR rs0+ getR d = case d of+ DefAll d -> [d]+ DefSome _ d -> [d]+ _ -> [] --- LDefView++writeCF :: (FilePath, Grammar) -> IO ()+writeCF (file,gr) = do+ writeFile file $ printTree gr+ putStrLn $ "wrote file " ++ file++---- These are Haskell specific;+---- should be generalized by inspecting the options xx++mkTestMulti :: String -> [String] -> FilePath -> [FilePath] -> IO ()+mkTestMulti cat xx file files = do+ let abs = takeWhile (/='.') file+ let cncs = map (takeWhile (/='.')) files+ let content = testfile cat xx abs cncs+ writeFile ("TestTrans" ++ abs ++ ".hs") content++mkMakefileMulti :: [String] -> FilePath -> [FilePath] -> IO ()+mkMakefileMulti xx file files = do+ let abs = takeWhile (/='.') file+ let cncs = map (takeWhile (/='.')) files+ let content = makefile xx abs cncs+ writeFile "Makefile" content++makefile xx abs cncs = unlines $+ "all:" :+ ["\tmake -f Makefile_" ++ cnc | cnc <- cncs] +++ ["\tghc --make -o TestTrans" ++ abs ++ " TestTrans" ++ abs,+ ""+ ]++testfile cat xx abs cncs = unlines $+ ["module Main where"] +++ ["import qualified Lex" ++ cnc | cnc <- cncs] +++ ["import qualified Par" ++ cnc | cnc <- cncs] +++ ["import qualified Print" ++ cnc | cnc <- cncs] +++ ["import Abs" ++ abs,+ "import ErrM",+ "import System.Environment (getArgs)",+ "",+ "main :: IO ()",+ "main = do",+ " i:o:f:_ <- getArgs",+ " s <- readFile f",+ " case parse i s of",+ " Ok t -> putStrLn $ prin o t",+ " Bad s -> error s",+ "",+ "parse i = case i of"+ ] +++ [+ " " ++ sho cnc ++ " -> Par" ++ cnc ++ ".p" ++ cat +++ " . Par" ++ cnc ++ ".myLexer" | cnc <- cncs+ ] +++ [+ "",+ "prin o = case o of"+ ] +++ [+ " " ++ sho cnc ++ " -> Print" ++ cnc +++ ".printTree" | cnc <- cncs+ ]+ where+ sho = show . tail . dropWhile (/='_')
+ src/BNFC/Options.hs view
@@ -0,0 +1,279 @@+module BNFC.Options where++import BNFC.CF (CF)+import BNFC.WarningM+import Control.Monad (liftM, when,unless)+import Control.Monad.State+import Control.Monad.Trans (lift)+import Data.Char+import Data.List (elemIndex, foldl', sort, intercalate)+import Data.Maybe (catMaybes, listToMaybe, isJust, fromMaybe)+import Data.Version ( showVersion )+import ErrM+import Paths_BNFC ( version )+import System.Console.GetOpt+import System.FilePath (takeBaseName, takeFileName)+import System.IO (stderr, hPutStrLn,hPutStr)+import Text.Printf (printf)++-- ~~~ Option data structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- | To decouple the option parsing from the execution of the program,+-- we introduce a data structure that holds the result of the+-- parsing of the arguments.+data Mode+ -- An error has been made by the user+ -- e.g. invalid argument/combination of arguments+ = UsageError String+ -- Basic modes: print some info and exits+ | Help | Version+ -- Normal mode, specifying the back end to use,+ -- the option record to be passed to the backend+ -- and the path of the input grammar file+ | Target SharedOptions FilePath+ deriving (Eq,Show,Ord)++-- | Target languages+data Target = TargetC | TargetCpp | TargetCppNoStl | TargetCSharp+ | TargetHaskell | TargetHaskellGadt | TargetLatex+ | TargetJava | TargetOCaml | TargetProfile+ deriving (Eq,Bounded, Enum,Ord)++-- Create a list of all target using the enum and bounded classes+targets :: [Target]+targets = [minBound..]++instance Show Target where+ show TargetC = "C"+ show TargetCpp = "C++"+ show TargetCppNoStl = "C++ (without STL)"+ show TargetCSharp = "C#"+ show TargetHaskell = "Haskell"+ show TargetHaskellGadt = "Haskell (with GADT)"+ show TargetLatex = "Latex"+ show TargetJava = "Java"+ show TargetOCaml = "OCaml"+ show TargetProfile = "Haskell (with permutation profiles)"++-- | Which version of Alex is targeted?+data AlexVersion = Alex1 | Alex2 | Alex3+ deriving (Show,Eq,Ord,Bounded,Enum)++-- | Happy modes+data HappyMode = Standard | GLR+ deriving (Eq,Show,Bounded,Enum,Ord)++-- | This is the option record that is passed to the different backends+data SharedOptions = Options+ -- Option shared by at least 2 backends+ { target :: Target+ , make :: Maybe String -- ^ The name of the Makefile to generate+ -- or Nothing for no Makefile.+ , inPackage :: Maybe String -- ^ The hierarchical package to put+ -- the modules in, or Nothing.+ , cnf :: Bool -- ^ Generate CNF-like tables?+ , lang :: String+ -- Haskell specific:+ , alexMode :: AlexVersion+ , inDir :: Bool+ , shareStrings :: Bool+ , byteStrings :: Bool+ , glr :: HappyMode+ , xml :: Int+ , ghcExtensions :: Bool+ -- C++ specific+ , linenumbers :: Bool -- ^ Add and set line_number field for syntax classes+ -- C# specific+ , visualStudio :: Bool -- ^ Generate Visual Studio solution/project files+ , wcf :: Bool -- ^ Windows Communication Foundation+ } deriving (Eq,Show,Ord)++-- | We take this oportunity to define the type of the backend functions+type Backend = SharedOptions -- ^ options+ -> CF -- ^ Grammar+ -> IO ()++defaultOptions = Options+ { cnf = False+ , target = TargetHaskell+ , inPackage = Nothing+ , make = Nothing+ , alexMode = Alex3+ , inDir = False+ , shareStrings = False+ , byteStrings = False+ , glr = Standard+ , xml = 0+ , ghcExtensions = False+ , lang = error "lang not set"+ , linenumbers = False+ , visualStudio = False+ , wcf = False }++-- ~~~ Option definition ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- This defines bnfc's "global" options, like --help+globalOptions :: [ OptDescr Mode ]+globalOptions = [+ Option [] ["help"] (NoArg Help) "show help",+ Option [] ["version","numeric-version"] (NoArg Version) "show version number"]++-- | Options for the target languages+-- targetOptions :: [ OptDescr Target ]+targetOptions :: [ OptDescr (SharedOptions -> SharedOptions)]+targetOptions = + [ Option "" ["java"] (NoArg (\o -> o {target = TargetJava}))+ "Output Java code for use with JLex and CUP"+ , Option "" ["haskell"] (NoArg (\o -> o {target = TargetHaskell}))+ "Output Haskell code for use with Alex and Happy (default)"+ , Option "" ["haskell-gadt"] (NoArg (\o -> o {target = TargetHaskellGadt}))+ "Output Haskell code which uses GADTs"+ , Option "" ["latex"] (NoArg (\o -> o {target = TargetLatex}))+ "Output LaTeX code to generate a PDF description of the language"+ , Option "" ["c"] (NoArg (\o -> o {target = TargetC}))+ "Output C code for use with FLex and Bison"+ , Option "" ["cpp"] (NoArg (\o -> o {target = TargetCpp}))+ "Output C++ code for use with FLex and Bison"+ , Option "" ["cpp-nostl"] (NoArg (\o -> o {target = TargetCppNoStl}))+ "Output C++ code (without STL) for use with FLex and Bison"+ , Option "" ["csharp"] (NoArg (\o -> o {target = TargetCSharp}))+ "Output C# code for use with GPLEX and GPPG"+ , Option "" ["ocaml"] (NoArg (\o -> o {target = TargetOCaml}))+ "Output OCaml code for use with ocamllex and ocamlyacc"+ , Option "" ["profile"] (NoArg (\o -> o {target = TargetProfile}))+ "Output Haskell code for rules with permutation profiles" ]++-- | A list of the options and for each of them, the target language+-- they apply to.+specificOptions :: [(OptDescr (SharedOptions -> SharedOptions), [Target])]+specificOptions =+ [ ( Option ['l'] [] (NoArg (\o -> o {linenumbers = True}))+ "Add and set line_number field for all syntax classes"+ , [TargetCpp] )+ , ( Option ['p'] []+ (ReqArg (\n o -> o {inPackage = Just n}) "<namespace>")+ "Prepend <namespace> to the package/module name"+ , [TargetCpp, TargetCSharp, TargetHaskell, TargetHaskellGadt, TargetProfile, TargetJava] )+ , ( Option [] ["vs"] (NoArg (\o -> o {visualStudio = True}))+ "Generate Visual Studio solution/project files"+ , [TargetCSharp] )+ , ( Option [] ["wcf"] (NoArg (\o -> o {wcf = True}))+ "Add support for Windows Communication Foundation,\n by marking abstract syntax classes as DataContracts"+ , [TargetCSharp] )+ , ( Option ['d'] [] (NoArg (\o -> o {inDir = True}))+ "Put Haskell code in modules Lang.* instead of Lang*"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["alex1"] (NoArg (\o -> o {alexMode = Alex1}))+ "Use Alex 1.1 as Haskell lexer tool"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["alex2"] (NoArg (\o -> o {alexMode = Alex2}))+ "Use Alex 2 as Haskell lexer tool"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["alex3"] (NoArg (\o -> o {alexMode = Alex3}))+ "Use Alex 3 as Haskell lexer tool (default)"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["sharestrings"] (NoArg (\o -> o {shareStrings = True}))+ "Use string sharing in Alex 2 lexer"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["bytestrings"] (NoArg (\o -> o {byteStrings = True}))+ "Use byte string in Alex 2 lexer"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["glr"] (NoArg (\o -> o {glr = GLR}))+ "Output Happy GLR parser"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["xml"] (NoArg (\o -> o {xml = 1}))+ "Also generate a DTD and an XML printer"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["xmlt"] (NoArg (\o -> o {xml = 2}))+ "DTD and an XML printer, another encoding"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["cnf"] (NoArg (\o -> o {cnf = True}))+ "Use the CNF parser instead of happy"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ , ( Option [] ["ghc"] (NoArg (\o -> o {ghcExtensions = True}))+ "Use ghc-specific language extensions"+ , [TargetHaskell, TargetHaskellGadt, TargetProfile] )+ ]++makefileOption =+ [ Option "m" ["makefile"] (OptArg (setMakefile . fromMaybe "Makefile") "MAKEFILE")+ "generate Makefile" ]+ where setMakefile = \mf -> \o -> o { make = Just mf }++allOptions = targetOptions ++ makefileOption ++ map fst specificOptions++-- ~~~ Help strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+title = unlines [+ "The BNF Converter, "++showVersion version,+ "(c) Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan, ",+ " Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson, ",+ " Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, ",+ " Michael Pellauer and Aarne Ranta 2002 - 2013.",+ "Free software under GNU General Public License (GPL).",+ "Bug reports to bnfc-dev@googlegroups.com."+ ]++usage :: String+usage = "usage: bnfc [--version] [--help] <target language> [<args>] file.cf"++help :: String+help = unlines $+ usage:""+ :usageInfo "Global options" globalOptions+ :usageInfo "Make option" makefileOption+ :usageInfo "Target languages" targetOptions+ :map targetUsage targets+ where targets = [TargetHaskell, TargetJava, TargetCpp, TargetCSharp ]+ targetUsage t = usageInfo+ (printf "Special options for the %s backend" (show t))+ (map fst $ filter(elem t . snd)specificOptions)++-- ~~~ Parsing machinery ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- | Main parsing function+parseMode :: [String] -> Mode+parseMode args =+ case args' of+ [] -> Help+ _ -> case getOpt' Permute globalOptions args' of+ (mode:_,_,_,_) -> mode+ _ -> case getOpt Permute allOptions args' of+ (_,_,e:_) -> UsageError e+ (_,[],_) -> UsageError "Missing grammar file"+ (optionsUpdates, [grammar], []) ->+ let options = foldl (.) id optionsUpdates defaultOptions in+ Target (options {lang = takeBaseName grammar}) grammar+ (_,_,_) -> UsageError "Too many arguments"+ where args' = translateOldOptions args++isUsageError :: Mode -> Bool+isUsageError (UsageError _) = True+isUsageError _ = False++-- ~~~ Backward compatibility ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A translating function to maintain backward compatiblicy+-- with the old option syntay+translateOldOptions :: [String] -> [String]+translateOldOptions = concatMap translateOne+ where translateOne "-java" = return "--java"+ translateOne "-java1.5" = return "--java"+ translateOne "-c" = return "--c"+ translateOne "-cpp" = return "--cpp"+ translateOne "-cpp_stl" = return "--cpp"+ translateOne "-cpp_no_stl" = return "--cpp-nostl"+ translateOne "-csharp" = return "--csharp"+ translateOne "-ocaml" = return "--ocaml"+ translateOne "-fsharp" = return "fsharp"+ translateOne "-haskell" = return "--haskell"+ translateOne "-prof" = return "--profile"+ translateOne "-gadt" = return "--haskell-gadt"+ translateOne "-alex1" = return "--alex1"+ translateOne "-alex2" = return "--alex2"+ translateOne "-alex3" = return "--alex3"+ translateOne "-sharestrings" = return "--sharestring"+ translateOne "-bytestrings" = return "--bytestring"+ translateOne "-glr" = return "--glr"+ translateOne "-xml" = return "--xml"+ translateOne "-xmlt" = return "--xmlt"+ translateOne "-vs" = return "--vs"+ translateOne "-wcf" = return "--wcf"+ translateOne other = return other+
+ src/BNFC/ToCNFCore.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-+ Copyright (C) 2012 Authors:+ Jean-Philippe Bernardy.++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++{-# LANGUAGE OverloadedStrings #-}++module BNFC.ToCNFCore (toCNF, isCat, group', catTag, punctuate', onRules, isUnitRule, splitOptim, second, lookupMulti,+ Set, CatDescriptions, UnitRel, RHSEl, Exp(..), prettyExp, appMany, app',after) where++{-++Construction of CYK tables. The algorithm follows:++Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient+Yet Presentable Version of the CYK Algorithm", Informatica Didactica++-}++import BNFC.CF hiding (App,Exp)+import BNFC.Backend.Haskell.HsOpts+import Control.Monad.RWS+import Control.Applicative hiding (Const)+import qualified Data.Map as M+import Data.List (nub,intercalate,sortBy,sort)+import Data.Maybe (maybeToList)+import Data.Function (on)+import Data.Char (isAlphaNum,ord)+import Data.String+import Data.Pair+import Text.PrettyPrint.HughesPJ hiding (first,(<>))++(f *** g) (a,b) = (f a, g b)+second g = id *** g++onRules f (CFG (exts,rules)) = CFG (exts,f rules)++toCNF cf0 = (cf1,cf2,units,descriptions,neighbors)+ where cf01@(CFG (exts01,_)) = funToExp . onRules delInternal $ cf0+ (rules',descriptions) = toBin (rulesOfCF cf01)+ cf1 = CFG (exts01,rules')+ cf2 = delNull cf1+ units = unitSet cf2+ neighbors = neighborSet cf2++funToExp :: CFG Fun -> CFG Exp+funToExp = fmap toExp++toExp f | isCoercion f = Id+ | otherwise = Con f++delInternal = filter (not . isInternalRhs . rhsRule)+ where isInternalRhs (Left c:_) = c == InternalCat+ isInternalRhs _ = False++isCat (Right _) = False+isCat (Left _) = True+++group0 :: Eq a => [(a,[b])] -> [(a,[b])]+group0 [] = []+group0 ((a,bs):xs) = (a,bs ++ concatMap snd ys) : group0 zs+ where (ys,zs) = span (\x -> fst x == a) xs++group' :: Ord a => [(a,[b])] -> [(a,[b])]+group' = group0 . sortBy (compare `on` fst)++catTag :: Either Cat String -> Doc+catTag (Left c) = "CAT_" <> text (concatMap escape (show c))+catTag (Right t) = "TOK_" <> text (concatMap escape t)++escape c | isAlphaNum c || c == '_' = [c]+escape '[' = ""+escape ']' = "_List"+escape '{' = "OPEN_"+escape '}' = "CLOS_"+escape '@' = "BIN_"+escape c = show $ ord c++punctuate' p = cat . punctuate p+--------------------------------------------------------------+-- BIN: make sure no rule has more than 2 symbols on the rhs++allocateCatName = do+ n <- get+ put (1+n)+ return $ show n++toBin :: [Rul Exp] -> ([Rul Exp], CatDescriptions)+toBin cf = (a,w)+ where (a,_,w) = runRWS (concat <$> forM cf toBinRul) () 0++type CatDescriptions = M.Map Cat Doc++-- | Convert a rule into a number of equivalent rules with at most 2+-- symbols on the rhs.+-- Also writes an explanation of what new categories are.+toBinRul :: Rul Exp -> RWS () CatDescriptions Int [Rul Exp]+toBinRul (Rule f cat rhs) | length rhs > 2 = do+ cat' <- liftM Cat allocateCatName+ r' <- toBinRul $ Rule f cat' p+ tell $ M.singleton cat' (int (length p) <> "-prefix of " <> prettyExp f <> " " <> parens (prettyRHS p))+ return $ Rule (Con "($)") cat [Left cat',l]+ : r'+ where l = last rhs+ p = init rhs+ fun' = case l of+ Left _ -> Con "($)" -- in this case we have to apply the final argument to the partial result+ Right _ -> Con "const" -- in this case the 2nd argument must be ignored (it is not present in the result).+toBinRul r = return [r]++prettyRHS = hcat . punctuate " " . map (either (text . show) (quotes . text))++---------------------------+-- Fixpoint utilities++x ∪ y = sort $ nub (x ++ y)++lookupMulti cat nullset = maybe [] id (M.lookup cat nullset)++type Set k x = M.Map k [x]++fixpointOnGrammar :: (Show k, Show x,Ord k, Ord x) => String -> (Set k x -> Rul f -> Set k x) -> CFG f -> Set k x+fixpointOnGrammar name f cf = case fixn 100 step M.empty of+ Left x -> error $ "Could not find fixpoint of " ++ name ++". Last iteration:\n" ++ show x+ Right x -> x+ where step curSet = M.unionsWith (∪) (map (f curSet) (rulesOfCF cf))++fixn :: Eq a => Int -> (a -> a) -> a -> Either a a+fixn 0 f x = Left x+fixn n f x = if x' == x then Right x else fixn (n-1) f x'+ where x' = f x++-------------------------------------------------------+-- DEL : make sure no rule has 0 symbol on the rhs++type Nullable = Set Cat Exp++cross :: [[a]] -> [[a]]+cross [] = [[]]+cross (x:xs) = [y:ys | y <- x, ys <- cross xs]++nullRule :: Nullable -> Rul Exp -> (Cat,[Exp])+nullRule nullset (Rule f c rhs) = (c, map (\xs -> (appMany f xs)) (cross (map nulls rhs)))+ where nulls (Right tok) = []+ nulls (Left cat) = lookupMulti cat nullset++nullable :: Nullable -> Rul Exp -> Bool+nullable s = not . null . snd . nullRule s++nullSet :: CFG Exp -> Nullable+nullSet = fixpointOnGrammar "nullable" (\s r -> uncurry M.singleton (nullRule s r))++-- | Replace nullable occurences by nothing, and adapt the function consequently.+delNullable :: Nullable -> Rul Exp -> [Rul Exp]+delNullable nullset r@(Rule f cat rhs) = case rhs of+ [] -> []+ [_] -> [r]+ [r1,r2] -> [r] ++ [Rule (app' f x) cat [r2] | x <- lk' r1]+ ++ [Rule (app2 (isCat r1) f x) cat [r1] | x <- lk' r2]+ _ -> error $ "Panic:" ++ show r ++ "should have at most two elements."+ where lk' (Right tok) = []+ lk' (Left cat) = lookupMulti cat nullset+++delNull cf = onRules (concatMap (delNullable (nullSet cf))) cf+++---------------+-- UNIT++type UnitRel cat = Set (Either cat String) (Exp,cat)++-- (c,(f,c')) ∈ unitSet ⇒ f : c → c'++unitSet :: CFG Exp -> UnitRel Cat+unitSet = fixpointOnGrammar "unit set" unitRule++unitRule unitSet (Rule f c [r]) = M.singleton r $ (f,c) : [(g `appl` f,c') | (g,c') <- lookupMulti (Left c) unitSet]+ where appl = case r of+ Left _ -> after+ Right _ -> app'+unitRule _ _ = M.empty++isUnitRule (Rule f c [r]) = True+isUnitRule _ = False+++------------------------+-- Left/Right occurences+type RHSEl = Either Cat String++isOnLeft, isOnRight :: RHSEl -> Rul f -> Bool+isOnLeft c (Rule f _ [c',_]) = c == c'+isOnLeft _ _ = False++isOnRight c (Rule f _ [_,c']) = c == c'+isOnRight _ _ = False++isEntryPoint cf el = either (`elem` allEntryPoints cf) (const False) el++occurs :: (RHSEl -> Rul f -> Bool) -> RHSEl -> CFG f -> Bool+occurs where_ el cf = any (where_ el) (rulesOfCF cf)++splitLROn :: (a -> RHSEl) -> CFG f -> [a] -> Pair [a]+splitLROn f cf xs = filt <*> pure xs+ where filt = filter (\c -> occurs isOnLeft (f c) cf || isEntryPoint cf (f c)) :/:+ filter (\c -> occurs isOnRight (f c) cf)++isSpecial (Left (Cat ('@':'@':_))) = True+isSpecial _ = False++optim :: (a -> RHSEl) -> Pair [a] -> Pair [(a,Doc -> Doc)]+optim f (x:/:y) = map modif x :/: map modif' y+ where modif a | isSpecial (f a) = (a,\x -> "(if not p then (" <> x <> ":) else id)")+ | otherwise = (a,rob)+ modif' a | isSpecial (f a) = (a,\x -> "(if p then (" <> x <> ":) else id)")+ | otherwise = (a,rob)+ rob x = "("<> x <> ":)"+++splitOptim f cf xs = optim f $ splitLROn f cf $ xs+++---------------------------+-- Error reporting++-- leftOf C = ⋃ { {X} ∪ leftOf X | C ::= X B ∈ Grammar or C ::= X ∈ Grammar }+leftRight pos s (Rule f c rhs) = M.singleton (show c) (lkCat x s)+ where x = pos rhs++lkCat (Right t) s = [Right t]+lkCat (Left c) s = Left c:lookupMulti (show c) s++-- neighbors A B = ∃ A' B'. P ::= A' B' ∧ A ∈ rightOf A' ∧ B ∈ leftOf B+neighborSet cf = map (second (nub . sort)) $ group' [(x',lkCat y leftSet) | Rule _ _ [x,y] <- rulesOfCF cf, x' <- lkCat x rightSet]+ where leftSet = fixpointOnGrammar "left set" (leftRight head) cf+ rightSet = fixpointOnGrammar "right set" (leftRight last) cf++data Exp = Id -- identity function+ | Con String -- constructor or variable+ | App Exp Exp+ | Exp `After` Exp+ | App2 Exp Exp+ deriving (Eq,Ord)++prettyExp Id = "id"+prettyExp (Con x) = text x+prettyExp (App f x) = prettyExp f <+> (parens $ prettyExp x)+prettyExp (App2 f x) = "flip" <+> parens (prettyExp f) <+> parens (prettyExp x)+prettyExp (f `After` g) = parens (prettyExp f) <> "." <> parens (prettyExp g)++instance Show Exp where show = render . prettyExp++-- | Apply in 2nd position if the flag is true, otherwise apply normally.+app2 True f x = App2 f x+app2 False f x = app' f x++infixl `app'`+app' :: Exp -> Exp -> Exp+app' (f `After` g) x = app' f (app' g x)+app' Id x = x+app' (App2 f y) x = (f `app'` x) `app'` y+app' (Con "($)") f = f+-- app' (Con "const") f = f+app' f x = App f x++after :: Exp -> Exp -> Exp+after Id f = f+after f Id = f+after f g = f `After` g++appMany f args = foldl app' f args
+ src/BNFC/TypeChecker.hs view
@@ -0,0 +1,146 @@++module BNFC.TypeChecker where++import Control.Monad+import Data.List+import Data.Char++import BNFC.CF+import ErrM++data Base = BaseT String+ | ListT Base+ deriving (Eq)++data Type = FunT [Base] Base+ deriving (Eq)++instance Show Base where+ show (BaseT x) = x+ show (ListT t) = "[" ++ show t ++ "]"++instance Show Type where+ show (FunT ts t) = unwords $ map show ts ++ ["->", show t]++data Context = Ctx { ctxLabels :: [(String, Type)]+ , ctxTokens :: [String]+ }++catchErr :: Err a -> (String -> Err a) -> Err a+catchErr (Bad s) f = f s+catchErr (Ok x) _ = Ok x++buildContext :: CF -> Context+buildContext cf@(CFG(_,rules)) =+ Ctx+ [ (f, mkType cat args) | Rule f cat args <- rules+ , not (isCoercion f)+ , not (isNilCons f)+ ]+ ("Ident" : tokenNames cf)+ where++ mkType cat args = FunT [ mkBase t | Left t <- args, t /= InternalCat ]+ (mkBase cat)+ mkBase t+ | isList t = ListT $ mkBase $ normCatOfList t+ | otherwise = BaseT $ show $ normCat t++isToken :: String -> Context -> Bool+isToken x ctx = elem x $ ctxTokens ctx++extendContext :: Context -> [(String,Type)] -> Context+extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx }++lookupCtx :: String -> Context -> Err Type+lookupCtx x ctx+ | isToken x ctx = return $ FunT [BaseT "String"] (BaseT x)+ | otherwise =+ case lookup x $ ctxLabels ctx of+ Nothing -> fail $ "Undefined symbol '" ++ x ++ "'."+ Just t -> return t++checkDefinitions :: CF -> Err ()+checkDefinitions cf =+ do checkContext ctx+ sequence_ [checkDefinition ctx f xs e | FunDef f xs e <- pragmasOfCF cf]+ where+ ctx = buildContext cf++checkContext :: Context -> Err ()+checkContext ctx =+ mapM_ checkEntry $ groupSnd $ ctxLabels ctx+ where+ -- This is a very handy function which transforms a lookup table+ -- with duplicate keys to a list valued lookup table with no duplicate+ -- keys.+ groupSnd :: Ord a => [(a,b)] -> [(a,[b])]+ groupSnd =+ map ((fst . head) /\ map snd)+ . groupBy ((==) **.* fst)+ . sortBy (compare **.* fst)++ (f /\ g) x = (f x, g x)+ (f **.* g) x y = f (g x) (g y)++ checkEntry (f,ts) =+ case nub ts of+ [_] -> return ()+ ts' ->+ fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" +++ unlines (map ((" " ++) . show) ts')++checkDefinition :: Context -> String -> [String] -> Exp -> Err ()+checkDefinition ctx f xs e =+ do checkDefinition' dummyConstructors ctx f xs e+ return ()++data ListConstructors = LC+ { nil :: Base -> String+ , cons :: Base -> String+ }++dummyConstructors :: ListConstructors+dummyConstructors = LC (const "[]") (const "(:)")++checkDefinition' :: ListConstructors -> Context -> String -> [String] -> Exp -> Err ([(String,Base)],(Exp,Base))+checkDefinition' list ctx f xs e =+ do unless (isLower $ head f) $ fail "Defined functions must start with a lowercase letter."+ t@(FunT ts t') <- lookupCtx f ctx `catchErr` \_ ->+ fail $ "'" ++ f ++ "' must be used in a rule."+ let expect = length ts+ given = length xs+ unless (expect == given) $ fail $ "'" ++ f ++ "' is used with type " ++ show t ++ " but defined with " ++ show given ++ " argument" ++ plural given ++ "."+ e' <- checkExp list (extendContext ctx $ zip xs (map (FunT []) ts)) e t'+ return (zip xs ts, (e', t'))+ `catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err+ where+ plural 1 = ""+ plural _ = "s"++checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp+checkExp list ctx (App "[]" []) (ListT t) = return (App (nil list t) [])+checkExp _ _ (App "[]" _) _ = fail $ "[] is applied to too many arguments."+checkExp list ctx (App "(:)" [e,es]) (ListT t) =+ do e' <- checkExp list ctx e t+ es' <- checkExp list ctx es (ListT t)+ return $ App (cons list t) [e',es']+checkExp _ _ (App "(:)" es) _ = fail $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "."+checkExp list ctx e@(App x es) t =+ do FunT ts t' <- lookupCtx x ctx+ es' <- matchArgs ctx es ts+ unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected."+ return $ App x es'+ where+ matchArgs ctx es ts+ | expect /= given = fail $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "."+ | otherwise = zipWithM (checkExp list ctx) es ts+ where+ expect = length ts+ given = length es+checkExp _ _ e@(LitInt _) (BaseT "Integer") = return e+checkExp _ _ e@(LitDouble _) (BaseT "Double") = return e+checkExp _ _ e@(LitChar _) (BaseT "Char") = return e+checkExp _ _ e@(LitString _) (BaseT "String") = return e+checkExp _ _ e t = fail $ show e ++ " does not have type " ++ show t ++ "."+
+ src/BNFC/Utils.hs view
@@ -0,0 +1,148 @@+{-+ BNF Converter: Abstract syntax+ Copyright (C) 2004 Author: Aarne Ranta++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License+ along with this program; if not, write to the Free Software+ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA+-}++module BNFC.Utils where++import Control.DeepSeq (rnf)+import Control.Monad (unless)+import System.IO (IOMode(ReadMode),hClose,hGetContents,openFile)+import System.IO.Error (tryIOError)+import System.Directory (createDirectory, doesDirectoryExist, renameFile,+ removeFile, doesFileExist)++import System.FilePath (pathSeparator)++infixr 5 ++++infixr 5 +++++infixr 5 +++++++-- printing operations++a +++ b = a ++ " " ++ b+a ++++ b = a ++ "\n" ++ b+a +++++ b = a ++ "\n\n" ++ b++prParenth s = if s == "" then "" else "(" ++ s ++ ")"++-- * List utilities++-- | Replace all occurences of a value by another value+replace :: Eq a =>+ a -- ^ Value to replace+ -> a -- ^ Value to replace it with+ -> [a] -> [a]+replace x y xs = [ if z == x then y else z | z <- xs]++-- | Split a list on the first occurence of a value.+-- Does not include the value that was split on in either+-- of the returned lists.+split :: Eq a => a -> [a] -> ([a],[a])+split x xs = let (ys, zs) = break (==x) xs+ in (ys, drop 1 zs)++-- | Split a list on every occurence of a value.+-- If the value does not occur in the list,+-- the result is the singleton list containing the input list.+-- Thus the returned list is never the empty list.+splitAll :: Eq a => a -> [a] -> [[a]]+splitAll _ [] = [[]]+splitAll x xs = let (ys, zs) = break (==x) xs+ in ys : case zs of+ [] -> []+ _:zs' -> splitAll x zs'++-- * File utilities++-- | Ensure that a directory exists.+prepareDir :: FilePath -> IO ()+prepareDir = mapM_ createDirectoryIfNotExists . pathInits++-- | Ensure that a directory exists. All parent directories+-- must already exist.+createDirectoryIfNotExists :: FilePath -> IO ()+createDirectoryIfNotExists d = do+ exists <- doesDirectoryExist d+ unless exists (createDirectory d)++-- | Like the prelude function 'inits' but for path names.+-- For example:+-- > pathInits "foo/bar" = ["foo","foo/bar"]+-- > pathInits "foo/bar/baz.hs" = ["foo","foo/bar","foo/bar/baz.hs"]+pathInits :: String -> [String]+pathInits "" = []+pathInits xs = let (ys,zs) = split pathSeparator xs+ in ys : map ((ys ++ [pathSeparator]) ++) (pathInits zs)++-- | Like basename(1), remove all leading directories from a path name.+-- basename :: String -> String+-- basename = last . splitAll pathSeparator+++-- | Write a file, after making a backup of an existing file with the same name.+writeFileRep :: FilePath -> String -> IO ()+writeFileRep = writeFileRep2++-- peteg: FIXME this is racey.+-- want to be a bit smarter about whether we actually generate the file+-- or save it... e.g. ErrM.hs need not be regenerated if it exists.+writeFileRep1 f s =+ do exists <- doesFileExist f+ backedUp <- if exists+ then do let fbak = f ++ ".bak"+ renameFile f fbak+ return $ " (saving old file as " ++ fbak ++ ")"+ else return ""+ putStrLn $ "writing file " ++ f ++ backedUp+ writeFile f s++-- New version by TH, 2010-09-23+-- If an old version of the file exist and the new version is the same,+-- keep the old file and don't create a .bak file.+writeFileRep2 :: FilePath -> String -> IO ()+writeFileRep2 path s =+ either newFile updateFile =<< tryIOError (readFile' path)+ where+ newFile _ =+ do putStrLn $ "writing new file "++path+ writeFile path s+ updateFile old =+ do let tmp=path++".tmp"+ writeFile tmp s+ new <- readFile' tmp+ if new==old -- test is O(1) space, O(n) time+ then do putStrLn $ "no change to file "++path+ removeFile tmp+ else do let bak=path++".bak"+ putStrLn $ "writing file "++path+ ++" (saving old file as "++bak++")"+ renameFile path bak+ renameFile tmp path++ -- force reading of contents of files to achieve compatibility with+ -- Windows IO handling as combining lazy IO with `readFile` and+ -- 2x `renameFile` on the open `path` file complains with+ -- "bnfc.exe: Makefile: MoveFileEx "Makefile" "Makefile.bak": permission+ -- denied (The process cannot access the file because it is being used+ -- by another process.)"+ readFile' :: FilePath -> IO String+ readFile' path =+ do inFile <- openFile path ReadMode+ contents <- hGetContents inFile+ rnf contents `seq` hClose inFile+ return contents
+ src/BNFC/WarningM.hs view
@@ -0,0 +1,26 @@+module BNFC.WarningM where++import qualified Control.Monad.Writer as W++-- Monad that allows pure computation to output+-- warnings+type WithWarnings a = W.Writer [String] a++-- Run the computation and return both the value+-- and the warnings+run :: WithWarnings a -> (a,[String])+run = W.runWriter++-- Run the computation and print the warnings+putWarnings :: WithWarnings a -> IO a+putWarnings c = do+ let (v,warnings) = run c+ mapM_ putStrLn warnings+ return v++hasWarnings :: WithWarnings a -> Bool+hasWarnings c = let (v,warnings) = run c in not (null warnings)++-- Output a warning+warn :: String -> WithWarnings ()+warn s = W.tell [s]
− src/CF.hs
@@ -1,605 +0,0 @@-{-# LANGUAGE PatternGuards, DeriveFunctor, StandaloneDeriving #-}-{-- BNF Converter: Abstract syntax- Copyright (C) 2004 Author: Markus Forberg, Michael Pellauer, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CF (- -- Types.- CF,- CFG(..), pragmasOfCF, -- ...- Rule, Rul(..), lookupRule,- Pragma(..),- Exp(..),- Literal,- Symbol,- KeyWord,- Cat,- Fun,- Tree(..),- prTree, -- print an abstract syntax tree- Data, -- describes the abstract syntax of a grammar- cf2data, -- translates a grammar to a Data object.- cf2dataLists, -- translates to a Data with List categories included.- -- Literal categories, constants,- firstCat, -- the first value category in the grammar.- firstEntry, -- the first entry or the first value category- specialCats, -- ident- specialCatsP, -- all literals- specialData, -- special data- isCoercion, -- wildcards in grammar (avoid syntactic clutter)- isDefinedRule, -- defined rules (allows syntactic sugar)- isProperLabel, -- not coercion or defined rule- allCats, -- all categories of a grammar- allCatsIdNorm,- allEntryPoints, - reservedWords, - cfTokens,- symbols, - literals, - reversibleCats, - findAllReversibleCats, -- find all reversible categories- identCat, -- transforms '[C]' to ListC (others, unchanged).- isParsable, - rulesOfCF, -- All rules of a grammar.- rulesForCat, -- rules for a given category- ruleGroups, -- Categories are grouped with their rules.- ruleGroupsInternals, --As above, but includes internal cats.- notUniqueNames, -- list of not unique names (replaces the following 2)--- notUniqueFuns, -- Returns a list of function labels that are not unique.--- badInheritence, -- Returns a list of all function labels that can cause problems in languages with inheritence.- isList, -- Checks if a category is a list category.- -- Information functions for list functions.- isNilFun, -- empty list function? ([])- isOneFun, -- one element list function? (:[])- hasOneFunc,- getCons,- isConsFun, -- constructor function? (:)- isNilCons, -- either three of above?- isEmptyListCat, -- checks if the list permits []- revSepListRule, -- reverse a rule, if it is of form C t [C].- normCat, - isDataCat,- normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C- listCat, - catOfList, - comments, -- translates the pragmas into two list containing the s./m. comments- tokenPragmas, - tokenNames, - precCat, -- get the precendence level of a Cat C1 => 1, C => 0- precLevels, -- get all precendence levels in the grammar, sorted in increasing order.- precRule, -- get the precendence level of the value category of a rule.- precCF, -- Check if the CF consists of precendence levels.- isUsedCat,- internalCat, - isPositionCat, - hasIdent,- hasLayout,- layoutPragmas,- - CFP, -- CF with profiles- RuleP,- FunP, - Prof,- cf2cfpRule,- cf2cfp,- cfp2cf,- trivialProf,- rulesOfCFP,- funRuleP, ruleGroupsP, allCatsP, allEntryPointsP- ) where--import Utils (prParenth,(+++))-import Data.List (nub, intersperse, partition, sort,sort,group,intercalate)-import Data.Char-import AbsBNF (Reg())---- | A context free grammar consists of a set of rules and some extended --- information (e.g. pragmas, literals, symbols, keywords)-type CF = CFG Fun---- | A rule consists of a function name, a main category and a sequence of--- terminals and non-terminals.--- function_name . Main_Cat ::= sequence-type Rule = Rul Fun ---- | Polymorphic rule type for common type signatures for CF and CFP-data Rul function = Rule { funRule :: function - -- ^ The function (semantic action) of a- -- rule. In order to be able to generate- -- data types this must be a constructor- -- (or an identity function).- , valCat :: Cat -- ^ The value category- , rhsRule :: [Either Cat String] - -- ^ The list of Terminals/NonTerminals in- -- the right-hand-side of a rule.- }- deriving (Eq,Functor)--instance (Show function) => Show (Rul function) where- show (Rule f cat rhs) = show f ++ ". " ++ cat ++ " ::= " ++ intercalate " " (map (either show id) rhs)---- | Polymorphic CFG type for common type signatures for CF and CFP-newtype CFG function = CFG { unCFG :: (Exts,[Rul function]) }- deriving (Functor)---instance (Show function) => Show (CFG function) where - show (CFG (_,rules)) = unlines $ map show rules--type Exts = ([Pragma],Info)---- | Info is information extracted from the CF, for easy access.--- Literals - Char, String, Ident, Integer, Double--- Strings are quoted strings, and Ident are unquoted.--- Symbols - symbols in the grammar, e.g. ´*´, '->'.--- KeyWord - reserved words, e.g. 'if' 'while'-type Info = ([Literal],[Symbol],[KeyWord],[Cat])---- Expressions for function definitions-data Exp = App String [Exp]- | LitInt Integer- | LitDouble Double- | LitChar Char- | LitString String- deriving (Eq)--instance Show Exp where- showsPrec p e =- case listView e of- Right es ->- showString "["- . foldr (.) id (intersperse (showString ", ") $ map shows es)- . showString "]"- Left (App x []) -> showString x- Left (App "(:)" [e1,e2]) ->- showParen (p>0)- $ showsPrec 1 e1- . showString " : "- . shows e2- Left (App x es) ->- showParen (p>1)- $ foldr (.) id- $ intersperse (showString " ")- $ showString x : map (showsPrec 2) es- Left (LitInt n) -> shows n- Left (LitDouble x) -> shows x- Left (LitChar c) -> shows c- Left (LitString s) -> shows s- where- listView (App "[]" []) = Right []- listView (App "(:)" [e1,e2])- | Right es <- listView e2 = Right $ e1:es- listView e = Left e---- | Pragmas -data Pragma = CommentS String -- ^ for single line comments- | CommentM (String,String) -- ^ for multiple-line comments. - | TokenReg String Bool Reg -- ^ for tokens- | EntryPoints [Cat]- | Layout [String]- | LayoutStop [String]- | LayoutTop- | FunDef String [String] Exp- -- ...- deriving (Show)---- | User-defined regular expression tokens-tokenPragmas :: CFG f -> [(String,Reg)]-tokenPragmas cf = [(name,exp) | TokenReg name _ exp <- pragmasOfCF cf]---- | The names of all user-defined tokens-tokenNames :: CFG f -> [String]-tokenNames cf = map fst (tokenPragmas cf)--layoutPragmas :: CF -> (Bool,[String],[String])-layoutPragmas cf = let ps = pragmasOfCF cf in (- not (null [() | LayoutTop <- ps]), -- if there's layout betw top-level- concat [ss | Layout ss <- ps], -- layout-block starting words- concat [ss | LayoutStop ss <- ps] -- layout-block ending words- )--hasLayout :: CF -> Bool-hasLayout cf = case layoutPragmas cf of- (t,ws,_) -> t || not (null ws) -- (True,[],_) means: top-level layout only---- | Literal: Char, String, Ident, Integer, Double-type Literal = Cat-type Symbol = String-type KeyWord = String---- | Cat is the Non-terminals of the grammar.-type Cat = String--- | Fun is the function name of a rule. -type Fun = String--- | Either Cat or Fun-type Name = String---- | The category '#'. It is inserted in 1st position in "internal"--- rules, essentially ensuring that they are never parsed.-internalCat :: Cat-internalCat = "#"----- | Abstract syntax tree.-newtype Tree = Tree (Fun,[Tree])---- | The abstract syntax of a grammar.-type Data = (Cat, [(Fun,[Cat])])---- | firstCat returns the first Category appearing in the grammar.-firstCat :: CF -> Cat-firstCat = valCat . head . rulesOfCF--firstEntry :: CF -> Cat-firstEntry cf = case allEntryPoints cf of - (x:_) -> x- _ -> firstCat cf--rulesOfCF :: CFG f -> [Rul f]-rulesOfCFP :: CFP -> [RuleP]-infoOfCF :: CFG f -> Info-pragmasOfCF :: CFG f -> [Pragma]--rulesOfCF = snd . unCFG-rulesOfCFP = rulesOfCF-infoOfCF = snd . fst . unCFG-pragmasOfCF = fst . fst . unCFG---- aggressively ban nonunique names (AR 31/5/2012)--notUniqueNames :: [Name] -> CF -> [Fun]-notUniqueNames reserved cf = [head xs | xs <- xss, length xs > 1] where- xss = group (sort names)- names = reserved ++ allCatsIdNorm cf ++ allFuns cf- allFuns g = [ f | f <- map funRule (rulesOfCF g), not (isNilCons f || isCoercion f)]--{-# DEPRECATED notUniqueFuns "obsolete" #-}-notUniqueFuns :: CF -> [Fun]-notUniqueFuns cf = let xss = group $ sort [ f | f <- map funRule (rulesOfCF cf),- not (isNilCons f || isCoercion f)]- in [ head xs | xs <- xss, length xs > 1]--badInheritence :: CF -> [Cat]-badInheritence cf = concatMap checkGroup (ruleGroups cf)- where- checkGroup (cat, rs) = if (length rs <= 1)- then []- else case lookupRule cat rs of- Nothing -> []- Just x -> [cat]---- extract the comment pragmas.-commentPragmas :: [Pragma] -> [Pragma]-commentPragmas = filter isComment- where isComment (CommentS _) = True- isComment (CommentM _) = True- isComment _ = False--lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat String])-lookupRule f = lookup f . map unRule- where unRule (Rule f c rhs) = (f,(c,rhs))---- | Returns all normal rules that constructs the given Cat.-rulesForCat :: CF -> Cat -> [Rule]-rulesForCat cf cat = [normRuleFun r | r <- rulesOfCF cf, isParsable r, valCat r == cat] ---- | As rulesForCat, but this version doesn't exclude internal rules.-rulesForCat' :: CF -> Cat -> [Rule]-rulesForCat' cf cat = [normRuleFun r | r <- rulesOfCF cf, valCat r == cat] ---- | Get all categories of a grammar. (No Cat w/o production returned; No duplicates)-allCats :: CFG f -> [Cat]-allCats = nub . map valCat . rulesOfCF ---- | Gets all normalized identified Categories-allCatsIdNorm :: CF -> [Cat]-allCatsIdNorm = nub . map identCat . map normCat . allCats---- | Is the category is used on an rhs?-isUsedCat :: CFG f -> Cat -> Bool-isUsedCat cf cat = elem cat [c | r <- (rulesOfCF cf), Left c <- rhsRule r]---- | Group all categories with their rules.-ruleGroups :: CF -> [(Cat,[Rule])]-ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf]---- | Group all categories with their rules including internal rules. -ruleGroupsInternals :: CF -> [(Cat,[Rule])]-ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf]---- | Get all literals of a grammar. (e.g. String, Double)-literals :: CFG f -> [String]-literals cf = lits ++ owns- where - (lits,_,_,_) = infoOfCF cf- owns = tokenNames cf--{-# DEPRECATED symbols, reservedWords "Almost certainly, you should treat symbols and reserved words uniformly, so use cfTokens instead." #-}---- | Get all symbols-symbols :: CFG f -> [String]-symbols cf = syms- where (_,syms,_,_) = infoOfCF cf---- | Get the keywords of a grammar. -reservedWords :: CFG f -> [String]-reservedWords cf = sort keywords- where (_,_,keywords,_) = infoOfCF cf---- | Canonical, numbered list of symbols and reserved words. (These do--- not end up in the AST.)-cfTokens :: CFG f -> [(String,Int)]-cfTokens cf = zip (sort (symbols cf ++ reservedWords cf)) [1..]--- NOTE: some backends (incl. Haskell) assume that this list is sorted.---- | Categories that is left-recursive transformable.-reversibleCats :: CFG f -> [Cat]-reversibleCats cf = cats - where (_,_,_,cats) = infoOfCF cf---- | Comments can be defined by the 'comment' pragma-comments :: CF -> ([(String,String)],[String])-comments cf = case commentPragmas (pragmasOfCF cf) of- xs -> ([p | CommentM p <- xs],- [s | CommentS s <- xs])---- built-in categories (corresponds to lexer)---- | Whether the grammar uses the predefined Ident type.-hasIdent :: CFG f -> Bool-hasIdent cf = isUsedCat cf "Ident"----- these need new datatypes---- | Categories corresponding to tokens. These end up in the--- AST. (unlike tokens returned by 'cfTokens')-specialCats :: CF -> [Cat]-specialCats cf = (if hasIdent cf then ("Ident":) else id) (tokenNames cf)---- the parser needs these-specialCatsP :: [Cat]-specialCatsP = words "Ident Integer String Char Double"---- to print parse trees-prTree :: Tree -> String-prTree (Tree (fun,[])) = fun -prTree (Tree (fun,trees)) = fun +++ unwords (map pr2 trees) where- pr2 t@(Tree (_,ts)) = (if (null ts) then id else prParenth) (prTree t)---- abstract syntax trees: data type definitions--cf2data' :: (Cat -> Bool) -> CF -> [Data]-cf2data' predicate cf = - [(cat, nub (map mkData [r | r <- rulesOfCF cf,- let f = funRule r,- not (isDefinedRule f),- not (isCoercion f), eqCat cat (valCat r)])) - | cat <- filter predicate (allCats cf)] - where- mkData (Rule f _ its) = (normFun f,[normCat c | Left c <- its, c /= internalCat])--cf2data :: CF -> [Data]-cf2data = cf2data' isDataCat- --- | Does the category correspond to a data type?-isDataCat c = isDataOrListCat c && not (isList c)--isDataOrListCat c = not (isDigit (last c) || head c == '@')--cf2dataLists :: CF -> [Data]-cf2dataLists = cf2data' isDataOrListCat--specialData :: CF -> [Data]-specialData cf = [(c,[(c,[arg c])]) | c <- specialCats cf] where- arg c = case c of - _ -> "String"----- to deal with coercions---- the Haskell convention: the wildcard _ is not a constructor---- | Is this function just a coercion? (Ie. the identity)-isCoercion :: Fun -> Bool-isCoercion = (== "_") -- perhaps this should be changed to "id"?--isDefinedRule :: Fun -> Bool-isDefinedRule (x:_) = isLower x--isProperLabel :: Fun -> Bool-isProperLabel f = not (isCoercion f || isDefinedRule f)---- categories C1, C2,... (one digit in end) are variants of C--eqCat :: Cat -> Cat -> Bool-eqCat c c1 = catCat c == catCat c1- where catCat :: Cat -> Cat- catCat = fst . analyseCat------ | Removes precendence information. C1 => C, [C2] => [C]-normCat :: Cat -> Cat-normCat c = case c of- '[':cs -> "[" ++ norm (init cs) ++ "]"- _ -> unList $ norm c -- to be deprecated- where- norm = reverse . dropWhile isDigit . reverse--normCatOfList :: Cat -> Cat-normCatOfList = normCat . catOfList---- | When given a list Cat, i.e. '[C]', it removes the square--- brackets, and adds the prefix List, i.e. 'ListC'. (for Happy and--- Latex)-identCat :: Cat -> Cat-identCat c = case c of- '[':cs -> "List" ++ identCat (init cs)- _ -> c--{-# DEPRECATED normFun "It's just the identity function" #-}-normFun :: Fun -> Fun-normFun = id -- takeWhile (not . isDigit)--normRuleFun :: Rule -> Rule-normRuleFun (Rule f p rhs) = Rule (normFun f) p rhs----- | Checks if the rule is parsable.-isParsable :: Rul f -> Bool-isParsable (Rule _ _ (Left c:_)) = c /= internalCat-isParsable _ = True--isList :: Cat -> Bool-isList c = head c == '[' --{-# DEPRECATED unList "It's just the identity function" #-}-unList :: Cat -> Cat-unList c = c---- | Adds list constructor-listCat :: Cat -> Cat-listCat c = "[" ++ c ++ "]"---- | Unwraps the list constructor from the category name. Eg. [C1] => C1-catOfList :: Cat -> Cat-catOfList c = case c of- '[':_:_ -> init (tail c)- _ -> c--isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: Fun -> Bool-isNilCons f = isNilFun f || isOneFun f || isConsFun f || isConcatFun f-isNilFun f = f == "[]" -isOneFun f = f == "(:[])" -isConsFun f = f == "(:)" -isConcatFun f = f == "(++)" ---- | Checks if the list has a non-empty rule.-hasOneFunc :: [Rule] -> Bool-hasOneFunc = any (isOneFun . funRule) ---- | Gets the separator for a list.-getCons :: [Rule] -> String-getCons (Rule f c cats:rs) =- if isConsFun f- then seper cats- else getCons rs- where- seper [] = []- seper ((Right x):xs) = x- seper ((Left x):xs) = seper xs---isEmptyListCat :: CF -> Cat -> Bool-isEmptyListCat cf c = elem "[]" $ map funRule $ rulesForCat' cf c--isNonterm = either (const True) (const False)---- used in Happy to parse lists of form 'C t [C]' in reverse order--- applies only if the [] rule has no terminals-revSepListRule :: Rul f -> Rul f-revSepListRule (Rule f c ts) = Rule f c (xs : x : sep) where- (x,sep,xs) = (head ts, init (tail ts), last ts) --- invariant: test in findAllReversibleCats have been performed--findAllReversibleCats :: CF -> [Cat]-findAllReversibleCats cf = [c | (c,r) <- ruleGroups cf, isRev c r] where- isRev c rs = case rs of- [r1,r2] | isList c -> if isConsFun (funRule r2) - then tryRev r2 r1- else if isConsFun (funRule r1) - then tryRev r1 r2- else False- _ -> False- tryRev (Rule f _ ts@(x:_:xs)) r = isEmptyNilRule r && - isConsFun f && isNonterm x && isNonterm (last ts)- tryRev _ _ = False--isEmptyNilRule (Rule f _ ts) = isNilFun f && null ts--precCat :: Cat -> Int-precCat = snd . analyseCat--precRule :: Rule -> Int-precRule = precCat . valCat--precLevels :: CF -> [Int]-precLevels cf = sort $ nub $ [ precCat c | c <- allCats cf]--precCF :: CF -> Bool-precCF cf = length (precLevels cf) > 1---analyseCat :: Cat -> (Cat,Int)-analyseCat c = if (isList c) then list c else noList c- where- list cat = let (rc,n) = noList (init (tail cat)) in (listCat rc,n)- noList cat = case span isDigit (reverse cat) of- ([],c') -> (reverse c', 0)- (d,c') -> (reverse c', read (reverse d))----- | Does the category have a position stored in AST?-isPositionCat :: CFG f -> Cat -> Bool-isPositionCat cf cat = or [b | TokenReg name b _ <- pragmasOfCF cf, name == cat]----- | Grammar with permutation profile à la GF. AR 22/9/2004-type CFP = CFG FunP -- (Exts,[RuleP])-type FunP = (Fun,Prof)-type RuleP = Rul FunP -- (FunP, (Cat, [Either Cat String]))---- | Pair of: the original function name, profile-type Prof = (Fun, [([[Int]],[Int])]) --cf2cfp :: CF -> CFP-cf2cfp (CFG (es,rs)) = CFG (es, map cf2cfpRule rs)--cf2cfpRule :: Rule -> RuleP-cf2cfpRule (Rule f c its) = Rule (f, (f, trivialProf its)) c its--cfp2cf :: CFP -> CF-cfp2cf = fmap fst--trivialProf :: [Either Cat String] -> [([[Int]],[Int])]-trivialProf its = [([],[i]) | (i,_) <- zip [0..] [c | Left c <- its]]--{-# DEPRECATED rulesOfCFP, allCatsP, allEntryPointsP "Use the version without P postfix instead" #-}--funRuleP :: RuleP -> Fun-funRuleP = fst . funRule--ruleGroupsP :: CFP -> [(Cat,[RuleP])]-ruleGroupsP cf = [(c, rulesForCatP cf c) | c <- allCatsP cf]--rulesForCatP :: CFP -> Cat -> [RuleP]-rulesForCatP cf cat = [r | r <- rulesOfCFP cf, isParsable r, valCat r == cat] --allCatsP :: CFP -> [Cat]-allCatsP = allCats----- | Categories that are entry points to the parser-allEntryPoints :: CFG f -> [Cat]-allEntryPoints cf = case concat [cats | EntryPoints cats <- pragmasOfCF cf] of- [] -> allCats cf- cs -> cs--allEntryPointsP :: CFP -> [Cat]-allEntryPointsP = allEntryPoints
src/ErrM.hs view
@@ -7,6 +7,7 @@ -- the Error monad: like Maybe type with error msgs import Control.Monad (MonadPlus(..), liftM)+import Control.Applicative (Applicative(..), Alternative(..)) data Err a = Ok a | Bad String deriving (Read, Show, Eq, Ord)@@ -17,6 +18,11 @@ Ok a >>= f = f a Bad s >>= f = Bad s +instance Applicative Err where+ pure = Ok+ (Bad s) <*> _ = Bad s+ (Ok f) <*> o = liftM f o+ instance Functor Err where fmap = liftM @@ -24,3 +30,7 @@ mzero = Bad "Err.mzero" mplus (Bad _) y = y mplus x _ = x++instance Alternative Err where+ empty = mzero+ (<|>) = mplus
− src/GetCF.hs
@@ -1,373 +0,0 @@-{-- BNF Converter: Abstract syntax- Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---module GetCF(tryReadCFP) where--import Control.Monad ( when )--import CF-import Utils-import ParBNF-import Data.List(nub,partition)-import qualified AbsBNF as Abs-import Data.Maybe (catMaybes)-import Data.Either (partitionEithers)-import ErrM-import Data.Char-import TypeChecker-import Options--readCF :: SharedOptions -> FilePath -> IO CFP-readCF opts f = tryReadCFP opts f >>= return . fst--tryReadCFP :: SharedOptions -> FilePath -> IO (CFP,Bool)-tryReadCFP opts file = do- putStrLn $ "\nReading grammar from " ++ file- s <- readFile file- let (cfp,msgs1) = getCFP (cnf opts) s- cf = cfp2cf cfp- msgs2 = case checkDefinitions cf of- Bad err -> [err]- Ok () -> []- msgs3 = checkTokens cf- msg = msgs1++msgs2 -- ++ msgs3 -- in a future version- ret = cfp-- let reserved = if anyTarget opts [TargetJava,TargetJava15] - then [takeWhile (/='.') file] else []- case filter (not . isDefinedRule) $ notUniqueNames reserved cf of- ns@(_:_) - | not (anyTarget opts [TargetHaskell,TargetHaskellGADT,TargetOCAML]) -> do- putStrLn $ "ERROR: names not unique: " ++ unwords ns- return (ret,False)- ns -> do- case ns of- _:_ -> do- putStrLn $ "Warning: names not unique: " ++ unwords ns- putStrLn "This can be an error in other back ends."- _ -> return ()- putStrLn $ unlines msgs3- if not (null msg) then do- putStrLn $ unlines msg- return (ret,False)- else do- putStrLn $ show (length (rulesOfCF cf)) +++ "rules accepted\n"- let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2]- if null c3s then return () else do- putStrLn - "Warning: comment delimiters longer than 2 characters ignored in Haskell:"- mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s]- return (ret,True)--{-- case filter (not . isDefinedRule) $ notUniqueFuns cf of- [] -> case (badInheritence cf) of- [] -> return (ret,True)- xs -> do- putStrLn "Warning :"- putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs- putStrLn $ " These categories have more than one Label, yet one of these"- putStrLn $ " Labels has the same name as the Category. This will almost"- putStrLn $ " certainly cause problems in languages other than Haskell.\n"- return (ret,True)- xs -> do - putStrLn $ "Warning :" - putStrLn $ " Non-unique label name(s) : " ++ unwords xs- putStrLn $ " There may be problems with the pretty-printer.\n"- case (badInheritence cf) of- [] -> return (ret,True)- xs -> do- putStrLn $ "Warning :"- putStrLn $ " Bad Label name in Category(s) :" ++ unwords xs- putStrLn $ " These categories have more than one Label, yet one of these"- putStrLn $ " Labels has the same name as the Category. This will almost"- putStrLn $ " certainly cause problems in languages other than Haskell.\n"- return (ret,True)--}--nilCFP :: CFP-nilCFP = CFG (([],([],[],[],[])),[])--getCFP :: Bool -> String -> (CFP,[String])-getCFP cnf s = case pGrammar . myLexer $ s of- Bad s -> (nilCFP,[s])- Ok (Abs.Grammar defs) -> (cf0,msgs)- where (pragma,rules) = partitionEithers $ concatMap (transDef cnf) defs- msgs = catMaybes $ map (checkRule (cfp2cf cf0)) (rulesOfCF cf0)- cf0 = revs srt - srt = let literals = nub [lit | xs <- map rhsRule rules,- Left lit <- xs,- elem lit specialCatsP]- (symbols,keywords) = partition notIdent reservedWords- notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s- isIdentRest c = isAlphaNum c || c == '_' || c == '\''- reservedWords = nub [t | r <- rules, Right t <- rhsRule r]- in CFG((pragma,(literals,symbols,keywords,[])),rules)- revs cf1@(CFG((pragma,(literals,symbols,keywords,_)),rules)) =- CFG((pragma,(literals,symbols,keywords,findAllReversibleCats (cfp2cf cf1))),rules)--transDef :: Bool -> Abs.Def -> [Either Pragma RuleP]-transDef cnf x = case x of- Abs.Rule label cat items -> - [Right $ Rule (transLabel label) (transCat cat) (map transItem items)]- Abs.Comment str -> [Left $ CommentS str]- Abs.Comments str0 str -> [Left $ CommentM (str0,str)]- Abs.Token ident reg -> [Left $ TokenReg (transIdent ident) False reg]- Abs.PosToken ident reg -> [Left $ TokenReg (transIdent ident) True reg]- Abs.Entryp idents -> [Left $ EntryPoints (map transIdent idents)]- Abs.Internal label cat items -> - [Right $ Rule (transLabel label) (transCat cat) (Left internalCat:(map transItem items))]- Abs.Separator size ident str -> map (Right . cf2cfpRule) $ separatorRules size ident str- Abs.Terminator size ident str -> map (Right . cf2cfpRule) $ terminatorRules size ident str- Abs.Delimiters a b c d e -> map (Right . cf2cfpRule) $ delimiterRules cnf a b c d e- Abs.Coercions ident int -> map (Right . cf2cfpRule) $ coercionRules ident int- Abs.Rules ident strs -> map (Right . cf2cfpRule) $ ebnfRules ident strs- Abs.Layout ss -> [Left $ Layout ss]- Abs.LayoutStop ss -> [Left $ LayoutStop ss]- Abs.LayoutTop -> [Left $ LayoutTop]- Abs.Function f xs e -> [Left $ FunDef (transIdent f) (map transArg xs) (transExp e)]----delimiterRules :: Bool -> Abs.Cat -> String -> String -> Abs.Separation -> Abs.MinimumSize -> [Rule]-delimiterRules False a0 l r sep size = [- Rule "_" as [Right l, Left (listCat x), Right r]- ] ++ separationRules (Abs.IdCat $ Abs.Ident $ x) sep size- where - a = transCat a0- as = listCat a- x = a ++ "_without_delimiters"-delimiterRules True a0 l r (Abs.SepTerm "") size = delimiterRules True a0 l r Abs.SepNone size-delimiterRules True a0 l r (Abs.SepSepar "") size = delimiterRules True a0 l r Abs.SepNone size-delimiterRules True a0 l r sep size = [- -- recognizing a single element- Rule "(:[])" a' (Left a : termin), -- optional terminator/separator- - -- glueing two sublists- Rule "(++)" a' [Left a', Left a'],- - -- starting on either side with a delimiter- Rule "[]" c [Right l],- Rule (if optFinal then "(:[])" else- "[]") - d ([Left a | optFinal] ++ [Right r]),- - -- gathering chains- Rule "(++)" c [Left c, Left a'],- Rule "(++)" d [Left a', Left d],- - -- finally, put together left and right chains- Rule "(++)" as [Left c,Left d]] ++ [- -- special rule for the empty list if necessary- Rule "[]" as [Right l,Right r] | optEmpty] - where a = transCat a0- as = listCat a- a' = '@':'@':a- c = '@':'{':a- d = '@':'}':a- -- optionally separated concat. of x and y categories.- x // y = (Left x :- [Right t | Abs.SepSepar t <- [sep]] ++ - [Left y ])- termin = case sep of- Abs.SepSepar t -> [Right t]- Abs.SepTerm t -> [Right t]- _ -> []- optFinal = case (sep,size) of- (Abs.SepSepar t,_) -> True- (Abs.SepTerm _,Abs.MNonempty) -> True- (Abs.SepNone,Abs.MNonempty) -> True- _ -> False- optEmpty = case sep of- Abs.SepSepar _ -> size == Abs.MEmpty- _ -> False-- -separationRules :: Abs.Cat -> Abs.Separation -> Abs.MinimumSize -> [Rule]-separationRules c Abs.SepNone size = terminatorRules size c "" -separationRules c (Abs.SepTerm t) size = terminatorRules size c t-separationRules c (Abs.SepSepar t) size = separatorRules size c t---separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]-separatorRules size c s = if null s then terminatorRules size c s else ifEmpty [- Rule "(:[])" cs [Left c'],- Rule "(:)" cs [Left c', Right s, Left cs]- ]- where - c' = transCat c- cs = listCat c'- ifEmpty rs = if (size == Abs.MNonempty)- then rs- else Rule "[]" cs [] : rs--terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> [Rule]-terminatorRules size c s = [- ifEmpty,- Rule "(:)" cs (Left c' : s' [Left cs])- ]- where - c' = transCat c- cs = listCat c'- s' its = if null s then its else (Right s : its)- ifEmpty = if (size == Abs.MNonempty) - then Rule "(:[])" cs ([Left c'] ++ if null s then [] else [Right s])- else Rule "[]" cs []--coercionRules :: Abs.Ident -> Integer -> [Rule]-coercionRules (Abs.Ident c) n = - Rule "_" c [Left (c ++ "1")] :- [(Rule "_" (c ++ show (i-1)) [Left (c ++ show i)]) | i <- [2..n]] ++- [(Rule "_" (c ++ show n) [Right "(", Left c, Right ")"])]--ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule]-ebnfRules (Abs.Ident c) rhss = - [Rule (mkFun k c its) c (map transItem its)- | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss]- where- mkFun k c i = case i of- [Abs.Terminal s] -> c' ++ "_" ++ mkName k s- [Abs.NTerminal n] -> c' ++ identCat (transCat n)- _ -> c' ++ "_" ++ show k- c' = c --- normCat c- mkName k s = if all (\c -> isAlphaNum c || elem c "_'") s - then s else show k--transItem :: Abs.Item -> Either Cat String-transItem x = case x of- Abs.Terminal str -> Right str- Abs.NTerminal cat -> Left (transCat cat)--transCat :: Abs.Cat -> Cat-transCat x = case x of- Abs.ListCat cat -> "[" ++ (transCat cat) ++ "]"- Abs.IdCat id -> transIdent id--transLabel :: Abs.Label -> (Fun,Prof)-transLabel y = case y of- Abs.LabNoP f -> let g = transLabelId f in (g,(g,[])) ---- should be Nothing- Abs.LabP f p -> let g = transLabelId f in (g,(g, map transProf p))- Abs.LabPF f g p -> (transLabelId f,(transLabelId g, map transProf p))- Abs.LabF f g -> (transLabelId f,(transLabelId g, []))- where- transLabelId x = case x of- Abs.Id id -> transIdent id- Abs.Wild -> "_"- Abs.ListE -> "[]"- Abs.ListCons -> "(:)"- Abs.ListOne -> "(:[])"- transProf (Abs.ProfIt bss as) = - ([map fromInteger bs | Abs.Ints bs <- bss], map fromInteger as)--transIdent :: Abs.Ident -> String-transIdent x = case x of- Abs.Ident str -> str--transArg :: Abs.Arg -> String-transArg (Abs.Arg x) = transIdent x--transExp :: Abs.Exp -> Exp-transExp e = case e of- Abs.App x es -> App (transIdent x) (map transExp es)- Abs.Var x -> App (transIdent x) []- Abs.Cons e1 e2 -> cons e1 (transExp e2)- Abs.List es -> foldr cons nil es- Abs.LitInt x -> LitInt x- Abs.LitDouble x -> LitDouble x- Abs.LitChar x -> LitChar x- Abs.LitString x -> LitString x- where- cons e1 e2 = App "(:)" [transExp e1, e2]- nil = App "[]" []--------------------------------------------------------------------------------------checkTokens :: CFG f -> [String]-checkTokens cf =- if null ns- then []- else ["Warning : ", -- change to error in a future version- " The following tokens accept the empty string: ",- " "++unwords ns,- " This is error-prone and will not be supported in the future."]- where- ns = map fst . filter (nullable.snd) $ tokenPragmas cf---- | Check if a regular expression is nullable (accepts the empty string)-nullable :: Abs.Reg -> Bool-nullable r =- case r of- Abs.RSeq r1 r2 -> nullable r1 && nullable r2- Abs.RAlt r1 r2 -> nullable r1 || nullable r2- Abs.RMinus r1 r2 -> nullable r1 && not (nullable r2)- Abs.RStar _ -> True- Abs.RPlus r1 -> nullable r1- Abs.ROpt _ -> True- Abs.REps -> True- Abs.RChar _ -> False- Abs.RAlts _ -> False- Abs.RSeqs s -> null s- Abs.RDigit -> False- Abs.RLetter -> False- Abs.RUpper -> False- Abs.RLower -> False- Abs.RAny -> False----- we should actually check that --- (1) coercions are always between variants--- (2) no other digits are used--checkRule :: CF -> RuleP -> Maybe String-checkRule cf (Rule _ ('@':_) rhs) = Nothing -- Generated by a pragma; it's a trusted category-checkRule cf (Rule (f,_) cat rhs)- | badCoercion = Just $ "Bad coercion in rule" +++ s- | badNil = Just $ "Bad empty list rule" +++ s- | badOne = Just $ "Bad one-element list rule" +++ s- | badCons = Just $ "Bad list construction rule" +++ s- | badList = Just $ "Bad list formation rule" +++ s- | badSpecial = Just $ "Bad special category rule" +++ s- | badTypeName = Just $ "Bad type name" +++ unwords badtypes +++ "in" +++ s- | badFunName = Just $ "Bad constructor name" +++ f +++ "in" +++ s- | badMissing = Just $ "No production for" +++ unwords missing ++- ", appearing in rule" +++ s- | otherwise = Nothing- where- s = f ++ "." +++ cat +++ "::=" +++ unwords (map (either id show) rhs) -- Todo: consider using the show instance of Rule- c = normCat cat- cs = [normCat c | Left c <- rhs]- badCoercion = isCoercion f && not ([c] == cs)- badNil = isNilFun f && not (isList c && null cs)- badOne = isOneFun f && not (isList c && cs == [catOfList c])- badCons = isConsFun f && not (isList c && cs == [catOfList c, c])- badList = isList c && - not (isCoercion f || isNilCons f)- badSpecial = elem c specialCatsP && not (isCoercion f)-- badMissing = not (null missing)- missing = filter nodef [c | Left c <- rhs] - nodef t = notElem t defineds- defineds =- internalCat : tokenNames cf ++ specialCatsP ++ map valCat (rulesOfCF cf) - badTypeName = not (null badtypes)- badtypes = filter isBadType $ cat : [c | Left c <- rhs]- isBadType c = not (isUpper (head c) || isList c || c == internalCat || (head c == '@') )- badFunName = not (all (\c -> isAlphaNum c || c == '_') f {-isUpper (head f)-}- || isCoercion f || isNilCons f)
src/LexBNF.x view
@@ -2,6 +2,7 @@ -- This Alex file was machine-generated by the BNF converter { {-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -w #-} module LexBNF where @@ -146,7 +147,7 @@ alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (p, c, bs, s) = c - -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.+-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. utf8Encode :: Char -> [Word8] utf8Encode = map fromIntegral . go . ord where
src/Main.hs view
@@ -1,7 +1,12 @@ {- BNF Converter: Main file- Copyright (C) 2002-2010 Authors: - Björn Bringert, Johan Broberg, Markus Forberg, Peter Gammie, + Copyright (C) 2002-2013 Authors:+ Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Paul Callaghan,+ Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Patrik Jansson,+ Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell,+ Michael Pellauer and Aarne Ranta 2002 - 2013.++ Björn Bringert, Johan Broberg, Markus Forberg, Peter Gammie, Patrik Jansson, Antti-Juhani Kaijanaho, Ulf Norell, Michael Pellauer, Aarne Ranta @@ -24,24 +29,23 @@ module Main where -- import Utils-import CF (cfp2cf)-import HaskellTop-import HaskellTopGADT-import ProfileTop-import JavaTop-import JavaTop15-import CPPTop-import CSharpTop-import STLTop-import CTop-import OCamlTop-import FSharpTop-import CFtoXML-import Utils-import Options-import GetCF+import BNFC.CF (cfp2cf)+import BNFC.Backend.Base hiding (Backend)+import BNFC.Backend.Latex+import BNFC.Backend.Haskell+import BNFC.Backend.HaskellGADT+import BNFC.Backend.HaskellProfile+import BNFC.Backend.Java+import BNFC.Backend.CPP.NoSTL+import BNFC.Backend.CSharp+import BNFC.Backend.CPP.STL+import BNFC.Backend.C+import BNFC.Backend.OCaml+import BNFC.Backend.XML+import BNFC.Utils+import BNFC.GetCF -import MultiView (preprocessMCF, mkTestMulti, mkMakefileMulti)+import BNFC.MultiView (preprocessMCF, mkTestMulti, mkMakefileMulti) import System.Environment (getEnv,getArgs ) import System.Exit (exitFailure,exitSuccess)@@ -49,177 +53,39 @@ import Data.Char import Data.List (elemIndex, foldl') import Control.Monad (when,unless)+import Paths_BNFC ( version )+import Data.Version ( showVersion ) -version = "2.6a"+import System.FilePath+import System.IO (stderr, hPutStrLn,hPutStr)+import BNFC.Options hiding (make)+import System.Console.GetOpt -title = unlines [- "The BNF Converter, "++version, - "(c) Krasimir Angelov, Jean-Philippe Bernardy, Bjorn Bringert, Johan Broberg, Paul Callaghan, ",- " Markus Forsberg, Ola Frid, Peter Gammie, Patrik Jansson, ",- " Kristofer Johannisson, Antti-Juhani Kaijanaho, Ulf Norell, ",- " Michael Pellauer and Aarne Ranta 2002 - 2012.",- "Free software under GNU General Public License (GPL).",- "Bug reports to bnfc-dev@googlegroups.com."- ]- +-- Print an error message and a (short) usage help and exit+printUsageErrors :: [String] -> IO ()+printUsageErrors msg = do+ mapM_ (hPutStrLn stderr) msg+ hPutStrLn stderr usage+ exitFailure+ main :: IO () main = do- xx <- getArgs- - case xx of- ["--numeric-version"] -> do- putStrLn version- exitSuccess- [] -> printUsage- _ | elem "-multi" xx -> do- putStrLn "preprocessing multilingual BNF"- let file = last xx- (files,entryp) <- preprocessMCF file- mapM_ mkOne [init xx ++ [f] | f <- files]- mkTestMulti entryp xx file files- mkMakefileMulti xx file files- _ -> mkOne xx--mkOne :: [String] -> IO ()-mkOne xx = do - let args = (map (filter (not . isSpace)) xx)- let file = last args - if (head file == '-') then printUsage - else do- let name = takeWhile (/= '.') $ basename file- let make = elem "-m" args- let multi = elem "-multi" args- let c = elem "-c" args- let cpp_no_stl = elem "-cpp_no_stl" args - let cpp_stl = elem "-cpp_stl" args || elem "-cpp" args- let csharp = elem "-csharp" args- let java14 = elem "-java1.4" args- let java15 = elem "-java1.5" args || elem "-java" args- let ocaml = elem "-ocaml" args- let fsharp = elem "-fsharp" args- let haskell = elem "-haskell" args- let haskellGADT = elem "-gadt" args- let profile = elem "-prof" args- let alexMode = foldl' (\m arg -> - case arg of- "-alex1" -> Alex1- "-alex2" -> Alex2- "-alex3" -> Alex3- _ -> m- ) Alex3 args- alex1 = alexMode == Alex1- alex2StringSharing = elem "-sharestrings" args- alex2ByteString = elem "-bytestrings" args- glr = "-glr" `elem` args- let xml = if elem "-xml" args then 1 else - if elem "-xmlt" args then 2 else 0- let inDir = elem "-d" args- let vsfiles = elem "-vs" args- let wcfSupport = elem "-wcf" args- let linenumbers = elem "-l" args -- for C++ STL target- inPackage <- case elemIndex "-p" args of- Nothing -> return Nothing- Just i | i < length args - 1 -> return (Just (args!!(i+1)))- _ -> do- putStrLn "-p option requires an argument"- printUsage- let options = Options {make = make, - alexMode = alexMode, - inDir = inDir, - shareStrings = alex2StringSharing, - byteStrings = alex2ByteString,- glr = if glr then GLR else Standard,- xml = xml,- inPackage = inPackage,- lang = name,- multi = multi,- cnf = elem "-cnf" args,- targets = targets- }- targets0 = [ TargetC |c] ++ [ TargetCPP | cpp_no_stl ] ++ [TargetCPP_STL | cpp_stl - ] ++ [ TargetCSharp | csharp] ++ [ TargetFSharp |fsharp] ++ [TargetHaskellGADT|haskellGADT- ] ++ [ TargetJava15 |java15] ++ [TargetJava |java14] ++ [TargetOCAML |ocaml] ++ [TargetProfile|profile]- targets = if null targets0 then [TargetHaskell] else targets0- putStrLn title- unless (length targets == 1) $- fail "Error: only one language mode may be chosen"- unless (isCF (reverse file)) $ - fail "Error: the input file must end with .cf"- (cfp, isOk) <- tryReadCFP options file- let cf = cfp2cf cfp- unless isOk $- fail "Error: Failed"- case () of- _ | c -> makeC make name cf- _ | cpp_no_stl -> makeCPP make name cf- _ | cpp_stl-> makeSTL make linenumbers inPackage name cf- _ | csharp -> makeCSharp make vsfiles wcfSupport inPackage cf file- _ | java14 -> makeJava make name cf- _ | java15 -> makeJava15 make inPackage name cf- _ | ocaml -> makeOCaml options cf- _ | fsharp -> makeFSharp options cf- _ | profile-> makeAllProfile make alex1 False xml name cfp- _ | haskellGADT -> makeAllGADT options cf- _ -> makeAll options cf- when (make && multi) $ do- system ("cp Makefile Makefile_" ++ name)- return ()- putStrLn "Done!"- where isCF ('f':'c':'.':_) = True- isCF ('f':'n':'b':'.':_) = True- isCF ('f':'n':'b':'l':'.':_) = True- isCF ('c':'f':'n':'b':'.':_) = True- isCF _ = False- -printUsage = do - putStrLn title- putStrLn "Usage: bnfc <makeoption>* <language>? <special>* file.cf"- putStrLn ""- putStrLn "Version options:"- putStrLn " --numeric-version Print just the version number"- putStrLn ""- putStrLn "Make option:"- putStrLn " -m generate Makefile"- putStrLn ""- putStrLn "Languages (Only one language mode may be selected.)"- putStrLn " -java Output Java 1.5 code for use with JLex and CUP"- putStrLn " -java1.5 Output Java 1.5 code for use with JLex and CUP (same as -java)"- putStrLn " -java1.4 Output Java 1.4 code for use with JLex and CUP (before 2.5 was: -java)"- putStrLn " -c Output C code for use with FLex and Bison"- putStrLn " -cpp Output C++ code for use with FLex and Bison (same as -cpp_stl)"- putStrLn " -cpp_stl Output C++ code for use with FLex and Bison (same as -cpp)"- putStrLn " -cpp_no_stl Output C++ code (without STL) for use with FLex and Bison (before 2.5 was: -cpp)"- putStrLn " and the Standard Template Library"- putStrLn " -csharp Output C# code for use with GPLEX and GPPG"- putStrLn " -ocaml Output OCaml code for use with ocamllex and ocamlyacc"- putStrLn " -fsharp Output F# code for use with fslex and fsyacc"- putStrLn " -haskell Output Haskell code for use with Alex and Happy (default)"- putStrLn " -prof Output Haskell code for rules with permutation profiles"- putStrLn " -gadt Output Haskell code which uses GADTs"- putStrLn ""- putStrLn "Special options for the Haskell back-end:"- putStrLn " -d Put Haskell code in modules Lang.* instead of Lang*"- putStrLn " -p <name> Prepend <name> to the Haskell module names."- putStrLn " Dots in the module name create hierarchical modules."- putStrLn " -alex1 Use Alex 1.1 as Haskell lexer tool"- putStrLn " -alex2 Use Alex 2 as Haskell lexer tool"- putStrLn " -alex3 Use Alex 3 as Haskell lexer tool (default)"- putStrLn " -sharestrings Use string sharing in Alex 2 lexer"- putStrLn " -bytestrings Use byte string in Alex 2 lexer"- putStrLn " -glr Output Happy GLR parser"- putStrLn " -xml Also generate a DTD and an XML printer"- putStrLn " -xmlt DTD and an XML printer, another encoding"- putStrLn ""- putStrLn "Special options for the C++ (with STL) back-end:"- putStrLn " -l Add and set line_number field for all syntax classes"- putStrLn " -p <namespace> Use <namespace> as the C++ namespace"- putStrLn ""- putStrLn "Special options for the Java (v 1.5) back-end:"- putStrLn " -p <package> Prepend <package> to the Java package name"- putStrLn ""- putStrLn "Special options for the C# backend:"- putStrLn " -p <namespace> Use <namespace> as the C# namespace"- putStrLn " -vs Generate Visual Studio solution/project files"- putStrLn " -wcf Add support for Windows Communication Foundation, by"- putStrLn " marking abstract syntax classes as DataContracts"- exitFailure+ args <- getArgs+ case parseMode args of+ UsageError e -> printUsageErrors [e]+ Help -> putStrLn help >> exitSuccess+ Version -> putStrLn (showVersion version) >> exitSuccess+ Target options file | target options == TargetProfile ->+ readFile file >>= parseCFP options TargetProfile >>= makeHaskellProfile options+ Target options file ->+ readFile file >>= parseCF options (target options) >>= make (target options) options+ where make TargetC opts cf = writeFiles "." $ makeC opts cf+ make TargetCpp opts cf = writeFiles "." $ makeCppStl opts cf+ make TargetCppNoStl opts cf = writeFiles "." $ makeCppNoStl opts cf+ make TargetCSharp opts cf = writeFiles "." $ makeCSharp opts cf+ make TargetHaskell opts cf = writeFiles "." $ makeHaskell opts cf+ make TargetHaskellGadt opts cf = writeFiles "." $ makeHaskellGadt opts cf+ make TargetLatex opts cf = writeFiles "." $ makeLatex opts cf+ make TargetJava opts cf = writeFiles "." $ makeJava opts cf+ make TargetOCaml opts cf = writeFiles "." $ makeOCaml opts cf+ make TargetProfile opts cf = fail "" opts cf
− src/MultiView.hs
@@ -1,137 +0,0 @@-{-- BNF Converter: Abstract syntax- Copyright (C) 2004 Author: Markus Forsberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---module MultiView where--import System.Directory ( doesFileExist, renameFile )--import qualified CF as CF-import Utils-import ParBNF-import PrintBNF-import Data.List(nub,partition)-import AbsBNF--- import LexBNF-import ErrM-import Data.Char-import TypeChecker--preprocessMCF :: FilePath -> IO ([FilePath],String)-preprocessMCF f = do- s <- readFile f- gr <- case pLGrammar $ myLexer s of- Ok g -> return g- Bad s -> error s- let name = takeWhile (/='.') f- let grs = extract name gr- let entryp = entrypoint gr- mapM_ writeCF grs- return $ (map fst grs,entryp)--extract :: String -> LGrammar -> [(FilePath, Grammar)]-extract name (LGr ldefs) = - [(file lang,Grammar [unldef ldef | ldef <- ldefs, isFor lang ldef]) | - lang <- views]- where- views = [lang | LDefView langs <- ldefs, Ident lang <- langs]- isFor lang ldef = case ldef of- DefAll _ -> True- DefSome ids _ -> elem (Ident lang) ids- _ -> False- unldef ldef = case ldef of- DefAll d -> d- DefSome _ d -> d- file lang = name ++ "_" ++ lang ++ ".cf"----- the entrypoint is the same for all languages - could be different--entrypoint :: LGrammar -> String-entrypoint (LGr rs0) = head $ - [c | Entryp (Ident c:_) <- rs] ++- [c | Rule _ (IdCat (Ident c)) _ <- rs]- where- rs = concatMap getR rs0- getR d = case d of- DefAll d -> [d]- DefSome _ d -> [d]- _ -> [] --- LDefView--writeCF :: (FilePath, Grammar) -> IO ()-writeCF (file,gr) = do - writeFile file $ printTree gr- putStrLn $ "wrote file " ++ file------ These are Haskell specific; ----- should be generalized by inspecting the options xx--mkTestMulti :: String -> [String] -> FilePath -> [FilePath] -> IO ()-mkTestMulti cat xx file files = do- let abs = takeWhile (/='.') file- let cncs = map (takeWhile (/='.')) files- let content = testfile cat xx abs cncs- writeFile ("TestTrans" ++ abs ++ ".hs") content--mkMakefileMulti :: [String] -> FilePath -> [FilePath] -> IO ()-mkMakefileMulti xx file files = do- let abs = takeWhile (/='.') file- let cncs = map (takeWhile (/='.')) files- let content = makefile xx abs cncs- writeFile "Makefile" content--makefile xx abs cncs = unlines $- "all:" : - ["\tmake -f Makefile_" ++ cnc | cnc <- cncs] ++- ["\tghc --make -o TestTrans" ++ abs ++ " TestTrans" ++ abs,- ""- ]--testfile cat xx abs cncs = unlines $- ["module Main where"] ++- ["import qualified Lex" ++ cnc | cnc <- cncs] ++- ["import qualified Par" ++ cnc | cnc <- cncs] ++- ["import qualified Print" ++ cnc | cnc <- cncs] ++- ["import Abs" ++ abs,- "import ErrM",- "import System.Environment (getArgs)",- "",- "main :: IO ()",- "main = do",- " i:o:f:_ <- getArgs",- " s <- readFile f",- " case parse i s of",- " Ok t -> putStrLn $ prin o t",- " Bad s -> error s",- "",- "parse i = case i of"- ] ++- [- " " ++ sho cnc ++ " -> Par" ++ cnc ++ ".p" ++ cat ++- " . Par" ++ cnc ++ ".myLexer" | cnc <- cncs- ] ++- [- "",- "prin o = case o of"- ] ++- [- " " ++ sho cnc ++ " -> Print" ++ cnc ++- ".printTree" | cnc <- cncs- ]- where- sho = show . tail . dropWhile (/='_')
− src/Options.hs
@@ -1,34 +0,0 @@-module Options where--data Target = TargetC | TargetCPP |TargetCPP_STL - | TargetCSharp | TargetFSharp |TargetHaskell |TargetHaskellGADT- | TargetJava15 |TargetJava |TargetOCAML |TargetProfile- deriving Eq---- | Which version of Alex is targeted?-data AlexMode = Alex1 | Alex2 | Alex3 deriving Eq--data HappyMode = Standard | GLR deriving Eq--data SharedOptions = Options - { - targets :: [Target],- make :: Bool,- alexMode :: AlexMode,- inDir :: Bool,- shareStrings :: Bool,- byteStrings :: Bool,- glr :: HappyMode,- xml :: Int,- inPackage :: Maybe String, -- ^ The hierarchical package to put- -- the modules in, or Nothing.- lang :: String, -- ^ Prefix to use in module names- multi :: Bool,- cnf :: Bool -- ^ Generate CNF-like tables?- }--anyTarget opts vs = any (isOpt opts) vs- where isOpt opts v = elem v $ targets opts---
src/PrintBNF.hs view
@@ -213,9 +213,7 @@ prtList es = case es of [] -> (concatD []) [x] -> (concatD [prt 2 x])- [x] -> (concatD [prt 0 x]) x:xs -> (concatD [prt 2 x , prt 2 xs])- x:xs -> (concatD [prt 0 x , doc (showString ",") , prt 0 xs]) instance Print RHS where prt i e = case e of
− src/TypeChecker.hs
@@ -1,146 +0,0 @@--module TypeChecker where--import Control.Monad-import Data.List-import Data.Char--import CF-import ErrM--data Base = BaseT String- | ListT Base- deriving (Eq)--data Type = FunT [Base] Base- deriving (Eq)--instance Show Base where- show (BaseT x) = x- show (ListT t) = "[" ++ show t ++ "]"--instance Show Type where- show (FunT ts t) = unwords $ map show ts ++ ["->", show t]--data Context = Ctx { ctxLabels :: [(String, Type)]- , ctxTokens :: [String]- }--catchErr :: Err a -> (String -> Err a) -> Err a-catchErr (Bad s) f = f s-catchErr (Ok x) _ = Ok x--buildContext :: CF -> Context-buildContext cf@(CFG(_,rules)) =- Ctx- [ (f, mkType cat args) | Rule f cat args <- rules- , not (isCoercion f)- , not (isNilCons f)- ]- ("Ident" : tokenNames cf)- where-- mkType cat args = FunT [ mkBase t | Left t <- args, t /= internalCat ]- (mkBase cat)- mkBase t- | isList t = ListT $ mkBase $ normCatOfList t- | otherwise = BaseT $ normCat t--isToken :: String -> Context -> Bool-isToken x ctx = elem x $ ctxTokens ctx--extendContext :: Context -> [(String,Type)] -> Context-extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx }--lookupCtx :: String -> Context -> Err Type-lookupCtx x ctx- | isToken x ctx = return $ FunT [BaseT "String"] (BaseT x)- | otherwise =- case lookup x $ ctxLabels ctx of- Nothing -> fail $ "Undefined symbol '" ++ x ++ "'."- Just t -> return t--checkDefinitions :: CF -> Err ()-checkDefinitions cf =- do checkContext ctx- sequence_ [checkDefinition ctx f xs e | FunDef f xs e <- pragmasOfCF cf]- where- ctx = buildContext cf--checkContext :: Context -> Err ()-checkContext ctx =- mapM_ checkEntry $ groupSnd $ ctxLabels ctx- where- -- This is a very handy function which transforms a lookup table- -- with duplicate keys to a list valued lookup table with no duplicate- -- keys.- groupSnd :: Ord a => [(a,b)] -> [(a,[b])]- groupSnd =- map ((fst . head) /\ map snd)- . groupBy ((==) **.* fst)- . sortBy (compare **.* fst)- - (f /\ g) x = (f x, g x)- (f **.* g) x y = f (g x) (g y)-- checkEntry (f,ts) =- case nub ts of- [_] -> return ()- ts' -> - fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" ++- unlines (map ((" " ++) . show) ts')--checkDefinition :: Context -> String -> [String] -> Exp -> Err ()-checkDefinition ctx f xs e =- do checkDefinition' dummyConstructors ctx f xs e- return ()--data ListConstructors = LC- { nil :: Base -> String- , cons :: Base -> String- }--dummyConstructors :: ListConstructors-dummyConstructors = LC (const "[]") (const "(:)")--checkDefinition' :: ListConstructors -> Context -> String -> [String] -> Exp -> Err ([(String,Base)],(Exp,Base))-checkDefinition' list ctx f xs e =- do unless (isLower $ head f) $ fail "Defined functions must start with a lowercase letter."- t@(FunT ts t') <- lookupCtx f ctx `catchErr` \_ ->- fail $ "'" ++ f ++ "' must be used in a rule."- let expect = length ts- given = length xs- unless (expect == given) $ fail $ "'" ++ f ++ "' is used with type " ++ show t ++ " but defined with " ++ show given ++ " argument" ++ plural given ++ "."- e' <- checkExp list (extendContext ctx $ zip xs (map (FunT []) ts)) e t'- return (zip xs ts, (e', t'))- `catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err- where- plural 1 = ""- plural _ = "s"--checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp-checkExp list ctx (App "[]" []) (ListT t) = return (App (nil list t) [])-checkExp _ _ (App "[]" _) _ = fail $ "[] is applied to too many arguments."-checkExp list ctx (App "(:)" [e,es]) (ListT t) =- do e' <- checkExp list ctx e t- es' <- checkExp list ctx es (ListT t)- return $ App (cons list t) [e',es']-checkExp _ _ (App "(:)" es) _ = fail $ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "."-checkExp list ctx e@(App x es) t =- do FunT ts t' <- lookupCtx x ctx- es' <- matchArgs ctx es ts- unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected."- return $ App x es'- where- matchArgs ctx es ts- | expect /= given = fail $ "'" ++ x ++ "' takes " ++ show expect ++ " arguments, but has been given " ++ show given ++ "."- | otherwise = zipWithM (checkExp list ctx) es ts- where- expect = length ts- given = length es-checkExp _ _ e@(LitInt _) (BaseT "Integer") = return e-checkExp _ _ e@(LitDouble _) (BaseT "Double") = return e-checkExp _ _ e@(LitChar _) (BaseT "Char") = return e-checkExp _ _ e@(LitString _) (BaseT "String") = return e-checkExp _ _ e t = fail $ show e ++ " does not have type " ++ show t ++ "."-
− src/Utils.hs
@@ -1,168 +0,0 @@-{-- BNF Converter: Abstract syntax- Copyright (C) 2004 Author: Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module Utils where--import Control.Monad (unless)-import System.IO.Error (tryIOError)-import System.Directory (createDirectory, doesDirectoryExist, renameFile,- removeFile, doesFileExist)--infixr 5 +++-infixr 5 ++++-infixr 5 +++++-infixr 2 |||-infixr 5 ...-infixr 3 ***----- printing operations--a +++ b = a ++ " " ++ b-a ++++ b = a ++ "\n" ++ b-a +++++ b = a ++ "\n\n" ++ b--prParenth s = if s == "" then "" else "(" ++ s ++ ")"----- parser combinators a` la Wadler and Hutton--type Parser a b = [a] -> [(b,[a])]--(...) :: Parser a b -> Parser a c -> Parser a (b,c)-(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]--(|||) :: Parser a b -> Parser a b -> Parser a b-(p ||| q) s = p s ++ q s--lit :: (Eq a) => a -> Parser a a-lit x (c:cs) = [(x,cs) | x == c]-lit _ _ = []--(***) :: Parser a b -> (b -> c) -> Parser a c-(p *** f) s = [(f x,r) | (x,r) <- p s] --succeed :: b -> Parser a b-succeed v s = [(v,s)]--fails :: Parser a b-fails s = []---- to get parse results--parseResults :: Parser a b -> [a] -> [b]-parseResults p s = [x | (x,r) <- p s, null r]----- * List utilities---- | Replace all occurences of a value by another value-replace :: Eq a => - a -- ^ Value to replace - -> a -- ^ Value to replace it with- -> [a] -> [a]-replace x y xs = [ if z == x then y else z | z <- xs]---- | Split a list on the first occurence of a value.--- Does not include the value that was split on in either--- of the returned lists.-split :: Eq a => a -> [a] -> ([a],[a])-split x xs = let (ys, zs) = break (==x) xs- in (ys, drop 1 zs)---- | Split a list on every occurence of a value.--- If the value does not occur in the list,--- the result is the singleton list containing the input list.--- Thus the returned list is never the empty list.-splitAll :: Eq a => a -> [a] -> [[a]]-splitAll _ [] = [[]]-splitAll x xs = let (ys, zs) = break (==x) xs- in ys : case zs of- [] -> []- _:zs' -> splitAll x zs'---- * File utilities---- | Ensure that a directory exists.-prepareDir :: FilePath -> IO ()-prepareDir = mapM_ createDirectoryIfNotExists . pathInits---- | Ensure that a directory exists. All parent directories--- must already exist.-createDirectoryIfNotExists :: FilePath -> IO ()-createDirectoryIfNotExists d = do- exists <- doesDirectoryExist d- unless exists (createDirectory d)--pathSep :: Char-pathSep = '/'---- | Like the prelude function 'inits' but for path names.--- For example:--- > pathInits "foo/bar" = ["foo","foo/bar"]--- > pathInits "foo/bar/baz.hs" = ["foo","foo/bar","foo/bar/baz.hs"]-pathInits :: String -> [String]-pathInits "" = []-pathInits xs = let (ys,zs) = split pathSep xs- in ys : map ((ys ++ [pathSep]) ++) (pathInits zs)---- | Like basename(1), remove all leading directories from a path name.-basename :: String -> String-basename = last . splitAll pathSep----- | Write a file, after making a backup of an existing file with the same name.-writeFileRep :: FilePath -> String -> IO ()-writeFileRep = writeFileRep2---- peteg: FIXME this is racey.--- want to be a bit smarter about whether we actually generate the file--- or save it... e.g. ErrM.hs need not be regenerated if it exists.-writeFileRep1 f s =- do exists <- doesFileExist f- backedUp <- if exists- then do let fbak = f ++ ".bak"- renameFile f fbak- return $ " (saving old file as " ++ fbak ++ ")"- else return ""- putStrLn $ "writing file " ++ f ++ backedUp- writeFile f s---- New version by TH, 2010-09-23--- If an old version of the file exist and the new version is the same,--- keep the old file and don't create a .bak file.-writeFileRep2 :: FilePath -> String -> IO ()-writeFileRep2 path s =- either newFile updateFile =<< tryIOError (readFile path)- where- newFile _ =- do putStrLn $ "writing new file "++path- writeFile path s- updateFile old =- do let tmp=path++".tmp"- writeFile tmp s- new <- readFile tmp- if new==old -- test is O(1) space, O(n) time- then do putStrLn $ "no change to file "++path- removeFile tmp- else do let bak=path++".bak"- putStrLn $ "writing file "++path- ++" (saving old file as "++bak++")"- renameFile path bak- renameFile tmp path
− src/formats/CFtoLatex.hs
@@ -1,276 +0,0 @@-{-- BNF Converter: Latex Generator- Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoLatex (cfToLatex)where--import CF-import AbsBNF (Reg (..))-import Utils-import Data.List (nub,intersperse)--cfToLatex :: String -> CF -> String-cfToLatex name cf = unlines [- "\\batchmode",- beginDocument name,- macros,- introduction,- prtTerminals name cf,- prtBNF name cf,- endDocument- ]--introduction :: String-introduction = concat - [- "\nThis document was automatically generated by ",- "the {\\em BNF-Converter}.",- " It was generated together with the lexer, the parser, and the",- " abstract syntax module, which guarantees that the document",- " matches with the implementation of the language (provided no",- " hand-hacking has taken place).\n"- ] --prtTerminals :: String -> CF -> String-prtTerminals name cf = unlines [- "\\section*{The lexical structure of " ++ name ++ "}",- identSection cf,- "\\subsection*{Literals}",- prtLiterals name cf,- unlines (map prtOwnToken (tokenPragmas cf)),- "\\subsection*{Reserved words and symbols}",- prtReserved name cf, - prtSymb name cf,- "\\subsection*{Comments}",- prtComments $ comments cf- ]--identSection cf = if not (hasIdent cf) then [] else- unlines [- "\\subsection*{Identifiers}",- prtIdentifiers- ]--prtIdentifiers :: String-prtIdentifiers = unlines- [- "Identifiers \\nonterminal{Ident} are unquoted strings beginning with a letter,",- "followed by any combination of letters, digits, and the characters {\\tt \\_ '},",- "reserved words excluded."- ]--prtLiterals :: String -> CF -> String-prtLiterals name cf = - unlines $ map stringLit $- filter (`notElem` ["Ident"]) $ - literals cf--stringLit :: String -> String-stringLit cat = unlines $ case cat of- "Char" -> ["Character literals \\nonterminal{Char}\\ have the form",- "\\terminal{'}$c$\\terminal{'}, where $c$ is any single character.",- ""- ]- "String" -> ["String literals \\nonterminal{String}\\ have the form",- "\\terminal{\"}$x$\\terminal{\"}, where $x$ is any sequence of any characters",- "except \\terminal{\"}\\ unless preceded by \\verb6\\6.",- ""]- "Integer" -> ["Integer literals \\nonterminal{Int}\\ are nonempty sequences of digits.",- ""]- "Double" -> ["Double-precision float literals \\nonterminal{Double}\\ have the structure",- "indicated by the regular expression" +++ - "$\\nonterminal{digit}+ \\mbox{{\\it `.'}} \\nonterminal{digit}+ (\\mbox{{\\it `e'}} \\mbox{{\\it `-'}}? \\nonterminal{digit}+)?$ i.e.\\",- "two sequences of digits separated by a decimal point, optionally",- "followed by an unsigned or negative exponent.",- ""]- _ -> []--prtOwnToken (name,reg) = unlines - [name +++ "literals are recognized by the regular expression",- "\\(" ++- latexRegExp reg ++- "\\)" - ]- -prtComments :: ([(String,String)],[String]) -> String-prtComments (xs,ys) = concat- [- if (null ys) then - "There are no single-line comments in the grammar. \\\\"- else- "Single-line comments begin with " ++ sing ++". \\\\",- if (null xs) then- "There are no multiple-line comments in the grammar."- else- "Multiple-line comments are enclosed with " ++ mult ++"."- ]- where - sing = concat $ intersperse ", " $ map (symbol.prt) ys- mult = concat $ intersperse ", " $ - map (\(x,y) -> (symbol (prt x)) - ++ " and " ++- (symbol (prt y))) xs--prtSymb :: String -> CF -> String-prtSymb name cf = case symbols cf of- [] -> "\nThere are no symbols in " ++ name ++ ".\\\\\n"- xs -> "The symbols used in " ++ name ++ " are the following: \\\\\n"- ++- (tabular 3 $ three $ map (symbol.prt) xs)--prtReserved :: String -> CF -> String-prtReserved name cf = case reservedWords cf of- [] -> stringRes name ++ - "\nThere are no reserved words in " ++ name ++ ".\\\\\n"- xs -> stringRes name ++ - (tabular 3 $ three $ map (reserved.prt) xs)--stringRes :: String -> String-stringRes name = concat - ["The set of reserved words is the set of terminals ",- "appearing in the grammar. Those reserved words ",- "that consist of non-letter characters are called symbols, and ",- "they are treated in a different way from those that ",- "are similar to identifiers. The lexer ",- "follows rules familiar from languages ",- "like Haskell, C, and Java, including longest match ",- "and spacing conventions.",- "\n\n",- "The reserved words used in " ++ name ++ " are the following: \\\\\n"]--three :: [String] -> [[String]] -three [] = []-three [x] = [[x,[],[]]]-three [x,y] = [[x,y,[]]]-three (x:y:z:xs) = [x,y,z] : three xs--prtBNF :: String -> CF -> String-prtBNF name cf = unlines [- "\\section*{The syntactic structure of " ++ name ++"}",- "Non-terminals are enclosed between $\\langle$ and $\\rangle$. ",- "The symbols " ++ arrow ++ " (production), " ++ - delimiter ++" (union) ",- "and " ++ empty ++ " (empty rule) belong to the BNF notation. ",- "All other symbols are terminals.\\\\",- prtRules (ruleGroups cf)- ]--prtRules :: [(Cat,[Rule])] -> String-prtRules [] = []-prtRules ((c,[]):xs) - = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs-prtRules ((c,(r:rs)):xs) - = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ - [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ - prtRules xs--prtSymbols :: [Either Cat String] -> String-prtSymbols [] = empty-prtSymbols xs = foldr (+++) [] (map p xs)- where p (Left r) = nonterminal r --- (prt r)- p (Right r) = terminal (prt r) - -prt :: String -> String-prt [] = []-prt (c:xs)- | elem c "$&%#_{}^" = "\\" ++ [c] ++ prt xs- | elem c "+=|<>-" = "{$" ++ [c] ++ "$}" ++ prt xs- | c == '\\' = "$\\backslash$"- | c == '~' = "\\~{}"- | otherwise = c : prt xs--macros :: String-macros =- "\\newcommand{\\emptyP}{\\mbox{$\\epsilon$}}" ++++- "\\newcommand{\\terminal}[1]{\\mbox{{\\texttt {#1}}}}" ++++- "\\newcommand{\\nonterminal}[1]{\\mbox{$\\langle \\mbox{{\\sl #1 }} \\! \\rangle$}}" ++++- "\\newcommand{\\arrow}{\\mbox{::=}}" ++++- "\\newcommand{\\delimit}{\\mbox{$|$}}" ++++- "\\newcommand{\\reserved}[1]{\\mbox{{\\texttt {#1}}}}" ++++- "\\newcommand{\\literal}[1]{\\mbox{{\\texttt {#1}}}}" ++++- "\\newcommand{\\symb}[1]{\\mbox{{\\texttt {#1}}}}"--reserved :: String -> String-reserved s = "{\\reserved{" ++ s ++ "}}"--literal :: String -> String-literal s = "{\\literal{" ++ s ++ "}}"--empty :: String-empty = "{\\emptyP}"--symbol :: String -> String-symbol s = "{\\symb{" ++ s ++ "}}"--tabular :: Int -> [[String]] -> String-tabular n xs = "\n\\begin{tabular}{" ++ concat (replicate n "l") ++ "}\n" ++- concat (map (\(a:as) -> foldr (+++) "\\\\\n" (a:(map ('&':) as))) xs) ++- "\\end{tabular}\\\\\n"--terminal :: String -> String-terminal s = "{\\terminal{" ++ s ++ "}}"--nonterminal :: String -> String-nonterminal s = "{\\nonterminal{" ++ identCat (mkId s) ++ "}}" where- mkId = map mk- mk c = case c of- '_' -> '-' ---- _ -> c- --arrow :: String-arrow = " {\\arrow} "--delimiter :: String-delimiter = " {\\delimit} "--beginDocument :: String -> String-beginDocument name =- "%This Latex file is machine-generated by the BNF-converter\n" ++++- "\\documentclass[a4paper,11pt]{article}" ++++- "\\author{BNF-converter}" ++++- "\\title{The Language " ++ name ++ "}" ++++- -- "\\usepackage{isolatin1}" ++++- "\\setlength{\\parindent}{0mm}" ++++- "\\setlength{\\parskip}{1mm}" ++++- "\\begin{document}\n" ++++- "\\maketitle\n"--endDocument :: String-endDocument =- "\n\\end{document}\n"--latexRegExp :: Reg -> String-latexRegExp = rex (0 :: Int) where- rex i e = case e of- RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg- RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "\\mid" +++ rex 1 reg- RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg- RStar reg -> rex 3 reg ++ "*"- RPlus reg -> rex 3 reg ++ "+"- ROpt reg -> rex 3 reg ++ "?"- REps -> "\\epsilon"- RChar c -> "\\mbox{`" ++ prt [c] ++ "'}"- RAlts str -> "[" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "]"- RSeqs str -> "\\{" ++ "\\mbox{``" ++ prt str ++ "''}" ++ "\\}"- RDigit -> "{\\nonterminal{digit}}"- RLetter -> "{\\nonterminal{letter}}"- RUpper -> "{\\nonterminal{upper}}"- RLower -> "{\\nonterminal{lower}}"- RAny -> "{\\nonterminal{anychar}}"- ifPar i j s = if i > j then "(" ++ s ++ ")" else s
− src/formats/CFtoTxt.hs
@@ -1,249 +0,0 @@-{-- BNF Converter: Latex Generator- Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoTxt (cfToTxt)where--import CF-import AbsBNF (Reg (..))-import Utils-import Data.List (nub,intersperse)--cfToTxt :: String -> CF -> String-cfToTxt name cf = unlines [- beginDocument name,- introduction,- prtTerminals name cf,- prtBNF name cf- ]--introduction :: String-introduction = concat - [- "\nThis document was automatically generated by ",- "the //BNF-Converter//.",- " It was generated together with the lexer, the parser, and the",- " abstract syntax module, which guarantees that the document",- " matches with the implementation of the language (provided no",- " hand-hacking has taken place).\n"- ] --prtTerminals :: String -> CF -> String-prtTerminals name cf = unlines [- "==The lexical structure of " ++ name ++ "==",- identSection cf,- "===Literals===",- prtLiterals name cf,- unlines (map prtOwnToken (tokenPragmas cf)),- "===Reserved words and symbols===",- prtReserved name cf, - prtSymb name cf,- "===Comments===",- prtComments $ comments cf- ]--identSection cf = if not (hasIdent cf) then [] else- unlines [- "===Identifiers===",- prtIdentifiers- ]--prtIdentifiers :: String-prtIdentifiers = unlines- [- "Identifiers //Ident// are unquoted strings beginning with a letter,",- "followed by any combination of letters, digits, and the characters ``_ '``",- "reserved words excluded."- ]--prtLiterals :: String -> CF -> String-prtLiterals name cf = - unlines $ map stringLit $- filter (`notElem` ["Ident"]) $ - literals cf--stringLit :: String -> String-stringLit cat = unlines $ case cat of- "Char" -> ["Character literals //Char// have the form",- "``'``//c//``'``, where //c// is any single character.",- ""- ]- "String" -> ["String literals //String// have the form",- "``\"``//x//``\"``}, where //x// is any sequence of any characters",- "except ``\"`` unless preceded by ``\\``.",- ""]- "Integer" -> ["Integer literals //Integer// are nonempty sequences of digits.",- ""]- "Double" -> ["Double-precision float literals //Double// have the structure",- "indicated by the regular expression" +++ - "``digit+ '.' digit+ ('e' ('-')? digit+)?`` i.e.\\",- "two sequences of digits separated by a decimal point, optionally",- "followed by an unsigned or negative exponent.",- ""]- _ -> []--prtOwnToken (name,reg) = unlines - [name +++ "literals are recognized by the regular expression",- "```" ++- latexRegExp reg ++- "```" - ]- -prtComments :: ([(String,String)],[String]) -> String-prtComments (xs,ys) = concat- [- if (null ys) then - "There are no single-line comments in the grammar."- else- "Single-line comments begin with " ++ sing ++".",- if (null xs) then- "There are no multiple-line comments in the grammar."- else- "Multiple-line comments are enclosed with " ++ mult ++"."- ]- where - sing = concat $ intersperse ", " $ map (symbol.prt) ys- mult = concat $ intersperse ", " $ - map (\(x,y) -> (symbol (prt x)) - ++ " and " ++- (symbol (prt y))) xs--prtSymb :: String -> CF -> String-prtSymb name cf = case symbols cf of- [] -> "\nThere are no symbols in " ++ name ++ ".\n"- xs -> "The symbols used in " ++ name ++ " are the following:\n"- ++- (tabular 4 $ three $ map (symbol.prt) xs)--prtReserved :: String -> CF -> String-prtReserved name cf = case reservedWords cf of- [] -> stringRes name ++ - "\nThere are no reserved words in " ++ name ++ ".\n"- xs -> stringRes name ++ - (tabular 4 $ three $ map quote xs)--stringRes :: String -> String-stringRes name = concat - ["The set of reserved words is the set of terminals ",- "appearing in the grammar. Those reserved words ",- "that consist of non-letter characters are called symbols, and ",- "they are treated in a different way from those that ",- "are similar to identifiers. The lexer ",- "follows rules familiar from languages ",- "like Haskell, C, and Java, including longest match ",- "and spacing conventions.",- "\n\n",- "The reserved words used in " ++ name ++ " are the following:\n"]--three :: [String] -> [[String]] -three [] = []-three [x] = [[x,[],[],[]]]-three [x,y] = [[x,y,[],[]]]-three [x,y,z] = [[x,y,z,[]]]-three (x:y:z:u:xs) = [x,y,z,u] : three xs--prtBNF :: String -> CF -> String-prtBNF name cf = unlines [- "==The syntactic structure of " ++ name ++"==",- "Non-terminals are enclosed between < and >. ",- "The symbols " ++ arrow ++ " (production), " ++ - delimiter ++" (union) ",- "and " ++ empty ++ " (empty rule) belong to the BNF notation. ",- "All other symbols are terminals.",- "",- prtRules (ruleGroups cf)- ]--prtRules :: [(Cat,[Rule])] -> String-prtRules [] = []-prtRules ((c,[]):xs) - = tabular 3 [[nonterminal c,arrow,[]]] ++ prtRules xs-prtRules ((c,(r:rs)):xs) - = tabular 3 ([[nonterminal c,arrow,prtSymbols $ rhsRule r]] ++ - [[[],delimiter,prtSymbols (rhsRule y)] | y <- rs]) ++ - --- "\n\n" ++ --- with empty lines good for latex, bad for html- prtRules xs--prtSymbols :: [Either Cat String] -> String-prtSymbols [] = empty-prtSymbols xs = foldr (+++) [] (map p xs)- where p (Left r) = nonterminal r- p (Right r) = terminal r- -prt :: String -> String-prt s = s--reserved :: String -> String-reserved s = "{\\reserved{" ++ s ++ "}}"--literal :: String -> String-literal s = "{\\literal{" ++ s ++ "}}"--empty :: String-empty = "**eps**"--symbol :: String -> String-symbol s = s--tabular :: Int -> [[String]] -> String-tabular n xs = unlines [unwords (intersperse "|" (" " : x)) | x <- xs]--terminal :: String -> String-terminal s = "``" ++ s ++ "``"--nonterminal :: String -> String-nonterminal s = "//" ++ s ++ "//"--arrow :: String-arrow = "->"--delimiter :: String-delimiter = " **|** "--beginDocument :: String -> String-beginDocument name = unlines [- "The Language " ++ name,- "BNF Converter",- "",- "",- "%This txt2tags file is machine-generated by the BNF-converter",- "%Process by txt2tags to generate html or latex",- ""- ]--latexRegExp :: Reg -> String-latexRegExp = quote . rex (0 :: Int) where- rex i e = case e of- RSeq reg0 reg -> ifPar i 2 $ rex 2 reg0 +++ rex 2 reg- RAlt reg0 reg -> ifPar i 1 $ rex 1 reg0 +++ "|" +++ rex 1 reg- RMinus reg0 reg -> ifPar i 1 $ rex 2 reg0 +++ "-" +++ rex 2 reg- RStar reg -> rex 3 reg ++ "*"- RPlus reg -> rex 3 reg ++ "+"- ROpt reg -> rex 3 reg ++ "?"- REps -> "eps"- RChar c -> "'" ++ [c] ++ "'"- RAlts str -> "[\"" ++ str ++ "\"]"- RSeqs str -> "{\"" ++ str ++ "\"}"- RDigit -> "digit"- RLetter -> "letter"- RUpper -> "upper"- RLower -> "lower"- RAny -> "char"- ifPar i j s = if i > j then "(" ++ s ++ ")" else s- -quote s = "``" ++ s ++ "``"
− src/formats/NamedVariables.hs
@@ -1,109 +0,0 @@--{-- BNF Converter: Named instance variables- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---{- - **************************************************************- BNF Converter Module-- Description : This module provides support for languages which need- named instance variables. (IE Java, C, C++) It provides- a data type to represent the name mapping and utility- functions to work with it.- - Variables are grouped and numbered in a nice way.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)- - ************************************************************** --}--module NamedVariables where--import CF-import Data.Char (toLower)-import Data.List (nub)--type IVar = (String, Int)---The type of an instance variable---and a # unique to that type--type UserDef = String --user-defined types-----A symbol-mapping environment.-type SymEnv = [(String, String)]----Converts a list of categories into their types to be used as instance variables. -getVars :: [Cat] -> [IVar]-getVars [] = []-getVars cs = foldl addVar [] (map identCat cs)- where- addVar vs c = addVar' vs 0 c- addVar' [] n c = [(c, n)]- addVar' (i@(t,x):is) n c = - if c == t- then if x == 0- then (t, 1) : (addVar' is 2 c)- else i : (addVar' is (x+1) c)- else i : (addVar' is n c)----Given a rule's definition, it goes through and nicely the variables by type.-numVars :: [(String, Int)] -> [Either String b] -> [Either String b]-numVars _env [] = []-numVars env ((Right f) : fs) = (Right f) : (numVars env fs)-numVars env ((Left f) : fs) = - case lookup f' env of- Nothing -> (Left f') : (numVars ((f',1):env) fs)- Just n -> (Left $ f' ++ (show $ n + 1)) : (numVars ((f',n+1):env) fs)- where- f' = varName (normCat (identCat f))----This makes numbers a little nicer.---If there's only one variable of a type we drop the redundant _1 label.---(Actually here we add _1 labels to variables that need it, but the effect--- is the same.)-fixOnes [] = []-fixOnes ((Right f): fs) = (Right f) : (fixOnes fs)-fixOnes ((Left f) : fs) = - if elem (Left (f ++ "2")) fs - then (Left (f ++ "1")) : (fixOnes fs)- else (Left f) : (fixOnes fs)----This fixes the problem with coercions.-fixCoercions :: [(Cat, [Rule])] -> [(Cat, [Rule])]-fixCoercions rs = nub (fixAll rs rs)- where- fixCoercion :: Cat -> [(Cat, [Rule])] -> [Rule]- fixCoercion _ [] = []- fixCoercion cat ((c,rules):cats) = if (normCat c) == (normCat cat)- then rules ++ (fixCoercion cat cats)- else fixCoercion cat cats- fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])]- fixAll _ [] = []- fixAll top ((cat,rules):cats) = if isCoercion cat- then fixAll top cats- else (normCat cat, fixCoercion cat top) : (fixAll top cats)----A generic variable name for C-like languages.-varName c = (map toLower c) ++ "_"----this makes var names a little cleaner.-showNum n = if n == 0 then [] else (show n)
− src/formats/OOAbstract.hs
@@ -1,129 +0,0 @@-{-- BNF Converter: Datastructure for object-oriented abstract syntax generators- Copyright (C) 2006 Author: Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module defines a data structure that is- used for generating abstract syntax in cpp_stl.- It should be used in other STL modules as well,- and could be used for object-oriented languages- in general, to avoid duplicated work.-- Author : Aarne Ranta (aarne@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 29 August, 2006 -- Modified : 29 August, 2006 / Aarne Ranta- - - ************************************************************** --}--module OOAbstract where--import CF-import Utils((+++),(++++))-import NamedVariables-import Data.List-import Data.Char(toLower)---- A datastructure more appropriate than CF--data CAbs = CAbs {- tokentypes :: [Cat], -- user non-position token types- listtypes :: [(Cat,Bool)], -- list types used, whether of classes- absclasses :: [Cat], -- grammar-def cats, normalized names- conclasses :: [Fun], -- constructors, except list ones- signatures :: [(Cat,[CAbsRule])], -- rules for each class, incl. pos tokens- postokens :: [Cat], -- position token types- defineds :: [Fun] -- defined (non-)constructors - }---- (valcat,(constr,args)), True = is class (not basic), class variable stored-type CAbsRule = (Fun,[(Cat,Bool,String)]) ---- all those names that denote classes in C++-allClasses :: CAbs -> [Cat]-allClasses ca = - absclasses ca ++ conclasses ca ++ map fst (listtypes ca) ++ postokens ca ---- all those names that denote non-class types in C++-allNonClasses :: CAbs -> [Cat]-allNonClasses ca = - map fst basetypes ++ tokentypes ca--cf2cabs :: CF -> CAbs-cf2cabs cf = CAbs {- tokentypes = toks,- listtypes = [(c, snd (status (drop 4 c))) | -- remove "List" from "ListC"- c <- map (normCat . identCat) lists],- absclasses = nub $ map normCat cats,- conclasses = [f | Just f <- map testRule (rulesOfCF cf)],- signatures = posdata ++ map normSig (cf2data cf), - postokens = pos,- defineds = defs- }- where- (pos,base) = partition (isPositionCat cf) $ fst (unzip (tokenPragmas cf))- (lists,cats) = partition isList $ allCats cf- toks = map normCat base- testRule (Rule f c r)- | isList c = Nothing- | f == "_" = Nothing- | otherwise = Just f- normSig (c,fcs) = - (identCat c,[(f, classVars (map (status . identCat) cs)) | (f,cs) <- fcs])- posdata = - [("Visitable", -- to give superclass- [(c,[("String",False,"string_"),("Integer",False,"integer_")])]) | c<-pos]- status cat = (cat, notElem cat (map fst basetypes ++ toks))- defs = [f | FunDef f _ _ <- pragmasOfCF cf]-- classVars :: [(Cat,Bool)] -> [(Cat,Bool,String)]- classVars cs = - [(c,b,s) | ((c,b),s) <- zip cs (vars [] (map (classVar . fst) cs))]- --- creating new names is quadratic, but parameter lists are short- --- this should conform with Michael's naming- vars seen vv = case vv of- [] -> vv- v:vs -> case length (filter (==v) seen) of- 0 | elem v vs -> (v ++ "1"): vars (v:seen) vs- 0 -> v : vars (v:seen) vs- n -> (v ++ show (n+1)) : vars (v:seen) vs--basetypes = [- ("Integer","int"),- ("Char", "char"),- ("Double", "double"),- ("String", "std::string"),- ("Ident", "std::string")- ]--isBaseType :: CAbs -> Cat -> Bool-isBaseType cf c = elem c $ tokentypes cf ++ map fst basetypes--classVar :: Cat -> String-classVar c = map toLower c ++ "_"--pointerIf :: Bool -> String -> String-pointerIf b v = if b then "*" ++ v else v
− src/formats/c-sharp/CAbstoCSharpAbs.hs
@@ -1,277 +0,0 @@-{-- BNF Converter: C# Abstract Syntax Generator- Copyright (C) 2006-2007 Author: Johan Broberg- - Modified from CFtoSTLAbs-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C# Abstract Syntax- tree classes. It uses the Visitor design - pattern.-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 22 November, 2006 - - Modified : 21 January, 2007 by Johan Broberg-- ************************************************************** --}--module CAbstoCSharpAbs (cabs2csharpabs) where--import OOAbstract-import CF-import Utils((+++),(++++))-import NamedVariables-import Data.List-import Data.Char(toLower)-import Data.Maybe-import CSharpUtils----The result is one file (.cs)--cabs2csharpabs :: Namespace -> CAbs -> Bool -> String-cabs2csharpabs namespace cabs useWCF = unlinesInline [ - "//C# Abstract Syntax Interface generated by the BNF Converter.",- -- imports- "using System;",- if useWCF then "using System.Runtime.Serialization;" else "",- "using System.Collections.Generic;",- "namespace " ++ namespace ++ ".Absyn",- "{",- " #region Token Classes",- prTokenBaseType useWCF,- unlinesInlineMap (prToken namespace useWCF) (tokentypes cabs),- " #endregion",- " ",- " #region Abstract Syntax Classes",- unlinesInlineMap (prAbs namespace useWCF) abstractclasses,- " ",- unlinesInlineMap (prCon namespace useWCF) (flattenSignatures cabs),- " ",- " #region Lists",- unlinesInlineMap (prList namespace) (listtypes cabs),- " #endregion",- " #endregion",- "}"- ]- where - -- an abstract class is a category which does not contain rules- abstractclasses = [ (cat, (map fst cabsrules)) | (cat, cabsrules) <- signatures cabs, cat `notElem` (map fst cabsrules) ]---- auxiliaries--prDataContract :: Bool -> [Cat] -> String-prDataContract False _ = ""-prDataContract True [] = " [DataContract]"-prDataContract True funs = unlinesInline [- prDataContract True [],- unlinesInline $ map prDataContract' funs- ]- where- prDataContract' :: Cat -> String- prDataContract' fun = " [KnownType(typeof(" ++ fun ++ "))]"--prDataMember :: Bool -> String-prDataMember False = ""-prDataMember True = " [DataMember]"--prTokenBaseType :: Bool -> String-prTokenBaseType useWCF = unlinesInline [- prDataContract useWCF [],- " public class TokenBaseType",- " {",- prDataMember useWCF,- " private string str;",- " ",- " public TokenBaseType(string str)",- " {",- " this.str = str;",- " }",- " ",- " public override string ToString()",- " {",- " return this.str;",- " }",- " }",- " "- ]--prToken :: Namespace -> Bool -> Cat -> String-prToken namespace useWCF name = unlinesInline [- prDataContract useWCF [],- " public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType",- " {",- " public " ++ name ++ "(string str) : base(str)",- " {",- " }",- prAccept namespace name Nothing,- prVisitor namespace [name],- prEquals namespace name ["ToString()"],- prHashCode namespace name ["ToString()"],- " }"- ]--prAbs :: Namespace -> Bool -> (Cat, [Cat]) -> String-prAbs namespace useWCF (cat, funs) = unlinesInline [- prDataContract useWCF funs,- " public abstract class " ++ cat,- " {",- " public abstract R Accept<R,A>(" ++ identifier namespace cat ++ ".Visitor<R,A> v, A arg);",- prVisitor namespace funs,- " }"- ]--prVisitor :: Namespace -> [Cat] -> String-prVisitor namespace funs = unlinesInline [- " ",- " public interface Visitor<R,A>",- " {",- unlinesInline (map prVisitFun funs),- " }"- ]- where- prVisitFun f = " R Visit(" ++ identifier namespace f ++ " p, A arg);"--prCon :: Namespace -> Bool -> (Cat,CSharpAbsRule) -> String-prCon namespace useWCF (c,(f,cs)) = unlinesInline [- prDataContract useWCF [],- " public class " ++ f ++ ext,- " {",- -- Instance variables- unlines [prInstVar typ var | (typ,_,var,_) <- cs],- prConstructor namespace (f,cs),- unlinesInline [prProperty typ var prop | (typ,_,var,prop) <- cs],- prEquals namespace f propnames,- prHashCode namespace f propnames,- -- print Accept method, override keyword needed for classes inheriting an abstract class- prAccept namespace c (if isAlsoCategory f c then Nothing else (Just " override")),- -- if this label is also a category, we need to print the Visitor interface- -- (if not, it was already printed in the abstract class)- if isAlsoCategory f c then prVisitor namespace [c] else "",- " }"- ]- where- -- This handles the case where a LBNF label is the same as the category.- ext = if isAlsoCategory f c then "" else " : " ++ identifier namespace (identCat c)- propnames = [prop | (_, _, _, prop) <- cs]- prInstVar typ var = unlinesInline [- " private " ++ identifier namespace (typename typ) +++ var ++ ";"- ]- prProperty typ var prop = unlinesInline [- " ",- prDataMember useWCF,- " public " ++ identifier namespace (typename typ) +++ prop,- " {",- " get",- " {",- " return this." ++ var ++ ";",- " }",- " set",- " {",- " this." ++ var ++ " = value;",- " }",- " }"- ]---- Creates the Equals() methods-prEquals :: Namespace -> Fun -> [String] -> String-prEquals namespace c vars = unlinesInline [- " ",- " public override bool Equals(Object obj)",- " {",- " if(this == obj)",- " {",- " return true;",- " }",- " if(obj is " ++ identifier namespace c ++ ")",- " {",- " return this.Equals((" ++ identifier namespace c ++ ")obj);",- " }",- " return base.Equals(obj);",- " }",- " ",- " public bool Equals(" ++ identifier namespace c ++ " obj)",- " {",- " if(this == obj)",- " {",- " return true;",- " }",- " return " ++ prEqualsVars vars ++ ";",- " }"- ]- where- prEqualsVars [] = "true"- prEqualsVars vs = concat $ intersperse " && " $ map equalVar vs- equalVar v = "this." ++ v ++ ".Equals(obj." ++ v ++ ")"---- Creates the GetHashCode() method.-prHashCode :: Namespace -> Fun -> [String] -> String-prHashCode namespace c vars = unlinesInline [- " ",- " public override int GetHashCode()",- " {",- " return " ++ prHashVars vars ++ ";",- " }"- ]- where - aPrime = 37- prHashVars [] = show aPrime- prHashVars (v:vs) = prHashVars' (hashVar v) vs- prHashVars' r [] = r- prHashVars' r (v:vs) = prHashVars' (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashVar v) vs- hashVar var = "this." ++ var ++ ".GetHashCode()"--prList :: Namespace -> (Cat,Bool) -> String-prList namespace (c,_) = unlinesInline [- " public class " ++ c ++ " : List<" ++ identifier namespace (typename bas) ++ ">",- " {",- " }"- ]- where - bas = drop 4 c -- drop List---- The standard Accept method for the Visitor pattern-prAccept :: Namespace -> Cat -> Maybe String -> String-prAccept namespace cat maybeOverride = unlinesInline [- " ",- " public" ++ fromMaybe "" maybeOverride ++ " R Accept<R,A>(" ++ identifier namespace cat ++ ".Visitor<R,A> visitor, A arg)",- " {", - " return visitor.Visit(this, arg);",- " }"- ]---- The constructor assigns the parameters to the corresponding instance variables.-prConstructor :: Namespace -> CSharpAbsRule -> String-prConstructor namespace (f,cs) = unlinesInline [- " public " ++ f ++ "(" ++ conargs ++ ")",- " {",- unlinesInline [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs],- " }"- ]- where- cvs = [c | (_,_,c,_) <- cs]- pvs = ["p" ++ show i | ((x,st,_,_),i) <- zip cs [1..]]- conargs = concat $ intersperse ", " - [identifier namespace (typename x) +++ v | ((x,_,_,_),v) <- zip cs pvs]
− src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs
@@ -1,97 +0,0 @@-{-- BNF Converter: C# Abstract Visit Skeleton Generator- - Copyright (C) 2006 Author: Johan Broberg- - Modified from CAbstoCSharpVisitSkeleton-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates an Abstract Visit Skeleton for C#.- This can be useful if you often make changes to your - grammar and want to keep your own changes (not having to - merge with the new visit skeleton each time), while still - getting compile errors if your code is no longer correct.- The generated file uses the Visitor design pattern.-- This could have been generated from within - CAbstoVisitSkeleton, but that would have made it more - difficult to actually use it (and the visit skeleton).-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 19 December, 2006-- Modified : 19 December, 2006 by Johan Broberg- - ************************************************************** --}--module CAbstoCSharpAbstractVisitSkeleton (cabs2csharpAbstractVisitSkeleton) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import OOAbstract hiding (basetypes)-import CSharpUtils-import CAbstoCSharpAbs----Produces .cs file-cabs2csharpAbstractVisitSkeleton :: Namespace -> CAbs -> String-cabs2csharpAbstractVisitSkeleton namespace cabs = unlines [- "/*** BNFC-Generated Abstract Visitor Design Pattern Skeleton. ***/",- "/* This implements the common visitor design pattern.",- " Replace the R and A parameters with the desired return",- " and context types.*/",- "",- "namespace " ++ namespace ++ ".VisitSkeleton",- "{",- " #region Classes",- unlinesInlineMap (prCon namespace) (signatures cabs),- " #endregion",- " ",- " #region Token types",- unlinesInlineMap (prBasic namespace) (tokentypes cabs),- " #endregion",- "}"- ]--prBasic namespace c = unlinesInline [- " public abstract class Abstract" ++ c ++ "Visitor<R,A> : " ++ identifier namespace c ++ ".Visitor<R,A>",- " {",- " public abstract R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg);",- " }"- ]--prCon :: Namespace -> (Cat, [CAbsRule]) -> String-prCon namespace (c,fs) = unlinesInline [- " public abstract class Abstract" ++ c ++ "Visitor<R,A> : " ++ identifier namespace c ++ ".Visitor<R,A>",- " {",- unlinesInlineMap (prVisit namespace) fs,- " }"- ]--prVisit :: Namespace -> (Fun, [(Cat, Bool, String)]) -> String-prVisit namespace (f,cs) = unlinesInline [- " public abstract R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg);"- ]
− src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs
@@ -1,118 +0,0 @@-{-- BNF Converter: C# Visit Skeleton Generator- - Copyright (C) 2006 Author: Johan Broberg-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C# Visit Skeleton.- The generated file uses the Visitor design pattern.-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 30 November, 2006-- Modified : 21 January, 2007 by Johan Broberg- - ************************************************************** --}--module CAbstoCSharpVisitSkeleton (cabs2csharpvisitskeleton) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import OOAbstract hiding (basetypes)-import CSharpUtils-import CAbstoCSharpAbs----Produces .cs file-cabs2csharpvisitskeleton :: Namespace -> CAbs -> String-cabs2csharpvisitskeleton namespace cabs = unlines [- "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",- "/* This implements the common visitor design pattern. To make sure that",- " compile errors occur when code in the Visitor don't match the abstract",- " syntaxt, the \"abstract visit skeleton\" is used.",- " ",- " Replace the R and A parameters with the desired return",- " and context types.*/",- "",- "namespace " ++ namespace ++ ".VisitSkeleton",- "{",- " #region Classes",- unlinesInlineMap (prCon namespace) (signatures cabs),- " #endregion",- " ",- " #region Token types",- unlinesInlineMap (prBasic namespace) (tokentypes cabs),- " #endregion",- "}"- ]--prBasic namespace c = unlinesInline [- " public class " ++ c ++ "Visitor<R,A> : Abstract" ++ c ++ "Visitor<R,A>",- " {",- " public override R Visit(" ++ identifier namespace (typename c) +++ varname c ++ ", A arg)",- " {",- " /* Code for " ++ c ++ " Goes Here */",- " return default(R);",- " }",- " }"- ]--prCon :: Namespace -> (Cat, [CAbsRule]) -> String-prCon namespace (c,fs) = unlinesInline [- " public class " ++ c ++ "Visitor<R,A> : Abstract" ++ c ++ "Visitor<R,A>",- " {",- unlinesInlineMap (prVisit namespace) (map cabsrule2csharpabsrule fs),- " }"- ]---prVisit :: Namespace -> CSharpAbsRule -> String-prVisit namespace (f,cs) = unlinesInline [- " public override R Visit(" ++ identifier namespace f +++ varname f ++ ", A arg)",- " {",- " /* Code For " ++ f ++ " Goes Here */",- unlinesInline $ map (prVisitArg namespace (varname f)) cs,- " return default(R);",- " }"- ]--prVisitArg :: Namespace -> String -> (Cat, Bool, VariableName, PropertyName) -> String-prVisitArg namespace vname (cat, isPt, var, prop) - | cat `elem` (map fst basetypes) = " // " ++ vname ++ "." ++ prop- -- var /= "list_" is a dummy fix to make sure that a category named "List" doesn't get interpreted as a List.- -- this isn't very good though, and should be fixed somehow.- | "list" `isPrefixOf` var && var /= "list_" = listAccept- | otherwise = " " ++ vname ++ "." ++ prop ++ ".Accept(new " ++ cat ++ "Visitor<R,A>(), arg);"- where- listtype = typename (drop 4 cat)- listAccept = unlinesInline [- " foreach(" ++ identifier namespace listtype ++ " x in " ++ vname ++ "." ++ prop ++ ")",- " {",- if listtype `notElem` (map snd basetypes)- then " x.Accept(new " ++ listtype ++ "Visitor<R,A>(), arg);"- else " // x",- " }"- ]
− src/formats/c-sharp/CFtoCSharpPrinter.hs
@@ -1,455 +0,0 @@-{-- BNF Converter: C# Pretty Printer Generator- Copyright (C) 2006 Author: Johan Broberg- - Modified from CFtoSTLPrinter-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C# Pretty Printer.- It also generates the "show" method for- printing an abstract syntax tree.-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 26 November, 2006-- Modified : 21 January, 2007 by Johan Broberg- - ************************************************************** --}--module CFtoCSharpPrinter (cf2csharpprinter) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper, isSpace)-import Data.Maybe-import CSharpUtils----Produces .cs file-cf2csharpprinter :: Namespace -> CF -> String-cf2csharpprinter namespace cf = unlinesInline [- header namespace cf,- " ",- entrypoints namespace cf,- " ",- " #region (Internal) Print Methods",- unlinesInlineMap (prData namespace user) groups,- " #endregion",- " ",- " #region (Internal) Show Methods",- unlinesInlineMap (shData namespace user) groups,- " #endregion",- " }",- " #endregion",- "}"- ]- where- groups = fixCoercions (ruleGroupsInternals cf)- user = [n | (n,_) <- tokenPragmas cf]--header :: Namespace -> CF -> String-header namespace cf = unlinesInline [- "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",- " ",- -- imports- "using System;",- "using System.Text; // for StringBuilder",- "using " ++ namespace ++ ".Absyn;",- " ",- "namespace " ++ namespace,- "{",- " #region Pretty-printer class",- " public class PrettyPrinter",- " {",- " #region Misc rendering functions",- " // You may wish to change these:",- " private const int BUFFER_INITIAL_CAPACITY = 2000;",- " private const string LEFT_PARENTHESIS = \"(\";",- " private const string RIGHT_PARENTHESIS = \")\";",- " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",- " ",- " private static int _n_ = 0;",- " private static StringBuilder buffer = new StringBuilder(BUFFER_INITIAL_CAPACITY);",- " ",- " //You may wish to change render",- " private static void Render(String s)",- " {",- " if(s == \"{\")",- " {",- " buffer.Append(\"\\n\");",- " Indent();",- " buffer.Append(s);",- " _n_ = _n_ + 2;",- " buffer.Append(\"\\n\");",- " Indent();",- " }",- " else if(s == \"(\" || s == \"[\")",- " buffer.Append(s);",- " else if(s == \")\" || s == \"]\")",- " {",- " Backup();",- " buffer.Append(s);",- " buffer.Append(\" \");",- " }",- " else if(s == \"}\")",- " {",- " _n_ = _n_ - 2;",- " Backup();",- " Backup();",- " buffer.Append(s);",- " buffer.Append(\"\\n\");",- " Indent();",- " }",- " else if(s == \",\")",- " {",- " Backup();",- " buffer.Append(s);",- " buffer.Append(\" \");",- " }",- " else if(s == \";\")",- " {",- " Backup();",- " buffer.Append(s);",- " buffer.Append(\"\\n\");",- " Indent();",- " }",- " else if(s == \"\") return;",- " else",- " {",- " // Make sure escaped characters are printed properly!",- " if(s.StartsWith(\"\\\"\") && s.EndsWith(\"\\\"\"))",- " {",- " buffer.Append('\"');",- " StringBuilder sb = new StringBuilder(s);",- " // Remove enclosing citation marks",- " sb.Remove(0,1);",- " sb.Remove(sb.Length-1,1);",- " // Note: we have to replace backslashes first! (otherwise it will \"double-escape\" the other escapes)",- " sb.Replace(\"\\\\\", \"\\\\\\\\\");",- " sb.Replace(\"\\n\", \"\\\\n\");",- " sb.Replace(\"\\t\", \"\\\\t\");",- " sb.Replace(\"\\\"\", \"\\\\\\\"\");",- " buffer.Append(sb.ToString());",- " buffer.Append('\"');",- " }",- " else",- " {",- " buffer.Append(s);",- " }",- " buffer.Append(\" \");",- " }",- " }",- " ",- " private static void PrintInternal(int n, int _i_)",- " {",- " buffer.Append(n.ToString(InvariantFormatInfo));",- " buffer.Append(' ');",- " }",- " ",- " private static void PrintInternal(double d, int _i_)",- " {",- " buffer.Append(d.ToString(InvariantFormatInfo));",- " buffer.Append(' ');",- " }",- " ",- " private static void PrintInternal(string s, int _i_)",- " {",- " Render(s);",- " }",- " ",- " private static void PrintInternal(char c, int _i_)",- " {",- " PrintQuoted(c);",- " }",- " ",- unlinesInlineMap (prToken namespace) (tokenNames cf),- " ",- " private static void ShowInternal(int n)",- " {",- " Render(n.ToString(InvariantFormatInfo));",- " }",- " ",- " private static void ShowInternal(double d)",- " {",- " Render(d.ToString(InvariantFormatInfo));",- " }",- " ",- " private static void ShowInternal(char c)",- " {",- " PrintQuoted(c);",- " }",- " ",- " private static void ShowInternal(string s)",- " {",- " PrintQuoted(s);",- " }",- " ",- unlinesInlineMap (shToken namespace) (tokenNames cf),- " ",- " private static void PrintQuoted(string s)",- " {",- " Render(\"\\\"\" + s + \"\\\"\");",- " }",- " ",- " private static void PrintQuoted(char c)",- " {",- " // Makes sure the character is escaped properly before printing it.",- " string str = c.ToString();",- " if(c == '\\n') str = \"\\\\n\";",- " if(c == '\\t') str = \"\\\\t\";",- " Render(\"'\" + str + \"'\");",- " }",- " ",- " private static void Indent()",- " {",- " int n = _n_;",- " while (n > 0)",- " {",- " buffer.Append(' ');",- " n--;",- " }",- " }",- " ",- " private static void Backup()",- " {",- " if(buffer[buffer.Length - 1] == ' ')",- " {", - " buffer.Length = buffer.Length - 1;",- " }",- " }",- " ",- " private static void Trim()",- " {",- " while(buffer.Length > 0 && buffer[0] == ' ')",- " buffer.Remove(0, 1); ",- " while(buffer.Length > 0 && buffer[buffer.Length-1] == ' ')",- " buffer.Remove(buffer.Length-1, 1);",- " }",- " ",- " private static string GetAndReset()",- " {",- " Trim();",- " string strReturn = buffer.ToString();",- " Reset();",- " return strReturn;",- " }",- " ",- " private static void Reset()",- " {",- " buffer.Remove(0, buffer.Length);",- " }",- " #endregion"- ]--prToken :: Namespace -> Cat -> String-prToken namespace token = unlinesInline [- " private static void PrintInternal(" ++ identifier namespace token ++ " token, int _i_)",- " {",- " buffer.Append('\\\"');",- " buffer.Append(token.ToString());",- " buffer.Append('\\\"');",- " }"- ]--shToken :: Namespace -> Cat -> String-shToken namespace token = unlinesInline [- " private static void ShowInternal(" ++ identifier namespace token ++ " token)",- " {",- " Render(token.ToString());",- " }"- ]--entrypoints :: Namespace -> CF -> String-entrypoints namespace cf = unlinesInline [- " #region Print Entry Points",- unlinesInlineMap prEntryPoint (allCats cf),- " #endregion",- " ",- " #region Show Entry Points",- unlinesInlineMap shEntryPoint (allCats cf),- " #endregion"- ]- where- prEntryPoint cat | (normCat cat) == cat = unlinesInline [- " public static string Print(" ++ identifier namespace (identCat cat) ++ " cat)",- " {",- " PrintInternal(cat, 0);",- " return GetAndReset();",- " }"- ]- prEntryPoint _ = ""- shEntryPoint cat | (normCat cat) == cat = unlinesInline [- " public static String Show(" ++ identifier namespace (identCat cat) ++ " cat)",- " {",- " ShowInternal(cat);",- " return GetAndReset();",- " }"- ]- shEntryPoint _ = ""--prData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String-prData namespace user (cat, rules) - -- list- | isList cat = unlinesInline [ - " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)",- " {",- (prList user cat rules),- " }"- ]- -- not a list- | otherwise = unlinesInline [- " private static void PrintInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p, int _i_)",- " {",- -- first rule starts with "if", the rest of them start with "else if".- -- this isn't very pretty, but does the job and produces nice code.- prRule namespace Nothing firstRule,- unlinesInline $ map (prRule namespace (Just "else ")) otherRules,- " }"- ]- where - -- Removes the rules at the beginning of the list which won't be used by the prRule function.- rules' = dropWhile (\r -> isCoercion (funRule r) || isDefinedRule (funRule r)) rules- firstRule = head rules'- otherRules = tail rules'--prRule :: Namespace -> Maybe String -> Rule -> String-prRule namespace maybeElse r@(Rule fun _c cats)- | not (isCoercion fun || isDefinedRule fun) = unlinesInline [- " " ++ fromMaybe "" maybeElse ++ "if(p is " ++ identifier namespace fun ++ ")",- " {",- " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;",- " if(_i_ > " ++ (show p) ++ ") Render(LEFT_PARENTHESIS);",- cats',- " if(_i_ > " ++ (show p) ++ ") Render(RIGHT_PARENTHESIS);",- " }"- ]- where- p = precRule r- cats' = case cats of - [] -> ""- _ -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats))- fnm = '_' : map toLower fun-- getPrec (Right {}) = 0- getPrec (Left c) = precCat c-prRule _nm _ _ = ""--prList :: [UserDef] -> Cat -> [Rule] -> String-prList user c rules = unlinesInline [- " for(int i=0; i < p.Count; i++)",- " {",- " PrintInternal(p[i], 0);",- " if(i < p.Count - 1)",- " {",- " Render(\"" ++ escapeChars sep ++ "\");",- " }",- " else",- " {",- " Render(\"" ++ optsep ++ "\");",- " }",- " }"- ]- where- et = typename (normCatOfList c)- sep = getCons rules- optsep = if hasOneFunc rules then "" else escapeChars sep--prCat fnm (c, p) = - case c of- Right t -> " Render(\"" ++ escapeChars t ++ "\");"- Left nt - | "string" `isPrefixOf` nt -> " PrintQuoted(" ++ fnm ++ "." ++ nt ++ ");"- | isInternalVar nt -> ""- | otherwise -> " PrintInternal(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");"-----The following methods generate the Show function.--shData :: Namespace -> [UserDef] -> (Cat, [Rule]) -> String-shData namespace user (cat, rules) - | isList cat = unlinesInline [- " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)",- " {",- (shList user cat rules),- " }"- ]- | otherwise = unlinesInline [ - " private static void ShowInternal(" ++ identifier namespace (identCat (normCat cat)) ++ " p)",- " {",- unlinesInline $ map (shRule namespace) rules,- " }"- ]--shRule :: Namespace -> Rule -> String-shRule namespace (Rule fun _c cats)- | not (isCoercion fun || isDefinedRule fun) = unlinesInline [- " if(p is " ++ identifier namespace fun ++ ")",- " {",- " " ++ identifier namespace fun +++ fnm ++ " = (" ++ identifier namespace fun ++ ")p;",- lparen,- " Render(\"" ++ (escapeChars fun) ++ "\");",- cats',- rparen,- " }"- ]- where- cats' | allTerms cats = ""- | otherwise = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats))- lparen | allTerms cats = ""- | otherwise = " Render(\"(\");"- rparen | allTerms cats = ""- | otherwise = " Render(\")\");"- allTerms [] = True- allTerms ((Left {}):_) = False- allTerms (_:zs) = allTerms zs- fnm = '_' : map toLower fun-shRule _nm _ = ""--shList :: [UserDef] -> Cat -> [Rule] -> String-shList user c _rules = unlinesInline [- " for(int i=0; i < p.Count; i++)",- " {",- " ShowInternal(p[i]);",- " if(i < p.Count - 1)",- " Render(\",\");",- " }"- ]- where- et = typename (normCatOfList c)- -shCat fnm c =- case c of- Right {} -> ""- Left nt - | "list" `isPrefixOf` nt -> unlinesInline [- " Render(\"[\");",- " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");",- " Render(\"]\");"- ]- | isInternalVar nt -> ""- | otherwise -> " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");"--isInternalVar x = x == internalCat ++ "_"
− src/formats/c-sharp/CFtoGPLEX.hs
@@ -1,221 +0,0 @@-{-- BNF Converter: C# GPLEX Generator- Copyright (C) 2006 Author: Johan Broberg- - Modified from CFtoFlex-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the GPLEX file.-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 23 November, 2006-- Modified : 17 December, 2006 by Johan Broberg-- ************************************************************** --}--module CFtoGPLEX (cf2gplex) where--import CF-import RegToGPLEX-import Utils((+++), (++++))-import NamedVariables-import Data.List-import CSharpUtils----The environment must be returned for the parser to use.-cf2gplex :: Namespace -> CF -> (String, SymEnv)-cf2gplex namespace cf = (unlines [- prelude namespace,- cMacros,- prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'),- "%%"- ], env')- where- env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)- env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env))- -- GPPG doesn't seem to like tokens beginning with an underscore, so they (the underscores, nothing else) have been removed.- makeSymEnv [] _ = []- makeSymEnv (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))--prelude :: Namespace -> String-prelude namespace = unlines [- "/* This GPLex file was machine-generated by the BNF converter */",- "",- "%namespace " ++ namespace,- "",- "%{",- " /// <summary>",- " /// Buffer for escaped characters in strings.",- " /// </summary>",- " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();",- "",- " /// <summary>",- " /// Change to enable output - useful for debugging purposes",- " /// </summary>",- " public bool Trace = false;",- "",- " /// <summary>",- " /// Culture-independent IFormatProvider for numbers. ",- " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.",- " /// </summary>",- " /// <remarks>",- " /// This should be used when parsing numbers. Otherwise the parser might fail: ",- " /// culture en-US uses a dot as decimal separator, while for example sv-SE uses a comma. ",- " /// BNFC uses dot as decimal separator for Double values, so if your culture is sv-SE ",- " /// the parse will fail if this InvariantInfo isn't used.",- " /// </remarks>",- " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;",- "",- " /// <summary>",- " /// Convenience method to create scanner AND initialize it correctly.",- " /// As long as you don't want to enable trace output, this is all you ",- " /// need to call and give to the parser to be able to parse.",- " /// </summary>",- " public static Scanner CreateScanner(Stream stream)",- " {",- " Scanner scanner = new Scanner(stream);",- " scanner.Begin();",- " return scanner;",- " }",- "",- " /// <summary>",- " /// Sets the scanner to the correct initial state (YYINITIAL). ",- " /// You should call this method prior to calling parser.Parse().",- " /// </summary>",- " public void Begin()",- " {",- " BEGIN(YYINITIAL);",- " }",- "",- " /// <summary>",- " /// Convenience method to \"reset\" the buffer for escaped characters in strings.",- " /// </summary>",- " private void BufferReset()",- " {",- " this.strBuffer = new System.Text.StringBuilder();",- " }",- "",- "%}",- ""- ]----For now all categories are included.---Optimally only the ones that are used should be generated.-cMacros :: String-cMacros = unlines- [- "alpha [a-zA-Z]",- "alphaCapital [A-Z]",- "alphaSmall [a-z]",- "digit [0-9]",- "ident [a-zA-Z0-9'_]",- -- start states, must be defined one at a time- "%s YYINITIAL",- "%s COMMENT",- "%s CHAR",- "%s CHARESC",- "%s CHAREND",- "%s STRING",- "%s ESCAPED",- "%%"- ]--lexSymbols :: SymEnv -> [(String, String)]-lexSymbols ss = map transSym ss- where- transSym (s,r) = - ("<YYINITIAL>\"" ++ s' ++ "\"" , "if(Trace) System.Console.Error.WriteLine(yytext); return (int)Tokens." ++ r ++ ";")- where- s' = escapeChars s--gplex :: Namespace -> CF -> SymEnv -> [(String, String)]-gplex namespace cf env = concat [- lexComments (comments cf),- userDefTokens,- ifC "String" strStates,- ifC "Char" charStates,- ifC "Double" [("<YYINITIAL>{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")],- ifC "Integer" [("<YYINITIAL>{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")],- ifC "Ident" [("<YYINITIAL>{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")],- [("<YYINITIAL>[ \\t\\r\\n\\f]" , "/* ignore white space. */;")],- [("<YYINITIAL>." , "return (int)Tokens.error;")]- ]- where- ifC cat s = if isUsedCat cf cat then s else []- userDefTokens = map tokenline (tokenPragmas cf)- where- tokenline (name, exp) = ("<YYINITIAL>" ++ printRegGPLEX exp , action name)- action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName (normCat n) ++ " = new " ++ identifier namespace n ++ "(yytext); return (int)Tokens." ++ sName n ++ ";"- sName n = case lookup n env of- Just x -> x- Nothing -> n- -- These handle escaped characters in Strings.- strStates = [- ("<YYINITIAL>\"\\\"\"" , "BEGIN(STRING);"),- ("<STRING>\\\\" , "BEGIN(ESCAPED);"),- ("<STRING>\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"),- ("<STRING>." , "this.strBuffer.Append(yytext);"),- ("<ESCAPED>n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"),- ("<ESCAPED>\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"),- ("<ESCAPED>\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"),- ("<ESCAPED>t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"),- ("<ESCAPED>." , "this.strBuffer.Append(yytext); BEGIN(STRING);")- ]- -- These handle escaped characters in Chars.- charStates = [- ("<YYINITIAL>\"'\"" , "BEGIN(CHAR);"),- ("<CHAR>\\\\" , "BEGIN(CHARESC);"),- ("<CHAR>[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),- ("<CHARESC>n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"),- ("<CHARESC>t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"),- ("<CHARESC>." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"),- ("<CHAREND>\"'\"" , "BEGIN(YYINITIAL);")- ]--lexComments :: ([(String, String)], [String]) -> [(String, String)]-lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m)--lexSingleComment :: String -> (String, String)-lexSingleComment c = - ("<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n" , "/* BNFC single-line comment */;")----There might be a possible bug here if a language includes 2 multi-line comments.---They could possibly start a comment with one character and end it with another.---However this seems rare.-lexMultiComment :: (String, String) -> [(String, String)]-lexMultiComment (b,e) = [- ("<YYINITIAL>\"" ++ b ++ "\"" , "BEGIN(COMMENT);"),- ("<COMMENT>\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"),- ("<COMMENT>." , "/* BNFC multi-line comment */;"),- ("<COMMENT>[\\n]" , "/* BNFC multi-line comment */;")- ]---- Used to print the lexer rules; makes sure that all rules are equally indented, to make the GPLEX file a little more readable.-prettyprinter :: [(String, String)] -> String-prettyprinter xs = unlines $ map prettyprinter' xs- where - padlength = 1 + (last $ sort $ map length $ map fst xs)- prettyprinter' (x, y) = x ++ replicate (padlength - length x) ' ' ++ y
− src/formats/c-sharp/CFtoGPPG.hs
@@ -1,275 +0,0 @@-{-- BNF Converter: C# GPPG Generator- Copyright (C) 2006 Author: Johan Broberg- - Modified from CFtoBisonSTL.-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the GPPG input file.-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 24 November, 2006-- Modified : 17 December, 2006 by Johan Broberg-- ************************************************************** --}--module CFtoGPPG (cf2gppg) where--import CF-import Data.List (intersperse, isPrefixOf)-import NamedVariables hiding (varName)-import Data.Char (toLower,isUpper,isDigit)-import Utils ((+++), (++++))-import TypeChecker-import ErrM-import OOAbstract hiding (basetypes)-import CSharpUtils----This follows the basic structure of CFtoHappy.---- Type declarations-type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String----The environment comes from the CFtoGPLEX-cf2gppg :: Namespace -> CF -> SymEnv -> String-cf2gppg namespace cf env = unlines [- header namespace cf,- union namespace (positionCats cf ++ allCats cf ++ tokentypes (cf2cabs cf)),- tokens user env,- declarations cf,- "",- specialToks cf,- "",- "%%",- prRules (rulesForGPPG namespace cf env)- ]- where- user = fst (unzip (tokenPragmas cf))--positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))--header :: Namespace -> CF -> String-header namespace cf = unlines [- "/* This GPPG file was machine-generated by BNFC */",- "",- "%namespace " ++ namespace,- "%{",- definedRules namespace cf,- unlinesInline $ map (parseMethod namespace) (allCatsIdNorm cf ++ positionCats cf),- "%}"- ]--definedRules :: Namespace -> CF -> String-definedRules namespace cf = unlinesInline [- if null [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ] - then ""- else error "Defined rules are not yet available in C# mode!"- ]- where- ctx = buildContext cf-- list = LC (const "[]") (\t -> "List" ++ unBase t)- where- unBase (ListT t) = unBase t- unBase (BaseT x) = normCat x-- rule f xs e =- case checkDefinition' list ctx f xs e of- Bad err -> error $ "Panic! This should have been caught already:\n" ++ err- Ok (args,(e',t)) -> unlinesInline [- "Defined Rule goes here"- ]----This generates a parser method for each entry point.-parseMethod :: Namespace -> Cat -> String-parseMethod namespace cat = unlinesInline [- " " ++ returntype +++ returnvar ++ " = null;",- " public " ++ returntype ++ " Parse" ++ cat' ++ "()",- " {",- " if(this.Parse())",- " {",- " return " ++ returnvar ++ ";",- " }",- " else",- " {",- " throw new Exception(\"Could not parse input stream!\");",- " }",- " }",- " "- ]- where- cat' = identCat (normCat cat)- returntype = identifier namespace cat'- returnvar = resultName cat'----The union declaration is special to GPPG/GPLEX and gives the type of yylval.---For efficiency, we may want to only include used categories here.-union :: Namespace -> [Cat] -> String-union namespace cats = unlines $ filter (\x -> x /= "\n") [- "%union",- "{",- " public int int_;",- " public char char_;",- " public double double_;",- " public string string_;",- unlinesInline $ map catline cats,- "}"- ]- where --This is a little weird because people can make [Exp2] etc.- catline cat | (identCat cat /= cat) || (normCat cat == cat) = - " public " ++ identifier namespace (identCat (normCat cat)) +++ (varName (normCat cat)) ++ ";"- catline cat = ""----declares non-terminal types.-declarations :: CF -> String-declarations cf = unlinesInline $ map (typeNT cf) (positionCats cf ++ allCats cf)- where --don't define internal rules- typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt)- typeNT cf nt = ""----declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user ts = concatMap (declTok user) ts- where- declTok u (s,r) = if elem s u- then "%token<" ++ varName (normCat s) ++ "> " ++ r ++ " // " ++ s ++ "\n"- else "%token " ++ r ++ " // " ++ s ++ "\n"--specialToks :: CF -> String-specialToks cf = unlinesInline [ - ifC "String" "%token<string_> STRING_",- ifC "Char" "%token<char_> CHAR_",- ifC "Integer" "%token<int_> INTEGER_",- ifC "Double" "%token<double_> DOUBLE_",- ifC "Ident" "%token<string_> IDENT_"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules-rulesForGPPG namespace cf env = (map mkOne $ ruleGroups cf) ++ posRules where- mkOne (cat,rules) = constructRule namespace cf env rules cat- posRules = map mkPos $ positionCats cf- mkPos cat = (cat, [(maybe cat id (lookup cat env),- "$$ = new " ++ cat ++ "($1);")])---- For every non-terminal, we construct a set of rules.-constructRule :: Namespace -> - CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule namespace cf env rules nt = - (nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) | - r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf env r b])- where- ruleName r = case funRule r of- ---- "(:)" -> identCat nt- ---- "(:[])" -> identCat nt- z -> z- revs = reversibleCats cf- eps = allEntryPoints cf- isEntry nt = if elem nt eps then True else False- result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else ""---- Generates a string containing the semantic action.--- This was copied from CFtoCup15, with only a few small modifications-generateAction :: Namespace -> NonTerminal -> Fun -> Bool -> [(MetaVar, Bool)] - -> Action-generateAction namespace nt f rev mbs- | isNilFun f = "$$ = new " ++ identifier namespace c ++ "();"- | isOneFun f = "$$ = new " ++ identifier namespace c ++ "(); $$.Add(" ++ p_1 ++ ");"- | isConsFun f && not rev = "$$ = " ++ p_2 ++ "; " ++ p_2 ++ ".Insert(0, " ++ p_1 ++ ");"- | isConsFun f && rev = "$$ = " ++ p_1 ++ "; " ++ p_1 ++ ".Add(" ++ p_2 ++ ");"- | isCoercion f = "$$ = " ++ p_1 ++ ";"- | isDefinedRule f = "$$ = " ++ f ++ "_" ++ "(" ++ concat (intersperse "," ms) ++ ");"- | otherwise = "$$ = new " ++ identifier namespace c ++ "(" ++ concat (intersperse "," ms) ++ ");"- where- c = if isNilFun f || isOneFun f || isConsFun f - then identCat (normCat nt) else f- ms = map fst mbs- p_1 = ms!!0- p_2 = ms!!1----- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])-generatePatterns cf env r revv = case rhsRule r of- [] -> ("/* empty */",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> case lookup c env of- -- This used to be x, but that didn't work if we had a symbol "String" in env, and tried to use a normal String - it would use the symbol...- Just x | not (isPositionCat cf c) && c `notElem` (map fst basetypes) -> x- _ -> typeName (identCat c)- Right s -> case lookup s env of- Just x -> x- Nothing -> s- metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]-- -- notice: reversibility with push_back vectors is the opposite- -- of right-recursive lists!- revert c = (head c == '[') && - not (isConsFun (funRule r)) && notElem c revs - revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules [] = []-prRules ((nt, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls----Some helper functions.-resultName :: String -> String-resultName s = "YY_RESULT_" ++ s ++ "_"----slightly stronger than the NamedVariable version.-varName :: String -> String-varName s = (map toLower (identCat s)) ++ "_"--typeName :: String -> String-typeName "Ident" = "IDENT_"-typeName "String" = "STRING_"-typeName "Char" = "CHAR_"-typeName "Integer" = "INTEGER_"-typeName "Double" = "DOUBLE_"-typeName x = x
− src/formats/c-sharp/CSharpTop.hs
@@ -1,361 +0,0 @@-{-- BNF Converter: C# Main file- Copyright (C) 2006-2007 Author: Johan Broberg-- Modified from STLTop 2006.-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}-{- - **************************************************************- BNF Converter Module-- Description : C# Main file-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 20 November, 2006-- Modified : 8 January, 2007 by Johan Broberg- - ************************************************************** --}--module CSharpTop (makeCSharp) where--import Utils-import CF-import OOAbstract-import CAbstoCSharpAbs-import CFtoGPLEX-import CFtoGPPG-import CAbstoCSharpVisitSkeleton-import CAbstoCSharpAbstractVisitSkeleton-import CFtoCSharpPrinter-import CFtoLatex-import CSharpUtils-import Data.Char-import System.Exit (exitFailure)-import System.Environment (getEnv)-import System.Directory-import System.IO-import System.IO.Error (catchIOError)-import System.Process-import Data.Maybe-import Data.Char-import Control.Monad.ST---- Control.Monad.State--makeCSharp :: Bool -- Makefile- -> Bool -- Visual Studio files- -> Bool -- Windows Communication Foundation support- -> Maybe Namespace -- C# namespace to use- -> CF - -> FilePath- -> IO ()-makeCSharp make vsfiles wcfSupport maybenamespace cf file = do- let namespace = fromMaybe (filepathtonamespace file) maybenamespace- cabs = cf2cabs cf- absyn = cabs2csharpabs namespace cabs wcfSupport- (gplex, env) = cf2gplex namespace cf- gppg = cf2gppg namespace cf env- skeleton = cabs2csharpvisitskeleton namespace cabs- absSkeleton = cabs2csharpAbstractVisitSkeleton namespace cabs- printer = cf2csharpprinter namespace cf- latex = cfToLatex namespace cf- writeFileRep "Absyn.cs" absyn- writeFileRep (namespace ++ ".l") gplex- putStrLn " (Tested with GPLEX RC1)"- writeFileRep (namespace ++ ".y") gppg- putStrLn " (Tested with GPPG 1.0)"- writeFileRep "AbstractVisitSkeleton.cs" absSkeleton- writeFileRep "VisitSkeleton.cs" skeleton- writeFileRep "Printer.cs" printer- writeFileRep "Test.cs" (csharptest namespace cf)- writeFileRep (namespace ++ ".tex") latex- if vsfiles then (writeVisualStudioFiles namespace) else return ()- if make then (writeMakefile namespace) else return ()--writeMakefile :: Namespace -> IO ()-writeMakefile namespace = do - writeFileRep "Makefile" makefile- putStrLn ""- putStrLn "-----------------------------------------------------------------------------"- putStrLn "Generated Makefile, which uses mono. You may want to modify the paths to"- putStrLn "GPLEX and GPPG - unless you are sure that they are globally accessible (the"- putStrLn "default commands are \"mono gplex.exe\" and \"mono gppg.exe\", respectively."- putStrLn "The Makefile assumes that ShiftReduceParser.dll is located in ./bin and that"- putStrLn "is also where test.exe will be generated."- putStrLn "-----------------------------------------------------------------------------"- putStrLn ""- where- makefile = unlines [ - "MONO = mono",- "MONOC = gmcs",- "MONOCFLAGS = -optimize -reference:${PARSERREF}",- "GPLEX = ${MONO} gplex.exe",- "GPPG = ${MONO} gppg.exe",- "LATEX = latex",- "DVIPS = dvips",- "PARSERREF = bin/ShiftReduceParser.dll",- -- Apparently GPLEX outputs filenames in lowercase, so scanner.cs is supposed to be like that!- "CSFILES = Absyn.cs Parser.cs Printer.cs scanner.cs Test.cs VisitSkeleton.cs",- "",- "all: test " ++ namespace ++ ".ps",- "",- "clean:",- -- peteg: don't nuke what we generated - move that to the "vclean" target.- "\trm -f " ++ namespace ++ ".dvi " ++ namespace ++ ".aux " ++ namespace ++ ".log " ++ namespace ++ ".ps test",- "",- "distclean:",- "\trm -f ${CSFILES} " ++ namespace ++ ".l " ++ namespace ++ ".y " ++ namespace ++ ".tex " ++ namespace ++ ".dvi " ++ namespace ++ ".aux " ++ namespace ++ ".log " ++ namespace ++ ".ps test Makefile",- "",- "test: Parser.cs Scanner.cs",- "\t@echo \"Compiling test...\"",- "\t${MONOC} ${MONOCFLAGS} -out:bin/test.exe ${CSFILES}",- "",- "Scanner.cs: " ++ namespace ++ ".l",- "\t${GPLEX} /out:Scanner.cs " ++ namespace ++ ".l",- "",- "Parser.cs: " ++ namespace ++ ".y",- "\t${GPPG} /gplex " ++ namespace ++ ".y > Parser.cs",- "",- "" ++ namespace ++ ".dvi: " ++ namespace ++ ".tex",- "\t${LATEX} " ++ namespace ++ ".tex",- "",- "" ++ namespace ++ ".ps: " ++ namespace ++ ".dvi",- "\t${DVIPS} " ++ namespace ++ ".dvi -o " ++ namespace ++ ".ps",- ""- ]--writeVisualStudioFiles :: Namespace -> IO ()-writeVisualStudioFiles namespace = do- guid <- projectguid- writeFileRep (namespace ++ ".csproj") (csproj guid)- writeFileRep (namespace ++ ".sln") (sln guid)- writeFileRep "run-gp.bat" batchfile- putStrLn ""- putStrLn "-----------------------------------------------------------------------------"- putStrLn "Visual Studio solution (.sln) and project (.csproj) files were written."- putStrLn "The project file has a reference to GPLEX/GPPG's ShiftReduceParser. You will"- putStrLn "have to either copy this file to bin\\ShiftReduceParser.dll or change the"- putStrLn "reference so that it points to the right location (you can do this from"- putStrLn "within Visual Studio)."- putStrLn "Additionally, the project includes Parser.cs and Scanner.cs. These have not"- putStrLn "been generated yet. You can use the run-gp.bat file to generate them, but"- putStrLn "note that it requires gppg and gplex to be in your PATH."- putStrLn "-----------------------------------------------------------------------------"- putStrLn ""- where- batchfile = unlines [- "@echo off",- "gppg /gplex " ++ namespace ++ ".y > Parser.cs",- "gplex /verbose /out:Scanner.cs " ++ namespace ++ ".l"- ]- sln guid = unlines [- "Microsoft Visual Studio Solution File, Format Version 9.00",- "# Visual Studio 2005",- "Project(\"{FAE04EC0-301F-11D3-BF4B-00C04F79EFBC}\") = \"" ++ namespace ++ "\", \"" ++ namespace ++ ".csproj\", \"" ++ guid ++ "\"",- "EndProject",- "Global",- " GlobalSection(SolutionConfigurationPlatforms) = preSolution",- " Debug|Any CPU = Debug|Any CPU",- " Release|Any CPU = Release|Any CPU",- " EndGlobalSection",- " GlobalSection(ProjectConfigurationPlatforms) = postSolution",- " " ++ guid ++ ".Debug|Any CPU.ActiveCfg = Debug|Any CPU",- " " ++ guid ++ ".Debug|Any CPU.Build.0 = Debug|Any CPU",- " " ++ guid ++ ".Release|Any CPU.ActiveCfg = Release|Any CPU",- " " ++ guid ++ ".Release|Any CPU.Build.0 = Release|Any CPU",- " EndGlobalSection",- " GlobalSection(SolutionProperties) = preSolution",- " HideSolutionNode = FALSE",- " EndGlobalSection",- "EndGlobal"- ]- csproj guid = unlines [- "<?xml version=\"1.0\" encoding=\"utf-8\"?>",- "<Project DefaultTargets=\"Build\" xmlns=\"http://schemas.microsoft.com/developer/msbuild/2003\">",- " <PropertyGroup>",- " <Configuration Condition=\" '$(Configuration)' == '' \">Debug</Configuration>",- " <Platform Condition=\" '$(Platform)' == '' \">AnyCPU</Platform>",- " <ProductVersion>8.0.50727</ProductVersion>",- " <SchemaVersion>2.0</SchemaVersion>",- " <ProjectGuid>" ++ guid ++ "</ProjectGuid>",- " <OutputType>Library</OutputType>",- " <AppDesignerFolder>Properties</AppDesignerFolder>",- " <RootNamespace>" ++ namespace ++ "</RootNamespace>",- " <AssemblyName>" ++ namespace ++ "</AssemblyName>",- " <StartupObject>",- " </StartupObject>",- " </PropertyGroup>",- " <PropertyGroup Condition=\" '$(Configuration)|$(Platform)' == 'Debug|AnyCPU' \">",- " <DebugSymbols>true</DebugSymbols>",- " <DebugType>full</DebugType>",- " <Optimize>false</Optimize>",- " <OutputPath>bin\\Debug\\</OutputPath>",- " <DefineConstants>DEBUG;TRACE</DefineConstants>",- " <ErrorReport>prompt</ErrorReport>",- " <WarningLevel>4</WarningLevel>",- " </PropertyGroup>",- " <PropertyGroup Condition=\" '$(Configuration)|$(Platform)' == 'Release|AnyCPU' \">",- " <DebugType>pdbonly</DebugType>",- " <Optimize>true</Optimize>",- " <OutputPath>bin\\Release\\</OutputPath>",- " <DefineConstants>TRACE</DefineConstants>",- " <ErrorReport>prompt</ErrorReport>",- " <WarningLevel>4</WarningLevel>",- " </PropertyGroup>",- " <Import Project=\"$(MSBuildBinPath)\\Microsoft.CSharp.targets\" />",- " <!-- To modify your build process, add your task inside one of the targets below and uncomment it. ",- " Other similar extension points exist, see Microsoft.Common.targets.",- " <Target Name=\"BeforeBuild\">",- " </Target>",- " <Target Name=\"AfterBuild\">",- " </Target>",- " -->",- " <ItemGroup>",- " <Compile Include=\"AbstractVisitSkeleton.cs\" />",- " <Compile Include=\"Absyn.cs\" />",- " <Compile Include=\"Parser.cs\" />",- " <Compile Include=\"Printer.cs\" />",- " <Compile Include=\"Scanner.cs\" />",- " <Compile Include=\"Test.cs\" />",- " <Compile Include=\"VisitSkeleton.cs\" />",- " </ItemGroup>",- " <ItemGroup>",- " <Reference Include=\"ShiftReduceParser, Version=0.0.0.0, Culture=neutral, processorArchitecture=MSIL\">",- " <SpecificVersion>False</SpecificVersion>",- " <HintPath>bin\\ShiftReduceParser.dll</HintPath>",- " </Reference>",- " </ItemGroup>",- " <ItemGroup>",- " <None Include=\"" ++ namespace ++ ".cf\" />",- " <None Include=\"" ++ namespace ++ ".l\" />",- " <None Include=\"" ++ namespace ++ ".y\" />",- " <None Include=\"" ++ namespace ++ ".tex\" />",- " <None Include=\"run-gp.bat\" />",- " </ItemGroup>",- " <PropertyGroup>",- " <PreBuildEvent>",- " </PreBuildEvent>",- " </PropertyGroup>",- "</Project>"- ]--csharptest :: Namespace -> CF -> String-csharptest namespace cf = unlines [- "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",- "/* */",- "/* This test will parse a file, print the abstract syntax tree, and then */",- "/* pretty-print the result. */",- "/* */",- "/****************************************************************************/",- "using System;",- "using System.IO;",- "using " ++ namespace ++ ".Absyn;",- "",- "namespace " ++ namespace,- "{",- " public class Test",- " {",- " public static void Main(string[] args)",- " {",- " if (args.Length > 0)",- " {",- " Stream stream = File.OpenRead(args[0]);",- " /* The default entry point is used. For other options see class Parser */",- " Parser parser = new Parser();",- " Scanner scanner = Scanner.CreateScanner(stream);",- " // Uncomment to enable trace information:",- " // parser.Trace shows what the parser is doing",- " // parser.Trace = true;",- " // scanner.Trace prints the tokens as they are parsed, one token per line",- " // scanner.Trace = true;",- " parser.scanner = scanner;",- " try",- " {",- " " ++ def ++ " parse_tree = parser.Parse" ++ def ++ "();",- " if (parse_tree != null)",- " {",- " Console.Out.WriteLine(\"Parse Successful!\");",- " Console.Out.WriteLine(\"\");",- " Console.Out.WriteLine(\"[Abstract Syntax]\");",- " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Show(parse_tree));",- " Console.Out.WriteLine(\"\");",- " Console.Out.WriteLine(\"[Linearized Tree]\");",- " Console.Out.WriteLine(\"{0}\", PrettyPrinter.Print(parse_tree));",- " }",- " else",- " {",- " Console.Out.WriteLine(\"Parse NOT Successful!\");",- " }",- " }",- " catch(Exception e)",- " {",- " Console.Out.WriteLine(\"Parse NOT Successful:\");",- " Console.Out.WriteLine(e.Message);",- " Console.Out.WriteLine(\"\");",- " Console.Out.WriteLine(\"Stack Trace:\");",- " Console.Out.WriteLine(e.StackTrace);",- " }",- " }",- " else",- " {",- " Console.Out.WriteLine(\"You must specify a filename!\");",- " }",- " }",- " }",- "}"- ]- where- def = head (allEntryPoints cf)--filepathtonamespace :: FilePath -> Namespace-filepathtonamespace file = take (length file - 3) (basename file)--projectguid :: IO String-projectguid = do- maybeFilePath <- findDirectory- guid <- maybe getBadGUID getGoodGUID maybeFilePath - return guid- where- getBadGUID :: IO String- getBadGUID = do- putStrLn "-----------------------------------------------------------------------------"- putStrLn "Could not find Visual Studio tool uuidgen.exe to generate project GUID!"- putStrLn "You might want to put this tool in your PATH."- putStrLn "-----------------------------------------------------------------------------"- return "{00000000-0000-0000-0000-000000000000}"- getGoodGUID :: FilePath -> IO String- getGoodGUID filepath = do - let filepath' = "\"" ++ filepath ++ "\""- (hIn, hOut, hErr, processHandle) <- runInteractiveCommand filepath'- guid <- hGetLine hOut- return ('{' : init guid ++ "}")- findDirectory :: IO (Maybe FilePath)- findDirectory = do- -- This works with Visual Studio 2005. - -- We will probably have to be modify this to include another environment variable name for Orcas. - -- I doubt there is any need to support VS2003? (I doubt they have patched it up to have 2.0 support?)- toolpath <- catchIOError (getEnv "VS80COMNTOOLS") (\_ -> return "C:\\Program Files\\Microsoft Visual Studio 8\\Common7\\Tools")- exists <- doesDirectoryExist toolpath- if exists - then return (Just (toolpath ++ "\\uuidgen.exe"))- -- this handles the case when the user was clever enough to add the directory to his/her PATH- else findExecutable "uuidgen.exe"
− src/formats/c-sharp/CSharpUtils.hs
@@ -1,154 +0,0 @@-{-- BNF Converter: Utility Functions for C#- Copyright (C) 2006 Author: Johan Broberg-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module provides utility functions for the - C# format.-- Author : Johan Broberg (johan@pontemonti.com)-- License : GPL (GNU General Public License)-- Created : 23 November, 2006-- Modified : 21 January, 2007 by Johan Broberg-- ************************************************************** --}--module CSharpUtils where--import CF-import Control.Monad.ST--- Control.Monad.State-import Data.Char (toLower)-import Data.Maybe-import Data.List-import OOAbstract hiding (basetypes)--type Namespace = String----The visit-function name of a basic type-visitFunName :: String -> String-visitFunName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else "Ident" --User-defined type--isUserDefined :: String -> Bool-isUserDefined v = v `notElem` (map classVar (map fst basetypes))--basetypes = [- ("Integer","int"),- ("Char", "char"),- ("Double", "double"),- ("String", "string"),- ("Ident", "string")- ]--typename :: String -> String-typename name - | name == "Char" = "char"- | name == "Double" = "double"- | name == "Ident" = "string"- | name == "Integer" = "int"- | name == "String" = "string"- | otherwise = name---- Creates a variable name. --- To make sure that no reserved keyword is generated, an underscore is added at the end. Not very pretty, but effective.-varname :: String -> String-varname name = (map toLower name) ++ "_"---- Given a variable name (in an abstract syntax class), returns ".ToString()" if the name doesn't match one of the basetypes.-toString :: String -> String-toString v = if isUserDefined v then ".ToString()" else ""---- Prepends namespace ".Absyn." to typ unless it is one of the basetypes-identifier :: Namespace -> String -> String-identifier namespace typ - | typ `elem` (map snd basetypes) = typ- | otherwise = namespace ++ ".Absyn." ++ typ---- Removes empty lines, and removes the line-break at the end. --- This can be useful if you want to use unlines "inside" unlines and don't want a whole lot of "useless" line-breaks.-unlinesInline :: [String] -> String-unlinesInline xs = concat $ intersperse "\n" $ filter (\x -> x /= "") xs--unlinesInlineMap :: (a -> String) -> [a] -> String-unlinesInlineMap fun xs = unlinesInline $ intersperse " " $ filter (\x -> x /= "") $ map fun xs----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)--isAlsoCategory :: Fun -> Cat -> Bool-isAlsoCategory f c = f == c--flattenSignatures :: CAbs -> [(Cat, CSharpAbsRule)]-flattenSignatures cabs = [(c,r) | (c,rs) <- signatures cabs, r <- map cabsrule2csharpabsrule rs]--type VariableName = String-type PropertyName = String---- Just like CAbsRule in OOAbstract, except this also has PropertyName.--- (valcat,(constr,args)), True = is class (not basic), class variable stored-type CSharpAbsRule = (Fun,[(Cat,Bool,VariableName,PropertyName)]) --cabsrule2csharpabsrule :: CAbsRule -> CSharpAbsRule-cabsrule2csharpabsrule (f, cabsrule) = (f, addPropertyNames cabsrule)---- This generates names for properties. It's done the same way as generation of variable names in OOAbstract->cf2cabs--- A property name uses the same casing as its category, but has an underscore at the end-addPropertyNames :: [(Cat, Bool, String)] -> [(Cat, Bool, VariableName, PropertyName)]-addPropertyNames cs = [(c,b,v,p) | ((c,b,v),p) <- zip cs (properties [] (map propertyName [c | (c,_,_) <- cs]))]- --- creating new names is quadratic, but parameter lists are short- --- this should conform with Michael's naming- where- properties seen vv = case vv of- [] -> vv- v:vs -> case length (filter (==v) seen) of- 0 | elem v vs -> (v ++ "1"): properties (v:seen) vs- 0 -> v : properties (v:seen) vs- n -> (v ++ show (n+1)) : properties (v:seen) vs--propertyName :: Cat -> PropertyName-propertyName c = c ++ "_"---- Given a rule's definition, it goes through and nicely the properties by type.--- Does the same thing as numVars in NamedVariables, except the varName part-numProps :: [(String, Int)] -> [Either String b] -> [Either String b]-numProps _env [] = []-numProps env ((Right f) : fs) = (Right f) : (numProps env fs)-numProps env ((Left f) : fs) = - case lookup f' env of- Nothing -> (Left f') : (numProps ((f',1):env) fs)- Just n -> (Left $ f' ++ (show $ n + 1)) : (numProps ((f',n+1):env) fs)- where- f' = propertyName (normCat (identCat f))-
− src/formats/c-sharp/RegToGPLEX.hs
@@ -1,73 +0,0 @@-module RegToGPLEX (printRegGPLEX) where---- modified from RegToFlex--import AbsBNF-import Data.Char---- the top-level printing method-printRegGPLEX :: Reg -> String-printRegGPLEX = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend (0::Int) where- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = [[c]]- prtList s = map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["[^.]"])- RChar c -> prPrec i 3 (prt 0 [mkEsc [c]])- RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str))- RDigit -> prPrec i 3 (concat [["{digit}"]])- RLetter -> prPrec i 3 (concat [["{alpha}"]])- RUpper -> prPrec i 3 (concat [["{alphaCapital}"]])- RLower -> prPrec i 3 (concat [["{alphaSmall}"]])- RAny -> prPrec i 3 (concat [["."]])---- Handle special characters in regular expressions.-mkEsc :: String -> String-mkEsc = concatMap escChar- where escChar c- | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c]- | otherwise = [c]
− src/formats/c/CFtoBisonC.hs
@@ -1,275 +0,0 @@-{-- BNF Converter: C Bison generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Bison input file.- Note that because of the way bison stores results- the programmer can increase performance by limiting- the number of entry points in their grammar.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 6 August, 2003 -- Modified : 6 August, 2003 -- - ************************************************************** --}---module CFtoBisonC (cf2Bison) where--import CF-import Data.List (intersperse, isPrefixOf)-import NamedVariables hiding (varName)-import Data.Char (toLower)-import Utils ((+++), (++++))----This follows the basic structure of CFtoHappy.---- Type declarations-type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String----The environment comes from the CFtoFlex-cf2Bison :: String -> CF -> SymEnv -> String-cf2Bison name cf env- = unlines - [header name cf,- union (allCats cf),- "%token _ERROR_",- tokens user env,- declarations cf,- specialToks cf,- "%%",- prRules (rulesForBison name cf env)- ]- where- user = fst (unzip (tokenPragmas cf))--header :: String -> CF -> String-header name cf = unlines - ["/* This Bison file was machine-generated by BNFC */",- "%{",- "#include <stdlib.h>",- "#include <stdio.h>",- "#include <string.h>",- "#include \"Absyn.h\"",- "#define initialize_lexer " ++ name ++ "_initialize_lexer",- "extern int yyparse(void);",- "extern int yylex(void);",- "extern int initialize_lexer(FILE * inp);",- "void yyerror(const char *str)",- "{",- " fprintf(stderr,\"error: %s\\n\",str);",- "}",- "",- -- M.F. 2004-09-17 changed allEntryPoints to allCatsIdNorm. Seems to fix the [Ty2] bug.- unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf),- concatMap reverseList (filter isList (allCats cf)),- "%}"- ]----This generates a parser method for each entry point.-parseMethod :: String -> Cat -> String-parseMethod name cat = --- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm--- then ""--- else - unlines- [- cat' +++ (resultName cat') +++ "= 0;",- cat' ++ " p" ++ cat' ++ "(FILE *inp)",- "{",- " initialize_lexer(inp);",- " if (yyparse())",- " { /* Failure */",- " return 0;",- " }",- " else",- " { /* Success */",- " return" +++ (resultName cat') ++ ";",- " }",- "}"- ]- where- cat' = identCat (normCat cat)----This method generates list reversal functions for each list type.-reverseList :: Cat -> String-reverseList c = unlines- [- c' ++ " reverse" ++ c' ++ "(" ++ c' +++ "l)",- "{",- " " ++ c' +++"prev = 0;",- " " ++ c' +++"tmp = 0;",- " while (l)",- " {",- " tmp = l->" ++ v ++ ";",- " l->" ++ v +++ "= prev;",- " prev = l;",- " l = tmp;",- " }",- " return prev;",- "}"- ]- where- c' = identCat (normCat c)- v = (map toLower c') ++ "_"----The union declaration is special to Bison/Yacc and gives the type of yylval.---For efficiency, we may want to only include used categories here.-union :: [Cat] -> String-union cats = unlines- [- "%union",- "{",- " int int_;",- " char char_;",- " double double_;",- " char* string_;",- concatMap mkPointer cats,- "}"- ]- where --This is a little weird because people can make [Exp2] etc.- mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion.- " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n"- mkPointer s | normCat s == s = --normal cat- " " ++ (identCat (normCat s)) +++ (varName (normCat s)) ++ ";\n"- mkPointer s = ""- ---declares non-terminal types.-declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (allCats cf)- where --don't define internal rules- typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n"- typeNT cf nt = ""----declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user ts = concatMap (declTok user) ts- where- declTok u (s,r) = if elem s u- then "%token<string_> " ++ r ++ " /* " ++ s ++ " */\n"- else "%token " ++ r ++ " /* " ++ s ++ " */\n"--specialToks :: CF -> String-specialToks cf = concat [ - ifC "String" "%token<string_> _STRING_\n",- ifC "Char" "%token<char_> _CHAR_\n",- ifC "Integer" "%token<int_> _INTEGER_\n",- ifC "Double" "%token<double_> _DOUBLE_\n",- ifC "Ident" "%token<string_> _IDENT_\n"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForBison :: String -> CF -> SymEnv -> Rules-rulesForBison name cf env = map mkOne $ ruleGroups cf where- mkOne (cat,rules) = constructRule cf env rules cat---- For every non-terminal, we construct a set of rules.-constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule cf env rules nt = (nt,[(p,(generateAction (normCat (identCat nt)) (ruleName r) b m) +++ result) | - r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf env r])- where- ruleName r = case funRule r of- "(:)" -> identCat nt- z -> z- revs = reversibleCats cf- eps = allEntryPoints cf- isEntry nt = if elem nt eps then True else False- result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else ""---- Generates a string containing the semantic action.-generateAction :: NonTerminal -> Fun -> Bool -> [MetaVar] -> Action-generateAction nt f b ms = - if isCoercion f - then (unwords ms) ++ ";"- else if isNilFun f- then "0;"- else if isOneFun f- then concat ["make_", nt, "(", (concat (intersperse ", " ms')), ", 0);"]- else concat ["make_", normCat f, "(", (concat (intersperse ", " ms')), ");"]- where- ms' = if b then reverse ms else ms- --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])-generatePatterns cf env r = case rhsRule r of- [] -> ("/* empty */",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> case lookup c env of- Just x -> x- Nothing -> typeName (identCat c)- Right s -> case lookup s env of- Just x -> x- Nothing -> s- metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]- revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")- else m -- no reversal in the left-recursive Cons rule itself- revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules [] = []-prRules ((nt, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls----Some helper functions.-resultName :: String -> String-resultName s = "YY_RESULT_" ++ s ++ "_"----slightly stronger than the NamedVariable version.-varName :: String -> String-varName s = (map toLower (identCat s)) ++ "_"--typeName :: String -> String-typeName "Ident" = "_IDENT_"-typeName "String" = "_STRING_"-typeName "Char" = "_CHAR_"-typeName "Integer" = "_INTEGER_"-typeName "Double" = "_DOUBLE_"-typeName x = x
− src/formats/c/CFtoCAbs.hs
@@ -1,329 +0,0 @@-{-- BNF Converter: C Abstract syntax- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C Abstract Syntax- tree classes. It generates both a Header file- and an Implementation file, and Appel's C- method.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 15 September, 2003 -- Modified : 15 September, 2003 -- - ************************************************************** --}--module CFtoCAbs (cf2CAbs) where--import CF-import Utils((+++),(++++))-import NamedVariables-import Data.List-import Data.Char(toLower)-----The result is two files (.H file, .C file)-cf2CAbs :: String -> CF -> (String, String)-cf2CAbs name cf = (mkHFile cf, mkCFile cf)---{- **** Header (.H) File Functions **** -}----Makes the Header file.-mkHFile :: CF -> String-mkHFile cf = unlines- [- "#ifndef ABSYN_HEADER",- "#define ABSYN_HEADER",- "",- header,- prTypeDefs user,- "/******************** Forward Declarations ********************/\n",- concatMap prForward classes,- "",- "/******************** Abstract Syntax Classes ********************/\n",- concatMap (prDataH user) (cf2dataLists cf),- "",- "#endif"- ]- where- user = fst (unzip (tokenPragmas cf))- header = "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/\n"- rules = getRules cf- classes = rules ++ getClasses (allCats cf)- prForward s | not (isCoercion s) = unlines- [- "struct " ++ s' ++ "_;",- "typedef struct " ++ s' ++ "_ *" ++ s' ++ ";"- ]- where- s' = normCat s- prForward s = ""- getRules cf = (map testRule (rulesOfCF cf))- getClasses [] = []- getClasses (c:cs) = - if identCat (normCat c) /= c - then getClasses cs- else if elem c rules- then getClasses cs- else c : (getClasses cs)- - testRule (Rule f c r) = - if isList c- then if isConsFun f - then identCat c- else "_" --ignore this- else "_"----Prints struct definitions for all categories.-prDataH :: [UserDef] -> Data -> String-prDataH user (cat, rules) = - if isList cat- then unlines- [- "struct " ++ c' ++ "_",- "{",- " " ++ mem +++ (varName mem) ++ ";",- " " ++ c' +++ (varName c') ++ ";",- "};",- "",- c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);"- ]- else unlines- [- "struct " ++ cat ++ "_",- "{",- " enum { " ++ (concat (intersperse ", " (map prKind rules))) ++ " } kind;",- " union",- " {",- concatMap (prUnion user) rules ++ " } u;",- "};",- "",- concatMap (prRuleH user cat) rules- ]- where- c' = identCat (normCat cat)- mem = identCat (normCatOfList cat)- prKind (fun, cats) = "is_" ++ (normCat fun)- prMember user (fun, []) = ""- prMember user (fun, cats) = " " ++ (prInstVars user (getVars cats))- prUnion user (fun, []) = ""- prUnion user (fun, cats) = " struct { " ++ (prInstVars user (getVars cats)) ++ " } " ++ (memName fun) ++ ";\n"- - ---Interface definitions for rules vary on the type of rule.-prRuleH :: [UserDef] -> String -> (Fun, [Cat]) -> String-prRuleH user c (fun, cats) = - if isNilFun fun || isOneFun fun || isConsFun fun- then "" --these are not represented in the AbSyn- else --a standard rule- c ++ " make_" ++ fun' ++ "(" ++ (prParamsH 0 (getVars cats)) ++ ");\n"- where - fun' = identCat (normCat fun)- prParamsH :: Int -> [(String, a)] -> String- prParamsH _ [] = ""- prParamsH n ((t,_):[]) = t ++ " p" ++ (show n)- prParamsH n ((t,_):vs) = (t ++ " p" ++ (show n) ++ ", ") ++ (prParamsH (n+1) vs)----typedefs in the Header make generation much nicer.-prTypeDefs user = unlines- [- "/******************** TypeDef Section ********************/",- "typedef int Integer;",- "typedef char Char;",- "typedef double Double;",- "typedef char* String;",- "typedef char* Ident;",- concatMap prUserDef user- ]- where- prUserDef s = "typedef char* " ++ s ++ ";\n"- ---A class's instance variables.-prInstVars :: [UserDef] -> [IVar] -> String-prInstVars _ [] = []-prInstVars user vars@((t,n):[]) =- t +++ uniques- where- (uniques, vs') = prUniques t vars-prInstVars user vars@((t,n):vs) = - t +++ uniques ++ - (prInstVars user vs')- where- (uniques, vs') = prUniques t vars- ---these functions group the types together nicely-prUniques :: String -> [IVar] -> (String, [IVar])-prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs)- where- remType :: String -> [IVar] -> [IVar]- remType _ [] = []- remType t ((t2,n):ts) = if t == t2 - then (remType t ts) - else (t2,n) : (remType t ts) - prVars (x:[]) vs = case vs !! x of- (t,n) -> (varName t) ++ (showNum n) ++ ";"- prVars (x:xs) vs = case vs !! x of - (t,n) -> (varName t) ++ (showNum n) ++ ", " ++- (prVars xs vs)-- -{- **** Implementation (.C) File Functions **** -}----Makes the .C file-mkCFile :: CF -> String-mkCFile cf = unlines- [- header,- concatMap (prDataC user) (cf2dataLists cf)- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines- [- "/* C Abstract Syntax Implementation generated by the BNF Converter. */",- "",- "#include <stdio.h>",- "#include <stdlib.h>",- "#include \"Absyn.h\"",- ""- ]----This is not represented in the implementation.---This is not represented in the implementation.-prDataC :: [UserDef] -> Data -> String-prDataC user (cat, rules) = concatMap (prRuleC user cat) rules----Classes for rules vary based on the type of rule.-prRuleC user c (fun, cats) = - if isNilFun fun || isOneFun fun- then "" --these are not represented in the AbSyn- else if isConsFun fun- then --this is the linked list case.- unlines- [- "/******************** " ++ c' ++ " ********************/",- prListFuncs user c',- ""- ]- else --a standard rule- unlines- [- "/******************** " ++ fun' ++ " ********************/",- prConstructorC user c fun' vs cats,- ""- ]- where - vs = getVars cats- fun' = identCat (normCat fun)- c' = identCat (normCat c)----These are all built-in list functions.---Later we could include things like lookup,insert,delete,etc.-prListFuncs :: [UserDef] -> String -> String-prListFuncs user c = unlines- [- c ++ " make_" ++ c ++"(" ++ m ++ " p1" ++ ", " ++ c ++ " p2)",- "{",- " " ++ c ++ " tmp = (" ++ c ++ ") malloc(sizeof(*tmp));",- " if (!tmp)",- " {",- " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");",- " exit(1);",- " }",- " tmp->" ++ m' ++ " = " ++ "p1;",- " tmp->" ++ v ++ " = " ++ "p2;",- " return tmp;",- "}"- ]- where- v = (map toLower c) ++ "_"- m = drop 4 c- m' = drop 4 v----The constructor just assigns the parameters to the corresponding instance variables.-prConstructorC :: [UserDef] -> String -> String -> [IVar] -> [Cat] -> String-prConstructorC user cat c vs cats = - unlines- [- cat' ++ " make_" ++ c ++"(" ++ (interleave types params) ++ ")",- "{",- " " ++ cat' ++ " tmp = (" ++ cat' ++ ") malloc(sizeof(*tmp));",- " if (!tmp)",- " {",- " fprintf(stderr, \"Error: out of memory when allocating " ++ c ++ "!\\n\");",- " exit(1);",- " }",- " tmp->kind = is_" ++ c ++ ";",- prAssigns c vs params,- " return tmp;",- "}"- ]- where- cat' = identCat (normCat cat)- (types, params) = unzip (prParams cats (length cats) ((length cats)+1))- interleave _ [] = []- interleave (x:[]) (y:[]) = x +++ y- interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys)----Prints the constructor's parameters. -prParams :: [Cat] -> Int -> Int -> [(String,String)]-prParams [] _ _ = []-prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n)))- : (prParams cs (n-1) m)- ---Prints the assignments of parameters to instance variables.---This algorithm peeks ahead in the list so we don't use map or fold-prAssigns :: String -> [IVar] -> [String] -> String-prAssigns _ [] _ = []-prAssigns _ _ [] = []-prAssigns c ((t,n):vs) (p:ps) =- if n == 1 then- case findIndices (\x -> case x of (l,r) -> l == t) vs of- [] -> " tmp->u." ++ c' ++ "_." ++ (varName t) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps)- z -> " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps)- else " tmp->u." ++ c' ++ "_." ++ ((varName t) ++ (showNum n)) ++ " = " ++ p ++ ";\n" ++ (prAssigns c vs ps)- where- c' = map toLower c--{- **** Helper Functions **** -}----Checks if something is a basic or user-defined type.-isBasic :: [UserDef] -> String -> Bool-isBasic user x = - if elem x user- then True- else case x of- "Integer" -> True- "Char" -> True- "String" -> True- "Double" -> True- "Ident" -> True- _ -> False--memName s = (map toLower s) ++ "_"
− src/formats/c/CFtoCPrinter.hs
@@ -1,654 +0,0 @@-{-- BNF Converter: C Pretty Printer printer- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C Pretty Printer.- It also generates the "show" method for- printing an abstract syntax tree.- - The generated files use the Visitor design pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 10 August, 2003 -- Modified : 3 September, 2003 - * Added resizable buffers- - ************************************************************** --}--module CFtoCPrinter (cf2CPrinter) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper)----Produces (.h file, .c file)-cf2CPrinter :: CF -> (String, String)-cf2CPrinter cf = (mkHFile cf groups, mkCFile cf groups)- where- groups = (fixCoercions (ruleGroupsInternals cf))--{- **** Header (.h) File Methods **** -}----An extremely large function to make the Header File-mkHFile :: CF -> [(Cat,[Rule])] -> String-mkHFile cf groups = unlines- [- header,- concatMap prPrints eps,- concatMap prPrintDataH groups,- concatMap prShows eps,- concatMap prShowDataH groups,- footer- ]- where- eps = allEntryPoints cf- prPrints s | normCat s == s = "char* print" ++ s' ++ "(" ++ s' ++ " p);\n"- where- s' = identCat s- prPrints _ = ""- prShows s | normCat s == s = "char* show" ++ s' ++ "(" ++ s' ++ " p);\n"- where- s' = identCat s- prShows _ = ""- header = unlines- [- "#ifndef PRINTER_HEADER",- "#define PRINTER_HEADER",- "",- "#include \"Absyn.h\"",- "",- "/* Certain applications may improve performance by changing the buffer size */",- "#define BUFFER_INITIAL 2000",- "/* You may wish to change _L_PAREN or _R_PAREN */",- "#define _L_PAREN '('",- "#define _R_PAREN ')'",- "",- "/* The following are simple heuristics for rendering terminals */",- "/* You may wish to change them */",- "void renderCC(Char c);",- "void renderCS(String s);",- "void indent(void);",- "void backup(void);",- ""- ]- footer = unlines $- ["void pp" ++ t ++ "(String s, int i);" | t <- tokenNames cf]- ++- ["void sh" ++ t ++ "(String s);" | t <- tokenNames cf]- ++- [- "void ppInteger(Integer n, int i);",- "void ppDouble(Double d, int i);",- "void ppChar(Char c, int i);",- "void ppString(String s, int i);",- "void ppIdent(String s, int i);",- "void shInteger(Integer n);",- "void shDouble(Double d);",- "void shChar(Char c);",- "void shString(String s);",- "void shIdent(String s);",- "void bufAppendS(const char* s);",- "void bufAppendC(const char c);",- "void bufReset(void);",- "void resizeBuffer(void);",- "",- "#endif"- ]----Prints all the required method names and their parameters.-prPrintDataH :: (Cat, [Rule]) -> String-prPrintDataH (cat, rules) = concat ["void pp", cl, "(", cl, " p, int i);\n"]- where- cl = identCat (normCat cat)- ---Prints all the required method names and their parameters.-prShowDataH :: (Cat, [Rule]) -> String-prShowDataH (cat, rules) = concat ["void sh", cl, "(", cl, " p);\n"]- where- cl = identCat (normCat cat)--{- **** Implementation (.C) File Methods **** -}----This makes the .C file by a similar method.-mkCFile :: CF -> [(Cat,[Rule])] -> String-mkCFile cf groups = concat - [- header,- prRender,- concatMap prPrintFun eps,- concatMap prShowFun eps,- concatMap (prPrintData user) groups,- printBasics,- printTokens,- concatMap (prShowData user) groups,- showBasics,- showTokens,- footer- ]- where- eps = allEntryPoints cf- user = fst (unzip (tokenPragmas cf))- header = unlines - [- "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",- "",- "#include \"Printer.h\"",- "#include <stdio.h>",- "#include <string.h>",- "#include <stdlib.h>",- "",- "int _n_;",- "char* buf_;",- "int cur_;",- "int buf_size;",- ""- ]- printBasics = unlines - [- "void ppInteger(Integer n, int i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%d\", n);",- " bufAppendS(tmp);",- "}",- "void ppDouble(Double d, int i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppendS(tmp);",- "}",- "void ppChar(Char c, int i)",- "{",- " bufAppendC('\\'');",- " bufAppendC(c);",- " bufAppendC('\\'');",- "}",- "void ppString(String s, int i)",- "{",- " bufAppendC('\\\"');",- " bufAppendS(s);",- " bufAppendC('\\\"');",- "}",- "void ppIdent(String s, int i)",- "{",- " renderS(s);",- "}",- ""- ]- printTokens = unlines - [unlines [- "void pp" ++ t ++ "(String s, int i)",- "{",- " renderS(s);",- "}",- ""- ] | t <- tokenNames cf- ]- showBasics = unlines - [- "void shInteger(Integer i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%d\", i);",- " bufAppendS(tmp);",- "}",- "void shDouble(Double d)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppendS(tmp);",- "}",- "void shChar(Char c)",- "{",- " bufAppendC('\\'');",- " bufAppendC(c);",- " bufAppendC('\\'');",- "}",- "void shString(String s)",- "{",- " bufAppendC('\\\"');",- " bufAppendS(s);",- " bufAppendC('\\\"');",- "}",- "void shIdent(String s)",- "{",- " bufAppendC('\\\"');",- " bufAppendS(s);",- " bufAppendC('\\\"');",- "}",- ""- ]- showTokens = unlines - [unlines [- "void sh" ++ t ++ "(String s)",- "{",- " bufAppendC('\\\"');",- " bufAppendS(s);",- " bufAppendC('\\\"');",- "}",- ""- ] | t <- tokenNames cf- ]- footer = unlines- [- "void bufAppendS(const char* s)",- "{",- " int len = strlen(s);",- " int n;",- " while (cur_ + len > buf_size)",- " {",- " buf_size *= 2; /* Double the buffer size */",- " resizeBuffer();",- " }",- " for(n = 0; n < len; n++)",- " {",- " buf_[cur_ + n] = s[n];",- " }",- " cur_ += len;",- " buf_[cur_] = 0;",- "}",- "void bufAppendC(const char c)",- "{",- " if (cur_ == buf_size)",- " {",- " buf_size *= 2; /* Double the buffer size */",- " resizeBuffer();",- " }",- " buf_[cur_] = c;",- " cur_++;",- " buf_[cur_] = 0;",- "}",- "void bufReset(void)",- "{",- " cur_ = 0;",- " buf_size = BUFFER_INITIAL;",- " resizeBuffer();",- " memset(buf_, 0, buf_size);",- "}",- "void resizeBuffer(void)",- "{",- " char* temp = (char*) malloc(buf_size);",- " if (!temp)",- " {",- " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",- " exit(1);",- " }",- " if (buf_)",- " {",- " strncpy(temp, buf_, buf_size); /* peteg: strlcpy is safer, but not POSIX/ISO C. */",- " free(buf_);",- " }",- " buf_ = temp;",- "}",- "char *buf_;",- "int cur_, buf_size;",- ""- ]- --{- **** Pretty Printer Methods **** -}----An entry point to begin printing-prPrintFun :: Cat -> String-prPrintFun ep | normCat ep == ep = unlines- [- "char* print" ++ ep' ++ "(" ++ ep' ++ " p)",- "{",- " _n_ = 0;",- " bufReset();",- " pp" ++ ep' ++ "(p, 0);",- " return buf_;",- "}"- ]- where- ep' = identCat ep-prPrintFun _ = ""----Generates methods for the Pretty Printer-prPrintData :: [UserDef] -> (Cat, [Rule]) -> String-prPrintData user (cat, rules) = - if isList cat- then unlines- [- "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)",- "{",- " while(" ++ vname ++ "!= 0)",- " {",- " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)",- " {",- visitMember,- optsep,- " " ++ vname +++ "= 0;",- " }",- " else",- " {",- visitMember,- " render" ++ sc ++ "(" ++ sep ++ ");",- " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",- " }",- " }",- "}",- ""- ] --Not a list:- else unlines- [- "void pp" ++ cl ++ "(" ++ cl ++ " _p_, int _i_)",- "{",- " switch(_p_->kind)",- " {",- concatMap (prPrintRule user) rules,- " default:",- " fprintf(stderr, \"Error: bad kind field when printing " ++ cat ++ "!\\n\");",- " exit(1);",- " }",- "}\n"- ]- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl- visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, 0);"- (sc, sep) = if length sep' == 1- then ("C", "'" ++ escapeChars sep' ++ "'")- else ("S", "\"" ++ escapeChars sep' ++ "\"")- sep' = getCons rules- optsep = if hasOneFunc rules then "" else (" render" ++ sc ++ "(" ++ sep ++ ");")- ---Pretty Printer methods for a rule.-prPrintRule :: [UserDef] -> Rule -> String-prPrintRule user r@(Rule fun c cats) | not (isCoercion fun) = unlines- [- " case is_" ++ fun ++ ":",- lparen,- cats',- rparen,- " break;\n"- ]- where- p = precRule r- (lparen, rparen) = - (" if (_i_ > " ++ (show p) ++ ") renderC(_L_PAREN);",- " if (_i_ > " ++ (show p) ++ ") renderC(_R_PAREN);")- cats' = (concatMap (prPrintCat user fun) (zip3 (fixOnes (numVars [] cats)) cats (map getPrec cats)))- getPrec (Right s) = (0 :: Int)- getPrec (Left c) = precCat c-prPrintRule _ _ = ""----This goes on to recurse to the instance variables.-prPrintCat :: [UserDef] -> String -> (Either Cat String, Either Cat String, Int) -> String-prPrintCat user fnm (c,o,p) = case c of- (Right t) -> " render" ++ sc ++ "(" ++ t' ++ ");\n"- where- (sc,t') = if length t == 1- then ("C", "'" ++ (escapeChars t) ++ "'")- else ("S", "\"" ++ (escapeChars t) ++ "\"")- (Left nt) -> if isBasic user nt- then " pp" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n"- else if nt == "#_" --Internal category- then " /* Internal Category */\n"- else " pp" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ", " ++ (show p) ++ ");\n"- where- v = map toLower (identCat (normCat fnm))- o' = case o of- Right x -> x- Left x -> normCat (identCat x) --{- **** Abstract Syntax Tree Printer **** -}----An entry point to begin printing-prShowFun :: Cat -> String-prShowFun ep | normCat ep == ep = unlines- [- "char* show" ++ ep' ++ "(" ++ ep' ++ " p)",- "{",- " _n_ = 0;",- " bufReset();",- " sh" ++ ep' ++ "(p);",- " return buf_;",- "}"- ]- where- ep' = identCat ep-prShowFun _ = ""- ---This prints the functions for Abstract Syntax tree printing.-prShowData :: [UserDef] -> (Cat, [Rule]) -> String-prShowData user (cat, rules) = - if isList cat- then unlines- [- "void sh" ++ cl ++ "("++ cl +++ vname ++ ")",- "{",- " while(" ++ vname ++ "!= 0)",- " {",- " if (" ++ vname ++ "->" ++ vname ++ "_)",- " {",- visitMember,- " bufAppendS(\", \");",- " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",- " }",- " else",- " {",- visitMember,- " " ++ vname ++ " = 0;",- " }",- " }",- "}",- ""- ] --Not a list:- else unlines- [- "void sh" ++ cl ++ "(" ++ cl ++ " _p_)",- "{",- " switch(_p_->kind)",- " {",- concatMap (prShowRule user) rules,- " default:",- " fprintf(stderr, \"Error: bad kind field when showing " ++ cat ++ "!\\n\");",- " exit(1);",- " }",- "}\n"- ]- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl- visitMember = " sh" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);"- ---Pretty Printer methods for a rule.-prShowRule :: [UserDef] -> Rule -> String-prShowRule user r@(Rule fun c cats) | not (isCoercion fun) = unlines- [- " case is_" ++ fun ++ ":",- lparen,- " bufAppendS(\"" ++ fun ++ "\");\n",- optspace,- cats',- rparen,- " break;\n"- ]- where- (optspace, lparen, rparen) = if allTerms cats- then ("","","")- else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n")- cats' = if allTerms cats- then ""- else concat (insertSpaces (map (prShowCat user fun) (zip (fixOnes (numVars [] cats)) cats)))- insertSpaces [] = []- insertSpaces (x:[]) = [x]- insertSpaces (x:xs) = if x == "" - then insertSpaces xs- else (x : [" bufAppendC(' ');\n"]) ++ (insertSpaces xs)- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs-prShowRule _ _ = ""----This goes on to recurse to the instance variables.-prShowCat :: [UserDef] -> String -> (Either Cat String, Either Cat String) -> String-prShowCat user fnm (c,o) = case c of- (Right t) -> ""- (Left nt) -> if isBasic user nt- then " sh" ++ (basicFunName nt) ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"- else if nt == "#_" --Internal category- then " /* Internal Category */\n"- else if ((normCat nt) /= nt)- then " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"- else concat- [- " bufAppendC('[');\n",- " sh" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n",- " bufAppendC(']');\n"- ]- where- v = map toLower (identCat (normCat fnm))- o' = case o of- Right x -> x- Left x -> normCat (identCat x) --{- **** Helper Functions Section **** -}-----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user----The visit-function name of a basic type-basicFunName :: String -> String-basicFunName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else "Ident" --User-defined type----Just sets the coercion level for parentheses in the Pretty Printer.-setI :: Int -> String-setI n = "_i_ = " ++ (show n) ++ "; "----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)- ---An extremely simple renderCer for terminals.-prRender :: String-prRender = unlines- [- "/* You may wish to change the renderC functions */",- "void renderC(Char c)",- "{",- " if (c == '{')",- " {",- " bufAppendC('\\n');",- " indent();",- " bufAppendC(c);",- " _n_ = _n_ + 2;",- " bufAppendC('\\n');",- " indent();",- " }",- " else if (c == '(' || c == '[')",- " bufAppendC(c);",- " else if (c == ')' || c == ']')",- " {",- " backup();",- " bufAppendC(c);",- " bufAppendC(' ');",- " }",- " else if (c == '}')",- " {",- " _n_ = _n_ - 2;",- " backup();",- " backup();",- " bufAppendC(c);",- " bufAppendC('\\n\');",- " indent();",- " }",- " else if (c == ',')",- " {",- " backup();",- " bufAppendC(c);",- " bufAppendC(' ');",- " }",- " else if (c == ';')",- " {",- " backup();",- " bufAppendC(c);",- " bufAppendC('\\n');",- " indent();",- " }",- " else if (c == 0) return;",- " else",- " {",- " bufAppendC(c);",- " bufAppendC(' ');",- " }",- "}",- "void renderS(String s)",- "{",- " if(strlen(s) > 0)",- " {",- " bufAppendS(s);",- " bufAppendC(' ');",- " }",- "}",- "void indent(void)",- "{",- " int n = _n_;",- " while (n > 0)",- " {",- " bufAppendC(' ');",- " n--;",- " }",- "}",- "void backup(void)",- "{",- " if (buf_[cur_ - 1] == ' ')",- " {", - " buf_[cur_ - 1] = 0;",- " cur_--;",- " }",- "}"- ]
− src/formats/c/CFtoCSkel.hs
@@ -1,240 +0,0 @@-{-- BNF Converter: C Skeleton generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C Skeleton functions.- - The generated files follow Appel's case method.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 9 August, 2003 -- Modified : 12 August, 2003 -- - ************************************************************** --}--module CFtoCSkel (cf2CSkel) where--import CF-import Utils ( (+++) )-import NamedVariables-import Data.List ( isPrefixOf )-import Data.Char ( toLower, toUpper )----Produces (.H file, .C file)-cf2CSkel :: CF -> (String, String)-cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups)- where- groups = (fixCoercions (ruleGroups cf))---{- **** Header (.H) File Functions **** -}----Generates the Header File-mkHFile :: CF -> [(Cat,[Rule])] -> String-mkHFile cf groups = unlines- [- header,- concatMap prDataH groups,- concatMap prUserH user,- footer- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines- [- "#ifndef SKELETON_HEADER",- "#define SKELETON_HEADER",- "/* You might want to change the above name. */",- "",- "#include \"Absyn.h\"",- ""- ]- prUserH u = "void visit" ++ u' ++ "(" ++ u ++ " p);"- where- u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.- footer = unlines- [- "void visitIdent(Ident i);",- "void visitInteger(Integer i);",- "void visitDouble(Double d);",- "void visitChar(Char c);",- "void visitString(String s);",- "",- "#endif"- ]- ---Prints out visit functions for a category-prDataH :: (Cat, [Rule]) -> String-prDataH (cat, _rules) = - if isList cat- then concat ["void visit", cl, "(", cl, " p);\n"]- else "void visit" ++ cl ++ "(" ++ cl ++ " p);\n"- where cl = identCat $ normCat cat--{- **** Implementation (.C) File Functions **** -}----Makes the .C File-mkCFile :: CF -> [(Cat,[Rule])] -> String-mkCFile cf groups = concat - [- header,- concatMap (prData user) groups,- concatMap prUser user,- footer- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines [- "/*** BNFC-Generated Visitor Traversal Skeleton. ***/",- "/* This traverses the abstract syntax tree.",- " To use, copy Skeleton.h and Skeleton.c to",- " new files. */",- "",- "#include \"Skeleton.h\"",- ""- ]- prUser u = unlines- [- "void visit" ++ u' ++ "(" ++ u ++ " p)",- "{",- " /* Code for " ++ u ++ " Goes Here */",- "}"- ]- where- u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.- footer = unlines - [- "void visitIdent(Ident i)",- "{",- " /* Code for Ident Goes Here */",- "}",- "void visitInteger(Integer i)",- "{",- " /* Code for Integer Goes Here */",- "}",- "void visitDouble(Double d)",- "{",- " /* Code for Double Goes Here */",- "}",- "void visitChar(Char c)",- "{",- " /* Code for Char Goes Here */",- "}",- "void visitString(String s)",- "{",- " /* Code for String Goes Here */",- "}",- ""- ]----Visit functions for a category.-prData :: [UserDef] -> (Cat, [Rule]) -> String-prData user (cat, rules) = - if isList cat- then unlines- [- "void visit" ++ cl ++ "("++ cl +++ vname ++ ")",- "{",- " while(" ++ vname ++ " != 0)",- " {",- " /* Code For " ++ cl ++ " Goes Here */",- " visit" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_);",- " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",- " }",- "}",- ""- ]- -- Not a list:- else unlines- [- "void visit" ++ cl ++ "(" ++ cl ++ " _p_)",- "{",- " switch(_p_->kind)",- " {",- concatMap (prPrintRule user) rules,- " default:",- " fprintf(stderr, \"Error: bad kind field when printing " ++ cl ++ "!\\n\");",- " exit(1);",- " }",- "}\n"- ]- where cl = identCat $ normCat cat- ecl = identCat $ normCatOfList cat- vname = map toLower cl- member = map toLower ecl---- Visits all the instance variables of a category.-prPrintRule :: [UserDef] -> Rule -> String-prPrintRule user (Rule fun _c cats) | not (isCoercion fun) = unlines- [- " case is_" ++ fun ++ ":",- " /* Code for " ++ fun ++ " Goes Here */",- cats' ++ " break;"- ]- where- cats' = concatMap (prCat user fun) (zip (fixOnes (numVars [] cats)) cats)-prPrintRule _user (Rule _fun _ _) = ""---- Prints the actual instance-variable visiting.-prCat :: [UserDef] -> String -> (Either Cat Cat, Either Cat Cat) -> String-prCat user fnm (c, o) = - case c of- Right {} -> ""- Left nt ->- if isBasic user nt- then " visit" ++ basicFunName nt ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"- else " visit" ++ o' ++ "(_p_->u." ++ v ++ "_." ++ nt ++ ");\n"- where v = map toLower $ identCat $ normCat fnm- o' = case o of- Right x -> x- Left x -> normCat $ identCat x----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user----The visit-function name of a basic type-basicFunName :: String -> String-basicFunName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else (toUpper (head v)) : (init (tail v)) --User-defined type
− src/formats/c/CFtoFlexC.hs
@@ -1,189 +0,0 @@-{-- BNF Converter: C flex generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Flex file. It is- similar to JLex but with a few peculiarities.- - Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 5 August, 2003 -- Modified : 10 August, 2003 -- - ************************************************************** --}-module CFtoFlexC (cf2flex) where--import CF-import RegToFlex--- import Utils((+++), (++++))-import NamedVariables-import Data.List----The environment must be returned for the parser to use.-cf2flex :: String -> CF -> (String, SymEnv)-cf2flex name cf = (unlines- [- prelude name,- cMacros,- lexSymbols env,- restOfFlex cf env'- ], env')- where- env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)- env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env))- makeSymEnv [] _ = []- makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))--prelude :: String -> String-prelude name = unlines- [- "/* -*- c -*- This FLex file was machine-generated by the BNF converter */",- "%option noyywrap",- "%{",- "#define yylval " ++ name ++ "lval",- "#define YY_BUFFER_APPEND " ++ name ++ "_BUFFER_APPEND",- "#define YY_BUFFER_RESET " ++ name ++ "_BUFFER_RESET",- "#define initialize_lexer " ++ name ++ "_initialize_lexer",- "#include <string.h>",- "#include \"Parser.h\"",- "#define YY_BUFFER_LENGTH 4096",- "char YY_PARSED_STRING[YY_BUFFER_LENGTH];",- "void YY_BUFFER_APPEND(char *s)",- "{",- " strcat(YY_PARSED_STRING, s); //Do something better here!",- "}",- "void YY_BUFFER_RESET(void)",- "{",- " int x;",- " for(x = 0; x < YY_BUFFER_LENGTH; x++)",- " YY_PARSED_STRING[x] = 0;",- "}",- "",- "%}"- ]----For now all categories are included.---Optimally only the ones that are used should be generated.-cMacros :: String-cMacros = unlines- [- "LETTER [a-zA-Z]",- "CAPITAL [A-Z]",- "SMALL [a-z]",- "DIGIT [0-9]",- "IDENT [a-zA-Z0-9'_]",- "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED",- "%%"- ]--lexSymbols :: SymEnv -> String-lexSymbols ss = concatMap transSym ss- where- transSym (s,r) = - "<YYINITIAL>\"" ++ s' ++ "\" \t return " ++ r ++ ";\n"- where- s' = escapeChars s--restOfFlex :: CF -> SymEnv -> String-restOfFlex cf env = concat- [- lexComments (comments cf),- userDefTokens,- ifC "String" strStates,- ifC "Char" chStates,- ifC "Double" "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n",- ifC "Integer" "<YYINITIAL>{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n",- ifC "Ident" "<YYINITIAL>{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n"- , "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",- "<YYINITIAL>. \t return _ERROR_;\n",- "%%\n",- footer- ]- where- ifC cat s = if isUsedCat cf cat then s else ""- userDefTokens = unlines $- ["<YYINITIAL>" ++ printRegFlex exp ++ - " \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"- | (name, exp) <- tokenPragmas cf]- where- sName n = case lookup n env of- Just x -> x- Nothing -> n- strStates = unlines --These handle escaped characters in Strings.- [- "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",- "<STRING>\\\\ \t BEGIN ESCAPED;",- "<STRING>\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;",- "<STRING>. \t YY_BUFFER_APPEND(yytext);",- "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",- "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",- "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",- "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",- "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"- ]- chStates = unlines --These handle escaped characters in Chars.- [- "<YYINITIAL>\"'\" \tBEGIN CHAR;",- "<CHAR>\\\\ \t BEGIN CHARESC;",- "<CHAR>[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",- "<CHARESC>n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;",- "<CHARESC>t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;",- "<CHARESC>. \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",- "<CHAREND>\"'\" \t BEGIN YYINITIAL;"- ]- footer = "void initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }"--lexComments :: ([(String, String)], [String]) -> String-lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m))--lexSingleComment :: String -> String-lexSingleComment c = - "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n \t /* BNFC single-line comment */;"----There might be a possible bug here if a language includes 2 multi-line comments.---They could possibly start a comment with one character and end it with another.---However this seems rare.-lexMultiComment :: (String, String) -> String-lexMultiComment (b,e) = unlines [- "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",- "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",- "<COMMENT>. \t /* BNFC multi-line comment */;",- "<COMMENT>[\\n] \t /* BNFC multi-line comment */;"- ]- -lexReserved :: String -> String-lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" \t yylval.string_ = strdup(yytext); return TS;"-----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)
− src/formats/c/CTop.hs
@@ -1,206 +0,0 @@-{-- BNF Converter: C Main file- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}-module CTop (makeC) where--import Utils-import CF-import CFtoCAbs-import CFtoFlexC-import CFtoBisonC-import CFtoCSkel-import CFtoCPrinter-import CFtoLatex-import Data.Char-import System.Exit (exitFailure)--makeC :: Bool -> String -> CF -> IO ()-makeC make name cf = do- let (hfile, cfile) = cf2CAbs name cf- writeFileRep "Absyn.h" hfile- writeFileRep "Absyn.c" cfile- let (flex, env) = cf2flex name cf- writeFileRep (name ++ ".l") flex- putStrLn " (Tested with flex 2.5.31)"- let bison = cf2Bison name cf env- writeFileRep (name ++ ".y") bison- putStrLn " (Tested with bison 1.875a)"- let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env- writeFileRep "Parser.h" header- let (skelH, skelC) = cf2CSkel cf- writeFileRep "Skeleton.h" skelH- writeFileRep "Skeleton.c" skelC- let (prinH, prinC) = cf2CPrinter cf- writeFileRep "Printer.h" prinH- writeFileRep "Printer.c" prinC- writeFileRep "Test.c" (ctest cf)- let latex = cfToLatex name cf- writeFileRep (name ++ ".tex") latex- if make then (writeFileRep "Makefile" $ makefile name) else return ()--makefile :: String -> String-makefile name = unlines - [- "CC = gcc",- "CCFLAGS = -g -W -Wall",- "",- "FLEX = flex",- "FLEX_OPTS = -P" ++ name,- "",- "BISON = bison",- "BISON_OPTS = -t -p" ++ name,- "",- "LATEX = pdflatex",- "",- "all: Test" ++ name ++ " " ++ name ++ ".pdf",- "",- ".PHONY: clean distclean",- "",- "clean:",- -- peteg: don't nuke what we generated - move that to the "vclean" target.- "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".pdf Test" ++ name,- "",- "distclean: clean", -- FIXME- "\trm -f *.o Absyn.c Absyn.h Test.c Parser.c Parser.h Lexer.c Skeleton.c Skeleton.h Printer.c Printer.h " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".pdf Test" ++ name ++ " Makefile",- "",- "Test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o",- "\t@echo \"Linking test" ++ name ++ "...\"",- "\t${CC} ${CCFLAGS} *.o -o Test" ++ name ++ "",- "",- "Absyn.o: Absyn.c Absyn.h",- "\t${CC} ${CCFLAGS} -c Absyn.c",- "",- "Lexer.c: " ++ name ++ ".l",- "\t${FLEX} ${FLEX_OPTS} -oLexer.c " ++ name ++ ".l",- "",- "Parser.c: " ++ name ++ ".y",- "\t${BISON} ${BISON_OPTS} " ++ name ++ ".y -o Parser.c",- "",- "Lexer.o: Lexer.c Parser.h",- "\t${CC} ${CCFLAGS} -c Lexer.c ",- "",- "Parser.o: Parser.c Absyn.h",- "\t${CC} ${CCFLAGS} -c Parser.c",- "",- "Printer.o: Printer.c Printer.h Absyn.h",- "\t${CC} ${CCFLAGS} -c Printer.c",- "",- "Test.o: Test.c Parser.h Printer.h Absyn.h",- "\t${CC} ${CCFLAGS} -c Test.c",- "",- "" ++ name ++ ".pdf: " ++ name ++ ".tex",- "\t${LATEX} " ++ name ++ ".tex",- ""- ]--ctest :: CF -> String-ctest cf =- unlines- [- "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",- "/* */",- "/* This test will parse a file, print the abstract syntax tree, and then */",- "/* pretty-print the result. */",- "/* */",- "/****************************************************************************/",- "",- "#include <stdio.h>",- "#include <stdlib.h>",- "",- "#include \"Parser.h\"",- "#include \"Printer.h\"",- "#include \"Absyn.h\"",- "",- "int main(int argc, char ** argv)",- "{",- " FILE *input;",- " " ++ def ++ " parse_tree;",- " if (argc > 1) ",- " {",- " input = fopen(argv[1], \"r\");",- " if (!input)",- " {",- " fprintf(stderr, \"Error opening input file.\\n\");",- " exit(1);",- " }",- " }",- " else input = stdin;",- " /* The default entry point is used. For other options see Parser.h */",- " parse_tree = p" ++ def ++ "(input);",- " if (parse_tree)",- " {",- " printf(\"\\nParse Succesful!\\n\");",- " printf(\"\\n[Abstract Syntax]\\n\");",- " printf(\"%s\\n\\n\", show" ++ def ++ "(parse_tree));",- " printf(\"[Linearized Tree]\\n\");",- " printf(\"%s\\n\\n\", print" ++ def ++ "(parse_tree));",- " return 0;",- " }",- " return 1;",- "}",- ""- ]- where- def = head (allEntryPoints cf)--mkHeaderFile :: CF -> [Cat] -> [Cat] -> [(a, String)] -> String-mkHeaderFile cf cats eps env = unlines- [- "#ifndef PARSER_HEADER_FILE",- "#define PARSER_HEADER_FILE",- "",- "#include \"Absyn.h\"",- "",- "typedef union",- "{",- " int int_;",- " char char_;",- " double double_;",- " char* string_;",- (concatMap mkVar cats) ++ "} YYSTYPE;",- "",- "#define _ERROR_ 258",- mkDefines (259::Int) env,- "extern YYSTYPE yylval;",- concatMap mkFunc eps,- "",- "#endif"- ]- where- mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n"- mkVar _ = ""- mkDefines n [] = mkString n- mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)- mkString n = if isUsedCat cf "String" - then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)- else mkChar n- mkChar n = if isUsedCat cf "Char" - then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)- else mkInteger n- mkInteger n = if isUsedCat cf "Integer" - then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)- else mkDouble n- mkDouble n = if isUsedCat cf "Double" - then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)- else mkIdent n- mkIdent n = if isUsedCat cf "Ident" - then ("#define _IDENT_ " ++ show n ++ "\n")- else ""- mkFunc s | (normCat s == s) = (identCat s) ++ " p" ++ (identCat s) ++ "(FILE *inp);\n"- mkFunc _ = ""-
− src/formats/cpp/CFtoBison.hs
@@ -1,352 +0,0 @@-{-- BNF Converter: Bison generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{-- BNF Converter: C++ Bison generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Bison input file.- Note that because of the way bison stores results- the programmer can increase performance by limiting- the number of entry points in their grammar.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 6 August, 2003 -- Modified : 6 August, 2003 -- - ************************************************************** --}---module CFtoBison (cf2Bison) where--import CF-import Data.List (intersperse, isPrefixOf)-import NamedVariables hiding (varName)-import Data.Char (toLower,isUpper)-import Utils ((+++), (++++))-import TypeChecker-import ErrM----This follows the basic structure of CFtoHappy.---- Type declarations-type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String----The environment comes from the CFtoFlex-cf2Bison :: String -> CF -> SymEnv -> String-cf2Bison name cf env- = unlines - [header name cf,- union (allCats cf),- "%token _ERROR_",- tokens user env,- declarations cf,- specialToks cf,- "%%",- prRules (rulesForBison name cf env)- ]- where- user = fst (unzip (tokenPragmas cf))--header :: String -> CF -> String-header name cf = unlines - ["/* This Bison file was machine-generated by BNFC */",- "%{",- "#include <stdlib.h>",- "#include <stdio.h>",- "#include <string.h>",- "#include <iostream>",- "#include \"Absyn.H\"",- "int yyparse(void);",- "int yylex(void);",- "int yy_mylinenumber;", --- hack to get line number. AR 2006- "int initialize_lexer(FILE * inp);",- "int yywrap(void)",- "{",- " return 1;",- "}",- "void yyerror(const char *str)",- "{",- " std::cout << \"line \" << yy_mylinenumber + 1 << std::endl ;",- " fprintf(stderr,\"error: %s\\n\",str);",- "}",- "",- definedRules cf,- unlines $ map (parseMethod name) (allCatsIdNorm cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.- concatMap reverseList (filter isList (allCats cf)),- "%}"- ]--definedRules :: CF -> String-definedRules cf =- unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf]- where- ctx = buildContext cf-- list = LC (const "[]") (\t -> "List" ++ unBase t)- where- unBase (ListT t) = unBase t- unBase (BaseT x) = normCat x-- rule f xs e =- case checkDefinition' list ctx f xs e of- Bad err -> error $ "Panic! This should have been caught already:\n" ++ err- Ok (args,(e',t)) -> unlines- [ cppType t ++ " " ++ f ++ "_ (" ++- concat (intersperse ", " $ map cppArg args) ++ ") {"- , " return " ++ cppExp e' ++ ";"- , "}"- ]- where-- cppType :: Base -> String- cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *"- cppType (ListT t) = cppType t ++ " *"- cppType (BaseT x)- | isToken x ctx = "String"- | otherwise = normCat x ++ " *"-- cppArg :: (String, Base) -> String- cppArg (x,t) = cppType t ++ " " ++ x ++ "_"-- cppExp :: Exp -> String- cppExp (App "[]" []) = "0"- cppExp (App x [])- | elem x xs = x ++ "_" -- argument- cppExp (App t [e])- | isToken t ctx = cppExp e- cppExp (App x es)- | isUpper (head x) = call ("new " ++ x) es- | otherwise = call (x ++ "_") es- cppExp (LitInt n) = show n- cppExp (LitDouble x) = show x- cppExp (LitChar c) = show c- cppExp (LitString s) = show s-- call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"-----This generates a parser method for each entry point.-parseMethod :: String -> Cat -> String-parseMethod name cat = - -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm- -- then ""- -- else - unlines- [- cat' ++ "*" +++ (resultName cat') +++ "= 0;",- cat' ++"* p" ++ cat' ++ "(FILE *inp)",- "{",- " initialize_lexer(inp);",- " if (yyparse())",- " { /* Failure */",- " return 0;",- " }",- " else",- " { /* Success */",- " return" +++ (resultName cat') ++ ";",- " }",- "}"- ]- where- cat' = identCat (normCat cat)----This method generates list reversal functions for each list type.-reverseList :: Cat -> String-reverseList c = unlines- [- c' ++ "* reverse" ++ c' ++ "(" ++ c' +++ "*l)",- "{",- " " ++ c' +++"*prev = 0;",- " " ++ c' +++"*tmp = 0;",- " while (l)",- " {",- " tmp = l->" ++ v ++ ";",- " l->" ++ v +++ "= prev;",- " prev = l;",- " l = tmp;",- " }",- " return prev;",- "}"- ]- where- c' = identCat (normCat c)- v = (map toLower c') ++ "_"----The union declaration is special to Bison/Yacc and gives the type of yylval.---For efficiency, we may want to only include used categories here.-union :: [Cat] -> String-union cats = unlines- [- "%union",- "{",- " int int_;",- " char char_;",- " double double_;",- " char* string_;",- concatMap mkPointer cats,- "}"- ]- where --This is a little weird because people can make [Exp2] etc.- mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion.- " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n"- mkPointer s | normCat s == s = --normal cat- " " ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n"- mkPointer s = ""- ---declares non-terminal types.-declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (allCats cf)- where --don't define internal rules- typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n"- typeNT cf nt = ""----declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user ts = concatMap (declTok user) ts- where- declTok u (s,r) = if elem s u- then "%token<string_> " ++ r ++ " // " ++ s ++ "\n"- else "%token " ++ r ++ " // " ++ s ++ "\n"--specialToks :: CF -> String-specialToks cf = concat [ - ifC "String" "%token<string_> _STRING_\n",- ifC "Char" "%token<char_> _CHAR_\n",- ifC "Integer" "%token<int_> _INTEGER_\n",- ifC "Double" "%token<double_> _DOUBLE_\n",- ifC "Ident" "%token<string_> _IDENT_\n"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForBison :: String -> CF -> SymEnv -> Rules-rulesForBison name cf env = map mkOne $ ruleGroups cf where- mkOne (cat,rules) = constructRule cf env rules cat---- For every non-terminal, we construct a set of rules.-constructRule :: CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule cf env rules nt = (nt,[(p,(generateAction (ruleName r) b m) +++ result) | - r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf env r])- where- ruleName r = case funRule r of- "(:)" -> identCat nt- "(:[])" -> identCat nt- z -> z- revs = reversibleCats cf- eps = allEntryPoints cf- isEntry nt = if elem nt eps then True else False- result = if isEntry nt then (resultName (normCat (identCat nt))) ++ "= $$;" else ""---- Generates a string containing the semantic action.-generateAction :: Fun -> Bool -> [MetaVar] -> Action-generateAction f b ms = - if isCoercion f - then (unwords ms) ++ ";"- else if f == "[]"- then "0;"- else if isDefinedRule f- then concat [ f, "_", "(", concat $ intersperse ", " ms', ");" ]- else concat ["new ", normCat f, "(", (concat (intersperse ", " ms')), ");"]- where- ms' = if b then reverse ms else ms- --- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])-generatePatterns cf env r = case rhsRule r of- [] -> ("/* empty */",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> case lookup c env of- Just x -> x- Nothing -> typeName (identCat c)- Right s -> case lookup s env of- Just x -> x- Nothing -> s- metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 :: Int ..] its]- revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("reverse" ++ (identCat (normCat c)) ++ "(" ++ m ++ ")")- else m -- no reversal in the left-recursive Cons rule itself- revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules [] = []-prRules ((nt, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ $$ =", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls----Some helper functions.-resultName :: String -> String-resultName s = "YY_RESULT_" ++ s ++ "_"----slightly stronger than the NamedVariable version.-varName :: String -> String-varName s = (map toLower (identCat s)) ++ "_"--typeName :: String -> String-typeName "Ident" = "_IDENT_"-typeName "String" = "_STRING_"-typeName "Char" = "_CHAR_"-typeName "Integer" = "_INTEGER_"-typeName "Double" = "_DOUBLE_"-typeName x = x
− src/formats/cpp/CFtoCPPAbs.hs
@@ -1,443 +0,0 @@-{-- BNF Converter: C++ abstract syntax generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C++ Abstract Syntax- tree classes. It generates both a Header file- and an Implementation file, and uses the Visitor- design pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 4 August, 2003 -- Modified : 22 May, 2004 / Antti-Juhani Kaijanaho-- - ************************************************************** --}--module CFtoCPPAbs (cf2CPPAbs) where--import CF-import Utils((+++),(++++))-import NamedVariables-import Data.List-import Data.Char(toLower)-----The result is two files (.H file, .C file)-cf2CPPAbs :: String -> CF -> (String, String)-cf2CPPAbs name cf = (mkHFile cf, mkCFile cf)---{- **** Header (.H) File Functions **** -}----Makes the Header file.-mkHFile :: CF -> String-mkHFile cf = unlines- [- "#ifndef ABSYN_HEADER",- "#define ABSYN_HEADER",- "",- header,- prTypeDefs user,- "/******************** Forward Declarations ********************/\n",- concatMap prForward classes,- "",- prVisitor classes,- prVisitable,- "",- "/******************** Abstract Syntax Classes ********************/\n",- concatMap (prDataH user) (cf2dataLists cf),- "",- "#endif"- ]- where- user = fst (unzip (tokenPragmas cf))- header = "//C++ Abstract Syntax Interface generated by the BNF Converter.\n"- rules = getRules cf- classes = rules ++ (getClasses (allCats cf))- prForward s | isProperLabel s = "class " ++ (normCat s) ++ ";\n"- prForward s = ""- getRules cf = (map testRule (rulesOfCF cf))- getClasses [] = []- getClasses (c:cs) = - if identCat (normCat c) /= c - then getClasses cs- else if elem c rules- then getClasses cs- else c : (getClasses cs)- - testRule (Rule f c r) = - if isList c- then if isConsFun f - then identCat c- else "_" --ignore this- else f----Prints interface classes for all categories.-prDataH :: [UserDef] -> Data -> String-prDataH user (cat, rules) = - case lookup cat rules of- Just x -> concatMap (prRuleH user cat) rules- Nothing -> if isList cat- then concatMap (prRuleH user cat) rules- else unlines- [- "class" +++ (identCat cat) +++ ": public Visitable {",- "public:",- " virtual" +++ (identCat cat) +++ "*clone() const = 0;",- "};\n",- concatMap (prRuleH user cat) rules- ]- ---Interface definitions for rules vary on the type of rule.-prRuleH :: [UserDef] -> String -> (Fun, [Cat]) -> String-prRuleH user c (fun, cats) = - if isNilFun fun || isOneFun fun- then "" --these are not represented in the AbSyn- else if isConsFun fun- then --this is the linked list case.- unlines- [- "class" +++ c' +++ ": public Visitable",- "{",- " public:",- prInstVars user vs,- " " ++ c' ++ "(const" +++ c' +++ "&);",- " " ++ c' ++ " &operator=(const" +++ c' +++ "&);",- " " ++ c' ++ "(" ++ (prConstructorH 1 vs) ++ ");",- " " ++ c' ++ "(" ++ mem +++ memstar ++ "p);",- prDestructorH c',- " " ++ c' ++ "* reverse();",- " " ++ c' ++ "* reverse(" ++ c' ++ " *l);",- " virtual void accept(Visitor *v);",- " virtual " ++ c' ++ " *clone() const;",- " void swap(" ++ c' +++ "&);",- "};"- ]- else --a standard rule- unlines- [- "class" +++ fun' +++ ": public" +++ super,- "{",- " public:",- prInstVars user vs,- " " ++ fun' ++ "(const" +++ fun' +++ "&);",- " " ++ fun' ++ " &operator=(const" +++ fun' +++ "&);",- " " ++ fun' ++ "(" ++ (prConstructorH 1 vs) ++ ");",- prDestructorH fun',- " virtual void accept(Visitor *v);",- " virtual " +++ fun' +++ " *clone() const;",- " void swap(" ++ fun' +++ "&);",- "};\n"- ]- where - vs = getVars cats- fun' = identCat (normCat fun)- c' = identCat (normCat c);- mem = drop 4 c'- memstar = if isBasic user mem then "" else "*"- super = if c == fun then "Visitable" else (identCat c)- prConstructorH :: Int -> [(String, b)] -> String- prConstructorH _ [] = ""- prConstructorH n ((t,_):[]) = t +++ (optstar t) ++ "p" ++ (show n)- prConstructorH n ((t,_):vs) =( t +++ (optstar t) ++ "p" ++ (show n) ++ ", ") ++ (prConstructorH (n+1) vs)- prDestructorH n = " ~" ++ n ++ "();"- optstar x = if isBasic user x- then ""- else "*"--prVisitable :: String-prVisitable = unlines- [- "class Visitable",- "{",- " public:",- -- all classes with virtual methods require a virtual destructor- " virtual ~Visitable() {}",- " virtual void accept(Visitor *v) = 0;",- "};\n"- ]--prVisitor :: [String] -> String-prVisitor fs = unlines- [- "/******************** Visitor Interfaces ********************/",- "",- "class Visitor",- "{",- " public:",- " virtual ~Visitor() {}",- (concatMap (prVisitFun) fs),- footer- ]- where- footer = unlines- [ --later only include used categories- " virtual void visitInteger(Integer i) = 0;",- " virtual void visitDouble(Double d) = 0;",- " virtual void visitChar(Char c) = 0;",- " virtual void visitString(String s) = 0;",- "};"- ]- prVisitFun f | isProperLabel f = - " virtual void visit" ++ f' ++ "(" ++ f' ++ " *p) = 0;\n"- where- f' = identCat (normCat f)- prVisitFun _ = ""----typedefs in the Header make generation much nicer.-prTypeDefs user = unlines- [- "/******************** TypeDef Section ********************/",- "typedef int Integer;",- "typedef char Char;",- "typedef double Double;",- "typedef char* String;",- "typedef char* Ident;",- concatMap prUserDef user- ]- where- prUserDef s = "typedef char* " ++ s ++ ";\n"- ---A class's instance variables.-prInstVars :: [UserDef] -> [IVar] -> String-prInstVars _ [] = []-prInstVars user vars@((t,n):vs) = - " " ++ t +++ uniques ++ ";" ++++- (prInstVars user vs')- where- (uniques, vs') = prUniques t vars- --these functions group the types together nicely- prUniques :: String -> [IVar] -> (String, [IVar])- prUniques t vs = (prVars (findIndices (\x -> case x of (y,_) -> y == t) vs) vs, remType t vs)- prVars (x:[]) vs = case vs !! x of- (t,n) -> ((varLinkName t) ++ (showNum n))- prVars (x:xs) vs = case vs !! x of - (t,n) -> ((varLinkName t) ++ (showNum n)) ++ "," +++- (prVars xs vs)- varLinkName z = if isBasic user z- then (map toLower z) ++ "_"- else "*" ++ (map toLower z) ++ "_"- remType :: String -> [IVar] -> [IVar]- remType _ [] = []- remType t ((t2,n):ts) = if t == t2 - then (remType t ts) - else (t2,n) : (remType t ts)-- -{- **** Implementation (.C) File Functions **** -}----Makes the .C file-mkCFile :: CF -> String-mkCFile cf = unlines- [- header,- concatMap (prDataC user) (cf2dataLists cf)- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines- [- "//C++ Abstract Syntax Implementation generated by the BNF Converter.",- "#include <algorithm>",- "#include \"Absyn.H\""- ]----This is not represented in the implementation.-prDataC :: [UserDef] -> Data -> String-prDataC user (cat, rules) = concatMap (prRuleC user cat) rules----Classes for rules vary based on the type of rule.-prRuleC user c (fun, cats) = - if isNilFun fun || isOneFun fun- then "" --these are not represented in the AbSyn- else if isConsFun fun- then --this is the linked list case.- unlines- [- "/******************** " ++ c' ++ " ********************/",- prConstructorC user c' vs cats,- prCopyC user c' vs,- prDestructorC user c' vs,- prListFuncs user c',- prAcceptC c',- prCloneC user c' vs,- ""- ]- else --a standard rule- unlines- [- "/******************** " ++ fun' ++ " ********************/",- prConstructorC user fun' vs cats,- prCopyC user fun' vs,- prDestructorC user fun' vs,- prAcceptC fun,- prCloneC user fun' vs,- ""- ]- where - vs = getVars cats- fun' = identCat (normCat fun)- c' = identCat (normCat c)----These are all built-in list functions.---Later we could include things like lookup,insert,delete,etc.-prListFuncs :: [UserDef] -> String -> String-prListFuncs user c = unlines- [- c ++ "::" ++ c ++ "(" ++ m +++ mstar ++ "p)",- "{",- " " ++ m' ++ " = p;",- " " ++ v ++ "= 0;",- "}",- c ++ "*" +++ c ++ "::" ++ "reverse()",- "{",- " if (" ++ v +++ "== 0) return this;",- " else",- " {",- " " ++ c ++ " *tmp =" +++ v ++ "->reverse(this);",- " " ++ v +++ "= 0;",- " return tmp;",- " }",- "}",- "",- c ++ "*" +++ c ++ "::" ++ "reverse(" ++ c ++ "* prev)",- "{",- " if (" ++ v +++ "== 0)",- " {",- " " ++ v +++ "= prev;",- " return this;",- " }",- " else",- " {",- " " ++ c +++ "*tmp =" +++ v ++ "->reverse(this);",- " " ++ v +++ "= prev;",- " return tmp;",- " }",- "}"- ]- where- v = (map toLower c) ++ "_"- m = drop 4 c- mstar = if isBasic user m then "" else "*"- m' = drop 4 v----The standard accept function for the Visitor pattern-prAcceptC :: String -> String-prAcceptC ty = - "\nvoid " ++ ty ++ "::accept(Visitor *v) { v->visit" ++ ty ++ "(this); }"----The constructor just assigns the parameters to the corresponding instance variables.-prConstructorC :: [UserDef] -> String -> [IVar] -> [Cat] -> String-prConstructorC user c vs cats = - c ++ "::" ++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ - prAssigns vs params ++ "}"- where- (types, params) = unzip (prParams cats (length cats) ((length cats)+1))- interleave _ [] = []- interleave (x:[]) (y:[]) = x +++ (optstar x) ++ y- interleave (x:xs) (y:ys) = x +++ (optstar x) ++ y ++ "," +++ (interleave xs ys)- optstar x = if isBasic user x- then ""- else "*"----Print copy constructor and copy assignment-prCopyC :: [UserDef] -> String -> [IVar] -> String-prCopyC user c vs =- c ++ "::" ++ c ++ "(const" +++ c +++ "& other) {" +++- concatMap doV vs ++++- "}" ++++- c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other) {" ++++- " " ++ c +++ "tmp(other);" ++++- " swap(tmp);" ++++- " return *this;" ++++- "}" ++++- "void" +++ c ++ "::swap(" ++ c +++ "& other) {" ++++- concatMap swapV vs ++++- "}\n"- where doV :: IVar -> String- doV v@(t, _) - | isBasic user t = " " ++ vn v ++ " = other." ++ vn v ++ ";\n"- | otherwise = " " ++ vn v ++ " = other." ++ vn v ++ "->clone();\n"- vn :: IVar -> String- vn (t, 0) = varName t- vn (t, n) = varName t ++ show n- swapV :: IVar -> String- swapV v = " std::swap(" ++ vn v ++ ", other." ++ vn v ++ ");\n"----The cloner makes a new deep copy of the object-prCloneC :: [UserDef] -> String -> [IVar] -> String-prCloneC user c vs =- c +++ "*" ++ c ++ "::clone() const {" ++++- " return new" +++ c ++ "(*this);\n}"----The destructor deletes all a class's members.-prDestructorC :: [UserDef] -> String -> [IVar] -> String-prDestructorC user c vs = - c ++ "::~" ++ c ++"()" +++ "{" +++ - (concatMap prDeletes vs) ++ "}"- where- prDeletes :: (String, Int) -> String- prDeletes (t, n) = if isBasic user t- then ""- else if n == 0- then "delete(" ++ (varName t) ++ "); "- else "delete(" ++ (varName t) ++ (show n) ++ "); "----Prints the constructor's parameters. -prParams :: [Cat] -> Int -> Int -> [(String,String)]-prParams [] _ _ = []-prParams (c:cs) n m = (identCat c,"p" ++ (show (m-n)))- : (prParams cs (n-1) m)- ---Prints the assignments of parameters to instance variables.---This algorithm peeks ahead in the list so we don't use map or fold-prAssigns :: [IVar] -> [String] -> String-prAssigns [] _ = []-prAssigns _ [] = []-prAssigns ((t,n):vs) (p:ps) =- if n == 1 then- case findIndices (\x -> case x of (l,r) -> l == t) vs of- [] -> (varName t) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)- z -> ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)- else ((varName t) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)---{- **** Helper Functions **** -}----Checks if something is a basic or user-defined type.-isBasic :: [UserDef] -> String -> Bool-isBasic user x = - if elem x user- then True- else case x of- "Integer" -> True- "Char" -> True- "String" -> True- "Double" -> True- "Ident" -> True- _ -> False
− src/formats/cpp/CFtoCPPPrinter.hs
@@ -1,606 +0,0 @@-{- - **************************************************************- BNF Converter Module-- Description : This module generates the C++ Pretty Printer.- It also generates the "show" method for- printing an abstract syntax tree.- - The generated files use the Visitor design pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 10 August, 2003 -- Modified : 3 September, 2003 - * Added resizable buffers- - ************************************************************** --}--module CFtoCPPPrinter (cf2CPPPrinter) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper)----Produces (.H file, .C file)-cf2CPPPrinter :: CF -> (String, String)-cf2CPPPrinter cf = (mkHFile cf groups, mkCFile cf groups)- where- groups = (fixCoercions (ruleGroupsInternals cf))--{- **** Header (.H) File Methods **** -}----An extremely large function to make the Header File-mkHFile :: CF -> [(Cat,[Rule])] -> String-mkHFile cf groups = unlines- [- printHeader,- concatMap prDataH groups,- classFooter,- showHeader,- concatMap prDataH groups,- classFooter,- footer- ]- where- printHeader = unlines- [- "#ifndef PRINTER_HEADER",- "#define PRINTER_HEADER",- "",- "#include \"Absyn.H\"",- "#include <stdio.h>",- "#include <string.h>",- "#include <stdlib.h>",- "",- "/* Certain applications may improve performance by changing the buffer size */",- "#define BUFFER_INITIAL 2000",- "/* You may wish to change _L_PAREN or _R_PAREN */",- "#define _L_PAREN '('",- "#define _R_PAREN ')'",- "",- "class PrintAbsyn : public Visitor",- "{",- " protected:",- " int _n_, _i_;",- " /* The following are simple heuristics for rendering terminals */",- " /* You may wish to change them */",- " void render(Char c);",- " void render(String s);",- " void indent(void);",- " void backup(void);",- " public:",- " PrintAbsyn(void);",- " ~PrintAbsyn(void);",- " char* print(Visitable* v);"- ]- classFooter = unlines- [- " void visitInteger(Integer i);",- " void visitDouble(Double d);",- " void visitChar(Char c);",- " void visitString(String s);",- " void visitIdent(String s);",- " protected:",- " void inline bufAppend(const char* s)",- " {",- " int len = strlen(s);",- " while (cur_ + len > buf_size)",- " {",- " buf_size *= 2; /* Double the buffer size */",- " resizeBuffer();",- " }",- " for(int n = 0; n < len; n++)",- " {",- " buf_[cur_ + n] = s[n];",- " }",- " cur_ += len;",- " buf_[cur_] = 0;",- " }",- " void inline bufAppend(const char c)",- " {",- " if (cur_ == buf_size)",- " {",- " buf_size *= 2; /* Double the buffer size */",- " resizeBuffer();",- " }",- " buf_[cur_] = c;",- " cur_++;",- " buf_[cur_] = 0;",- " }",- " void inline bufReset(void)",- " {",- " cur_ = 0;",- " buf_size = BUFFER_INITIAL;",- " resizeBuffer();",- " memset(buf_, 0, buf_size);",- " }",- " void inline resizeBuffer(void)",- " {",- " char* temp = (char*) malloc(buf_size);",- " if (!temp)",- " {",- " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",- " exit(1);",- " }",- " if (buf_)",- " {",- " strcpy(temp, buf_);",- " free(buf_);",- " }",- " buf_ = temp;",- " }",- " char *buf_;",- " int cur_, buf_size;",- "};",- ""- ]- showHeader = unlines- [- "",- "class ShowAbsyn : public Visitor",- "{",- " public:",- " ShowAbsyn(void);",- " ~ShowAbsyn(void);",- " char* show(Visitable* v);"- ]- footer = unlines- [- "",- "#endif"- ]----Prints all the required method names and their parameters.-prDataH :: (Cat, [Rule]) -> String-prDataH (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then concat [" void visit", cl, "(", cl, "* p);\n"]- else abstract ++ (concatMap prRuleH rules)- where- cl = identCat (normCat cat)- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n"----Prints all the methods to visit a rule.-prRuleH :: Rule -> String-prRuleH (Rule fun c cats) | isProperLabel fun = concat- [" void visit", fun, "(", fun, " *p);\n"]-prRuleH _ = ""--{- **** Implementation (.C) File Methods **** -}----This makes the .C file by a similar method.-mkCFile :: CF -> [(Cat,[Rule])] -> String-mkCFile cf groups = concat - [- header,- prRender,- printEntries,- concatMap (prPrintData user) groups,- printBasics,- showEntries,- concatMap (prShowData user) groups,- showBasics- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines - [- "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",- "",- "#include \"Printer.H\"",- ""- ]- printEntries = unlines- [- "PrintAbsyn::PrintAbsyn(void)",- "{",- " _i_ = 0; _n_ = 0;",- " buf_ = 0;",- " bufReset();",- "}",- "",- "PrintAbsyn::~PrintAbsyn(void)",- "{",- "}",- "",- "char* PrintAbsyn::print(Visitable *v)",- "{",- " _i_ = 0; _n_ = 0;",- " bufReset();",- " v->accept(this);",- " return buf_;",- "}"- ]- showEntries = unlines- [- "ShowAbsyn::ShowAbsyn(void)",- "{",- " buf_ = 0;",- " bufReset();",- "}",- "",- "ShowAbsyn::~ShowAbsyn(void)",- "{",- "}",- "",- "char* ShowAbsyn::show(Visitable *v)",- "{",- " bufReset();",- " v->accept(this);",- " return buf_;",- "}"- ]- printBasics = unlines - [- "void PrintAbsyn::visitInteger(Integer i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%d\", i);",- " bufAppend(tmp);",- "}",- "void PrintAbsyn::visitDouble(Double d)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppend(tmp);",- "}",- "void PrintAbsyn::visitChar(Char c)",- "{",- " bufAppend('\\'');",- " bufAppend(c);",- " bufAppend('\\'');",- "}",- "void PrintAbsyn::visitString(String s)",- "{",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- "void PrintAbsyn::visitIdent(String s)",- "{",- " render(s);",- "}",- ""- ]- showBasics = unlines - [- "void ShowAbsyn::visitInteger(Integer i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%d\", i);",- " bufAppend(tmp);",- "}",- "void ShowAbsyn::visitDouble(Double d)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppend(tmp);",- "}",- "void ShowAbsyn::visitChar(Char c)",- "{",- " bufAppend('\\'');",- " bufAppend(c);",- " bufAppend('\\'');",- "}",- "void ShowAbsyn::visitString(String s)",- "{",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- "void ShowAbsyn::visitIdent(String s)",- "{",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- ""- ]--{- **** Pretty Printer Methods **** -}----Generates methods for the Pretty Printer-prPrintData :: [UserDef] -> (Cat, [Rule]) -> String-prPrintData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then unlines- [- "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",- "{",- " while(" ++ vname ++ "!= 0)",- " {",- " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)",- " {",- visitMember,- optsep,- " " ++ vname +++ "= 0;",- " }",- " else",- " {",- visitMember,- " render(" ++ sep ++ ");",- " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",- " }",- " }",- "}",- ""- ] --Not a list:- else abstract ++ (concatMap (prPrintRule user) rules)- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl ++ "_"- visitMember = if isBasic user member- then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"- sep = if (length sep') == 1- then "'" ++ (escapeChars sep') ++ "'"- else "\"" ++ (escapeChars sep') ++ "\""- sep' = getCons rules- optsep = if hasOneFunc rules then "" else (" render(" ++ sep ++ ");")- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n"- ---Pretty Printer methods for a rule.-prPrintRule :: [UserDef] -> Rule -> String-prPrintRule user r@(Rule fun c cats) | isProperLabel fun = unlines- [- "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",- "{",- " int oldi = _i_;",- lparen,- cats',- rparen,- " _i_ = oldi;",- "}\n"- ]- where- p = precRule r- (lparen, rparen) = - (" if (oldi > " ++ (show p) ++ ") render(_L_PAREN);\n",- " if (oldi > " ++ (show p) ++ ") render(_R_PAREN);\n")- cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)))- fnm = "p" --old names could cause conflicts- getPrec (Right s) = 0- getPrec (Left c) = precCat c-prPrintRule _ _ = ""----This goes on to recurse to the instance variables.-prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String-prPrintCat user fnm (c,p) = case c of- (Right t) -> " render(" ++ t' ++ ");\n"- where- t' = if length t == 1- then "'" ++ (escapeChars t) ++ "'"- else "\"" ++ (escapeChars t) ++ "\""- (Left nt) -> if isBasic user nt- then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"- else if "list" `isPrefixOf` nt- then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}"- else " " ++ accept ++ "\n"- where- accept = if nt == "#_" --Internal category- then "/* Internal Category */\n"- else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);"--{- **** Abstract Syntax Tree Printer **** -}----This prints the functions for Abstract Syntax tree printing.-prShowData :: [UserDef] -> (Cat, [Rule]) -> String-prShowData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then unlines- [- "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",- "{",- " while(" ++ vname ++ "!= 0)",- " {",- " if (" ++ vname ++ "->" ++ vname ++ "_)",- " {",- visitMember,- " bufAppend(\", \");",- " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",- " }",- " else",- " {",- visitMember,- " " ++ vname ++ " = 0;",- " }",- " }",- "}",- ""- ] --Not a list:- else abstract ++ (concatMap (prShowRule user) rules)- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl ++ "_"- visitMember = if isBasic user member- then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n"----This prints all the methods for Abstract Syntax tree rules.-prShowRule :: [UserDef] -> Rule -> String-prShowRule user (Rule fun c cats) | isProperLabel fun = concat- [- "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n",- "{\n",- lparen,- " bufAppend(\"" ++ fun ++ "\");\n",- optspace,- cats',- rparen,- "}\n"- ]- where- (optspace, lparen, rparen) = if allTerms cats- then ("","","")- else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n")- cats' = if allTerms cats- then ""- else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats))))- insertSpaces [] = []- insertSpaces (x:[]) = [x]- insertSpaces (x:xs) = if x == "" - then insertSpaces xs- else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs)- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- fnm = "p" --other names could cause conflicts-prShowRule _ _ = ""----This recurses to the instance variables of a class.-prShowCat :: [UserDef] -> String -> Either Cat String -> String-prShowCat user fnm c = - case c of- (Right t) -> ""- (Left nt) -> - if isBasic user nt- then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"- else if nt == "#_" --internal category- then "/* Internal Category */\n"- else if ((normCat nt) /= nt)- then accept- else concat- [- " bufAppend('[');\n",- " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept,- " bufAppend(']');\n"- ]- where- accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n"--{- **** Helper Functions Section **** -}-----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user----The visit-function name of a basic type-funName :: String -> String-funName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else "Ident" --User-defined type----Just sets the coercion level for parentheses in the Pretty Printer.-setI :: Int -> String-setI n = "_i_ = " ++ (show n) ++ "; "----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)- ---An extremely simple renderer for terminals.-prRender :: String-prRender = unlines- [- "//You may wish to change render",- "void PrintAbsyn::render(Char c)",- "{",- " if (c == '{')",- " {",- " bufAppend('\\n');",- " indent();",- " bufAppend(c);",- " _n_ = _n_ + 2;",- " bufAppend('\\n');",- " indent();",- " }",- " else if (c == '(' || c == '[')",- " bufAppend(c);",- " else if (c == ')' || c == ']')",- " {",- " backup();",- " bufAppend(c);",- " bufAppend(' ');",- " }",- " else if (c == '}')",- " {",- " _n_ = _n_ - 2;",- " backup();",- " backup();",- " bufAppend(c);",- " bufAppend('\\n\');",- " indent();",- " }",- " else if (c == ',')",- " {",- " backup();",- " bufAppend(c);",- " bufAppend(' ');",- " }",- " else if (c == ';')",- " {",- " backup();",- " bufAppend(c);",- " bufAppend('\\n');",- " indent();",- " }",- " else if (c == 0) return;",- " else",- " {",- " bufAppend(c);",- " bufAppend(' ');",- " }",- "}",- "void PrintAbsyn::render(String s)",- "{",- " if(strlen(s) > 0)",- " {",- " bufAppend(s);",- " bufAppend(' ');",- " }",- "}",- "void PrintAbsyn::indent()",- "{",- " int n = _n_;",- " while (n > 0)",- " {",- " bufAppend(' ');",- " n--;",- " }",- "}",- "void PrintAbsyn::backup()",- "{",- " if (buf_[cur_ - 1] == ' ')",- " {", - " buf_[cur_ - 1] = 0;",- " cur_--;",- " }",- "}"- ]
− src/formats/cpp/CFtoCVisitSkel.hs
@@ -1,259 +0,0 @@-{-- BNF Converter: C++ Skeleton generation- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C++ Skeleton functions.- - The generated files use the Visitor design pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 9 August, 2003 -- Modified : 12 August, 2003 -- - ************************************************************** --}--module CFtoCVisitSkel (cf2CVisitSkel) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper)----Produces (.H file, .C file)-cf2CVisitSkel :: CF -> (String, String)-cf2CVisitSkel cf = (mkHFile cf groups, mkCFile cf groups)- where- groups = (fixCoercions (ruleGroups cf))---{- **** Header (.H) File Functions **** -}----Generates the Header File-mkHFile :: CF -> [(Cat,[Rule])] -> String-mkHFile cf groups = unlines- [- header,- concatMap prDataH groups,- concatMap prUserH user,- footer- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines- [- "#ifndef SKELETON_HEADER",- "#define SKELETON_HEADER",- "/* You might want to change the above name. */",- "",- "#include \"Absyn.H\"",- "",- "class Skeleton : public Visitor",- "{",- " public:"- ]- prUserH u = " void visit" ++ u' ++ "(" ++ u ++ " p);"- where- u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.- footer = unlines- [- " void visitIdent(String s);",- " void visitInteger(Integer i);",- " void visitDouble(Double d);",- " void visitChar(Char c);",- " void visitString(String s);",- "};",- "",- "#endif"- ]- ---Prints out visit functions for a category-prDataH :: (Cat, [Rule]) -> String-prDataH (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then concat [" void visit", cl, "(", cl, "* ", vname, ");"]- else abstract ++ (concatMap prRuleH rules)- where- cl = identCat (normCat cat)- vname = map toLower cl- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ "); /* abstract class */\n"----Visit functions for a rule.-prRuleH :: Rule -> String-prRuleH (Rule fun c cats) | not (isCoercion fun) = concat- [" void visit", fun, "(", fun, "* ", fnm, ");\n"]- where- fnm = map toLower fun-prRuleH _ = ""---{- **** Implementation (.C) File Functions **** -}----Makes the .C File-mkCFile :: CF -> [(Cat,[Rule])] -> String-mkCFile cf groups = concat - [- header,- concatMap (prData user) groups,- concatMap prUser user,- footer- ]- where- user = fst (unzip (tokenPragmas cf))- header = unlines [- "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",- "/* This implements the common visitor design pattern.",- " Note that this method uses Visitor-traversal of lists, so",- " List->accept() does NOT traverse the list. This allows different",- " algorithms to use context information differently. */",- "",- "#include \"Skeleton.H\"",- ""- ]- prUser x = unlines- [- "void Skeleton::visit" ++ x' ++ "(" ++ x ++ " p)",- "{",- " /* Code for " ++ x ++ " Goes Here */",- "}"- ]- where- x' = ((toUpper (head x)) : (map toLower (tail x))) --this is a hack to fix a potential capitalization problem.- footer = unlines - [- "void Skeleton::visitIdent(Ident i)",- "{",- " /* Code for Ident Goes Here */",- "}",- "void Skeleton::visitInteger(Integer i)",- "{",- " /* Code for Integers Goes Here */",- "}",- "void Skeleton::visitDouble(Double d)",- "{",- " /* Code for Doubles Goes Here */",- "}",- "void Skeleton::visitChar(Char c)",- "{",- " /* Code for Chars Goes Here */",- "}",- "void Skeleton::visitString(String s)",- "{",- " /* Code for Strings Goes Here */",- "}",- ""- ]----Visit functions for a category.-prData :: [UserDef] -> (Cat, [Rule]) -> String-prData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then unlines- [- "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")",- "{",- " while(" ++ vname ++ "!= 0)",- " {",- " /* Code For " ++ cl ++ " Goes Here */",- visitMember,- " " ++ vname ++ " = " ++ vname ++ "->" ++ vname ++ "_;",- " }",- "}",- ""- ] --Not a list:- else abstract ++ (concatMap (prRule user) rules)- where- cl = identCat (normCat cat)- vname = map toLower cl- ecl = identCat (normCatOfList cat)- member = map toLower ecl ++ "_"- visitMember = if isBasic user member- then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> "void Skeleton::visit" ++ cl ++ "(" ++ cl ++ "*" +++ vname ++ ") {} //abstract class\n\n"----Visits all the instance variables of a category.-prRule :: [UserDef] -> Rule -> String-prRule user (Rule fun c cats) | not (isCoercion fun) = unlines- [- "void Skeleton::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",- "{",- " /* Code For " ++ fun ++ " Goes Here */",- "",- cats' ++ "}\n"- ]- where- cats' = if allTerms cats- then ""- else (concatMap (prCat user fnm) (fixOnes (numVars [] cats)))- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- fnm = map toLower fun-prRule user _ = ""----Prints the actual instance-variable visiting.-prCat user fnm c =- case c of- (Right t) -> ""- (Left nt) -> if isBasic user nt- then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"- else if "list" `isPrefixOf` nt- then " if (" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}\n"- else " " ++ accept ++ "\n"- where- accept = fnm ++ "->" ++ nt ++ "->accept(this);"----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user----The visit-function name of a basic type-funName :: String -> String-funName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else (toUpper (head v)) : (init (tail v)) --User-defined type
− src/formats/cpp/CFtoFlex.hs
@@ -1,191 +0,0 @@-{-- BNF Converter: Flex generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Flex file. It is- similar to JLex but with a few peculiarities.- - Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 5 August, 2003 -- Modified : 22 August, 2006 by Aarne Ranta -- - ************************************************************** --}-module CFtoFlex (cf2flex) where--import CF-import RegToFlex-import Utils((+++), (++++))-import NamedVariables-import Data.List-import STLUtils----The environment must be returned for the parser to use.-cf2flex :: Maybe String -> String -> CF -> (String, SymEnv)-cf2flex inPackage name cf = (unlines- [- prelude inPackage name,- cMacros,- lexSymbols env,- restOfFlex inPackage cf env'- ], env')- where- env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)- env' = env ++ (makeSymEnv (fst (unzip (tokenPragmas cf))) (length env))- makeSymEnv [] _ = []- makeSymEnv (s:symbs) n = (s, nsDefine inPackage "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))--prelude :: Maybe String -> String -> String-prelude inPackage name = unlines- [- maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage,- "/* This FLex file was machine-generated by the BNF converter */",- "%{",- "#include <string.h>",- "#include \"Parser.H\"",- "#define YY_BUFFER_LENGTH 4096",- "extern int " ++ nsString inPackage ++ "yy_mylinenumber ;", --- hack to get line number. AR 2006- "static char YY_PARSED_STRING[YY_BUFFER_LENGTH];",- "static void YY_BUFFER_APPEND(char *s)",- "{",- " strcat(YY_PARSED_STRING, s); //Do something better here!",- "}",- "static void YY_BUFFER_RESET(void)",- "{",- " for(int x = 0; x < YY_BUFFER_LENGTH; x++)",- " YY_PARSED_STRING[x] = 0;",- "}",- "",- "%}"- ]----For now all categories are included.---Optimally only the ones that are used should be generated.-cMacros :: String-cMacros = unlines- [- "LETTER [a-zA-Z]",- "CAPITAL [A-Z]",- "SMALL [a-z]",- "DIGIT [0-9]",- "IDENT [a-zA-Z0-9'_]",- "%START YYINITIAL COMMENT CHAR CHARESC CHAREND STRING ESCAPED",- "%%"- ]--lexSymbols :: SymEnv -> String-lexSymbols ss = concatMap transSym ss- where- transSym (s,r) = - "<YYINITIAL>\"" ++ s' ++ "\" \t return " ++ r ++ ";\n"- where- s' = escapeChars s--restOfFlex :: Maybe String -> CF -> SymEnv -> String-restOfFlex inPackage cf env = concat- [- lexComments inPackage (comments cf),- userDefTokens,- ifC "String" strStates,- ifC "Char" chStates,- ifC "Double" ("<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"),- ifC "Integer" ("<YYINITIAL>{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"),- ifC "Ident" ("<YYINITIAL>{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"),- "\\n ++" ++ ns ++ "yy_mylinenumber ;\n",- "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",- "<YYINITIAL>. \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n",- "%%\n",- footer- ]- where- ifC cat s = if isUsedCat cf cat then s else ""- ns = nsString inPackage- userDefTokens = unlines $- ["<YYINITIAL>" ++ printRegFlex exp ++ - " \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"- | (name, exp) <- tokenPragmas cf]- where- sName n = case lookup n env of- Just x -> x- Nothing -> n- strStates = unlines --These handle escaped characters in Strings.- [- "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",- "<STRING>\\\\ \t BEGIN ESCAPED;",- "<STRING>\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";",- "<STRING>. \t YY_BUFFER_APPEND(yytext);",- "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",- "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",- "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",- "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",- "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"- ]- chStates = unlines --These handle escaped characters in Chars.- [- "<YYINITIAL>\"'\" \tBEGIN CHAR;",- "<CHAR>\\\\ \t BEGIN CHARESC;",- "<CHAR>[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHARESC>n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHARESC>t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHARESC>. \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHAREND>\"'\" \t BEGIN YYINITIAL;"- ]- footer = unlines- [- "int " ++ ns ++ "initialize_lexer(FILE *inp) { yyin = inp; BEGIN YYINITIAL; }",- "int yywrap(void) { return 1; }"- ]---lexComments :: Maybe String -> ([(String, String)], [String]) -> String-lexComments inPackage (m,s) = - (unlines (map (lexSingleComment inPackage) s)) - ++ (unlines (map (lexMultiComment inPackage) m))--lexSingleComment :: Maybe String -> String -> String-lexSingleComment inPackage c = - "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC single-line comment */;"----There might be a possible bug here if a language includes 2 multi-line comments.---They could possibly start a comment with one character and end it with another.---However this seems rare.-lexMultiComment :: Maybe String -> (String, String) -> String-lexMultiComment inPackage (b,e) = unlines [- "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",- "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",- "<COMMENT>. \t /* BNFC multi-line comment */;",- "<COMMENT>[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;"- ---- "\\n ++yy_mylinenumber ;"- ]- ----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)
− src/formats/cpp/CPPTop.hs
@@ -1,201 +0,0 @@-{-- BNF Converter: C++ Main file- Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CPPTop (makeCPP) where--import Utils-import CF-import CFtoCPPAbs-import CFtoFlex-import CFtoBison-import CFtoCVisitSkel-import CFtoCPPPrinter-import CFtoLatex-import Data.Char-import System.Exit (exitFailure)--makeCPP :: Bool -> String -> CF -> IO ()-makeCPP make name cf = do- let (hfile, cfile) = cf2CPPAbs name cf- writeFileRep "Absyn.H" hfile- writeFileRep "Absyn.C" cfile- let (flex, env) = cf2flex Nothing name cf- writeFileRep (name ++ ".l") flex- putStrLn " (Tested with flex 2.5.31)"- let bison = cf2Bison name cf env- writeFileRep (name ++ ".y") bison- putStrLn " (Tested with bison 1.875a)"- let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env- writeFileRep "Parser.H" header- let (skelH, skelC) = cf2CVisitSkel cf- writeFileRep "Skeleton.H" skelH- writeFileRep "Skeleton.C" skelC- let (prinH, prinC) = cf2CPPPrinter cf- writeFileRep "Printer.H" prinH- writeFileRep "Printer.C" prinC- writeFileRep "Test.C" (cpptest cf)- let latex = cfToLatex name cf- writeFileRep (name ++ ".tex") latex- if make then (writeFileRep "Makefile" $ makefile name) else return ()--makefile :: String -> String-makefile name = unlines - [- "CC = g++",- "CCFLAGS = -g",- "FLEX = flex",- "BISON = bison",- "LATEX = latex",- "DVIPS = dvips",- "",- "all: Test" ++ name ++ " " ++ name ++ ".ps",- "",- "clean:",- -- peteg: don't nuke what we generated - move that to the "vclean" target.- "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name,- "",- "distclean:",- "\t rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ++ " Makefile",- "",- "Test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o",- "\t@echo \"Linking Test" ++ name ++ "...\"",- "\t${CC} ${CCFLAGS} *.o -o Test" ++ name ++ "",- " ",- "Absyn.o: Absyn.C Absyn.H",- "\t${CC} ${CCFLAGS} -c Absyn.C",- "",- "Lexer.C: " ++ name ++ ".l",- "\t${FLEX} -oLexer.C " ++ name ++ ".l",- "",- "Parser.C: " ++ name ++ ".y",- "\t${BISON} " ++ name ++ ".y -o Parser.C",- "",- "Lexer.o: Lexer.C Parser.H",- "\t${CC} ${CCFLAGS} -c Lexer.C ",- "",- "Parser.o: Parser.C Absyn.H",- "\t${CC} ${CCFLAGS} -c Parser.C",- "",- "Printer.o: Printer.C Printer.H Absyn.H",- "\t${CC} ${CCFLAGS} -c Printer.C",- "",- "Test.o: Test.C Parser.H Printer.H Absyn.H",- "\t${CC} ${CCFLAGS} -c Test.C",- "",- "" ++ name ++ ".dvi: " ++ name ++ ".tex",- "\t${LATEX} " ++ name ++ ".tex",- "",- "" ++ name ++ ".ps: " ++ name ++ ".dvi",- "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps",- ""- ]- -cpptest :: CF -> String-cpptest cf =- unlines- [- "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",- "/* */",- "/* This test will parse a file, print the abstract syntax tree, and then */",- "/* pretty-print the result. */",- "/* */",- "/****************************************************************************/",- "#include <stdio.h>",- "#include \"Parser.H\"",- "#include \"Printer.H\"",- "#include \"Absyn.H\"",- "",- "int main(int argc, char ** argv)",- "{",- " FILE *input;",- " if (argc > 1) ",- " {",- " input = fopen(argv[1], \"r\");",- " if (!input)",- " {",- " fprintf(stderr, \"Error opening input file.\\n\");",- " exit(1);",- " }",- " }",- " else input = stdin;",- " /* The default entry point is used. For other options see Parser.H */",- " " ++ def ++ " *parse_tree = p" ++ def ++ "(input);",- " if (parse_tree)",- " {",- " printf(\"\\nParse Succesful!\\n\");",- " printf(\"\\n[Abstract Syntax]\\n\");",- " ShowAbsyn *s = new ShowAbsyn();",- " printf(\"%s\\n\\n\", s->show(parse_tree));",- " printf(\"[Linearized Tree]\\n\");",- " PrintAbsyn *p = new PrintAbsyn();",- " printf(\"%s\\n\\n\", p->print(parse_tree));",- " return 0;",- " }",- " return 1;",- "}",- ""- ]- where- def = head (allEntryPoints cf)--mkHeaderFile cf cats eps env = unlines- [- "#ifndef PARSER_HEADER_FILE",- "#define PARSER_HEADER_FILE",- "",- concatMap mkForwardDec cats,- "typedef union",- "{",- " int int_;",- " char char_;",- " double double_;",- " char* string_;",- (concatMap mkVar cats) ++ "} YYSTYPE;",- "",- "#define _ERROR_ 258",- mkDefines (259 :: Int) env,- "extern YYSTYPE yylval;",- concatMap mkFunc eps,- "",- "#endif"- ]- where- mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n"- mkForwardDec _ = ""- mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n"- mkVar _ = ""- mkDefines n [] = mkString n- mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)- mkString n = if isUsedCat cf "String" - then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)- else mkChar n- mkChar n = if isUsedCat cf "Char" - then ("#define _CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)- else mkInteger n- mkInteger n = if isUsedCat cf "Integer" - then ("#define _INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)- else mkDouble n- mkDouble n = if isUsedCat cf "Double" - then ("#define _DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)- else mkIdent n- mkIdent n = if isUsedCat cf "Ident" - then ("#define _IDENT_ " ++ show n ++ "\n")- else ""- mkFunc s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n"- mkFunc _ = ""
− src/formats/cpp/RegToFlex.hs
@@ -1,73 +0,0 @@-module RegToFlex (printRegFlex) where---- modified from pretty-printer generated by the BNF converter--import AbsBNF-import Data.Char---- the top-level printing method-printRegFlex :: Reg -> String-printRegFlex = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend (0::Int) where- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = [[c]]- prtList s = map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["[^.]"])- RChar c -> prPrec i 3 (prt 0 [mkEsc [c]])- RAlts str -> prPrec i 3 (concat [["["], prt 0 $ mkEsc str, ["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) $ mkEsc str))- RDigit -> prPrec i 3 (concat [["{DIGIT}"]])- RLetter -> prPrec i 3 (concat [["{LETTER}"]])- RUpper -> prPrec i 3 (concat [["{CAPITAL}"]])- RLower -> prPrec i 3 (concat [["{SMALL}"]])- RAny -> prPrec i 3 (concat [["."]])---- Handle special characters in regular expressions.-mkEsc :: String -> String-mkEsc = concatMap escChar- where escChar c- | c `elem` "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\"" = '\\':[c]- | otherwise = [c]
− src/formats/cpp_stl/CFtoBisonSTL.hs
@@ -1,374 +0,0 @@-{-- BNF Converter: C++ Bison generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Bison input file using- STL. The main difference to CFtoBison is in handling - lists: by using std::vector and push_back, our rules- for reverting lists are the opposite to linked lists. - Note that because of the way bison stores results- the programmer can increase performance by limiting- the number of entry points in their grammar.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)- - License : GPL (GNU General Public License)-- Created : 6 August, 2003 -- Modified : 19 August, 2006, by Aarne Ranta (aarne@cs.chalmers.se)-- - ************************************************************** --}---module CFtoBisonSTL (cf2Bison) where--import CF-import Data.List (intersperse, isPrefixOf)-import NamedVariables hiding (varName)-import Data.Char (toLower,isUpper,isDigit)-import Utils ((+++), (++++))-import TypeChecker-import ErrM-import STLUtils----This follows the basic structure of CFtoHappy.---- Type declarations-type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String----The environment comes from the CFtoFlex-cf2Bison :: Bool -> Maybe String -> String -> CF -> SymEnv -> String-cf2Bison ln inPackage name cf env- = unlines - [header inPackage name cf,- union inPackage (positionCats cf ++ allCats cf),- maybe "" (\ns -> "%name-prefix=\"" ++ ns ++ "yy\"") inPackage,- "%token _ERROR_",- tokens user env,- declarations cf,- specialToks cf,- "%%",- prRules (rulesForBison ln inPackage name cf env)- ]- where- user = fst (unzip (tokenPragmas cf))- --positionCats cf = filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))--header :: Maybe String -> String -> CF -> String-header inPackage name cf = unlines - ["/* This Bison file was machine-generated by BNFC */",- "%{",- "#include <stdlib.h>",- "#include <stdio.h>",- "#include <string.h>",- "#include <iostream>",- "#include <algorithm>",- "#include \"Absyn.H\"",- "typedef struct yy_buffer_state *YY_BUFFER_STATE;",- "int yyparse(void);",- "int yylex(void);",- "YY_BUFFER_STATE " ++ ns ++ "yy_scan_string(const char *str);",- "void " ++ ns ++ "yy_delete_buffer(YY_BUFFER_STATE buf);",- "int " ++ ns ++ "yy_mylinenumber;", --- hack to get line number. AR 2006- "int " ++ ns ++ "initialize_lexer(FILE * inp);",- "int " ++ ns ++ "yywrap(void)",- "{",- " return 1;",- "}",- "void " ++ ns ++ "yyerror(const char *str)",- "{",- " std::cout << \"line \" << " ++ ns ++ "yy_mylinenumber << std::endl ;",- " fprintf(stderr,\"error: %s\\n\",str);",- "}",- "",- definedRules cf,- nsStart inPackage,- unlines $ map (parseMethod inPackage name) (allCatsIdNorm cf ++ positionCats cf), -- (allEntryPoints cf), M.F. 2004-09-14 fix of [Ty2] bug.- nsEnd inPackage,- "%}"- ]- where- ns = nsString inPackage--definedRules :: CF -> String-definedRules cf =- unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]- where- ctx = buildContext cf-- list = LC (const "[]") (\t -> "List" ++ unBase t)- where- unBase (ListT t) = unBase t- unBase (BaseT x) = normCat x-- rule f xs e =- case checkDefinition' list ctx f xs e of- Bad err -> error $ "Panic! This should have been caught already:\n" ++ err- Ok (args,(e',t)) -> unlines- [ cppType t ++ " " ++ f ++ "_ (" ++- concat (intersperse ", " $ map cppArg args) ++ ") {"- , " return " ++ cppExp e' ++ ";"- , "}"- ]- where-- cppType :: Base -> String- cppType (ListT (BaseT x)) = "List" ++ normCat x ++ " *"- cppType (ListT t) = cppType t ++ " *"- cppType (BaseT x)- | isToken x ctx = "String"- | otherwise = normCat x ++ " *"-- cppArg :: (String, Base) -> String- cppArg (x,t) = cppType t ++ " " ++ x ++ "_"-- cppExp :: Exp -> String- cppExp (App "[]" []) = "0"- cppExp (App x [])- | elem x xs = x ++ "_" -- argument- cppExp (App t [e])- | isToken t ctx = cppExp e- cppExp (App x es)- | isUpper (head x) = call ("new " ++ x) es- | otherwise = call (x ++ "_") es- cppExp (LitInt n) = show n- cppExp (LitDouble x) = show x- cppExp (LitChar c) = show c- cppExp (LitString s) = show s-- call x es = x ++ "(" ++ concat (intersperse ", " $ map cppExp es) ++ ")"-----This generates a parser method for each entry point.-parseMethod :: Maybe String -> String -> Cat -> String-parseMethod inPackage name cat = - -- if normCat cat /= cat M.F. 2004-09-17 comment. No duplicates from allCatsIdNorm- -- then ""- -- else - unlines- [- "static " ++ cat' ++ "*" +++ (resultName cat') +++ "= 0;",- cat' ++"* p" ++ cat' ++ "(FILE *inp)",- "{",- " " ++ ns ++ "yy_mylinenumber = 1;", -- O.F.- " " ++ ns ++ "initialize_lexer(inp);",- " if (yyparse())",- " { /* Failure */",- " return 0;",- " }",- " else",- " { /* Success */",- " return" +++ (resultName cat') ++ ";",- " }",- "}",- cat' ++"* p" ++ cat' ++ "(const char *str)",- "{",- " YY_BUFFER_STATE buf;",- " int result;",- " " ++ ns ++ "yy_mylinenumber = 1;",- " " ++ ns ++ "initialize_lexer(0);",- " buf = " ++ ns ++ "yy_scan_string(str);",- " result = yyparse();",- " " ++ ns ++ "yy_delete_buffer(buf);",- " if (result)",- " { /* Failure */",- " return 0;",- " }",- " else",- " { /* Success */",- " return" +++ (resultName cat') ++ ";",- " }",- "}"- ]- where- cat' = identCat (normCat cat)- ns = nsString inPackage-----The union declaration is special to Bison/Yacc and gives the type of yylval.---For efficiency, we may want to only include used categories here.-union :: Maybe String -> [Cat] -> String-union inPackage cats = unlines- [- "%union",- "{",- " int int_;",- " char char_;",- " double double_;",- " char* string_;",- concatMap mkPointer cats,- "}"- ]- where --This is a little weird because people can make [Exp2] etc.- mkPointer s | identCat s /= s = --list. add it even if it refers to a coercion.- " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n"- mkPointer s | normCat s == s = --normal cat- " " ++ scope ++ (identCat (normCat s)) ++ "*" +++ (varName (normCat s)) ++ ";\n"- mkPointer s = ""- scope = nsScope inPackage- ---declares non-terminal types.-declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (positionCats cf ++ allCats cf)- where --don't define internal rules- typeNT cf nt | (isPositionCat cf nt || rulesForCat cf nt /= []) = "%type <" ++ (varName (normCat nt)) ++ "> " ++ (identCat nt) ++ "\n"- typeNT cf nt = ""----declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user ts = concatMap (declTok user) ts- where- declTok u (s,r) = if elem s u- then "%token<string_> " ++ r ++ " // " ++ s ++ "\n"- else "%token " ++ r ++ " // " ++ s ++ "\n"--specialToks :: CF -> String-specialToks cf = concat [ - ifC "String" "%token<string_> _STRING_\n",- ifC "Char" "%token<char_> _CHAR_\n",- ifC "Integer" "%token<int_> _INTEGER_\n",- ifC "Double" "%token<double_> _DOUBLE_\n",- ifC "Ident" "%token<string_> _IDENT_\n"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForBison :: Bool -> Maybe String -> String -> CF -> SymEnv -> Rules-rulesForBison ln inPackage name cf env = (map mkOne $ ruleGroups cf) ++ posRules where- mkOne (cat,rules) = constructRule ln inPackage cf env rules cat- posRules = map mkPos $ positionCats cf- mkPos cat = (cat, [(maybe cat id (lookup cat env),- "$$ = new " ++ cat ++ "($1," ++ nsString inPackage ++ "yy_mylinenumber) ; YY_RESULT_" ++ - cat ++ "_= $$ ;")])---- For every non-terminal, we construct a set of rules.-constructRule :: - Bool -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule ln inPackage cf env rules nt = - (nt,[(p,(generateAction ln inPackage nt (ruleName r) b m) +++ result) | - r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf env r b])- where- ruleName r = case funRule r of- ---- "(:)" -> identCat nt- ---- "(:[])" -> identCat nt- z -> z- revs = reversibleCats cf- eps = allEntryPoints cf- isEntry nt = if elem nt eps then True else False- result = if isEntry nt then (nsScope inPackage ++ resultName (normCat (identCat nt))) ++ "= $$;" else ""---- Generates a string containing the semantic action.-generateAction :: Bool -> Maybe String -> NonTerminal -> Fun -> Bool -> [(MetaVar,Bool)] -> Action-generateAction ln inPackage cat f b mbs = - reverses ++- if isCoercion f - then "$$ = " ++ (unwords ms) ++ ";"- else if (f == "[]")- then concat ["$$ = ","new ", scope, identCatV cat, "();"]- else if (f == "(:[])")- then concat ["$$ = ","new ", scope, identCatV cat, "() ; $$->push_back($1);"]- else if (f == "(:)" && b)- then "$1->push_back("++ lastms ++ ") ; $$ = $1 ;"- else if (f == "(:)")- then lastms ++ "->push_back($1) ; $$ = " ++ lastms ++ " ;" ---- not left rec- else if isDefinedRule f- then concat ["$$ = ", scope, f, "_", "(", concat $ intersperse ", " ms', ");" ]- else concat - ["$$ = ", "new ", scope, f, "(", (concat (intersperse ", " ms')), ");" ++ addLn ln]- where- ms = map fst mbs- ms' = ms- addLn ln = if ln then " $$->line_number = " ++ nsString inPackage ++ "yy_mylinenumber;" else "" -- O.F.- lastms = last ms- identCatV cat = reverse $ dropWhile isDigit $ reverse $ identCat cat- reverses = unwords [- "std::reverse(" ++ m ++"->begin(),"++m++"->end()) ;" |- (m,True) <- mbs]- scope = nsScope inPackage---- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)])-generatePatterns cf env r revv = case rhsRule r of- [] -> ("/* empty */",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> case lookup c env of- Just x | not (isPositionCat cf c) -> x- _ -> typeName (identCat c)- Right s -> case lookup s env of- Just x -> x- Nothing -> s- metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its]-- -- notice: reversibility with push_back vectors is the opposite- -- of right-recursive lists!- revert c = (head c == '[') && - not (isConsFun (funRule r)) && notElem c revs - revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules [] = []-prRules ((nt, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', ":" , p, "{ ", a, "}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ ", a , "}"])]) ++ pr ls----Some helper functions.-resultName :: String -> String-resultName s = "YY_RESULT_" ++ s ++ "_"----slightly stronger than the NamedVariable version.-varName :: String -> String-varName s = (map toLower (identCat s)) ++ "_"--typeName :: String -> String-typeName "Ident" = "_IDENT_"-typeName "String" = "_STRING_"-typeName "Char" = "_CHAR_"-typeName "Integer" = "_INTEGER_"-typeName "Double" = "_DOUBLE_"-typeName x = x--
− src/formats/cpp_stl/CFtoCVisitSkelSTL.hs
@@ -1,148 +0,0 @@-{-- BNF Converter: C++ Skeleton generation- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C++ Skeleton functions.- - The generated files use the Visitor design pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 9 August, 2003 -- Modified : 29 August, 2006 Aarne Ranta-- - ************************************************************** --}--module CFtoCVisitSkelSTL (cf2CVisitSkel) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper)-import OOAbstract-import STLUtils----Produces (.H file, .C file)-cf2CVisitSkel :: Maybe String -> CF -> (String, String)-cf2CVisitSkel inPackage cf = (mkHFile inPackage cab, mkCFile inPackage cab)- where- cab = cf2cabs cf---- **** Header (.H) File Functions ****----Generates the Header File-mkHFile :: Maybe String -> CAbs -> String-mkHFile inPackage cf = unlines [- "#ifndef " ++ hdef,- "#define " ++ hdef,- "/* You might want to change the above name. */",- "",- "#include \"Absyn.H\"",- "",- nsStart inPackage,- "class Skeleton : public Visitor",- "{",- "public:",- unlines [" void visit" ++ b ++ "(" ++ b ++ "* p);" | - b <- classes, notElem b (defineds cf)],- unlines [" void visit" ++ b ++ "(" ++ b ++ " x);" | b <- basics],- "};",- nsEnd inPackage,- "",- "#endif"- ]- where- hdef = nsDefine inPackage "SKELETON_HEADER"- classes = allClasses cf- basics = tokentypes cf ++ map fst basetypes- ---- **** Implementation (.C) File Functions ****----Makes the .C File-mkCFile :: Maybe String -> CAbs -> String-mkCFile inPackage cf = unlines [ - headerC,- nsStart inPackage,- unlines [- "void Skeleton::visit" ++ t ++ "(" ++ - t ++ "* t) {} //abstract class" | t <- absclasses cf],- unlines [prCon r | (_,rs) <- signatures cf, r <- rs],- unlines [prList cb | cb <- listtypes cf],- unlines [prBasic b | b <- tokentypes cf ++ map fst basetypes],- nsEnd inPackage- ]--headerC = unlines [- "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",- "/* This implements the common visitor design pattern.",- " Note that this method uses Visitor-traversal of lists, so",- " List->accept() does NOT traverse the list. This allows different",- " algorithms to use context information differently. */",- "",- "#include \"Skeleton.H\"",- ""- ]--prBasic c = unlines [- "void Skeleton::visit" ++ c ++ "(" ++ c ++ " x)",- "{",- " /* Code for " ++ c ++ " Goes Here */",- "}"- ]--prList (cl,b) = unlines [- "void Skeleton::visit" ++ cl ++ "("++ cl ++ "*" +++ vname ++ ")",- "{",- " for ("++ cl ++"::iterator i = " ++- vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",- " {",- if b- then " (*i)->accept(this);"- else " visit" ++ drop 4 cl ++ "(*i) ;",- " }",- "}"- ]- where- vname = map toLower cl--prCon fcs@(f,cs) = unlines [- "void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")",- "{",- " /* Code For " ++ f ++ " Goes Here */",- "",- unlines [" " ++ visitArg c | c <- cs],- "}"- ]- where- v = map toLower f- visitArg (cat,isPt,var) = - if isPt - then (v ++ "->" ++ var ++ "->accept(this);")- else ("visit" ++ cat ++ "(" ++ v ++ "->" ++ var ++ ");")-
− src/formats/cpp_stl/CFtoSTLAbs.hs
@@ -1,275 +0,0 @@-{-- BNF Converter: C++ abstract syntax generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the C++ Abstract Syntax- tree classes. It generates both a Header file- and an Implementation file, and uses the Visitor- design pattern. It uses STL (Standard Template Library).-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 4 August, 2003 -- Modified : 22 May, 2004 / Antti-Juhani Kaijanaho- 29 August, 2006 / Aarne Ranta- - ************************************************************** --}--module CFtoSTLAbs (cf2CPPAbs) where--import OOAbstract-import CF-import Utils((+++),(++++))-import NamedVariables-import Data.List-import Data.Char(toLower)-import STLUtils----The result is two files (.H file, .C file)--cf2CPPAbs :: Bool -> Maybe String -> String -> CF -> (String, String)-cf2CPPAbs ln inPackage name cf = (mkHFile ln inPackage cab, mkCFile inPackage cab)- where- cab = cf2cabs cf----- **** Header (.H) File Functions **** ------Makes the Header file.-mkHFile :: Bool -> Maybe String -> CAbs -> String-mkHFile ln inPackage cf = unlines- [- "#ifndef " ++ hdef,- "#define " ++ hdef,- "",- "#include<string>",- "#include<vector>",- "",- "//C++ Abstract Syntax Interface generated by the BNF Converter.",- nsStart inPackage,- "/******************** TypeDef Section ********************/",- "",- unlines ["typedef " ++ d ++ " " ++ c ++ ";" | (c,d) <- basetypes],- "",- unlines ["typedef std::string " ++ s ++ ";" | s <- tokentypes cf], - "",- "/******************** Forward Declarations ********************/",- "",- unlines ["class " ++ c ++ ";" | c <- classes, notElem c (defineds cf)],- "",- "/******************** Visitor Interfaces ********************/",- prVisitor cf,- "",- prVisitable,- "",- "/******************** Abstract Syntax Classes ********************/",- "",- unlines [prAbs ln c | c <- absclasses cf],- "",- unlines [prCon (c,r) | (c,rs) <- signatures cf, r <- rs],- "",- unlines [prList c | c <- listtypes cf],- nsEnd inPackage,- "#endif"- ]- where- classes = allClasses cf- hdef = nsDefine inPackage "ABSYN_HEADER"---- auxiliaries--prVisitable :: String-prVisitable = unlines [- "class Visitable",- "{",- " public:",- -- all classes with virtual methods require a virtual destructor- " virtual ~Visitable() {}",- " virtual void accept(Visitor *v) = 0;",- "};"- ]--prVisitor :: CAbs -> String-prVisitor cf = unlines [- "class Visitor",- "{",- "public:",- " virtual ~Visitor() {}",- unlines - [" virtual void visit"++c++"("++c++" *p) = 0;" | c <- allClasses cf, - notElem c (defineds cf)],- "",- unlines - [" virtual void visit"++c++"(" ++c++" x) = 0;" | c <- allNonClasses cf],- "};"- ]--prAbs :: Bool -> Cat -> String-prAbs ln c = unlines [- "class " ++c++ " : public Visitable",- "{",- "public:",- " virtual " ++ c ++ " *clone() const = 0;",- if ln then " int line_number;" else "",- "};"- ]--prCon :: (Cat,CAbsRule) -> String-prCon (c,(f,cs)) = unlines [- "class " ++f++ " : public " ++ c,- "{",- "public:",- unlines - [" "++ typ +++ pointerIf st var ++ ";" | (typ,st,var) <- cs],- " " ++ f ++ "(const " ++ f ++ " &);",- " " ++ f ++ " &operator=(const " ++f++ " &);",- " " ++ f ++ "(" ++ conargs ++ ");",- -- Typ *p1, PIdent *p2, ListStm *p3);- " ~" ++f ++ "();",- " virtual void accept(Visitor *v);",- " virtual " ++f++ " *clone() const;",- " void swap(" ++f++ " &);",- "};"- ]- where- conargs = concat $ intersperse ", " - [x +++ pointerIf st ("p" ++ show i) | ((x,st,_),i) <- zip cs [1..]]--prList :: (Cat,Bool) -> String-prList (c,b) = unlines [- "class " ++c++ " : public Visitable, public std::vector<" ++bas++ ">",- "{",- "public:",- " virtual void accept(Visitor *v);",- " virtual " ++ c ++ " *clone() const;",- "};"- ]- where - bas = drop 4 c ++ -- drop List- if b then "*" else ""----- **** Implementation (.C) File Functions **** ----mkCFile :: Maybe String -> CAbs -> String-mkCFile inPackage cf = unlines $ [- "//C++ Abstract Syntax Implementation generated by the BNF Converter.",- "#include <algorithm>",- "#include <string>",- "#include <iostream>",- "#include <vector>",- "#include \"Absyn.H\"",- nsStart inPackage,- unlines [prConC r | (_,rs) <- signatures cf, r <- rs],- unlines [prListC c | (c,_) <- listtypes cf],- nsEnd inPackage- ]--prConC :: CAbsRule -> String-prConC fcs@(f,cs) = unlines [- "/******************** " ++ f ++ " ********************/",- prConstructorC fcs,- prCopyC fcs,- prDestructorC fcs,- prAcceptC f,- prCloneC f,- ""- ]--prListC :: Cat -> String-prListC c = unlines [- "/******************** " ++ c ++ " ********************/",- "",- prAcceptC c,- "",- prCloneC c- ]-----The standard accept function for the Visitor pattern-prAcceptC :: Cat -> String-prAcceptC ty = unlines [- "void " ++ ty ++ "::accept(Visitor *v)",- "{", - " v->visit" ++ ty ++ "(this);",- "}"- ]----The cloner makes a new deep copy of the object-prCloneC :: Cat -> String-prCloneC c = unlines [- c +++ "*" ++ c ++ "::clone() const", - "{",- " return new" +++ c ++ "(*this);",- "}"- ]----The constructor assigns the parameters to the corresponding instance variables.-prConstructorC :: CAbsRule -> String-prConstructorC (f,cs) = unlines [- f ++ "::" ++ f ++ "(" ++ conargs ++ ")",- "{",- unlines [" " ++ c ++ " = " ++ p ++ ";" | (c,p) <- zip cvs pvs],- "}"- ]- where- cvs = [c | (_,_,c) <- cs]- pvs = ["p" ++ show i | ((x,st,_),i) <- zip cs [1..]]- conargs = concat $ intersperse ", " - [x +++ pointerIf st v | ((x,st,_),v) <- zip cs pvs]-----Copy constructor and copy assignment-prCopyC :: CAbsRule -> String-prCopyC (c,cs) = unlines [- c ++ "::" ++ c ++ "(const" +++ c +++ "& other)",- "{",- unlines [" " ++ cv ++ " = other." ++ cloneIf st cv ++ ";" | (_,st,cv) <- cs],- "}",- "",- c +++ "&" ++ c ++ "::" ++ "operator=(const" +++ c +++ "& other)", - "{",- " " ++ c +++ "tmp(other);",- " swap(tmp);",- " return *this;",- "}",- "",- "void" +++ c ++ "::swap(" ++ c +++ "& other)", - "{",- unlines [" std::swap(" ++ cv ++ ", other." ++ cv ++ ");" | (_,_,cv) <- cs],- "}"- ]- where- cloneIf st cv = if st then (cv ++ "->clone()") else cv----The destructor deletes all a class's members.-prDestructorC :: CAbsRule -> String-prDestructorC (c,cs) = unlines [ - c ++ "::~" ++ c ++"()",- "{",- unlines [" delete(" ++ cv ++ ");" | (_,isPointer,cv) <- cs, isPointer],- "}"- ]
− src/formats/cpp_stl/CFtoSTLPrinter.hs
@@ -1,658 +0,0 @@-{- - **************************************************************- BNF Converter Module-- Description : This module generates the C++ Pretty Printer.- It also generates the "show" method for- printing an abstract syntax tree.- - The generated files use the Visitor design pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 10 August, 2003 -- Modified : 3 September, 2003 - * Added resizable buffers- - ************************************************************** --}--module CFtoSTLPrinter (cf2CPPPrinter) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper)-import STLUtils----Produces (.H file, .C file)-cf2CPPPrinter :: Maybe String -> CF -> (String, String)-cf2CPPPrinter inPackage cf = (mkHFile inPackage cf groups, mkCFile inPackage cf groups)- where- groups = positionRules cf ++ (fixCoercions (ruleGroupsInternals cf))- -positionRules :: CF -> [(Cat,[Rule])]-positionRules cf = - [(cat,[Rule cat cat [Left "String", Left "Integer"]]) | - cat <- filter (isPositionCat cf) $ fst (unzip (tokenPragmas cf))]--{- **** Header (.H) File Methods **** -}----An extremely large function to make the Header File-mkHFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String-mkHFile inPackage cf groups = unlines- [- printHeader,- concatMap prDataH groups,- classFooter,- showHeader,- concatMap prDataH groups,- classFooter,- footer- ]- where- printHeader = unlines- [- "#ifndef " ++ hdef,- "#define " ++ hdef,- "",- "#include \"Absyn.H\"",- "#include <stdio.h>",- "#include <string.h>",- "#include <stdlib.h>",- "",- nsStart inPackage,- "/* Certain applications may improve performance by changing the buffer size */",- "#define " ++ nsDefine inPackage "BUFFER_INITIAL" ++ " 2000",- "/* You may wish to change _L_PAREN or _R_PAREN */",- "#define " ++ nsDefine inPackage "_L_PAREN" ++ " '('",- "#define " ++ nsDefine inPackage "_R_PAREN" ++ " ')'",- "",- "class PrintAbsyn : public Visitor",- "{",- " protected:",- " int _n_, _i_;",- " /* The following are simple heuristics for rendering terminals */",- " /* You may wish to change them */",- " void render(Char c);",- " void render(String s);",- " void indent(void);",- " void backup(void);",- " public:",- " PrintAbsyn(void);",- " ~PrintAbsyn(void);",- " char* print(Visitable* v);"- ]- hdef = nsDefine inPackage "PRINTER_HEADER"- classFooter = unlines $- [- " void visitInteger(Integer i);",- " void visitDouble(Double d);",- " void visitChar(Char c);",- " void visitString(String s);",- " void visitIdent(String s);"- ] ++ [" void visit" ++ t ++ "(String s);" | t <- tokenNames cf] ++- [- " protected:",- " void inline bufAppend(const char* s)",- " {",- " int len = strlen(s);",- " while (cur_ + len > buf_size)",- " {",- " buf_size *= 2; /* Double the buffer size */",- " resizeBuffer();",- " }",- " for(int n = 0; n < len; n++)",- " {",- " buf_[cur_ + n] = s[n];",- " }",- " cur_ += len;",- " buf_[cur_] = 0;",- " }",- " void inline bufAppend(const char c)",- " {",- " if (cur_ == buf_size)",- " {",- " buf_size *= 2; /* Double the buffer size */",- " resizeBuffer();",- " }",- " buf_[cur_] = c;",- " cur_++;",- " buf_[cur_] = 0;",- " }",- " void inline bufReset(void)",- " {",- " cur_ = 0;",- " buf_size = " ++ nsDefine inPackage "BUFFER_INITIAL" ++ ";",- " resizeBuffer();",- " memset(buf_, 0, buf_size);",- " }",- " void inline resizeBuffer(void)",- " {",- " char* temp = (char*) malloc(buf_size);",- " if (!temp)",- " {",- " fprintf(stderr, \"Error: Out of memory while attempting to grow buffer!\\n\");",- " exit(1);",- " }",- " if (buf_)",- " {",- " strcpy(temp, buf_);",- " free(buf_);",- " }",- " buf_ = temp;",- " }",- " char *buf_;",- " int cur_, buf_size;",- "};",- ""- ]- showHeader = unlines- [- "",- "class ShowAbsyn : public Visitor",- "{",- " public:",- " ShowAbsyn(void);",- " ~ShowAbsyn(void);",- " char* show(Visitable* v);"- ]- footer = unlines- [- nsEnd inPackage,- "",- "#endif"- ]----Prints all the required method names and their parameters.-prDataH :: (Cat, [Rule]) -> String-prDataH (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then concat [" void visit", cl, "(", cl, "* p);\n"]- else abstract ++ (concatMap prRuleH rules)- where- cl = identCat (normCat cat)- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n"----Prints all the methods to visit a rule.-prRuleH :: Rule -> String-prRuleH (Rule fun c cats) | isProperLabel fun = concat- [" void visit", fun, "(", fun, " *p);\n"]-prRuleH _ = ""--{- **** Implementation (.C) File Methods **** -}----This makes the .C file by a similar method.-mkCFile :: Maybe String -> CF -> [(Cat,[Rule])] -> String-mkCFile inPackage cf groups = concat - [- header,- nsStart inPackage ++ "\n",- prRender,- printEntries,- concatMap (prPrintData inPackage cf user) groups,- printBasics,- printTokens,- showEntries,- concatMap (prShowData user) groups,- showBasics,- showTokens,- nsEnd inPackage ++ "\n"- ]- where- user0 = fst (unzip (tokenPragmas cf))- (userPos,user) = partition (isPositionCat cf) user0- header = unlines - [- "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/",- "",- "#include <string>",- "#include \"Printer.H\"",- ""- ]- printEntries = unlines- [- "PrintAbsyn::PrintAbsyn(void)",- "{",- " _i_ = 0; _n_ = 0;",- " buf_ = 0;",- " bufReset();",- "}",- "",- "PrintAbsyn::~PrintAbsyn(void)",- "{",- "}",- "",- "char* PrintAbsyn::print(Visitable *v)",- "{",- " _i_ = 0; _n_ = 0;",- " bufReset();",- " v->accept(this);",- " return buf_;",- "}"- ]- showEntries = unlines- [- "ShowAbsyn::ShowAbsyn(void)",- "{",- " buf_ = 0;",- " bufReset();",- "}",- "",- "ShowAbsyn::~ShowAbsyn(void)",- "{",- "}",- "",- "char* ShowAbsyn::show(Visitable *v)",- "{",- " bufReset();",- " v->accept(this);",- " return buf_;",- "}"- ]- printBasics = unlines - [- "void PrintAbsyn::visitInteger(Integer i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%d\", i);",- " bufAppend(tmp);",- "}",- "void PrintAbsyn::visitDouble(Double d)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppend(tmp);",- "}",- "void PrintAbsyn::visitChar(Char c)",- "{",- " bufAppend('\\'');",- " bufAppend(c);",- " bufAppend('\\'');",- "}",- "void PrintAbsyn::visitString(String s_)",- "{",- " const char *s = s_.c_str() ;",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- "void PrintAbsyn::visitIdent(String s_)",- "{",- " const char *s = s_.c_str() ;",- " render(s);",- "}",- ""- ]-- printTokens = unlines - [unlines [- "void PrintAbsyn::visit" ++ t ++ "(String s_)",- "{",- " const char *s = s_.c_str() ;",- " render(s);",- "}",- ""- ] | t <- tokenNames cf- ]-- showBasics = unlines - [- "void ShowAbsyn::visitInteger(Integer i)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%d\", i);",- " bufAppend(tmp);",- "}",- "void ShowAbsyn::visitDouble(Double d)",- "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppend(tmp);",- "}",- "void ShowAbsyn::visitChar(Char c)",- "{",- " bufAppend('\\'');",- " bufAppend(c);",- " bufAppend('\\'');",- "}",- "void ShowAbsyn::visitString(String s_)",- "{",- " const char *s = s_.c_str() ;",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- "void ShowAbsyn::visitIdent(String s_)",- "{",- " const char *s = s_.c_str() ;",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- ""- ]-- showTokens = unlines - [unlines [- "void ShowAbsyn::visit" ++ t ++ "(String s_)",- "{",- " const char *s = s_.c_str() ;",- " bufAppend('\\\"');",- " bufAppend(s);",- " bufAppend('\\\"');",- "}",- ""- ] | t <- tokenNames cf- ]---{- **** Pretty Printer Methods **** -}----Generates methods for the Pretty Printer-prPrintData :: Maybe String -> CF -> [UserDef] -> (Cat, [Rule]) -> String-prPrintData inPackage cf user (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then unlines- [- "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",- "{",- " for ("++ cl ++"::const_iterator i = " ++- vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",- " {",- if isBase user vname- then " visit" ++ baseName cl ++ "(*i) ;"- else " (*i)->accept(this);",- optsep,- " }",- "}",- ""- ] --Not a list:- -- a position token- else if isPositionCat cf cat then unlines [- "void PrintAbsyn::visit" ++ cat ++ "(" ++ cat ++ "* p)",- "{",- " visitIdent(p->string_);",- "}"- ]- else abstract ++ (concatMap (prPrintRule inPackage user) rules)- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl ++ "_"- visitMember = if isBasic user member- then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"- sep = if (length sep') == 1- then "'" ++ (escapeChars sep') ++ "'"- else "\"" ++ (escapeChars sep') ++ "\""- sep' = getCons rules- optsep = - (if hasOneFunc rules - then " if (i != " ++ vname ++ "->end() - 1) " - else " " - ) ++ "render(" ++ sep ++ ");"- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl ++ "*p) {} //abstract class\n\n"- ---Pretty Printer methods for a rule.-prPrintRule :: Maybe String -> [UserDef] -> Rule -> String-prPrintRule inPackage user r@(Rule fun c cats) | isProperLabel fun = unlines- [- "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")",- "{",- " int oldi = _i_;",- lparen,- cats',- rparen,- " _i_ = oldi;",- "}\n"- ]- where- p = precRule r- (lparen, rparen) = - (" if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_L_PAREN" ++ ");\n",- " if (oldi > " ++ (show p) ++ ") render(" ++ nsDefine inPackage "_R_PAREN" ++ ");\n")- cats' = (concatMap (prPrintCat user fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats)))- fnm = "p" --old names could cause conflicts- getPrec (Right s) = 0- getPrec (Left c) = precCat c-prPrintRule _ _ _ = ""----This goes on to recurse to the instance variables.-prPrintCat :: [UserDef] -> String -> (Either Cat String, Int) -> String-prPrintCat user fnm (c,p) = case c of- (Right t) -> " render(" ++ t' ++ ");\n"- where- t' = if length t == 1- then "'" ++ (escapeChars t) ++ "'"- else "\"" ++ (escapeChars t) ++ "\""- (Left nt) -> if isBasic user nt- then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"- else if "list" `isPrefixOf` nt- then " if(" ++ fnm ++ "->" ++ nt ++ ") {" ++ accept ++ "}"- else " " ++ accept ++ "\n"- where- accept = if nt == "#_" --Internal category- then "/* Internal Category */\n"- else (setI p) ++ fnm ++ "->" ++ nt ++ "->accept(this);"--{- **** Abstract Syntax Tree Printer **** -}----This prints the functions for Abstract Syntax tree printing.-prShowData :: [UserDef] -> (Cat, [Rule]) -> String-prShowData user (cat, rules) = - if "List" `isPrefixOf` (identCat cat)- then unlines- [- "void ShowAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")",- "{",- " for ("++ cl ++"::const_iterator i = " ++- vname++"->begin() ; i != " ++vname ++"->end() ; ++i)",- " {",- if isBase user vname- then " visit" ++ baseName cl ++ "(*i) ;"- else " (*i)->accept(this);",- " if (i != " ++ vname ++ "->end() - 1) bufAppend(\", \");",- " }",- "}",- ""- ] --Not a list:- else abstract ++ (concatMap (prShowRule user) rules)- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl ++ "_"- visitMember = if isBasic user member- then " visit" ++ (funName member) ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ "* p) {} //abstract class\n\n"----This prints all the methods for Abstract Syntax tree rules.-prShowRule :: [UserDef] -> Rule -> String-prShowRule user (Rule fun c cats) | isProperLabel fun = concat- [- "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun ++ "*" +++ fnm ++ ")\n",- "{\n",- lparen,- " bufAppend(\"" ++ fun ++ "\");\n",- optspace,- cats',- rparen,- "}\n"- ]- where- (optspace, lparen, rparen) = if allTerms cats- then ("","","")- else (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n")- cats' = if allTerms cats- then ""- else concat (insertSpaces (map (prShowCat user fnm) (fixOnes (numVars [] cats))))- insertSpaces [] = []- insertSpaces (x:[]) = [x]- insertSpaces (x:xs) = if x == "" - then insertSpaces xs- else (x : [" bufAppend(' ');\n"]) ++ (insertSpaces xs)- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- fnm = "p" --other names could cause conflicts-prShowRule _ _ = ""----This recurses to the instance variables of a class.-prShowCat :: [UserDef] -> String -> Either Cat String -> String-prShowCat user fnm c = - case c of- (Right t) -> ""- (Left nt) -> - if isBasic user nt- then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "->" ++ nt ++ ");\n"- else if nt == "#_" --internal category- then "/* Internal Category */\n"- else if ((normCat nt) /= nt)- then accept- else concat- [- " bufAppend('[');\n",- " if (" ++ fnm ++ "->" ++ nt ++ ")" ++ accept,- " bufAppend(']');\n"- ]- where- accept = " " ++ fnm ++ "->" ++ nt ++ "->accept(this);\n"--{- **** Helper Functions Section **** -}-----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user---- from listident to ident_-isBase user vn = isBasic user (baseName vn ++ "_")--- from ListIdent to Ident-baseName cl = drop 4 cl -----The visit-function name of a basic type-funName :: String -> String-funName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else "Ident" --User-defined type----Just sets the coercion level for parentheses in the Pretty Printer.-setI :: Int -> String-setI n = "_i_ = " ++ (show n) ++ "; "----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)- ---An extremely simple renderer for terminals.-prRender :: String-prRender = unlines- [- "//You may wish to change render",- "void PrintAbsyn::render(Char c)",- "{",- " if (c == '{')",- " {",- " bufAppend('\\n');",- " indent();",- " bufAppend(c);",- " _n_ = _n_ + 2;",- " bufAppend('\\n');",- " indent();",- " }",- " else if (c == '(' || c == '[')",- " bufAppend(c);",- " else if (c == ')' || c == ']')",- " {",- " backup();",- " bufAppend(c);",- " bufAppend(' ');",- " }",- " else if (c == '}')",- " {",- " _n_ = _n_ - 2;",- " backup();",- " backup();",- " bufAppend(c);",- " bufAppend('\\n\');",- " indent();",- " }",- " else if (c == ',')",- " {",- " backup();",- " bufAppend(c);",- " bufAppend(' ');",- " }",- " else if (c == ';')",- " {",- " backup();",- " bufAppend(c);",- " bufAppend('\\n');",- " indent();",- " }",- " else if (c == 0) return;",- " else",- " {",- " bufAppend(c);",- " bufAppend(' ');",- " }",- "}",- "void PrintAbsyn::render(String s_)",- "{",- " const char *s = s_.c_str() ;",- " if(strlen(s) > 0)",- " {",- " bufAppend(s);",- " bufAppend(' ');",- " }",- "}",- "void PrintAbsyn::indent()",- "{",- " int n = _n_;",- " while (n > 0)",- " {",- " bufAppend(' ');",- " n--;",- " }",- "}",- "void PrintAbsyn::backup()",- "{",- " if (buf_[cur_ - 1] == ' ')",- " {", - " buf_[cur_ - 1] = 0;",- " cur_--;",- " }",- "}"- ]
− src/formats/cpp_stl/STLTop.hs
@@ -1,216 +0,0 @@-{-- BNF Converter: C++ Main file- Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer-- Modified from CPPTop to STLTop 2006 by Aarne Ranta.-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module STLTop (makeSTL) where--import Utils-import CF-import CFtoSTLAbs-import CFtoFlex-import CFtoBisonSTL-import CFtoCVisitSkelSTL-import CFtoSTLPrinter-import CFtoLatex-import System.Exit (exitFailure)-import Data.Char-import STLUtils--makeSTL :: Bool -> Bool -> Maybe String -> String -> CF -> IO ()-makeSTL make linenumbers inPackage name cf = do- let (hfile, cfile) = cf2CPPAbs linenumbers inPackage name cf- writeFileRep "Absyn.H" hfile- writeFileRep "Absyn.C" cfile- let (flex, env) = cf2flex inPackage name cf- writeFileRep (name ++ ".l") flex- putStrLn " (Tested with flex 2.5.31)"- let bison = cf2Bison linenumbers inPackage name cf env- writeFileRep (name ++ ".y") bison- putStrLn " (Tested with bison 1.875a)"- let header = mkHeaderFile inPackage cf (allCats cf) (allEntryPoints cf) env- writeFileRep "Parser.H" header- let (skelH, skelC) = cf2CVisitSkel inPackage cf- writeFileRep "Skeleton.H" skelH- writeFileRep "Skeleton.C" skelC- let (prinH, prinC) = cf2CPPPrinter inPackage cf- writeFileRep "Printer.H" prinH- writeFileRep "Printer.C" prinC- writeFileRep "Test.C" (cpptest inPackage cf)- let latex = cfToLatex name cf- writeFileRep (name ++ ".tex") latex- if make then (writeFileRep "Makefile" $ makefile name) else return ()--makefile :: String -> String-makefile name = unlines - [- "CC = g++",- "CCFLAGS = -g",- "FLEX = flex",- "BISON = bison",- "LATEX = latex",- "DVIPS = dvips",- "",- "all: Test" ++ name ++ " " ++ name ++ ".ps",- "",- "clean:",- -- peteg: don't nuke what we generated - move that to the "vclean" target.- "\trm -f *.o " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name,- "",- "distclean:",- "\t rm -f *.o Absyn.C Absyn.H Test.C Parser.C Parser.H Lexer.C Skeleton.C Skeleton.H Printer.C Printer.H " ++ name ++ ".l " ++ name ++ ".y " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps Test" ++ name ++ " Makefile",- "",- "Test" ++ name ++ ": Absyn.o Lexer.o Parser.o Printer.o Test.o",- "\t@echo \"Linking Test" ++ name ++ "...\"",- "\t${CC} ${CCFLAGS} *.o -o Test" ++ name ++ "",- " ",- "Absyn.o: Absyn.C Absyn.H",- "\t${CC} ${CCFLAGS} -c Absyn.C",- "",- "Lexer.C: " ++ name ++ ".l",- "\t${FLEX} -oLexer.C " ++ name ++ ".l",- "",- "Parser.C: " ++ name ++ ".y",- "\t${BISON} " ++ name ++ ".y -o Parser.C",- "",- "Lexer.o: Lexer.C Parser.H",- "\t${CC} ${CCFLAGS} -c Lexer.C ",- "",- "Parser.o: Parser.C Absyn.H",- "\t${CC} ${CCFLAGS} -c Parser.C",- "",- "Printer.o: Printer.C Printer.H Absyn.H",- "\t${CC} ${CCFLAGS} -c Printer.C",- "",- "Skeleton.o: Skeleton.C Skeleton.H Absyn.H",- "\t${CC} ${CCFLAGS} -c Skeleton.C",- "",- "Test.o: Test.C Parser.H Printer.H Absyn.H",- "\t${CC} ${CCFLAGS} -c Test.C",- "",- "" ++ name ++ ".dvi: " ++ name ++ ".tex",- "\t${LATEX} " ++ name ++ ".tex",- "",- "" ++ name ++ ".ps: " ++ name ++ ".dvi",- "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps",- ""- ]- -cpptest :: Maybe String -> CF -> String-cpptest inPackage cf =- unlines- [- "/*** Compiler Front-End Test automatically generated by the BNF Converter ***/",- "/* */",- "/* This test will parse a file, print the abstract syntax tree, and then */",- "/* pretty-print the result. */",- "/* */",- "/****************************************************************************/",- "#include <stdio.h>",- "#include \"Parser.H\"",- "#include \"Printer.H\"",- "#include \"Absyn.H\"",- "",- "int main(int argc, char ** argv)",- "{",- " FILE *input;",- " if (argc > 1) ",- " {",- " input = fopen(argv[1], \"r\");",- " if (!input)",- " {",- " fprintf(stderr, \"Error opening input file.\\n\");",- " exit(1);",- " }",- " }",- " else input = stdin;",- " /* The default entry point is used. For other options see Parser.H */",- " " ++ scope ++ def ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);",- " if (parse_tree)",- " {",- " printf(\"\\nParse Succesful!\\n\");",- " printf(\"\\n[Abstract Syntax]\\n\");",- " " ++ scope ++ "ShowAbsyn *s = new " ++ scope ++ "ShowAbsyn();",- " printf(\"%s\\n\\n\", s->show(parse_tree));",- " printf(\"[Linearized Tree]\\n\");",- " " ++ scope ++ "PrintAbsyn *p = new " ++ scope ++ "PrintAbsyn();",- " printf(\"%s\\n\\n\", p->print(parse_tree));",- " return 0;",- " }",- " return 1;",- "}",- ""- ]- where- def = head (allEntryPoints cf)- scope = nsScope inPackage--mkHeaderFile inPackage cf cats eps env = unlines- [- "#ifndef " ++ hdef,- "#define " ++ hdef,- "",- "#include<vector>",- "#include<string>",- "",- nsStart inPackage,- concatMap mkForwardDec cats,- "typedef union",- "{",- " int int_;",- " char char_;",- " double double_;",- " char* string_;",- (concatMap mkVar cats) ++ "} YYSTYPE;",- "",- concatMap mkFuncs eps,- nsEnd inPackage,- "",- "#define " ++ nsDefine inPackage "_ERROR_" ++ " 258",- mkDefines (259 :: Int) env,- "extern " ++ nsScope inPackage ++ "YYSTYPE " ++ nsString inPackage ++ "yylval;",- "",- "#endif"- ]- where- hdef = nsDefine inPackage "PARSER_HEADER_FILE"- mkForwardDec s | (normCat s == s) = "class " ++ (identCat s) ++ ";\n"- mkForwardDec _ = ""- mkVar s | (normCat s == s) = " " ++ (identCat s) ++"*" +++ (map toLower (identCat s)) ++ "_;\n"- mkVar _ = ""- mkDefines n [] = mkString n- mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) -- "nsDefine inPackage s" not needed (see cf2flex::makeSymEnv)- mkString n = if isUsedCat cf "String" - then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1)- else mkChar n- mkChar n = if isUsedCat cf "Char" - then ("#define " ++ nsDefine inPackage "_CHAR_ " ++ show n ++ "\n") ++ mkInteger (n+1)- else mkInteger n- mkInteger n = if isUsedCat cf "Integer" - then ("#define " ++ nsDefine inPackage "_INTEGER_ " ++ show n ++ "\n") ++ mkDouble (n+1)- else mkDouble n- mkDouble n = if isUsedCat cf "Double" - then ("#define " ++ nsDefine inPackage "_DOUBLE_ " ++ show n ++ "\n") ++ mkIdent(n+1)- else mkIdent n- mkIdent n = if isUsedCat cf "Ident" - then ("#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n")- else ""- mkFuncs s | (normCat s == s) = (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(FILE *inp);\n" ++- (identCat s) ++ "*" +++ "p" ++ (identCat s) ++ "(const char *str);\n"- mkFuncs _ = ""
− src/formats/cpp_stl/STLUtils.hs
@@ -1,37 +0,0 @@-{-- BNF Converter: C++ common functions- Copyright (C) 2008 Author: Martin Ejdestig-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module STLUtils where--import Data.Char--nsDefine :: Maybe String -> String -> String-nsDefine inPackage h = maybe h (\ns -> map toUpper ns ++ "_" ++ h) inPackage--nsStart :: Maybe String -> String-nsStart inPackage = maybe "" (\ns -> "namespace " ++ ns ++ "\n{") inPackage--nsEnd :: Maybe String -> String-nsEnd inPackage = maybe "" (\ns -> "}") inPackage--nsScope :: Maybe String -> String-nsScope inPackage = maybe "" (\ns -> ns ++ "::") inPackage--nsString :: Maybe String -> String-nsString inPackage = maybe "" id inPackage
− src/formats/f-sharp/FSharpTop.hs
@@ -1,188 +0,0 @@-{-- BNF Converter: F# main file- Copyright (C) 2005 Author: Kristofer Johannisson- Copyright (C) 2007 Author: Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- based on BNFC O'Caml backend---module FSharpTop (makeFSharp) where --import CF-import CFtoOCamlYacc-import CFtoOCamlLex-import CFtoLatex-import CFtoOCamlAbs-import CFtoOCamlTemplate-import CFtoOCamlPrinter-import CFtoOCamlShow-import CFtoOCamlTest-import CFtoXML-import Utils-import Options--import Data.Char-import Data.Maybe (fromMaybe,maybe)-import System.Exit (exitFailure)-import Control.Monad(when)---- naming conventions--noLang :: Options -> String -> String-noLang _ name = name--withLang :: Options -> String -> String-withLang opts name = name ++ lang opts--mkMod :: (Options -> String -> String) -> String -> Options -> String-mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name- where pref = maybe "" (++".") (inPackage opts)--mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath-mkFile addLang name ext opts = - pref ++ if inDir opts- then lang opts ++ [pathSep] ++ name ++ ext'- else addLang opts name ++ if null ext then "" else ext'- where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts)- ext' = if null ext then "" else "." ++ ext--absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile,- ocamlyaccFile, ocamlyaccFileM,- latexFile, utilFile, utilFileM,- templateFile, templateFileM, - printerFile, printerFileM,- psFile, tFile, tFileM :: Options -> String-absFile = mkFile withLang "Abs" "ml"-absFileM = mkMod withLang "Abs" -ocamllexFile = mkFile withLang "Lex" "mll"-ocamllexFileM = mkMod withLang "Lex"-ocamlyaccFile = mkFile withLang "Par" "mly"-ocamlyaccFileM = mkMod withLang "Par"-latexFile = mkFile withLang "Doc" "tex"-templateFile = mkFile withLang "Skel" "ml"-templateFileM = mkMod withLang "Skel"-printerFile = mkFile withLang "Print" "ml"-printerFileM = mkMod withLang "Print"-showFile = mkFile withLang "Show" "ml"-showFileM = mkMod withLang "Show"-dviFile = mkFile withLang "Doc" "dvi"-psFile = mkFile withLang "Doc" "ps"-tFile = mkFile withLang "Test" "ml"-tFileM = mkMod withLang "Test"-utilFile = mkFile noLang "BNFC_Util" "ml"-utilFileM = mkMod noLang "BNFC_Util"-xmlFileM = mkMod withLang "XML"--type Options = SharedOptions--makeFSharp :: Options -> CF -> IO ()-makeFSharp opts cf = do- let absMod = absFileM opts- lexMod = ocamllexFileM opts- parMod = ocamlyaccFileM opts- prMod = printerFileM opts- showMod = showFileM opts--- layMod = layoutFileM opts- utilMod = utilFileM opts- do- let dir = codeDir opts- when (not (null dir)) $ do- putStrLn $ "Creating directory " ++ dir- prepareDir dir- writeFileRep (absFile opts) $ cf2Abstract absMod cf- writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf- writeFileRep (ocamlyaccFile opts) $ - cf2ocamlyacc parMod absMod lexMod cf- writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf- writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf- writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf- writeFileRep (showFile opts) $ cf2show showMod absMod cf- writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf- writeFileRep (utilFile opts) $ utilM - when (make opts) $ writeFileRep "Makefile" $ makefile opts- case xml opts of- 2 -> makeXML (lang opts) True cf- 1 -> makeXML (lang opts) False cf- _ -> return ()--pkgToDir :: String -> FilePath-pkgToDir s = replace '.' pathSep s--codeDir :: Options -> FilePath-codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)- dir = if inDir opts then lang opts else ""- sep = if null pref || null dir then "" else [pathSep]- in pref ++ sep ++ dir --makefile :: Options -> String-makefile opts = makeA where- dir = let d = codeDir opts in if null d then "" else d ++ [pathSep]- cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")"- makeA = unlines - [- "all:",- "\tfsyacc " ++ ocamlyaccFile opts, - "\tfslex " ++ ocamllexFile opts,- "\t" ++ cd ("latex " ++ basename (latexFile opts)- ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)),- "\tfsc -o " ++ mkFile withLang "Test" "exe" opts +++- utilFile opts +++- absFile opts +++ templateFile opts +++- showFile opts +++ printerFile opts +++- mkFile withLang "Par" "mli" opts +++- mkFile withLang "Par" "ml" opts +++- mkFile withLang "Lex" "fs" opts +++- tFile opts, - "",- "clean:",- "\t-rm -f " ++ unwords (map (dir++) [- "*.log", "*.aux", "*.cmi", - "*.cmo", "*.o", "*.dvi"- ]),- "\t-rm -f " ++ psFile opts,- "",- "distclean: clean",- "\t-rm -f " ++ unwords [- mkFile withLang "Doc" "*" opts,- mkFile withLang "Lex" "*" opts,- mkFile withLang "Par" "*" opts,- mkFile withLang "Layout" "*" opts,- mkFile withLang "Skel" "*" opts,- mkFile withLang "Print" "*" opts,- mkFile withLang "Show" "*" opts,- mkFile withLang "Test" "*" opts,- mkFile withLang "Abs" "*" opts,- mkFile withLang "Test" "" opts,- utilFile opts,- "Makefile*"- ]- ]---utilM :: String-utilM = unlines - ["(* automatically generated by BNFC *)",- "",- "open Lexing",- "",- "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)",- "exception Parse_error of Lexing.position * Lexing.position"- ]-
− src/formats/haskell-gadt/CFtoAbstractGADT.hs
@@ -1,147 +0,0 @@-{- - BNF Converter: GADT Abstract syntax Generator - Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoAbstractGADT (cf2Abstract) where - -import CF -import Utils((+++),(++++)) -import Data.List(intersperse,nub) - -import HaskellGADTCommon - -import Data.Maybe (catMaybes) - --- to produce a Haskell module -cf2Abstract :: Bool -> String -> CF -> String -> String -cf2Abstract byteStrings name cf composOpMod = unlines $ [ - "{-# OPTIONS_GHC -fglasgow-exts #-}", - "module" +++ name +++ "(" ++ concat (intersperse ", " exports) ++ ")" +++ "where", - "", - "import " ++ composOpMod, - "", - "import Data.Monoid", - (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""), - "", - "-- Haskell module generated by the BNF converter", - ""] - ++ prDummyTypes cf - ++ [""] - ++ prTreeType byteStrings cf - ++ [""] - ++ prCompos cf - ++ [""] - ++ prShow cf - ++ [""] - ++ prEq cf - ++ [""] - ++ prOrd cf - where exports = ["Tree(..)"] - ++ getTreeCats cf - ++ ["johnMajorEq"] - ++ ["module " ++ composOpMod] - -getTreeCats :: CF -> [String] -getTreeCats cf = nub $ filter (not . isList) $ map consCat $ cf2cons cf - -prDummyTypes :: CF -> [String] -prDummyTypes cf = concatMap prDummyType $ getTreeCats cf - where - prDummyType cat = ["data" +++ t, "type" +++ cat +++ "= Tree" +++ t ] - where t = mkRealType cat - -mkRealType :: Cat -> String -mkRealType cat = cat ++ "_" -- FIXME: make sure that there is no such category already - -prTreeType :: Bool -> CF -> [String] -prTreeType byteStrings cf = ["data Tree :: * -> * where"] ++ map ((" "++) . prTreeCons) (cf2cons cf) - where - prTreeCons c - | isPositionCat cf cat = fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType cat - | otherwise = fun +++ "::" +++ concat [c +++ "-> " | (c,_) <- consVars c] ++ "Tree" +++ mkRealType cat - where (cat,fun) = (consCat c, consFun c) - stringType - | byteStrings = "BS.ByteString" - | otherwise = "String" - -prCompos :: CF -> [String] -prCompos cf = - ["instance Compos Tree where", - " compos r a f t = case t of"] - ++ map (" "++) (concatMap prComposCons cs - ++ if not (all isRecursive cs) then ["_ -> r t"] else []) - where - cs = cf2cons cf - prComposCons c - | isRecursive c = [consFun c +++ unwords (map snd (consVars c)) +++ "->" +++ rhs c] - | otherwise = [] - isRecursive c = any (isTreeType cf) (map fst (consVars c)) - rhs c = "r" +++ consFun c +++ unwords (map prRec (consVars c)) - where prRec (cat,var) | not (isTreeType cf cat) = "`a`" +++ "r" +++ var - | isList cat = "`a` foldr (a . a (r (:)) . f) (r [])" +++ var - | otherwise = "`a`" +++ "f" +++ var - -prShow :: CF -> [String] -prShow cf = ["instance Show (Tree c) where", - " showsPrec n t = case t of"] - ++ map (" "++) (map prShowCons cs) - ++ [" where opar n = if n > 0 then showChar '(' else id", - " cpar n = if n > 0 then showChar ')' else id"] - where - cs = cf2cons cf - prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun - | otherwise = fun +++ unwords (map snd vars) +++ "->" - +++ "opar n . showString" +++ show fun - +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars] - +++ ". cpar n" - where (fun, vars) = (consFun c, consVars c) - -prEq :: CF -> [String] -prEq cf = ["instance Eq (Tree c) where (==) = johnMajorEq", - "", - "johnMajorEq :: Tree a -> Tree b -> Bool"] - ++ map (prEqCons) (cf2cons cf) - ++ ["johnMajorEq _ _ = False"] - where prEqCons c - | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True" - | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")" - +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" - +++ (concat $ intersperse " && " $ zipWith (\x y -> x +++ "==" +++ y) vars vars') - where (fun, vars) = (consFun c, map snd (consVars c)) - vars' = map (++"_") vars - -prOrd :: CF -> [String] -prOrd cf = ["instance Ord (Tree c) where", - " compare x y = compare (index x) (index y) `mappend` compareSame x y"] ++ - ["index :: Tree c -> Int"] ++ - zipWith (\ c i -> mkIndex c i) cs [0..] ++ - ["compareSame :: Tree c -> Tree c -> Ordering"] ++ - map mkCompareSame cs ++ - ["compareSame x y = error \"BNFC error:\" compareSame"] - where cs = cf2cons cf - mkCompareSame c - | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ" - | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")" - +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "=" - +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc - where (fun, vars) = (consFun c, map snd (consVars c)) - vars' = map (++"_") vars - cc = zipWith (\x y -> "compare"+++x+++y) vars vars' - mkIndex c i = "index" +++ "(" ++ consFun c - +++ unwords (replicate (length (consVars c)) "_") ++ ")" - +++ "=" +++ show i
− src/formats/haskell-gadt/CFtoPrinterGADT.hs
@@ -1,167 +0,0 @@-{-- BNF Converter: GADT Pretty-printer generator- Copyright (C) 2004-2005 Author: Aarne Ranta, Björn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoPrinterGADT (cf2Printer) where--import CF-import Utils-import CFtoTemplate-import Data.List (intersperse)-import Data.Char(toLower)--import HaskellGADTCommon---- derive pretty-printer from a BNF grammar. AR 15/2/2002-cf2Printer :: String -> String -> CF -> String-cf2Printer name absMod cf = unlines $ [- prologue name absMod,- integerRule cf,- doubleRule cf]- ++ prPrt cf- ++ [""]- ++ concatMap (prPrtList cf) (filter isList (allCats cf))--prologue :: String -> String -> String-prologue name absMod = unlines [- "{-# OPTIONS_GHC -fglasgow-exts #-}",- "module " ++ name +++ "where\n",- "-- pretty-printer generated by the BNF converter\n",- "import " ++ absMod,- "import Data.Char",- "import Data.List (intersperse)",- "",- "-- the top-level printing method",- "printTree :: Print a => a -> String",- "printTree = render . prt 0",- "",- "type Doc = [ShowS] -> [ShowS]",- "",- "doc :: ShowS -> Doc",- "doc = (:)",- "",- "render :: Doc -> String",- "render d = rend 0 (map ($ \"\") $ d []) \"\" where",- " rend i ss = case ss of",- " \"[\" :ts -> showChar '[' . rend i ts",- " \"(\" :ts -> showChar '(' . rend i ts",- " \"{\" :ts -> showChar '{' . new (i+1) . rend (i+1) ts",- " \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts",- " \"}\" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts",- " \";\" :ts -> showChar ';' . new i . rend i ts",- " t : \",\" :ts -> showString t . space \",\" . rend i ts",- " t : \")\" :ts -> showString t . showChar ')' . rend i ts",- " t : \"]\" :ts -> showString t . showChar ']' . rend i ts",- " t :ts -> space t . rend i ts",- " _ -> id",- " new i = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace",- " space t = showString t . (\\s -> if null s then \"\" else (' ':s))",- "",- "parenth :: Doc -> Doc",- "parenth ss = doc (showChar '(') . ss . doc (showChar ')')",- "",- "concatS :: [ShowS] -> ShowS",- "concatS = foldr (.) id",- "",- "concatD :: [Doc] -> Doc",- "concatD = foldr (.) id",- "",- "unwordsD :: [Doc] -> Doc",- "unwordsD = concatD . intersperse (doc (showChar ' '))",- "",- "replicateS :: Int -> ShowS -> ShowS",- "replicateS n f = concatS (replicate n f)",- "",- "-- the printer class does the job",- "class Print a where",- " prt :: Int -> a -> Doc",- "",- "instance Print Char where",- " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')",- "",- "instance Print String where",- " prt _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')",- "",- "mkEsc :: Char -> Char -> ShowS",- "mkEsc q s = case s of",- " _ | s == q -> showChar '\\\\' . showChar s",- " '\\\\'-> showString \"\\\\\\\\\"", - " '\\n' -> showString \"\\\\n\"",- " '\\t' -> showString \"\\\\t\"",- " _ -> showChar s",- "",- "prPrec :: Int -> Int -> Doc -> Doc",- "prPrec i j = if j<i then parenth else id",- ""- ]--integerRule cf = showsPrintRule cf "Integer"-doubleRule cf = showsPrintRule cf "Double"--showsPrintRule cf t = unlines $ [- "instance Print " ++ t ++ " where",- " prt _ x = doc (shows x)",- ""] ++ ifList cf t--ownPrintRule cf own = unlines $ [- "instance Print " ++ own ++ " where",- " prt _ (" ++ own ++ posn ++ ") = doc (showString i)",- ""] ++ ifList cf own- where- posn = if isPositionCat cf own then " (_,i)" else " i"--ifList :: CF -> Cat -> [String]-ifList cf cat = prPrtList cf ("["++cat++"]") -- FIXME: hackish--prPrt :: CF -> [String]-prPrt cf = ["instance Print (Tree c) where",- " prt _i e = case e of"- ] ++ map prPrtCons (cf2cons cf)- where- prPrtCons c = " " ++ consFun c +++ unwords (vars c) +++ "->" +++ - "prPrec _i" +++ show (consPrec c) +++ rhs - -- for token rules, just print the string argument unquoted- where rhs | isToken c = let [v] = vars c in "(doc (showString " ++ v ++ "))"- | otherwise = mkRhs (vars c) (consRhs c)- vars = map snd . consVars- isToken c = consCat c `elem` specialCats cf--prPrtList :: CF -> Cat -> [String]-prPrtList cf cat = mkListRule (nil ++ one ++ cons)- where- nil = [" [] -> " ++ mkRhs [] its | - Rule f _ its <- rules, isNilFun f]- one = [" [x] -> " ++ mkRhs ["x"] its | - Rule f _ its <- rules, isOneFun f]- cons = [" x:xs -> " ++ mkRhs ["x","xs"] its | - Rule f _ its <- rules, isConsFun f]- mkListRule [] = []- mkListRule rs = ["instance Print" +++ cat +++ "where",- " prt _" +++ "es = case es of"] ++ rs- rules = rulesForCat cf cat--mkRhs :: [String] -> [Either Cat String] -> String-mkRhs args its = - "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])"- where- mk args (Left "#" : items) = mk args items- mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items- mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items- mk _ _ = []- prt c = "prt" +++ show (precCat c)-
− src/formats/haskell-gadt/CFtoTemplateGADT.hs
@@ -1,65 +0,0 @@-{-- BNF Converter: GADT Template Generator- Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---module CFtoTemplateGADT (- cf2Template- ) where--import CF-import Utils((+++))-import Data.List (delete,groupBy)--import HaskellGADTCommon--type ModuleName = String--cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String-cf2Template skelName absName errName cf = unlines $- [- "module "++ skelName ++ " where",- "",- "-- Haskell module generated by the BNF converter",- "",- "import " ++ absName,- "import " ++ errName,- "type Result = Err String\n",- "failure :: Show a => a -> Result",- "failure x = Bad $ \"Undefined case: \" ++ show x",- "",- "transTree :: Tree c -> Result",- "transTree t = case t of"]- ++ map prConsCase (cf2cons cf)- ++ [""]- ++ concatMap ((++[""]) . uncurry prCatTrans) (catCons cf)--prConsCase :: Constructor -> String-prConsCase c =- " " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t"--catCons :: CF -> [(Cat,[Constructor])]-catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf]--catEq :: Constructor -> Constructor -> Bool-catEq c1 c2 = consCat c1 == consCat c2--prCatTrans :: Cat -> [Constructor] -> [String]-prCatTrans cat cs = ["trans" ++ cat +++ "::" +++ cat +++ "-> Result",- "trans" ++ cat +++ "t = case t of"]- ++ map prConsCase cs
− src/formats/haskell-gadt/HaskellGADTCommon.hs
@@ -1,83 +0,0 @@-{- - BNF Converter: Haskell GADT back-end common stuff - Copyright (C) 2004-2005 Author: Markus Forberg, Björn Bringert - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where - -import CF - -import Data.Char - -data Constructor = Constructor { - consCat :: Cat, - consFun :: Fun, - consPrec :: Int, - consVars :: [(Cat,String)], - consRhs :: [Either Cat String] - } - --- | Get category, function, and rhs categories paired with variable names. -cf2cons :: CF -> [Constructor] -cf2cons cf = [ Constructor { consCat = cat, - consFun = fun, - consPrec = precFun cf fun, - consVars = zip cats (mkVars cats), - consRhs = rhsFun cf fun} - | (cat,rules) <- cf2data cf, (fun,cats) <- rules] - ++ [ Constructor { consCat = cat, - consFun = cat, - consPrec = 0, - consVars = [("String","str")], - consRhs = [Left "String"]} - | cat <- specialCats cf] - where mkVars cats = mkUnique (map catToVar cats) (0 :: Int) - mkUnique [] _ = [] - mkUnique (x:xs) n | elem x xs || n > 0 = (x ++ show n) : mkUnique xs (n+1) - | otherwise = x : mkUnique xs n - --- | Make a variable name for a category. -catToVar :: Cat -> String -catToVar = checkRes . var - where var cat | isList cat = var (normCatOfList cat) ++ "s" - var "Ident" = "i" - var "Integer" = "n" - var "String" = "str" - var "Char" = "c" - var "Double" = "d" - var xs = map toLower xs - checkRes s | elem s reservedHaskell = s ++ "'" - | otherwise = s - reservedHaskell = ["case","class","data","default","deriving","do","else","if", - "import","in","infix","infixl","infixr","instance","let","module", - "newtype","of","then","type","where","as","qualified","hiding"] - --- | Get the rule for a function. -ruleFun :: CF -> Fun -> Rule -ruleFun cf f = head $ filter (\r -> funRule r == f) $ rulesOfCF cf - --- | Get the precedence of a function. -precFun :: CF -> Fun -> Int -precFun cf f = precRule $ ruleFun cf f - --- | Get the RHS of a function -rhsFun :: CF -> Fun -> [Either Cat String] -rhsFun cf f = rhsRule $ ruleFun cf f - -isTreeType :: CF -> Cat -> Bool -isTreeType cf c | isList c = isTreeType cf (catOfList c) - | otherwise = c `elem` (allCats cf ++ specialCats cf)
− src/formats/haskell-gadt/HaskellTopGADT.hs
@@ -1,309 +0,0 @@-{-- BNF Converter: Haskell main file- Copyright (C) 2004-2005 Author: Markus Forberg, Peter Gammie, - Aarne Ranta, Björn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module HaskellTopGADT (makeAllGADT) where ------ import Utils-import Options-import HsOpts-import CF-import CFtoHappy-import CFtoAlex-import CFtoAlex2-import CFtoAlex3-import CFtoLatex-import HaskellTop(AlexMode(..))-import CFtoAbstractGADT-import CFtoTemplateGADT-import CFtoPrinterGADT-import CFtoLayout-import CFtoXML-import MkErrM-import MkSharedString-import Utils--import Data.Char-import Data.Maybe (fromMaybe,maybe)-import System.Exit (exitFailure)-import Control.Monad(when)---makeAllGADT :: Options -> CF -> IO ()-makeAllGADT opts cf = do- let absMod = absFileM opts- composOpMod = composOpFileM opts- lexMod = alexFileM opts- parMod = happyFileM opts- prMod = printerFileM opts- layMod = layoutFileM opts- errMod = errFileM opts- shareMod = shareFileM opts- do- let dir = codeDir opts- when (not (null dir)) $ do- putStrLn $ "Creating directory " ++ dir- prepareDir dir- writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod- writeFileRep (composOpFile opts) $ composOp composOpMod- case alexMode opts of- Alex1 -> do- writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf- putStrLn " (Use Alex 1.1 to compile.)" - Alex2 -> do- writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf- putStrLn " (Use Alex 2.0 to compile.)"- Alex3 -> do- writeFileRep (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf- putStrLn " (Use Alex 3.0 to compile.)"- writeFileRep (happyFile opts) $ - cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf- putStrLn " (Tested with Happy 1.15)"- writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf- writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf- writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf- when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alexMode opts == Alex1) (inDir opts) layMod lexMod cf- writeFileRep (tFile opts) $ testfile opts cf- writeFileRep (errFile opts) $ errM errMod cf- when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf- when (make opts) $ writeFileRep "Makefile" $ makefile opts- case xml opts of- 2 -> makeXML (lang opts) True cf- 1 -> makeXML (lang opts) False cf- _ -> return ()--codeDir :: Options -> FilePath-codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)- dir = if inDir opts then lang opts else ""- sep = if null pref || null dir then "" else [pathSep]- in pref ++ sep ++ dir --makefile :: Options -> String-makefile opts = makeA where- glr_params = if glr opts == GLR then "--glr --decode " else "" - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep]- cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")"- makeA = unlines - [- "all:", - "\thappy -gca " ++ glr_params ++ happyFile opts, - "\talex -g " ++ alexFile opts,- "\t" ++ cd ("latex " ++ basename (latexFile opts)- ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)),- "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts,- "clean:",- "\t-rm -f " ++ unwords (map (dir++) [- "*.log", "*.aux", "*.hi", - "*.o", "*.dvi"- ]),- "\t-rm -f " ++ psFile opts,-- "distclean: clean",- "\t-rm -f " ++ unwords [- mkFile withLang "Doc" "*" opts,- mkFile withLang "Lex" "*" opts,- mkFile withLang "Par" "*" opts,- mkFile withLang "Layout" "*" opts,- mkFile withLang "Skel" "*" opts,- mkFile withLang "Print" "*" opts,- mkFile withLang "Test" "*" opts,- mkFile withLang "Abs" "*" opts,- mkFile withLang "ComposOp" "*" opts,- mkFile withLang "Test" "" opts,- mkFile noLang "ErrM" "*" opts,- mkFile noLang "SharedString" "*" opts,- dir ++ lang opts ++ ".dtd",- mkFile withLang "XML" "*" opts, - "Makefile*"- ],- if null dir then "" else "\t-rmdir -p " ++ dir- ]---testfile :: Options -> CF -> String-testfile opts cf- = let lay = hasLayout cf - use_xml = xml opts > 0- xpr = if use_xml then "XPrint a, " else ""- use_glr = glr opts == GLR- if_glr s = if use_glr then s else ""- firstParser = if use_glr then "the_parser" else parserName- parserName = 'p' : topType- topType = firstEntry cf- in unlines- ["-- automatically generated by BNF Converter",- "module Main where\n",- "",- "import System.IO ( stdin, hGetContents )",- "import System.Environment ( getArgs, getProgName )",- "",- "import " ++ alexFileM opts,- "import " ++ happyFileM opts,- "import " ++ templateFileM opts,- "import " ++ printerFileM opts,- "import " ++ absFileM opts,- if lay then ("import " ++ layoutFileM opts) else "",- if use_xml then ("import " ++ xmlFileM opts) else "",- if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)",- if_glr "import Data.Maybe(fromJust)",- "import " ++ errFileM opts,- "",- if use_glr- then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"- else "type ParseFun a = [Token] -> Err a",- "",- "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer",- "",- "type Verbosity = Int",- "",- "putStrV :: Verbosity -> String -> IO ()",- "putStrV v s = if v > 1 then putStrLn s else return ()",- "",- "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()",- "runFile v p f = putStrLn f >> readFile f >>= run v p",- "",- "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()",- if use_glr then run_glr else run_std use_xml,- "",- "showTree :: (Show a, Print a) => Int -> a -> IO ()",- "showTree v tree",- " = do",- " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree",- " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree",- "",- "main :: IO ()",- "main = do args <- getArgs",- " case args of",- " [] -> hGetContents stdin >>= run 2 " ++ firstParser,- " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",- " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",- "",- if_glr $ "the_parser :: ParseFun " ++ topType,- if_glr $ "the_parser = lift_parser " ++ parserName,- if_glr $ "",- if_glr $ lift_parser- ]--run_std xml- = unlines - [ "run v p s = let ts = myLLexer s in case p ts of"- , " Bad s -> do putStrLn \"\\nParse Failed...\\n\""- , " putStrV v \"Tokens:\""- , " putStrV v $ show ts"- , " putStrLn s"- , " Ok tree -> do putStrLn \"\\nParse Successful!\""- , " showTree v tree"- , if xml then- " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"- else ""- ]--run_glr- = unlines - [ "run v p s"- , " = let ts = map (:[]) $ myLLexer s"- , " (raw_output, simple_output) = p ts in"- , " case simple_output of"- , " GLR_Fail major minor -> do"- , " putStrLn major"- , " putStrV v minor"- , " GLR_Result df trees -> do"- , " putStrLn \"\\nParse Successful!\""- , " case trees of"- , " [] -> error \"No results but parse succeeded?\""- , " [Ok x] -> showTree v x"- , " xs@(_:_) -> showSeveralTrees v xs"- , " where"- , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()"- , " showSeveralTrees v trees"- , " = sequence_ "- , " [ do putStrV v (replicate 40 '-')"- , " putStrV v $ \"Parse number: \" ++ show n"- , " showTree v t"- , " | (Ok t,n) <- zip trees [1..]"- , " ]"- ]- --lift_parser- = unlines - [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export."- , "data GLR_Output a"- , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]"- , " , semantic_result :: [a]"- , " }"- , " | GLR_Fail { main_message :: String"- , " , extra_info :: String"- , " }"- , ""- , "lift_parser"- , " :: (TreeDecode a, Show a, Print a)"- , " => ([[Token]] -> GLRResult) -> ParseFun a"- , "lift_parser parser ts"- , " = let result = parser ts in"- , " (\\o -> (result, o)) $"- , " case result of"- , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\""- , " (\"Tokens: \" ++ show ts)"- , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\""- , " (\"Partial forest:\\n\""- , " ++ unlines (map show $ fmToList f))"- , " ParseOK r f -> let find f = fromJust . lookupFM f"- , " dec_fn f = decode (find f) r"- , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)"- ]--composOp :: String -> String-composOp composOpMod = unlines- [- "{-# OPTIONS_GHC -fglasgow-exts #-}",- "module " ++ composOpMod ++ " (Compos(..),composOp,composOpM,composOpM_,composOpMonoid,",- " composOpMPlus,composOpFold) where",- "",- "import Control.Monad.Identity",- "import Data.Monoid",- "",- "class Compos t where",- " compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)",- " -> (forall a. t a -> m (t a)) -> t c -> m (t c)",- "",- "composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c",- "composOp f = runIdentity . composOpM (Identity . f)",- "",- "composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)",- "composOpM = compos return ap",- "",- "composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()",- "composOpM_ = composOpFold (return ()) (>>)",- "",- "composOpMonoid :: (Compos t, Monoid m) => (forall a. t a -> m) -> t c -> m",- "composOpMonoid = composOpFold mempty mappend",- "",- "composOpMPlus :: (Compos t, MonadPlus m) => (forall a. t a -> m b) -> t c -> m b",- "composOpMPlus = composOpFold mzero mplus",- "",- "composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b",- "composOpFold z c f = unC . compos (\\_ -> C z) (\\(C x) (C y) -> C (c x y)) (C . f)",- "",- "newtype C b a = C { unC :: b }"- ]
− src/formats/haskell2/CFtoAbstract.hs
@@ -1,51 +0,0 @@-{- - BNF Converter: Abstract syntax Generator - Copyright (C) 2004 Author: Markus Forberg - - This program is free software; you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --} - -module CFtoAbstract (cf2Abstract) where - -import CF -import Utils((+++),(++++)) -import Data.List(intersperse) - --- to produce a Haskell module -cf2Abstract :: Bool -> String -> CF -> String -cf2Abstract byteStrings name cf = unlines $ - ("module "++name +++ "where\n") : - "-- Haskell module generated by the BNF converter\n" : - (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "") : - (map (prSpecialData byteStrings cf) (specialCats cf) ++ map prData (cf2data cf)) - -prData :: Data -> String -prData (cat,rules) = - "data" +++ cat +++ "=\n " ++ - concat (intersperse "\n | " (map prRule rules)) ++++ - " deriving (Eq,Ord,Show)\n" - where - prRule (fun,cats) = unwords (fun:cats) - -prSpecialData :: Bool -> CF -> Cat -> String -prSpecialData byteStrings cf cat = - unwords ["newtype",cat,"=",cat,contentSpec byteStrings cf cat,"deriving (Eq,Ord,Show)"] - -contentSpec :: Bool -> CF -> Cat -> String -contentSpec byteStrings cf cat = if isPositionCat cf cat then "((Int,Int),"++stringType++")" else stringType - where - stringType - | byteStrings = "BS.ByteString" - | otherwise = "String"
− src/formats/haskell2/CFtoAlex.hs
@@ -1,230 +0,0 @@-{-- BNF Converter: Alex 1.1 Generator- Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---module CFtoAlex (cf2alex) where--import CF-import RegToAlex-import Data.List--cf2alex :: String -> String -> CF -> String-cf2alex name errMod cf = unlines $ concat $ intersperse [""] [- prelude name errMod,- cMacros,- rMacros cf,- restOfAlex cf- ]--prelude :: String -> String -> [String]-prelude name errMod = [- "-- This Alex file was machine-generated by the BNF converter",- "%{",- "module " ++ name ++ " where",- "",- "import Alex",- "import " ++ errMod,- "%}"- ]-{- -----cf2alex :: String -> CF -> String-cf2alex name cf = unlines $ concat $ intersperse [""] [- prelude name,- cMacros,- rMacros cf,- restOfAlex cf- ]--prelude :: String -> [String]-prelude name = [- "-- This Alex file was machine-generated by the BNF converter",- "%{",- "module Lex" ++ name ++ " where",- "",- "import Alex",- "import ErrM",- "%}"- ]--}-cMacros :: [String]-cMacros = [- "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter",- "{ ^c = [A-Z^192-^221] # [^215]} -- capital isolatin1 letter",- "{ ^s = [a-z^222-^255] # [^247]} -- small isolatin1 letter",- "{ ^d = [0-9] } -- digit",- "{ ^i = [^l^d^'^_] } -- identifier character",- "{ ^u = [^0-^255] } -- universal: any character"- ]--rMacros :: CF -> [String]-rMacros cf = - let symbs = symbols cf - in- (if null symbs then [] else [- "{ %s = -- reserved words consisting of special symbols",- " " ++ unwords (intersperse "|" (map mkEsc symbs)),- "}"- ])- where- mkEsc = unwords . map ( f . (:[]))- f s = if all isSpec s then '^':s else s- isSpec = flip elem "$+-*=<>[](){}!?.,;:^~|&%#/\\$_@\""--restOfAlex :: CF -> [String]-restOfAlex cf = [- "\"tokens_lx\"/\"tokens_acts\":-", - lexComments (comments cf),- "<> ::= ^w+",- pTSpec (symbols cf,[]), -- modif Markus 12/02 - 2002-- userDefTokenTypes,- identAndRes,-- ifC "String" "<string> ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++- "%{ string p = PT p . TL . unescapeInitTail %}",- ifC "Char" "<char> ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}",- ifC "Integer" "<int> ::= ^d+ %{ int p = PT p . TI %}",- ifC "Double" - "<double> ::= ^d+ ^. ^d+ (e (^-)? ^d+)? %{ double p = PT p . TD %}",- "",- "%{ ",- "",- "data Tok =", - " TS String -- reserved words",- " | TL String -- string literals", - " | TI String -- integer literals",- " | TV String -- identifiers",- " | TD String -- double precision float literals",- " | TC String -- character literals",- userDefTokenConstrs,- " deriving (Eq,Show)",- "",- "data Token = ",- " PT Posn Tok",- " | Err Posn",- " deriving Show",- "",- "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l", - "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l", - "tokenPos _ = \"end of file\"",- "",- "posLineCol (Pn _ l c) = (l,c)",- "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",- "",- "prToken t = case t of", - " PT _ (TS s) -> s",- " PT _ (TI s) -> s",- " PT _ (TV s) -> s",- " PT _ (TD s) -> s",- " PT _ (TC s) -> s",- userDefTokenPrint,- " _ -> show t",- "",- "tokens:: String -> [Token]",- "tokens inp = scan tokens_scan inp",- "",- "tokens_scan:: Scan Token",- "tokens_scan = load_scan (tokens_acts,stop_act) tokens_lx",- " where",- " stop_act p \"\" = []",- " stop_act p inp = [Err p]",- "",- "eitherResIdent :: (String -> Tok) -> String -> Tok",- "eitherResIdent tv s = if isResWord s then (TS s) else (tv s) where",- " isResWord s = isInTree s $",- " " ++ (show $ sorted2tree $ sort resws),- "",- "data BTree = N | B String BTree BTree deriving (Show)",- "",- "isInTree :: String -> BTree -> Bool",- "isInTree x tree = case tree of",- " N -> False",- " B a left right", - " | x < a -> isInTree x left",- " | x > a -> isInTree x right",- " | x == a -> True",- "",- "unescapeInitTail :: String -> String",- "unescapeInitTail = unesc . tail where",- " unesc s = case s of",- " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",- " '\\\\':'n':cs -> '\\n' : unesc cs",- " '\\\\':'t':cs -> '\\t' : unesc cs",- " '\"':[] -> []",- " c:cs -> c : unesc cs",- " _ -> []",- "%}"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""- lexComments ([],[]) = [] - lexComments (xs,s1:ys) = "<> ::= " ++ ('^':intersperse '^' s1) ++ " [.]* ^n\n" ++ lexComments (xs,ys)- lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $- [- "<> ::= ",- ('^':l1:' ':'^':l2:" ([^u # ^"), - (l2:"] | ^"),- (r1:" [^u # ^"),- (r2:"])* (^"),- (r1:")+ ^"),- (r2:"\n"),- lexComments (xs,[])- ]- lexComments ((_:xs),[]) = lexComments (xs,[]) ---- lexComments (xs,(_:ys)) = lexComments (xs,ys) - pTSpec ([],[]) = ""- pTSpec xp =- "<pTSpec> ::= " ++ aux xp ++ "%{ pTSpec p = PT p . TS %}"- aux (xs,[]) = " %s "- aux ([],ys) = " %r "- aux (xs,ys) = " %s | %r "- resWs = - "[" ++ concat (intersperse "," [show s | s <- resws]) ++ "]"- --- show s can be strange for isolatin1 characters- --- precompile to search tree!-- userDefTokenTypes = unlines $- ["<mk_" ++ name ++ "> ::= " ++ printRegAlex exp ++- "%{ mk_" ++ name ++ " p = PT p . eitherResIdent T_" ++ name ++ " %}" - | (name,exp) <- tokenPragmas cf]- userDefTokenConstrs = unlines $- [" | T_" ++ name ++ " String" | (name,_) <- tokenPragmas cf]- userDefTokenPrint = unlines $- [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf]-- identAndRes = --This has to be there for Reserved Words. Michael- "<ident> ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" - --ifC "Ident" "<ident> ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" -- resws = reservedWords cf--data BTree = N | B String BTree BTree deriving (Show)--isInTree :: String -> BTree -> Bool-isInTree x tree = case tree of- N -> False- B a left right - | x < a -> isInTree x left- | x > a -> isInTree x right- | x == a -> True--sorted2tree :: [String] -> BTree-sorted2tree [] = N-sorted2tree xs = B x (sorted2tree t1) (sorted2tree t2) where- (t1,(x:t2)) = splitAt (length xs `div` 2) xs
− src/formats/haskell2/CFtoAlex2.hs
@@ -1,338 +0,0 @@-{-- BNF Converter: Alex 2.0 Generator- Copyright (C) 2004 Author: Peter Gammie-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}------------------------------------------------------------------------ |--- Module : CFtoAlex2--- Copyright : (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se--- License : GPL (see COPYING for details)--- --- Maintainer : {markus,aarne} at cs dot chalmers dot se--- Stability : alpha--- Portability : Haskell98------ Hacked version of @CFtoAlex@ to cope with Alex2.------------------------------------------------------------------------module CFtoAlex2 (cf2alex2) where--import CF-import Data.List---- For RegToAlex, see below.-import AbsBNF-import Data.Char--cf2alex2 :: String -> String -> String -> Bool -> Bool -> CF -> String-cf2alex2 name errMod shareMod shareStrings byteStrings cf = - unlines $ concat $ intersperse [""] [- prelude name errMod shareMod shareStrings byteStrings,- cMacros,- rMacros cf,- restOfAlex shareMod shareStrings byteStrings cf- ]--prelude :: String -> String -> String -> Bool -> Bool -> [String]-prelude name errMod shareMod shareStrings byteStrings = [- "-- -*- haskell -*-",- "-- This Alex file was machine-generated by the BNF converter",- "{",- "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}",- "module " ++ name ++ " where",- "",- -- "import " ++ errMod,- if shareStrings then "import " ++ shareMod else "",- if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",- "}",- ""- ]--cMacros :: [String]-cMacros = [- "$l = [a-zA-Z\\192 - \\255] # [\\215 \\247] -- isolatin1 letter FIXME",- "$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter FIXME",- "$s = [a-z\\222-\\255] # [\\247] -- small isolatin1 letter FIXME",- "$d = [0-9] -- digit",- "$i = [$l $d _ '] -- identifier character",- "$u = [\\0-\\255] -- universal: any character"- ]--rMacros :: CF -> [String]-rMacros cf = - let symbs = symbols cf- in- (if null symbs then [] else [- "@rsyms = -- symbols and non-identifier-like reserved words",- " " ++ unwords (intersperse "|" (map mkEsc symbs))- ])- where- mkEsc = unwords . esc- esc s = if null a then rest else show a : rest- where (a,r) = span isAlphaNum s- rest = case r of- [] -> []- (c:xs) -> s : esc xs- where s = if isPrint c then ['\\',c]- else '\\':show (ord c)--restOfAlex :: String -> Bool -> Bool -> CF -> [String]-restOfAlex shareMod shareStrings byteStrings cf = [- ":-", - lexComments (comments cf),- "$white+ ;",- pTSpec (symbols cf),-- userDefTokenTypes,- ident,-- ifC "String" ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++- "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"),- ifC "Char" "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }",- ifC "Integer" "$d+ { tok (\\p s -> PT p (TI $ share s)) }",- ifC "Double" "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }",- "",- "{",- "",- "tok f p s = f p s",- "",- "share :: "++stringType++" -> "++stringType,- "share = " ++ if shareStrings then "shareString" else "id",- "",- "data Tok =", - " TS !"++stringType++" !Int -- reserved words and symbols",- " | TL !"++stringType++" -- string literals", - " | TI !"++stringType++" -- integer literals",- " | TV !"++stringType++" -- identifiers",- " | TD !"++stringType++" -- double precision float literals",- " | TC !"++stringType++" -- character literals",- userDefTokenConstrs,- " deriving (Eq,Show,Ord)",- "",- "data Token = ",- " PT Posn Tok",- " | Err Posn",- " deriving (Eq,Show,Ord)",- "",- "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l", - "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l", - "tokenPos _ = \"end of file\"",- "",- "posLineCol (Pn _ l c) = (l,c)",- "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",- "",- "prToken t = case t of", - " PT _ (TS s _) -> s",- " PT _ (TL s) -> s",- " PT _ (TI s) -> s",- " PT _ (TV s) -> s",- " PT _ (TD s) -> s",- " PT _ (TC s) -> s",- userDefTokenPrint, - "",- "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",- "",- "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",- "eitherResIdent tv s = treeFind resWords",- " where",- " treeFind N = tv s",- " treeFind (B a t left right) | s < a = treeFind left",- " | s > a = treeFind right",- " | s == a = t",- "",- "resWords = " ++ (show $ sorted2tree $ zip (sort resws) [1..]),- " where b s n = let bs = "++stringPack++" s",- " in B bs (TS bs n)",- "",- "unescapeInitTail :: "++stringType++" -> "++stringType++"",- "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",- " unesc s = case s of",- " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",- " '\\\\':'n':cs -> '\\n' : unesc cs",- " '\\\\':'t':cs -> '\\t' : unesc cs",- " '\"':[] -> []",- " c:cs -> c : unesc cs",- " _ -> []",- "",- "-------------------------------------------------------------------",- "-- Alex wrapper code.",- "-- A modified \"posn\" wrapper.",- "-------------------------------------------------------------------",- "",- "data Posn = Pn !Int !Int !Int",- " deriving (Eq, Show,Ord)",- "",- "alexStartPos :: Posn",- "alexStartPos = Pn 0 1 1",- "",- "alexMove :: Posn -> Char -> Posn",- "alexMove (Pn a l c) '\\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)",- "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1) 1",- "alexMove (Pn a l c) _ = Pn (a+1) l (c+1)",- "",- "type AlexInput = (Posn, -- current position,",- " Char, -- previous char",- " "++stringType++") -- current input string",- "",- "tokens :: "++stringType++" -> [Token]",- "tokens str = go (alexStartPos, '\\n', str)",- " where",- " go :: AlexInput -> [Token]",- " go inp@(pos, _, str) =",- " case alexScan inp 0 of",- " AlexEOF -> []",- " AlexError (pos, _, _) -> [Err pos]",- " AlexSkip inp' len -> go inp'",- " AlexToken inp' len act -> act pos ("++stringTake++" len str) : (go inp')",- "",- "alexGetChar :: AlexInput -> Maybe (Char,AlexInput)",- "alexGetChar (p, _, s) =",- " case "++stringUncons++" s of",- " "++stringNilP++" -> Nothing",- " "++stringConsP++" ->",- " let p' = alexMove p c",- " in p' `seq` Just (c, (p', c, s))",- "",- "alexInputPrevChar :: AlexInput -> Char",- "alexInputPrevChar (p, c, s) = c",- "}"- ]- where- (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP)- | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")- | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" )-- ifC cat s = if isUsedCat cf cat then s else ""- lexComments ([],[]) = [] - lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys)- lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $- [- ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape?- (l2:"] | \\"),- (r1:" [$u # \\"),- (r2:"])* (\""),- (r1:"\")+ \""),- (r2:"\" ; \n"),- lexComments (xs, [])- ]- lexComments ((_:xs),[]) = lexComments (xs,[]) ---- lexComments (xs,(_:ys)) = lexComments (xs,ys) -- -- tokens consisting of special symbols- pTSpec [] = ""- pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"-- userDefTokenTypes = unlines $- [printRegAlex exp ++- " { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }"- | (name,exp) <- tokenPragmas cf]- userDefTokenConstrs = unlines $- [" | T_" ++ name ++ " !"++stringType | (name,_) <- tokenPragmas cf]- userDefTokenPrint = unlines $- [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf]-- ident =- "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" - --ifC "Ident" "<ident> ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" -- resws = reservedWords cf ++ symbols cf---data BTree = N | B String Int BTree BTree --instance Show BTree where- showsPrec _ N = showString "N"- showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '- . showsPrec 1 l . showChar ' '- . showsPrec 1 r)- where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f--sorted2tree :: [(String,Int)] -> BTree-sorted2tree [] = N-sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where- (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs------------------------------------------------------------------------- Inlined version of @RegToAlex@.--- Syntax has changed...------------------------------------------------------------------------ modified from pretty-printer generated by the BNF converter---- the top-level printing method-printRegAlex :: Reg -> String-printRegAlex = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend 0- where rend :: Int -> [String] -> String- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""-- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ " " ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]]- prtList s = map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["()"])- RChar c -> prPrec i 3 (concat [prt 0 c])- RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) str))- RDigit -> prPrec i 3 (concat [["$d"]])- RLetter -> prPrec i 3 (concat [["$l"]])- RUpper -> prPrec i 3 (concat [["$c"]])- RLower -> prPrec i 3 (concat [["$s"]])- RAny -> prPrec i 3 (concat [["$u"]])
− src/formats/haskell2/CFtoAlex3.hs
@@ -1,356 +0,0 @@-{-- BNF Converter: Alex 3.0 Generator- Copyright (C) 2012 Author: Antti-Juhani Kaijanaho- Copyright (C) 2004 Author: Peter Gammie- (C)opyright 2003, {aarne,markus,peteg} at cs dot chalmers dot se-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoAlex3 (cf2alex3) where--import CF-import Data.List---- For RegToAlex, see below.-import AbsBNF-import Data.Char--cf2alex3 :: String -> String -> String -> Bool -> Bool -> CF -> String-cf2alex3 name errMod shareMod shareStrings byteStrings cf = - unlines $ concat $ intersperse [""] [- prelude name errMod shareMod shareStrings byteStrings,- cMacros,- rMacros cf,- restOfAlex shareMod shareStrings byteStrings cf- ]--prelude :: String -> String -> String -> Bool -> Bool -> [String]-prelude name errMod shareMod shareStrings byteStrings = [- "-- -*- haskell -*-",- "-- This Alex file was machine-generated by the BNF converter",- "{",- "{-# OPTIONS -fno-warn-incomplete-patterns #-}",- "module " ++ name ++ " where",- "",- -- "import " ++ errMod,- if shareStrings then "import " ++ shareMod else "",- if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",- "import qualified Data.Bits",- "import Data.Word (Word8)",- "}",- ""- ]--cMacros :: [String]-cMacros = [- "$l = [a-zA-Z\\192 - \\255] # [\\215 \\247] -- isolatin1 letter FIXME",- "$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter FIXME",- "$s = [a-z\\222-\\255] # [\\247] -- small isolatin1 letter FIXME",- "$d = [0-9] -- digit",- "$i = [$l $d _ '] -- identifier character",- "$u = [\\0-\\255] -- universal: any character"- ]--rMacros :: CF -> [String]-rMacros cf = - let symbs = symbols cf- in- (if null symbs then [] else [- "@rsyms = -- symbols and non-identifier-like reserved words",- " " ++ unwords (intersperse "|" (map mkEsc symbs))- ])- where- mkEsc = unwords . esc- esc s = if null a then rest else show a : rest- where (a,r) = span isAlphaNum s- rest = case r of- [] -> []- (c:xs) -> s : esc xs- where s = if isPrint c then ['\\',c]- else '\\':show (ord c)--restOfAlex :: String -> Bool -> Bool -> CF -> [String]-restOfAlex shareMod shareStrings byteStrings cf = [- ":-", - lexComments (comments cf),- "$white+ ;",- pTSpec (symbols cf),-- userDefTokenTypes,- ident,-- ifC "String" ("\\\" ([$u # [\\\" \\\\ \\n]] | (\\\\ (\\\" | \\\\ | \\' | n | t)))* \\\"" ++- "{ tok (\\p s -> PT p (TL $ share $ unescapeInitTail s)) }"),- ifC "Char" "\\\' ($u # [\\\' \\\\] | \\\\ [\\\\ \\\' n t]) \\' { tok (\\p s -> PT p (TC $ share s)) }",- ifC "Integer" "$d+ { tok (\\p s -> PT p (TI $ share s)) }",- ifC "Double" "$d+ \\. $d+ (e (\\-)? $d+)? { tok (\\p s -> PT p (TD $ share s)) }",- "",- "{",- "",- "tok f p s = f p s",- "",- "share :: "++stringType++" -> "++stringType,- "share = " ++ if shareStrings then "shareString" else "id",- "",- "data Tok =", - " TS !"++stringType++" !Int -- reserved words and symbols",- " | TL !"++stringType++" -- string literals", - " | TI !"++stringType++" -- integer literals",- " | TV !"++stringType++" -- identifiers",- " | TD !"++stringType++" -- double precision float literals",- " | TC !"++stringType++" -- character literals",- userDefTokenConstrs,- " deriving (Eq,Show,Ord)",- "",- "data Token = ",- " PT Posn Tok",- " | Err Posn",- " deriving (Eq,Show,Ord)",- "",- "tokenPos (PT (Pn _ l _) _ :_) = \"line \" ++ show l", - "tokenPos (Err (Pn _ l _) :_) = \"line \" ++ show l", - "tokenPos _ = \"end of file\"",- "",- "tokenPosn (PT p _) = p",- "tokenPosn (Err p) = p",- "tokenLineCol = posLineCol . tokenPosn",- "posLineCol (Pn _ l c) = (l,c)",- "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",- "",- "prToken t = case t of", - " PT _ (TS s _) -> s",- " PT _ (TL s) -> s",- " PT _ (TI s) -> s",- " PT _ (TV s) -> s",- " PT _ (TD s) -> s",- " PT _ (TC s) -> s",- userDefTokenPrint, - "",- "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)",- "",- "eitherResIdent :: ("++stringType++" -> Tok) -> "++stringType++" -> Tok",- "eitherResIdent tv s = treeFind resWords",- " where",- " treeFind N = tv s",- " treeFind (B a t left right) | s < a = treeFind left",- " | s > a = treeFind right",- " | s == a = t",- "",- "resWords = " ++ (show $ sorted2tree $ cfTokens $ cf),- " where b s n = let bs = "++stringPack++" s",- " in B bs (TS bs n)",- "",- "unescapeInitTail :: "++stringType++" -> "++stringType++"",- "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",- " unesc s = case s of",- " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs",- " '\\\\':'n':cs -> '\\n' : unesc cs",- " '\\\\':'t':cs -> '\\t' : unesc cs",- " '\"':[] -> []",- " c:cs -> c : unesc cs",- " _ -> []",- "",- "-------------------------------------------------------------------",- "-- Alex wrapper code.",- "-- A modified \"posn\" wrapper.",- "-------------------------------------------------------------------",- "",- "data Posn = Pn !Int !Int !Int",- " deriving (Eq, Show,Ord)",- "",- "alexStartPos :: Posn",- "alexStartPos = Pn 0 1 1",- "",- "alexMove :: Posn -> Char -> Posn",- "alexMove (Pn a l c) '\\t' = Pn (a+1) l (((c+7) `div` 8)*8+1)",- "alexMove (Pn a l c) '\\n' = Pn (a+1) (l+1) 1",- "alexMove (Pn a l c) _ = Pn (a+1) l (c+1)",- "",- "type Byte = Word8",- "",- "type AlexInput = (Posn, -- current position,",- " Char, -- previous char",- " [Byte], -- pending bytes on the current char",- " "++stringType++") -- current input string",- "",- "tokens :: "++stringType++" -> [Token]",- "tokens str = go (alexStartPos, '\\n', [], str)",- " where",- " go :: AlexInput -> [Token]",- " go inp@(pos, _, _, str) =",- " case alexScan inp 0 of",- " AlexEOF -> []",- " AlexError (pos, _, _, _) -> [Err pos]",- " AlexSkip inp' len -> go inp'",- " AlexToken inp' len act -> act pos ("++stringTake++" len str) : (go inp')",- "",- "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)",- "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))",- "alexGetByte (p, _, [], s) =",- " case "++stringUncons++" s of",- " "++stringNilP++" -> Nothing",- " "++stringConsP++" ->",- " let p' = alexMove p c",- " (b:bs) = utf8Encode c",- " in p' `seq` Just (b, (p', c, bs, s))",- "",- "alexInputPrevChar :: AlexInput -> Char",- "alexInputPrevChar (p, c, bs, s) = c",- "",- " -- | Encode a Haskell String to a list of Word8 values, in UTF8 format.",- "utf8Encode :: Char -> [Word8]",- "utf8Encode = map fromIntegral . go . ord",- " where",- " go oc",- " | oc <= 0x7f = [oc]",- "",- " | oc <= 0x7ff = [ 0xc0 + (oc `Data.Bits.shiftR` 6)",- " , 0x80 + oc Data.Bits..&. 0x3f",- " ]",- "",- " | oc <= 0xffff = [ 0xe0 + (oc `Data.Bits.shiftR` 12)",- " , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",- " , 0x80 + oc Data.Bits..&. 0x3f",- " ]",- " | otherwise = [ 0xf0 + (oc `Data.Bits.shiftR` 18)",- " , 0x80 + ((oc `Data.Bits.shiftR` 12) Data.Bits..&. 0x3f)",- " , 0x80 + ((oc `Data.Bits.shiftR` 6) Data.Bits..&. 0x3f)",- " , 0x80 + oc Data.Bits..&. 0x3f",- " ]",- "}"- ]- where- (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP)- | byteStrings = ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")- | otherwise = ("String", "take", "", "id", "id", "[]", "(c:s)" )-- ifC cat s = if isUsedCat cf cat then s else ""- lexComments ([],[]) = [] - lexComments (xs,s1:ys) = '\"' : s1 ++ "\"" ++ " [.]* ; -- Toss single line comments\n" ++ lexComments (xs, ys)- lexComments (([l1,l2],[r1,r2]):xs,[]) = concat $- [- ('\"':l1:l2:"\" ([$u # \\"), -- FIXME quotes or escape?- (l2:"] | \\"),- (r1:" [$u # \\"),- (r2:"])* (\""),- (r1:"\")+ \""),- (r2:"\" ; \n"),- lexComments (xs, [])- ]- lexComments ((_:xs),[]) = lexComments (xs,[]) ---- lexComments (xs,(_:ys)) = lexComments (xs,ys) -- -- tokens consisting of special symbols- pTSpec [] = ""- pTSpec _ = "@rsyms { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"-- userDefTokenTypes = unlines $- [printRegAlex exp ++- " { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }"- | (name,exp) <- tokenPragmas cf]- userDefTokenConstrs = unlines $- [" | T_" ++ name ++ " !"++stringType | (name,_) <- tokenPragmas cf]- userDefTokenPrint = unlines $- [" PT _ (T_" ++ name ++ " s) -> s" | (name,_) <- tokenPragmas cf]-- ident =- "$l $i* { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" - --ifC "Ident" "<ident> ::= ^l ^i* { ident p = PT p . eitherResIdent TV }" ---data BTree = N | B String Int BTree BTree --instance Show BTree where- showsPrec _ N = showString "N"- showsPrec n (B s k l r) = wrap (showString "b " . shows s . showChar ' '. shows k . showChar ' '- . showsPrec 1 l . showChar ' '- . showsPrec 1 r)- where wrap f = if n > 0 then showChar '(' . f . showChar ')' else f--sorted2tree :: [(String,Int)] -> BTree-sorted2tree [] = N-sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2) where- (t1,((x,n):t2)) = splitAt (length xs `div` 2) xs------------------------------------------------------------------------- Inlined version of @RegToAlex@.--- Syntax has changed...------------------------------------------------------------------------ modified from pretty-printer generated by the BNF converter---- the top-level printing method-printRegAlex :: Reg -> String-printRegAlex = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend 0- where rend :: Int -> [String] -> String- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""-- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ " " ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = if isAlphaNum c then [[c]] else ['\\':[c]]- prtList s = map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["$"])- RChar c -> prPrec i 3 (concat [prt 0 c])- RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) str))- RDigit -> prPrec i 3 (concat [["$d"]])- RLetter -> prPrec i 3 (concat [["$l"]])- RUpper -> prPrec i 3 (concat [["$c"]])- RLower -> prPrec i 3 (concat [["$s"]])- RAny -> prPrec i 3 (concat [["$u"]])
− src/formats/haskell2/CFtoHappy.hs
@@ -1,278 +0,0 @@-{-- BNF Converter: Happy Generator- Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoHappy - (- cf2HappyS -- cf2HappyS :: CF -> CFCat -> String- )- where--import CF---import Lexer-import Data.List (intersperse, sort)-import Data.Char-import Options (HappyMode(..))--- Type declarations--type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String---- default naming--moduleName = "HappyParser"-tokenName = "Token"---- Happy mode----cf2HappyS :: String -> String -> String -> String -> HappyMode -> Bool -> CF -> String----- cf2HappyS :: String -> CF -> String-cf2HappyS = cf2Happy---- The main function, that given a CF and a CFCat to parse according to, --- generates a happy module. -cf2Happy name absName lexName errName mode byteStrings cf - = unlines - [header name absName lexName errName mode byteStrings,- declarations mode (allEntryPoints cf),- tokens (cfTokens cf),- specialToks cf,- delimiter,- specialRules byteStrings cf,- prRules (rulesForHappy cf),- finalize byteStrings cf]---- construct the header.-header :: String -> String -> String -> String -> HappyMode -> Bool -> String-header modName absName lexName errName mode byteStrings = unlines - ["-- This Happy file was machine-generated by the BNF converter",- "{",- "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}",- case mode of - Standard -> "module " ++ modName ++ " where" - GLR -> "-- module name filled in by Happy",- "import " ++ absName,- "import " ++ lexName,- "import " ++ errName,- if byteStrings then "import qualified Data.ByteString.Char8 as BS" else "",- "}"- ]--{- -----cf2Happy :: String -> CF -> String-cf2Happy name cf - = unlines - [header name,- declarations (allEntryPoints cf),- tokens (cfTokens cf),- specialToks cf,- delimiter,- specialRules cf,- prRules (rulesForHappy cf),- finalize cf]---- construct the header.-header :: String -> String-header name = unlines - ["-- This Happy file was machine-generated by the BNF converter",- "{",- "module Par" ++ name ++ " where", - "import Abs"++name,- "import Lex"++name,- "import ErrM",- "}"- ]--}---- The declarations of a happy file.-declarations :: HappyMode -> [NonTerminal] -> String-declarations mode ns = unlines - [generateP ns,- case mode of - Standard -> "-- no lexer declaration"- GLR -> "%lexer { myLexer } { Err _ }",- "%monad { Err } { thenM } { returnM }",- "%tokentype { " ++ tokenName ++ " }"]- where generateP [] = []- generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns]- where n' = identCat n---- The useless delimiter symbol.-delimiter :: String-delimiter = "\n%%\n"---- Generate the list of tokens and their identifiers.-tokens :: [(String,Int)] -> String-tokens toks = "%token \n" ++ prTokens toks- where prTokens [] = []- prTokens ((t,k):tk) = " " ++ (convert t) ++ - " { " ++ oneTok t k ++ " }\n" ++- prTokens tk- oneTok t k = "PT _ (TS _ " ++ show k ++ ")"---- Happy doesn't allow characters such as åäö to occur in the happy file. This--- is however not a restriction, just a naming paradigm in the happy source file.-convert :: String -> String-convert "\\" = concat ['\'':"\\\\","\'"]-convert xs = concat ['\'':(escape xs),"\'"]- where escape [] = []- escape ('\'':xs) = '\\':'\'':escape xs- escape (x:xs) = x:escape xs--rulesForHappy :: CF -> Rules-rulesForHappy cf = map mkOne $ ruleGroups cf where- mkOne (cat,rules) = constructRule cf rules cat---- For every non-terminal, we construct a set of rules. A rule is a sequence of--- terminals and non-terminals, and an action to be performed--- As an optimization, a pair of list rules [C] ::= "" | C k [C]--- is left-recursivized into [C] ::= "" | [C] C k.--- This could be generalized to cover other forms of list rules.-constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) | - r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf r])- where- revF b r = if b then ("flip " ++ funRule r) else (underscore $ funRule r)- revs = reversibleCats cf- underscore f | isDefinedRule f = f ++ "_"- | otherwise = f---- Generates a string containing the semantic action.--- An action can for example be: Sum $1 $2, that is, construct an AST--- with the constructor Sum applied to the two metavariables $1 and $2.-generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action-generateAction nt f ms = unwords $ (if isCoercion f then [] else [f]) ++ ms---- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal--generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])-generatePatterns cf r = case rhsRule r of- [] -> ("{- empty -}",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> identCat c- Right s -> convert s- metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]- revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("(reverse " ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself- revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules = unlines . map prOne- where- prOne (nt,[]) = [] -- nt has only internal use- prOne (nt,((p,a):ls)) =- unwords [nt', "::", "{", normCat nt, "}\n" ++ - nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n"- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = - unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls- --- Finally, some haskell code.--finalize :: Bool -> CF -> String-finalize byteStrings cf = unlines $- [- "{",- "\nreturnM :: a -> Err a",- "returnM = return",- "\nthenM :: Err a -> (a -> Err b) -> Err b",- "thenM = (>>=)",- "\nhappyError :: [" ++ tokenName ++ "] -> Err a",- "happyError ts =", - " Bad $ \"syntax error at \" ++ tokenPos ts ++ ",- " case ts of",- " [] -> []",- " [Err _] -> \" due to lexer error\"", - " _ -> \" before \" ++ unwords (map ("++stringUnpack++" . prToken) (take 4 ts))",- "",- "myLexer = tokens"- ] ++ definedRules cf ++ [ "}" ]- where- stringUnpack- | byteStrings = "BS.unpack"- | otherwise = "id"---definedRules cf = [ mkDef f xs e | FunDef f xs e <- pragmasOfCF cf ]- where- mkDef f xs e = unwords $ (f ++ "_") : xs' ++ ["=", show e']- where- xs' = map (++"_") xs- e' = underscore e- underscore (App x es)- | isLower $ head x = App (x ++ "_") $ map underscore es- | otherwise = App x $ map underscore es- underscore e = e---- aarne's modifs 8/1/2002:--- Markus's modifs 11/02/2002---- GF literals-specialToks :: CF -> String-specialToks cf = unlines $- (map aux (literals cf))- ++ ["L_err { _ }"]- where aux cat = - case cat of- "Ident" -> "L_ident { PT _ (TV $$) }"- "String" -> "L_quoted { PT _ (TL $$) }"- "Integer" -> "L_integ { PT _ (TI $$) }"- "Double" -> "L_doubl { PT _ (TD $$) }"- "Char" -> "L_charac { PT _ (TC $$) }"- own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }"- where- posn = if isPositionCat cf cat then "_" else "$$"--specialRules :: Bool -> CF -> String-specialRules byteStrings cf = unlines $- map aux (literals cf)- where - aux cat = - case cat of- "Ident" -> "Ident :: { Ident } : L_ident { Ident $1 }" - "String" -> "String :: { String } : L_quoted { "++stringUnpack++" $1 }" - "Integer" -> "Integer :: { Integer } : L_integ { (read ("++stringUnpack++" $1)) :: Integer }"- "Double" -> "Double :: { Double } : L_doubl { (read ("++stringUnpack++" $1)) :: Double }"- "Char" -> "Char :: { Char } : L_charac { (read ("++stringUnpack++" $1)) :: Char }"- own -> own ++ " :: { " ++ own ++ "} : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}"- -- PCC: take "own" as type name? (manual says newtype)- where- posn = if isPositionCat cf cat then "mkPosToken " else ""-- stringUnpack- | byteStrings = "BS.unpack"- | otherwise = ""-
− src/formats/haskell2/CFtoLayout.hs
@@ -1,270 +0,0 @@-{-- BNF Converter: Layout handling Generator- Copyright (C) 2004 Author: Aarne Ranta- Copyright (C) 2005 Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoLayout where--import Data.List (sort)-import CF--layoutOpen = "{"-layoutClose = "}"-layoutSep = ";"--cf2Layout :: Bool -> Bool -> String -> String -> CF -> String-cf2Layout alex1 inDir layName lexName cf = - let - (top,lay,stop) = layoutPragmas cf - in unlines $ [- "module " ++ layName ++ " where",- "",- "import " ++ lexName,- if alex1 then "import Alex" else "",- "",- "import Data.Maybe (isNothing, fromJust)",- "",- "-- Generated by the BNF Converter",- "",- "-- local parameters",- "",- "topLayout = " ++ show top,- "layoutWords = " ++ show lay,- "layoutStopWords = " ++ show stop,- "",- "-- layout separators",- "",- "layoutOpen = " ++ show layoutOpen,- "layoutClose = " ++ show layoutClose,- "layoutSep = " ++ show layoutSep,- "",- "-- | Replace layout syntax with explicit layout tokens.",- "resolveLayout :: Bool -- ^ Whether to use top-level layout.",- " -> [Token] -> [Token]",- "resolveLayout tp = res Nothing [if tl then Implicit 1 else Explicit]",- " where",- " -- Do top-level layout if the function parameter and the grammar say so.",- " tl = tp && topLayout",- "",- " res :: Maybe Token -- ^ The previous token, if any.",- " -> [Block] -- ^ A stack of layout blocks.",- " -> [Token] -> [Token]",- "",- " -- The stack should never be empty.",- " res _ [] ts = error $ \"Layout error: stack empty. Tokens: \" ++ show ts",- "",- " res _ st (t0:ts)",- " -- We found an open brace in the input,",- " -- put an explicit layout block on the stack.",- " -- This is done even if there was no layout word,",- " -- to keep opening and closing braces.",- " | isLayoutOpen t0 = moveAlong (Explicit:st) [t0] ts",- "",- " res _ st (t0:ts)",- " -- Start a new layout block if the first token is a layout word",- " | isLayout t0 =",- " case ts of",- " -- Explicit layout, just move on. The case above",- " -- will push an explicit layout block.",- " t1:_ | isLayoutOpen t1 -> moveAlong st [t0] ts",- " -- at end of file, the start column doesn't matter",- " _ -> let col = if null ts then column t0 else column (head ts)",- " -- insert an open brace after the layout word",- " b:ts' = addToken (nextPos t0) layoutOpen ts",- " -- save the start column",- " st' = Implicit col:st ",- " in moveAlong st' [t0,b] ts'",- "",- " -- If we encounter a closing brace, exit the first explicit layout block.",- " | isLayoutClose t0 = ",- " let st' = drop 1 (dropWhile isImplicit st)",- " in if null st' ",- " then error $ \"Layout error: Found \" ++ layoutClose ++ \" at (\" ",- " ++ show (line t0) ++ \",\" ++ show (column t0) ",- " ++ \") without an explicit layout block.\"",- " else moveAlong st' [t0] ts",- "",- " -- We are in an implicit layout block",- " res pt st@(Implicit n:ns) (t0:ts)",- "",- " -- End of implicit block by a layout stop word",- " | isStop t0 = ",- " -- Exit the current block and all implicit blocks ",- " -- more indented than the current token",- " let (ebs,ns') = span (`moreIndent` column t0) ns",- " moreIndent (Implicit x) y = x > y",- " moreIndent Explicit _ = False",- " -- the number of blocks exited",- " b = 1 + length ebs",- " bs = replicate b layoutClose",- " -- Insert closing braces after the previous token.",- " (ts1,ts2) = splitAt (1+b) $ addTokens (afterPrev pt) bs (t0:ts)",- " in moveAlong ns' ts1 ts2",- "",- " -- End of an implicit layout block",- " | newLine && column t0 < n = ",- " -- Insert a closing brace after the previous token.",- " let b:t0':ts' = addToken (afterPrev pt) layoutClose (t0:ts)",- " -- Repeat, with the current block removed from the stack",- " in moveAlong ns [b] (t0':ts')",- "",- " -- Encounted a new line in an implicit layout block.",- " | newLine && column t0 == n = ",- " -- Insert a semicolon after the previous token.",- " -- unless we are the beginning of the file,",- " -- or the previous token is a semicolon or open brace.",- " if isNothing pt || isTokenIn [layoutSep,layoutOpen] (fromJust pt) ",- " then moveAlong st [t0] ts",- " else let b:t0':ts' = addToken (afterPrev pt) layoutSep (t0:ts)",- " in moveAlong st [b,t0'] ts'",- " where newLine = case pt of",- " Nothing -> True",- " Just t -> line t /= line t0",- "",- " -- Nothing to see here, move along.",- " res _ st (t:ts) = moveAlong st [t] ts",- "",- " -- At EOF: skip explicit blocks.",- " res (Just t) (Explicit:bs) [] | null bs = []",- " | otherwise = res (Just t) bs []",- "",- " -- If we are using top-level layout, insert a semicolon after",- " -- the last token, if there isn't one already",- " res (Just t) [Implicit n] []",- " | isTokenIn [layoutSep] t = []",- " | otherwise = addToken (nextPos t) layoutSep []",- "",- " -- At EOF in an implicit, non-top-level block: close the block",- " res (Just t) (Implicit n:bs) [] =",- " let c = addToken (nextPos t) layoutClose []",- " in moveAlong bs c []",- "",- " -- This should only happen if the input is empty.",- " res Nothing st [] = []",- "",- " -- | Move on to the next token.",- " moveAlong :: [Block] -- ^ The layout stack.",- " -> [Token] -- ^ Any tokens just processed.",- " -> [Token] -- ^ the rest of the tokens.",- " -> [Token]",- " moveAlong st [] ts = error $ \"Layout error: moveAlong got [] as old tokens\"",- " moveAlong st ot ts = ot ++ res (Just $ last ot) st ts",- "",- "data Block = Implicit Int -- ^ An implicit layout block with its start column.",- " | Explicit ",- " deriving Show",- "",- "type Position = Posn",- "",- "-- | Check if s block is implicit.",- "isImplicit :: Block -> Bool",- "isImplicit (Implicit _) = True",- "isImplicit _ = False",- "",- "-- | Insert a number of tokens at the begninning of a list of tokens.",- "addTokens :: Position -- ^ Position of the first new token.",- " -> [String] -- ^ Token symbols.",- " -> [Token] -- ^ The rest of the tokens. These will have their",- " -- positions updated to make room for the new tokens .",- " -> [Token] ",- "addTokens p ss ts = foldr (addToken p) ts ss",- "",- "-- | Insert a new symbol token at the begninning of a list of tokens.",- "addToken :: Position -- ^ Position of the new token.",- " -> String -- ^ Symbol in the new token.",- " -> [Token] -- ^ The rest of the tokens. These will have their",- " -- positions updated to make room for the new token.", " -> [Token]",- "addToken p s ts = sToken p s : map (incrGlobal p (length s)) ts",- "",- "-- | Get the position immediately to the right of the given token.",- "-- If no token is given, gets the first position in the file.",- "afterPrev :: Maybe Token -> Position",- "afterPrev = maybe (Pn 0 1 1) nextPos",- "",- "-- | Get the position immediately to the right of the given token.",- "nextPos :: Token -> Position ",- "nextPos t = Pn (g + s) l (c + s + 1) ",- " where Pn g l c = position t",- " s = tokenLength t",- "",- "-- | Add to the global and column positions of a token.",- "-- The column position is only changed if the token is on",- "-- the same line as the given position.",- "incrGlobal :: Position -- ^ If the token is on the same line",- " -- as this position, update the column position.",- " -> Int -- ^ Number of characters to add to the position.",- " -> Token -> Token",- "incrGlobal (Pn _ l0 _) i (PT (Pn g l c) t) =",- " if l /= l0 then PT (Pn (g + i) l c) t",- " else PT (Pn (g + i) l (c + i)) t",- "incrGlobal _ _ p = error $ \"cannot add token at \" ++ show p",- "",- "-- | Create a symbol token.",- "sToken :: Position -> String -> Token",- "sToken p s = PT p (TS s i)",- " where",- " i = case s of"] ++- [ " " ++ show s ++ " -> " ++ show i- | (s, i) <- zip resws [1..]- ] ++- [" _ -> error $ \"not a reserved word: \" ++ show s",- "",- "-- | Get the position of a token.",- "position :: Token -> Position",- "position t = case t of",- " PT p _ -> p",- " Err p -> p",- "",- "-- | Get the line number of a token.",- "line :: Token -> Int",- "line t = case position t of Pn _ l _ -> l",- "",- "-- | Get the column number of a token.",- "column :: Token -> Int",- "column t = case position t of Pn _ _ c -> c",- "",- "-- | Check if a token is one of the given symbols.",- "isTokenIn :: [String] -> Token -> Bool",- "isTokenIn ts t = case t of",- " PT _ (TS r _) | elem r ts -> True",- " _ -> False",- "",- "-- | Check if a word is a layout start token.",- "isLayout :: Token -> Bool",- "isLayout = isTokenIn layoutWords",- "",- "-- | Check if a token is a layout stop token.",- "isStop :: Token -> Bool",- "isStop = isTokenIn layoutStopWords",- "",- "-- | Check if a token is the layout open token.",- "isLayoutOpen :: Token -> Bool",- "isLayoutOpen = isTokenIn [layoutOpen]",- "",- "-- | Check if a token is the layout close token.",- "isLayoutClose :: Token -> Bool",- "isLayoutClose = isTokenIn [layoutClose]",- "",- "-- | Get the number of characters in the token.",- "tokenLength :: Token -> Int",- "tokenLength t = length $ prToken t",-- ""- ]- where- resws = sort (reservedWords cf ++ symbols cf)
− src/formats/haskell2/CFtoPrinter.hs
@@ -1,189 +0,0 @@-{-- BNF Converter: Pretty-printer generator- Copyright (C) 2004 Author: Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoPrinter (cf2Printer) where--import CF-import Utils-import CFtoTemplate-import Data.List (intersperse)-import Data.Char(toLower)---- derive pretty-printer from a BNF grammar. AR 15/2/2002-cf2Printer :: Bool -> String -> String -> CF -> String-cf2Printer byteStrings name absMod cf = unlines [- prologue byteStrings name absMod,- integerRule cf,- doubleRule cf,- if hasIdent cf then identRule byteStrings cf else "",- unlines [ownPrintRule byteStrings cf own | (own,_) <- tokenPragmas cf],- rules cf- ]---prologue :: Bool -> String -> String -> String-prologue byteStrings name absMod = unlines [- "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}",- "module " ++ name +++ "where\n",- "-- pretty-printer generated by the BNF converter\n",- "import " ++ absMod,- "import Data.Char",- (if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""),- "",- "-- the top-level printing method",- "printTree :: Print a => a -> String",- "printTree = render . prt 0",- "",- "type Doc = [ShowS] -> [ShowS]",- "",- "doc :: ShowS -> Doc",- "doc = (:)",- "",- "render :: Doc -> String",- "render d = rend 0 (map ($ \"\") $ d []) \"\" where",- " rend i ss = case ss of",- " \"[\" :ts -> showChar '[' . rend i ts",- " \"(\" :ts -> showChar '(' . rend i ts",- " \"{\" :ts -> showChar '{' . new (i+1) . rend (i+1) ts",- " \"}\" : \";\":ts -> new (i-1) . space \"}\" . showChar ';' . new (i-1) . rend (i-1) ts",- " \"}\" :ts -> new (i-1) . showChar '}' . new (i-1) . rend (i-1) ts",- " \";\" :ts -> showChar ';' . new i . rend i ts",- " t : \",\" :ts -> showString t . space \",\" . rend i ts",- " t : \")\" :ts -> showString t . showChar ')' . rend i ts",- " t : \"]\" :ts -> showString t . showChar ']' . rend i ts",- " t :ts -> space t . rend i ts",- " _ -> id",- " new i = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace",- " space t = showString t . (\\s -> if null s then \"\" else (' ':s))",- "",- "parenth :: Doc -> Doc",- "parenth ss = doc (showChar '(') . ss . doc (showChar ')')",- "",- "concatS :: [ShowS] -> ShowS",- "concatS = foldr (.) id",- "",- "concatD :: [Doc] -> Doc",- "concatD = foldr (.) id",- "",- "replicateS :: Int -> ShowS -> ShowS",- "replicateS n f = concatS (replicate n f)",- "",- "-- the printer class does the job",- "class Print a where",- " prt :: Int -> a -> Doc",- " prtList :: [a] -> Doc",- " prtList = concatD . map (prt 0)",- "",- "instance Print a => Print [a] where",- " prt _ = prtList",- "",- "instance Print Char where",- " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')",- " prtList s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')",- "",- "mkEsc :: Char -> Char -> ShowS",- "mkEsc q s = case s of",- " _ | s == q -> showChar '\\\\' . showChar s",- " '\\\\'-> showString \"\\\\\\\\\"", - " '\\n' -> showString \"\\\\n\"",- " '\\t' -> showString \"\\\\t\"",- " _ -> showChar s",- "",- "prPrec :: Int -> Int -> Doc -> Doc",- "prPrec i j = if j<i then parenth else id",- ""- ]--integerRule cf = showsPrintRule cf "Integer"-doubleRule cf = showsPrintRule cf "Double"--showsPrintRule cf t = unlines $ [- "instance Print " ++ t ++ " where",- " prt _ x = doc (shows x)",- ifList cf t- ]--identRule byteStrings cf = ownPrintRule byteStrings cf "Ident"--ownPrintRule byteStrings cf own = unlines $ [- "instance Print " ++ own ++ " where",- " prt _ (" ++ own ++ posn ++ ") = doc (showString ("++stringUnpack++" i))",- ifList cf own- ]- where- posn = if isPositionCat cf own then " (_,i)" else " i"- - stringUnpack | byteStrings = "BS.unpack"- | otherwise = ""---- copy and paste from CFtoTemplate--rules :: CF -> String-rules cf = unlines $ - map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf- where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)- names [] _ = []- names (x:xs) n- | elem x xs = (x ++ show n) : names xs (n+1)- | otherwise = x : names xs n- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedHaskell = s ++ "'"- | otherwise = s- reservedHaskell = ["case","class","data","default","deriving","do","else","if",- "import","in","infix","infixl","infixr","instance","let","module",- "newtype","of","then","type","where","as","qualified","hiding"]- ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)----- case_fun :: Cat -> [(Constructor,Rule)] -> String-case_fun cat xs = unlines [- "instance Print" +++ cat +++ "where",- " prt i" +++ "e = case e of",- unlines $ map (\ ((c,xx),r) -> - " " ++ c +++ unwords xx +++ "->" +++ - "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs- ]--ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where- nil cat = [" [] -> " ++ mkRhs [] its | - Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]- one cat = [" [x] -> " ++ mkRhs ["x"] its | - Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]- cons cat = [" x:xs -> " ++ mkRhs ["x","xs"] its | - Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]- mkListRule [] = ""- mkListRule rs = unlines $ (" prtList" +++ "es = case es of"):rs---mkRhs args its = - "(concatD [" ++ unwords (intersperse "," (mk args its)) ++ "])"- where- mk args (Left "#" : items) = mk args items- mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items- mk args (Right s : items) = ("doc (showString" +++ show s ++ ")") : mk args items- mk _ _ = []- prt c = "prt" +++ show (precCat c)-
− src/formats/haskell2/CFtoTemplate.hs
@@ -1,114 +0,0 @@-{-- BNF Converter: Template Generator- Copyright (C) 2004 Author: Markus Forberg-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---module CFtoTemplate (- cf2Template- ) where--import CF-import Data.Char-import Data.List (delete)--type ModuleName = String-type Constructor = String--cf2Template :: ModuleName -> ModuleName -> ModuleName -> CF -> String-cf2Template skelName absName errName cf = unlines- [- "module "++ skelName ++ " where\n",- "-- Haskell module generated by the BNF converter\n",- "import " ++ absName,- "import " ++ errName,- "type Result = Err String\n",- "failure :: Show a => a -> Result",- "failure x = Bad $ \"Undefined case: \" ++ show x\n",- unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf- ]- where toArgs [] = []- toArgs ((cons,args):xs) - = (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs- names _ [] _ = []- names b (x:xs) n- | elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1)- | otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n)-{-- toArgs ((cons,args):xs) - = (cons ++ " " ++ names (map (checkRes . var) args) (0 :: Int)) : toArgs xs- names [] _ = []- names (x:xs) n- | elem x xs = (x ++ show n) ++ " " ++ names xs (n+1)- | otherwise = x ++ " " ++ names xs n--}- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedHaskell = s ++ "'"- | otherwise = s- reservedHaskell = ["case","class","data","default","deriving","do","else","if",- "import","in","infix","infixl","infixr","instance","let","module",- "newtype","of","then","type","where","as","qualified","hiding"]--{- -----cf2Template :: ModuleName -> CF -> String-cf2Template name cf = unlines- [- "module Skel"++ name ++ " where\n",- "-- Haskell module generated by the BNF converter\n",- "import Abs" ++ name,- "import ErrM",- "type Result = Err String\n",- "failure :: Show a => a -> Result",- "failure x = Bad $ \"Undefined case: \" ++ show x\n",- unlines $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf- ]- where toArgs [] = []- toArgs ((cons,args):xs) - = (cons ++ " " ++ names False (map (checkRes . var) args) (1 :: Int)) : toArgs xs- names _ [] _ = []- names b (x:xs) n- | elem x xs = (x ++ show n) ++ " " ++ names True xs (n+1)- | otherwise = (x ++ if b then show n else "") ++ " " ++ names b xs (if b then n+1 else n)- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedHaskell = s ++ "'"- | otherwise = s- reservedHaskell = ["case","class","data","default","deriving","do","else","if",- "import","in","infix","infixl","infixr","instance","let","module",- "newtype","of","then","type","where","as","qualified","hiding"]--}--case_fun :: Cat -> [Constructor] -> String-case_fun cat xs = - unlines $ - ["trans" ++ cat ++ " :: " ++ cat ++ " -> Result",- "trans" ++ cat ++ " x = case x of",- unlines $ map (\s -> " " ++ s ++ " -> " ++ "failure x") xs]-
− src/formats/haskell2/HaskellTop.hs
@@ -1,280 +0,0 @@-{-- BNF Converter: Haskell main file- Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module HaskellTop (makeAll, AlexMode(..)) where ------ import Utils-import Options-import CF-import CFtoHappy-import CFtoAlex-import CFtoAlex2-import CFtoAlex3-import CFtoLatex-import CFtoTxt-import CFtoAbstract-import CFtoTemplate-import CFtoPrinter-import CFtoLayout-import CFtoXML-import HsOpts-import ToCNF-import MkErrM-import MkSharedString-import Utils--import Data.Char-import Data.Maybe (fromMaybe,maybe)-import System.Exit (exitFailure)-import Control.Monad(when)---- naming conventions-----makeAll :: Options -> CF -> IO ()-makeAll opts cf = do- let absMod = absFileM opts- lexMod = alexFileM opts- parMod = happyFileM opts- prMod = printerFileM opts- layMod = layoutFileM opts- errMod = errFileM opts- shareMod = shareFileM opts- do- let dir = codeDir opts- when (not (null dir)) $ do- putStrLn $ "Creating directory " ++ dir- prepareDir dir- writeFileRep (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf- case alexMode opts of- Alex1 -> do- writeFileRep (alexFile opts) $ cf2alex lexMod errMod cf- putStrLn " (Use Alex 1.1 to compile.)" - Alex2 -> do- writeFileRep (alexFile opts) $ cf2alex2 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf- putStrLn " (Use Alex 2.0 to compile.)"- Alex3 -> do- writeFileRep (alexFile opts) $ cf2alex3 lexMod errMod shareMod (shareStrings opts) (byteStrings opts) cf- putStrLn " (Use Alex 3.0 to compile.)"- writeFileRep (happyFile opts) $ - cf2HappyS parMod absMod lexMod errMod (glr opts) (byteStrings opts) cf- putStrLn " (Tested with Happy 1.15)"- writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf- writeFileRep (txtFile opts) $ cfToTxt (lang opts) cf- writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf- writeFileRep (printerFile opts) $ cf2Printer (byteStrings opts) prMod absMod cf- when (hasLayout cf) $ writeFileRep (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf- writeFileRep (tFile opts) $ testfile opts cf- writeFileRep (errFile opts) $ errM errMod cf- when (shareStrings opts) $ writeFileRep (shareFile opts) $ sharedString shareMod (byteStrings opts) cf- when (make opts) $ writeFileRep "Makefile" $ makefile opts- case xml opts of- 2 -> makeXML (lang opts) True cf- 1 -> makeXML (lang opts) False cf- _ -> return ()- when (cnf opts) $ do - writeFileRep (cnfTablesFile opts) $ ToCNF.generate opts cf- writeFileRep "TestCNF.hs" $ ToCNF.genTestFile opts cf- writeFileRep "BenchCNF.hs" $ ToCNF.genBenchmark opts--codeDir :: Options -> FilePath-codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)- dir = if inDir opts then lang opts else ""- sep = if null pref || null dir then "" else [pathSep]- in pref ++ sep ++ dir --makefile :: Options -> String-makefile opts = makeA where- glr_params = if glr opts == GLR then "--glr --decode " else "" - dir = let d = codeDir opts in if null d then "" else d ++ [pathSep]- cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")"- makeA = unlines - [- "all:", - "\thappy -gca " ++ glr_params ++ happyFile opts, - "\talex -g " ++ alexFile opts,- "\t" ++ cd ("latex " ++ basename (latexFile opts)- ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)),- "\tghc --make " ++ tFile opts ++ " -o " ++ mkFile withLang "Test" "" opts,- "clean:",- "\t-rm -f " ++ unwords (map (dir++) [- "*.log", "*.aux", "*.hi", - "*.o", "*.dvi"- ]),- "\t-rm -f " ++ psFile opts,-- "distclean: clean",- "\t-rm -f " ++ unwords [- mkFile withLang "Doc" "*" opts,- mkFile withLang "Lex" "*" opts,- mkFile withLang "Par" "*" opts,- mkFile withLang "Layout" "*" opts,- mkFile withLang "Skel" "*" opts,- mkFile withLang "Print" "*" opts,- mkFile withLang "Test" "*" opts,- mkFile withLang "Abs" "*" opts,- mkFile withLang "Test" "" opts,- mkFile noLang "ErrM" "*" opts,- mkFile noLang "SharedString" "*" opts,- dir ++ lang opts ++ ".dtd",- mkFile withLang "XML" "*" opts, - "Makefile*"- ],- if null dir then "" else "\t-rmdir -p " ++ dir- ]---testfile :: Options -> CF -> String-testfile opts cf- = let lay = hasLayout cf - use_xml = xml opts > 0- xpr = if use_xml then "XPrint a, " else ""- use_glr = glr opts == GLR- if_glr s = if use_glr then s else ""- firstParser = if use_glr then "the_parser" else parserName- parserName = 'p' : topType- topType = firstEntry cf- in unlines- ["-- automatically generated by BNF Converter",- "module Main where\n",- "",- "import System.IO ( stdin, hGetContents )",- "import System.Environment ( getArgs, getProgName )",- "",- "import " ++ alexFileM opts,- "import " ++ happyFileM opts,- "import " ++ templateFileM opts,- "import " ++ printerFileM opts,- "import " ++ absFileM opts,- if lay then ("import " ++ layoutFileM opts) else "",- if use_xml then ("import " ++ xmlFileM opts) else "",- if_glr "import Data.FiniteMap(FiniteMap, lookupFM, fmToList)",- if_glr "import Data.Maybe(fromJust)",- "import " ++ errFileM opts,- "",- if use_glr- then "type ParseFun a = [[Token]] -> (GLRResult, GLR_Output (Err a))"- else "type ParseFun a = [Token] -> Err a",- "",- "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer",- "",- "type Verbosity = Int",- "",- "putStrV :: Verbosity -> String -> IO ()",- "putStrV v s = if v > 1 then putStrLn s else return ()",- "",- "runFile :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> FilePath -> IO ()",- "runFile v p f = putStrLn f >> readFile f >>= run v p",- "",- "run :: (" ++ xpr ++ if_glr "TreeDecode a, " ++ "Print a, Show a) => Verbosity -> ParseFun a -> String -> IO ()",- if use_glr then run_glr else run_std use_xml,- "",- "showTree :: (Show a, Print a) => Int -> a -> IO ()",- "showTree v tree",- " = do",- " putStrV v $ \"\\n[Abstract Syntax]\\n\\n\" ++ show tree",- " putStrV v $ \"\\n[Linearized tree]\\n\\n\" ++ printTree tree",- "",- "main :: IO ()",- "main = do args <- getArgs",- " case args of",- " [] -> hGetContents stdin >>= run 2 " ++ firstParser,- " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",- " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",- "",- if_glr $ "the_parser :: ParseFun " ++ topType,- if_glr $ "the_parser = lift_parser " ++ parserName,- if_glr $ "",- if_glr $ lift_parser- ]--run_std xml- = unlines - [ "run v p s = let ts = myLLexer s in case p ts of"- , " Bad s -> do putStrLn \"\\nParse Failed...\\n\""- , " putStrV v \"Tokens:\""- , " putStrV v $ show ts"- , " putStrLn s"- , " Ok tree -> do putStrLn \"\\nParse Successful!\""- , " showTree v tree"- , if xml then- " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"- else ""- ]--run_glr- = unlines - [ "run v p s"- , " = let ts = map (:[]) $ myLLexer s"- , " (raw_output, simple_output) = p ts in"- , " case simple_output of"- , " GLR_Fail major minor -> do"- , " putStrLn major"- , " putStrV v minor"- , " GLR_Result df trees -> do"- , " putStrLn \"\\nParse Successful!\""- , " case trees of"- , " [] -> error \"No results but parse succeeded?\""- , " [Ok x] -> showTree v x"- , " xs@(_:_) -> showSeveralTrees v xs"- , " where"- , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()"- , " showSeveralTrees v trees"- , " = sequence_ "- , " [ do putStrV v (replicate 40 '-')"- , " putStrV v $ \"Parse number: \" ++ show n"- , " showTree v t"- , " | (Ok t,n) <- zip trees [1..]"- , " ]"- ]- --lift_parser- = unlines - [ "type Forest = FiniteMap ForestId [Branch] -- omitted in ParX export."- , "data GLR_Output a"- , " = GLR_Result { pruned_decode :: (Forest -> Forest) -> [a]"- , " , semantic_result :: [a]"- , " }"- , " | GLR_Fail { main_message :: String"- , " , extra_info :: String"- , " }"- , ""- , "lift_parser"- , " :: (TreeDecode a, Show a, Print a)"- , " => ([[Token]] -> GLRResult) -> ParseFun a"- , "lift_parser parser ts"- , " = let result = parser ts in"- , " (\\o -> (result, o)) $"- , " case result of"- , " ParseError ts f -> GLR_Fail \"Parse failed, unexpected token(s)\\n\""- , " (\"Tokens: \" ++ show ts)"- , " ParseEOF f -> GLR_Fail \"Parse failed, unexpected EOF\\n\""- , " (\"Partial forest:\\n\""- , " ++ unlines (map show $ fmToList f))"- , " ParseOK r f -> let find f = fromJust . lookupFM f"- , " dec_fn f = decode (find f) r"- , " in GLR_Result (\\ff -> dec_fn $ ff f) (dec_fn f)"- ]
− src/formats/haskell2/HsOpts.hs
@@ -1,78 +0,0 @@-module HsOpts where--import Utils-import Options--type Options = SharedOptions--alex1 opts = alexMode opts == Alex1 --absFile, absFileM, alexFile, alexFileM, dviFile,- composOpFile, composOpFileM,- gfAbs, gfConc,- happyFile, happyFileM,- latexFile, errFile, errFileM,- templateFile, templateFileM, - printerFile, printerFileM,- layoutFile, layoutFileM, - psFile, tFile, tFileM :: Options -> String-absFile = mkFile withLangAbs "Abs" "hs"-absFileM = mkMod withLangAbs "Abs" -alexFile = mkFile withLang "Lex" "x"-alexFileM = mkMod withLang "Lex"-happyFile = mkFile withLang "Par" "y"-happyFileM = mkMod withLang "Par"-latexFile = mkFile withLang "Doc" "tex"-txtFile = mkFile withLang "Doc" "txt"-templateFile = mkFile withLang "Skel" "hs"-templateFileM = mkMod withLang "Skel"-printerFile = mkFile withLang "Print" "hs"-printerFileM = mkMod withLang "Print"-dviFile = mkFile withLang "Doc" "dvi"-psFile = mkFile withLang "Doc" "ps"-gfAbs = mkFile withLangAbs "" "Abs.gf"-gfConc = mkFile withLang "" "Conc.gf"-tFile = mkFile withLang "Test" "hs"-tFileM = mkMod withLang "Test"-errFile = mkFile noLang "ErrM" "hs"-errFileM = mkMod noLang "ErrM"-shareFile = mkFile noLang "SharedString" "hs"-shareFileM = mkMod noLang "SharedString"-layoutFileM = mkMod withLang "Layout"-layoutFile = mkFile withLang "Layout" "hs"-cnfTablesFile = mkFile withLang "CnfTables" "hs"-cnfTablesFileM= mkMod withLang "CnfTables" -xmlFileM = mkMod withLang "XML"-composOpFile = mkFile noLang "ComposOp" "hs"-composOpFileM = mkMod noLang "ComposOp"---noLang :: Options -> String -> String-noLang _ name = name--withLang :: Options -> String -> String-withLang opts name = name ++ lang opts--withLangAbs :: Options -> String -> String-withLangAbs opts name = postp $ name ++ lang opts- where- postp nam = if multi opts - then takeWhile (/='_') nam- else nam--pkgToDir :: String -> FilePath-pkgToDir s = replace '.' pathSep s---mkMod :: (Options -> String -> String) -> String -> Options -> String-mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name- where pref = maybe "" (++".") (inPackage opts)--mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath-mkFile addLang name ext opts = - pref ++ if inDir opts- then lang opts ++ [pathSep] ++ name ++ ext'- else addLang opts name ++ if null ext then "" else ext'- where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts)- ext' = if null ext then "" else "." ++ ext
− src/formats/haskell2/MkErrM.hs
@@ -1,51 +0,0 @@-{-- BNF Converter: Haskell error monad- Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie, - Aarne Ranta, Björn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}-module MkErrM where--errM :: String -> b -> String-errM errMod _ = unlines- [- "-- BNF Converter: Error Monad",- "-- Copyright (C) 2004 Author: Aarne Ranta",- "",- "-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.",- "module " ++ errMod ++ " where",- "",- "-- the Error monad: like Maybe type with error msgs",- "",- "import Control.Monad (MonadPlus(..), liftM)",- "",- "data Err a = Ok a | Bad String",- " deriving (Read, Show, Eq, Ord)",- "",- "instance Monad Err where",- " return = Ok",- " fail = Bad",- " Ok a >>= f = f a",- " Bad s >>= f = Bad s",- "",- "instance Functor Err where",- " fmap = liftM",- "",- "instance MonadPlus Err where",- " mzero = Bad \"Err.mzero\"",- " mplus (Bad _) y = y",- " mplus x _ = x"- ]
@@ -1,67 +0,0 @@-{-- BNF Converter: Haskell string sharing- Copyright (C) 2004-2007 Author: Björn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}-module MkSharedString where--sharedString :: String -> Bool -> b -> String-sharedString shareMod byteString _ = unlines $- if byteString- then- [- "module " ++ shareMod ++ " (shareString) where",- "",- "import Data.Map as M",- "import Data.IORef",- "import qualified Data.ByteString.Char8 as BS",- "import System.IO.Unsafe (unsafePerformIO)",- "",- "{-# NOINLINE stringPoolRef #-}",- "stringPoolRef :: IORef (M.Map BS.ByteString BS.ByteString)",- "stringPoolRef = unsafePerformIO $ newIORef M.empty",- "",- "{-# NOINLINE shareString #-}",- "shareString :: BS.ByteString -> BS.ByteString",- "shareString s = unsafePerformIO $ do",- " stringPool <- readIORef stringPoolRef",- " case M.lookup s stringPool of",- " Just s' -> return s'",- " Nothing -> do let s' = BS.copy s",- " writeIORef stringPoolRef $! M.insert s' s' stringPool",- " return s'"- ]- else- [- "module " ++ shareMod ++ " (shareString) where",- "",- "import Data.HashTable as H",- "import System.IO.Unsafe (unsafePerformIO)",- "",- "{-# NOINLINE stringPool #-}",- "stringPool :: HashTable String String",- "stringPool = unsafePerformIO $ new (==) hashString",- "",- "{-# NOINLINE shareString #-}",- "shareString :: String -> String",- "shareString s = unsafePerformIO $ do",- " mv <- H.lookup stringPool s",- " case mv of",- " Just s' -> return s'",- " Nothing -> do",- " H.insert stringPool s s",- " return s"- ]
− src/formats/haskell2/RegToAlex.hs
@@ -1,88 +0,0 @@-{-- BNF Converter: Regular expression pretty printer- Copyright (C) 2004 Author: BNF Converter, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module RegToAlex (printRegAlex) where---- modified from pretty-printer generated by the BNF converter--import AbsBNF-import Data.Char---- the top-level printing method-printRegAlex :: Reg -> String-printRegAlex = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend (0::Int) where- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ " " ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = if isAlphaNum c then [[c]] else ['^':[c]]- prtList s = map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["$"])- RChar c -> prPrec i 3 (concat [prt 0 c])- RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) str))- RDigit -> prPrec i 3 (concat [["^d"]])- RLetter -> prPrec i 3 (concat [["^l"]])- RUpper -> prPrec i 3 (concat [["^c"]])- RLower -> prPrec i 3 (concat [["^s"]])- RAny -> prPrec i 3 (concat [["^u"]])---
− src/formats/haskell2/ToCNF.hs
@@ -1,472 +0,0 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}-{-- Copyright (C) 2012 Authors: - Jean-Philippe Bernardy.-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{-# LANGUAGE OverloadedStrings #-}--module ToCNF (generate, genTestFile, genBenchmark) where--{---Construction of CYK tables. The algorithm follows:--Lange, Martin; Leiß, Hans (2009), "To CNF or not to CNF? An Efficient-Yet Presentable Version of the CYK Algorithm", Informatica Didactica---}--import CF hiding (App,Exp)-import HsOpts-import Control.Monad.RWS-import Control.Applicative hiding (Const)-import qualified Data.Map as M-import Data.List (nub,intercalate,sortBy,sort)-import Data.Maybe (maybeToList)-import Data.Function (on)-import Data.Char (isAlphaNum,ord)-import Data.String-import Data.Pair-import Text.PrettyPrint.HughesPJ hiding (first,(<>))--(f *** g) (a,b) = (f a, g b)-second g = id *** g--onRules f (CFG (exts,rules)) = CFG (exts,f rules)--toCNF cf0 = (cf1,cf2,units,descriptions)- where cf01@(CFG (exts01,_)) = funToExp . onRules delInternal $ cf0- (rules',descriptions) = toBin (rulesOfCF cf01) - cf1 = CFG (exts01,rules')- cf2 = delNull cf1- units = unitSet cf2- -funToExp :: CFG Fun -> CFG Exp-funToExp = fmap toExp--delInternal = filter (not . isInternalRhs . rhsRule)- where isInternalRhs (Left c:_) = c == internalCat- isInternalRhs _ = False------------------------------------------------------------------- BIN: make sure no rule has more than 2 symbols on the rhs--allocateCatName = do- n <- get- put (1+n)- return $ show n--toBin :: [Rul Exp] -> ([Rul Exp], CatDescriptions)-toBin cf = (a,w)- where (a,_,w) = runRWS (concat <$> forM cf toBinRul) () 0- -type CatDescriptions = M.Map Cat Doc---- | Convert a rule into a number of equivalent rules with at most 2--- symbols on the rhs.--- Also writes an explanation of what new categories are.-toBinRul :: Rul Exp -> RWS () CatDescriptions Int [Rul Exp]-toBinRul (Rule f cat rhs) | length rhs > 2 = do- cat' <- allocateCatName- r' <- toBinRul $ Rule f cat' p- tell $ M.singleton cat' (int (length p) <> "-prefix of " <> prettyExp f <> " " <> parens (prettyRHS p))- return $ Rule (Con "($)") cat [Left cat',l]- : r'- where l = last rhs- p = init rhs- fun' = case l of- Left _ -> Con "($)" -- in this case we have to apply the final argument to the partial result- Right _ -> Con "const" -- in this case the 2nd argument must be ignored (it is not present in the result).-toBinRul r = return [r]--prettyRHS = hcat . punctuate " " . map (either text (quotes . text))-------------------------------- Fixpoint utilities--x ∪ y = sort $ nub (x ++ y)- -lk cat nullset = maybe [] id (M.lookup cat nullset)- -type Set k x = M.Map k [x]--fixpointOnGrammar :: (Show k, Show x,Ord k, Ord x) => String -> (Set k x -> Rul f -> Set k x) -> CFG f -> Set k x-fixpointOnGrammar name f cf = case fixn 100 step M.empty of- Left x -> error $ "Could not find fixpoint of " ++ name ++". Last iteration:\n" ++ show x- Right x -> x- where step curSet = M.unionsWith (∪) (map (f curSet) (rulesOfCF cf))--fixn :: Eq a => Int -> (a -> a) -> a -> Either a a-fixn 0 f x = Left x-fixn n f x = if x' == x then Right x else fixn (n-1) f x'- where x' = f x- ----------------------------------------------------------- DEL : make sure no rule has 0 symbol on the rhs--type Nullable = Set Cat Exp--cross :: [[a]] -> [[a]]-cross [] = [[]]-cross (x:xs) = [y:ys | y <- x, ys <- cross xs]--nullRule :: Nullable -> Rul Exp -> (Cat,[Exp])-nullRule nullset (Rule f c rhs) = (c, map (\xs -> (appMany f xs)) (cross (map nulls rhs)))- where nulls (Right tok) = []- nulls (Left cat) = lk cat nullset--nullable :: Nullable -> Rul Exp -> Bool-nullable s = not . null . snd . nullRule s--nullSet :: CFG Exp -> Nullable -nullSet = fixpointOnGrammar "nullable" (\s r -> uncurry M.singleton (nullRule s r))---- | Replace nullable occurences by nothing, and adapt the function consequently.-delNullable :: Nullable -> Rul Exp -> [Rul Exp]-delNullable nullset r@(Rule f cat rhs) = case rhs of- [] -> []- [_] -> [r] - [r1,r2] -> [r] ++ [Rule (app' f x) cat [r2] | x <- lk' r1]- ++ [Rule (app2 (isCat r1) f x) cat [r1] | x <- lk' r2]- _ -> error $ "Panic:" ++ show r ++ "should have at most two elements."- where lk' (Right tok) = []- lk' (Left cat) = lk cat nullset- - -delNull cf = onRules (concatMap (delNullable (nullSet cf))) cf--------------------- UNIT--type UnitRel cat = Set (Either cat String) (Exp,cat)---- (c,(f,c')) ∈ unitSet ⇒ f : c → c'--unitSet :: CFG Exp -> UnitRel Cat-unitSet = fixpointOnGrammar "unit set" unitRule --unitRule unitSet (Rule f c [r]) = M.singleton r $ (f,c) : [(g `appl` f,c') | (g,c') <- lk (Left c) unitSet]- where appl = case r of- Left _ -> after- Right _ -> app'-unitRule _ _ = M.empty--isUnitRule (Rule f c [r]) = True-isUnitRule _ = False------------------------------ Left/Right occurences--isOnLeft, isOnRight :: RHSEl -> Rul f -> Bool-isOnLeft c (Rule f _ [c',_]) = c == c'-isOnLeft _ _ = False--isOnRight c (Rule f _ [_,c']) = c == c'-isOnRight _ _ = False--isEntryPoint cf el = either (`elem` allEntryPoints cf) (const False) el--occurs :: (RHSEl -> Rul f -> Bool) -> RHSEl -> CFG f -> Bool-occurs where_ el cf = any (where_ el) (rulesOfCF cf)--splitLROn :: (a -> RHSEl) -> CFG f -> [a] -> Pair [a]-splitLROn f cf xs = filt <*> pure xs- where filt = filter (\c -> occurs isOnLeft (f c) cf || isEntryPoint cf (f c)) :/: - filter (\c -> occurs isOnRight (f c) cf)- -isSpecial (Left ('@':'@':_)) = True-isSpecial _ = False- -optim :: (a -> RHSEl) -> Pair [a] -> Pair [(a,Doc -> Doc)]-optim f (x:/:y) = map modif x :/: map modif' y- where modif a | isSpecial (f a) = (a,\x -> "(if not p then (" <> x <> ":) else id)")- | otherwise = (a,rob) - modif' a | isSpecial (f a) = (a,\x -> "(if p then (" <> x <> ":) else id)")- | otherwise = (a,rob)- rob x = "("<> x <> ":)"- --splitOptim f cf xs = optim f $ splitLROn f cf $ xs--------------------------------- Error reporting---- leftOf C = ⋃ { {X} ∪ leftOf X | C ::= X B ∈ Grammar or C ::= X ∈ Grammar }-leftRight pos s (Rule f c rhs) = M.singleton c (lkCat x s)- where x = pos rhs--lkCat (Right t) s = [Right t]-lkCat (Left c) s = Left c:lk c s- --- neighbors A B = ∃ A' B'. A ∈ rightOf A' ∧ B ∈ leftOf B-neighborSet cf = map (second (nub . sort)) $ group' [(x',lkCat y leftSet) | Rule _ _ [x,y] <- rulesOfCF cf, x' <- lkCat x rightSet]- where leftSet = fixpointOnGrammar "left set" (leftRight head) cf- rightSet = fixpointOnGrammar "right set" (leftRight last) cf--genNeighborSet cf = vcat - ["neighbors " <> catTag x <> " = " <> ppList (map catTag y) - | (x,y) <- neighborSet cf] $$- "neighbors _ = []"--ppList = brackets . punctuate' ", " ------------------------------ Code generation--incomment x = "{-" <> x <> "-}"--generate opts cf0 = render $ vcat [header opts- ,genShowFunction cf0- ,genCatTags cf1- ,genDesc cf1 descriptions- ,genNeighborSet cf1 - ,genCombTable units (onRules (filter (not . isUnitRule)) cf)- ,genTokTable units cf- ,incomment $ vcat - ["Normalised grammar:"- ,text $ show cf- ,"Unit relation:"- ,prettyUnitSet units- ]- ]- where (cf1,cf,units,descriptions) = toCNF cf0--class Pretty a where- pretty :: a -> Doc--instance (Pretty k, Pretty v) => Pretty (Set k v) where- pretty s = sep [pretty k <> " --> " <> pretty v | (k,x) <- M.assocs s, v <- x] --instance Pretty (Either Cat String) where- pretty (Left x) = text x- pretty (Right x) = quotes $ text x--instance Pretty String where- pretty = text--prettyUnitSet units = vcat [prettyExp f <> " : " <> catTag cat <> " --> " <> text cat' | (cat,x) <- M.assocs units, (f,cat') <- x] --header opts- = vcat ["{-# LANGUAGE MagicHash, FlexibleInstances #-}"- ,"module " <> text (cnfTablesFileM opts) <> " where"- ,"import GHC.Prim"- ,"import GHC.Exts"- ,"import Control.Applicative hiding (Const)"- ,"import Algebra.RingUtils"- ,"import Parsing.Chart ()"- ,"import " <> text (absFileM opts)- ,"import " <> text (alexFileM opts)- ,"import " <> text ( printerFileM opts)- ,"readInteger :: String -> Integer"- ,"readInteger = read"- ,"readDouble :: String -> Double"- ,"readDouble = read"- ,"instance RingP [(CATEGORY,Any)] where"- ," mul p a b = trav [map (app tx ty) l :/: map (app tx ty) r | (x,tx) <- a, (y,ty) <- b, let l:/:r = combine p x y]"- ," where trav :: [Pair [a]] -> Pair [a]"- ," trav [] = pure []"- ," trav (x:xs) = (++) <$> x <*> trav xs"- ," app tx ty (z,f) = (z, f tx ty)"- ]--punctuate' p = cat . punctuate p--genShowFunction cf = hang "showAst (cat,ast) = case cat of " 6 - (vcat [catTag (Left cat) <> " -> printTree ((unsafeCoerce# ast)::" <> text cat <> ")"- | cat <- filter isDataCat $ allCats cf] $$ - "_ -> \"Unprintable category\"")---genCatTags :: CFG Exp -> Doc-genCatTags cf = "data CATEGORY = " <> punctuate' "|" (map catTag (allSyms cf)) $$- " deriving (Eq,Ord,Show)"--genDesc :: CFG Exp -> CatDescriptions -> Doc-genDesc cf descs = vcat ["describe " <> catTag s <> " = " <> doubleQuotes (descOf s) | s <- allSyms cf]- where descOf (Right x) = "token " <> text x- descOf (Left x) = maybe (text x) id $ M.lookup x descs- - --genCombTable :: UnitRel Cat -> CFG Exp -> Doc-genCombTable units cf = - "combine :: Bool -> CATEGORY -> CATEGORY -> Pair [(CATEGORY, Any -> Any -> Any)]"- $$ genCombine units cf- $$ "combine _ _ _ = pure []"--allSyms :: CFG Exp -> [Either String String]-allSyms cf = map Left (allCats cf ++ literals cf) ++ map (Right . fst) (cfTokens cf)- --ppPair (x,y) = parens $ x <> comma <> " " <> y--unsafeCoerce' = app' (Con "unsafeCoerce#")--type RHSEl = Either Cat String--isCat (Right _) = False-isCat (Left _) = True--group0 :: Eq a => [(a,[b])] -> [(a,[b])]-group0 [] = []-group0 ((a,bs):xs) = (a,bs ++ concatMap snd ys) : group0 zs- where (ys,zs) = span (\x -> fst x == a) xs--group' :: Ord a => [(a,[b])] -> [(a,[b])]-group' = group0 . sortBy (compare `on` fst)--prettyPair (x :/: y) = sep [x,":/:",y]-prettyListFun xs = parens $ sep (map (<> "$") xs) <> "[]"---genCombine :: UnitRel Cat -> CFG Exp -> Doc-genCombine units cf = vcat $ map genEntry $ group' $ map (alt units) (rulesOfCF cf)- where genEntry :: ((RHSEl,RHSEl),[(Cat,Exp)]) -> Doc- genEntry ((r1,r2),cs) = "combine p " <> catTag r1 <> " " <> catTag r2 <> " = " <> prettyPair (genList <$> splitOptim (Left . fst) cf cs)- mkLam body = "\\x y -> " <> body- genList xs = prettyListFun [p (ppPair (catTag . Left $ x, mkLam . prettyExp . unsafeCoerce' $ y)) | ((x,y),p) <- xs]--alt :: UnitRel Cat -> Rul Exp -> ((RHSEl,RHSEl),[(Cat,Exp)])-alt units (Rule f c [r1,r2]) = ((r1,r2),initial:others)- where initial = (c, f `appMany` args)- others = [(c', f' `app'` (f `appMany` args)) | (f',c') <- lk (Left c) units]- args = map (unsafeCoerce' . Con) $ ["x"|isCat r1]++["y"|isCat r2]- --catTag :: Either String String -> Doc-catTag (Left c) = "CAT_" <> text (concatMap escape c)-catTag (Right t) = "TOK_" <> text (concatMap escape t)--escape c | isAlphaNum c || c == '_' = [c]-escape '[' = ""-escape ']' = "_List"-escape '{' = "OPEN_"-escape '}' = "CLOS_"-escape '@' = "BIN_"-escape c = show $ ord c--genTokTable :: UnitRel Cat -> CFG Exp -> Doc-genTokTable units cf = "tokenToCats :: Bool -> Token -> Pair [(CATEGORY,Any)]" $$- vcat (map (genSpecEntry cf units) (tokInfo cf)) $$- vcat (map (genTokEntry cf units) (cfTokens cf)) $$- "tokenToCats p t = error (\"unknown token: \" ++ show t)"--tokInfo cf = ("Char","TC",Con "head"):- ("String","TL",Id):("Integer","TI",Con "readInteger"):- ("Double","TD",Con "readDouble"):- [("Ident","TV",Con "Ident")|hasIdent cf] ++- [(t,"T_" <> text t,(Con t)) | t <- tokenNames cf]--genTokCommon cf xs = prettyPair (gen <$> splitOptim fst cf xs)- where gen ys = prettyListFun [p (ppPair (catTag x,y)) | ((x,y),p) <- ys]--genSpecEntry cf units (tokName,constrName,fun) = "tokenToCats p (PT (Pn _ l c) (" <> constrName <> " x)) = " <> genTokCommon cf xs- where xs = map (second (prettyExp . (\f -> unsafeCoerce' (f `app'` tokArgs)))) $ - (Left tokName, fun) : [(Left c,f `after` fun) | (f,c) <- lk (Left tokName) units]- tokArgs | isPositionCat cf tokName = Con "((l,c),x)"- | otherwise = Con "x"--genTokEntry cf units (tok,x) = - " -- " <> text tok $$- "tokenToCats p (PT posn (TS _ " <> int x <> ")) = " <> genTokCommon cf xs- where xs = (Right tok, tokVal) : - [(Left c,prettyExp (unsafeCoerce' f)) | (f,c) <- lk (Right tok) units]- tokVal = "error" <> (text $ show $ "cannot access value of token: " ++ tok)- ------------------------- --- Test file generation--genTestFile opts cf = render $ vcat- ["module Main where"- ,"import " <> text ( alexFileM opts)- ,"import " <> text ( cnfTablesFileM opts)- ,"import Parsing.TestProgram"- ,"main = mainTest showAst tokenToCats tokens tokenLineCol describe neighbors"]---genBenchmark opts = render $ vcat- ["import System.Environment ( getArgs )"- ,"import "<> text ( alexFileM opts) <> " as Lexer"- ,"import "<> text ( cnfTablesFileM opts) <> " as Parser"- ,"import GHC.Exts"- ,"import Parsing.Chart"- ,"import Criterion.Main"- ,"import Algebra.RingUtils"- ,"import Control.Applicative"- ,"type T = [(CATEGORY,Any)]"- ,"pLGrammar :: [Pair T] -> MT2 T"- ,"pLGrammar = mkTree"- ,"main = do"- ," f:_ <- getArgs"- ," s <- readFile f"- ," let ts = zipWith tokenToCats (cycle [False,True]) (Lexer.tokens s)"- ," (ts1,x:ts2) = splitAt (length ts `div` 2) ts"- ," cs = [mkTree ts1,mkTree' ts2]"- ," work [c1,c2] = show $ map fst $ root $ mergein False c1 x c2"- ," defaultMain [bench f $ nf work cs] -- note the hack!!!"- ]--- ---------------------------------- --- Management of expressions. ---- Most of this is not strictly useful; its main purpose is to--- generate "nice-looking" semantic actions--data Exp = Id -- identity function- | Con String -- constructor or variable- | App Exp Exp- | Exp `After` Exp- | App2 Exp Exp- deriving (Eq,Ord)--prettyExp Id = "id"-prettyExp (Con x) = text x-prettyExp (App f x) = prettyExp f <+> (parens $ prettyExp x)-prettyExp (App2 f x) = "flip" <+> parens (prettyExp f) <+> parens (prettyExp x)-prettyExp (f `After` g) = parens (prettyExp f) <> "." <> parens (prettyExp g)--instance Show Exp where show = render . prettyExp---- | Apply in 2nd position if the flag is true, otherwise apply normally.-app2 True f x = App2 f x-app2 False f x = app' f x--infixl `app'`-app' :: Exp -> Exp -> Exp-app' (f `After` g) x = app' f (app' g x)-app' Id x = x-app' (App2 f y) x = (f `app'` x) `app'` y-app' (Con "($)") f = f--- app' (Con "const") f = f-app' f x = App f x--toExp f | isCoercion f = Id- | otherwise = Con f --after :: Exp -> Exp -> Exp-after Id f = f-after f Id = f-after f g = f `After` g---appMany f args = foldl app' f args
− src/formats/java/CFtoCup.hs
@@ -1,282 +0,0 @@-{-- BNF Converter: Java Cup Generator- Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the CUP input file. It- follows the same basic structure of CFtoHappy.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 26 April, 2003 -- Modified : 2 September, 2003 -- - ************************************************************** --}-module CFtoCup ( cf2Cup ) where--import CF-import Data.List (intersperse, isPrefixOf)-import Data.Char (isUpper)-import NamedVariables-import TypeChecker -- We need to (re-)typecheck to figure out list instances in- -- defined rules.-import ErrM-import Utils ( (+++) )---- Type declarations-type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String----The environment comes from the CFtoJLex-cf2Cup :: String -> String -> CF -> SymEnv -> String-cf2Cup packageBase packageAbsyn cf env = unlines - [- header,- declarations packageAbsyn (allCats cf),- tokens env,- specialToks cf,- specialRules cf,- prEntryPoint cf,- prRules (rulesForCup packageAbsyn cf env)- ]- where- header :: String- header = unlines - ["// -*- Java -*- This Cup file was machine-generated by BNFC",- "package" +++ packageBase ++ ";",- "",- "import java_cup.runtime.*;",- "import" +++ packageAbsyn ++ ".*;",- "",- "parser code {:",- parseMethod packageAbsyn (firstEntry cf),- definedRules packageAbsyn cf,- -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf),- "public void syntax_error(Symbol cur_token)",- "{",- "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);",- "}",- "",- "public void unrecovered_syntax_error(Symbol cur_token) throws java.lang.Exception",- "{",- "\tthrow new Exception(\"Unrecoverable Syntax Error\");",- "}",- "",- ":}"- ]--definedRules :: String -> CF -> String-definedRules packageAbsyn cf =- unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]- where- ctx = buildContext cf-- list = LC (const "null") (\t -> "List" ++ unBase t)- where- unBase (ListT t) = unBase t- unBase (BaseT x) = normCat x-- rule f xs e =- case checkDefinition' list ctx f xs e of- Bad err -> error $ "Panic! This should have been caught already:\n" ++ err- Ok (args,(e',t)) -> unlines- [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++- concat (intersperse ", " $ map javaArg args) ++ ") {"- , " return " ++ javaExp e' ++ ";"- , "}"- ]- where-- javaType :: Base -> String- javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x- javaType (ListT t) = javaType t- javaType (BaseT x)- | isToken x ctx = "String"- | otherwise = packageAbsyn ++ "." ++ normCat x-- javaArg :: (String, Base) -> String- javaArg (x,t) = javaType t ++ " " ++ x ++ "_"-- javaExp :: Exp -> String- javaExp (App "null" []) = "null"- javaExp (App x [])- | elem x xs = x ++ "_" -- argument- javaExp (App t [e])- | isToken t ctx = call ("new String") [e]- javaExp (App x es)- | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es- | otherwise = call (x ++ "_") es- javaExp (LitInt n) = "new Integer(" ++ show n ++ ")"- javaExp (LitDouble x) = "new Double(" ++ show x ++ ")"- javaExp (LitChar c) = "new Character(" ++ show c ++ ")"- javaExp (LitString s) = "new String(" ++ show s ++ ")"-- call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")"---- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.-prEntryPoint :: CF -> String-prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""]--- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""]--- eps -> error $ "FIXME multiple entry points." ++ show eps----This generates a parser method for each entry point.-parseMethod :: String -> Cat -> String-parseMethod packageAbsyn cat = - if normCat cat /= cat- then ""- else unlines- [- " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()"- ++ " throws Exception",- " {",- "\tSymbol res = parse();",- "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", - " }"- ]- where cat' = identCat (normCat cat)----non-terminal types-declarations :: String -> [NonTerminal] -> String-declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns)- where- typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "."- ++ identCat (normCat nt) +++ identCat nt ++ ";"----terminal types-tokens :: SymEnv -> String-tokens ts = unlines (map declTok ts)- where- declTok (s,r) = "terminal" +++ r ++ "; // " ++ s--specialToks :: CF -> String-specialToks cf = unlines [ - ifC "String" "terminal String _STRING_;",- ifC "Char" "terminal Character _CHAR_;",- ifC "Integer" "terminal Integer _INTEGER_;",- ifC "Double" "terminal Double _DOUBLE_;",- ifC "Ident" "terminal String _IDENT_;"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""---- This handles user defined tokens--- FIXME-specialRules:: CF -> String-specialRules cf =- unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf]----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForCup :: String -> CF -> SymEnv -> Rules-rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where- mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat---- For every non-terminal, we construct a set of rules. A rule is a sequence of--- terminals and non-terminals, and an action to be performed.-constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule packageAbsyn cf env rules nt =- (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m))- | r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True, revSepListRule r0) - else (False, r0)- (p,m) = generatePatterns cf env r])- where- --this basically reverses revSepListRule for the parameters- revM False m = m- revM True (h:c:t) = (t ++ [c] ++ [h])- revs = reversibleCats cf---- Generates a string containing the semantic action.-generateAction :: String -> NonTerminal -> Fun -> [MetaVar] -> Action-generateAction packageAbsyn nt f ms =- if isNilFun f- then "RESULT = null;"- else if isOneFun f- then "RESULT = new " ++ packageAbsyn ++ "." ++ identCat (normCat nt) ++- (concat $ ["("] ++ ms ++ [",null);"])- else- (unwords $- (if isCoercion f then [unwords revLists, "RESULT = "] - else if isDefinedRule f then [unwords revLists, "RESULT = parser." ++ f ++ "_"]- else [unwords revLists, "RESULT = new " ++ packageAbsyn ++ "." ++ f']- )) - ++ (concat $ ["("] ++ ms'' ++ [");"])- where- f' = if isConsFun f then identCat (normCat nt)- else f- (revLists, ms') = revMs [] [] ms- ms'' = reverse ms'- revMs ls ns [] = (ls,ns)- revMs ls ns (m:ms) = if "list_" `isPrefixOf` m- then revMs (("if (" ++ m' ++ " != null) " ++ m' ++ " = " ++ m' ++ ".reverse(); ") : ls)- (m' : ns) ms- else revMs ls (m:ns) ms- where m' = drop 5 m --remove the list marker---- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])-generatePatterns cf env r = case rhsRule r of- [] -> (" /* empty */ ",[])- its -> (mkIt env 1 its, metas its) - where- mkIt _env _n [] = []- mkIt env n (i:is) = case i of- Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is)- where - c' = case c of- "Ident" -> "_IDENT_"- "Integer" -> "_INTEGER_"- "Char" -> "_CHAR_"- "Double" -> "_DOUBLE_"- "String" -> "_STRING_"- _ -> identCat c- Right s -> case (lookup s env) of- (Just x) -> x +++ (mkIt env (n+1) is)- (Nothing) -> (mkIt env n is)- metas its = intersperse "," [revIf c ("p_" ++ (show i)) | (i,Left c) <- zip [1 :: Int ..] its]- --This is slightly messy, but it marks lists for reversal.- revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then "list_" ++ m -- ("(reverse " ++ m ++ ")") --not yet!- else m -- no reversal in the left-recursive Cons rule itself- revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.-prRules :: Rules -> String-prRules [] = []-prRules ((nt, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls-
− src/formats/java/CFtoJLex.hs
@@ -1,174 +0,0 @@-{-- BNF Converter: Java JLex generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the JLex input file. This- file is quite different than Alex or Flex.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 25 April, 2003 -- Modified : 2 September, 2003 -- - ************************************************************** --}--module CFtoJLex ( cf2jlex ) where--import CF-import RegToJLex-import Utils ( (+++) )-import NamedVariables-import Data.List----The environment must be returned for the parser to use.-cf2jlex :: String -> String -> CF -> (String, SymEnv)-cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ - [- prelude packageBase packageAbsyn,- cMacros,- lexSymbols env,- restOfJLex cf- ], env)- where- env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)- makeSymEnv [] _ = []- makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))- -prelude :: String -> String -> [String]-prelude packageBase packageAbsyn =- [- "// This JLex file was machine-generated by the BNF converter",- "package" +++ packageBase ++ ";",- "",- "import java_cup.runtime.*;",- "import " ++ packageAbsyn ++ ".*;",- "%%",- "%cup",- "%full",- "%line",- "%{",- " String pstring = new String();",- " public int line_num() { return (yyline+1); }",- " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }",- "%}"- ]----For now all categories are included.---Optimally only the ones that are used should be generated.-cMacros :: [String]-cMacros = [- "LETTER = ({CAPITAL}|{SMALL})",- "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]",- "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]",- "DIGIT = [0-9]",- "IDENT = ({LETTER}|{DIGIT}|['_])",- "%state COMMENT",- "%state CHAR",- "%state CHARESC",- "%state CHAREND",- "%state STRING",- "%state ESCAPED",- "%%"- ]--lexSymbols :: SymEnv -> [String]-lexSymbols ss = map transSym ss- where- transSym (s,r) = - "<YYINITIAL>" ++ (escapeChars s) ++ " { return new Symbol(sym." - ++ r ++ "); }"--restOfJLex :: CF -> [String]-restOfJLex cf =- [- lexComments (comments cf),- userDefTokens,- ifC "String" strStates,- ifC "Char" chStates,- ifC "Double" "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }",- ifC "Integer" "<YYINITIAL>{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }",- ifC "Ident" "<YYINITIAL>{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, new String(yytext())); }"- , "<YYINITIAL>[ \\t\\r\\n\\f] { /* ignore white space. */ }"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""- userDefTokens = unlines $- ["<YYINITIAL>" ++ printRegJLex exp +++ - "{ return new Symbol(sym." ++ name ++ ", yytext()); }"- | (name, exp) <- tokenPragmas cf]- strStates = unlines --These handle escaped characters in Strings.- [- "<YYINITIAL>\"\\\"\" { yybegin(STRING); }",- "<STRING>\\\\ { yybegin(ESCAPED); }",- "<STRING>\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo); }",- "<STRING>. { pstring += yytext(); }",- "<ESCAPED>n { pstring += \"\\n\"; yybegin(STRING); }",- "<ESCAPED>\\\" { pstring += \"\\\"\"; yybegin(STRING); }",- "<ESCAPED>\\\\ { pstring += \"\\\\\"; yybegin(STRING); }",- "<ESCAPED>t { pstring += \"\\t\"; yybegin(STRING); }",- "<ESCAPED>. { pstring += yytext(); yybegin(STRING); }"- ]- chStates = unlines --These handle escaped characters in Chars.- [- "<YYINITIAL>\"'\" { yybegin(CHAR); }",- "<CHAR>\\\\ { yybegin(CHARESC); }",- "<CHAR>[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",- "<CHARESC>n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }",- "<CHARESC>t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }",- "<CHARESC>. { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",- "<CHAREND>\"'\" {yybegin(YYINITIAL);}"- ]-----lexComments :: ([(String, String)], [String]) -> String-lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m))--lexSingleComment :: String -> String-lexSingleComment c = - "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }"----There might be a possible bug here if a language includes 2 multi-line comments.---They could possibly start a comment with one character and end it with another.---However this seems rare.-lexMultiComment :: (String, String) -> String-lexMultiComment (b,e) = unlines [- "<YYINITIAL>\"" ++ b ++ "\" { yybegin(COMMENT); }",- "<COMMENT>\"" ++ e ++ "\" { yybegin(YYINITIAL); }",- "<COMMENT>. { }",- "<COMMENT>[\\n] { }"- ]- --- lexReserved :: String -> String--- lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }"----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars = concatMap escapeChar
− src/formats/java/CFtoJavaAbs.hs
@@ -1,238 +0,0 @@-{-- BNF Converter: Java Abstract Syntax- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Java Abstract Syntax- It uses the NamedVariables module for variable- naming. It returns a list of file names, and the- contents to be written into that file. (In Java- public classes must go in their own file.)- - The generated classes also support the Visitor- Design Pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 24 April, 2003 -- Modified : 2 September, 2003 -- - ************************************************************** --}--module CFtoJavaAbs (cf2JavaAbs) where--import CF-import Utils((+++),(++++))-import NamedVariables hiding (IVar, getVars, varName)-import Data.List-import Data.Char(toLower)----Produces abstract data types in Java.---These follow Appel's "non-object oriented" version.---They also allow users to use the Visitor design pattern.--type IVar = (String, Int, String)---The type of an instance variable---a # unique to that type---and an optional name (handles typedefs).----The result is a list of files which must be written to disk.---The tuple is (FileName, FileContents)-cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)]-cf2JavaAbs packageBase packageAbsyn cf =- concat (map (prData header packageBase user) (cf2dataLists cf))- where- header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n"- user = [n | (n,_) <- tokenPragmas cf]----Generates a (possibly abstract) category class, and classes for all its rules.-prData :: String -> String -> [UserDef] -> Data ->[(String, String)]-prData header name user (cat, rules) =- (identCat cat, header ++++- "public abstract class" +++ (identCat cat) +++ "implements" +++ name ++ ".Visitable {}\n") :- prRules header name user cat rules --don't use map because some will be Nil- where- prRules h n u c [] = [] --this is basically a map which excludes Nil values.- prRules h n u c (f:fs) = case res of- ("","") -> prRules h n u c fs- z -> res : (prRules h n u c fs)- where res = prRule h n u c f----Generates classes for a rule, depending on what type of rule it is.-prRule h name user c (fun, cats) = - if isNilFun fun || isOneFun fun- then ("","") --these are not represented in the AbSyn- else if isConsFun fun- then (fun', --this is the linked list case.- unlines- [- h,- "public class" +++ fun' +++ "implements"+++ name ++ ".Visitable",- "{",- (prInstVars vs),- prConstructor fun' user vs cats,- prListFuncs fun',- prAccept name fun', - "}"- ])- else (fun, --a standard rule- unlines- [- h,- "public class" +++ fun +++ ext +++ "implements"+++ name ++ ".Visitable",- "{",- (prInstVars vs),- prConstructor fun user vs cats,- prAccept name fun,- "}\n"- ])- where - vs = getVars cats user- fun' = identCat (normCat c)- --This handles the case where a LBNF label is the same as the category.- ext = if fun == c then "" else "extends" +++ (identCat c)----These are all built-in list functions.---Later we could include things like lookup,insert,delete,etc.-prListFuncs :: String -> String-prListFuncs c = unlines- [- " public" +++ c +++ "reverse()",- " {",- " if (" ++ v +++ "== null) return this;",- " else",- " {",- " " ++ c ++ " tmp =" +++ v ++ ".reverse(this);",- " " ++ v +++ "= null;",- " return tmp;",- " }",- " }",- " public" +++ c +++ "reverse(" ++ c +++ "prev)",- " {",- " if (" ++ v +++ "== null)",- " {",- " " ++ v +++ "= prev;",- " return this;",- " }",- " else",- " {",- " " ++ c +++ "tmp =" +++ v ++ ".reverse(this);",- " " ++ v +++ "= prev;",- " return tmp;",- " }",- " }"- ]- where- v = (map toLower c) ++ "_"----The standard accept function for the Visitor pattern-prAccept :: String -> String -> String-prAccept pack ty = - "\n public void accept(" ++ pack ++ ".Visitor v) { v.visit" ++ ty ++ "(this); }"----A class's instance variables.-prInstVars :: [IVar] -> String-prInstVars [] = []-prInstVars vars@((t,n,nm):vs) = - " public" +++ t +++ uniques ++ ";" ++++- (prInstVars vs')- where- (uniques, vs') = prUniques t vars- --these functions group the types together nicely- prUniques :: String -> [IVar] -> (String, [IVar])- prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs)- prVars (x:[]) vs = case vs !! x of- (t,n,nm) -> ((varName t nm) ++ (showNum n))- prVars (x:xs) vs = case vs !! x of - (t,n,nm) -> ((varName t nm) ++ (showNum n)) ++ "," +++- (prVars xs vs)- remType :: String -> [IVar] -> [IVar]- remType _ [] = []- remType t ((t2,n,nm):ts) = if t == t2 - then (remType t ts) - else (t2,n,nm) : (remType t ts)----The constructor just assigns the parameters to the corresponding instance variables.-prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String-prConstructor c u vs cats = - " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ - prAssigns vs params ++ "}"- where- (types, params) = unzip (prParams cats u (length cats) ((length cats)+1))- interleave _ [] = []- interleave (x:[]) (y:[]) = x +++ y- interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys)----Prints the parameters to the constructors. -prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)]-prParams [] _ _ _ = []-prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n)))- : (prParams cs u (n-1) m)- where- c' = typename c u- ---This algorithm peeks ahead in the list so we don't use map or fold-prAssigns :: [IVar] -> [String] -> String-prAssigns [] _ = []-prAssigns _ [] = []-prAssigns ((t,n,nm):vs) (p:ps) =- if n == 1 then- case findIndices (\x -> case x of (l,r,_) -> l == t) vs of- [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)- z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)- else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)----Different than the standard NamedVariables version because of the user-defined---types.-getVars :: [Cat] -> [UserDef] -> [IVar]-getVars cs user = foldl (addVar user) [] (map identCat cs)- where- addVar user vs c = addVar' vs user 0 c- addVar' [] u n c = [(c', n, nm)]- where- c' = typename c user- nm = if c == c' then "" else c- addVar' (i@(t,x,nm):is) u n c = - if c == t || c == nm- then if x == 0- then (t, 1, nm) : (addVar' is u 2 c)- else i : (addVar' is u (x+1) c)- else i : (addVar' is u n c)---varName c s = (map toLower c') ++ "_"- where- c' = if s == "" then c else s----This makes up for the fact that there's no typedef in Java-typename t user = - if t == "Ident" - then "String" - else if t == "Char" - then "Character" - else if elem t user- then "String"- else t
− src/formats/java/CFtoJavaPrinter.hs
@@ -1,367 +0,0 @@-{-- BNF Converter: Java Pretty Printer generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---{- - **************************************************************- BNF Converter Module-- Description : This module generates the Java Pretty Printer- class. In addition, since there's no good way- to display a class heirarchy (toString() doesn't- count) in Java, it generates a method that- displays the Abstract Syntax in a way similar- to Haskell.- - This uses Appel's method and may serve as a- useful example to those who wish to use it.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 24 April, 2003 -- Modified : 2 September, 2003 -- Added string buffer for efficiency (Michael, August 03)- ************************************************************** --}-module CFtoJavaPrinter ( cf2JavaPrinter ) where--import CF-import NamedVariables-import Utils ( (+++) )-import Data.List-import Data.Char ( toLower )----Produces the PrettyPrinter class.---It will generate two methods "print" and "show"---print is the actual pretty printer for linearization.---show produces a Haskell-style syntax that can be extremely useful---especially for testing parser correctness.--cf2JavaPrinter :: String -> String -> CF -> String-cf2JavaPrinter packageBase packageAbsyn cf = - unlines - [- header,- prEntryPoints packageAbsyn cf,- unlines (map (prData packageAbsyn) groups),- unlines (map (shData packageAbsyn) groups),- footer- ]- where- groups = (fixCoercions (ruleGroupsInternals cf))- header = unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "",- "public class PrettyPrinter",- "{",- " //For certain applications increasing the initial size of the buffer may improve performance.",- " private static final int INITIAL_BUFFER_SIZE = 128;",- " //You may wish to change the parentheses used in precedence.",- " private static final String _L_PAREN = new String(\"(\");",- " private static final String _R_PAREN = new String(\")\");",- prRender- ]- footer = unlines [ --later only include used categories- " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }",- " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }",- " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }",- " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }",- " private static void sh(Integer n) { buf_.append(n); }",- " private static void sh(Double d) { buf_.append(d); }",- " private static void sh(Character c) { buf_.append(c); }",- " private static void sh(String s) { printQuoted(s); }",- " private static void printQuoted(String s) { buf_.append(\"\\\"\" + s + \"\\\"\"); }",- " private static void indent()",- " {",- " int n = _n_;",- " while (n > 0)",- " {",- " buf_.append(\" \");",- " n--;",- " }",- " }",- " private static void backup()",- " {",- " String s = buf_.toString();", -- peteg: java 1.1.8 compatibility.- "",- " if (s.substring(buf_.length() - 1, buf_.length()).equals(\" \")) {",- " buf_.setCharAt(buf_.length() - 1, '\\\"');",- " buf_.setLength(buf_.length() - 1);",- " }",- " }",- " private static int _n_ = 0;",- " private static StringBuffer buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);",- "}"- ]----An extremely simple renderer for terminals.-prRender :: String-prRender = unlines- [- " //You may wish to change render",- " private static void render(String s)",- " {",- " if (s.equals(\"{\"))",- " {",- " buf_.append(\"\\n\");",- " indent();",- " buf_.append(s);",- " _n_ = _n_ + 2;",- " buf_.append(\"\\n\");",- " indent();",- " }",- " else if (s.equals(\"(\") || s.equals(\"[\"))",- " buf_.append(s);",- " else if (s.equals(\")\") || s.equals(\"]\"))",- " {",- " backup();",- " buf_.append(s);",- " buf_.append(\" \");",- " }",- " else if (s.equals(\"}\"))",- " {",- " _n_ = _n_ - 2;",- " backup();",- " backup();",- " buf_.append(s);",- " buf_.append(\"\\n\");",- " indent();",- " }",- " else if (s.equals(\",\"))",- " {",- " backup();",- " buf_.append(s);",- " buf_.append(\" \");",- " }",- " else if (s.equals(\";\"))",- " {",- " backup();",- " buf_.append(s);",- " buf_.append(\"\\n\");",- " indent();",- " }",- " else if (s.equals(\"\")) return;",- " else",- " {",- " buf_.append(s);",- " buf_.append(\" \");",- " }",- " }"- ]--prEntryPoints :: String -> CF -> String-prEntryPoints packageAbsyn cf =- msg ++ concat (map prEntryPoint (allEntryPoints cf)) ++ msg2- where- msg = " // print and show methods are defined for each Entry Point type.\n"- msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n"- prEntryPoint cat | (normCat cat) == cat = unlines- [- " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",- " {",- " pp(foo, 0);",- " String temp = buf_.toString();",- " buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);",- " return temp;",- " }",- " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",- " {",- " sh(foo);",- " String temp = buf_.toString();",- " buf_ = new StringBuffer(INITIAL_BUFFER_SIZE);",- " return temp;",- " }"- ]- where- cat' = identCat cat- prEntryPoint _ = ""--prData :: String -> (Cat, [Rule]) -> String-prData packageAbsyn (cat, rules) = - if isList cat- then unlines- [- " private static void pp(" ++ packageAbsyn ++ "."- ++ identCat (normCat cat) +++ "foo, int _i_)",- " {",- (prList cat rules) ++ " }"- ]- else unlines --not a list- [- " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)",- " {",- (concat (map (prRule packageAbsyn) rules)) ++ " }"- ]--prRule :: String -> Rule -> String-prRule packageAbsyn r@(Rule fun _c cats)- | not (isCoercion fun) && not (isDefinedRule fun) = concat- [- " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n",- " {\n",- " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("- ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n",- lparen,- cats',- rparen,- " }\n"- ]- where- p = precRule r- (lparen, rparen) = - (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n",- " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n")- cats' = case cats of - [] -> ""- _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))- fnm = '_' : map toLower fun-- getPrec (Right {}) = 0- getPrec (Left c) = precCat c--prRule _nm _ = ""--prList :: Cat -> [Rule] -> String-prList c rules = unlines- [- " while (foo != null)",- " {",- " if (foo." ++ c'' ++ "_ == null)",- " {",- " pp(foo." ++ c' ++ "_, 0);",- optsep,- " }",- " else",- " {",- " pp(foo." ++ c' ++ "_, 0);",- " render(\"" ++ (escapeChars sep) ++ "\");",- " }",- " foo = foo." ++ c'' ++ "_;",- " }"- ]- where- c' = map toLower (identCat (normCatOfList c))- c'' = map toLower (identCat c)- sep = getCons rules- optsep = if hasOneFunc rules then "" else (" render(\"" ++ (escapeChars sep) ++ "\");")--prCat fnm (c, p) = - case c of- Right t -> " render(\"" ++ escapeChars t ++ "\");\n"- Left nt | "string" `isPrefixOf` nt- -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n"- | isInternalVar nt -> ""- | otherwise- -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n"----The following methods generate the Show function.--shData :: String -> (Cat, [Rule]) -> String-shData packageAbsyn (cat, rules) = - if isList cat- then unlines- [- " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",- " {",- (shList cat rules) ++ " }"- ]- else unlines - [- " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",- " {",- (concat (map (shRule packageAbsyn) rules)) ++ " }"- ]--shRule :: String -> Rule -> String-shRule packageAbsyn (Rule fun _c cats)- | not (isCoercion fun) && not (isDefinedRule fun) = unlines- [- " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")",- " {",- " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("- ++ packageAbsyn ++ "." ++ fun ++ ") foo;",- members ++ " }"- ]- where- members = concat- [- lparen,- " render(\"" ++ (escapeChars fun) ++ "\");\n",- cats', - rparen- ]- cats' = if allTerms cats - then ""- else (concat (map (shCat fnm) (fixOnes (numVars [] cats))))- (lparen, rparen) = - if allTerms cats- then ("","")- else (" render(\"(\");\n"," render(\")\");\n")- allTerms [] = True- allTerms ((Left {}):_) = False- allTerms (_:zs) = allTerms zs- fnm = '_' : map toLower fun-shRule _nm _ = ""--shList :: Cat -> [Rule] -> String-shList c _rules = unlines- [- " while (foo != null)",- " {",- " if (foo." ++ c'' ++ "_ == null)",- " {",- " sh(foo." ++ c' ++ "_);",- " }",- " else",- " {",- " sh(foo." ++ c' ++ "_);",- " render(\",\");",- " }",- " foo = foo." ++ c'' ++ "_;",- " }"- ]- where- c' = map toLower (identCat (normCatOfList c))- c'' = map toLower (identCat c)---shCat fnm c =- case c of- Right {} -> ""- Left nt | "list" `isPrefixOf` nt - -> unlines [" render(\"[\");",- " sh(" ++ fnm ++ "." ++ nt ++ ");",- " render(\"]\");"]- | isInternalVar nt -> ""- | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n"-----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)--isInternalVar x = x == internalCat ++ "_"
− src/formats/java/CFtoJavaSkeleton.hs
@@ -1,124 +0,0 @@-{- - **************************************************************- BNF Converter Module-- Description : This module generates the Skeleton Function- using Appel's method, not the Visitor Pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 29 April, 2003 -- Modified : 2 September, 2003 -- - ************************************************************** --}-module CFtoJavaSkeleton (cf2JavaSkeleton) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower)---cf2JavaSkeleton :: String -> String -> CF -> String-cf2JavaSkeleton packageBase packageAbsyn cf = - unlines [- header,- unlines (map (prData packageAbsyn) groups),- footer]- where- groups = (fixCoercions (ruleGroups cf))- header = unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "/*** BNFC-Generated Skeleton function. ***/",- "/* You will probably want to save this in a new file.",- " Then do two search-and-replaces.",- " First replace \"skel\" with a real funciton name.",- " Then replace Object with a real return type. */",- "",- "public class Skeleton",- "{"- ]- footer = unlines [ --later only include used categories- " public static Object skel(Integer i) { return null; }",- " public static Object skel(Double d) { return null; }",- " public static Object skel(String s) { return null; }",- "}"- ]----Traverses a category based on its type. -prData :: String -> (Cat, [Rule]) -> String-prData packageAbsyn (cat, rules) = - if isList cat- then unlines- [- " public static Object skel(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",- " {",- prList cat rules,- " }"- ]- else unlines --not a list- [- " public static Object skel(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",- " {",- unlines (map (prRule packageAbsyn) rules),- " return null;",- " }"- ]----traverses a standard rule-prRule :: String -> Rule -> String-prRule packageAbsyn (Rule fun c cats) | not (isCoercion fun) = unlines- [- " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")",- " {",- " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("- ++ packageAbsyn ++ "." ++ fun ++ ") foo;",- "",- " /* Code For " ++ fun ++ " Goes Here */",- "",- cats',- " return null;",- " }"- ]- where- cats' = if allTerms cats- then ""- else (unlines (map (prCat fnm) (fixOnes (numVars [] cats))))- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- fnm = map toLower fun-prRule nm _ = ""----This traverses list rules.-prList :: Cat -> [Rule] -> String-prList c rules = unlines- [- " if (foo == null)",- " {",- " /* Optional End of List Code Goes Here */",- " return null;",- " }",- " else",- " {",- " /* Optional List Member Code Goes Here */",- " skel(foo." ++ c' ++ "_);",- " skel(foo." ++ c'' ++ "_);",- " return null;",- " }"- ]- where- c' = map toLower (identCat (normCatOfList c))- c'' = map toLower (identCat c)----This traverses a class's instance variables.-prCat fnm c = case c of- (Right t) -> ""- (Left nt) -> " skel(" ++ fnm ++ "." ++ nt ++ ");"
− src/formats/java/CFtoVisitSkel.hs
@@ -1,173 +0,0 @@-{-- BNF Converter: Java Vistor skeleton generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates a Skeleton function- which uses the Visitor Design Pattern, which- users may find more familiar than Appel's- method.-- Author : Michael Pellauer (pellauer@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 4 August, 2003 -- Modified : 2 September, 2003 -- - ************************************************************** --}-module CFtoVisitSkel (cf2VisitSkel) where--import CF-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper)----Produces a Skeleton using the Visitor Design Pattern.---Thus the user can choose which Skeleton to use.--cf2VisitSkel :: String -> String -> CF -> String-cf2VisitSkel packageBase packageAbsyn cf = - concat [- header,- concatMap (prData packageAbsyn user) groups,- concatMap prUser user,- footer]- where- user = fst (unzip (tokenPragmas cf))- groups = (fixCoercions (ruleGroups cf))- header = unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",- "/* This implements the common visitor design pattern.",- " Tests show it to be slightly less efficient than the",- " instanceof method, but easier to use.",- " Note that this method uses Visitor-traversal of lists, so",- " List.accept() does NOT traverse the list. This allows different",- " algorithms to use context information differently. */",- "",- "public class VisitSkel implements Visitor",- "{"- ]- prUser u = " public void visit" ++ u' ++ "(String p) {}\n"- where- u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.- footer = unlines - [ --later only include used categories- " public void visitIdent(String i) {}",- " public void visitInteger(Integer i) {}",- " public void visitDouble(Double d) {}",- " public void visitChar(Character c) {}",- " public void visitString(String s) {}",- "}"- ]- ---Traverses a category based on its type.-prData :: String -> [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = - if isList cat- then unlines- [- " public void visit" ++ cl ++ "(" ++ packageAbsyn ++ "." ++ cl +++ vname ++ ")",- " {",- " while(" ++ vname ++ "!= null)",- " {",- " /* Code For" +++ cl +++ "Goes Here */",- visitMember,- " " ++ vname +++ "=" +++ vname ++ "." ++ vname ++ "_;",- " }",- " }"- ] --Not a list:- else abstract ++ (concatMap (prRule packageAbsyn user) rules)- where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl ++ "_"- visitMember = if isBasic user member- then " visit" ++ (funName member) ++ "(" ++ vname ++ "." ++ member ++ ");"- else " " ++ vname ++ "." ++ member ++ ".accept(this);"- abstract = case lookupRule cat rules of- Just x -> ""- Nothing -> " public void visit" ++ cl ++ "(" ++ packageAbsyn ++ "."- ++ cl +++ vname ++ ") {} //abstract class\n"----traverses a standard rule.-prRule :: String -> [UserDef] -> Rule -> String-prRule packageAbsyn user (Rule fun c cats) | not (isCoercion fun) = unlines- [- " public void visit" ++ fun ++ "(" ++ packageAbsyn ++ "." ++ fun +++ fnm ++ ")",- " {",- " /* Code For " ++ fun ++ " Goes Here */",- "",- cats' ++ " }"- ]- where- cats' = if allTerms cats- then ""- else (concatMap (prCat user fnm) (fixOnes (numVars [] cats)))- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- fnm = map toLower fun-prRule user nm _ = ""----Traverses a class's instance variables.-prCat user fnm c = - case c of- (Right t) -> ""- (Left nt) -> if isBasic user nt- then " visit" ++ (funName nt) ++ "(" ++ fnm ++ "." ++ nt ++ ");\n"- else if "list" `isPrefixOf` nt- then " if (" ++ fnm ++ "." ++ nt ++ " != null) {" ++ accept ++ "}\n"- else " " ++ accept ++ "\n"- where- accept = fnm ++ "." ++ nt ++ ".accept(this);"----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user----The visit-function name of a basic type-funName :: String -> String-funName v = - if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else (toUpper (head v)) : (init (tail v)) --User-defined type
− src/formats/java/JavaTop.hs
@@ -1,306 +0,0 @@-{-- BNF Converter: Java Top File- Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}------------------------------------------------------------------------ |--- Module : JavaTop--- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg} at cs dot chalmers dot se--- License : GPL (see COPYING for details)--- --- Maintainer : {markus, aarne} at cs dot chalmers dot se--- Stability : alpha--- Portability : Haskell98------ Top-level for the Java back end.------ > $Id: JavaTop.hs,v 1.10 2005/09/21 13:06:10 bringert Exp $----------------------------------------------------------------------module JavaTop ( makeJava ) where ------------------------------------------------------------------------ Dependencies.---------------------------------------------------------------------import System.Directory ( createDirectory )-import System.IO.Error ( tryIOError, isAlreadyExistsError )-import System.Exit ( exitFailure )--import Utils-import CF-import CFtoCup ( cf2Cup )-import CFtoJLex-import CFtoJavaAbs ( cf2JavaAbs )-import CFtoJavaPrinter-import CFtoJavaSkeleton-import CFtoVisitSkel-import CFtoLatex-import Data.Char-import Data.List(intersperse)------------------------------------------------------------------------ | Build the Java output.--- FIXME: get everything to put the files in the right places.--- Adapt Makefile to do the business.---------------------------------------------------------------------makeJava :: Bool -> String -> CF -> IO ()-makeJava = mkFiles--mkFiles :: Bool -> String -> CF -> IO ()-mkFiles make name cf =- do -- Create the package directories if necessary.- let packageBase = name- packageAbsyn = packageBase ++ "." ++ "Absyn"- dirBase = pkgToDir packageBase- dirAbsyn = pkgToDir packageAbsyn- chkExists dirBase- chkExists dirAbsyn- let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf- absynBaseNames = map fst absynFiles- absynFileNames = map (dirAbsyn ++) absynBaseNames- let writeAbsyn (filename, contents) =- writeFileRep (dirAbsyn ++ filename ++ ".java") contents- mapM writeAbsyn absynFiles- writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf- writeFileRep (dirBase ++ "Skeleton.java") $ cf2JavaSkeleton packageBase packageAbsyn cf- writeFileRep (dirBase ++ "Visitable.java") $ prVisitable packageBase- let user = fst $ unzip $ tokenPragmas cf -- FIXME better var name- writeFileRep (dirBase ++ "Visitor.java") $ prVisitor packageBase packageAbsyn absynBaseNames user- writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf- writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf- let (lex, env) = cf2jlex packageBase packageAbsyn cf- writeFileRep (dirBase ++ "Yylex") lex- putStrLn " (Tested with JLex 1.2.6.)"- writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env- -- FIXME: put in a doc directory?- putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")"- putStrLn " (Tested with CUP 0.10k)"- writeFileRep (name ++ ".tex") $ cfToLatex name cf- if make- then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames- else return ()- where- remDups [] = []- remDups ((a,b):as) = case lookup a as of- Just {} -> remDups as- Nothing -> (a, b) : (remDups as)-- pkgToDir :: String -> FilePath- pkgToDir p = [ if c == '.' then '/' else c | c <- p] ++ "/"-- chkExists :: FilePath -> IO ()- chkExists dir =- do eErr <- tryIOError $ createDirectory dir- case eErr of- Left ioerr -> if isAlreadyExistsError ioerr- then return ()- else fail $ show ioerr- Right () -> putStrLn $ "Created directory: " ++ dir---- FIXME get filenames right.--- FIXME It's almost certainly better to just feed all the Java source--- files to javac in one go.--- Replace with an ANT script?-makefile :: String -> FilePath -> FilePath -> [String] -> String-makefile name dirBase dirAbsyn absynFileNames =- unlines - [- "JAVAC = javac",- "JAVAC_FLAGS = -sourcepath .",- "",- "JAVA = java",- "",- "CUP = java_cup.Main",- "CUPFLAGS = -nopositions -expect 100",- "",- "JLEX = JLex.Main",- "",- "LATEX = latex",- "DVIPS = dvips",- "",- "all: test " ++ name ++ ".ps",- "",- "test: absyn "- ++ unwords (map (dirBase ++) ["Visitor.class",- "Visitable.class",- "Test.class"]),- "",- ".PHONE: absyn",- "",- "absyn: " ++ absynJavaClass,- "",- "%.class: " ++ "%.java",- "\t${JAVAC} ${JAVAC_FLAGS} $*.java",- "",- dirBase ++ "Visitable.class: " ++ dirBase ++ "Visitable.java",- "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitable.java",- "",- dirBase ++ "Visitor.class: " ++ dirBase ++ "Visitor.java",- "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Visitor.java",- "",- dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex",- "\t${JAVA} ${JLEX} " ++ dirBase ++ "Yylex",- "",- -- FIXME- dirBase ++ "sym.java" ++ " " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup",- "\t${JAVA} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup ; mv sym.java parser.java " ++ dirBase,- "",- dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java "- ++ dirBase ++ "sym.java",- "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Yylex.java",- "",- dirBase ++ "Test.class: "- ++ unwords (map (dirBase ++) ["Test.java",- "PrettyPrinter.class",- "Yylex.class",- "parser.class",- "sym.class"]),- "\t${JAVAC} ${JAVAC_FLAGS} " ++ dirBase ++ "Test.java",- "",- "" ++ name ++ ".dvi: " ++ name ++ ".tex",- "\t${LATEX} " ++ name ++ ".tex",- "",- "" ++ name ++ ".ps: " ++ name ++ ".dvi",- "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps",--- FIXME- "",- "clean:",- "\t rm -f " ++ absynJavaClass,- "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class Makefile",- "",- "distclean:",- "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass,- "\t rmdir " ++ dirAbsyn,- "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ",- "\t rm -f " ++ unwords (map (dirBase ++) ["Yylex",- name ++ ".cup",- "Yylex.java",- "sym.java", - "parser.java",- "Visitor.java",- "Visitable.java",- "VisitSkel.java",- "PrettyPrinter.java",- "Skeleton.java",- "Test.java",- "*.class"]),- "\t rmdir " ++ dirBase,- "\t rm -f Makefile",- ""- ]- where absynJavaSrc = unwords (map (++ ".java") absynFileNames)- absynJavaClass = unwords (map (++ ".class") absynFileNames)--prVisitable :: String -> String-prVisitable packageBase = unlines- [- "package" +++ packageBase ++ ";\n",- "public interface Visitable",- "{",- " public void accept(" ++ packageBase ++ ".Visitor v);",- "}"- ]--prVisitor :: String -> String -> [String] -> [String]-> String-prVisitor packageBase packageAbsyn funs user =- unlines- [- "package" +++ packageBase ++ ";\n",- "public interface Visitor",- "{",- concatMap prVisitFun funs,- concatMap prUser user,- footer- ]- where- prUser u = " public void visit" ++ u' ++ "(String p);\n"- where - u' = ((toUpper (head u)) : (map toLower (tail u))) --this is a hack to fix a potential capitalization problem.- footer = unlines- [ --later only include used categories- " public void visitIdent(String i);",- " public void visitInteger(Integer i);",- " public void visitDouble(Double d);",- " public void visitChar(Character c);",- " public void visitString(String s);",- "}"- ]- prVisitFun f = " public void visit" ++ f ++ "(" ++ packageAbsyn- ++ "." ++ f ++ " p);\n"--javaTest :: String -> String -> CF -> String-javaTest packageBase packageAbsyn cf =- unlines- [- "package" +++ packageBase ++ ";",- "import java_cup.runtime.*;",- "import" +++ packageBase ++ ".*;",- "import" +++ packageAbsyn ++ ".*;",- "import java.io.*;",- "",- "public class Test",- "{",- " public static void main(String args[]) throws Exception",- " {",- " Yylex l = null;",- " parser p;",- " try",- " {",- " if (args.length == 0) l = new Yylex(System.in);",- " else l = new Yylex(new FileReader(args[0]));",- " }",- " catch(FileNotFoundException e)",- " {",- " System.err.println(\"Error: File not found: \" + args[0]);",- " System.exit(1);",- " }",- " p = new parser(l);",- " /* The default parser is the first-defined entry point. */",- " /* You may want to change this. Other options are: */",- " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */",- " try",- " {",- " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" - ++ def ++ "();",- " System.out.println();",- " System.out.println(\"Parse Succesful!\");",- " System.out.println();",- " System.out.println(\"[Abstract Syntax]\");",- " System.out.println();",- " System.out.println(PrettyPrinter.show(parse_tree));",- " System.out.println();",- " System.out.println(\"[Linearized Tree]\");",- " System.out.println();",- " System.out.println(PrettyPrinter.print(parse_tree));",- " }",- " catch(Throwable e)",- " {",- " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");",- " System.err.println(\" \" + e.getMessage());",- " System.exit(1);",- " }",- " }",- "}"- ]- where eps = allEntryPoints cf- def = head eps- showOpts [] = []-- showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)]- showOpts (x:xs) = if normCat x /= x then (showOpts xs) - else ('p' : (identCat x)) : (showOpts xs)
− src/formats/java/RegToJLex.hs
@@ -1,86 +0,0 @@-module RegToJLex (printRegJLex, escapeChar) where---- modified from pretty-printer generated by the BNF converter--import AbsBNF-import Data.Char---- the top-level printing method-printRegJLex :: Reg -> String-printRegJLex = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend (0 :: Int) where- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = [escapeChar c]- prtList s = map (concat . prt 0) s--escapeChar :: Char -> String-escapeChar '^' = "\\x5E" -- special case, since \^ is a control character escape-escapeChar x | x `elem` jlexReserved = '\\' : [x]-escapeChar x = [x]---- Characters that must be escaped in JLex regular expressions-jlexReserved :: [Char]-jlexReserved = ['?', '*', '+', '|', '(', ')', '^', '$', '.', '[', ']', '{', '}', '"', '\\']--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])-- -- JLex does not support set difference- --RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RMinus reg0 REps -> prt i reg0 -- REps is identity for set difference- RMinus RAny reg@(RChar _) -> prPrec i 3 (concat [["[^"],prt 0 reg,["]"]])- RMinus RAny (RAlts str) -> prPrec i 3 (concat [["[^"],prt 0 str,["]"]])- -- FIXME: maybe we could add cases for char - RDigit, RLetter etc.- RMinus reg0 reg -> error $ "JLex does not support general set difference"-- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["[^.]"])- RChar c -> prPrec i 3 (concat [prt 0 c])- RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) str))- RDigit -> prPrec i 3 (concat [["{DIGIT}"]])- RLetter -> prPrec i 3 (concat [["{LETTER}"]])- RUpper -> prPrec i 3 (concat [["{CAPITAL}"]])- RLower -> prPrec i 3 (concat [["{SMALL}"]])- RAny -> prPrec i 3 (concat [["."]])---
− src/formats/java1.5/CFtoAbstractVisitor.hs
@@ -1,60 +0,0 @@-{-- BNF Converter: Java 1.5 Abstract Vistor generator- Copyright (C) 2006 Bjorn Bringert- Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoAbstractVisitor (cf2AbstractVisitor) where--import CF-import CFtoJavaAbs15 (typename)-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper, isDigit)--cf2AbstractVisitor :: String -> String -> CF -> String-cf2AbstractVisitor packageBase packageAbsyn cf = - unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "/** BNFC-Generated Abstract Visitor */",- "public class AbstractVisitor<R,A> implements AllVisitor<R,A> {",- concatMap (prData packageAbsyn user) groups,- "}"]- where- user = fst (unzip (tokenPragmas cf))- groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]----Traverses a category based on its type.-prData :: String -> [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = - unlines $ ["/* " ++ identCat cat ++ " */"]- ++ map (prRule packageAbsyn user cat) rules- ++ [" public R visitDefault(" ++ q ++ " p, A arg) {",- " throw new IllegalArgumentException(this.getClass().getName() + \": \" + p);",- " }"]- where q = packageAbsyn ++ "." ++ identCat cat----traverses a standard rule.-prRule :: String -> [UserDef] -> Cat -> Rule -> String-prRule packageAbsyn user cat (Rule fun _ cats)- | not (isCoercion fun || isDefinedRule fun) =- " public R visit(" ++ cls ++ " p, A arg) { return visitDefault(p, arg); }"- where cls = packageAbsyn ++ "." ++ fun-prRule _ _ _ _ = ""-
− src/formats/java1.5/CFtoAllVisitor.hs
@@ -1,51 +0,0 @@-{-- BNF Converter: Java 1.5 All Visitor generator- Copyright (C) 2006 Bjorn Bringert- Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoAllVisitor (cf2AllVisitor) where--import CF-import CFtoJavaAbs15 (typename)-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper, isDigit)--cf2AllVisitor :: String -> String -> CF -> String-cf2AllVisitor packageBase packageAbsyn cf = - unlines [- "package" +++ packageBase ++ ";",- "",- "import" +++ packageAbsyn ++ ".*;",- "",- "/** BNFC-Generated All Visitor */",- "public interface AllVisitor<R,A> extends",- concat $ intersperse ",\n" $ map (" "++) is,- "{}"]- where- groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]- is = map (prInterface packageAbsyn) groups- header = unlines [- - ]--prInterface :: String -> (Cat, [Rule]) -> String-prInterface packageAbsyn (cat, rules) = - q ++ ".Visitor<R,A>"- where q = packageAbsyn ++ "." ++ identCat cat
− src/formats/java1.5/CFtoComposVisitor.hs
@@ -1,117 +0,0 @@-{-- BNF Converter: Java 1.5 Compositional Vistor generator- Copyright (C) 2006 Bjorn Bringert- Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoComposVisitor (cf2ComposVisitor) where--import CF-import CFtoJavaAbs15 (typename)-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper, isDigit)--cf2ComposVisitor :: String -> String -> CF -> String-cf2ComposVisitor packageBase packageAbsyn cf = - concat [- header,- concatMap (prData packageAbsyn user) groups,- "}"]- where- user = fst (unzip (tokenPragmas cf))- groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]- is = map (prInterface packageAbsyn) groups- header = unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "/** BNFC-Generated Composition Visitor",- "*/",- "",- "public class ComposVisitor<A> implements",- concat $ intersperse ",\n" $ map (" "++) is,- "{"- ]---prInterface :: String -> (Cat, [Rule]) -> String-prInterface packageAbsyn (cat, rules) = - q ++ ".Visitor<" ++ q ++ ",A>"- where q = packageAbsyn ++ "." ++ identCat cat--commaList :: [String] -> String-commaList = concat . intersperse ", "----Traverses a category based on its type.-prData :: String -> [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = - unlines [- "/* " ++ identCat cat ++ " */",- concatMap (prRule packageAbsyn user cat) rules- ]---traverses a standard rule.-prRule :: String -> [UserDef] -> Cat -> Rule -> String-prRule packageAbsyn user cat (Rule fun _ cats)- | not (isCoercion fun || isDefinedRule fun) = unlines- [- " public " ++ identCat cat ++ " visit(" ++ cls ++ " p, A arg)",- " {",- unlines (map (" "++) visitVars),- " return new " ++ cls ++ "(" ++ commaList children ++ ");",- " }"- ]- where- cats' = if allTerms cats- then []- else [ (c,v) | - (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ]- cls = packageAbsyn ++ "." ++ fun- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- children = map snd cats'- visitVars = concatMap (uncurry (prCat user)) cats'-prRule _ _ _ _ = ""----Traverses a class's instance variables.-prCat :: [UserDef] - -> Cat -- ^ Variable category- -> String -- ^ Variable name- -> [String] -- ^ Code for visiting the variable-prCat user cat nt - | isBasicType user varType || (isListType varType && isBasicType user et) = [decl var]- | isListType varType = listAccept- | otherwise = [decl (var ++ ".accept(this, arg)")]- where- var = "p." ++ nt- varType = typename (normCat (identCat cat)) user- accept = var ++ ".accept(this, arg);"- et = typename (normCatOfList cat) user- decl v = varType +++ nt +++ "=" +++ v ++ ";"- listAccept = [decl ("new"+++varType++"()"),- "for (" ++ et ++ " x : " ++ var ++ ") {", - " " ++ nt ++ ".add(x.accept(this,arg));",- "}"]--isListType :: String -> Bool-isListType nt = "List" `isPrefixOf` nt----Just checks if something is a basic or user-defined type.-isBasicType :: [UserDef] -> String -> Bool-isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"])-
− src/formats/java1.5/CFtoCup15.hs
@@ -1,274 +0,0 @@-{-- BNF Converter: Java 1.5 Cup Generator- Copyright (C) 2004 Author: Markus Forsberg, Michael Pellauer,- Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the CUP input file. It- follows the same basic structure of CFtoHappy.-- Author : Michael Pellauer (pellauer@cs.chalmers.se),- Bjorn Bringert (bringert@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 26 April, 2003 -- Modified : 5 Aug, 2004-- - ************************************************************** --}-module CFtoCup15 ( cf2Cup ) where--import CF-import Data.List (intersperse, isPrefixOf)-import NamedVariables-import Utils ( (+++) )-import TypeChecker -- We need to (re-)typecheck to figure out list instances in- -- defined rules.-import ErrM--import Data.Char---- Type declarations-type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String----The environment comes from the CFtoJLex-cf2Cup :: String -> String -> CF -> SymEnv -> String-cf2Cup packageBase packageAbsyn cf env = unlines - [- header,- declarations packageAbsyn (allCats cf),- tokens env,- specialToks cf,- specialRules cf,- prEntryPoint cf,- prRules (rulesForCup packageAbsyn cf env)- ]- where- header :: String- header = unlines - ["// -*- Java -*- This Cup file was machine-generated by BNFC",- "package" +++ packageBase ++ ";",- "",- "parser code {:",- parseMethod packageAbsyn (firstEntry cf),- "public <B,A extends java.util.LinkedList<? super B>> A cons_(B x, A xs) { xs.addFirst(x); return xs; }",- definedRules packageAbsyn cf,- -- unlines $ map (parseMethod packageAbsyn) (allEntryPoints cf),- "public void syntax_error(java_cup.runtime.Symbol cur_token)",- "{",- "\treport_error(\"Syntax Error, trying to recover and continue parse...\", cur_token);",- "}",- "",- "public void unrecovered_syntax_error(java_cup.runtime.Symbol cur_token) throws java.lang.Exception",- "{",- "\tthrow new Exception(\"Unrecoverable Syntax Error\");",- "}",- "",- ":}"- ]--definedRules :: String -> CF -> String-definedRules packageAbsyn cf =- unlines [ rule f xs e | FunDef f xs e <- pragmasOfCF cf ]- where- ctx = buildContext cf-- list = LC (\t -> "List" ++ unBase t) (const "cons")- where- unBase (ListT t) = unBase t- unBase (BaseT x) = normCat x-- rule f xs e =- case checkDefinition' list ctx f xs e of- Bad err -> error $ "Panic! This should have been caught already:\n" ++ err- Ok (args,(e',t)) -> unlines- [ "public " ++ javaType t ++ " " ++ f ++ "_ (" ++- concat (intersperse ", " $ map javaArg args) ++ ") {"- , " return " ++ javaExp e' ++ ";"- , "}"- ]- where-- javaType :: Base -> String- javaType (ListT (BaseT x)) = packageAbsyn ++ ".List" ++ normCat x- javaType (ListT t) = javaType t- javaType (BaseT x)- | isToken x ctx = "String"- | otherwise = packageAbsyn ++ "." ++ normCat x-- javaArg :: (String, Base) -> String- javaArg (x,t) = javaType t ++ " " ++ x ++ "_"-- javaExp :: Exp -> String- javaExp (App "null" []) = "null"- javaExp (App x [])- | elem x xs = x ++ "_" -- argument- javaExp (App t [e])- | isToken t ctx = call ("new String") [e]- javaExp (App x es)- | isUpper (head x) = call ("new " ++ packageAbsyn ++ "." ++ x) es- | otherwise = call (x ++ "_") es- javaExp (LitInt n) = "new Integer(" ++ show n ++ ")"- javaExp (LitDouble x) = "new Double(" ++ show x ++ ")"- javaExp (LitChar c) = "new Character(" ++ show c ++ ")"- javaExp (LitString s) = "new String(" ++ show s ++ ")"-- call x es = x ++ "(" ++ concat (intersperse ", " $ map javaExp es) ++ ")"----- peteg: FIXME JavaCUP can only cope with one entry point AFAIK.-prEntryPoint :: CF -> String-prEntryPoint cf = unlines ["", "start with " ++ firstEntry cf ++ ";", ""]--- [ep] -> unlines ["", "start with " ++ ep ++ ";", ""]--- eps -> error $ "FIXME multiple entry points." ++ show eps----This generates a parser method for each entry point.-parseMethod :: String -> Cat -> String-parseMethod packageAbsyn cat = - if normCat cat /= cat- then ""- else unlines- [- " public" +++ packageAbsyn ++ "." ++ cat' +++ "p" ++ cat' ++ "()"- ++ " throws Exception",- " {",- "\tjava_cup.runtime.Symbol res = parse();",- "\treturn (" ++ packageAbsyn ++ "." ++ cat' ++ ") res.value;", - " }"- ]- where cat' = identCat (normCat cat)----non-terminal types-declarations :: String -> [NonTerminal] -> String-declarations packageAbsyn ns = unlines (map (typeNT packageAbsyn) ns)- where- typeNT _nm nt = "nonterminal" +++ packageAbsyn ++ "."- ++ identCat (normCat nt) +++ identCat nt ++ ";"----terminal types-tokens :: SymEnv -> String-tokens ts = unlines (map declTok ts)- where- declTok (s,r) = "terminal" +++ r ++ "; // " ++ s--specialToks :: CF -> String-specialToks cf = unlines [ - ifC "String" "terminal String _STRING_;",- ifC "Char" "terminal Character _CHAR_;",- ifC "Integer" "terminal Integer _INTEGER_;",- ifC "Double" "terminal Double _DOUBLE_;",- ifC "Ident" "terminal String _IDENT_;"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""---- This handles user defined tokens--- FIXME-specialRules:: CF -> String-specialRules cf =- unlines ["terminal String " ++ name ++ ";" | (name, _) <- tokenPragmas cf]----The following functions are a (relatively) straightforward translation---of the ones in CFtoHappy.hs-rulesForCup :: String -> CF -> SymEnv -> Rules-rulesForCup packageAbsyn cf env = map mkOne $ ruleGroups cf where- mkOne (cat,rules) = constructRule packageAbsyn cf env rules cat---- For every non-terminal, we construct a set of rules. A rule is a sequence of--- terminals and non-terminals, and an action to be performed.-constructRule :: String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule packageAbsyn cf env rules nt =- (nt, [(p,generateAction packageAbsyn nt (funRule r) (revM b m) b)- | r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True, revSepListRule r0) - else (False, r0)- (p,m) = generatePatterns cf env r])- where- revM False m = m- revM True [h,t] = [t,h] - revs = reversibleCats cf---- Generates a string containing the semantic action.-generateAction :: String -> NonTerminal -> Fun -> [MetaVar] - -> Bool -- ^ Whether the list should be reversed or not. - -- Only used if this is a list rule.- -> Action-generateAction packageAbsyn nt f ms rev- | isNilFun f = "RESULT = new " ++ c ++ "();"- | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");"- | isConsFun f = "RESULT = " ++ p_2 ++ "; " - ++ p_2 ++ "." ++ add ++ "(" ++ p_1 ++ ");"- | isCoercion f = "RESULT = " ++ p_1 ++ ";"- | isDefinedRule f = "RESULT = parser." ++ f ++ "_"- ++ "(" ++ concat (intersperse "," ms) ++ ");"- | otherwise = "RESULT = new " ++ c - ++ "(" ++ concat (intersperse "," ms) ++ ");"- where- c = packageAbsyn ++ "." ++- if isNilFun f || isOneFun f || isConsFun f - then identCat (normCat nt) else f- p_1 = ms!!0- p_2 = ms!!1- add = if rev then "addLast" else "addFirst"---- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])-generatePatterns cf env r = case rhsRule r of- [] -> (" /* empty */ ",[])- its -> (mkIt env 1 its, metas its) - where- mkIt _env _n [] = []- mkIt env n (i:is) = case i of- Left c -> c' ++ ":p_" ++ (show (n :: Int)) +++ (mkIt env (n+1) is)- where - c' = case c of- "Ident" -> "_IDENT_"- "Integer" -> "_INTEGER_"- "Char" -> "_CHAR_"- "Double" -> "_DOUBLE_"- "String" -> "_STRING_"- _ -> identCat c- Right s -> case (lookup s env) of- (Just x) -> x +++ (mkIt env (n+1) is)- (Nothing) -> (mkIt env n is)- metas its = ["p_" ++ show i | (i,Left c) <- zip [1 :: Int ..] its]---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.-prRules :: Rules -> String-prRules [] = []-prRules ((nt, []):rs) = prRules rs --internal rule-prRules ((nt,((p,a):ls)):rs) = - (unwords [nt', "::=", p, "{:", a, ":}", "\n" ++ pr ls]) ++ ";\n" ++ prRules rs- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{:", a , ":}"])]) ++ pr ls-
− src/formats/java1.5/CFtoFoldVisitor.hs
@@ -1,104 +0,0 @@-{-- BNF Converter: Java 1.5 Fold Vistor generator- Copyright (C) 2006 Bjorn Bringert- Based on CFtoVisitSkel.hs, Copyright (C) 2004-2006 Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoFoldVisitor (cf2FoldVisitor) where--import CF-import CFtoJavaAbs15 (typename)-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper, isDigit)--cf2FoldVisitor :: String -> String -> CF -> String-cf2FoldVisitor packageBase packageAbsyn cf = - unlines- ["package" +++ packageBase ++ ";",- "",- "import" +++ packageAbsyn ++ ".*;",- "import java.util.Collections;",- "import java.util.List;",- "import java.util.ArrayList;",- "",- "/** BNFC-Generated Fold Visitor */",- "public abstract class FoldVisitor<R,A> implements AllVisitor<R,A> {",- " public abstract R leaf(A arg);",- " public abstract R combine(R x, R y, A arg);",- "",- concatMap (prData packageAbsyn user) groups,- "}"]- where- user = fst (unzip (tokenPragmas cf))- groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]----Traverses a category based on its type.-prData :: String -> [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = - unlines [- "/* " ++ identCat cat ++ " */",- concatMap (prRule packageAbsyn user cat) rules- ]----traverses a standard rule.-prRule :: String -> [UserDef] -> Cat -> Rule -> String-prRule packageAbsyn user cat (Rule fun _ cats)- | not (isCoercion fun || isDefinedRule fun) = unlines $- [" public R visit(" ++ cls ++ " p, A arg) {",- " R r = leaf(arg);"] - ++ map (" "++) visitVars- ++ [" return r;",- " }"]- where- cats' = if allTerms cats- then []- else [ (c,v) | - (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)), c /= internalCat ]- cls = packageAbsyn ++ "." ++ fun- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs- children = map snd cats'- visitVars = concatMap (uncurry (prCat user)) cats'-prRule _ _ _ _ = ""----Traverses a class's instance variables.-prCat :: [UserDef] - -> Cat -- ^ Variable category- -> String -- ^ Variable name- -> [String] -- ^ Code for visiting the variable-prCat user cat nt - | isBasicType user varType || (isListType varType && isBasicType user et) = []- | isListType varType = listAccept- | otherwise = ["r = combine(" ++ var ++ ".accept(this, arg), r, arg);"]- where- var = "p." ++ nt- varType = typename (normCat (identCat cat)) user- et = typename (normCatOfList cat) user- listAccept = ["for (" ++ et ++ " x : " ++ var ++ ") {", - " r = combine(x.accept(this,arg), r, arg);",- "}"]--isListType :: String -> Bool-isListType nt = "List" `isPrefixOf` nt----Just checks if something is a basic or user-defined type.-isBasicType :: [UserDef] -> String -> Bool-isBasicType user v = v `elem` (user ++ ["Integer","Character","String","Double"])-
− src/formats/java1.5/CFtoJLex15.hs
@@ -1,175 +0,0 @@-{-- BNF Converter: Java JLex generator- Copyright (C) 2004 Author: Michael Pellauer-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the JLex input file. This- file is quite different than Alex or Flex.-- Author : Michael Pellauer (pellauer@cs.chalmers.se),- Bjorn Bringert (bringert@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 25 April, 2003 -- Modified : 4 Nov, 2004-- - ************************************************************** --}--module CFtoJLex15 ( cf2jlex ) where--import CF-import RegToJLex-import Utils ( (+++) )-import NamedVariables-import Data.List----The environment must be returned for the parser to use.-cf2jlex :: String -> String -> CF -> (String, SymEnv)-cf2jlex packageBase packageAbsyn cf = (unlines $ concat $ - [- prelude packageBase packageAbsyn,- cMacros,- lexSymbols env,- restOfJLex cf- ], env)- where- env = makeSymEnv (symbols cf ++ reservedWords cf) (0 :: Int)- makeSymEnv [] _ = []- makeSymEnv (s:symbs) n = (s, "_SYMB_" ++ (show n)) : (makeSymEnv symbs (n+1))- -prelude :: String -> String -> [String]-prelude packageBase packageAbsyn =- [- "// This JLex file was machine-generated by the BNF converter",- "package" +++ packageBase ++ ";",- "",- "import java_cup.runtime.*;",- "%%",- "%cup",- "%unicode",- "%line",- "%public",- "%{",- " String pstring = new String();",- " public int line_num() { return (yyline+1); }",- " public String buff() { return new String(yy_buffer,yy_buffer_index,10).trim(); }",- "%}"- ]----For now all categories are included.---Optimally only the ones that are used should be generated.-cMacros :: [String]-cMacros = [- "LETTER = ({CAPITAL}|{SMALL})",- "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]",- "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]",- "DIGIT = [0-9]",- "IDENT = ({LETTER}|{DIGIT}|['_])",- "%state COMMENT",- "%state CHAR",- "%state CHARESC",- "%state CHAREND",- "%state STRING",- "%state ESCAPED",- "%%"- ]--lexSymbols :: SymEnv -> [String]-lexSymbols ss = map transSym ss- where- transSym (s,r) = - "<YYINITIAL>" ++ (escapeChars s) ++ " { return new Symbol(sym." - ++ r ++ "); }"--restOfJLex :: CF -> [String]-restOfJLex cf =- [- lexComments (comments cf),- userDefTokens,- ifC "String" strStates,- ifC "Char" chStates,- ifC "Double" "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }",- ifC "Integer" "<YYINITIAL>{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }",- ifC "Ident" "<YYINITIAL>{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }"- , "<YYINITIAL>[ \\t\\r\\n\\f] { /* ignore white space. */ }"- ]- where- ifC cat s = if isUsedCat cf cat then s else ""- userDefTokens = unlines $- ["<YYINITIAL>" ++ printRegJLex exp +++ - "{ return new Symbol(sym." ++ name ++ ", yytext().intern()); }"- | (name, exp) <- tokenPragmas cf]- strStates = unlines --These handle escaped characters in Strings.- [- "<YYINITIAL>\"\\\"\" { yybegin(STRING); }",- "<STRING>\\\\ { yybegin(ESCAPED); }",- "<STRING>\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }",- "<STRING>. { pstring += yytext(); }",- "<ESCAPED>n { pstring += \"\\n\"; yybegin(STRING); }",- "<ESCAPED>\\\" { pstring += \"\\\"\"; yybegin(STRING); }",- "<ESCAPED>\\\\ { pstring += \"\\\\\"; yybegin(STRING); }",- "<ESCAPED>t { pstring += \"\\t\"; yybegin(STRING); }",- "<ESCAPED>. { pstring += yytext(); yybegin(STRING); }"- ]- chStates = unlines --These handle escaped characters in Chars.- [- "<YYINITIAL>\"'\" { yybegin(CHAR); }",- "<CHAR>\\\\ { yybegin(CHARESC); }",- "<CHAR>[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",- "<CHARESC>n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }",- "<CHARESC>t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }",- "<CHARESC>. { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }",- "<CHAREND>\"'\" {yybegin(YYINITIAL);}"- ]-----lexComments :: ([(String, String)], [String]) -> String-lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m))--lexSingleComment :: String -> String-lexSingleComment c = - "<YYINITIAL>\"" ++ c ++ "\"[^\\n]*\\n { /* BNFC single-line comment */ }"----There might be a possible bug here if a language includes 2 multi-line comments.---They could possibly start a comment with one character and end it with another.---However this seems rare.-lexMultiComment :: (String, String) -> String-lexMultiComment (b,e) = unlines [- "<YYINITIAL>\"" ++ b ++ "\" { yybegin(COMMENT); }",- "<COMMENT>\"" ++ e ++ "\" { yybegin(YYINITIAL); }",- "<COMMENT>. { }",- "<COMMENT>[\\n] { }"- ]- --- lexReserved :: String -> String--- lexReserved s = "<YYINITIAL>\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }"----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars = concatMap escapeChar
− src/formats/java1.5/CFtoJavaAbs15.hs
@@ -1,263 +0,0 @@-{-- BNF Converter: Java 1.5 Abstract Syntax- Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates the Java Abstract Syntax- It uses the NamedVariables module for variable- naming. It returns a list of file names, and the- contents to be written into that file. (In Java- public classes must go in their own file.)- - The generated classes also support the Visitor- Design Pattern.-- Author : Michael Pellauer (pellauer@cs.chalmers.se),- Bjorn Bringert (bringert@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 24 April, 2003 -- Modified : 16 June, 2004 -- - ************************************************************** --}--module CFtoJavaAbs15 (cf2JavaAbs, typename) where--import CF-import Utils((+++),(++++))-import NamedVariables hiding (IVar, getVars, varName)-import Data.List-import Data.Char(toLower, isDigit)-import Data.Maybe(catMaybes,fromMaybe)----Produces abstract data types in Java.---These follow Appel's "non-object oriented" version.---They also allow users to use the Visitor design pattern.--type IVar = (String, Int, Maybe String)---The type of an instance variable---a # unique to that type---and an optional name (handles typedefs).----The result is a list of files which must be written to disk.---The tuple is (FileName, FileContents)-cf2JavaAbs :: String -> String -> CF -> [(FilePath, String)]-cf2JavaAbs packageBase packageAbsyn cf =- concatMap (prData header packageAbsyn user) rules- where- header = "package " ++ packageAbsyn ++ "; // Java Package generated by the BNF Converter.\n"- user = [n | (n,_) <- tokenPragmas cf]- rules = [ (normCat c,fs) | (c,fs) <- cf2dataLists cf]----Generates a (possibly abstract) category class, and classes for all its rules.-prData :: String -> String -> [UserDef] -> Data ->[(String, String)]-prData header packageAbsyn user (cat, rules) =- categoryClass ++ (catMaybes $ map (prRule header packageAbsyn funs user cat) rules)- where- funs = map fst rules- categoryClass - | cat `elem` funs = [] -- the catgory is also a function, skip abstract class- | otherwise = [(identCat cat, header ++++- unlines [- "public abstract class" +++ cls - +++ "implements java.io.Serializable {",- " public abstract <R,A> R accept(" - ++ cls ++ ".Visitor<R,A> v, A arg);",- prVisitor packageAbsyn funs,- "}"- ])]- where cls = identCat cat--prVisitor :: String -> [String] -> String-prVisitor packageAbsyn funs = - unlines [- " public interface Visitor <R,A> {",- unlines (map prVisitFun funs),- " }"- ]- where- prVisitFun f = " public R visit(" ++ packageAbsyn ++ "." ++ f ++ " p, A arg);"----Generates classes for a rule, depending on what type of rule it is.-prRule :: String -- ^ Header- -> String -- ^ Abstract syntax package name- -> [String] -- ^ Names of all constructors in the category- -> [UserDef] -> String -> (Fun, [Cat]) -> Maybe (String, String)-prRule h packageAbsyn funs user c (fun, cats) = - if isNilFun fun || isOneFun fun- then Nothing --these are not represented in the AbSyn- else if isConsFun fun- then Just $ (fun', --this is the linked list case.- unlines- [- h,- "public class" +++ fun' +++ "extends java.util.LinkedList<"++ et ++"> {",- "}"- ])- else Just $ (fun, --a standard rule- unlines- [- h,- "public class" +++ fun ++ ext +++ "{",- (prInstVars vs),- prConstructor fun user vs cats,- prAccept packageAbsyn c fun,- prEquals packageAbsyn fun vs,- prHashCode packageAbsyn fun vs,- if isAlsoCategory then prVisitor packageAbsyn funs else "",- "}"- ])- where - vs = getVars cats user- fun' = identCat (normCat c)- isAlsoCategory = fun == c- --This handles the case where a LBNF label is the same as the category.- ext = if isAlsoCategory then "" else " extends" +++ (identCat c)- et = typename (normCatOfList c) user-----The standard accept function for the Visitor pattern-prAccept :: String -> String -> String -> String-prAccept pack cat _ = "\n public <R,A> R accept(" ++ pack ++ "." ++ cat - ++ ".Visitor<R,A> v, A arg) { return v.visit(this, arg); }\n"---- Creates the equals() method.-prEquals :: String -> String -> [IVar] -> String-prEquals pack fun vs = - unlines $ map (" "++) $ ["public boolean equals(Object o) {",- " if (this == o) return true;",- " if (o instanceof " ++ fqn ++ ") {"]- ++ (if null vs - then [" return true;"]- else [" " ++ fqn +++ "x = ("++fqn++")o;",- " return " ++ checkKids ++ ";"]) ++- [" }",- " return false;",- "}"]- where - fqn = pack++"."++fun- checkKids = concat $ intersperse " && " $ map checkKid vs- checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")"- where v = iVarName iv---- Creates the equals() method.-prHashCode :: String -> String -> [IVar] -> String-prHashCode pack fun vs = - unlines $ map (" "++) ["public int hashCode() {",- " return " ++ hashKids vs ++ ";",- "}"- ]- where - aPrime = 37- hashKids [] = show aPrime- hashKids (v:vs) = hashKids_ (hashKid v) vs- hashKids_ r [] = r- hashKids_ r (v:vs) = hashKids_ (show aPrime ++ "*" ++ "(" ++ r ++ ")+" ++ hashKid v) vs- hashKid iv = "this." ++ iVarName iv ++ ".hashCode()"-----A class's instance variables.-prInstVars :: [IVar] -> String-prInstVars [] = []-prInstVars vars@((t,n,nm):vs) = - " public" +++ "final" +++ t +++ uniques ++ ";" ++++- (prInstVars vs')- where- (uniques, vs') = prUniques t vars- --these functions group the types together nicely- prUniques :: String -> [IVar] -> (String, [IVar])- prUniques t vs = (prVars (findIndices (\x -> case x of (y,_,_) -> y == t) vs) vs, remType t vs)- prVars (x:[]) vs = iVarName (vs!!x)- prVars (x:xs) vs = iVarName (vs!!x) ++ "," +++ prVars xs vs- remType :: String -> [IVar] -> [IVar]- remType _ [] = []- remType t ((t2,n,nm):ts) = if t == t2 - then (remType t ts) - else (t2,n,nm) : (remType t ts)--iVarName :: IVar -> String-iVarName (t,n,nm) = varName t nm ++ showNum n----The constructor just assigns the parameters to the corresponding instance variables.-prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> String-prConstructor c u vs cats = - " public" +++ c ++"(" ++ (interleave types params) ++ ")" +++ "{" +++ - prAssigns vs params ++ "}"- where- (types, params) = unzip (prParams cats u (length cats) ((length cats)+1))- interleave _ [] = []- interleave (x:[]) (y:[]) = x +++ y- interleave (x:xs) (y:ys) = x +++ y ++ "," +++ (interleave xs ys)----Prints the parameters to the constructors. -prParams :: [Cat] -> [UserDef] -> Int -> Int -> [(String,String)]-prParams [] _ _ _ = []-prParams (c:cs) u n m = (identCat c',"p" ++ (show (m-n)))- : (prParams cs u (n-1) m)- where- c' = typename c u- ---This algorithm peeks ahead in the list so we don't use map or fold-prAssigns :: [IVar] -> [String] -> String-prAssigns [] _ = []-prAssigns _ [] = []-prAssigns ((t,n,nm):vs) (p:ps) =- if n == 1 then- case findIndices (\x -> case x of (l,r,_) -> l == t) vs of- [] -> (varName t nm) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)- z -> ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)- else ((varName t nm) ++ (showNum n)) +++ "=" +++ p ++ ";" +++ (prAssigns vs ps)----Different than the standard NamedVariables version because of the user-defined---types.-getVars :: [Cat] -> [UserDef] -> [IVar]-getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs)- where- addVar is c = (c', n, nm):is- where c' = typename c user- nm = if c == c' then Nothing else Just c- n = maximum (1:[n'+1 | (t,n',_) <- is, t == c'])- singleToZero is = [(t,n',nm) | (t,n,nm) <- is, - let n' = if length (filter (hasType t) is) == 1 - then 0 else n]- hasType t (t',_,_) = t == t'--varName :: String -- ^ Category- -> Maybe String -- ^ Java type name- -> String -- ^ Variable name-varName c jt = (map toLower c') ++ "_"- where- c' = fromMaybe c jt----This makes up for the fact that there's no typedef in Java-typename :: String -> [UserDef] -> String-typename t user = - if t == "Ident" - then "String" - else if t == "Char" - then "Character" - else if elem t user- then "String"- else t
− src/formats/java1.5/CFtoJavaPrinter15.hs
@@ -1,361 +0,0 @@-{-- BNF Converter: Java Pretty Printer generator- Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---{- - **************************************************************- BNF Converter Module-- Description : This module generates the Java Pretty Printer- class. In addition, since there's no good way- to display a class heirarchy (toString() doesn't- count) in Java, it generates a method that- displays the Abstract Syntax in a way similar- to Haskell.- - This uses Appel's method and may serve as a- useful example to those who wish to use it.-- Author : Michael Pellauer (pellauer@cs.chalmers.se),- Bjorn Bringert (bringert@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 24 April, 2003 -- Modified : 9 Aug, 2004 -- Added string buffer for efficiency (Michael, August 03)- ************************************************************** --}-module CFtoJavaPrinter15 ( cf2JavaPrinter ) where--import CFtoJavaAbs15--import CF-import NamedVariables-import Utils ( (+++) )-import Data.List-import Data.Char ( toLower, isSpace )----Produces the PrettyPrinter class.---It will generate two methods "print" and "show"---print is the actual pretty printer for linearization.---show produces a Haskell-style syntax that can be extremely useful---especially for testing parser correctness.--cf2JavaPrinter :: String -> String -> CF -> String-cf2JavaPrinter packageBase packageAbsyn cf =- unlines - [- header,- prEntryPoints packageAbsyn cf,- unlines (map (prData packageAbsyn user) groups),- unlines (map (shData packageAbsyn user) groups),- footer- ]- where- user = [n | (n,_) <- tokenPragmas cf]- groups = fixCoercions (ruleGroupsInternals cf)- header = unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "",- "public class PrettyPrinter",- "{",- " //For certain applications increasing the initial size of the buffer may improve performance.",- " private static final int INITIAL_BUFFER_SIZE = 128;",- " //You may wish to change the parentheses used in precedence.",- " private static final String _L_PAREN = new String(\"(\");",- " private static final String _R_PAREN = new String(\")\");",- prRender- ]- footer = unlines [ --later only include used categories- " private static void pp(Integer n, int _i_) { buf_.append(n); buf_.append(\" \"); }",- " private static void pp(Double d, int _i_) { buf_.append(d); buf_.append(\" \"); }",- " private static void pp(String s, int _i_) { buf_.append(s); buf_.append(\" \"); }",- " private static void pp(Character c, int _i_) { buf_.append(\"'\" + c.toString() + \"'\"); buf_.append(\" \"); }",- " private static void sh(Integer n) { render(n.toString()); }",- " private static void sh(Double d) { render(d.toString()); }",- " private static void sh(Character c) { render(c.toString()); }",- " private static void sh(String s) { printQuoted(s); }",- " private static void printQuoted(String s) { render(\"\\\"\" + s + \"\\\"\"); }",- " private static void indent()",- " {",- " int n = _n_;",- " while (n > 0)",- " {",- " buf_.append(\" \");",- " n--;",- " }",- " }",- " private static void backup()",- " {",- " if (buf_.charAt(buf_.length() - 1) == ' ') {",- " buf_.setLength(buf_.length() - 1);",- " }",- " }",- " private static void trim()",- " {",- " while (buf_.length() > 0 && buf_.charAt(0) == ' ')",- " buf_.deleteCharAt(0); ",- " while (buf_.length() > 0 && buf_.charAt(buf_.length()-1) == ' ')",- " buf_.deleteCharAt(buf_.length()-1);",- " }", - " private static int _n_ = 0;",- " private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);",- "}"- ]----An extremely simple renderer for terminals.-prRender :: String-prRender = unlines- [- " //You may wish to change render",- " private static void render(String s)",- " {",- " if (s.equals(\"{\"))",- " {",- " buf_.append(\"\\n\");",- " indent();",- " buf_.append(s);",- " _n_ = _n_ + 2;",- " buf_.append(\"\\n\");",- " indent();",- " }",- " else if (s.equals(\"(\") || s.equals(\"[\"))",- " buf_.append(s);",- " else if (s.equals(\")\") || s.equals(\"]\"))",- " {",- " backup();",- " buf_.append(s);",- " buf_.append(\" \");",- " }",- " else if (s.equals(\"}\"))",- " {",- " _n_ = _n_ - 2;",- " backup();",- " backup();",- " buf_.append(s);",- " buf_.append(\"\\n\");",- " indent();",- " }",- " else if (s.equals(\",\"))",- " {",- " backup();",- " buf_.append(s);",- " buf_.append(\" \");",- " }",- " else if (s.equals(\";\"))",- " {",- " backup();",- " buf_.append(s);",- " buf_.append(\"\\n\");",- " indent();",- " }",- " else if (s.equals(\"\")) return;",- " else",- " {",- " buf_.append(s);",- " buf_.append(\" \");",- " }",- " }"- ]--prEntryPoints :: String -> CF -> String-prEntryPoints packageAbsyn cf =- msg ++ concat (map prEntryPoint (allCats cf)) ++ msg2- where- msg = " // print and show methods are defined for each category.\n"- msg2 = " /*** You shouldn't need to change anything beyond this point. ***/\n"- prEntryPoint cat | (normCat cat) == cat = unlines- [- " public static String print(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",- " {",- " pp(foo, 0);",- " trim();",- " String temp = buf_.toString();",- " buf_.delete(0,buf_.length());",- " return temp;",- " }",- " public static String show(" ++ packageAbsyn ++ "." ++ cat' ++ " foo)",- " {",- " sh(foo);",- " String temp = buf_.toString();",- " buf_.delete(0,buf_.length());",- " return temp;",- " }"- ]- where- cat' = identCat cat- prEntryPoint _ = ""--prData :: String -> [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = - if isList cat- then unlines- [- " private static void pp(" ++ packageAbsyn ++ "."- ++ identCat (normCat cat) +++ "foo, int _i_)",- " {",- (prList user cat rules) ++ " }"- ]- else unlines --not a list- [- " private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)",- " {",- (concat (addElse $ map (prRule packageAbsyn) rules)) ++ " }"- ]- where addElse = map (" "++). intersperse "else " . filter (not . null) . map (dropWhile isSpace)--prRule :: String -> Rule -> String-prRule packageAbsyn r@(Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = concat- [- " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n",- " {\n",- " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("- ++ packageAbsyn ++ "." ++ fun ++ ") foo;\n",- lparen,- cats',- rparen,- " }\n"- ]- where- p = precRule r- (lparen, rparen) = - (" if (_i_ > " ++ (show p) ++ ") render(_L_PAREN);\n",- " if (_i_ > " ++ (show p) ++ ") render(_R_PAREN);\n")- cats' = case cats of - [] -> ""- _ -> concatMap (prCat fnm) (zip (fixOnes (numVars [] cats)) (map getPrec cats))- fnm = '_' : map toLower fun-- getPrec (Right {}) = 0- getPrec (Left c) = precCat c--prRule _nm _ = ""--prList :: [UserDef] -> Cat -> [Rule] -> String-prList user c rules = unlines- [- " for (java.util.Iterator<" ++ et- ++ "> it = foo.iterator(); it.hasNext();)",- " {",- " pp(it.next(), 0);",- " if (it.hasNext()) {",- " render(\"" ++ sep ++ "\");",- " } else {",- " render(\"" ++ optsep ++ "\");",- " }",- " }"- ]- where- et = typename (normCatOfList c) user- sep = escapeChars $ getCons rules- optsep = if hasOneFunc rules then "" else sep--prCat fnm (c, p) = - case c of- Right t -> " render(\"" ++ escapeChars t ++ "\");\n"- Left nt | "string" `isPrefixOf` nt- -> " printQuoted(" ++ fnm ++ "." ++ nt ++ ");\n"- | isInternalVar nt -> ""- | otherwise- -> " pp(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");\n"----The following methods generate the Show function.--shData :: String -> [UserDef] -> (Cat, [Rule]) -> String-shData packageAbsyn user (cat, rules) = - if isList cat- then unlines- [- " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",- " {",- (shList user cat rules) ++ " }"- ]- else unlines - [- " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)",- " {",- (concat (map (shRule packageAbsyn) rules)) ++ " }"- ]--shRule :: String -> Rule -> String-shRule packageAbsyn (Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = unlines- [- " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")",- " {",- " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("- ++ packageAbsyn ++ "." ++ fun ++ ") foo;",- members ++ " }"- ]- where- members = concat- [- lparen,- " render(\"" ++ (escapeChars fun) ++ "\");\n",- cats', - rparen- ]- cats' = if allTerms cats - then ""- else (concat (map (shCat fnm) (fixOnes (numVars [] cats))))- (lparen, rparen) = - if allTerms cats- then ("","")- else (" render(\"(\");\n"," render(\")\");\n")- allTerms [] = True- allTerms ((Left {}):_) = False- allTerms (_:zs) = allTerms zs- fnm = '_' : map toLower fun-shRule _nm _ = ""--shList :: [UserDef] -> Cat -> [Rule] -> String-shList user c _rules = unlines- [- " for (java.util.Iterator<" ++ et- ++ "> it = foo.iterator(); it.hasNext();)",- " {",- " sh(it.next());",- " if (it.hasNext())",- " render(\",\");",- " }"- ]- where- et = typename (normCatOfList c) user- -shCat fnm c =- case c of- Right {} -> ""- Left nt | "list" `isPrefixOf` nt - -> unlines [" render(\"[\");",- " sh(" ++ fnm ++ "." ++ nt ++ ");",- " render(\"]\");"]- | isInternalVar nt -> ""- | otherwise -> " sh(" ++ fnm ++ "." ++ nt ++ ");\n"----Helper function that escapes characters in strings-escapeChars :: String -> String-escapeChars [] = []-escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))-escapeChars ('\"':xs) = '\\' : ('\"' : (escapeChars xs))-escapeChars (x:xs) = x : (escapeChars xs)--isInternalVar x = x == internalCat ++ "_"
− src/formats/java1.5/CFtoVisitSkel15.hs
@@ -1,141 +0,0 @@-{-- BNF Converter: Java Vistor skeleton generator- Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--{- - **************************************************************- BNF Converter Module-- Description : This module generates a Skeleton function- which uses the Visitor Design Pattern, which- users may find more familiar than Appel's- method.-- Author : Michael Pellauer (pellauer@cs.chalmers.se),- Bjorn Bringert (bringert@cs.chalmers.se)-- License : GPL (GNU General Public License)-- Created : 4 August, 2003 -- Modified : 16 June, 2004 -- - ************************************************************** --}-module CFtoVisitSkel15 (cf2VisitSkel) where--import CF-import CFtoJavaAbs15 (typename)-import Utils ((+++), (++++))-import NamedVariables-import Data.List-import Data.Char(toLower, toUpper, isDigit)----Produces a Skeleton using the Visitor Design Pattern.---Thus the user can choose which Skeleton to use.--cf2VisitSkel :: String -> String -> CF -> String-cf2VisitSkel packageBase packageAbsyn cf = - concat [- header,--- " // NOT IMPLEMENTED for java1.5\n",- concatMap (prData packageAbsyn user) groups,- "}"]- where- user = fst (unzip (tokenPragmas cf))- groups = (fixCoercions (ruleGroups cf))- header = unlines [- "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;",- "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",- "/* This implements the common visitor design pattern.",- " Tests show it to be slightly less efficient than the",- " instanceof method, but easier to use. ",- " Replace the R and A parameters with the desired return",- " and context types.*/",- "",- "public class VisitSkel",- "{"- ]-- ---Traverses a category based on its type.-prData :: String -> [UserDef] -> (Cat, [Rule]) -> String-prData packageAbsyn user (cat, rules) = - if isList cat- then ""- else unlines [" public class " ++ identCat cat ++ "Visitor<R,A> implements "- ++ identCat cat ++ ".Visitor<R,A>",- " {",- concatMap (prRule packageAbsyn user) rules,- " }"- ]----traverses a standard rule.-prRule :: String -> [UserDef] -> Rule -> String-prRule packageAbsyn user (Rule fun c cats) | not (isCoercion fun || isDefinedRule fun) = unlines- [- " public R visit(" ++ packageAbsyn ++ "." ++ fun ++ " p, A arg)",- " {",- " /* Code For " ++ fun ++ " Goes Here */",- "",- concatMap (uncurry (prCat user)) cats',- " return null;",- " }"- ]- where- cats' = if allTerms cats- then []- else [ (c,v) | - (Left c, Left v) <- zip cats (fixOnes (numVars [] cats)) ]- allTerms [] = True- allTerms ((Left z):zs) = False- allTerms (z:zs) = allTerms zs-prRule user nm _ = ""----Traverses a class's instance variables.-prCat :: [UserDef] - -> Cat -- ^ Variable category- -> String -- ^ Variable name- -> String -- ^ Code for visiting the variable-prCat user cat nt | isBasic user nt = " //" ++ var ++ ";\n"- | "list" `isPrefixOf` nt = listAccept- | otherwise = " " ++ accept ++ "\n"- where- var = "p." ++ nt- varType = typename (normCat (identCat cat)) user- accept = var ++ ".accept(new " ++ varType ++ "Visitor<R,A>(), arg);"- et = typename (normCatOfList cat) user- listAccept = unlines [" for (" ++ et ++ " x : " ++ var ++ ") {", - " }"]----Just checks if something is a basic or user-defined type.---This is because you don't -> a basic non-pointer type.-isBasic :: [UserDef] -> String -> Bool-isBasic user v = - if elem (init v) user'- then True- else if "integer_" `isPrefixOf` v then True- else if "char_" `isPrefixOf` v then True- else if "string_" `isPrefixOf` v then True- else if "double_" `isPrefixOf` v then True- else if "ident_" `isPrefixOf` v then True- else False- where- user' = map (map toLower) user
− src/formats/java1.5/JavaTop15.hs
@@ -1,281 +0,0 @@-{-- BNF Converter: Java Top File- Copyright (C) 2004 Author: Markus Forsberg, Peter Gammie, - Michael Pellauer, Bjorn Bringert-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}------------------------------------------------------------------------ |--- Module : JavaTop--- Copyright : (C)opyright 2003, {markus, aarne, pellauer, peteg, bringert} at cs dot chalmers dot se--- License : GPL (see COPYING for details)--- --- Maintainer : {markus, aarne} at cs dot chalmers dot se--- Stability : alpha--- Portability : Haskell98------ Top-level for the Java back end.------ > $Id: JavaTop15.hs,v 1.12 2007/01/08 18:20:23 aarne Exp $----------------------------------------------------------------------module JavaTop15 ( makeJava15 ) where ------------------------------------------------------------------------ Dependencies.---------------------------------------------------------------------import System.Directory ( createDirectory )-import System.IO.Error ( isAlreadyExistsError )-import System.Exit ( exitFailure )-import Utils-import CF-import CFtoCup15 ( cf2Cup )-import CFtoJLex15-import CFtoJavaAbs15 ( cf2JavaAbs )-import CFtoJavaPrinter15---import CFtoJavaSkeleton-import CFtoVisitSkel15-import CFtoComposVisitor-import CFtoAbstractVisitor-import CFtoFoldVisitor-import CFtoAllVisitor-import CFtoLatex-import Data.Char-import Data.List(intersperse)------------------------------------------------------------------------ | Build the Java output.--- FIXME: get everything to put the files in the right places.--- Adapt Makefile to do the business.---------------------------------------------------------------------makeJava15 :: Bool - -> Maybe String -- ^ Java package name to put the classes in- -> String -- ^ Name of grammar- -> CF -- ^ Grammar file- -> IO ()-makeJava15 = mkFiles--mkFiles :: Bool -> Maybe String -> String -> CF -> IO ()-mkFiles make inPackage name cf =- do -- Create the package directories if necessary.- let packageBase = case inPackage of- Nothing -> name- Just p -> p ++ "." ++ name- packageAbsyn = packageBase ++ "." ++ "Absyn"- dirBase = pkgToDir packageBase- dirAbsyn = pkgToDir packageAbsyn- prepareDir dirBase- prepareDir dirAbsyn- let absynFiles = remDups $ cf2JavaAbs packageBase packageAbsyn cf- absynBaseNames = map fst absynFiles- absynFileNames = map (dirAbsyn ++) absynBaseNames- absynFuns = [ f | (_,ps) <- cf2data cf, (f,_) <- ps ]- let writeAbsyn (filename, contents) =- writeFileRep (dirAbsyn ++ filename ++ ".java") contents- mapM writeAbsyn absynFiles- writeFileRep (dirBase ++ "PrettyPrinter.java") $ cf2JavaPrinter packageBase packageAbsyn cf- writeFileRep (dirBase ++ "VisitSkel.java") $ cf2VisitSkel packageBase packageAbsyn cf- writeFileRep (dirBase ++ "ComposVisitor.java") $ cf2ComposVisitor packageBase packageAbsyn cf- writeFileRep (dirBase ++ "AbstractVisitor.java") $ cf2AbstractVisitor packageBase packageAbsyn cf- writeFileRep (dirBase ++ "FoldVisitor.java") $ cf2FoldVisitor packageBase packageAbsyn cf- writeFileRep (dirBase ++ "AllVisitor.java") $ cf2AllVisitor packageBase packageAbsyn cf- writeFileRep (dirBase ++ "Test.java") $ javaTest packageBase packageAbsyn cf---- writeFileRep ("Test" ++ name) $ "java " ++ dirBase ++ "Test $(1)"- let (lex, env) = cf2jlex packageBase packageAbsyn cf- writeFileRep (dirBase ++ "Yylex") lex- putStrLn " (Tested with JLex 1.2.6.)"- writeFileRep (dirBase ++ name ++ ".cup") $ cf2Cup packageBase packageAbsyn cf env- -- FIXME: put in a doc directory?- putStrLn $ " (Parser created for category " ++ firstEntry cf ++ ")"- putStrLn " (Tested with CUP 0.10k)"- writeFileRep (name ++ ".tex") $ cfToLatex name cf- if make- then writeFileRep "Makefile" $ makefile name dirBase dirAbsyn absynFileNames- else return ()- where- remDups [] = []- remDups ((a,b):as) = case lookup a as of- Just {} -> remDups as- Nothing -> (a, b) : (remDups as)-- pkgToDir :: String -> FilePath- pkgToDir s = replace '.' pathSep s ++ [pathSep]----- FIXME get filenames right.--- FIXME It's almost certainly better to just feed all the Java source--- files to javac in one go.--- Replace with an ANT script?-makefile :: String -> FilePath -> FilePath -> [String] -> String-makefile name dirBase dirAbsyn absynFileNames =- unlines - [- "JAVAC = javac",- "JAVAC_FLAGS = -sourcepath .",- "",- "JAVA = java",- "JAVA_FLAGS =",- "",- "CUP = java_cup.Main",- "CUPFLAGS = -nopositions -expect 100",- "",- "JLEX = JLex.Main",- "",- "LATEX = latex",- "DVIPS = dvips",- "",- "all: test " ++ name ++ ".ps",- "",- "test: absyn "- ++ unwords (map (dirBase ++) [- "Yylex.class",- "PrettyPrinter.class",- "Test.class",- "ComposVisitor.class",- "AbstractVisitor.class",- "FoldVisitor.class",- "AllVisitor.class",- "parser.class",- "sym.class",- "Test.class"]),- "",- ".PHONY: absyn",- "",- "%.class: %.java",- "\t${JAVAC} ${JAVAC_FLAGS} $^",- "",- "absyn: " ++ absynJavaSrc,- "\t${JAVAC} ${JAVAC_FLAGS} $^",- "",- dirBase ++ "Yylex.java: " ++ dirBase ++ "Yylex",- "\t${JAVA} ${JAVA_FLAGS} ${JLEX} " ++ dirBase ++ "Yylex",- "",- dirBase ++ "sym.java " ++ dirBase ++ "parser.java: " ++ dirBase ++ name ++ ".cup",- "\t${JAVA} ${JAVA_FLAGS} ${CUP} ${CUPFLAGS} " ++ dirBase ++ name ++ ".cup",- "\tmv sym.java parser.java " ++ dirBase,- "",- dirBase ++ "Yylex.class: " ++ dirBase ++ "Yylex.java"- ++ " " ++ dirBase ++ "sym.java",- "",- dirBase ++ "sym.class: " ++ dirBase ++ "sym.java",- "",- dirBase ++ "parser.class: " ++ dirBase ++ "parser.java " ++ dirBase ++ "sym.java",- "",- dirBase ++ "PrettyPrinter.class: " ++ dirBase ++ "PrettyPrinter.java",- "",- "" ++ name ++ ".dvi: " ++ name ++ ".tex",- "\t${LATEX} " ++ name ++ ".tex",- "",- "" ++ name ++ ".ps: " ++ name ++ ".dvi",- "\t${DVIPS} " ++ name ++ ".dvi -o " ++ name ++ ".ps",--- FIXME- "",- "clean:",- "\t rm -f " ++ dirAbsyn ++ "*.class" ++ " " ++ dirBase ++ "*.class",- "\t rm -f " ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps " ++ " *.class",- "",- "distclean: vclean",- "",- "vclean:",- "\t rm -f " ++ absynJavaSrc ++ " " ++ absynJavaClass,- "\t rm -f " ++ dirAbsyn ++ "*.class", ---- "\t rm -f " ++ "Test" ++ name,- "\t rmdir " ++ dirAbsyn,- "\t rm -f " ++ name ++ ".tex " ++ name ++ ".dvi " ++ name ++ ".aux " ++ name ++ ".log " ++ name ++ ".ps ",- "\t rm -f " ++ unwords (map (dirBase ++) [- "Yylex",- name ++ ".cup",- "Yylex.java",- "VisitSkel.java",- "ComposVisitor.java",- "AbstractVisitor.java",- "FoldVisitor.java",- "AllVisitor.java",- "PrettyPrinter.java",- "Skeleton.java",- "Test.java",- "sym.java",- "parser.java",- "*.class"]),- "\t rm -f Makefile",- "\t rmdir -p " ++ dirBase,- ""- ]- where absynJavaSrc = unwords (map (++ ".java") absynFileNames)- absynJavaClass = unwords (map (++ ".class") absynFileNames)--javaTest :: String -> String -> CF -> String-javaTest packageBase packageAbsyn cf =- unlines- [- "package" +++ packageBase ++ ";",- "import java_cup.runtime.*;",- "import" +++ packageBase ++ ".*;",- "import" +++ packageAbsyn ++ ".*;",- "import java.io.*;",- "",- "public class Test",- "{",- " public static void main(String args[]) throws Exception",- " {",- " Yylex l = null;",- " parser p;",- " try",- " {",- " if (args.length == 0) l = new Yylex(System.in);",- " else l = new Yylex(new FileReader(args[0]));",- " }",- " catch(FileNotFoundException e)",- " {",- " System.err.println(\"Error: File not found: \" + args[0]);",- " System.exit(1);",- " }",- " p = new parser(l);",- " /* The default parser is the first-defined entry point. */",- " /* You may want to change this. Other options are: */",- " /* " ++ (concat (intersperse ", " (showOpts (tail eps)))) ++ " */",- " try",- " {",- " " ++ packageAbsyn ++ "." ++ def +++ "parse_tree = p.p" - ++ def ++ "();",- " System.out.println();",- " System.out.println(\"Parse Succesful!\");",- " System.out.println();",- " System.out.println(\"[Abstract Syntax]\");",- " System.out.println();",- " System.out.println(PrettyPrinter.show(parse_tree));",- " System.out.println();",- " System.out.println(\"[Linearized Tree]\");",- " System.out.println();",- " System.out.println(PrettyPrinter.print(parse_tree));",- " }",- " catch(Throwable e)",- " {",- " System.err.println(\"At line \" + String.valueOf(l.line_num()) + \", near \\\"\" + l.buff() + \"\\\" :\");",- " System.err.println(\" \" + e.getMessage());",- " System.exit(1);",- " }",- " }",- "}"- ]- where eps = allEntryPoints cf- def = head eps- showOpts [] = []-- showOpts (x:[]) = if normCat x /= x then [] else ['p' : (identCat x)]- showOpts (x:xs) = if normCat x /= x then (showOpts xs) - else ('p' : (identCat x)) : (showOpts xs)
− src/formats/ocaml/CFtoOCamlAbs.hs
@@ -1,63 +0,0 @@-{-- BNF Converter: OCaml Abstract Syntax Generator- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- based on BNFC Haskell backend--module CFtoOCamlAbs (cf2Abstract) where--import CF-import Utils((+++),(++++))-import Data.List(intersperse)-import OCamlUtil---- to produce an OCaml module-cf2Abstract :: String -> CF -> String-cf2Abstract name cf = unlines $ - "(* OCaml module generated by the BNF converter *)\n\n" :- mutualRecDefs (map (prSpecialData cf) (specialCats cf) ++ map prData (cf2data cf))---- allow mutual recursion so that we do not have to sort the type definitions in--- dependency order-mutualRecDefs :: [String] -> [String]-mutualRecDefs ss = case ss of- [] -> []- [x] -> ["type" +++ x]- x:xs -> ("type" +++ x) : map ("and" +++) xs- ---prData :: Data -> String-prData (cat,rules) = - fixType cat +++ "=\n " ++- concat (intersperse "\n | " (map prRule rules)) ++- "\n"--prRule (fun,[]) = fun-prRule (fun,cats) = fun +++ "of" +++ mkTupleType cats--mkTupleType [c] = fixType c-mkTupleType (c:cs) = fixType c +++ "*" +++ mkTupleType cs--prSpecialData :: CF -> Cat -> String-prSpecialData cf cat = fixType cat +++ "=" +++ cat +++ "of" +++ contentSpec cf cat--- unwords ["newtype",cat,"=",cat,contentSpec cf cat,"deriving (Eq,Ord,Show)"]--contentSpec :: CF -> Cat -> String-contentSpec cf cat = -- if isPositionCat cf cat then "((Int,Int),String)" else "String"- if isPositionCat cf cat then "((int * int) * string)" else "string"
− src/formats/ocaml/CFtoOCamlLex.hs
@@ -1,230 +0,0 @@-{-- BNF Converter: ocamllex Generator- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}----- based on BNFC Haskell backend--module CFtoOCamlLex (cf2ocamllex) where--import Data.List-import Data.Char--import CF-import AbsBNF-import CFtoOCamlYacc (terminal)-import Utils ((+++))--cf2ocamllex :: String -> String -> CF -> String-cf2ocamllex name parserMod cf = - unlines $ concat $ intersperse [""] [- header parserMod cf,- definitions cf,- let r = rules cf in case r of - [] -> []- x:xs -> ("rule" +++ x) : map ("and" +++) xs- ]--header :: String -> CF -> [String]-header parserMod cf = [- "(* This ocamllex file was machine-generated by the BNF converter *)",- "{",- "open " ++ parserMod,- "open Lexing",- "",- hashtables cf,- "", - "let unescapeInitTail (s:string) : string =",- " let rec unesc s = match s with",- " '\\\\'::c::cs when List.mem c ['\\\"'; '\\\\'; '\\\''] -> c :: unesc cs",- " | '\\\\'::'n'::cs -> '\\n' :: unesc cs",- " | '\\\\'::'t'::cs -> '\\t' :: unesc cs",- " | '\\\"'::[] -> []",- " | c::cs -> c :: unesc cs",- " | _ -> []",- " (* explode/implode from caml FAQ *)",- " in let explode (s : string) : char list =",- " let rec exp i l =",- " if i < 0 then l else exp (i - 1) (s.[i] :: l) in",- " exp (String.length s - 1) []",- " in let implode (l : char list) : string =",- " let res = String.create (List.length l) in",- " let rec imp i = function",- " | [] -> res",- " | c :: l -> res.[i] <- c; imp (i + 1) l in",- " imp 0 l",- " in implode (unesc (List.tl (explode s)))",- "",- "let incr_lineno (lexbuf:Lexing.lexbuf) : unit =",- " let pos = lexbuf.lex_curr_p in",- " lexbuf.lex_curr_p <- { pos with",- " pos_lnum = pos.pos_lnum + 1;", - " pos_bol = pos.pos_cnum;",- " }",- "}"- ]---- | set up hashtables for reserved symbols and words-hashtables :: CF -> String-hashtables cf = ht "symbol_table" (symbols cf ) ++ "\n" ++ - ht "resword_table" (reservedWords cf)- where ht table syms | length syms == 0 = ""- ht table syms = unlines [ - "let" +++ table +++ "= Hashtbl.create " ++ show (length syms),- "let _ = List.iter (fun (kwd, tok) -> Hashtbl.add" +++ table - +++ "kwd tok)",- " [" ++ concat (intersperse ";" keyvals) ++ "]"- ]- where keyvals = map (\(x,y) -> "(" ++ x ++ ", " ++ y ++ ")")- (zip (map show syms) (map (terminal cf) syms))----definitions :: CF -> [String]-definitions cf = concat [- cMacros,- rMacros cf- ]---cMacros :: [String]-cMacros = [- "let l = ['a'-'z' 'A'-'Z' '\\192' - '\\255'] # ['\\215' '\\247'] (* isolatin1 letter FIXME *)",- "let c = ['A'-'Z' '\\192'-'\\221'] # ['\\215'] (* capital isolatin1 letter FIXME *)",- "let s = ['a'-'z' '\\222'-'\\255'] # ['\\247'] (* small isolatin1 letter FIXME *)",- "let d = ['0'-'9'] (* digit *)",- "let i = l | d | ['_' '\\''] (* identifier character *)",- "let u = ['\\000'-'\\255'] (* universal: any character *)"- ]--rMacros :: CF -> [String]-rMacros cf = - let symbs = symbols cf - in- (if null symbs then [] else [- "let rsyms = (* reserved words consisting of special symbols *)",- " " ++ unwords (intersperse "|" (map mkEsc symbs))- ])- where- mkEsc s = "\"" ++ concat (map f s) ++ "\""- f x = if x `elem` ['"','\\'] then "\\" ++ [x] else [x]----rules :: CF -> [String]-rules cf = oneRule $ concat [- lexComments (comments cf),- ["l i* " ++ case reservedWords cf of- [] -> "{let id = lexeme lexbuf in TOK_Ident id}"- _ -> "{let id = lexeme lexbuf in try Hashtbl.find resword_table id with Not_found -> TOK_Ident id}"- ],- if null (symbols cf) then [] - else ["rsyms {let id = lexeme lexbuf in try Hashtbl.find symbol_table id with Not_found -> failwith (\"internal lexer error: reserved symbol \" ^ id ^ \" not found in hashtable\")}"],- ["d+ {let i = lexeme lexbuf in TOK_Integer (int_of_string i)}"],- ["d+ '.' d+ ('e' ('-')? d+)? {let f = lexeme lexbuf in TOK_Double (float_of_string f)}"],- ["'\\\"' ((u # ['\\\"' '\\\\' '\\n']) | ('\\\\' ('\\\"' | '\\\\' | '\\\'' | 'n' | 't')))* '\\\"' {let s = lexeme lexbuf in TOK_String (unescapeInitTail s)}"],- ["[' ' '\\t'] {token lexbuf}"],- ["'\\n' {incr_lineno lexbuf; token lexbuf}"],- ["eof { TOK_EOF }"]- ] - where- oneRule xs = ["token = \n parse " ++ concat (intersperse "\n | " xs)]- lexComments ([],[]) = []- lexComments (xs,s1:ys) = ('\"' : s1 ++ "\"" ++ - " (_ # '\\n')* { token lexbuf } (* Toss single line comments *)") : - lexComments (xs, ys)- lexComments (([l1,l2],[r1,r2]):xs,[]) = (concat $- [- ('\"':l1:l2:"\" ((u # ['"), -- FIXME quotes or escape?- (l2:"']) | '"),- (r1:"' (u # ['"),- (r2:"']))* ('"),- (r1:"')+ '"),- (r2:"' { token lexbuf } \n")- ]) : - lexComments (xs, [])- lexComments ((_:xs),[]) = lexComments (xs,[]) - ------------------------------------------------------------------------ Modified from the inlined version of @RegToAlex@.------------------------------------------------------------------------ modified from pretty-printer generated by the BNF converter---- the top-level printing method-printRegOCaml :: Reg -> String-printRegOCaml = render . prt 0---- you may want to change render and parenth--render :: [String] -> String-render = rend 0- where rend :: Int -> [String] -> String- rend i ss = case ss of- "[" :ts -> cons "[" $ rend i ts- "(" :ts -> cons "(" $ rend i ts- t : "," :ts -> cons t $ space "," $ rend i ts- t : ")" :ts -> cons t $ cons ")" $ rend i ts- t : "]" :ts -> cons t $ cons "]" $ rend i ts- t :ts -> space t $ rend i ts- _ -> ""-- cons s t = s ++ t- new i s = s- space t s = if null s then t else t ++ " " ++ s--parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]---- the printer class does the job-class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concat . map (prt 0)--instance Print a => Print [a] where- prt _ = prtList--instance Print Char where- prt _ c = [show c] -- if isAlphaNum c then [[c]] else ['\\':[c]]- prtList s = [show s] -- map (concat . prt 0) s--prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]--instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])- RMinus reg0 reg -> prPrec i 1 (concat [prt 2 reg0 , ["#"] , prt 2 reg])- RStar reg -> prPrec i 3 (concat [prt 3 reg , ["*"]])- RPlus reg -> prPrec i 3 (concat [prt 3 reg , ["+"]])- ROpt reg -> prPrec i 3 (concat [prt 3 reg , ["?"]])- REps -> prPrec i 3 (["\"\""]) -- special construct for eps in ocamllex?- RChar c -> prPrec i 3 (concat [prt 0 c])- RAlts str -> prPrec i 3 (concat [["["],prt 0 (concatMap show str),["]"]])- RSeqs str -> prPrec i 2 (concat (map (prt 0) str))- RDigit -> prPrec i 3 (concat [["digit"]])- RLetter -> prPrec i 3 (concat [["letter"]])- RUpper -> prPrec i 3 (concat [["upper"]])- RLower -> prPrec i 3 (concat [["lower"]])- RAny -> prPrec i 3 (concat [["univ"]])
− src/formats/ocaml/CFtoOCamlPrinter.hs
@@ -1,200 +0,0 @@-{-- BNF Converter: Pretty-printer generator- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- based on BNFC Haskell backend--module CFtoOCamlPrinter (cf2Printer) where--import CF-import Utils-import CFtoTemplate-import Data.List (intersperse)-import Data.Char(toLower,isDigit)-import OCamlUtil---- derive pretty-printer from a BNF grammar. AR 15/2/2002-cf2Printer :: String -> String -> CF -> String-cf2Printer name absMod cf = unlines [- prologue name absMod,- charRule cf,- integerRule cf,- doubleRule cf,- stringRule cf,- if hasIdent cf then identRule cf else "",- unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],- rules cf- ]---prologue :: String -> String -> String-prologue name absMod = unlines [- "(* pretty-printer generated by the BNF converter *)\n",- "open " ++ absMod,- "open Printf",- "",- "(* We use string buffers for efficient string concatenation.",- " A document takes a buffer and an indentation, has side effects on the buffer",- " and returns a new indentation. The indentation argument indicates the level",- " of indentation to be used if a new line has to be started (because of what is",- " already in the buffer) *)",- "type doc = Buffer.t -> int -> int",- "",- "let rec printTree (printer : int -> 'a -> doc) (tree : 'a) : string = ",- " let buffer_init_size = 16 (* you may want to change this *)",- " in let buffer = Buffer.create buffer_init_size",- " in ",- " let _ = printer 0 tree buffer 0 in (* discard return value *)",- " Buffer.contents buffer",- "",- "let indent_width = 4",- "",- "let indent (i: int) : string = ",- " let s = String.make (i+1) ' ' in",- " String.set s 0 '\\n';",- " s",- "",- "(* this render function is written for C-style languages, you may want to change it *)",- "let render (s : string) : doc = fun buf i -> ",- " (* invariant: last char of the buffer is never whitespace *)",- " let n = Buffer.length buf in",- " let last = if n = 0 then None else Some (Buffer.nth buf (n-1)) in",- " let whitespace = match last with",- " None -> \"\" ",- " | Some '{' -> indent i",- " | Some '}' -> (match s with",- " \";\" -> \"\"",- " | _ -> indent i)",- " | Some ';' -> indent i",- " | (Some '[') | (Some '(') -> \"\"",- " | Some _ -> (match s with",- " \",\" | \")\" | \"]\" -> \"\"",- " | _ -> \" \") in",- " let newindent = match s with",- " \"{\" -> i + indent_width",- " | \"}\" -> i - indent_width",- " | _ -> i in",- " Buffer.add_string buf whitespace;",- " Buffer.add_string buf s;",- " newindent",- "",- "let emptyDoc : doc = fun buf i -> i",- "",- "let concatD (ds : doc list) : doc = fun buf i -> ",- " List.fold_left (fun accIndent elemDoc -> elemDoc buf accIndent) (emptyDoc buf i) ds",- "",- "let parenth (d:doc) : doc = concatD [render \"(\"; d; render \")\"]",- "",- "let prPrec (i:int) (j:int) (d:doc) : doc = if j<i then parenth d else d",- ""- ]--charRule cf = unlines [- "let rec prtChar (_:int) (c:char) : doc = render (\"'\" ^ Char.escaped c ^ \"'\")",- ifList cf "Char",- ""- ]--integerRule cf = unlines [- "let rec prtInt (_:int) (i:int) : doc = render (string_of_int i)",- ifList cf "Integer",- ""- ]--doubleRule cf = unlines [- "let rec prtFloat (_:int) (f:float) : doc = render (sprintf \"%f\" f)",- ifList cf "Double",- ""- ]- -stringRule cf = unlines [- "let rec prtString (_:int) (s:string) : doc = render (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",- ifList cf "String",- ""- ]--identRule cf = ownPrintRule cf "Ident"--ownPrintRule cf own = unlines $ [- "let rec" +++ prtFun own +++ "_ (" ++ own ++ posn ++ ") : doc = render i",- ifList cf own- ]- where- posn = if isPositionCat cf own then " (_,i)" else " i"---- copy and paste from CFtoTemplate--rules :: CF -> String-rules cf = unlines $ mutualDefs $ - map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf- where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)- names [] _ = []- names (x:xs) n- | elem x xs = (x ++ show n) : names xs (n+1)- | otherwise = x : names xs n- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedOCaml = s ++ "'"- | otherwise = s- ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)----- case_fun :: Cat -> [(Constructor,Rule)] -> String-case_fun cat xs = unlines [--- "instance Print" +++ cat +++ "where",- prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with",- unlines $ insertBar $ map (\ ((c,xx),r) -> - " " ++ c +++ mkTuple xx +++ "->" +++ - "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs- ]--ifList cf cat = mkListRule $ nil cat ++ one cat ++ cons cat where- nil cat = [" [] -> " ++ mkRhs [] its | - Rule f c its <- rulesOfCF cf, isNilFun f , normCatOfList c == cat]- one cat = [" | [x] -> " ++ mkRhs ["x"] its | - Rule f c its <- rulesOfCF cf, isOneFun f , normCatOfList c == cat]- cons cat = [" | x::xs -> " ++ mkRhs ["x","xs"] its | - Rule f c its <- rulesOfCF cf, isConsFun f , normCatOfList c == cat]- mkListRule [] = ""- mkListRule rs = unlines $ ("and prt" ++ fixTypeUpper cat ++ "ListBNFC" +++ "_ es : doc = match es with"):rs---mkRhs args its = - "(concatD [" ++ unwords (intersperse ";" (mk args its)) ++ "])"- where- mk args (Left "#" : items) = mk args items- mk (arg:args) (Left c : items) = (prt c +++ arg) : mk args items- mk args (Right s : items) = ("render " ++ show s) : mk args items- mk _ _ = []- prt c = prtFun c +++ show (precCat c)--prtFun :: Cat -> String-prtFun c = case c of- '[':xs -> case break (== ']') xs of - (t,"]") -> prtFun t ++ "ListBNFC"- _ -> c -- should not occur (this means an invariant of the type Cat is broken)- _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax- then "prt" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c)))- else "prt" ++ (fixTypeUpper c)-
− src/formats/ocaml/CFtoOCamlShow.hs
@@ -1,153 +0,0 @@-{-- BNF Converter: Non-pretty-printer generator (no "deriving Show" in OCaml...)- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- there is no "deriving Show" in OCaml, although there are solutions based--- on camlp4. Here we generate our own "show module".---module CFtoOCamlShow (cf2show) where--import CF-import Utils-import CFtoTemplate-import Data.List (intersperse)-import Data.Char(toLower,isDigit)-import OCamlUtil--cf2show :: String -> String -> CF -> String-cf2show name absMod cf = unlines [- prologue name absMod,- integerRule cf,- doubleRule cf,- if hasIdent cf then identRule cf else "",- unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],- rules cf- ]---prologue :: String -> String -> String-prologue name absMod = unlines [- "(* show functions generated by the BNF converter *)\n",- "open " ++ absMod,- "",- "(* use string buffers for efficient string concatenations *)",- "type showable = Buffer.t -> unit",- "",- "let show (s : showable) : string = ",- " let init_size = 16 in (* you may want to adjust this *)",- " let b = Buffer.create init_size in",- " s b;",- " Buffer.contents b",- " ",- "let emptyS : showable = fun buf -> ()",- "",- "let c2s (c:char) : showable = fun buf -> Buffer.add_char buf c",- "let s2s (s:string) : showable = fun buf -> Buffer.add_string buf s",- "",- "let ( >> ) (s1 : showable) (s2 : showable) : showable = fun buf -> s1 buf; s2 buf",- "",- "let showChar (c:char) : showable = fun buf -> ",- " Buffer.add_string buf (\"'\" ^ Char.escaped c ^ \"'\")",- "",- "let showString (s:string) : showable = fun buf -> ",- " Buffer.add_string buf (\"\\\"\" ^ String.escaped s ^ \"\\\"\")",- "",- "let showList (showFun : 'a -> showable) (xs : 'a list) : showable = fun buf -> ",- " let rec f ys = match ys with",- " [] -> ()",- " | [y] -> showFun y buf",- " | y::ys -> showFun y buf; Buffer.add_string buf \"; \"; f ys ",- " in",- " Buffer.add_char buf '[';",- " f xs;",- " Buffer.add_char buf ']'",- ""- ] --integerRule cf = "let showInt (i:int) : showable = s2s (string_of_int i)"--doubleRule cf = "let showFloat (f:float) : showable = s2s (string_of_float f)"---identRule cf = ownPrintRule cf "Ident"--ownPrintRule cf own = unlines $ [- "let rec" +++ showsFun own +++ "(" ++ own ++ posn ++ ") : showable = s2s \"" - ++ own ++ " \" >> showString i"- ]- where- posn = if isPositionCat cf own then " (_,i)" else " i"---- copy and paste from CFtoTemplate--rules :: CF -> String-rules cf = unlines $ mutualDefs $ - map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf -- ++ ifList cf s- where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), - ruleOf cons)- names [] _ = []- names (x:xs) n- | elem x xs = (x ++ show n) : names xs (n+1)- | otherwise = x : names xs n- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedOCaml = s ++ "'"- | otherwise = s- ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)----- case_fun :: Cat -> [(Constructor,Rule)] -> String-case_fun cat xs = unlines [--- "instance Print" +++ cat +++ "where",- showsFun cat +++ "(e:" ++ fixType cat ++ ") : showable = match e with",- unlines $ insertBar $ map (\ ((c,xx),r) -> - " " ++ c +++ mkTuple xx +++ "->" +++ - "s2s" +++ show c +++ - case mkRhs xx (snd r) of {[] -> []; str -> ">> c2s ' ' >> " ++ str}- ) - xs- ]---mkRhs args its = - case unwords (intersperse " >> s2s \", \" >> " (mk args its)) of- [] -> ""- str -> "c2s '(' >> " ++ str ++ " >> c2s ')'"- where - mk args (Left "#" : items) = mk args items- mk (arg:args) (Left c : items) = (showsFun c +++ arg) : mk args items- mk args (Right s : items) = mk args items- mk _ _ = []- prt c = showsFun c +++ show (precCat c)--showsFun :: Cat -> String-showsFun c = case c of- '[':xs -> case break (== ']') xs of - (t,"]") -> "showList" +++ showsFun t -- showFun t ++ "List"- _ -> c -- should not occur (this means an invariant of the type Cat is broken)- _ -> if precCat c > 0 -- precedence-level cats are not in abstract syntax- then "show" ++ (fixTypeUpper $ reverse (dropWhile isDigit (reverse c)))- else "show" ++ (fixTypeUpper c)-
− src/formats/ocaml/CFtoOCamlTemplate.hs
@@ -1,73 +0,0 @@-{-- BNF Converter: Template Generator- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- based on BNFC Haskell backend---module CFtoOCamlTemplate (- cf2Template- ) where--import CF-import Data.Char-import Data.List (delete)-import Utils((+++))-import OCamlUtil---type ModuleName = String-type Constructor = String--cf2Template :: ModuleName -> ModuleName -> CF -> String-cf2Template skelName absName cf = unlines- [- "module "++ skelName ++ " = struct\n",- "(* OCaml module generated by the BNF converter *)\n",- "open " ++ absName ++ "\n",- "type result = string\n",- "let failure x = failwith \"Undefined case.\" (* x discarded *)\n",- unlines $ mutualDefs $ map (\(s,xs) -> case_fun s (toArgs xs)) $ specialData cf ++ cf2data cf,- "end"- ]- where toArgs [] = []- toArgs ((cons,args):xs) - = (cons ++ " " ++ (mkTuple $ names (map (checkRes . var) args) (0 :: Int))) : toArgs xs- names :: [String] -> Int -> [String]- names [] _ = []- names (x:xs) n- | elem x xs = (x ++ show n) : names xs (n+1)- | otherwise = x : names xs n- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedOCaml = s ++ "'"- | otherwise = s---case_fun :: Cat -> [Constructor] -> String-case_fun cat xs = - unlines $ - ["trans" ++ cat ++ " (x : " ++ fixType cat ++ ") : result = match x with",- unlines $ insertBar $ map (\s -> s ++ " -> " ++ "failure x") xs]-
− src/formats/ocaml/CFtoOCamlTest.hs
@@ -1,70 +0,0 @@-{-- BNF Converter: Generate main/test module for OCaml- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoOCamlTest where --import CF-import Utils-import OCamlUtil--ocamlTestfile :: String -> String -> String -> String -> String -> CF -> String-ocamlTestfile absM lexM parM printM showM cf = - let - lexerName = lexM ++ ".token"- parserName = parM ++ ".p" ++ topTypeC- printerName = printM ++ ".printTree " ++ printM ++ ".prt" ++ topTypeC- showFun = "(fun x -> " ++ showM ++ ".show (" ++ showM ++ ".show" ++ - topTypeC ++ " x))"- topTypeC = fixTypeUpper (firstEntry cf)- topType = absM ++ "." ++ fixType (firstEntry cf)- in unlines [- "(* automatically generated by the BNF Converter *)",- "",- "open Lexing",- "",- "let parse (c : in_channel) : " ++ topType ++ " = ",- " " ++ parserName +++ lexerName +++ "(Lexing.from_channel c)",- ";;",- "",- "let showTree (t : " ++ topType ++ ") : string = ",- " \"[Abstract syntax]\\n\\n\" ^ " ++ showFun +++ "t" ++ " ^ \"\\n\\n\" ^", - " \"[Linearized tree]\\n\\n\" ^ " ++ printerName +++ "t" ++ " ^ \"\\n\"",- ";;",- "",- "let main () =",- " let channel =",- " if Array.length Sys.argv > 1 then",- " open_in Sys.argv.(1)",- " else",- " stdin",- " in",- " try",- " print_string (showTree (parse channel));",- " flush stdout",- " with BNFC_Util.Parse_error (start_pos, end_pos) ->", -- " ++ parM ++ ".- " Printf.printf \"Parse error at %d.%d-%d.%d\\n\"",- " start_pos.pos_lnum (start_pos.pos_cnum - start_pos.pos_bol)",- " end_pos.pos_lnum (end_pos.pos_cnum - end_pos.pos_bol);",- ";;",- "",- "main ();;",- ""- ]--
− src/formats/ocaml/CFtoOCamlYacc.hs
@@ -1,232 +0,0 @@-{-- BNF Converter: ocamlyacc Generator- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- based on BNFC Haskell backend---module CFtoOCamlYacc - (- cf2ocamlyacc, terminal- )- where--import CF-import Data.List (intersperse,nub)-import Data.Char--import Utils ((+++))-import OCamlUtil---- Type declarations--type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String---- default naming---tokenName = "Token"------ The main function, that given a CF--- generates a ocamlyacc module. -cf2ocamlyacc :: String -> String -> String -> CF -> String-cf2ocamlyacc name absName lexName cf - = unlines - [header name absName lexName,- declarations absName cf,- "%%",- rules cf- ]---header :: String -> String -> String -> String-header modName absName lexName = unlines - ["/* This ocamlyacc file was machine-generated by the BNF converter */",- "%{",- "open " ++ absName,- "open Lexing",- "%}"- ]---declarations :: String -> CF -> String-declarations absName cf = unlines - [tokens (symbols cf) (reservedWords cf),- specialTokens cf,- entryPoints absName cf- ]- -tokens :: [String] -> [String] -> String-tokens symbols reswords = unlines- [- if (length reswords) > 0 - then "%token" +++ concat (intersperse " " (map ("TOK_" ++) reswords))- else ""- ,- concatMap (\(s,n) -> "\n%token SYMB" ++ (show n) +++ "/*" +++ s +++ "*/") - (zip symbols [1..])- ]---- | map a CF terminal into a ocamlyacc token-terminal :: CF -> String -> String-terminal cf s | s `elem` reservedWords cf = "TOK_" ++ s-terminal cf s = case lookup s (zip (symbols cf) [1..]) of- Just i -> "SYMB" ++ show i- Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF."----- | map a CF nonterminal into a ocamlyacc symbol-nonterminal :: Cat -> String-nonterminal c = map spaceToUnderscore (fixType c)- where spaceToUnderscore ' ' = '_'- spaceToUnderscore x = x--specialTokens :: CF -> String-specialTokens cf = unlines ("%token TOK_EOF" : map aux (nub $ ["Ident","String","Integer","Double","Char"] ++ literals cf))- where aux cat = "%token" +++ (case cat of- "Ident" -> "<string>"- "String" -> "<string>"- "Integer" -> "<int>"- "Double" -> "<float>"- "Char" -> "<char>"- own -> "<string>" ) - +++ "TOK_" ++ cat- --entryPoints :: String -> CF -> String-entryPoints absName cf = unlines $- ("%start" +++ - concat (intersperse " " (map epName eps))) - : - (map typing eps)- where eps = (nub $ map normCat (allEntryPoints cf))- typing :: Cat -> String- typing c = "%type" +++ "<" ++ qualify c ++ ">" +++ epName c- qualify c = if c `elem` ["Integer","Double","Char","String",- "[Integer]","[Double]","[Char]","[String]"]- then fixType c- else absName ++ "." ++ fixType c- -epName :: Cat -> String-epName c = "p" ++ capitalize (nonterminal c)- where capitalize s = case s of- [] -> []- c:cs -> toUpper c : cs--entryPointRules :: CF -> String-entryPointRules cf = unlines $ map mkRule (nub $ map normCat (allEntryPoints cf))- where- mkRule :: String -> String- mkRule s = unlines [- epName s ++ " : " ++ nonterminal s ++ " TOK_EOF { $1 }",- " | error { raise (BNFC_Util.Parse_error (Parsing.symbol_start_pos (), Parsing.symbol_end_pos ())) };"- ]--rules :: CF -> String-rules cf = unlines [- entryPointRules cf,- (unlines $ map (prOne . mkOne) (ruleGroups cf)),- specialRules cf- ]- where - mkOne (cat,rules) = constructRule cf rules cat- prOne (nt,[]) = [] -- nt has only internal use- prOne (nt,((p,a):ls)) =- unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n"- where - nt' = nonterminal nt- pr [] = []- pr ((p,a):ls) = - unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls------ For every non-terminal, we construct a set of rules. A rule is a sequence of--- terminals and non-terminals, and an action to be performed--- As an optimization, a pair of list rules [C] ::= "" | C k [C]--- is left-recursivized into [C] ::= "" | [C] C k.--- This could be generalized to cover other forms of list rules.-constructRule :: CF -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule cf rules nt = (nt,[(p,generateAction nt (funRule r) (mkFlip b m)) | - r0 <- rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf r])- where- revs = reversibleCats cf- mkFlip doit xs = case xs of- a:b:rest | doit -> b:a:rest- _ -> xs------ Generates a string containing the semantic action.--- An action can for example be: Sum $1 $2, that is, construct an AST--- with the constructor Sum applied to the two metavariables $1 and $2.-generateAction :: NonTerminal -> Fun -> [MetaVar] -> Action-generateAction nt f ms = (if isCoercion f then "" else f') +++ mkTuple ms- where f' = case f of -- ocaml cons is somehow not a standard infix oper, right?- "(:[])" -> "(fun x -> [x])"- "(:)" -> "(fun (x,xs) -> x::xs)"- _ -> f---generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])-generatePatterns cf r = case rhsRule r of- [] -> ("/* empty */",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> nonterminal c- Right s -> terminal cf s- metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]- revIf c m = if (not (isConsFun (funRule r)) && elem c revs) - then ("(List.rev " ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself- revs = reversibleCats cf------specialRules :: CF -> String-specialRules cf = unlines $- map aux (literals cf)- where - aux cat = - case cat of- "Ident" -> "ident : TOK_Ident { Ident $1 };" - "String" -> "string : TOK_String { $1 };" - "Integer" -> "int : TOK_Integer { $1 };"- "Double" -> "float : TOK_Double { $1 };"- "Char" -> "char : TOK_Char { $1 };"- own -> (fixType own) ++ " : TOK_" ++ own ++ - " { " ++ own ++ " ("++ posn ++ "$1)};"- -- PCC: take "own" as type name? (manual says newtype)- where -- ignore position categories for now- posn = "" -- if isPositionCat cf cat then "mkPosToken " else ""---
− src/formats/ocaml/OCamlTop.hs
@@ -1,188 +0,0 @@-{-- BNF Converter: OCaml main file- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}---- based on BNFC Haskell backend---module OCamlTop (makeOCaml) where --import CF-import CFtoOCamlYacc-import CFtoOCamlLex-import CFtoLatex-import CFtoOCamlAbs-import CFtoOCamlTemplate-import CFtoOCamlPrinter-import CFtoOCamlShow-import CFtoOCamlTest-import CFtoXML-import Utils-import Options--import Data.Char-import Data.Maybe (fromMaybe,maybe)-import System.Exit (exitFailure)-import Control.Monad(when)---- naming conventions--noLang :: Options -> String -> String-noLang _ name = name--withLang :: Options -> String -> String-withLang opts name = name ++ lang opts--mkMod :: (Options -> String -> String) -> String -> Options -> String-mkMod addLang name opts = - pref ++ if inDir opts then lang opts ++ "." ++ name else addLang opts name- where pref = maybe "" (++".") (inPackage opts)--mkFile :: (Options -> String -> String) -> String -> String -> Options -> FilePath-mkFile addLang name ext opts = - pref ++ if inDir opts- then lang opts ++ [pathSep] ++ name ++ ext'- else addLang opts name ++ if null ext then "" else ext'- where pref = maybe "" (\p->pkgToDir p++[pathSep]) (inPackage opts)- ext' = if null ext then "" else "." ++ ext--absFile, absFileM, ocamllexFile, ocamllexFileM, dviFile,- ocamlyaccFile, ocamlyaccFileM,- latexFile, utilFile, utilFileM,- templateFile, templateFileM, - printerFile, printerFileM,- psFile, tFile, tFileM :: Options -> String-absFile = mkFile withLang "Abs" "ml"-absFileM = mkMod withLang "Abs" -ocamllexFile = mkFile withLang "Lex" "mll"-ocamllexFileM = mkMod withLang "Lex"-ocamlyaccFile = mkFile withLang "Par" "mly"-ocamlyaccFileM = mkMod withLang "Par"-latexFile = mkFile withLang "Doc" "tex"-templateFile = mkFile withLang "Skel" "ml"-templateFileM = mkMod withLang "Skel"-printerFile = mkFile withLang "Print" "ml"-printerFileM = mkMod withLang "Print"-showFile = mkFile withLang "Show" "ml"-showFileM = mkMod withLang "Show"-dviFile = mkFile withLang "Doc" "dvi"-psFile = mkFile withLang "Doc" "ps"-tFile = mkFile withLang "Test" "ml"-tFileM = mkMod withLang "Test"-utilFile = mkFile noLang "BNFC_Util" "ml"-utilFileM = mkMod noLang "BNFC_Util"-xmlFileM = mkMod withLang "XML"--type Options = SharedOptions---- FIXME: we probably don't need all these arguments-makeOCaml :: Options -> CF -> IO ()-makeOCaml opts cf = do- let absMod = absFileM opts- lexMod = ocamllexFileM opts- parMod = ocamlyaccFileM opts- prMod = printerFileM opts- showMod = showFileM opts--- layMod = layoutFileM opts- utilMod = utilFileM opts- do- let dir = codeDir opts- when (not (null dir)) $ do- putStrLn $ "Creating directory " ++ dir- prepareDir dir- writeFileRep (absFile opts) $ cf2Abstract absMod cf- writeFileRep (ocamllexFile opts) $ cf2ocamllex lexMod parMod cf- writeFileRep (ocamlyaccFile opts) $ - cf2ocamlyacc parMod absMod lexMod cf- writeFileRep (latexFile opts) $ cfToLatex (lang opts) cf- writeFileRep (templateFile opts) $ cf2Template (templateFileM opts) absMod cf- writeFileRep (printerFile opts) $ cf2Printer prMod absMod cf- writeFileRep (showFile opts) $ cf2show showMod absMod cf- writeFileRep (tFile opts) $ ocamlTestfile absMod lexMod parMod prMod showMod cf- writeFileRep (utilFile opts) $ utilM - when (make opts) $ writeFileRep "Makefile" $ makefile opts- case xml opts of- 2 -> makeXML (lang opts) True cf- 1 -> makeXML (lang opts) False cf- _ -> return ()--pkgToDir :: String -> FilePath-pkgToDir s = replace '.' pathSep s--codeDir :: Options -> FilePath-codeDir opts = let pref = maybe "" pkgToDir (inPackage opts)- dir = if inDir opts then lang opts else ""- sep = if null pref || null dir then "" else [pathSep]- in pref ++ sep ++ dir --makefile :: Options -> String-makefile opts = makeA where- dir = let d = codeDir opts in if null d then "" else d ++ [pathSep]- cd c = if null dir then c else "(cd " ++ dir ++ "; " ++ c ++ ")"- makeA = unlines - [- "all:",- "\tocamlyacc " ++ ocamlyaccFile opts, - "\tocamllex " ++ ocamllexFile opts,- "\t" ++ cd ("latex " ++ basename (latexFile opts)- ++ "; " ++ "dvips " ++ basename (dviFile opts) - ++ " -o " ++ basename (psFile opts)),- "\tocamlc -o " ++ mkFile withLang "Test" "" opts +++- utilFile opts +++- absFile opts +++ templateFile opts +++- showFile opts +++ printerFile opts +++- mkFile withLang "Par" "mli" opts +++- mkFile withLang "Par" "ml" opts +++- mkFile withLang "Lex" "ml" opts +++- tFile opts, - "",- "clean:",- "\t-rm -f " ++ unwords (map (dir++) [- "*.log", "*.aux", "*.cmi", - "*.cmo", "*.o", "*.dvi"- ]),- "\t-rm -f " ++ psFile opts,- "",- "distclean: clean",- "\t-rm -f " ++ unwords [- mkFile withLang "Doc" "*" opts,- mkFile withLang "Lex" "*" opts,- mkFile withLang "Par" "*" opts,- mkFile withLang "Layout" "*" opts,- mkFile withLang "Skel" "*" opts,- mkFile withLang "Print" "*" opts,- mkFile withLang "Show" "*" opts,- mkFile withLang "Test" "*" opts,- mkFile withLang "Abs" "*" opts,- mkFile withLang "Test" "" opts,- utilFile opts,- "Makefile*"- ]- ]---utilM :: String-utilM = unlines - ["(* automatically generated by BNFC *)",- "",- "open Lexing",- "",- "(* this should really be in the parser, but ocamlyacc won't put it in the .mli *)",- "exception Parse_error of Lexing.position * Lexing.position"- ]-
− src/formats/ocaml/OCamlUtil.hs
@@ -1,72 +0,0 @@-{-- BNF Converter: OCaml backend utility module- Copyright (C) 2005 Author: Kristofer Johannisson-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module OCamlUtil where--import CF-import Utils-import Data.Char (toLower, toUpper)---- Translate Haskell types to OCaml types--- Note: OCaml (data-)types start with lowercase letter-fixType :: Cat -> String-fixType s = case s of- '[':xs -> case break (== ']') xs of - (t,"]") -> fixType t +++ "list"- _ -> s -- should not occur (this means an invariant of the type Cat is broken)- "Integer" -> "int"- "Double" -> "float"- c:cs -> let ls = toLower c : cs in- if (elem ls reservedOCaml) then (ls ++ "T") else ls- _ -> s- --- as fixType, but leave first character in upper case-fixTypeUpper :: Cat -> String-fixTypeUpper c = case fixType c of- [] -> []- c:cs -> toUpper c : cs- - -reservedOCaml :: [String]-reservedOCaml = [- "and","as","assert","asr","begin","class",- "constraint","do","done","downto","else","end", - "exception","external","false","for","fun","function", - "functor","if","in","include","inherit","initializer", - "land","lazy","let","lor","lsl","lsr", - "lxor","match","method","mod","module","mutable", - "new","object","of","open","or","private",- "rec","sig","struct","then","to","true", - "try","type","val","virtual","when","while","with"]- -mkTuple :: [String] -> String-mkTuple [] = ""-mkTuple [x] = x-mkTuple (x:xs) = "(" ++ foldl (\acc e -> acc ++ "," +++ e) x xs ++ ")"--insertBar :: [String] -> [String]-insertBar [] = []-insertBar [x] = [" " ++ x]-insertBar (x:xs) = (" " ++ x ) : map (" | " ++) xs--mutualDefs :: [String] -> [String]-mutualDefs defs = case defs of- [] -> []- [d] -> ["let rec" +++ d]- d:ds -> ("let rec" +++ d) : map ("and" +++) ds
− src/formats/profile/CFtoHappyProfile.hs
@@ -1,223 +0,0 @@-{-- BNF Converter: Happy Generator- Copyright (C) 2004 Author: Markus Forberg, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoHappyProfile- (- cf2HappyProfileS - )- where--import CF---import Lexer-import Data.List (intersperse)-import Data.Char---- Type declarations--type Rules = [(NonTerminal,[(Pattern,Action)])]-type NonTerminal = String-type Pattern = String-type Action = String-type MetaVar = String---- default naming--moduleName = "HappyParser"-tokenName = "Token"---- The main function, that given a CF and a CFCat to parse according to, --- generates a happy module. -cf2HappyProfileS :: String -> String -> String -> String -> CFP -> String-cf2HappyProfileS = cf2Happy--cf2Happy :: String -> String -> String -> String -> CFP -> String-cf2Happy name absName lexName errName cf - = unlines - [header name absName lexName errName,- declarations (allEntryPointsP cf),- tokens (symbols cf ++ reservedWords cf),- specialToks cf,- delimiter,- specialRules cf,- prRules (rulesForHappy cf),- finalize cf]---- construct the header.-header :: String -> String -> String -> String -> String-header modName absName lexName errName = unlines - ["-- This Happy file was machine-generated by the BNF converter",- "{",- "module " ++ modName ++ " where", ----- "import " ++ absName,- "import Trees",- "import " ++ lexName,- "import " ++ errName,- "}"- ]----- The declarations of a happy file.-declarations :: [NonTerminal] -> String-declarations ns = unlines - [generateP ns,- "%monad { Err } { thenM } { returnM }",- "%tokentype { " ++ tokenName ++ " }"]- where generateP [] = []- generateP (n:ns) = concat ["%name p",n'," ",n',"\n",generateP ns]- where n' = identCat n---- The useless delimiter symbol.-delimiter :: String-delimiter = "\n%%\n"---- Generate the list of tokens and their identifiers.-tokens :: [String] -> String-tokens toks = "%token \n" ++ prTokens toks- where prTokens [] = []- prTokens (t:tk) = " " ++ (convert t) ++ - " { " ++ oneTok t ++ " }\n" ++- prTokens tk- oneTok t = "PT _ (TS " ++ show t ++ ")"---- Happy doesn't allow characters such as åäö to occur in the happy file. This--- is however not a restriction, just a naming paradigm in the happy source file.-convert :: String -> String-convert "\\" = concat ['\'':"\\\\","\'"]-convert xs = concat ['\'':(escape xs),"\'"]- where escape [] = []- escape ('\'':xs) = '\\':'\'':escape xs- escape (x:xs) = x:escape xs--rulesForHappy :: CFP -> Rules-rulesForHappy cf = map mkOne $ ruleGroupsP cf where- mkOne (cat,rules) = constructRule cf rules cat---- For every non-terminal, we construct a set of rules. A rule is a sequence of--- terminals and non-terminals, and an action to be performed--- As an optimization, a pair of list rules [C] ::= "" | C k [C]--- is left-recursivized into [C] ::= "" | [C] C k.--- This could be generalized to cover other forms of list rules.-constructRule :: CFP -> [RuleP] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])-constructRule cf rules nt = (nt,[(p,generateAction nt (revF b r) m) | - r0 <- rules,- let (b,r) = if isConsFun (funRuleP r0) && elem (valCat r0) revs - then (True,revSepListRule r0) - else (False,r0),- let (p,m) = generatePatterns cf r])- where- ---- left rec optimization does not work yet- revF b r = ---- if b then ("flip " ++ funRuleP r) else (funRuleP r)- funRule r- revs = reversibleCats cf---- Generates a string containing the semantic action.--- An action can for example be: Sum $1 $2, that is, construct an AST--- with the constructor Sum applied to the two metavariables $1 and $2.-generateAction :: NonTerminal -> FunP -> [MetaVar] -> Action-generateAction nt f@(_,(h,p)) ms = unwords $ (if isCoercion h then args else (fun ++ mss)) - where- fun = ["mkFunTree",show h,show p]- mss = ["["] ++ intersperse "," ms ++ ["]"] - args = intersperse "," ms---- Generate patterns and a set of metavariables indicating --- where in the pattern the non-terminal--generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar])-generatePatterns cf r = case rhsRule r of- [] -> ("{- empty -}",[])- its -> (unwords (map mkIt its), metas its) - where- mkIt i = case i of- Left c -> identCat c- Right s -> convert s- metas its = [revIf c ('$': show i) | (i,Left c) <- zip [1 ::Int ..] its]- revIf c m = if (not (isConsFun (funRuleP r)) && elem c revs) - then ("(reverse " ++ m ++ ")") - else m -- no reversal in the left-recursive Cons rule itself- revs = reversibleCats cf---- We have now constructed the patterns and actions, --- so the only thing left is to merge them into one string.--prRules :: Rules -> String-prRules = unlines . map prOne- where- prOne (nt,[]) = [] -- nt has only internal use- prOne (nt,((p,a):ls)) =- unwords [nt', "::", "{", "CFTree", "}\n" ++ - nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ "\n"- where - nt' = identCat nt- pr [] = []- pr ((p,a):ls) = - unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls- --- Finally, some haskell code.--finalize :: CFP -> String-finalize cf = unlines- [- "{",- "\nreturnM :: a -> Err a",- "returnM = return",- "\nthenM :: Err a -> (a -> Err b) -> Err b",- "thenM = (>>=)",- "\nhappyError :: [" ++ tokenName ++ "] -> Err a",- "happyError ts =", - " Bad $ \"syntax error at \" ++ tokenPos ts ++ " ++- "if null ts then [] else " ++- "(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))",- "\nmyLexer = tokens",- "}"- ]- --- aarne's modifs 8/1/2002:--- Markus's modifs 11/02/2002---- GF literals-specialToks :: CFP -> String-specialToks cf = unlines $- (map aux (literals cf))- ++ ["L_err { _ }"]- where aux cat = - case cat of- "Ident" -> "L_ident { PT _ (TV $$) }"- "String" -> "L_quoted { PT _ (TL $$) }"- "Integer" -> "L_integ { PT _ (TI $$) }"- "Double" -> "L_doubl { PT _ (TD $$) }"- "Char" -> "L_charac { PT _ (TC $$) }"- own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }"- where- posn = if isPositionCat cf cat then "_" else "$$"--specialRules :: CFP -> String-specialRules cf = unlines $- map aux (literals cf)- where - aux cat = - case cat of- "Ident" -> "Ident : L_ident { mkAtTree (AV (Ident $1)) }" - "String" -> "String : L_quoted { mkAtTree (AS $1) }" - "Integer" -> "Integer : L_integ { mkAtTree (AI ((read $1) :: Integer)) }"- "Double" -> "Double : L_doubl { (read $1) :: Double }" ----- "Char" -> "Char : L_charac { (read $1) :: Char }" ----- own -> own ++ " : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}"- where- posn = if isPositionCat cf cat then "mkPosToken " else ""
− src/formats/profile/ProfileTop.hs
@@ -1,226 +0,0 @@-{-- BNF Converter: Haskell main file- Copyright (C) 2004 Author: Markus Forberg, Peter Gammie, Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module ProfileTop (makeAllProfile) where ---- import Utils-import CF-import CFtoHappyProfile-import CFtoAlex-import CFtoAlex2-import CFtoLatex-import MkErrM----- import CFtoAbstract----- import CFtoTemplate----- import CFtoPrinter----- import CFtoLayout----- import CFtoXML-import Utils--import Data.Char-import System.Exit(exitFailure)-import Control.Monad(when)---- naming conventions--nameMod :: String -> Bool -> String -> FilePath-nameMod name inDir lang =- if inDir - then lang ++ "." ++ name - else name ++ lang --nameFile :: String -> String -> Bool -> String -> FilePath-nameFile name ext inDir lang = - if inDir - then lang ++ "/" ++ name ++ "." ++ ext- else name ++ lang ++ "." ++ ext--absFile, absFileM, alexFile, alexFileM, dviFile,- gfAbs, gfConc,- happyFile, happyFileM,- latexFile, errFile, errFileM,- templateFile, templateFileM, - printerFile, printerFileM,- layoutFile, layoutFileM, - psFile, tFile, tFileM, mFile :: Bool -> String -> FilePath-absFile = nameFile "Abs" "hs"-absFileM = nameMod "Abs" -alexFile = nameFile "Lex" "x"-alexFileM = nameMod "Lex"-happyFile = nameFile "Par" "y"-happyFileM = nameMod "Par"-latexFile = nameFile "Doc" "tex"-templateFile = nameFile "Skel" "hs"-templateFileM = nameMod "Skel"-printerFile = nameFile "Print" "hs"-printerFileM = nameMod "Print"-dviFile = nameFile "Doc" "dvi"-psFile = nameFile "Doc" "ps"-gfAbs = nameFile "" "Abs.gf"-gfConc = nameFile "" "Conc.gf"-tFile = nameFile "Test" "hs"-tFileM = nameMod "Test"-mFile inDir n = if inDir then n ++ "/" ++ "Makefile" else "Makefile"-errFile b n = if b then n ++ "/" ++ "ErrM.hs" else "ErrM.hs"-errFileM b n = if b then n ++ "." ++ "ErrM" else "ErrM"-layoutFileM = nameMod "Layout"-xmlFileM = nameMod "XML"-layoutFile = nameFile "Layout" "hs"--makeAllProfile :: Bool -> Bool -> Bool -> Int -> String -> CFP -> IO ()-makeAllProfile make alex1 inDir xml name cfp = do- let absMod = absFileM inDir name- lexMod = alexFileM inDir name- parMod = happyFileM inDir name- prMod = printerFileM inDir name- layMod = layoutFileM inDir name- tplMod = templateFileM inDir name- errMod = errFileM inDir name- let cf = cfp2cf cfp- do- when inDir (prepareDir name)----- writeFileRep (absFile inDir name) $ cf2Abstract (absFileM inDir name) cf- if (alex1) then do- writeFileRep (alexFile inDir name) $ cf2alex lexMod errMod cf- putStrLn " (Use Alex 1.1 to compile.)" - else do- writeFileRep (alexFile inDir name) $ cf2alex2 lexMod errMod "" False False cf- putStrLn " (Use Alex 2.0 to compile.)"- writeFileRep (happyFile inDir name) $ - cf2HappyProfileS parMod absMod lexMod errMod cfp- putStrLn " (Tested with Happy 1.13)"- writeFileRep (latexFile inDir name) $ cfToLatex name cf----- writeFileRep (templateFile inDir name) $ ----- cf2Template tplMod absMod errMod cf----- writeFileRep (printerFile inDir name) $ cf2Printer prMod absMod cf----- if hasLayout cf then ----- writeFileRep (layoutFile inDir name) $ cf2Layout alex1 inDir layMod lexMod cf----- else return ()- writeFileRep (tFile inDir name) $ testfile inDir name (xml>0) cf- writeFileRep (errFile inDir name) $ errM errMod cf- if make - then (writeFileRep (mFile inDir name) $ makefile inDir name) - else return () ----- case xml of----- 2 -> makeXML name True cf----- 1 -> makeXML name False cf----- _ -> return ()--makefile :: Bool -> String -> String-makefile inDir name = makeA where- name' = if inDir then "" else name -- Makefile is inDir- ghcCommand = "ghc --make "++ tFile inDir name ++ " -o " ++ - if inDir then name ++ "/" ++ "Test" else "Test" ++ name- makeA = unlines - [- "all:", - "\thappy -gca " ++ happyFile False name', - "\talex " ++ alexFile False name',- "\tlatex " ++ latexFile False name',- "\tdvips " ++ dviFile False name' ++ " -o " ++ psFile False name',- "\t" ++ if inDir then - "(" ++ "cd ..; " ++ ghcCommand ++ ")"- else ghcCommand,- "clean:",- "\t rm -f " ++ unwords [- "*.log *.aux *.hi *.o *.dvi",- psFile False name',- "*.o"- ],- "distclean: " ++ if inDir then "" else "clean",- if inDir then- "\t rm -rf ../" ++ name -- erase this directory!- else- "\t rm -f " ++ unwords [- "Doc" ++ name ++ ".*",- "Lex" ++ name ++ ".*",- "Par" ++ name ++ ".*",----- "Layout" ++ name ++ ".*",----- "Skel" ++ name ++ ".*",----- "Print" ++ name ++ ".*",- "Test" ++ name ++ ".*",----- "Abs" ++ name ++ ".*", - "Test" ++ name,- "ErrM.*",----- name ++ ".dtd",----- "XML" ++ name ++ ".*", - "Makefile*"- ]- ]---testfile :: Bool -> String -> Bool -> CF -> String-testfile inDir name xml cf = makeA where-- makeA = let lay = hasLayout cf - xpr = if xml then "XPrint a, " else ""- in unlines- ["-- automatically generated by BNF Converter",- "module Main where\n",- "",- "import Trees",- "import Profile",- "import System.IO ( stdin, hGetContents )",- "import System.Environment ( getArgs, getProgName )",- "",- "import " ++ alexFileM inDir name,- "import " ++ happyFileM inDir name,----- "import " ++ templateFileM inDir name,----- "import " ++ printerFileM inDir name,----- "import " ++ absFileM inDir name,----- if lay then ("import " ++ layoutFileM inDir name) else "",----- if xml then ("import " ++ xmlFileM inDir name) else "",- "import " ++ errFileM inDir name,- "",- "type ParseFun = [Token] -> Err CFTree",- "",- "myLLexer = " ++ if lay then "resolveLayout True . myLexer" - else "myLexer",- "",- "runFile :: ParseFun -> FilePath -> IO ()",- "runFile p f = readFile f >>= run p",- "",- "run :: ParseFun -> String -> IO ()",- "run p s = do",- " let ts = myLLexer s",- " let etree = p ts",- " case etree of",- " Ok tree -> do",- " case postParse tree of",- " Bad s -> do", - " putStrLn \"\\nParse Failed... CFTree:\\n\"",- " putStrLn $ prCFTree tree",- " putStrLn s",- " Ok tree -> do", - " putStrLn \"\\nParse Successful!\"",- " putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree",- " Bad s -> do",- " putStrLn s",- " putStrLn \"\\nParse failed... tokenization:\"",- " print ts",- "",- "main :: IO ()",- "main = do args <- getArgs",- " case args of",- " [] -> hGetContents stdin >>= run " ++ firstParser,- " [f] -> runFile " ++ firstParser ++ " f",- " _ -> do progName <- getProgName",- " putStrLn $ progName ++ \": excess arguments.\""- ]- where firstParser = 'p' : firstEntry cf
− src/formats/xml/CFtoXML.hs
@@ -1,216 +0,0 @@-{-- BNF Converter: XML generator- Copyright (C) 2004 Author: Aarne Ranta-- This program is free software; you can redistribute it and/or modify- it under the terms of the GNU General Public License as published by- the Free Software Foundation; either version 2 of the License, or- (at your option) any later version.-- This program is distributed in the hope that it will be useful,- but WITHOUT ANY WARRANTY; without even the implied warranty of- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the- GNU General Public License for more details.-- You should have received a copy of the GNU General Public License- along with this program; if not, write to the Free Software- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA--}--module CFtoXML ---- (cf2DTD, cf2XML) - where--import CF-import Utils-import CFtoTemplate-import Data.List (intersperse, nub)-import Data.Char(toLower)--type Coding = Bool ---- change to at least three values--makeXML :: FilePath -> Coding -> CF -> IO ()-makeXML name typ cf = do- writeFileRep (name ++ ".dtd") $ cf2DTD typ name cf- let absmod = "XML" ++ name- writeFileRep (absmod ++ ".hs") $ cf2XMLPrinter typ name absmod cf---- derive a DTD from a BNF grammar. AR 21/8/2004-cf2DTD :: Coding -> String -> CF -> String-cf2DTD typ name cf = unlines [- tag ("?xml version=\"1.0\" standalone=\"yes\"?"),- "<!DOCTYPE " ++ name ++ " [",- elemEmp "Integer",- elemEmp "Double",- elemEmp "String",- if hasIdent cf then elemEmp "Ident" else "",- unlines [elemEmp own | (own,_) <- tokenPragmas cf],- unlines (map (elemData typ cf) (cf2data cf)),- "]>"- ]--tag s = "<" ++ s ++ ">"-element t ts = - tag ("!ELEMENT " ++ t ++ " " ++ alts ts)-attlist t a = - tag ("!ATTLIST " ++ t ++ " " ++ a ++ " CDATA #REQUIRED")-elemAtt t a ts = element t ts ++++ attlist t a-elemt t = elemAtt t "name"-elemc cat fs = unlines $ element cat (map snd fs) : [element f [] | (f,_) <- fs] -elemEmp t = elemAtt t "value" []-alts ts = - if null ts then "EMPTY" else parenth (unwords (intersperse "|" ts))----- choose between these two encodings:--elemData b = if b then elemDataConstr else elemDataNotyp -efunDef b = if b then efunDefConstr else efunDefNotyp -endtagDef b = if b then endtagDefConstr else endtagDefNotyp---- coding 0: ---- not finished--- to show both types and constructors as tags;--- lengthy, but validation guarantees type correctness--- flag -xmlt-elemDataConstrs cf (cat,fcs) = elemc cat ([(f,rhsCat cf (f:cs)) | (f,cs) <- fcs])-efunDefConstrs = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"-endtagDefConstrs = "endtag f c = tag (\"/\" ++ c)"---- coding 1:--- to show constructors as empty tags;--- shorter than 0, but validation still guarantees type correctness--- flag -xmlt-elemDataConstr cf (cat,fcs) = elemc cat ([(f,rhsCat cf (f:cs)) | (f,cs) <- fcs])-efunDefConstr = "elemFun i t x = [replicate (i+i) ' ' ++ tag t ++ \" \" ++ etag x]"-endtagDefConstr = "endtag f c = tag (\"/\" ++ c)"---- coding 2:--- constructors as tags, no types.--- clumsy DTD, but nice trees. Validation guarantees type correctness--- flag -xml-elemDataNotyp cf (cat,fcs) = unlines [element f [rhsCatNot cf cs] | (f,cs) <- fcs]-efunDefNotyp = "elemFun i t x = [replicate (i+i) ' ' ++ tag x]"-endtagDefNotyp = "endtag f c = tag (\"/\" ++ f)"----- to show constructors as attributes; --- nice, but validation does not guarantee type correctness. --- Therefore rejected.--- elemDataAttr cf (cat,fcs) = elemt cat (nub [rhsCat cf cs | (_,cs) <- fcs])--- efunDefAttr = "elemFun i t x = [replicate (i+i) ' ' ++ tag (t ++ \" name = \" ++ x)]"---rhsCat cf cs = parenth (concat (intersperse ", " (map (symbCat cf) cs)))-rhsCatNot cf cs = if null cs then "EMPTY" else concat (intersperse ", " (map (symbCatNot cf) cs))--symbCat cf c- | isList c = normCatOfList c ++ if isEmptyListCat cf c then "*" else "+"- | otherwise = c--symbCatNot cf c- | isList c = funs (normCatOfList c) ++ if isEmptyListCat cf c then "*" else "+"- | otherwise = funs c- where- funs k = case lookup k (cf2data cf) of- Just [] -> "EMPTY"- Just fcs -> parenth $ unwords $ intersperse "|" $ map fst fcs- _ -> parenth k ------parenth s = "(" ++ s ++ ")"---- derive an XML printer from a BNF grammar-cf2XMLPrinter :: Bool -> String -> String -> CF -> String-cf2XMLPrinter typ name absMod cf = unlines [- prologue typ name absMod,- integerRule cf,- doubleRule cf,- stringRule cf,- if hasIdent cf then identRule cf else "",- unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],- rules cf- ]---prologue :: Bool -> String -> String -> String-prologue b name absMod = unlines [- "module " ++ absMod +++ "where\n",- "-- pretty-printer generated by the BNF converter\n",- "import Abs" ++ name,- "import Data.Char",- "",- "-- the top-level printing method",- "printXML :: XPrint a => a -> String",- "printXML = render . prt 0",- "",- "render = unlines",- "",- "-- the printer class does the job",- "class XPrint a where",- " prt :: Int -> a -> [String]",- " prtList :: Int -> [a] -> [String]",- " prtList i = concat . map (prt i)",- "",- "instance XPrint a => XPrint [a] where",- " prt = prtList",- "",- "tag t = \"<\" ++ t ++ \">\"",- "etag t = \"<\" ++ t ++ \"/>\"",- "elemTok i t x = [replicate (i+i) ' ' ++ tag (t ++ \" value = \" ++ show x ++ \" /\")]",- "elemTokS i t x = elemTok i t (show x)",- efunDef b,- endtagDef b,- ""- ]--integerRule cf = showsPrintRule cf "Integer"-doubleRule cf = showsPrintRule cf "Double"-stringRule cf = showsPrintRule cf "Char" ++++ " prtList i xs = elemTok i \"String\" xs"--showsPrintRule cf t = unlines $ [- "instance XPrint " ++ t ++ " where",- " prt i x = elemTokS i" +++ "\"" ++ t ++ "\"" +++ "x"- ]--identRule cf = ownPrintRule cf "Ident"--ownPrintRule cf t = unlines $ [- "instance XPrint " ++ t ++ " where",- " prt i (" ++ t ++ posn ++ ") = elemTok i" +++ "\"" ++ t ++ "\"" +++ "x"- ]- where- posn = if isPositionCat cf t then " (_,x)" else " x"--rules :: CF -> String-rules cf = unlines $ - map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf- where - toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)- names [] _ = []- names (x:xs) n- | elem x xs = (x ++ show n) : names xs (n+1)- | otherwise = x : names xs n- var ('[':xs) = var (init xs) ++ "s"- var "Ident" = "id"- var "Integer" = "n"- var "String" = "str"- var "Char" = "c"- var "Double" = "d"- var xs = map toLower xs- checkRes s- | elem s reservedHaskell = s ++ "'"- | otherwise = s- reservedHaskell = ["case","class","data","default","deriving","do","else","if",- "import","in","infix","infixl","infixr","instance","let","module",- "newtype","of","then","type","where","as","qualified","hiding"]- ruleOf s = maybe undefined id $ lookupRule s (rulesOfCF cf)----- case_fun :: Cat -> [(Constructor,Rule)] -> String-case_fun cat xs = unlines [- "instance XPrint" +++ cat +++ "where",- " prt i" +++ "e = case e of",- unlines $ map (\ ((c,xx),r) -> - " " ++ c +++ unwords xx +++ "-> concat $ " +++ - "elemFun i \"" ++ cat ++ "\" \"" ++ c ++ "\"" +++- unwords [": prt (i+1)" +++ x | x <- xx] +++ ":" +++- "[[replicate (i+i) ' ' ++ endtag \"" ++ c ++ "\" \"" ++ cat ++ "\"]]" - ) xs- ]
+ test/BNFC/Backend/Common/MakefileSpec.hs view
@@ -0,0 +1,24 @@+module BNFC.Backend.Common.MakefileSpec where++import Test.Hspec++import BNFC.Backend.Base (execBackend)+import BNFC.Options (defaultOptions,make)+import BNFC.Backend.Common.Makefile -- SUT++spec :: Spec+spec = do+ describe "mkRule" $ do++ it "prduce makefile rules correctly" $+ mkRule "main" ["file1","file2"] ["do something"] ""+ `shouldBe` "main: file1 file2\n\tdo something\n\n"++ it "produce mafefile rules without receipes" $+ mkRule "main" ["program.exe"] [] ""+ `shouldBe` "main: program.exe\n\n"++ describe "mkMakefile" $ do+ it "uses the names in the options dictionary" $+ let opts = defaultOptions { make = Just "MyMakefile" } in+ execBackend (mkMakefile opts "") `shouldReturn` [("MyMakefile","")]
+ test/BNFC/OptionsSpec.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}+module BNFC.OptionsSpec where++import Control.Monad (liftM, liftM2)+import Data.List (intercalate)+import Data.Maybe (fromJust)+import System.Console.GetOpt+import System.FilePath ((<.>), takeBaseName)+import Test.Hspec+import Test.QuickCheck++import BNFC.Options -- SUT+import BNFC.WarningM+++-- Expectation that a particular option has a particular value+shouldSet :: (Eq a, Show a) => Mode -> (SharedOptions -> a, a) -> Expectation+shouldSet (Target opts _) (option, value) = option opts `shouldBe` value++spec :: Spec+spec = do++ describe "parseMode" $ do++ it "returns Help on an empty list of arguments" $+ parseMode [] `shouldBe` Help++ it "returns Help if given --help" $+ parseMode ["--help"] `shouldBe` Help++ it "returns Version if given --version" $+ parseMode ["--version"] `shouldBe` Version++ it "returns an error if help is given an argument" $+ isUsageError (parseMode ["--help=2"]) `shouldBe` True++ it "If no language is specified, it should default to haskell" $+ parseMode["file.cf"] `shouldSet` (target, TargetHaskell)++ it "returns an error if the grammar file is missing" $+ parseMode["--haskell"] `shouldBe` UsageError "Missing grammar file"++ it "returns an error if multiple grammar files are given" $+ parseMode["--haskell", "file1.cf", "file2.cf"]+ `shouldBe` UsageError "Too many arguments"++ it "sets the language name to the basename of the grammar file" $+ parseMode["foo.cf"] `shouldSet` (lang, "foo")++ it "accept 'old style' options" $ do+ parseMode["-haskell", "-m", "-glr", "file.cf"]+ `shouldSet` (target, TargetHaskell)+ parseMode["-haskell", "-m", "-glr", "file.cf"]+ `shouldSet` (make, Just "Makefile")+ parseMode["-haskell", "-m", "-glr", "file.cf"]+ `shouldSet` (glr, GLR)++ it "accept latex as a target language" $+ parseMode["--latex", "file.cf"] `shouldSet` (target, TargetLatex)++ describe "Old option translation" $ do+ it "translate -haskell to --haskell" $+ translateOldOptions ["-haskell"] `shouldBe` ["--haskell"]++ describe "--makefile" $ do++ it "is off by default" $+ parseMode["--c", "foo.cf"] `shouldSet` (make, Nothing)++ it "uses the file name 'Makefile' by default" $+ parseMode["--c", "-m", "foo.cf"] `shouldSet` (make, Just "Makefile")++ context "when using the option with an argument" $+ it "uses the argument as Makefile name" $+ parseMode["--c", "-mMyMakefile", "foo.cf"]+ `shouldSet` (make, Just "MyMakefile")++-- ~~~ Arbitrary instances ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++randomOption :: Gen String+randomOption = oneof [ nonOption, noArg, withArg ]+ where nonOption = stringOf1 ['a'..'z'] -- non-option argument+ noArg = liftM ("--"++) nonOption -- flag+ withArg = do+ arg <- nonOption+ flag <- noArg+ return $ flag ++ "=" ++ arg++-- Helper function that generates a string of random length using the given+-- set of characters. Not that the type signature explicitely uses+-- [Char] and not String for documentation purposes+stringOf :: [Char] -> Gen String+stringOf = listOf . elements++-- | Same as stringOf but only generates non empty strings+stringOf1 :: [Char] -> Gen String+stringOf1 = listOf1 . elements+++instance Arbitrary Target where arbitrary = elements [minBound .. ]++-- creates a filepath with the given extension+arbitraryFilePath :: String -> Gen FilePath+arbitraryFilePath ext = do+ path <- listOf1 $ stringOf1 ['a'..'z']+ return $ intercalate "/" path <.> ext++-- Generates unix command line options. Can be in long form (ex: --option)+-- or short form (ex: -o)+-- Note: we only use letters x,y,z to make (almost) sure that we are not+-- going to generate accidentally an global/target language option+arbitraryOption :: Gen String+arbitraryOption = oneof [arbitraryShortOption, arbitraryLongOption]+ where arbitraryShortOption = liftM (('-':) . (:[])) (elements ['x'..'z'])+ arbitraryLongOption = liftM ("--" ++) (stringOf1 ['x'..'z'])++-- Arbitrary instance for Mode+instance Arbitrary Mode where+ arbitrary = oneof+ [ return Help+ , return Version+ , liftM UsageError arbitrary -- generates a random error message+ , do target' <- arbitrary -- random target+ cfFile <- arbitraryFilePath "cf"+ let args = defaultOptions { lang = takeBaseName cfFile, target = target'}+ return $ Target args cfFile+ ]
+ test/BNFC/WarningMSpec.hs view
@@ -0,0 +1,28 @@+module BNFC.WarningMSpec where++import Test.Hspec++import BNFC.WarningM -- SUT++spec :: Spec+spec = do++ describe "run" $ do++ it "returns the result of the computation and all raised warnings" $+ run computationWithWarnings `shouldBe` (3,["Coucou", "Hi"])++ describe "putWarnings" $ do++ it "returns the result of the computation" $ do+ putWarnings computationWithWarnings `shouldReturn` 3++ describe "hasWarnings" $ do++ it "returns true if the computation has warnings" $+ hasWarnings computationWithWarnings `shouldBe` True++ it "returns Fasle if the computation doesn't have any warnings" $+ hasWarnings (return ()) `shouldBe` False++ where computationWithWarnings = warn "Coucou" >> warn "Hi" >> return 3
+ test/unit-tests.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}