diff --git a/BNFC.cabal b/BNFC.cabal --- a/BNFC.cabal +++ b/BNFC.cabal @@ -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 diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -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 " +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? + +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 + + +-------------- diff --git a/dist/build/bnfc/bnfc-tmp/LexBNF.hs b/dist/build/bnfc/bnfc-tmp/LexBNF.hs --- a/dist/build/bnfc/bnfc-tmp/LexBNF.hs +++ b/dist/build/bnfc/bnfc-tmp/LexBNF.hs @@ -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 "" #-} + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + +# 6 "" 2 {-# LINE 1 "templates/GenericTemplate.hs" #-} -- ----------------------------------------------------------------------------- -- ALEX TEMPLATE diff --git a/dist/build/bnfc/bnfc-tmp/ParBNF.hs b/dist/build/bnfc/bnfc-tmp/ParBNF.hs --- a/dist/build/bnfc/bnfc-tmp/ParBNF.hs +++ b/dist/build/bnfc/bnfc-tmp/ParBNF.hs @@ -1450,6 +1450,34 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + +# 8 "" 2 {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp diff --git a/dist/build/unit-tests/unit-tests-tmp/LexBNF.hs b/dist/build/unit-tests/unit-tests-tmp/LexBNF.hs new file mode 100644 --- /dev/null +++ b/dist/build/unit-tests/unit-tests-tmp/LexBNF.hs @@ -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 "" #-} + + + + + + +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + +# 6 "" 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 diff --git a/dist/build/unit-tests/unit-tests-tmp/ParBNF.hs b/dist/build/unit-tests/unit-tests-tmp/ParBNF.hs new file mode 100644 --- /dev/null +++ b/dist/build/unit-tests/unit-tests-tmp/ParBNF.hs @@ -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 "" #-} +{-# LINE 8 "" #-} +# 1 "/usr/include/stdc-predef.h" 1 3 4 + +# 17 "/usr/include/stdc-predef.h" 3 4 + + + + + + + + + + + + + + + + + + + + + + + +# 8 "" 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. diff --git a/runtime/Algebra/RingUtils.hs b/runtime/Algebra/RingUtils.hs --- a/runtime/Algebra/RingUtils.hs +++ b/runtime/Algebra/RingUtils.hs @@ -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) diff --git a/runtime/Data/Matrix/Class.hs b/runtime/Data/Matrix/Class.hs --- a/runtime/Data/Matrix/Class.hs +++ b/runtime/Data/Matrix/Class.hs @@ -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 - - - - - + + + + + diff --git a/runtime/Data/Matrix/Quad.hs b/runtime/Data/Matrix/Quad.hs --- a/runtime/Data/Matrix/Quad.hs +++ b/runtime/Data/Matrix/Quad.hs @@ -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'] + diff --git a/runtime/Parsing/Chart.hs b/runtime/Parsing/Chart.hs --- a/runtime/Parsing/Chart.hs +++ b/runtime/Parsing/Chart.hs @@ -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 diff --git a/runtime/Parsing/TestProgram.hs b/runtime/Parsing/TestProgram.hs --- a/runtime/Parsing/TestProgram.hs +++ b/runtime/Parsing/TestProgram.hs @@ -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 diff --git a/src/BNFC/Backend/Base.hs b/src/BNFC/Backend/Base.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Base.hs @@ -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 diff --git a/src/BNFC/Backend/C.hs b/src/BNFC/Backend/C.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/C.hs @@ -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 ", + "#include ", + "", + "#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 _ = "" + diff --git a/src/BNFC/Backend/C/CFtoBisonC.hs b/src/BNFC/Backend/C/CFtoBisonC.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/C/CFtoBisonC.hs @@ -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 ", + "#include ", + "#include ", + "#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 " ++ r ++ " /* " ++ s ++ " */\n" + else "%token " ++ r ++ " /* " ++ s ++ " */\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC catString "%token _STRING_\n", + ifC catChar "%token _CHAR_\n", + ifC catInteger "%token _INTEGER_\n", + ifC catDouble "%token _DOUBLE_\n", + ifC catIdent "%token _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 diff --git a/src/BNFC/Backend/C/CFtoCAbs.hs b/src/BNFC/Backend/C/CFtoCAbs.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/C/CFtoCAbs.hs @@ -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 ", + "#include ", + "#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) ++ "_" diff --git a/src/BNFC/Backend/C/CFtoCPrinter.hs b/src/BNFC/Backend/C/CFtoCPrinter.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/C/CFtoCPrinter.hs @@ -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 ", + "#include ", + "#include ", + "", + "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_--;", + " }", + "}" + ] diff --git a/src/BNFC/Backend/C/CFtoCSkel.hs b/src/BNFC/Backend/C/CFtoCSkel.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/C/CFtoCSkel.hs @@ -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 diff --git a/src/BNFC/Backend/C/CFtoFlexC.hs b/src/BNFC/Backend/C/CFtoFlexC.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/C/CFtoFlexC.hs @@ -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 ", + "#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) = + "\"" ++ 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 "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n", + ifC catInteger "{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n", + ifC catIdent "{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n" + , "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", + ". \t return _ERROR_;\n", + "%%\n", + footer + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ 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. + [ + "\"\\\"\" \t BEGIN STRING;", + "\\\\ \t BEGIN ESCAPED;", + "\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;", + ". \t YY_BUFFER_APPEND(yytext);", + "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", + "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", + "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", + "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", + ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" \tBEGIN CHAR;", + "\\\\ \t BEGIN CHARESC;", + "[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", + "n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;", + "t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;", + ". \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", + "\"'\" \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 = + "\"" ++ 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 [ + "\"" ++ b ++ "\" \t BEGIN COMMENT;", + "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", + ". \t /* BNFC multi-line comment */;", + "[\\n] \t /* BNFC multi-line comment */;" + ] + +lexReserved :: String -> String +lexReserved s = "\"" ++ 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) diff --git a/src/BNFC/Backend/CPP/NoSTL.hs b/src/BNFC/Backend/CPP/NoSTL.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL.hs @@ -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 ", + "#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 _ = "" diff --git a/src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs b/src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs @@ -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 ", + "#include ", + "#include ", + "#include ", + "#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 " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC catString "%token _STRING_\n", + ifC catChar "%token _CHAR_\n", + ifC catInteger "%token _INTEGER_\n", + ifC catDouble "%token _DOUBLE_\n", + ifC catIdent "%token _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 diff --git a/src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs b/src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs @@ -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 ", + "#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 diff --git a/src/BNFC/Backend/CPP/NoSTL/CFtoCPPPrinter.hs b/src/BNFC/Backend/CPP/NoSTL/CFtoCPPPrinter.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL/CFtoCPPPrinter.hs @@ -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 ", + "#include ", + "#include ", + "", + "/* 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_--;", + " }", + "}" + ] diff --git a/src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs b/src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs @@ -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 diff --git a/src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs b/src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs @@ -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 ", + "#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) = + "\"" ++ 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 ("{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"), + ifC catInteger ("{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"), + ifC catIdent ("{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"), + "\\n ++" ++ ns ++ "yy_mylinenumber ;\n", + "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", + ". \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n", + "%%\n", + footer + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + ns = nsString inPackage + userDefTokens = unlines $ + ["" ++ 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. + [ + "\"\\\"\" \t BEGIN STRING;", + "\\\\ \t BEGIN ESCAPED;", + "\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";", + ". \t YY_BUFFER_APPEND(yytext);", + "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", + "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", + "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", + "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", + ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" \tBEGIN CHAR;", + "\\\\ \t BEGIN CHARESC;", + "[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + ". \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", + "\"'\" \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 = + "\"" ++ 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 [ + "\"" ++ b ++ "\" \t BEGIN COMMENT;", + "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", + ". \t /* BNFC multi-line 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) diff --git a/src/BNFC/Backend/CPP/NoSTL/RegToFlex.hs b/src/BNFC/Backend/CPP/NoSTL/RegToFlex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/NoSTL/RegToFlex.hs @@ -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 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] diff --git a/src/BNFC/Backend/CPP/STL.hs b/src/BNFC/Backend/CPP/STL.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/STL.hs @@ -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 ", + "#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", + "#include", + "", + 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 _ = "" diff --git a/src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs b/src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs @@ -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 ", + "#include ", + "#include ", + "#include ", + "#include ", + "#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 " ++ r ++ " // " ++ s ++ "\n" + else "%token " ++ r ++ " // " ++ s ++ "\n" + +specialToks :: CF -> String +specialToks cf = concat [ + ifC catString "%token _STRING_\n", + ifC catChar "%token _CHAR_\n", + ifC catInteger "%token _INTEGER_\n", + ifC catDouble "%token _DOUBLE_\n", + ifC catIdent "%token _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 + + diff --git a/src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs b/src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs @@ -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 ++ ");") + diff --git a/src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs b/src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/STL/CFtoSTLAbs.hs @@ -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", + "#include", + "", + "//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 ", + "#include ", + "#include ", + "#include ", + "#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], + "}" + ] diff --git a/src/BNFC/Backend/CPP/STL/CFtoSTLPrinter.hs b/src/BNFC/Backend/CPP/STL/CFtoSTLPrinter.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/STL/CFtoSTLPrinter.hs @@ -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 ", + "#include ", + "#include ", + "", + 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 ", + "#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_--;", + " }", + "}" + ] diff --git a/src/BNFC/Backend/CPP/STL/STLUtils.hs b/src/BNFC/Backend/CPP/STL/STLUtils.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CPP/STL/STLUtils.hs @@ -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 diff --git a/src/BNFC/Backend/CSharp.hs b/src/BNFC/Backend/CSharp.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp.hs @@ -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 [ + "", + "", + " ", + " Debug", + " AnyCPU", + " 8.0.50727", + " 2.0", + " " ++ guid ++ "", + " Library", + " Properties", + " " ++ namespace ++ "", + " " ++ namespace ++ "", + " ", + " ", + " ", + " ", + " true", + " full", + " false", + " bin\\Debug\\", + " DEBUG;TRACE", + " prompt", + " 4", + " ", + " ", + " pdbonly", + " true", + " bin\\Release\\", + " TRACE", + " prompt", + " 4", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " False", + " bin\\ShiftReduceParser.dll", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + " ", + "" + ] + +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" diff --git a/src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs b/src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs @@ -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(" ++ identifier namespace cat ++ ".Visitor v, A arg);", + prVisitor namespace funs, + " }" + ] + +prVisitor :: Namespace -> [String] -> String +prVisitor namespace funs = unlinesInline [ + " ", + " public interface Visitor", + " {", + 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(" ++ identifier namespace cat ++ ".Visitor 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] diff --git a/src/BNFC/Backend/CSharp/CAbstoCSharpAbstractVisitSkeleton.hs b/src/BNFC/Backend/CSharp/CAbstoCSharpAbstractVisitSkeleton.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CAbstoCSharpAbstractVisitSkeleton.hs @@ -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 : " ++ identifier namespace c ++ ".Visitor", + " {", + " 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 : " ++ identifier namespace c ++ ".Visitor", + " {", + 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);" + ] diff --git a/src/BNFC/Backend/CSharp/CAbstoCSharpVisitSkeleton.hs b/src/BNFC/Backend/CSharp/CAbstoCSharpVisitSkeleton.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CAbstoCSharpVisitSkeleton.hs @@ -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 : Abstract" ++ c ++ "Visitor", + " {", + " 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 : Abstract" ++ c ++ "Visitor", + " {", + 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(), 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(), arg);" + else " // x", + " }" + ] diff --git a/src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs b/src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs @@ -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 ++ "_" diff --git a/src/BNFC/Backend/CSharp/CFtoGPLEX.hs b/src/BNFC/Backend/CSharp/CFtoGPLEX.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CFtoGPLEX.hs @@ -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, + "", + "%{", + " /// ", + " /// Buffer for escaped characters in strings.", + " /// ", + " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();", + "", + " /// ", + " /// Change to enable output - useful for debugging purposes", + " /// ", + " public bool Trace = false;", + "", + " /// ", + " /// Culture-independent IFormatProvider for numbers. ", + " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.", + " /// ", + " /// ", + " /// 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.", + " /// ", + " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", + "", + " /// ", + " /// 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.", + " /// ", + " public static Scanner CreateScanner(Stream stream)", + " {", + " Scanner scanner = new Scanner(stream);", + " scanner.Begin();", + " return scanner;", + " }", + "", + " /// ", + " /// Sets the scanner to the correct initial state (YYINITIAL). ", + " /// You should call this method prior to calling parser.Parse().", + " /// ", + " public void Begin()", + " {", + " BEGIN(YYINITIAL);", + " }", + "", + " /// ", + " /// Convenience method to \"reset\" the buffer for escaped characters in strings.", + " /// ", + " 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) = + ("\"" ++ 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 [("{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")], + ifC catInteger [("{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")], + ifC catIdent [("{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")], + [("[ \\t\\r\\n\\f]" , "/* ignore white space. */;")], + [("." , "return (int)Tokens.error;")] + ] + where + ifC cat s = if isUsedCat cf cat then s else [] + userDefTokens = map tokenline (tokenPragmas cf) + where + tokenline (name, exp) = ("" ++ 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 = [ + ("\"\\\"\"" , "BEGIN(STRING);"), + ("\\\\" , "BEGIN(ESCAPED);"), + ("\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"), + ("." , "this.strBuffer.Append(yytext);"), + ("n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"), + ("\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"), + ("\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"), + ("t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"), + ("." , "this.strBuffer.Append(yytext); BEGIN(STRING);") + ] + -- These handle escaped characters in Chars. + charStates = [ + ("\"'\"" , "BEGIN(CHAR);"), + ("\\\\" , "BEGIN(CHARESC);"), + ("[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), + ("n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"), + ("t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"), + ("." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), + ("\"'\"" , "BEGIN(YYINITIAL);") + ] + +lexComments :: ([(String, String)], [String]) -> [(String, String)] +lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m) + +lexSingleComment :: String -> (String, String) +lexSingleComment c = + ("\"" ++ 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) = [ + ("\"" ++ b ++ "\"" , "BEGIN(COMMENT);"), + ("\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"), + ("." , "/* BNFC multi-line 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 diff --git a/src/BNFC/Backend/CSharp/CFtoGPPG.hs b/src/BNFC/Backend/CSharp/CFtoGPPG.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CFtoGPPG.hs @@ -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_", + ifC catChar "%token CHAR_", + ifC catInteger "%token INTEGER_", + ifC catDouble "%token DOUBLE_", + ifC catIdent "%token 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 diff --git a/src/BNFC/Backend/CSharp/CSharpUtils.hs b/src/BNFC/Backend/CSharp/CSharpUtils.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/CSharpUtils.hs @@ -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)) + diff --git a/src/BNFC/Backend/CSharp/RegToGPLEX.hs b/src/BNFC/Backend/CSharp/RegToGPLEX.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/CSharp/RegToGPLEX.hs @@ -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 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] diff --git a/src/BNFC/Backend/Common/Makefile.hs b/src/BNFC/Backend/Common/Makefile.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Common/Makefile.hs @@ -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 diff --git a/src/BNFC/Backend/Common/NamedVariables.hs b/src/BNFC/Backend/Common/NamedVariables.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Common/NamedVariables.hs @@ -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) diff --git a/src/BNFC/Backend/Common/OOAbstract.hs b/src/BNFC/Backend/Common/OOAbstract.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Common/OOAbstract.hs @@ -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 diff --git a/src/BNFC/Backend/Common/StrUtils.hs b/src/BNFC/Backend/Common/StrUtils.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Common/StrUtils.hs @@ -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) + + diff --git a/src/BNFC/Backend/Haskell.hs b/src/BNFC/Backend/Haskell.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell.hs @@ -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)" + ] + diff --git a/src/BNFC/Backend/Haskell/CFtoAbstract.hs b/src/BNFC/Backend/Haskell/CFtoAbstract.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoAbstract.hs @@ -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" diff --git a/src/BNFC/Backend/Haskell/CFtoAlex.hs b/src/BNFC/Backend/Haskell/CFtoAlex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoAlex.hs @@ -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 " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++ + "%{ string p = PT p . TL . unescapeInitTail %}", + ifC catChar " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}", + ifC catInteger " ::= ^d+ %{ int p = PT p . TI %}", + ifC catDouble + " ::= ^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 = + " ::= " ++ 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 $ + [" ::= " ++ 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 + " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" + --ifC "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 diff --git a/src/BNFC/Backend/Haskell/CFtoAlex2.hs b/src/BNFC/Backend/Haskell/CFtoAlex2.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoAlex2.hs @@ -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" " ::= ^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 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"]]) diff --git a/src/BNFC/Backend/Haskell/CFtoAlex3.hs b/src/BNFC/Backend/Haskell/CFtoAlex3.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoAlex3.hs @@ -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" " ::= ^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 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"]]) diff --git a/src/BNFC/Backend/Haskell/CFtoHappy.hs b/src/BNFC/Backend/Haskell/CFtoHappy.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoHappy.hs @@ -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 = "" + diff --git a/src/BNFC/Backend/Haskell/CFtoLayout.hs b/src/BNFC/Backend/Haskell/CFtoLayout.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoLayout.hs @@ -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) diff --git a/src/BNFC/Backend/Haskell/CFtoPrinter.hs b/src/BNFC/Backend/Haskell/CFtoPrinter.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoPrinter.hs @@ -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 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) + diff --git a/src/BNFC/Backend/Haskell/CFtoTemplate.hs b/src/BNFC/Backend/Haskell/CFtoTemplate.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/CFtoTemplate.hs @@ -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 diff --git a/src/BNFC/Backend/Haskell/HsOpts.hs b/src/BNFC/Backend/Haskell/HsOpts.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/HsOpts.hs @@ -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 diff --git a/src/BNFC/Backend/Haskell/MkErrM.hs b/src/BNFC/Backend/Haskell/MkErrM.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/MkErrM.hs @@ -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" + ] diff --git a/src/BNFC/Backend/Haskell/MkSharedString.hs b/src/BNFC/Backend/Haskell/MkSharedString.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/MkSharedString.hs @@ -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" + ] diff --git a/src/BNFC/Backend/Haskell/RegToAlex.hs b/src/BNFC/Backend/Haskell/RegToAlex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/RegToAlex.hs @@ -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 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"]]) + + + diff --git a/src/BNFC/Backend/Haskell/ToCNF.hs b/src/BNFC/Backend/Haskell/ToCNF.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Haskell/ToCNF.hs @@ -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!!!" + ] + + diff --git a/src/BNFC/Backend/HaskellGADT.hs b/src/BNFC/Backend/HaskellGADT.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellGADT.hs @@ -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 }" + ] diff --git a/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs b/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs @@ -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 diff --git a/src/BNFC/Backend/HaskellGADT/CFtoPrinterGADT.hs b/src/BNFC/Backend/HaskellGADT/CFtoPrinterGADT.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellGADT/CFtoPrinterGADT.hs @@ -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 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) + diff --git a/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs b/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs @@ -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 diff --git a/src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs b/src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs @@ -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) diff --git a/src/BNFC/Backend/HaskellProfile.hs b/src/BNFC/Backend/HaskellProfile.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellProfile.hs @@ -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) diff --git a/src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs b/src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs @@ -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 "" diff --git a/src/BNFC/Backend/Java.hs b/src/BNFC/Backend/Java.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java.hs @@ -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) diff --git a/src/BNFC/Backend/Java/CFtoAbstractVisitor.hs b/src/BNFC/Backend/Java/CFtoAbstractVisitor.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoAbstractVisitor.hs @@ -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 implements AllVisitor {", + 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 _ _ _ _ = "" + diff --git a/src/BNFC/Backend/Java/CFtoAllVisitor.hs b/src/BNFC/Backend/Java/CFtoAllVisitor.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoAllVisitor.hs @@ -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 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" + where q = packageAbsyn ++ "." ++ identCat cat diff --git a/src/BNFC/Backend/Java/CFtoComposVisitor.hs b/src/BNFC/Backend/Java/CFtoComposVisitor.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoComposVisitor.hs @@ -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 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"]) + diff --git a/src/BNFC/Backend/Java/CFtoCup15.hs b/src/BNFC/Backend/Java/CFtoCup15.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoCup15.hs @@ -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 > 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 + diff --git a/src/BNFC/Backend/Java/CFtoFoldVisitor.hs b/src/BNFC/Backend/Java/CFtoFoldVisitor.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoFoldVisitor.hs @@ -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 implements AllVisitor {", + " 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"]) + diff --git a/src/BNFC/Backend/Java/CFtoJLex15.hs b/src/BNFC/Backend/Java/CFtoJLex15.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoJLex15.hs @@ -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) = + "" ++ (escapeChars s) ++ " { return new Symbol(sym." + ++ r ++ "); }" + +restOfJLex :: CF -> [String] +restOfJLex cf = + [ + lexComments (comments cf), + userDefTokens, + ifC catString strStates, + ifC catChar chStates, + ifC catDouble "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", + ifC catInteger "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", + ifC catIdent "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }" + , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" + ] + where + ifC cat s = if isUsedCat cf cat then s else "" + userDefTokens = unlines $ + ["" ++ printRegJLex exp +++ + "{ return new Symbol(sym." ++ show name ++ ", yytext().intern()); }" + | (name, exp) <- tokenPragmas cf] + strStates = unlines --These handle escaped characters in Strings. + [ + "\"\\\"\" { yybegin(STRING); }", + "\\\\ { yybegin(ESCAPED); }", + "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }", + ". { pstring += yytext(); }", + "n { pstring += \"\\n\"; yybegin(STRING); }", + "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", + "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", + "t { pstring += \"\\t\"; yybegin(STRING); }", + ". { pstring += yytext(); yybegin(STRING); }" + ] + chStates = unlines --These handle escaped characters in Chars. + [ + "\"'\" { yybegin(CHAR); }", + "\\\\ { yybegin(CHARESC); }", + "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", + "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", + ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", + "\"'\" {yybegin(YYINITIAL);}" + ] + + + + +lexComments :: ([(String, String)], [String]) -> String +lexComments (m,s) = + (unlines (map lexSingleComment s)) + ++ (unlines (map lexMultiComment m)) + +lexSingleComment :: String -> String +lexSingleComment c = + "\"" ++ 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 [ + "\"" ++ b ++ "\" { yybegin(COMMENT); }", + "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", + ". { }", + "[\\n] { }" + ] + +-- lexReserved :: String -> String +-- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" + +--Helper function that escapes characters in strings +escapeChars :: String -> String +escapeChars = concatMap escapeChar diff --git a/src/BNFC/Backend/Java/CFtoJavaAbs15.hs b/src/BNFC/Backend/Java/CFtoJavaAbs15.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoJavaAbs15.hs @@ -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 accept(" + ++ cls ++ ".Visitor v, A arg);", + prVisitor packageAbsyn funs, + "}" + ])] + where cls = identCat cat + +prVisitor :: String -> [String] -> String +prVisitor packageAbsyn funs = + unlines [ + " public interface Visitor {", + 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 accept(" ++ pack ++ "." ++ show cat + ++ ".Visitor 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 diff --git a/src/BNFC/Backend/Java/CFtoJavaPrinter15.hs b/src/BNFC/Backend/Java/CFtoJavaPrinter15.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoJavaPrinter15.hs @@ -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 ++ "_" diff --git a/src/BNFC/Backend/Java/CFtoVisitSkel15.hs b/src/BNFC/Backend/Java/CFtoVisitSkel15.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/CFtoVisitSkel15.hs @@ -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 implements " + ++ identCat cat ++ ".Visitor", + " {", + 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(), 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 diff --git a/src/BNFC/Backend/Java/RegToJLex.hs b/src/BNFC/Backend/Java/RegToJLex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Java/RegToJLex.hs @@ -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 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 [["."]]) + + + diff --git a/src/BNFC/Backend/Latex.hs b/src/BNFC/Backend/Latex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Latex.hs @@ -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 diff --git a/src/BNFC/Backend/OCaml.hs b/src/BNFC/Backend/OCaml.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml.hs @@ -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" + ] + diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs b/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlAbs.hs @@ -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" diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs b/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlLex.hs @@ -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 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"]]) diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs b/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs @@ -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 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) + diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlShow.hs b/src/BNFC/Backend/OCaml/CFtoOCamlShow.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlShow.hs @@ -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) + diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs b/src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlTemplate.hs @@ -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] + diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlTest.hs b/src/BNFC/Backend/OCaml/CFtoOCamlTest.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlTest.hs @@ -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 ();;", + "" + ] + + diff --git a/src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs b/src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs @@ -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" -> "" + "Integer" -> "" + "Double" -> "" + "Char" -> "" + own -> "" ) + +++ "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 "" + + + diff --git a/src/BNFC/Backend/OCaml/OCamlUtil.hs b/src/BNFC/Backend/OCaml/OCamlUtil.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/OCaml/OCamlUtil.hs @@ -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 diff --git a/src/BNFC/Backend/Txt2Tag.hs b/src/BNFC/Backend/Txt2Tag.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/Txt2Tag.hs @@ -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 ++ "``" diff --git a/src/BNFC/Backend/XML.hs b/src/BNFC/Backend/XML.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Backend/XML.hs @@ -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\"?"), + "" + ] + +-- | >>> tag "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 + ] diff --git a/src/BNFC/CF.hs b/src/BNFC/CF.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/CF.hs @@ -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 diff --git a/src/BNFC/GetCF.hs b/src/BNFC/GetCF.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/GetCF.hs @@ -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) diff --git a/src/BNFC/MultiView.hs b/src/BNFC/MultiView.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/MultiView.hs @@ -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 (/='_') diff --git a/src/BNFC/Options.hs b/src/BNFC/Options.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Options.hs @@ -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}) "") + "Prepend 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] [] 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 + diff --git a/src/BNFC/ToCNFCore.hs b/src/BNFC/ToCNFCore.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/ToCNFCore.hs @@ -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 diff --git a/src/BNFC/TypeChecker.hs b/src/BNFC/TypeChecker.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/TypeChecker.hs @@ -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 ++ "." + diff --git a/src/BNFC/Utils.hs b/src/BNFC/Utils.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/Utils.hs @@ -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 diff --git a/src/BNFC/WarningM.hs b/src/BNFC/WarningM.hs new file mode 100644 --- /dev/null +++ b/src/BNFC/WarningM.hs @@ -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] diff --git a/src/CF.hs b/src/CF.hs deleted file mode 100644 --- a/src/CF.hs +++ /dev/null @@ -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 diff --git a/src/ErrM.hs b/src/ErrM.hs --- a/src/ErrM.hs +++ b/src/ErrM.hs @@ -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 diff --git a/src/GetCF.hs b/src/GetCF.hs deleted file mode 100644 --- a/src/GetCF.hs +++ /dev/null @@ -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) diff --git a/src/LexBNF.x b/src/LexBNF.x --- a/src/LexBNF.x +++ b/src/LexBNF.x @@ -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 diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 * ? * 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 Prepend 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 Use as the C++ namespace" - putStrLn "" - putStrLn "Special options for the Java (v 1.5) back-end:" - putStrLn " -p Prepend to the Java package name" - putStrLn "" - putStrLn "Special options for the C# backend:" - putStrLn " -p Use 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 diff --git a/src/MultiView.hs b/src/MultiView.hs deleted file mode 100644 --- a/src/MultiView.hs +++ /dev/null @@ -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 (/='_') diff --git a/src/Options.hs b/src/Options.hs deleted file mode 100644 --- a/src/Options.hs +++ /dev/null @@ -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 - - - diff --git a/src/PrintBNF.hs b/src/PrintBNF.hs --- a/src/PrintBNF.hs +++ b/src/PrintBNF.hs @@ -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 diff --git a/src/TypeChecker.hs b/src/TypeChecker.hs deleted file mode 100644 --- a/src/TypeChecker.hs +++ /dev/null @@ -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 ++ "." - diff --git a/src/Utils.hs b/src/Utils.hs deleted file mode 100644 --- a/src/Utils.hs +++ /dev/null @@ -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 diff --git a/src/formats/CFtoLatex.hs b/src/formats/CFtoLatex.hs deleted file mode 100644 --- a/src/formats/CFtoLatex.hs +++ /dev/null @@ -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 diff --git a/src/formats/CFtoTxt.hs b/src/formats/CFtoTxt.hs deleted file mode 100644 --- a/src/formats/CFtoTxt.hs +++ /dev/null @@ -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 ++ "``" diff --git a/src/formats/NamedVariables.hs b/src/formats/NamedVariables.hs deleted file mode 100644 --- a/src/formats/NamedVariables.hs +++ /dev/null @@ -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) diff --git a/src/formats/OOAbstract.hs b/src/formats/OOAbstract.hs deleted file mode 100644 --- a/src/formats/OOAbstract.hs +++ /dev/null @@ -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 diff --git a/src/formats/c-sharp/CAbstoCSharpAbs.hs b/src/formats/c-sharp/CAbstoCSharpAbs.hs deleted file mode 100644 --- a/src/formats/c-sharp/CAbstoCSharpAbs.hs +++ /dev/null @@ -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(" ++ identifier namespace cat ++ ".Visitor v, A arg);", - prVisitor namespace funs, - " }" - ] - -prVisitor :: Namespace -> [Cat] -> String -prVisitor namespace funs = unlinesInline [ - " ", - " public interface Visitor", - " {", - 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(" ++ identifier namespace cat ++ ".Visitor 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] diff --git a/src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs b/src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs deleted file mode 100644 --- a/src/formats/c-sharp/CAbstoCSharpAbstractVisitSkeleton.hs +++ /dev/null @@ -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 : " ++ identifier namespace c ++ ".Visitor", - " {", - " 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 : " ++ identifier namespace c ++ ".Visitor", - " {", - 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);" - ] diff --git a/src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs b/src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs deleted file mode 100644 --- a/src/formats/c-sharp/CAbstoCSharpVisitSkeleton.hs +++ /dev/null @@ -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 : Abstract" ++ c ++ "Visitor", - " {", - " 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 : Abstract" ++ c ++ "Visitor", - " {", - 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(), 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(), arg);" - else " // x", - " }" - ] diff --git a/src/formats/c-sharp/CFtoCSharpPrinter.hs b/src/formats/c-sharp/CFtoCSharpPrinter.hs deleted file mode 100644 --- a/src/formats/c-sharp/CFtoCSharpPrinter.hs +++ /dev/null @@ -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 ++ "_" diff --git a/src/formats/c-sharp/CFtoGPLEX.hs b/src/formats/c-sharp/CFtoGPLEX.hs deleted file mode 100644 --- a/src/formats/c-sharp/CFtoGPLEX.hs +++ /dev/null @@ -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, - "", - "%{", - " /// ", - " /// Buffer for escaped characters in strings.", - " /// ", - " private System.Text.StringBuilder strBuffer = new System.Text.StringBuilder();", - "", - " /// ", - " /// Change to enable output - useful for debugging purposes", - " /// ", - " public bool Trace = false;", - "", - " /// ", - " /// Culture-independent IFormatProvider for numbers. ", - " /// This is just a \"wrapper\" for System.Globalization.NumberFormatInfo.InvariantInfo.", - " /// ", - " /// ", - " /// 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.", - " /// ", - " private static System.Globalization.NumberFormatInfo InvariantFormatInfo = System.Globalization.NumberFormatInfo.InvariantInfo;", - "", - " /// ", - " /// 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.", - " /// ", - " public static Scanner CreateScanner(Stream stream)", - " {", - " Scanner scanner = new Scanner(stream);", - " scanner.Begin();", - " return scanner;", - " }", - "", - " /// ", - " /// Sets the scanner to the correct initial state (YYINITIAL). ", - " /// You should call this method prior to calling parser.Parse().", - " /// ", - " public void Begin()", - " {", - " BEGIN(YYINITIAL);", - " }", - "", - " /// ", - " /// Convenience method to \"reset\" the buffer for escaped characters in strings.", - " /// ", - " 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) = - ("\"" ++ 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" [("{digit}+\".\"{digit}+(\"e\"(\\-)?{digit}+)?" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.double_ = Double.Parse(yytext, InvariantFormatInfo); return (int)Tokens.DOUBLE_;")], - ifC "Integer" [("{digit}+" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.int_ = Int32.Parse(yytext, InvariantFormatInfo); return (int)Tokens.INTEGER_;")], - ifC "Ident" [("{alpha}{ident}*" , "if(Trace) System.Console.Error.WriteLine(yytext); yylval.string_ = yytext; return (int)Tokens.IDENT_;")], - [("[ \\t\\r\\n\\f]" , "/* ignore white space. */;")], - [("." , "return (int)Tokens.error;")] - ] - where - ifC cat s = if isUsedCat cf cat then s else [] - userDefTokens = map tokenline (tokenPragmas cf) - where - tokenline (name, exp) = ("" ++ 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 = [ - ("\"\\\"\"" , "BEGIN(STRING);"), - ("\\\\" , "BEGIN(ESCAPED);"), - ("\\\"" , "yylval.string_ = this.strBuffer.ToString(); BufferReset(); BEGIN(YYINITIAL); return (int)Tokens.STRING_;"), - ("." , "this.strBuffer.Append(yytext);"), - ("n" , "this.strBuffer.Append(\"\\n\"); BEGIN(STRING);"), - ("\\\"" , "this.strBuffer.Append(\"\\\"\"); BEGIN(STRING);"), - ("\\\\" , "this.strBuffer.Append(\"\\\\\"); BEGIN(STRING);"), - ("t" , "this.strBuffer.Append(\"\\t\"); BEGIN(STRING);"), - ("." , "this.strBuffer.Append(yytext); BEGIN(STRING);") - ] - -- These handle escaped characters in Chars. - charStates = [ - ("\"'\"" , "BEGIN(CHAR);"), - ("\\\\" , "BEGIN(CHARESC);"), - ("[^']" , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), - ("n" , "BEGIN(CHAREND); yylval.char_ = '\\n'; return (int)Tokens.CHAR_;"), - ("t" , "BEGIN(CHAREND); yylval.char_ = '\\t'; return (int)Tokens.CHAR_;"), - ("." , "BEGIN(CHAREND); yylval.char_ = yytext[0]; return (int)Tokens.CHAR_;"), - ("\"'\"" , "BEGIN(YYINITIAL);") - ] - -lexComments :: ([(String, String)], [String]) -> [(String, String)] -lexComments (m,s) = (map lexSingleComment s) ++ (concatMap lexMultiComment m) - -lexSingleComment :: String -> (String, String) -lexSingleComment c = - ("\"" ++ 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) = [ - ("\"" ++ b ++ "\"" , "BEGIN(COMMENT);"), - ("\"" ++ e ++ "\"" , "BEGIN(YYINITIAL);"), - ("." , "/* BNFC multi-line 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 diff --git a/src/formats/c-sharp/CFtoGPPG.hs b/src/formats/c-sharp/CFtoGPPG.hs deleted file mode 100644 --- a/src/formats/c-sharp/CFtoGPPG.hs +++ /dev/null @@ -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_", - ifC "Char" "%token CHAR_", - ifC "Integer" "%token INTEGER_", - ifC "Double" "%token DOUBLE_", - ifC "Ident" "%token 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 diff --git a/src/formats/c-sharp/CSharpTop.hs b/src/formats/c-sharp/CSharpTop.hs deleted file mode 100644 --- a/src/formats/c-sharp/CSharpTop.hs +++ /dev/null @@ -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 [ - "", - "", - " ", - " Debug", - " AnyCPU", - " 8.0.50727", - " 2.0", - " " ++ guid ++ "", - " Library", - " Properties", - " " ++ namespace ++ "", - " " ++ namespace ++ "", - " ", - " ", - " ", - " ", - " true", - " full", - " false", - " bin\\Debug\\", - " DEBUG;TRACE", - " prompt", - " 4", - " ", - " ", - " pdbonly", - " true", - " bin\\Release\\", - " TRACE", - " prompt", - " 4", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " False", - " bin\\ShiftReduceParser.dll", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - " ", - "" - ] - -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" diff --git a/src/formats/c-sharp/CSharpUtils.hs b/src/formats/c-sharp/CSharpUtils.hs deleted file mode 100644 --- a/src/formats/c-sharp/CSharpUtils.hs +++ /dev/null @@ -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)) - diff --git a/src/formats/c-sharp/RegToGPLEX.hs b/src/formats/c-sharp/RegToGPLEX.hs deleted file mode 100644 --- a/src/formats/c-sharp/RegToGPLEX.hs +++ /dev/null @@ -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 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] diff --git a/src/formats/c/CFtoBisonC.hs b/src/formats/c/CFtoBisonC.hs deleted file mode 100644 --- a/src/formats/c/CFtoBisonC.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "#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 " ++ r ++ " /* " ++ s ++ " */\n" - else "%token " ++ r ++ " /* " ++ s ++ " */\n" - -specialToks :: CF -> String -specialToks cf = concat [ - ifC "String" "%token _STRING_\n", - ifC "Char" "%token _CHAR_\n", - ifC "Integer" "%token _INTEGER_\n", - ifC "Double" "%token _DOUBLE_\n", - ifC "Ident" "%token _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 diff --git a/src/formats/c/CFtoCAbs.hs b/src/formats/c/CFtoCAbs.hs deleted file mode 100644 --- a/src/formats/c/CFtoCAbs.hs +++ /dev/null @@ -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 ", - "#include ", - "#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) ++ "_" diff --git a/src/formats/c/CFtoCPrinter.hs b/src/formats/c/CFtoCPrinter.hs deleted file mode 100644 --- a/src/formats/c/CFtoCPrinter.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "", - "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_--;", - " }", - "}" - ] diff --git a/src/formats/c/CFtoCSkel.hs b/src/formats/c/CFtoCSkel.hs deleted file mode 100644 --- a/src/formats/c/CFtoCSkel.hs +++ /dev/null @@ -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 diff --git a/src/formats/c/CFtoFlexC.hs b/src/formats/c/CFtoFlexC.hs deleted file mode 100644 --- a/src/formats/c/CFtoFlexC.hs +++ /dev/null @@ -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 ", - "#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) = - "\"" ++ 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" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n", - ifC "Integer" "{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n", - ifC "Ident" "{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n" - , "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", - ". \t return _ERROR_;\n", - "%%\n", - footer - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - userDefTokens = unlines $ - ["" ++ 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. - [ - "\"\\\"\" \t BEGIN STRING;", - "\\\\ \t BEGIN ESCAPED;", - "\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;", - ". \t YY_BUFFER_APPEND(yytext);", - "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", - "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", - "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", - "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", - ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" \tBEGIN CHAR;", - "\\\\ \t BEGIN CHARESC;", - "[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", - "n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;", - "t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;", - ". \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;", - "\"'\" \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 = - "\"" ++ 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 [ - "\"" ++ b ++ "\" \t BEGIN COMMENT;", - "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", - ". \t /* BNFC multi-line comment */;", - "[\\n] \t /* BNFC multi-line comment */;" - ] - -lexReserved :: String -> String -lexReserved s = "\"" ++ 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) diff --git a/src/formats/c/CTop.hs b/src/formats/c/CTop.hs deleted file mode 100644 --- a/src/formats/c/CTop.hs +++ /dev/null @@ -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 ", - "#include ", - "", - "#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 _ = "" - diff --git a/src/formats/cpp/CFtoBison.hs b/src/formats/cpp/CFtoBison.hs deleted file mode 100644 --- a/src/formats/cpp/CFtoBison.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "#include ", - "#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 " ++ r ++ " // " ++ s ++ "\n" - else "%token " ++ r ++ " // " ++ s ++ "\n" - -specialToks :: CF -> String -specialToks cf = concat [ - ifC "String" "%token _STRING_\n", - ifC "Char" "%token _CHAR_\n", - ifC "Integer" "%token _INTEGER_\n", - ifC "Double" "%token _DOUBLE_\n", - ifC "Ident" "%token _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 diff --git a/src/formats/cpp/CFtoCPPAbs.hs b/src/formats/cpp/CFtoCPPAbs.hs deleted file mode 100644 --- a/src/formats/cpp/CFtoCPPAbs.hs +++ /dev/null @@ -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 ", - "#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 diff --git a/src/formats/cpp/CFtoCPPPrinter.hs b/src/formats/cpp/CFtoCPPPrinter.hs deleted file mode 100644 --- a/src/formats/cpp/CFtoCPPPrinter.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "", - "/* 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_--;", - " }", - "}" - ] diff --git a/src/formats/cpp/CFtoCVisitSkel.hs b/src/formats/cpp/CFtoCVisitSkel.hs deleted file mode 100644 --- a/src/formats/cpp/CFtoCVisitSkel.hs +++ /dev/null @@ -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 diff --git a/src/formats/cpp/CFtoFlex.hs b/src/formats/cpp/CFtoFlex.hs deleted file mode 100644 --- a/src/formats/cpp/CFtoFlex.hs +++ /dev/null @@ -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 ", - "#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) = - "\"" ++ 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" ("{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"), - ifC "Integer" ("{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"), - ifC "Ident" ("{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"), - "\\n ++" ++ ns ++ "yy_mylinenumber ;\n", - "[ \\t\\r\\n\\f] \t /* ignore white space. */;\n", - ". \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n", - "%%\n", - footer - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - ns = nsString inPackage - userDefTokens = unlines $ - ["" ++ 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. - [ - "\"\\\"\" \t BEGIN STRING;", - "\\\\ \t BEGIN ESCAPED;", - "\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";", - ". \t YY_BUFFER_APPEND(yytext);", - "n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;", - "\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;", - "\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;", - "t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;", - ". \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" \tBEGIN CHAR;", - "\\\\ \t BEGIN CHARESC;", - "[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - "n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - "t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - ". \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";", - "\"'\" \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 = - "\"" ++ 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 [ - "\"" ++ b ++ "\" \t BEGIN COMMENT;", - "\"" ++ e ++ "\" \t BEGIN YYINITIAL;", - ". \t /* BNFC multi-line 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) diff --git a/src/formats/cpp/CPPTop.hs b/src/formats/cpp/CPPTop.hs deleted file mode 100644 --- a/src/formats/cpp/CPPTop.hs +++ /dev/null @@ -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 ", - "#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 _ = "" diff --git a/src/formats/cpp/RegToFlex.hs b/src/formats/cpp/RegToFlex.hs deleted file mode 100644 --- a/src/formats/cpp/RegToFlex.hs +++ /dev/null @@ -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 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] diff --git a/src/formats/cpp_stl/CFtoBisonSTL.hs b/src/formats/cpp_stl/CFtoBisonSTL.hs deleted file mode 100644 --- a/src/formats/cpp_stl/CFtoBisonSTL.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "#include ", - "#include ", - "#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 " ++ r ++ " // " ++ s ++ "\n" - else "%token " ++ r ++ " // " ++ s ++ "\n" - -specialToks :: CF -> String -specialToks cf = concat [ - ifC "String" "%token _STRING_\n", - ifC "Char" "%token _CHAR_\n", - ifC "Integer" "%token _INTEGER_\n", - ifC "Double" "%token _DOUBLE_\n", - ifC "Ident" "%token _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 - - diff --git a/src/formats/cpp_stl/CFtoCVisitSkelSTL.hs b/src/formats/cpp_stl/CFtoCVisitSkelSTL.hs deleted file mode 100644 --- a/src/formats/cpp_stl/CFtoCVisitSkelSTL.hs +++ /dev/null @@ -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 ++ ");") - diff --git a/src/formats/cpp_stl/CFtoSTLAbs.hs b/src/formats/cpp_stl/CFtoSTLAbs.hs deleted file mode 100644 --- a/src/formats/cpp_stl/CFtoSTLAbs.hs +++ /dev/null @@ -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", - "#include", - "", - "//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 ", - "#include ", - "#include ", - "#include ", - "#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], - "}" - ] diff --git a/src/formats/cpp_stl/CFtoSTLPrinter.hs b/src/formats/cpp_stl/CFtoSTLPrinter.hs deleted file mode 100644 --- a/src/formats/cpp_stl/CFtoSTLPrinter.hs +++ /dev/null @@ -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 ", - "#include ", - "#include ", - "", - 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 ", - "#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_--;", - " }", - "}" - ] diff --git a/src/formats/cpp_stl/STLTop.hs b/src/formats/cpp_stl/STLTop.hs deleted file mode 100644 --- a/src/formats/cpp_stl/STLTop.hs +++ /dev/null @@ -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 ", - "#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", - "#include", - "", - 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 _ = "" diff --git a/src/formats/cpp_stl/STLUtils.hs b/src/formats/cpp_stl/STLUtils.hs deleted file mode 100644 --- a/src/formats/cpp_stl/STLUtils.hs +++ /dev/null @@ -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 diff --git a/src/formats/f-sharp/FSharpTop.hs b/src/formats/f-sharp/FSharpTop.hs deleted file mode 100644 --- a/src/formats/f-sharp/FSharpTop.hs +++ /dev/null @@ -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" - ] - diff --git a/src/formats/haskell-gadt/CFtoAbstractGADT.hs b/src/formats/haskell-gadt/CFtoAbstractGADT.hs deleted file mode 100644 --- a/src/formats/haskell-gadt/CFtoAbstractGADT.hs +++ /dev/null @@ -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 diff --git a/src/formats/haskell-gadt/CFtoPrinterGADT.hs b/src/formats/haskell-gadt/CFtoPrinterGADT.hs deleted file mode 100644 --- a/src/formats/haskell-gadt/CFtoPrinterGADT.hs +++ /dev/null @@ -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 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) - diff --git a/src/formats/haskell-gadt/CFtoTemplateGADT.hs b/src/formats/haskell-gadt/CFtoTemplateGADT.hs deleted file mode 100644 --- a/src/formats/haskell-gadt/CFtoTemplateGADT.hs +++ /dev/null @@ -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 diff --git a/src/formats/haskell-gadt/HaskellGADTCommon.hs b/src/formats/haskell-gadt/HaskellGADTCommon.hs deleted file mode 100644 --- a/src/formats/haskell-gadt/HaskellGADTCommon.hs +++ /dev/null @@ -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) diff --git a/src/formats/haskell-gadt/HaskellTopGADT.hs b/src/formats/haskell-gadt/HaskellTopGADT.hs deleted file mode 100644 --- a/src/formats/haskell-gadt/HaskellTopGADT.hs +++ /dev/null @@ -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 }" - ] diff --git a/src/formats/haskell2/CFtoAbstract.hs b/src/formats/haskell2/CFtoAbstract.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoAbstract.hs +++ /dev/null @@ -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" diff --git a/src/formats/haskell2/CFtoAlex.hs b/src/formats/haskell2/CFtoAlex.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoAlex.hs +++ /dev/null @@ -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" " ::= ^\" ([^u # [^\"^\\^n]] | (^\\ (^\" | ^\\ | ^' | n | t)))* ^\"" ++ - "%{ string p = PT p . TL . unescapeInitTail %}", - ifC "Char" " ::= ^\' (^u # [^\'^\\] | ^\\ [^\\ ^\' n t]) ^' %{ char p = PT p . TC %}", - ifC "Integer" " ::= ^d+ %{ int p = PT p . TI %}", - ifC "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 = - " ::= " ++ 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 $ - [" ::= " ++ 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 - " ::= ^l ^i* %{ ident p = PT p . eitherResIdent TV %}" - --ifC "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 diff --git a/src/formats/haskell2/CFtoAlex2.hs b/src/formats/haskell2/CFtoAlex2.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoAlex2.hs +++ /dev/null @@ -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" " ::= ^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 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"]]) diff --git a/src/formats/haskell2/CFtoAlex3.hs b/src/formats/haskell2/CFtoAlex3.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoAlex3.hs +++ /dev/null @@ -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" " ::= ^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 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"]]) diff --git a/src/formats/haskell2/CFtoHappy.hs b/src/formats/haskell2/CFtoHappy.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoHappy.hs +++ /dev/null @@ -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 = "" - diff --git a/src/formats/haskell2/CFtoLayout.hs b/src/formats/haskell2/CFtoLayout.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoLayout.hs +++ /dev/null @@ -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) diff --git a/src/formats/haskell2/CFtoPrinter.hs b/src/formats/haskell2/CFtoPrinter.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoPrinter.hs +++ /dev/null @@ -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 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) - diff --git a/src/formats/haskell2/CFtoTemplate.hs b/src/formats/haskell2/CFtoTemplate.hs deleted file mode 100644 --- a/src/formats/haskell2/CFtoTemplate.hs +++ /dev/null @@ -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] - diff --git a/src/formats/haskell2/HaskellTop.hs b/src/formats/haskell2/HaskellTop.hs deleted file mode 100644 --- a/src/formats/haskell2/HaskellTop.hs +++ /dev/null @@ -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)" - ] diff --git a/src/formats/haskell2/HsOpts.hs b/src/formats/haskell2/HsOpts.hs deleted file mode 100644 --- a/src/formats/haskell2/HsOpts.hs +++ /dev/null @@ -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 diff --git a/src/formats/haskell2/MkErrM.hs b/src/formats/haskell2/MkErrM.hs deleted file mode 100644 --- a/src/formats/haskell2/MkErrM.hs +++ /dev/null @@ -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" - ] diff --git a/src/formats/haskell2/MkSharedString.hs b/src/formats/haskell2/MkSharedString.hs deleted file mode 100644 --- a/src/formats/haskell2/MkSharedString.hs +++ /dev/null @@ -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" - ] diff --git a/src/formats/haskell2/RegToAlex.hs b/src/formats/haskell2/RegToAlex.hs deleted file mode 100644 --- a/src/formats/haskell2/RegToAlex.hs +++ /dev/null @@ -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 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"]]) - - - diff --git a/src/formats/haskell2/ToCNF.hs b/src/formats/haskell2/ToCNF.hs deleted file mode 100644 --- a/src/formats/haskell2/ToCNF.hs +++ /dev/null @@ -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 diff --git a/src/formats/java/CFtoCup.hs b/src/formats/java/CFtoCup.hs deleted file mode 100644 --- a/src/formats/java/CFtoCup.hs +++ /dev/null @@ -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 - diff --git a/src/formats/java/CFtoJLex.hs b/src/formats/java/CFtoJLex.hs deleted file mode 100644 --- a/src/formats/java/CFtoJLex.hs +++ /dev/null @@ -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) = - "" ++ (escapeChars s) ++ " { return new Symbol(sym." - ++ r ++ "); }" - -restOfJLex :: CF -> [String] -restOfJLex cf = - [ - lexComments (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" chStates, - ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", - ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", - ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, new String(yytext())); }" - , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - userDefTokens = unlines $ - ["" ++ printRegJLex exp +++ - "{ return new Symbol(sym." ++ name ++ ", yytext()); }" - | (name, exp) <- tokenPragmas cf] - strStates = unlines --These handle escaped characters in Strings. - [ - "\"\\\"\" { yybegin(STRING); }", - "\\\\ { yybegin(ESCAPED); }", - "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo); }", - ". { pstring += yytext(); }", - "n { pstring += \"\\n\"; yybegin(STRING); }", - "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", - "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", - "t { pstring += \"\\t\"; yybegin(STRING); }", - ". { pstring += yytext(); yybegin(STRING); }" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" { yybegin(CHAR); }", - "\\\\ { yybegin(CHARESC); }", - "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", - "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", - ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "\"'\" {yybegin(YYINITIAL);}" - ] - - - - -lexComments :: ([(String, String)], [String]) -> String -lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m)) - -lexSingleComment :: String -> String -lexSingleComment c = - "\"" ++ 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 [ - "\"" ++ b ++ "\" { yybegin(COMMENT); }", - "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", - ". { }", - "[\\n] { }" - ] - --- lexReserved :: String -> String --- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars = concatMap escapeChar diff --git a/src/formats/java/CFtoJavaAbs.hs b/src/formats/java/CFtoJavaAbs.hs deleted file mode 100644 --- a/src/formats/java/CFtoJavaAbs.hs +++ /dev/null @@ -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 diff --git a/src/formats/java/CFtoJavaPrinter.hs b/src/formats/java/CFtoJavaPrinter.hs deleted file mode 100644 --- a/src/formats/java/CFtoJavaPrinter.hs +++ /dev/null @@ -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 ++ "_" diff --git a/src/formats/java/CFtoJavaSkeleton.hs b/src/formats/java/CFtoJavaSkeleton.hs deleted file mode 100644 --- a/src/formats/java/CFtoJavaSkeleton.hs +++ /dev/null @@ -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 ++ ");" diff --git a/src/formats/java/CFtoVisitSkel.hs b/src/formats/java/CFtoVisitSkel.hs deleted file mode 100644 --- a/src/formats/java/CFtoVisitSkel.hs +++ /dev/null @@ -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 diff --git a/src/formats/java/JavaTop.hs b/src/formats/java/JavaTop.hs deleted file mode 100644 --- a/src/formats/java/JavaTop.hs +++ /dev/null @@ -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) diff --git a/src/formats/java/RegToJLex.hs b/src/formats/java/RegToJLex.hs deleted file mode 100644 --- a/src/formats/java/RegToJLex.hs +++ /dev/null @@ -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 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 [["."]]) - - - diff --git a/src/formats/java1.5/CFtoAbstractVisitor.hs b/src/formats/java1.5/CFtoAbstractVisitor.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoAbstractVisitor.hs +++ /dev/null @@ -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 implements AllVisitor {", - 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 _ _ _ _ = "" - diff --git a/src/formats/java1.5/CFtoAllVisitor.hs b/src/formats/java1.5/CFtoAllVisitor.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoAllVisitor.hs +++ /dev/null @@ -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 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" - where q = packageAbsyn ++ "." ++ identCat cat diff --git a/src/formats/java1.5/CFtoComposVisitor.hs b/src/formats/java1.5/CFtoComposVisitor.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoComposVisitor.hs +++ /dev/null @@ -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 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"]) - diff --git a/src/formats/java1.5/CFtoCup15.hs b/src/formats/java1.5/CFtoCup15.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoCup15.hs +++ /dev/null @@ -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 > 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 - diff --git a/src/formats/java1.5/CFtoFoldVisitor.hs b/src/formats/java1.5/CFtoFoldVisitor.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoFoldVisitor.hs +++ /dev/null @@ -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 implements AllVisitor {", - " 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"]) - diff --git a/src/formats/java1.5/CFtoJLex15.hs b/src/formats/java1.5/CFtoJLex15.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoJLex15.hs +++ /dev/null @@ -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) = - "" ++ (escapeChars s) ++ " { return new Symbol(sym." - ++ r ++ "); }" - -restOfJLex :: CF -> [String] -restOfJLex cf = - [ - lexComments (comments cf), - userDefTokens, - ifC "String" strStates, - ifC "Char" chStates, - ifC "Double" "{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? { return new Symbol(sym._DOUBLE_, new Double(yytext())); }", - ifC "Integer" "{DIGIT}+ { return new Symbol(sym._INTEGER_, new Integer(yytext())); }", - ifC "Ident" "{LETTER}{IDENT}* { return new Symbol(sym._IDENT_, yytext().intern()); }" - , "[ \\t\\r\\n\\f] { /* ignore white space. */ }" - ] - where - ifC cat s = if isUsedCat cf cat then s else "" - userDefTokens = unlines $ - ["" ++ printRegJLex exp +++ - "{ return new Symbol(sym." ++ name ++ ", yytext().intern()); }" - | (name, exp) <- tokenPragmas cf] - strStates = unlines --These handle escaped characters in Strings. - [ - "\"\\\"\" { yybegin(STRING); }", - "\\\\ { yybegin(ESCAPED); }", - "\\\" { String foo = pstring; pstring = new String(); yybegin(YYINITIAL); return new Symbol(sym._STRING_, foo.intern()); }", - ". { pstring += yytext(); }", - "n { pstring += \"\\n\"; yybegin(STRING); }", - "\\\" { pstring += \"\\\"\"; yybegin(STRING); }", - "\\\\ { pstring += \"\\\\\"; yybegin(STRING); }", - "t { pstring += \"\\t\"; yybegin(STRING); }", - ". { pstring += yytext(); yybegin(STRING); }" - ] - chStates = unlines --These handle escaped characters in Chars. - [ - "\"'\" { yybegin(CHAR); }", - "\\\\ { yybegin(CHARESC); }", - "[^'] { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "n { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\n')); }", - "t { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character('\\t')); }", - ". { yybegin(CHAREND); return new Symbol(sym._CHAR_, new Character(yytext().charAt(0))); }", - "\"'\" {yybegin(YYINITIAL);}" - ] - - - - -lexComments :: ([(String, String)], [String]) -> String -lexComments (m,s) = - (unlines (map lexSingleComment s)) - ++ (unlines (map lexMultiComment m)) - -lexSingleComment :: String -> String -lexSingleComment c = - "\"" ++ 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 [ - "\"" ++ b ++ "\" { yybegin(COMMENT); }", - "\"" ++ e ++ "\" { yybegin(YYINITIAL); }", - ". { }", - "[\\n] { }" - ] - --- lexReserved :: String -> String --- lexReserved s = "\"" ++ s ++ "\" { return new Symbol(sym.TS, yytext()); }" - ---Helper function that escapes characters in strings -escapeChars :: String -> String -escapeChars = concatMap escapeChar diff --git a/src/formats/java1.5/CFtoJavaAbs15.hs b/src/formats/java1.5/CFtoJavaAbs15.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoJavaAbs15.hs +++ /dev/null @@ -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 accept(" - ++ cls ++ ".Visitor v, A arg);", - prVisitor packageAbsyn funs, - "}" - ])] - where cls = identCat cat - -prVisitor :: String -> [String] -> String -prVisitor packageAbsyn funs = - unlines [ - " public interface Visitor {", - 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 accept(" ++ pack ++ "." ++ cat - ++ ".Visitor 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 diff --git a/src/formats/java1.5/CFtoJavaPrinter15.hs b/src/formats/java1.5/CFtoJavaPrinter15.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoJavaPrinter15.hs +++ /dev/null @@ -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 ++ "_" diff --git a/src/formats/java1.5/CFtoVisitSkel15.hs b/src/formats/java1.5/CFtoVisitSkel15.hs deleted file mode 100644 --- a/src/formats/java1.5/CFtoVisitSkel15.hs +++ /dev/null @@ -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 implements " - ++ identCat cat ++ ".Visitor", - " {", - 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(), 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 diff --git a/src/formats/java1.5/JavaTop15.hs b/src/formats/java1.5/JavaTop15.hs deleted file mode 100644 --- a/src/formats/java1.5/JavaTop15.hs +++ /dev/null @@ -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) diff --git a/src/formats/ocaml/CFtoOCamlAbs.hs b/src/formats/ocaml/CFtoOCamlAbs.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlAbs.hs +++ /dev/null @@ -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" diff --git a/src/formats/ocaml/CFtoOCamlLex.hs b/src/formats/ocaml/CFtoOCamlLex.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlLex.hs +++ /dev/null @@ -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 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"]]) diff --git a/src/formats/ocaml/CFtoOCamlPrinter.hs b/src/formats/ocaml/CFtoOCamlPrinter.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlPrinter.hs +++ /dev/null @@ -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 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) - diff --git a/src/formats/ocaml/CFtoOCamlShow.hs b/src/formats/ocaml/CFtoOCamlShow.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlShow.hs +++ /dev/null @@ -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) - diff --git a/src/formats/ocaml/CFtoOCamlTemplate.hs b/src/formats/ocaml/CFtoOCamlTemplate.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlTemplate.hs +++ /dev/null @@ -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] - diff --git a/src/formats/ocaml/CFtoOCamlTest.hs b/src/formats/ocaml/CFtoOCamlTest.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlTest.hs +++ /dev/null @@ -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 ();;", - "" - ] - - diff --git a/src/formats/ocaml/CFtoOCamlYacc.hs b/src/formats/ocaml/CFtoOCamlYacc.hs deleted file mode 100644 --- a/src/formats/ocaml/CFtoOCamlYacc.hs +++ /dev/null @@ -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" -> "" - "Integer" -> "" - "Double" -> "" - "Char" -> "" - own -> "" ) - +++ "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 "" - - - diff --git a/src/formats/ocaml/OCamlTop.hs b/src/formats/ocaml/OCamlTop.hs deleted file mode 100644 --- a/src/formats/ocaml/OCamlTop.hs +++ /dev/null @@ -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" - ] - diff --git a/src/formats/ocaml/OCamlUtil.hs b/src/formats/ocaml/OCamlUtil.hs deleted file mode 100644 --- a/src/formats/ocaml/OCamlUtil.hs +++ /dev/null @@ -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 diff --git a/src/formats/profile/CFtoHappyProfile.hs b/src/formats/profile/CFtoHappyProfile.hs deleted file mode 100644 --- a/src/formats/profile/CFtoHappyProfile.hs +++ /dev/null @@ -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 "" diff --git a/src/formats/profile/ProfileTop.hs b/src/formats/profile/ProfileTop.hs deleted file mode 100644 --- a/src/formats/profile/ProfileTop.hs +++ /dev/null @@ -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 diff --git a/src/formats/xml/CFtoXML.hs b/src/formats/xml/CFtoXML.hs deleted file mode 100644 --- a/src/formats/xml/CFtoXML.hs +++ /dev/null @@ -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\"?"), - "" - ] - -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 - ] diff --git a/test/BNFC/Backend/Common/MakefileSpec.hs b/test/BNFC/Backend/Common/MakefileSpec.hs new file mode 100644 --- /dev/null +++ b/test/BNFC/Backend/Common/MakefileSpec.hs @@ -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","")] diff --git a/test/BNFC/OptionsSpec.hs b/test/BNFC/OptionsSpec.hs new file mode 100644 --- /dev/null +++ b/test/BNFC/OptionsSpec.hs @@ -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 + ] diff --git a/test/BNFC/WarningMSpec.hs b/test/BNFC/WarningMSpec.hs new file mode 100644 --- /dev/null +++ b/test/BNFC/WarningMSpec.hs @@ -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 diff --git a/test/unit-tests.hs b/test/unit-tests.hs new file mode 100644 --- /dev/null +++ b/test/unit-tests.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}