BNFC 2.8.3.1 → 2.8.4
raw patch · 112 files changed
+17804/−4206 lines, 112 filesdep ~basedep ~mtlPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: base, mtl
API changes (from Hackage documentation)
- Algebra.RingUtils: class Monad m => MonadFail (m :: Type -> Type)
- Algebra.RingUtils: (!!) :: [a] -> Int -> a
+ Algebra.RingUtils: (!!) :: () => [a] -> Int -> a
- Algebra.RingUtils: ($!) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b
+ Algebra.RingUtils: ($!) :: () => (a -> b) -> a -> b
- Algebra.RingUtils: ($) :: forall (r :: RuntimeRep) a (b :: TYPE r). (a -> b) -> a -> b
+ Algebra.RingUtils: ($) :: () => (a -> b) -> a -> b
- Algebra.RingUtils: (++) :: [a] -> [a] -> [a]
+ Algebra.RingUtils: (++) :: () => [a] -> [a] -> [a]
- Algebra.RingUtils: (.) :: (b -> c) -> (a -> b) -> a -> c
+ Algebra.RingUtils: (.) :: () => (b -> c) -> (a -> b) -> a -> c
- Algebra.RingUtils: asTypeOf :: a -> a -> a
+ Algebra.RingUtils: asTypeOf :: () => a -> a -> a
- Algebra.RingUtils: break :: (a -> Bool) -> [a] -> ([a], [a])
+ Algebra.RingUtils: break :: () => (a -> Bool) -> [a] -> ([a], [a])
- Algebra.RingUtils: class Foldable (t :: TYPE LiftedRep -> Type)
+ Algebra.RingUtils: class Foldable (t :: Type -> Type)
- Algebra.RingUtils: const :: a -> b -> a
+ Algebra.RingUtils: const :: () => a -> b -> a
- Algebra.RingUtils: curry :: ((a, b) -> c) -> a -> b -> c
+ Algebra.RingUtils: curry :: () => ((a, b) -> c) -> a -> b -> c
- Algebra.RingUtils: cycle :: [a] -> [a]
+ Algebra.RingUtils: cycle :: () => [a] -> [a]
- Algebra.RingUtils: drop :: Int -> [a] -> [a]
+ Algebra.RingUtils: drop :: () => Int -> [a] -> [a]
- Algebra.RingUtils: dropWhile :: (a -> Bool) -> [a] -> [a]
+ Algebra.RingUtils: dropWhile :: () => (a -> Bool) -> [a] -> [a]
- Algebra.RingUtils: either :: (a -> c) -> (b -> c) -> Either a b -> c
+ Algebra.RingUtils: either :: () => (a -> c) -> (b -> c) -> Either a b -> c
- Algebra.RingUtils: error :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => [Char] -> a
+ Algebra.RingUtils: error :: HasCallStack => [Char] -> a
- Algebra.RingUtils: errorWithoutStackTrace :: forall (r :: RuntimeRep) (a :: TYPE r). [Char] -> a
+ Algebra.RingUtils: errorWithoutStackTrace :: () => [Char] -> a
- Algebra.RingUtils: fail :: MonadFail m => String -> m a
+ Algebra.RingUtils: fail :: Monad m => String -> m a
- Algebra.RingUtils: filter :: (a -> Bool) -> [a] -> [a]
+ Algebra.RingUtils: filter :: () => (a -> Bool) -> [a] -> [a]
- Algebra.RingUtils: flip :: (a -> b -> c) -> b -> a -> c
+ Algebra.RingUtils: flip :: () => (a -> b -> c) -> b -> a -> c
- Algebra.RingUtils: fst :: (a, b) -> a
+ Algebra.RingUtils: fst :: () => (a, b) -> a
- Algebra.RingUtils: head :: [a] -> a
+ Algebra.RingUtils: head :: () => [a] -> a
- Algebra.RingUtils: id :: a -> a
+ Algebra.RingUtils: id :: () => a -> a
- Algebra.RingUtils: infixl 1 >>=
+ Algebra.RingUtils: infixl 1 >>
- Algebra.RingUtils: init :: [a] -> [a]
+ Algebra.RingUtils: init :: () => [a] -> [a]
- Algebra.RingUtils: ioError :: IOError -> IO a
+ Algebra.RingUtils: ioError :: () => IOError -> IO a
- Algebra.RingUtils: iterate :: (a -> a) -> a -> [a]
+ Algebra.RingUtils: iterate :: () => (a -> a) -> a -> [a]
- Algebra.RingUtils: last :: [a] -> a
+ Algebra.RingUtils: last :: () => [a] -> a
- Algebra.RingUtils: map :: (a -> b) -> [a] -> [b]
+ Algebra.RingUtils: map :: () => (a -> b) -> [a] -> [b]
- Algebra.RingUtils: maybe :: b -> (a -> b) -> Maybe a -> b
+ Algebra.RingUtils: maybe :: () => b -> (a -> b) -> Maybe a -> b
- Algebra.RingUtils: onlyLeft :: [a] -> Pair [a]
+ Algebra.RingUtils: onlyLeft :: () => [a] -> Pair [a]
- Algebra.RingUtils: onlyRight :: [a] -> Pair [a]
+ Algebra.RingUtils: onlyRight :: () => [a] -> Pair [a]
- Algebra.RingUtils: readParen :: Bool -> ReadS a -> ReadS a
+ Algebra.RingUtils: readParen :: () => Bool -> ReadS a -> ReadS a
- Algebra.RingUtils: repeat :: a -> [a]
+ Algebra.RingUtils: repeat :: () => a -> [a]
- Algebra.RingUtils: replicate :: Int -> a -> [a]
+ Algebra.RingUtils: replicate :: () => Int -> a -> [a]
- Algebra.RingUtils: reverse :: [a] -> [a]
+ Algebra.RingUtils: reverse :: () => [a] -> [a]
- Algebra.RingUtils: scanl :: (b -> a -> b) -> b -> [a] -> [b]
+ Algebra.RingUtils: scanl :: () => (b -> a -> b) -> b -> [a] -> [b]
- Algebra.RingUtils: scanl1 :: (a -> a -> a) -> [a] -> [a]
+ Algebra.RingUtils: scanl1 :: () => (a -> a -> a) -> [a] -> [a]
- Algebra.RingUtils: scanr :: (a -> b -> b) -> b -> [a] -> [b]
+ Algebra.RingUtils: scanr :: () => (a -> b -> b) -> b -> [a] -> [b]
- Algebra.RingUtils: scanr1 :: (a -> a -> a) -> [a] -> [a]
+ Algebra.RingUtils: scanr1 :: () => (a -> a -> a) -> [a] -> [a]
- Algebra.RingUtils: select :: Bool -> [a] -> Pair [a]
+ Algebra.RingUtils: select :: () => Bool -> [a] -> Pair [a]
- Algebra.RingUtils: seq :: forall {r :: RuntimeRep} a (b :: TYPE r). a -> b -> b
+ Algebra.RingUtils: seq :: () => a -> b -> b
- Algebra.RingUtils: snd :: (a, b) -> b
+ Algebra.RingUtils: snd :: () => (a, b) -> b
- Algebra.RingUtils: span :: (a -> Bool) -> [a] -> ([a], [a])
+ Algebra.RingUtils: span :: () => (a -> Bool) -> [a] -> ([a], [a])
- Algebra.RingUtils: tail :: [a] -> [a]
+ Algebra.RingUtils: tail :: () => [a] -> [a]
- Algebra.RingUtils: take :: Int -> [a] -> [a]
+ Algebra.RingUtils: take :: () => Int -> [a] -> [a]
- Algebra.RingUtils: takeWhile :: (a -> Bool) -> [a] -> [a]
+ Algebra.RingUtils: takeWhile :: () => (a -> Bool) -> [a] -> [a]
- Algebra.RingUtils: uncurry :: (a -> b -> c) -> (a, b) -> c
+ Algebra.RingUtils: uncurry :: () => (a -> b -> c) -> (a, b) -> c
- Algebra.RingUtils: undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a
+ Algebra.RingUtils: undefined :: HasCallStack => a
- Algebra.RingUtils: until :: (a -> Bool) -> (a -> a) -> a -> a
+ Algebra.RingUtils: until :: () => (a -> Bool) -> (a -> a) -> a -> a
- Algebra.RingUtils: unzip :: [(a, b)] -> ([a], [b])
+ Algebra.RingUtils: unzip :: () => [(a, b)] -> ([a], [b])
- Algebra.RingUtils: unzip3 :: [(a, b, c)] -> ([a], [b], [c])
+ Algebra.RingUtils: unzip3 :: () => [(a, b, c)] -> ([a], [b], [c])
- Algebra.RingUtils: zip :: [a] -> [b] -> [(a, b)]
+ Algebra.RingUtils: zip :: () => [a] -> [b] -> [(a, b)]
- Algebra.RingUtils: zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]
+ Algebra.RingUtils: zip3 :: () => [a] -> [b] -> [c] -> [(a, b, c)]
- Algebra.RingUtils: zipWith :: (a -> b -> c) -> [a] -> [b] -> [c]
+ Algebra.RingUtils: zipWith :: () => (a -> b -> c) -> [a] -> [b] -> [c]
- Algebra.RingUtils: zipWith3 :: (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
+ Algebra.RingUtils: zipWith3 :: () => (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
- Data.Matrix.Class: (***) :: (t -> a) -> (t -> b) -> (t, t) -> (a, b)
+ Data.Matrix.Class: (***) :: () => (t1 -> a) -> (t2 -> b) -> (t1, t2) -> (a, b)
- Data.Matrix.Class: ext :: Dimension -> (a, a) -> a
+ Data.Matrix.Class: ext :: () => Dimension -> (p, p) -> p
- Data.Matrix.Class: glueExt :: (AbelianGroup a, AbelianGroup b) => Dimension -> (a, b) -> (a, b) -> (a, b)
+ Data.Matrix.Class: glueExt :: (AbelianGroup a1, AbelianGroup a2) => Dimension -> (a1, a2) -> (a1, a2) -> (a1, a2)
- Data.Matrix.Class: splitExt :: Num b => Dimension -> b -> (b, b) -> ((b, b), (b, b))
+ Data.Matrix.Class: splitExt :: Num a => Dimension -> a -> (a, a) -> ((a, a), (a, a))
- Data.Matrix.Quad: (-+-) :: [a] -> [a] -> [a]
+ Data.Matrix.Quad: (-+-) :: () => [a] -> [a] -> [a]
- Data.Matrix.Quad: (|+|) :: [[a]] -> [[a]] -> [[a]]
+ Data.Matrix.Quad: (|+|) :: () => [[a]] -> [[a]] -> [[a]]
- Data.Matrix.Quad: first :: (t -> a) -> (t, b) -> (a, b)
+ Data.Matrix.Quad: first :: () => (t -> a) -> (t, b) -> (a, b)
- Data.Matrix.Quad: quad :: forall {x1 :: Shape} {y1 :: Shape} {a} {x2 :: Shape} {y2 :: Shape}. Mat x1 y1 a -> Mat x2 y1 a -> Mat x1 y2 a -> Mat x2 y2 a -> Mat ('Bin x1 x2) ('Bin y1 y2) a
+ Data.Matrix.Quad: 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
- Data.Matrix.Quad: quad' :: forall {f} {x1 :: Shape} {y1 :: Shape} {a} {x2 :: Shape} {y2 :: Shape}. Applicative f => f (Mat x1 y1 a) -> f (Mat x2 y1 a) -> f (Mat x1 y2 a) -> f (Mat x2 y2 a) -> f (Mat ('Bin x1 x2) ('Bin y1 y2) a)
+ Data.Matrix.Quad: quad' :: Applicative f => f (Mat x1 y1 a) -> f (Mat x2 y1 a) -> f (Mat x1 y2 a) -> f (Mat x2 y2 a) -> f (Mat (Bin x1 x2) (Bin y1 y2) a)
- Data.Matrix.Quad: row :: forall {x1 :: Shape} {a} {x2 :: Shape}. Mat x1 'Leaf a -> Mat x2 'Leaf a -> Mat ('Bin x1 x2) 'Leaf a
+ Data.Matrix.Quad: row :: () => Mat x1 Leaf a -> Mat x2 Leaf a -> Mat (Bin x1 x2) Leaf a
- Data.Matrix.Quad: second :: (t -> b) -> (a, t) -> (a, b)
+ Data.Matrix.Quad: second :: () => (t -> b) -> (a, t) -> (a, b)
- Data.Matrix.Quad: shiftX :: forall {s :: Shape} {b} {c}. Shape' s -> [(Int, b, c)] -> [(Int, b, c)]
+ Data.Matrix.Quad: shiftX :: () => Shape' s -> [(Int, b, c)] -> [(Int, b, c)]
- Data.Matrix.Quad: shiftY :: forall {s :: Shape} {a} {c}. Shape' s -> [(a, Int, c)] -> [(a, Int, c)]
+ Data.Matrix.Quad: shiftY :: () => Shape' s -> [(a, Int, c)] -> [(a, Int, c)]
- Parsing.TestProgram: pairs :: [a] -> [(a, a)]
+ Parsing.TestProgram: pairs :: () => [a] -> [(a, a)]
Files
- BNFC.cabal +70/−54
- Makefile +12/−11
- changelog +19/−3
- compat/Prelude'.hs +0/−15
- src/AbsBNF.hs +35/−37
- src/BNF.cf +36/−29
- src/BNFC/Backend/Agda.hs +274/−143
- src/BNFC/Backend/C.hs +47/−45
- src/BNFC/Backend/C/CFtoBisonC.hs +90/−66
- src/BNFC/Backend/C/CFtoCAbs.hs +88/−44
- src/BNFC/Backend/C/CFtoCPrinter.hs +140/−119
- src/BNFC/Backend/C/CFtoCSkel.hs +11/−9
- src/BNFC/Backend/C/CFtoFlexC.hs +115/−110
- src/BNFC/Backend/C/RegToFlex.hs +4/−3
- src/BNFC/Backend/CPP/Makefile.hs +4/−4
- src/BNFC/Backend/CPP/NoSTL.hs +34/−30
- src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs +33/−121
- src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs +6/−3
- src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs +0/−272
- src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs +119/−109
- src/BNFC/Backend/CPP/PrettyPrinter.hs +166/−158
- src/BNFC/Backend/CPP/STL.hs +75/−39
- src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs +109/−115
- src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs +64/−28
- src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs +1/−1
- src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs +7/−10
- src/BNFC/Backend/CSharp/CFtoGPLEX.hs +15/−10
- src/BNFC/Backend/CSharp/CFtoGPPG.hs +20/−21
- src/BNFC/Backend/CSharp/CSharpUtils.hs +4/−2
- src/BNFC/Backend/CSharp/RegToGPLEX.hs +4/−3
- src/BNFC/Backend/Common.hs +21/−3
- src/BNFC/Backend/Common/Makefile.hs +1/−1
- src/BNFC/Backend/Common/NamedVariables.hs +21/−13
- src/BNFC/Backend/Common/OOAbstract.hs +6/−6
- src/BNFC/Backend/Common/StrUtils.hs +4/−4
- src/BNFC/Backend/Haskell.hs +132/−106
- src/BNFC/Backend/Haskell/CFtoAbstract.hs +117/−52
- src/BNFC/Backend/Haskell/CFtoAlex.hs +3/−23
- src/BNFC/Backend/Haskell/CFtoAlex2.hs +32/−28
- src/BNFC/Backend/Haskell/CFtoAlex3.hs +136/−94
- src/BNFC/Backend/Haskell/CFtoHappy.hs +113/−140
- src/BNFC/Backend/Haskell/CFtoLayout.hs +9/−8
- src/BNFC/Backend/Haskell/CFtoPrinter.hs +166/−149
- src/BNFC/Backend/Haskell/CFtoTemplate.hs +31/−60
- src/BNFC/Backend/Haskell/MkErrM.hs +58/−27
- src/BNFC/Backend/Haskell/MkSharedString.hs +30/−5
- src/BNFC/Backend/Haskell/RegToAlex.hs +2/−2
- src/BNFC/Backend/Haskell/ToCNF.hs +10/−8
- src/BNFC/Backend/Haskell/Utils.hs +112/−29
- src/BNFC/Backend/HaskellGADT.hs +14/−13
- src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs +90/−62
- src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs +39/−30
- src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs +3/−20
- src/BNFC/Backend/HaskellProfile.hs +25/−21
- src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs +31/−46
- src/BNFC/Backend/Java.hs +44/−38
- src/BNFC/Backend/Java/CFtoAbstractVisitor.hs +23/−19
- src/BNFC/Backend/Java/CFtoAllVisitor.hs +10/−10
- src/BNFC/Backend/Java/CFtoAntlr4Lexer.hs +3/−3
- src/BNFC/Backend/Java/CFtoAntlr4Parser.hs +127/−79
- src/BNFC/Backend/Java/CFtoComposVisitor.hs +58/−50
- src/BNFC/Backend/Java/CFtoCup15.hs +24/−27
- src/BNFC/Backend/Java/CFtoFoldVisitor.hs +17/−21
- src/BNFC/Backend/Java/CFtoJLex15.hs +51/−33
- src/BNFC/Backend/Java/CFtoJavaAbs15.hs +32/−21
- src/BNFC/Backend/Java/CFtoJavaPrinter15.hs +40/−32
- src/BNFC/Backend/Java/CFtoVisitSkel15.hs +64/−46
- src/BNFC/Backend/Java/RegToAntlrLexer.hs +9/−5
- src/BNFC/Backend/Java/RegToJLex.hs +40/−61
- src/BNFC/Backend/Java/Utils.hs +73/−15
- src/BNFC/Backend/OCaml.hs +4/−2
- src/BNFC/Backend/OCaml/CFtoOCamlLex.hs +42/−47
- src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs +41/−36
- src/BNFC/Backend/OCaml/CFtoOCamlShow.hs +25/−26
- src/BNFC/Backend/OCaml/CFtoOCamlTest.hs +2/−2
- src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs +72/−67
- src/BNFC/Backend/OCaml/OCamlUtil.hs +43/−9
- src/BNFC/Backend/Pygments.hs +1/−2
- src/BNFC/Backend/XML.hs +17/−32
- src/BNFC/CF.hs +283/−131
- src/BNFC/GetCF.hs +394/−266
- src/BNFC/Lexing.hs +200/−51
- src/BNFC/MultiView.hs +8/−10
- src/BNFC/Options.hs +251/−92
- src/BNFC/Regex.hs +342/−0
- src/BNFC/ToCNFCore.hs +72/−38
- src/BNFC/TypeChecker.hs +175/−112
- src/BNFC/Utils.hs +95/−5
- src/BNFC/WarningM.hs +0/−26
- src/ErrM.hs +0/−47
- src/LexBNF.hs +8786/−0
- src/LexBNF.x +20/−11
- src/Main.hs +11/−1
- src/ParBNF.hs +3273/−0
- src/ParBNF.y +103/−79
- src/PrintBNF.hs +29/−20
- stack-7.10.3.yaml +1/−0
- stack-8.0.2.yaml +1/−0
- stack-8.10.2.yaml +35/−0
- stack-8.2.2.yaml +1/−0
- stack-8.4.4.yaml +1/−0
- stack-8.6.4.yaml +2/−0
- stack-8.6.5.yaml +1/−0
- stack-8.8.2.yaml +2/−0
- stack-8.8.3.yaml +2/−0
- stack-8.8.4.yaml +4/−0
- test/BNFC/Backend/BaseSpec.hs +2/−5
- test/BNFC/Backend/HaskellSpec.hs +0/−1
- test/BNFC/CFSpec.hs +3/−4
- test/BNFC/GetCFSpec.hs +4/−4
- test/BNFC/OptionsSpec.hs +33/−28
- test/BNFC/WarningMSpec.hs +0/−28
BNFC.cabal view
@@ -1,9 +1,9 @@ Name: BNFC-Version: 2.8.3.1+Version: 2.8.4 cabal-version: >= 1.10 build-type: Simple category: Development-Copyright: (c) Andreas Abel, Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Bjorn Bringert, Johan Broberg, Kyle Butt, Paul Callaghan, Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Pascal Hof, Patrik Jansson, Kristofer Johannisson, Antti-Juhani Kaijanaho, Andreas Lööw, Justin Meiners, Kent Mein, Ulf Norell, Gabrielle Paganelli, Michael Pellauer, Fabian Ruch, and Aarne Ranta 2002 - 2019. Free software under GNU General Public License (GPL).+Copyright: (c) Andreas Abel, Jonas Almström Duregård, Krasimir Angelov, Jean-Philippe Bernardy, Björn Bringert, Johan Broberg, Kyle Butt, Paul Callaghan, Grégoire Détrez, Markus Forsberg, Ola Frid, Peter Gammie, Thomas Hallgren, Pascal Hof, Simon Huber, Patrik Jansson, Kristofer Johannisson, Antti-Juhani Kaijanaho, Andreas Lööw, Justin Meiners, Kent Mein, Ulf Norell, Gabriele Paganelli, Michael Pellauer, Fabian Ruch, and Aarne Ranta 2002 - 2020. Free software under GNU General Public License (GPL). License: GPL-2 License-File: LICENSE Maintainer: bnfc-dev@googlegroups.com@@ -23,42 +23,59 @@ a pretty-printer as a Haskell, Agda, C, C++, C#, Java, or Ocaml module, an XML representation, a LaTeX file containing a readable specification of the language.-tested-with: GHC == 7.6.3- , GHC == 7.8.4- , GHC == 7.10.3- , GHC == 8.0.2- , GHC == 8.2.2- , GHC == 8.4.4- , GHC == 8.6.5- , GHC == 8.8.4- , GHC == 8.10.7- , GHC == 9.0.1- , GHC == 9.2.1-Extra-source-files: src/BNF.cf changelog Makefile +tested-with: GHC == 7.10.3+ GHC == 8.0.2+ GHC == 8.2.2+ GHC == 8.4.4+ GHC == 8.6.5+ GHC == 8.8.4+ GHC == 8.10.2++Extra-source-files:+ src/BNF.cf+ changelog+ Makefile+ stack-8.10.2.yaml+ stack-8.8.4.yaml+ stack-8.8.3.yaml+ stack-8.8.2.yaml+ stack-8.6.5.yaml+ stack-8.6.4.yaml+ stack-8.4.4.yaml+ stack-8.2.2.yaml+ stack-8.0.2.yaml+ stack-7.10.3.yaml+ Source-repository head- type: git- location: https://github.com/BNFC/bnfc.git- subdir: source+ type: git+ location: git://github.com/BNFC/bnfc.git+ subdir: source +Source-repository this+ type: git+ location: git://github.com/BNFC/bnfc.git+ subdir: source+ tag: v2.8.4+ Library hs-source-dirs: runtime, src- Build-Depends: base>=4.6 && <5, array- default-language:- Haskell98+ default-language: Haskell2010+ Build-Depends: base>=4.8 && <5, array exposed-modules:- Algebra.RingUtils- Data.Pair- Data.Matrix.Quad- Data.Matrix.Class- Parsing.Chart- Parsing.TestProgram+ Algebra.RingUtils+ Data.Pair+ Data.Matrix.Quad+ Data.Matrix.Class+ Parsing.Chart+ Parsing.TestProgram Executable bnfc+ default-language: Haskell2010 Build-Depends:- base>=4.6 && <5,+ base>=4.8 && <5, semigroups,- mtl,+ mtl >= 2.2.1, directory, array, process,@@ -69,14 +86,14 @@ time build-tools: alex, happy Main-is: Main.hs- HS-source-dirs: compat src- ghc-options: -W- default-language:- Haskell98+ HS-source-dirs: src default-extensions:+ CPP+ DoAndIfThenElse FlexibleContexts LambdaCase OverloadedStrings+ PatternGuards RecordWildCards ScopedTypeVariables TupleSections@@ -88,13 +105,12 @@ ParBNF AbsBNF PrintBNF- ErrM -- BNFC core- Prelude' BNFC.Utils BNFC.CF BNFC.ToCNFCore BNFC.MultiView+ BNFC.Regex BNFC.TypeChecker BNFC.GetCF BNFC.Lexing@@ -105,9 +121,8 @@ BNFC.Backend.Common.OOAbstract BNFC.Backend.Common.StrUtils BNFC.Options- BNFC.WarningM- Data.Pair BNFC.PrettyPrint+ Data.Pair -- Documentation backends BNFC.Backend.Latex@@ -166,7 +181,6 @@ BNFC.Backend.CPP.NoSTL.CFtoFlex BNFC.Backend.CPP.NoSTL.CFtoBison BNFC.Backend.CPP.NoSTL.CFtoCPPAbs- BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel -- C++ STL backend BNFC.Backend.CPP.STL@@ -214,11 +228,13 @@ -- --- Testing -------------------------------------------------------------- Test-suite unit-tests+ default-language: Haskell2010 Type: exitcode-stdio-1.0 Build-Depends:- base>=4 && <5,+ -- base-4.9 would be needed for Show1 needed for Show WriterT+ base>=4.8 && <5, semigroups,- mtl,+ mtl >= 2.2.1, directory, array, process,@@ -232,13 +248,15 @@ deepseq, time Main-is: unit-tests.hs- HS-source-dirs: compat src test- default-language:- Haskell98+ HS-source-dirs: src test+ ghc-options: -W default-extensions:+ CPP+ DoAndIfThenElse FlexibleContexts LambdaCase OverloadedStrings+ PatternGuards RecordWildCards ScopedTypeVariables TupleSections@@ -246,7 +264,6 @@ BNFC.CFSpec BNFC.GetCFSpec BNFC.OptionsSpec- BNFC.WarningMSpec BNFC.Hspec BNFC.Backend.BaseSpec BNFC.Backend.Common.MakefileSpec@@ -272,13 +289,13 @@ ParBNF AbsBNF PrintBNF- ErrM+ -- BNFC core- Prelude' BNFC.Utils BNFC.CF BNFC.ToCNFCore BNFC.MultiView+ BNFC.Regex BNFC.TypeChecker BNFC.GetCF BNFC.Lexing@@ -289,9 +306,8 @@ BNFC.Backend.Common.OOAbstract BNFC.Backend.Common.StrUtils BNFC.Options- BNFC.WarningM- Data.Pair BNFC.PrettyPrint+ Data.Pair -- Documentation backends BNFC.Backend.Latex@@ -350,7 +366,6 @@ BNFC.Backend.CPP.NoSTL.CFtoFlex BNFC.Backend.CPP.NoSTL.CFtoBison BNFC.Backend.CPP.NoSTL.CFtoCPPAbs- BNFC.Backend.CPP.NoSTL.CFtoCVisitSkel -- C++ STL backend BNFC.Backend.CPP.STL@@ -398,9 +413,10 @@ Test-suite bnfc-doctests- type: exitcode-stdio-1.0- ghc-options: -threaded- main-is: doctests.hs- build-depends: base, doctest >= 0.8- HS-source-dirs: test- default-language: Haskell98+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ default-extensions: CPP+ main-is: doctests.hs+ build-depends: base, doctest >= 0.8+ HS-source-dirs: test
Makefile view
@@ -4,16 +4,17 @@ # Cabal options (to be overwritten from the command line) CABAL_OPTS =-CABAL_BUILD_OPTS = --builddir=dist-ghc-$(GHC_VERSION)+CABAL_BUILDDIR_SUFFIX=+CABAL_BUILD_OPTS = --builddir=dist-ghc-$(GHC_VERSION)$(CABAL_BUILDDIR_SUFFIX) CABAL_CONFIGURE_OPTS = --enable-tests CABAL_INSTALL_OPTS = $(CABAL_CONFIGURE_OPTS) $(CABAL_BUILD_OPTS) CABAL_TEST_OPTS = $(CABAL_BUILD_OPTS) CABAL = cabal $(CABAL_OPTS)-CABAL_CONFIGURE = $(CABAL) configure $(CABAL_CONFIGURE_OPTS)-CABAL_BUILD = $(CABAL) build $(CABAL_BUILD_OPTS)-CABAL_INSTALL = $(CABAL) install $(CABAL_INSTALL_OPTS)-CABAL_TEST = $(CABAL) test $(CABAL_TEST_OPTS)+CABAL_CONFIGURE = $(CABAL) v1-configure $(CABAL_CONFIGURE_OPTS)+CABAL_BUILD = $(CABAL) v1-build $(CABAL_BUILD_OPTS)+CABAL_INSTALL = $(CABAL) v1-install $(CABAL_INSTALL_OPTS)+CABAL_TEST = $(CABAL) v1-test $(CABAL_TEST_OPTS) # Name for binary distribution (e.g. bnfc-2.4.5-linux32) BDIST_TAG=bnfc-${BNFC_VERSION}-$(shell uname -s)-$(shell uname -m)@@ -33,7 +34,7 @@ $(CABAL_TEST) doc:- $(CABAL) haddock --executables --internal+ $(CABAL) v1-haddock --executables --internal TAGS : hasktags --etags .@@ -42,11 +43,11 @@ bdist: dist/${BDIST_TAG}.tar.gz dist/%.tar.gz:- cabal clean- cabal install ${CABAL_OPTS} --only-dependencies- cabal configure ${CABAL_OPTS} --prefix=/- cabal build ${CABAL_OPTS}- cabal copy --destdir=dist/install+ cabal v1-clean+ cabal v1-install ${CABAL_OPTS} --only-dependencies+ cabal v1-configure ${CABAL_OPTS} --prefix=/+ cabal v1-build ${CABAL_OPTS}+ cabal v1-copy --destdir=dist/install mkdir dist/$* cp dist/install/bin/bnfc dist/$* cp LICENSE dist/$*
changelog view
@@ -1,6 +1,22 @@-2.8.3.1 Andreas Abel <andreas.abel@gu.se> November 2021- * GHC 9.2 compatibility (sanitized released source tarball)- * bump cabal-version from 1.8 to 1.10+2.8.4 Andreas Abel <andreas.abel@gu.se> October 2020+ * GHC versions 7.10 - 8.10 supported, dropped GHC 7.6 and 7.8+ * LBNF: whitespace list separators are now accepted; treated like "" [#70]+ * `define` pragma now implemented by all maintained backends [#266, #285]+ * BNFC performs more sanity checks on the grammar, reports errors with source locations [#186, #213, #214]+ * option `--check` to only perform sanity checks [#286]+ * Backends now more resilient against keyword and name clashes (e.g. via qualified imports) [#278, #289]+ * Haskell: new option --text-token to use Data.Text instead of String in the lexer [#167]+ * Haskell: allow block comment delimiters of any length [#169, #202]+ * Haskell: define Err monad as Either String [#273], migration guide at https://bnfc.readthedocs.io/en/v2.8.4/user_guide.html#haskell-backend+ * Haskell: IsString instances for Ident-like token types [#192]+ * C/C++/Java: support multiple block comment forms per grammar [#202]+ * C++(STL): parser now throws exception on parse error [#288]+ * C++: fixed quadratic behavior in C++-generated printer (regression in 2.8.2)+ * Java: escape JFlex special characters [#299]+ * Java/ANTLR: emit start rules to work around ANTLR issue #2689 [#272]+ * Ocaml: new flag --menhir to generate parser with menhir instead of ocamlyacc+ * Bug fixes: #163, #169, #196, #212, #235, #256, #264, #269, #274, #276, #277, #279, #282, #283, #290+ * Fact-checking and revising LBNF documentation at https://bnfc.readthedocs.io/en/v2.8.4/lbnf.html 2.8.3 Andreas Abel <andreas.abel@gu.se> August 2019 * GHC 8.8 compatibility
− compat/Prelude'.hs
@@ -1,15 +0,0 @@-{-# LANGUAGE CPP #-}---- See #227 for what's going on here.--module Prelude'-(- module P-)-where--#if __GLASGOW_HASKELL__ >= 803-import Prelude as P hiding ((<>))-#else-import Prelude as P-#endif
src/AbsBNF.hs view
@@ -1,94 +1,92 @@ -- Haskell data types for the abstract syntax. -- Generated by the BNF converter. -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}- module AbsBNF where -import Data.Data (Data, Typeable)-import GHC.Generics (Generic)+import Prelude (Char, Double, Int, Integer, String)+import qualified Prelude as C (Eq, Ord, Show, Read) -newtype Ident = Ident String- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+newtype Identifier = Identifier ((Int, Int), String)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data LGrammar = LGr [LDef]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) -data LDef = DefAll Def | DefSome [Ident] Def | LDefView [Ident]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+data LDef+ = DefAll Def | DefSome [Identifier] Def | LDefView [Identifier]+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Grammar = Grammar [Def]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Def = Rule Label Cat [Item] | Comment String | Comments String String | Internal Label Cat [Item]- | Token Ident Reg- | PosToken Ident Reg- | Entryp [Ident]+ | Token Identifier Reg+ | PosToken Identifier Reg+ | Entryp [Identifier] | Separator MinimumSize Cat String | Terminator MinimumSize Cat String | Delimiters Cat String String Separation MinimumSize- | Coercions Ident Integer- | Rules Ident [RHS]- | Function Ident [Arg] Exp+ | Coercions Identifier Integer+ | Rules Identifier [RHS]+ | Function Identifier [Arg] Exp | Layout [String] | LayoutStop [String] | LayoutTop- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Item = Terminal String | NTerminal Cat- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) -data Cat = ListCat Cat | IdCat Ident- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+data Cat = ListCat Cat | IdCat Identifier+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Label = LabNoP LabelId | LabP LabelId [ProfItem] | LabPF LabelId LabelId [ProfItem] | LabF LabelId LabelId- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) -data LabelId = Id Ident | Wild | ListE | ListCons | ListOne- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+data LabelId = Id Identifier | Wild | ListE | ListCons | ListOne+ deriving (C.Eq, C.Ord, C.Show, C.Read) data ProfItem = ProfIt [IntList] [Integer]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data IntList = Ints [Integer]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) -data Arg = Arg Ident- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+data Arg = Arg Identifier+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Separation = SepNone | SepTerm String | SepSepar String- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Exp = Cons Exp Exp- | App Ident [Exp]- | Var Ident+ | App Identifier [Exp]+ | Var Identifier | LitInt Integer | LitChar Char | LitString String | LitDouble Double | List [Exp]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data RHS = RHS [Item]- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data MinimumSize = MNonempty | MEmpty- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Reg- = RSeq Reg Reg- | RAlt Reg Reg+ = RAlt Reg Reg | RMinus Reg Reg+ | RSeq Reg Reg | RStar Reg | RPlus Reg | ROpt Reg@@ -101,5 +99,5 @@ | RUpper | RLower | RAny- deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)+ deriving (C.Eq, C.Ord, C.Show, C.Read)
src/BNF.cf view
@@ -22,8 +22,8 @@ LGr. LGrammar ::= [LDef] ; DefAll. LDef ::= Def ;-DefSome. LDef ::= [Ident] ":" Def ;-LDefView. LDef ::= "views" [Ident] ;+DefSome. LDef ::= [Identifier] ":" Def ;+LDefView. LDef ::= "views" [Identifier] ; -- separator LDef ";" ; []. [LDef] ::= ;@@ -32,7 +32,7 @@ -- extra semicolons allowed _. [LDef] ::= ";" [LDef] ; -separator nonempty Ident "," ;+separator nonempty Identifier "," ; -- A Grammar is a sequence of definitions @@ -56,7 +56,7 @@ -- Categories (non-terminals) ListCat . Cat ::= "[" Cat "]" ;-IdCat . Cat ::= Ident ;+IdCat . Cat ::= Identifier ; -- Labels with or without profiles LabNoP . Label ::= LabelId ;@@ -67,7 +67,7 @@ LabF . Label ::= LabelId LabelId ; -- functional labels-Id . LabelId ::= Ident ; -- AST constructor+Id . LabelId ::= Identifier ; -- AST constructor Wild . LabelId ::= "_" ; -- No AST constructor (embedding) ListE . LabelId ::= "[" "]" ; -- Empty list ListCons . LabelId ::= "(" ":" ")" ; -- Cons@@ -86,17 +86,17 @@ Comment . Def ::= "comment" String ; -- Line comment Comments . Def ::= "comment" String String ; -- Block comment Internal . Def ::= "internal" Label "." Cat "::=" [Item] ; -- No parsing, AST and printing only-Token. Def ::= "token" Ident Reg ; -- Lexer token-PosToken. Def ::= "position" "token" Ident Reg ; -- Lexer token with position info-Entryp. Def ::= "entrypoints" [Ident] ; -- Names of parsers+Token. Def ::= "token" Identifier Reg ; -- Lexer token+PosToken. Def ::= "position" "token" Identifier Reg ; -- Lexer token with position info+Entryp. Def ::= "entrypoints" [Identifier] ; -- Names of parsers Separator. Def ::= "separator" MinimumSize Cat String ; -- List Terminator. Def ::= "terminator" MinimumSize Cat String ; -- List Delimiters. Def ::= "delimiters" Cat String String Separation MinimumSize;-Coercions. Def ::= "coercions" Ident Integer ; -- Embeddings and parenthesized exprs.-Rules. Def ::= "rules" Ident "::=" [RHS] ; -- Automatically generated lables (e.g. enums)-Function. Def ::= "define" Ident [Arg] "=" Exp ;+Coercions. Def ::= "coercions" Identifier Integer ; -- Embeddings and parenthesized exprs.+Rules. Def ::= "rules" Identifier "::=" [RHS] ; -- Automatically generated lables (e.g. enums)+Function. Def ::= "define" Identifier [Arg] "=" Exp; -Arg. Arg ::= Ident ;+Arg. Arg ::= Identifier ; separator Arg "" ; -- Lists@@ -113,8 +113,8 @@ -- Expressions Cons. Exp ::= Exp1 ":" Exp ;-App. Exp1 ::= Ident [Exp2] ;-Var. Exp2 ::= Ident ;+App. Exp1 ::= Identifier [Exp2] ;+Var. Exp2 ::= Identifier ; LitInt. Exp2 ::= Integer ; LitChar. Exp2 ::= Char ; LitString. Exp2 ::= String ;@@ -134,27 +134,34 @@ MEmpty. MinimumSize ::= ; -- Regular expressions-RSeq. Reg2 ::= Reg2 Reg3 ; -- left-associative-RAlt. Reg1 ::= Reg1 "|" Reg2 ; -- left-associative-RMinus. Reg1 ::= Reg2 "-" Reg2 ; -- non-associative -RStar. Reg3 ::= Reg3 "*" ;-RPlus. Reg3 ::= Reg3 "+" ;-ROpt. Reg3 ::= Reg3 "?" ;+RAlt. Reg ::= Reg "|" Reg1 ; -- left-associative -REps. Reg3 ::= "eps" ;+RMinus. Reg1 ::= Reg1 "-" Reg2 ; -- left-associative -RChar. Reg3 ::= Char ; -- single character-RAlts. Reg3 ::= "[" String "]" ; -- list of alternative characters-RSeqs. Reg3 ::= "{" String "}" ; -- character sequence+RSeq. Reg2 ::= Reg2 Reg3 ; -- left-associative -RDigit. Reg3 ::= "digit" ;-RLetter. Reg3 ::= "letter" ;-RUpper. Reg3 ::= "upper" ;-RLower. Reg3 ::= "lower" ;-RAny. Reg3 ::= "char" ;+RStar. Reg3 ::= Reg3 "*" ;+RPlus. Reg3 ::= Reg3 "+" ;+ROpt. Reg3 ::= Reg3 "?" ; +REps. Reg3 ::= "eps" ; -- empty string, same as {""}++RChar. Reg3 ::= Char ; -- single character+RAlts. Reg3 ::= "[" String "]" ; -- list of alternative characters+RSeqs. Reg3 ::= "{" String "}" ; -- character sequence++RDigit. Reg3 ::= "digit" ;+RLetter. Reg3 ::= "letter" ;+RUpper. Reg3 ::= "upper" ;+RLower. Reg3 ::= "lower" ;+RAny. Reg3 ::= "char" ;+ coercions Reg 3;++-- LBNF identifiers++position token Identifier letter (letter | digit | '_')* ; -- Comments in BNF source comment "--" ;
src/BNFC/Backend/Agda.hs view
@@ -3,46 +3,67 @@ Example for abstract syntax generated in Haskell backend: @@- newtype Ident = Ident String deriving (Eq, Ord, Show, Read) + module CPP.Abs where++ import Prelude (Char, Double, Integer, String)+ import qualified Prelude as C (Eq, Ord, Show, Read)++ import qualified Data.Text++ newtype Ident = Ident Data.Text.Text+ deriving (C.Eq, C.Ord, C.Show, C.Read)+ data Def = DFun Type Ident [Arg] [Stm]- deriving (Eq, Ord, Show, Read)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Arg = ADecl Type Ident- deriving (Eq, Ord, Show, Read)+ deriving (C.Eq, C.Ord, C.Show, C.Read) data Stm = SExp Exp | SInit Type Ident Exp | SBlock [Stm] | SIfElse Exp Stm Stm- deriving (Eq, Ord, Show, Read)+ deriving (C.Eq, C.Ord, C.Show, C.Read) + data Exp+ data Type = Type_bool | Type_int | Type_double | Type_void- deriving (Eq, Ord, Show, Read)+ deriving (C.Eq, C.Ord, C.Show, C.Read) @@ This should be accompanied by the following Agda code: @@- module <mod> where+ module CPP.AST where + open import Agda.Builtin.Char using () renaming (Char to Char)+ open import Agda.Builtin.Float public using () renaming (Float to Double)+ open import Agda.Builtin.Int public using () renaming (Int to Integer)+ open import Agda.Builtin.List using () renaming (List to #List)+ open import Agda.Builtin.String using () renaming+ ( String to #String+ ; primStringFromList to #stringFromList+ )++ {-# FOREIGN GHC import Prelude (Char, Double, Integer, String) #-} {-# FOREIGN GHC import qualified Data.Text #-}- {-# FOREIGN GHC import CPP.Abs #-}+ {-# FOREIGN GHC import qualified CPP.Abs #-} {-# FOREIGN GHC import CPP.Print (printTree) #-} data Ident : Set where- ident : List Char → Ident+ ident : #String → Ident - {-# COMPILE GHC Ident = data Ident (Ident) #-}+ {-# COMPILE GHC Ident = data CPP.Abs.Ident (CPP.Abs.Ident) #-} data Def : Set where dFun : (t : Type) (x : Ident) (as : List Arg) (ss : List Stm) → Def - {-# COMPILE GHC Def = data Def (DFun) #-}+ {-# COMPILE GHC Def = data CPP.Abs.Def (CPP.Abs.DFun) #-} data Arg : Set where aDecl : (t : Type) (x : Ident) → Arg - {-# COMPILE GHC Arg = data Arg (ADecl) #-}+ {-# COMPILE GHC Arg = data CPP.Abs.Arg (CPP.Abs.ADecl) #-} data Stm : Set where sExp : (e : Exp) → Stm@@ -50,21 +71,21 @@ sBlock : (ss : List Stm) → Stm sIfElse : (e : Exp) (s s' : Stm) → Stm - {-# COMPILE GHC Stm = data Stm- ( SExp- | SInit- | SBlock- | SIfElse+ {-# COMPILE GHC Stm = data CPP.Abs.Stm+ ( CPP.Abs.SExp+ | CPP.Abs.SInit+ | CPP.Abs.SBlock+ | CPP.Abs.SIfElse ) #-} data Type : Set where typeBool typeInt typeDouble typeVoid : Type - {-# COMPILE GHC Type = data Type- ( Type_bool- | Type_int- | Type_double- | Type_void+ {-# COMPILE GHC Type = data CPP.Abs.Type+ ( CPP.Abs.Type_bool+ | CPP.Abs.Type_int+ | CPP.Abs.Type_double+ | CPP.Abs.Type_void ) #-} -- Binding the BNFC pretty printers.@@ -80,12 +101,12 @@ printDef : Def → String printProgram : Program → String - {-# COMPILE GHC printType = \ t -> Data.Text.pack (printTree (t :: Type)) #-}- {-# COMPILE GHC printExp = \ e -> Data.Text.pack (printTree (e :: Exp)) #-}- {-# COMPILE GHC printStm = \ s -> Data.Text.pack (printTree (s :: Stm)) #-}- {-# COMPILE GHC printArg = \ a -> Data.Text.pack (printTree (a :: Arg)) #-}- {-# COMPILE GHC printDef = \ d -> Data.Text.pack (printTree (d :: Def)) #-}- {-# COMPILE GHC printProgram = \ p -> Data.Text.pack (printTree (p :: Program)) #-}+ {-# COMPILE GHC printType = \ t -> Data.Text.pack (printTree (t :: CPP.Abs.Type)) #-}+ {-# COMPILE GHC printExp = \ e -> Data.Text.pack (printTree (e :: CPP.Abs.Exp)) #-}+ {-# COMPILE GHC printStm = \ s -> Data.Text.pack (printTree (s :: CPP.Abs.Stm)) #-}+ {-# COMPILE GHC printArg = \ a -> Data.Text.pack (printTree (a :: CPP.Abs.Arg)) #-}+ {-# COMPILE GHC printDef = \ d -> Data.Text.pack (printTree (d :: CPP.Abs.Def)) #-}+ {-# COMPILE GHC printProgram = \ p -> Data.Text.pack (printTree (p :: CPP.Abs.Program)) #-} @@ -} @@ -93,6 +114,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}@@ -100,27 +123,27 @@ module BNFC.Backend.Agda (makeAgda) where -import Prelude'+import Prelude hiding ((<>)) import Control.Monad.State hiding (when) import Data.Char import Data.Function (on)-import Data.Functor ((<$>)) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NEList import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe (mapMaybe, isJust, fromJust)+import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set+import Data.String (IsString) import BNFC.CF import BNFC.Backend.Base (Backend, mkfile) import BNFC.Backend.Haskell.HsOpts-import BNFC.Backend.Haskell.Utils (parserName)-import BNFC.Options (SharedOptions)+import BNFC.Backend.Haskell.Utils (parserName, catToType, mkDefName, typeToHaskell')+import BNFC.Options (SharedOptions, TokenText(..), tokenText) import BNFC.PrettyPrint-import BNFC.Utils (replace, when)+import BNFC.Utils (ModuleName, replace, when, table) type NEList = NEList.NonEmpty @@ -147,10 +170,10 @@ makeAgda time opts cf = do -- Generate AST bindings. mkfile (agdaASTFile opts) $- cf2AgdaAST time (agdaASTFileM opts) (absFileM opts) (printerFileM opts) cf+ cf2AgdaAST time (tokenText opts) (agdaASTFileM opts) (absFileM opts) (printerFileM opts) cf -- Generate parser bindings. mkfile (agdaParserFile opts) $- cf2AgdaParser time (agdaParserFileM opts) (agdaASTFileM opts) (absFileM opts) (errFileM opts) (happyFileM opts)+ cf2AgdaParser time (tokenText opts) (agdaParserFileM opts) (agdaASTFileM opts) (errFileM opts) (happyFileM opts) layoutMod parserCats -- Generate an I/O library for the test parser.@@ -180,21 +203,27 @@ -- cf2AgdaAST :: String -- ^ Current time.+ -> TokenText -> String -- ^ Module name. -> String -- ^ Haskell Abs module name. -> String -- ^ Haskell Print module name. -> CF -- ^ Grammar. -> Doc-cf2AgdaAST time mod amod pmod cf = vsep $+cf2AgdaAST time tokenText mod amod pmod cf = vsep $ [ preamble time "abstract syntax data types" , hsep [ "module", text mod, "where" ]- , imports YesImportNumeric False- , if usesString then hsep [ "String", equals, listT, charT ] else empty- , importPragmas [amod, unwords [ pmod, "(printTree)" ]]- , vsep $ map prToken tcats- , absyn NamedArg dats+ , imports YesImportNumeric False usesPos+ , when usesString $ hsep [ "String", equals, listT, charT ]+ , importPragmas tokenText usesPos+ [ unwords [ "qualified", amod ]+ , unwords [ pmod, "(printTree)" ]+ ]+ , when usesPos defineIntAndPair+ , vsep $ map (uncurry $ prToken amod tokenText) tcats+ , absyn amod NamedArg dats+ , definedRules cf -- , allTokenCats printToken tcats -- seem to be included in printerCats- , printers printerCats+ , printers amod printerCats , empty -- Make sure we terminate the file with a new line. ] where@@ -203,37 +232,62 @@ dats = cf2data cf -- getAbstractSyntax also includes list categories, which isn't what we need -- The user-defined token categories (including Ident).- tcats :: [TokenCat]- tcats = specialCats cf+ tcats :: [(TokenCat, Bool)]+ tcats = (if hasIdent cf then ((catIdent, False) :) else id)+ [ (wpThing name, b) | TokenReg name b _ <- cfgPragmas cf ] -- Bind printers for the following categories (involves lists and literals). printerCats :: [Cat]- printerCats = map fst (getAbstractSyntax cf) ++ map TokenCat (cfgLiterals cf)+ printerCats = concat+ [ map fst (getAbstractSyntax cf)+ , map TokenCat $ List.nub $ cfgLiterals cf ++ map fst tcats+ ] usesString = "String" `elem` cfgLiterals cf-+ usesPos = hasPositionTokens cf+ defineIntAndPair = vsep+ [ vcat $ concat+ [ [ "postulate" ]+ , map (nest 2 . text) $ table " "+ [ [ intT, ":", "Set" ]+ , [ intToNatT, ":", intT, arrow , natT ]+ , [ natToIntT, ":", natT, arrow , intT ]+ ]+ ]+ , vcat $ map (\ s -> hsep [ "{-#", "COMPILE", "GHC", text s, "#-}" ]) $+ table " = "+ [ [ intT, "type Prelude.Int" ]+ , [ intToNatT, "Prelude.toInteger" ]+ , [ natToIntT, "Prelude.fromInteger" ]+ ]+ , vcat+ [ "data #Pair (A B : Set) : Set where"+ , nest 2 $ "#pair : A → B → #Pair A B"+ ]+ , "{-# COMPILE GHC #Pair = data (,) ((,)) #-}"+ ] -- | Generate parser bindings for Agda. -- cf2AgdaParser :: String -- ^ Current time.+ -> TokenText -> String -- ^ Module name. -> String -- ^ Agda AST module name.- -> String -- ^ Haskell Abs module name. -> String -- ^ Haskell ErrM module name. -> String -- ^ Haskell Par module name. -> Maybe String -- ^ Does the grammar use layout? If yes, Haskell Layout module name. -> [Cat] -- ^ Bind parsers for these non-terminals. -> Doc-cf2AgdaParser time mod astmod amod emod pmod layoutMod cats = vsep $+cf2AgdaParser time tokenText mod astmod emod pmod layoutMod cats = vsep $ [ preamble time "parsers" , hsep [ "module", text mod, "where" ]- , imports NoImportNumeric (isJust layoutMod)+ , imports NoImportNumeric (isJust layoutMod) False , importCats astmod (List.nub cs)- , importPragmas $ [amod, emod, pmod] ++ maybe [] (\ m -> ["qualified " ++ m]) layoutMod+ , importPragmas tokenText False $ [ qual emod, pmod] ++ maybeToList (qual <$> layoutMod) , "-- Error monad of BNFC"- , prErrM+ , prErrM emod , "-- Happy parsers"- , parsers layoutMod cats+ , parsers tokenText layoutMod cats , empty -- Make sure we terminate the file with a new line. ] where@@ -246,16 +300,20 @@ TokenCat "Char" -> Nothing TokenCat s -> Just s ListCat c -> baseCat c- InternalCat{} -> Nothing+ qual m = "qualified " ++ m -- We prefix the Agda types with "#" to not conflict with user-provided nonterminals.-arrow, charT, intT, listT, stringT, stringFromListT :: Doc+arrow, charT, integerT, listT, intT, natT, intToNatT, natToIntT, stringT, stringFromListT :: IsString a => a arrow = "→" charT = "Char" -- This is the BNFC name for token type Char!-intT = "Integer" -- This is the BNFC name for token type Integer!+integerT = "Integer" -- This is the BNFC name for token type Integer! doubleT = "Double" -- This is the BNFC name for token type Double! boolT = "#Bool" listT = "#List"+intT = "#Int" -- Int is the type used by the Haskell backend for line and column positions.+natT = "#Nat"+intToNatT = "#intToNat"+natToIntT = "#natToInt" stringT = "#String" stringFromListT = "#stringFromList" @@ -277,21 +335,23 @@ imports :: ImportNumeric -- ^ Import also numeric types? -> Bool -- ^ If have layout, import booleans.+ -> Bool -- ^ If have position tokens, import natural numbers. -> Doc-imports numeric layout = vcat . map prettyImport . concat $+imports numeric layout pos = vcat . map prettyImport . concat $ [ when layout [ ("Agda.Builtin.Bool", [("Bool", boolT)]) ] , [ ("Agda.Builtin.Char", [("Char", charT)]) ] , when (numeric == YesImportNumeric) importNumeric- , [ ("Agda.Builtin.List", [("List", listT)])- , ("Agda.Builtin.String", [("String", stringT), ("primStringFromList", stringFromListT) ])- ]+ , [ ("Agda.Builtin.List", [("List", listT)]) ]+ , when pos+ [ ("Agda.Builtin.Nat", [("Nat" , natT )]) ]+ , [ ("Agda.Builtin.String", [("String", stringT), ("primStringFromList", stringFromListT) ]) ] ] where importNumeric :: [(String, [(String, Doc)])] importNumeric = [ ("Agda.Builtin.Float public", [("Float", doubleT)])- , ("Agda.Builtin.Int public", [("Int", intT)])+ , ("Agda.Builtin.Int public", [("Int", integerT)]) ] prettyImport :: (String, [(String, Doc)]) -> Doc prettyImport (m, ren) = prettyList 2 pre lparen rparen semi $@@ -311,28 +371,63 @@ -- | Import pragmas. ----- >>> importPragmas ["Foo.Abs", "Foo.Print (printTree)", "qualified Foo.Layout"]+-- >>> importPragmas ByteStringToken False ["qualified Foo.Abs", "Foo.Print (printTree)", "qualified Foo.Layout"]+-- {-# FOREIGN GHC import Prelude (Bool, Char, Double, Integer, String, (.)) #-}+-- {-# FOREIGN GHC import qualified Data.ByteString.Char8 as BS #-} -- {-# FOREIGN GHC import qualified Data.Text #-}--- {-# FOREIGN GHC import Foo.Abs #-}+-- {-# FOREIGN GHC import qualified Foo.Abs #-} -- {-# FOREIGN GHC import Foo.Print (printTree) #-} -- {-# FOREIGN GHC import qualified Foo.Layout #-} -- importPragmas- :: [String] -- ^ Haskell modules to import.+ :: TokenText+ -> Bool -- ^ Do we use position tokens?+ -> [String] -- ^ Haskell modules to import. -> Doc-importPragmas mods = vcat $ map imp $ [ "qualified Data.Text" ] ++ mods+importPragmas tokenText pos mods = vcat $ map imp $ base ++ mods where imp s = hsep [ "{-#", "FOREIGN", "GHC", "import", text s, "#-}" ]+ base = concat+ [ [ "Prelude (" ++ preludeImports ++ ")" ]+ , when pos+ [ "qualified Prelude" ]+ , case tokenText of+ TextToken -> []+ StringToken -> []+ ByteStringToken -> [ "qualified Data.ByteString.Char8 as BS" ]+ , [ "qualified Data.Text" ]+ ]+ preludeImports = List.intercalate ", " $ concat+ [ [ "Bool", "Char", "Double", "Integer", "String", "(.)" ]+ , when pos+ [ "error" ] -- used unqualified by the GHC backend for postulates+ ] -- * Bindings for the AST. -- | Pretty-print types for token types similar to @Ident@. -prToken :: String -> Doc-prToken t =- prettyData UnnamedArg t [(agdaLower t, [ListCat (Cat "Char")])]- $++$- pragmaData t [(t, [])]+prToken :: ModuleName -> TokenText -> String -> Bool -> Doc+prToken amod tokenText t pos = vsep+ [ if pos then vcat+ -- can't use prettyData as it excepts a Cat for the type+ [ hsep [ "data", text t, ":", "Set", "where" ]+ , nest 2 $ hsep+ [ text $ agdaLower t+ , ":"+ , "#Pair (#Pair #Int #Int)"+ , prettyCat typ+ , arrow, text t+ ]+ ]+ else prettyData UnnamedArg t [(agdaLower t, [ typ ])]+ , pragmaData amod t [(t, [])]+ ]+ where+ typ = case tokenText of+ TextToken -> Cat "#String"+ ByteStringToken -> Cat "#String"+ StringToken -> ListCat (Cat "Char") -- | Pretty-print abstract syntax definition in Agda syntax. --@@ -340,30 +435,30 @@ -- strongly-connected component analysis and topological -- sort by dependency order. ---absyn :: ConstructorStyle -> [Data] -> Doc-absyn _style [] = empty-absyn style ds = vsep . ("mutual" :) . concatMap (map (nest 2) . prData style) $ ds+absyn :: ModuleName -> ConstructorStyle -> [Data] -> Doc+absyn _amod _style [] = empty+absyn amod style ds = vsep . ("mutual" :) . concatMap (map (nest 2) . prData amod style) $ ds -- | Pretty-print Agda data types and pragmas for AST. ----- >>> vsep $ prData UnnamedArg (Cat "Nat", [ ("Zero", []), ("Suc", [Cat "Nat"]) ])+-- >>> vsep $ prData "Foo" UnnamedArg (Cat "Nat", [ ("Zero", []), ("Suc", [Cat "Nat"]) ]) -- data Nat : Set where -- zero : Nat--- suc : Nat → Nat+-- suc : Nat → Nat -- <BLANKLINE>--- {-# COMPILE GHC Nat = data Nat--- ( Zero--- | Suc+-- {-# COMPILE GHC Nat = data Foo.Nat+-- ( Foo.Zero+-- | Foo.Suc -- ) #-} ----- >>> vsep $ prData UnnamedArg (Cat "C", [ ("C1", []), ("C2", [Cat "C"]) ])+-- >>> vsep $ prData "Bar" UnnamedArg (Cat "C", [ ("C1", []), ("C2", [Cat "C"]) ]) -- data C : Set where -- c1 : C -- c2 : C → C -- <BLANKLINE>--- {-# COMPILE GHC C = data C--- ( C1--- | C2+-- {-# COMPILE GHC C = data Bar.C+-- ( Bar.C1+-- | Bar.C2 -- ) #-} -- -- We return a list of 'Doc' rather than a single 'Doc' since want@@ -373,31 +468,31 @@ -- This is a bit of a design problem of the pretty print library: -- there is no native concept of a blank line; @text ""@ is a bad hack. ---prData :: ConstructorStyle -> Data -> [Doc]-prData style (Cat d, cs) = prData' style d cs-prData _ (c , _ ) = error $ "prData: unexpected category " ++ show c+prData :: ModuleName -> ConstructorStyle -> Data -> [Doc]+prData amod style (Cat d, cs) = prData' amod style d cs+prData _ _ (c , _ ) = error $ "prData: unexpected category " ++ show c -- | Pretty-print Agda data types and pragmas. ----- >>> vsep $ prData' UnnamedArg "Err A" [ ("Ok", [Cat "A"]), ("Bad", [ListCat $ Cat "Char"]) ]+-- >>> vsep $ prData' "ErrM" UnnamedArg "Err A" [ ("Ok", [Cat "A"]), ("Bad", [ListCat $ Cat "Char"]) ] -- data Err A : Set where--- ok : A → Err A+-- ok : A → Err A -- bad : #List Char → Err A -- <BLANKLINE>--- {-# COMPILE GHC Err = data Err--- ( Ok--- | Bad+-- {-# COMPILE GHC Err = data ErrM.Err+-- ( ErrM.Ok+-- | ErrM.Bad -- ) #-} ---prData' :: ConstructorStyle -> String -> [(Fun, [Cat])] -> [Doc]-prData' style d cs = [ prettyData style d cs , pragmaData (head $ words d) cs ]+prData' :: ModuleName -> ConstructorStyle -> String -> [(Fun, [Cat])] -> [Doc]+prData' amod style d cs = [ prettyData style d cs , pragmaData amod (head $ words d) cs ] -- | Pretty-print Agda binding for the BNFC Err monad. -- -- Note: we use "Err" here since a category "Err" would also conflict -- with BNFC's error monad in the Haskell backend.-prErrM :: Doc-prErrM = vsep $ prData' UnnamedArg "Err A"+prErrM :: ModuleName -> Doc+prErrM emod = vsep $ prData' emod UnnamedArg "Err A" [ ("Ok" , [Cat "A"]) , ("Bad", [ListCat $ Cat "Char"]) ]@@ -407,7 +502,7 @@ -- >>> prettyData UnnamedArg "Nat" [ ("zero", []), ("suc", [Cat "Nat"]) ] -- data Nat : Set where -- zero : Nat--- suc : Nat → Nat+-- suc : Nat → Nat -- -- >>> prettyData UnnamedArg "C" [ ("C1", []), ("C2", [Cat "C"]) ] -- data C : Set where@@ -432,49 +527,49 @@ -- :} -- data Stm : Set where -- block : (ss : #List Stm) → Stm--- if : (e : Exp) (s₁ s₂ : Stm) → Stm+-- if : (e : Exp) (s₁ s₂ : Stm) → Stm -- prettyData :: ConstructorStyle -> String -> [(Fun, [Cat])] -> Doc-prettyData style d cs = vcat $- [ hsep [ "data", text d, colon, "Set", "where" ] ] ++- map (nest 2 . prettyConstructor style d) cs+prettyData style d cs = vcat $ concat+ [ [ hsep [ "data", text d, colon, "Set", "where" ] ]+ , mkTSTable $ map (prettyConstructor style d) cs+ ]+ where +mkTSTable :: [(Doc,Doc)] -> [Doc]+mkTSTable = map (nest 2 . text) . table " : " . map mkRow+ where+ mkRow (c,t) = [ render c, render t ]+ -- | Generate pragmas to bind Haskell AST to Agda. ----- >>> pragmaData "Empty" []--- {-# COMPILE GHC Empty = data Empty () #-}+-- >>> pragmaData "Foo" "Empty" []+-- {-# COMPILE GHC Empty = data Foo.Empty () #-} ----- >>> pragmaData "Nat" [ ("zero", []), ("suc", [Cat "Nat"]) ]--- {-# COMPILE GHC Nat = data Nat--- ( zero--- | suc+-- >>> pragmaData "Foo" "Nat" [ ("zero", []), ("suc", [Cat "Nat"]) ]+-- {-# COMPILE GHC Nat = data Foo.Nat+-- ( Foo.zero+-- | Foo.suc -- ) #-} ---pragmaData :: String -> [(Fun, [Cat])] -> Doc-pragmaData d cs = prettyList 2 pre lparen (rparen <+> "#-}") "|" $- map (prettyFun . fst) cs+pragmaData :: ModuleName -> String -> [(Fun, [Cat])] -> Doc+pragmaData amod d cs = prettyList 2 pre lparen (rparen <+> "#-}") "|" $+ map (prettyFun amod . fst) cs where- pre = hsep [ "{-#", "COMPILE", "GHC", text d, equals, "data", text d ]+ pre = hsep [ "{-#", "COMPILE", "GHC", text d, equals, "data", text $ concat [ amod, ".", d ] ] -- | Pretty-print since rule as Agda constructor declaration. -- -- >>> prettyConstructor UnnamedArg "D" ("c", [Cat "A", Cat "B", Cat "C"])--- c : A → B → C → D+-- (c,A → B → C → D) -- >>> prettyConstructor undefined "D" ("c1", [])--- c1 : D+-- (c1,D) -- >>> prettyConstructor NamedArg "Stm" ("SIf", map Cat ["Exp", "Stm", "Stm"])--- sIf : (e : Exp) (s₁ s₂ : Stm) → Stm+-- (sIf,(e : Exp) (s₁ s₂ : Stm) → Stm) ---prettyConstructor :: ConstructorStyle -> String -> (Fun,[Cat]) -> Doc-prettyConstructor _style d (c, []) = hsep $- [ prettyCon c- , colon- , text d- ]-prettyConstructor style d (c, as) = hsep $- [ prettyCon c- , colon- , prettyConstructorArgs style as+prettyConstructor :: ConstructorStyle -> String -> (Fun,[Cat]) -> (Doc,Doc)+prettyConstructor style d (c, as) = (prettyCon c,) $ if null as then text d else hsep $+ [ prettyConstructorArgs style as , arrow , text d ]@@ -496,7 +591,8 @@ ts = map prettyCat as ns = map (text . subscript) $ numberUniquely $ map nameSuggestion as tel = aggregateOn (render . snd) $ zip ns ts- subscript (m, s) = maybe s (\ i -> s ++ [chr (ord '₀' + i)]) m+ deltaSubscript = ord '₀' - ord '0' -- exploiting that '0' comes before '₀' in character table+ subscript (m, s) = maybe s (\ n -> s ++ map (chr . (deltaSubscript +) . ord) (show n)) m -- Aggregate consecutive arguments of the same type. aggregateOn :: Eq c => ((a,b) -> c) -> [(a,b)] -> [(NEList a,b)] aggregateOn f@@ -515,7 +611,6 @@ CoercCat d _ -> nameFor d Cat d -> nameFor d TokenCat{} -> "x"- InternalCat{} -> error "impossible: Backend.Agda.nameSuggestion: Cat cannot be InternalCat" -- | Suggest the name of a bound variable of the given base category. --@@ -558,6 +653,31 @@ incr :: Ord a => a -> Frequency a -> Frequency a incr = Map.alter $ maybe (Just 1) (Just . succ) +-- * Generate the defined constructors.++-- | Generate Haskell code for the @define@d constructors.+definedRules :: CF -> Doc+definedRules cf = vsep [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]+ where+ mkDef f xs e = vcat $ map text $ concat+ [ [ unwords [ mkDefName f, ":", typeToHaskell' "→" $ wpThing t ]+ | t <- maybeToList $ sigLookup f cf+ ]+ , [ unwords $ concat+ [ [ mkDefName f, "=", "λ" ]+ , map agdaLower xs+ , [ "→", show $ sanitize e ]+ ]+ ]+ ]+ sanitize = \case+ App x es -> App (agdaLower x) $ map sanitize es+ Var x -> Var $ agdaLower x+ e@LitInt{} -> e+ e@LitDouble{} -> e+ e@LitChar{} -> e+ e@LitString{} -> e+ -- * Generate bindings for the pretty printers -- | Generate Agda code to print tokens.@@ -577,47 +697,53 @@ -- | Generate Agda bindings to printers for AST. ----- >>> printers $ map Cat [ "Exp", "Stm" ]+-- >>> printers "Foo" $ map Cat [ "Exp", "Stm" ] -- -- Binding the pretty printers. -- <BLANKLINE> -- postulate -- printExp : Exp → #String -- printStm : Stm → #String -- <BLANKLINE>--- {-# COMPILE GHC printExp = \ e -> Data.Text.pack (printTree (e :: Exp)) #-}--- {-# COMPILE GHC printStm = \ s -> Data.Text.pack (printTree (s :: Stm)) #-}+-- {-# COMPILE GHC printExp = \ e -> Data.Text.pack (printTree (e :: Foo.Exp)) #-}+-- {-# COMPILE GHC printStm = \ s -> Data.Text.pack (printTree (s :: Foo.Stm)) #-} ---printers :: [Cat] -> Doc-printers [] = empty-printers cats =- "-- Binding the pretty printers."- $++$- vcat ("postulate" : map (nest 2 . prettyTySig) cats)- $++$- vcat (map pragmaBind cats)+printers :: ModuleName -> [Cat] -> Doc+printers _amod [] = empty+printers amod cats = vsep+ [ "-- Binding the pretty printers."+ , vcat $ "postulate" : mkTSTable (map (prettyTySig) cats)+ , vcat $ map pragmaBind cats+ ] where- prettyTySig c = hsep [ agdaPrinterName c, colon, prettyCat c, arrow, stringT ]+ prettyTySig c = (agdaPrinterName c, hsep [ prettyCat c, arrow, stringT ]) pragmaBind c = hsep [ "{-#", "COMPILE", "GHC", agdaPrinterName c, equals, "\\", y, "->" , "Data.Text.pack", parens ("printTree" <+> parens (y <+> "::" <+> t)), "#-}" ] where y = text $ nameSuggestion c- t = text $ show $ normCat c -- Removes CoercCat.+ t = catToType ((text amod <> text ".") <>) empty c -- Removes CoercCat. -- | Bind happy parsers. ----- >>> parsers Nothing [ListCat (CoercCat "Exp" 2)]+-- >>> parsers StringToken Nothing [ListCat (CoercCat "Exp" 2)] -- postulate -- parseListExp2 : #String → Err (#List Exp) -- <BLANKLINE> -- {-# COMPILE GHC parseListExp2 = pListExp2 . myLexer . Data.Text.unpack #-} --+-- >>> parsers TextToken Nothing [ListCat (CoercCat "Exp" 2)]+-- postulate+-- parseListExp2 : #String → Err (#List Exp)+-- <BLANKLINE>+-- {-# COMPILE GHC parseListExp2 = pListExp2 . myLexer #-}+-- parsers- :: Maybe String -- ^ Grammar uses layout? If yes, Haskell layout module name.+ :: TokenText+ -> Maybe String -- ^ Grammar uses layout? If yes, Haskell layout module name. -> [Cat] -- ^ Bind parsers for these non-terminals. -> Doc-parsers layoutMod cats =+parsers tokenText layoutMod cats = vcat ("postulate" : map (nest 2 . prettyTySig) cats) $++$ vcat (map pragmaBind cats)@@ -637,7 +763,13 @@ , when layout [ "\\", "tl", "->" ] , [ parserName c, "." ] , when layout [ hcat [ text lmod, ".", "resolveLayout" ], "tl", "." ]- , [ "myLexer", ".", "Data.Text.unpack", "#-}" ]+ , [ "myLexer" ]+ , case tokenText of+ -- Agda's String is Haskell's Data.Text+ TextToken -> []+ StringToken -> [ ".", "Data.Text.unpack" ]+ ByteStringToken -> [ ".", "BS.pack", ".", "Data.Text.unpack" ]+ , [ "#-}" ] ] layout :: Bool layout = isJust layoutMod@@ -657,8 +789,8 @@ allTokenCats f = vsep . map f -- | Pretty-print a rule name for Haskell.-prettyFun :: Fun -> Doc-prettyFun = text+prettyFun :: ModuleName -> Fun -> Doc+prettyFun amod c = text $ concat [ amod, ".", c ] -- | Pretty-print a rule name for Agda. prettyCon :: Fun -> Doc@@ -713,7 +845,6 @@ TokenCat s -> text s CoercCat s _ -> text s ListCat c -> listT <+> prettyCatParens c- InternalCat -> error "prettyCat: unexpected case InternalCat" -- | Pretty-print category in parentheses, if 'compositeCat'. prettyCatParens :: Cat -> Doc
src/BNFC/Backend/C.hs view
@@ -20,7 +20,8 @@ -} module BNFC.Backend.C (makeC) where -import Prelude'+import Prelude hiding ((<>))+import qualified Data.Map as Map import BNFC.Utils import BNFC.CF@@ -32,7 +33,7 @@ import BNFC.Backend.C.CFtoCSkel import BNFC.Backend.C.CFtoCPrinter import BNFC.PrettyPrint-import Data.Char+ import qualified BNFC.Backend.Common.Makefile as Makefile makeC :: SharedOptions -> CF -> MkFiles ()@@ -44,7 +45,7 @@ mkfile (name ++ ".l") flex let bison = cf2Bison (linenumbers opts) prefix cf env mkfile (name ++ ".y") bison- let header = mkHeaderFile (linenumbers opts) cf (allCats cf) (allEntryPoints cf) env+ let header = mkHeaderFile (linenumbers opts) cf (Map.elems env) mkfile "Parser.h" header let (skelH, skelC) = cf2CSkel cf mkfile "Skeleton.h" skelH@@ -66,8 +67,8 @@ makefile :: String -> String -> String -> Doc makefile name prefix basename = vcat- [ "CC = gcc"- , "CCFLAGS = -g -W -Wall"+ [ "CC = gcc -g"+ , "CCFLAGS = --ansi -W -Wall -Wno-unused-parameter -Wno-unused-function -Wno-unneeded-internal-declaration ${CC_OPTS}" , "" , "FLEX = flex" , "FLEX_OPTS = -P" <> text prefix@@ -94,7 +95,7 @@ ] , Makefile.mkRule testName ["${OBJS}", "Test.o"] [ "@echo \"Linking " ++ testName ++ "...\""- , "${CC} ${CCFLAGS} ${OBJS} Test.o -o " ++ testName ]+ , "${CC} ${OBJS} Test.o -o " ++ testName ] , Makefile.mkRule "Absyn.o" [ "Absyn.c", "Absyn.h"] [ "${CC} ${CCFLAGS} -c Absyn.c" ] , Makefile.mkRule "Lexer.c" [ name ++ ".l" ]@@ -196,43 +197,44 @@ dat :: String dat = identCat . normCat $ cat -mkHeaderFile :: RecordPositions -> 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;",- "",- -- https://www.gnu.org/software/bison/manual/html_node/Location-Type.html#Location-Type- "typedef struct YYLTYPE",- "{",- " int first_line;",- " int first_column;",- " int last_line;",- " int last_column;",- "} YYLTYPE;",- "#define _ERROR_ 258",- mkDefines (259::Int) env,- "extern YYLTYPE yylloc;",- "extern YYSTYPE yylval;",- concatMap mkFunc eps,- "",- "#endif"- ]- where- mkVar s | (normCat s == s) = " " ++ (identCat s) +++ (map toLower (identCat s)) ++ "_;\n"- mkVar _ = ""+mkHeaderFile :: RecordPositions -> CF -> [String] -> String+mkHeaderFile _ cf env = unlines $ concat+ [ [ "#ifndef PARSER_HEADER_FILE"+ , "#define PARSER_HEADER_FILE"+ , ""+ , "#include \"Absyn.h\""+ , ""+ , "typedef union"+ , "{"+ ]+ , map (" " ++) unionBuiltinTokens+ , concatMap mkPointer $ allParserCatsNorm cf+ , [ "} YYSTYPE;"+ , ""+ -- https://www.gnu.org/software/bison/manual/html_node/Location-Type.html#Location-Type+ , "typedef struct YYLTYPE"+ , "{"+ , " int first_line;"+ , " int first_column;"+ , " int last_line;"+ , " int last_column;"+ , "} YYLTYPE;"+ , ""+ , "#define _ERROR_ 258"+ , mkDefines (259::Int) env+ , ""+ , "extern YYLTYPE yylloc;"+ , "extern YYSTYPE yylval;"+ , ""+ ]+ , concatMap mkFunc $ allEntryPoints cf+ , [ ""+ , "#endif"+ ]+ ]+ where mkDefines n [] = mkString n- mkDefines n ((_,s):ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss)+ mkDefines n (s:ss) = ("#define " ++ s +++ (show n) ++ "\n") ++ (mkDefines (n+1) ss) mkString n = if isUsedCat cf (TokenCat catString) then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) else mkChar n@@ -249,7 +251,7 @@ then ("#define _IDENT_ " ++ show n ++ "\n") else "" -- Andreas, 2019-04-29, issue #210: generate parsers also for coercions- mkFunc c = concat- [ identCat (normCat c) ++ " p" ++ identCat c ++ "(FILE *inp);\n"- , identCat (normCat c) ++ " ps" ++ identCat c ++ "(const char *str);\n"+ mkFunc c =+ [ identCat (normCat c) ++ " p" ++ identCat c ++ "(FILE *inp);"+ , identCat (normCat c) ++ " ps" ++ identCat c ++ "(const char *str);" ]
src/BNFC/Backend/C/CFtoBisonC.hs view
@@ -38,12 +38,22 @@ ************************************************************** -} +{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-} -module BNFC.Backend.C.CFtoBisonC (cf2Bison, startSymbol) where+module BNFC.Backend.C.CFtoBisonC+ ( cf2Bison+ , mkPointer+ , resultName, typeName, varName+ , specialToks, startSymbol+ , unionBuiltinTokens+ )+ where import Data.Char (toLower) import Data.List (intercalate, nub) import Data.Maybe (fromMaybe)+import qualified Data.Map as Map import BNFC.CF import BNFC.Backend.Common.NamedVariables hiding (varName)@@ -59,11 +69,11 @@ type MetaVar = String --The environment comes from the CFtoFlex-cf2Bison :: RecordPositions -> String -> CF -> SymEnv -> String+cf2Bison :: RecordPositions -> String -> CF -> SymMap -> String cf2Bison rp name cf env = unlines [header name cf,- union (allCatsNorm cf),+ union (allParserCatsNorm cf), "%token _ERROR_", tokens user env, declarations cf,@@ -78,27 +88,30 @@ header :: String -> CF -> String header name cf = unlines- [ "/* This Bison file was machine-generated by BNFC */"- , "%locations"- , "%{"- , "#include <stdlib.h>"- , "#include <stdio.h>"- , "#include <string.h>"- , "#include \"Absyn.h\""- , "typedef struct " ++ name ++ "_buffer_state *YY_BUFFER_STATE;"- , "YY_BUFFER_STATE " ++ name ++ "_scan_string(const char *str);"- , "void " ++ name ++ "_delete_buffer(YY_BUFFER_STATE buf);"- , "extern int yyparse(void);"- , "extern int yylex(void);"- , "extern int " ++ name ++ "_init_lexer(FILE * inp);"- -- this must be deferred until yylloc is defined- , "extern void yyerror(const char *str);"- , ""- , unlines $ map parseResult $ nub $ map normCat eps- , unlines $ map (parseMethod name) eps- , concatMap reverseList $ filter isList $ allCatsNorm cf- , "%}"- ]+ [ "/* This Bison file was machine-generated by BNFC */"+ , "%locations"+ , "%{"+ , "#include <stdlib.h>"+ , "#include <stdio.h>"+ , "#include <string.h>"+ , "#include \"Absyn.h\""+ , ""+ , "#define YYMAXDEPTH 10000000" -- default maximum stack size is 10000, but right-recursion needs O(n) stack+ , ""+ , "typedef struct " ++ name ++ "_buffer_state *YY_BUFFER_STATE;"+ , "YY_BUFFER_STATE " ++ name ++ "_scan_string(const char *str);"+ , "void " ++ name ++ "_delete_buffer(YY_BUFFER_STATE buf);"+ , "extern int yyparse(void);"+ , "extern int yylex(void);"+ , "extern int " ++ name ++ "_init_lexer(FILE * inp);"+ -- this must be deferred until yylloc is defined+ , "extern void yyerror(const char *str);"+ , ""+ , concatMap reverseList $ filter isList $ allParserCatsNorm cf+ , unlines $ map parseResult $ nub $ map normCat eps+ , unlines $ map (parseMethod cf name) eps+ , "%}"+ ] where eps = allEntryPoints cf -- Andreas, 2019-04-29, #210: Generate also parsers for CoercCat.@@ -130,8 +143,8 @@ ] --This generates a parser method for each entry point.-parseMethod :: String -> Cat -> String-parseMethod name cat = unlines $+parseMethod :: CF -> String -> Cat -> String+parseMethod cf name cat = unlines $ [ dat ++ " p" ++ parser ++ "(FILE *inp)" , "{" , " " ++ name ++ "_init_lexer(inp);"@@ -165,7 +178,9 @@ where dat = identCat (normCat cat) parser = identCat cat- res = resultName dat+ res0 = resultName dat+ revRes = "reverse" ++ dat ++ "(" ++ res0 ++ ")"+ res = if cat `elem` cfgReversibleCats cf then revRes else res0 --This method generates list reversal functions for each list type. reverseList :: Cat -> String@@ -192,27 +207,34 @@ --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 _ = ""+union cats = unlines $ concat+ [ [ "%union"+ , "{"+ ]+ , map (" " ++) unionBuiltinTokens+ , concatMap mkPointer cats+ , [ "}"+ ]+ ]+--This is a little weird because people can make [Exp2] etc.+mkPointer :: Cat -> [String]+mkPointer c+ | identCat c /= show c --list. add it even if it refers to a coercion.+ || normCat c == c --normal cat+ = [ " " ++ identCat (normCat c) +++ varName (normCat c) ++ ";" ]+ | otherwise = [] +unionBuiltinTokens :: [String]+unionBuiltinTokens =+ [ "int _int;"+ , "char _char;"+ , "double _double;"+ , "char* _string;"+ ]+ --declares non-terminal types. declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (allCats cf)+declarations cf = concatMap (typeNT cf) (allParserCats cf) where --don't define internal rules typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName (normCat nt) ++ "> " ++ identCat nt ++ "\n" typeNT _ _ = ""@@ -221,12 +243,12 @@ -- token name "literal" -- "Syntax error messages passed to yyerror from the parser will reference the literal string instead of the token name." -- https://www.gnu.org/software/bison/manual/html_node/Token-Decl.html-tokens :: [UserDef] -> SymEnv -> String-tokens user = concatMap (declTok user)+tokens :: [UserDef] -> SymMap -> String+tokens user env = unlines $ map declTok $ Map.toList env where- declTok u (s,r) = if s `elem` u- then "%token<string_> " ++ r ++ " /* " ++ cStringEscape s ++ " */\n"- else "%token " ++ r ++ " /* " ++ cStringEscape s ++ " */\n"+ declTok (Keyword s, r) = tok "" s r+ declTok (Tokentype s, r) = tok (if s `elem` user then "<_string>" else "") s r+ tok t s r = "%token" ++ t ++ " " ++ r ++ " /* " ++ cStringEscape s ++ " */" -- | Escape characters inside a C string. cStringEscape :: String -> String@@ -237,27 +259,27 @@ | otherwise = [c] specialToks :: CF -> String-specialToks cf = concat [- ifC catString "%token<string_> _STRING_\n",- ifC catChar "%token<char_> _CHAR_\n",- ifC catInteger "%token<int_> _INTEGER_\n",- ifC catDouble "%token<double_> _DOUBLE_\n",- ifC catIdent "%token<string_> _IDENT_\n"+specialToks cf = unlines $ concat+ [ ifC catString "%token<_string> _STRING_"+ , ifC catChar "%token<_char> _CHAR_"+ , ifC catInteger "%token<_int> _INTEGER_"+ , ifC catDouble "%token<_double> _DOUBLE_"+ , ifC catIdent "%token<_string> _IDENT_" ]- where- ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""+ where+ ifC cat s = if isUsedCat cf (TokenCat cat) then [s] else [] startSymbol :: CF -> String startSymbol cf = "%start" +++ identCat (firstEntry cf) --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForBison :: RecordPositions -> CF -> SymEnv -> Rules+rulesForBison :: RecordPositions -> CF -> SymMap -> Rules rulesForBison rp cf env = map mkOne $ ruleGroups cf where mkOne (cat,rules) = constructRule rp cf env rules cat -- For every non-terminal, we construct a set of rules.-constructRule :: RecordPositions -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+constructRule :: RecordPositions -> CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) constructRule rp cf env rules nt = (nt,[(p, generateAction rp (identCat (normCat nt)) (funRule r) b m +++ result) | r0 <- rules, let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs@@ -283,28 +305,28 @@ -- "make_ListFoo($1, $2);" -- >>> generateAction NoRecordPositions "ListFoo" "(:)" True ["$1","$2"] -- "make_ListFoo($2, $1);"-generateAction :: RecordPositions -> String -> Fun -> Bool -> [MetaVar] -> Action+generateAction :: IsFun a => RecordPositions -> String -> a -> Bool -> [MetaVar] -> Action generateAction rp nt f b ms | isCoercion f = unwords ms ++ ";" ++ loc | isNilFun f = "0;" | isOneFun f = concat ["make_", nt, "(", intercalate ", " ms', ", 0);"] | isConsFun f = concat ["make_", nt, "(", intercalate ", " ms', ");"]- | otherwise = concat ["make_", f, "(", intercalate ", " ms', ");", loc]+ | otherwise = concat ["make_", funName f, "(", intercalate ", " ms', ");", loc] where ms' = if b then reverse ms else ms loc = if rp == RecordPositions then " $$->line_number = @$.first_line; $$->char_number = @$.first_column;" else "" -- Generate patterns and a set of metavariables indicating -- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns :: CF -> SymMap -> 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 (TokenCat s) -> fromMaybe (typeName s) $ lookup s env+ Left (TokenCat s) -> fromMaybe (typeName s) $ Map.lookup (Tokentype s) env Left c -> identCat c- Right s -> fromMaybe s $ lookup s env+ Right s -> fromMaybe s $ Map.lookup (Keyword s) env 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 ++ ")"@@ -332,7 +354,9 @@ -- >>> varName (Cat "Abc") -- "abc_" varName :: Cat -> String-varName = (++ "_") . map toLower . identCat . normCat+varName = \case+ TokenCat s -> "_" ++ map toLower s+ c -> (++ "_") . map toLower . identCat . normCat $ c typeName :: String -> String typeName "Ident" = "_IDENT_"
src/BNFC/Backend/C/CFtoCAbs.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-} {- BNF Converter: C Abstract syntax@@ -42,16 +44,16 @@ module BNFC.Backend.C.CFtoCAbs (cf2CAbs) where -import Prelude'+import Prelude hiding ((<>))+import Data.Char (toLower)+import Data.Function (on)+import Data.List (groupBy, intercalate, nub, sort) import BNFC.CF import BNFC.PrettyPrint-import BNFC.Utils((+++)) import BNFC.Options (RecordPositions(..))+import BNFC.Utils ((+++), uncurry3, unless) import BNFC.Backend.Common.NamedVariables-import Data.Function (on)-import Data.List-import Data.Char(toLower) -- | The result is two files (.H file, .C file)@@ -67,23 +69,31 @@ -- | Makes the Header file. mkHFile :: RecordPositions -> CF -> String-mkHFile rp cf = unlines- [ "#ifndef ABSYN_HEADER"+mkHFile rp cf = unlines $ concat+ [ [ "#ifndef ABSYN_HEADER" , "#define ABSYN_HEADER" , ""- , header+ , "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/"+ , "" , prTypeDefs user- , "/******************** Forward Declarations ********************/\n"- , concatMap prForward classes+ , "/******************** Forward Declarations ***********************/"+ ]+ , map prForward classes+ , [ "/******************** Abstract Syntax Classes ********************/" , ""- , "/******************** Abstract Syntax Classes ********************/\n"- , concatMap (prDataH rp) (getAbstractSyntax cf)+ ]+ , map (prDataH rp) $ getAbstractSyntax cf+ , unless (null definedConstructors)+ [ "/******************** Defined Constructors ***********************/" , ""+ ]+ , map (uncurry3 prDefH) definedConstructors+ , [ "" , "#endif" ]+ ] where- user = fst (unzip (tokenPragmas cf))- header = "/* C++ Abstract Syntax Interface generated by the BNF Converter.*/\n"+ user = map fst $ tokenPragmas cf rules :: [String] rules = getRules cf classes = nub (rules ++ getClasses (allCatsNorm cf))@@ -94,10 +104,35 @@ prForward _ = "" getRules cf = map testRule (cfgRules cf) getClasses = map show . filter isDataCat- testRule (Rule f c _)+ testRule (Rule f (WithPosition _ c) _ _) | isList c && isConsFun f = identCat (normCat c) | otherwise = "_"+ definedConstructors = [ (funName f, xs, e) | FunDef f xs e <- cfgPragmas cf ] +-- | For @define@d constructors, make a CPP definition.+--+-- >>> prDefH "iSg" ["i"] (App "ICons" [Var "i", App "INil" []])+-- "#define make_iSg(i) make_ICons(i,make_INil())"+--+-- >>> prDefH "snoc" ["xs","x"] (App "Cons" [Var "x", Var "xs"])+-- "#define make_snoc(xs,x) make_Cons(x,xs)"+--+prDefH+ :: String -- ^ Name of the defined constructors.+ -> [String] -- ^ Names of the arguments.+ -> Exp -- ^ Definition (referring to arguments and rule labels).+ -> String+prDefH f xs e = concat [ "#define make_", f, "(", intercalate "," xs, ") ", prExp e ]+ where+ prExp :: Exp -> String+ prExp = \case+ Var x -> x+ App g es -> concat [ "make_", g, "(", intercalate "," (map prExp es), ")" ]+ LitInt i -> show i+ LitDouble d -> show d+ LitChar c -> show c+ LitString s -> show s+ -- | Prints struct definitions for all categories. prDataH :: RecordPositions -> Data -> String prDataH rp (cat, rules)@@ -110,18 +145,20 @@ , "" , c' ++ " make_" ++ c' ++ "(" ++ mem ++ " p1, " ++ c' ++ " p2);" ]- | otherwise = unlines- [ "struct " ++ show cat ++ "_"+ | otherwise = unlines $ concat+ [ [ "struct " ++ show cat ++ "_" , "{"- , if rp == RecordPositions then " int line_number, char_number;" else ""- , " enum { " ++ intercalate ", " (map prKind rules) ++ " } kind;"+ ]+ , [ " int line_number, char_number;" | rp == RecordPositions ]+ , [ " enum { " ++ intercalate ", " (map prKind rules) ++ " } kind;" , " union" , " {" , concatMap prUnion rules ++ " } u;" , "};" , ""- , concatMap (prRuleH cat) rules ]+ , concatMap (prRuleH cat) rules+ ] where c' = identCat (normCat cat) mem = identCat (normCatOfList cat)@@ -131,30 +168,31 @@ -- | Interface definitions for rules vary on the type of rule.-prRuleH :: Cat -> (Fun, [Cat]) -> String-prRuleH 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"+prRuleH :: Cat -> (Fun, [Cat]) -> [String]+prRuleH c (fun, cats)+ | isNilFun fun || isOneFun fun || isConsFun fun = [] -- these are not represented in the AbSyn+ | otherwise = return $ concat+ [ catToStr c, " make_", fun, "(", prParamsH (getVars cats), ");" ] where- prParamsH :: Int -> [(String, a)] -> String- prParamsH _ [] = "void"- prParamsH n ((t,_):[]) = t ++ " p" ++ (show n)- prParamsH n ((t,_):vs) = (t ++ " p" ++ (show n) ++ ", ") ++ (prParamsH (n+1) vs)+ prParamsH :: [(String, a)] -> String+ prParamsH [] = "void"+ prParamsH ps = intercalate ", " $ zipWith par ps [0..]+ where par (t, _) n = t ++ " p" ++ show n -- typedefs in the Header make generation much nicer.-prTypeDefs user = unlines- [ "/******************** TypeDef Section ********************/"+prTypeDefs user = unlines $ concat+ [ [ "/******************** TypeDef Section ********************/"+ , "" , "typedef int Integer;" , "typedef char Char;" , "typedef double Double;" , "typedef char* String;" , "typedef char* Ident;"- , concatMap prUserDef user ]+ , map prUserDef user+ ] where- prUserDef s = "typedef char* " ++ s ++ ";\n"+ prUserDef s = "typedef char* " ++ s ++ ";" -- | A class's instance variables. Print the variables declaration by grouping -- together the variables of the same type.@@ -175,9 +213,9 @@ -- | Makes the .C file mkCFile :: CF -> String-mkCFile cf = unlines+mkCFile cf = concat [ header- , concatMap (render . prDataC) (getAbstractSyntax cf)+ , render $ vsep $ concatMap prDataC $ getAbstractSyntax cf ] where header = unlines@@ -189,19 +227,22 @@ , "" ] -prDataC :: Data -> Doc-prDataC (cat, rules) = vcat' $ map (prRuleC cat) rules+prDataC :: Data -> [Doc]+prDataC (cat, rules) = map (prRuleC cat) rules -- | Classes for rules vary based on the type of rule. -- -- * Empty list constructor, these are not represented in the AbSyn+-- -- >>> prRuleC (ListCat (Cat "A")) ("[]", [Cat "A", Cat "B", Cat "B"]) -- <BLANKLINE> -- -- * Linked list case. These are all built-in list functions. -- Later we could include things like lookup, insert, delete, etc.+-- -- >>> prRuleC (ListCat (Cat "A")) ("(:)", [Cat "A", Cat "B", Cat "B"]) -- /******************** ListA ********************/+-- <BLANKLINE> -- ListA make_ListA(A p1, ListA p2) -- { -- ListA tmp = (ListA) malloc(sizeof(*tmp));@@ -216,8 +257,10 @@ -- } -- -- * Standard rule+-- -- >>> prRuleC (Cat "A") ("funa", [Cat "A", Cat "B", Cat "B"]) -- /******************** funa ********************/+-- <BLANKLINE> -- A make_funa(A p1, B p2, B p3) -- { -- A tmp = (A) malloc(sizeof(*tmp));@@ -236,6 +279,7 @@ prRuleC _ (fun, _) | isNilFun fun || isOneFun fun = empty prRuleC cat (fun, _) | isConsFun fun = vcat' [ "/******************** " <> c <> " ********************/"+ , "" , c <+> "make_" <> c <> parens (text m <+> "p1" <> "," <+> c <+> "p2") , lbrace , nest 4 $ vcat'@@ -260,6 +304,7 @@ m' = map toLower m ++ "_" prRuleC c (fun, cats) = vcat' [ text $ "/******************** " ++ fun ++ " ********************/"+ , "" , prConstructorC c fun vs cats ] where vs = getVars cats@@ -318,11 +363,10 @@ where prAssign (t,n) p = text ("tmp->u." ++ c' ++ "_." ++ vname t n) <+> char '=' <+> p <> semi- vname t n | n == 1 =- case findIndices ((== t).fst) vars of- [_] -> varName t- _ -> varName t ++ showNum n- vname t n = varName t ++ showNum n+ vname t n+ | n == 1, [_] <- filter ((t ==) . fst) vars+ = varName t+ | otherwise = varName t ++ showNum n c' = map toLower c {- **** Helper Functions **** -}
src/BNFC/Backend/C/CFtoCPrinter.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- BNF Converter: C Pretty Printer printer@@ -43,24 +44,27 @@ module BNFC.Backend.C.CFtoCPrinter (cf2CPrinter) where -import Prelude'+import Prelude hiding ((<>)) +import Data.Bifunctor ( second )+import Data.Char ( toLower )+import Data.Either ( lefts )+import Data.List ( nub )+ import BNFC.CF-import BNFC.Utils ((+++))+import BNFC.PrettyPrint+import BNFC.Utils ((+++), unless) import BNFC.Backend.Common (renderListSepByPrecedence) import BNFC.Backend.Common.NamedVariables import BNFC.Backend.Common.StrUtils (renderCharOrString)-import Data.List-import Data.Char(toLower)-import Data.Either (lefts)-import BNFC.PrettyPrint -- | Produces (.h file, .c file). cf2CPrinter :: CF -> (String, String) cf2CPrinter cf = (mkHFile cf groups, mkCFile cf groups) where- groups = fixCoercions (ruleGroupsInternals cf)+ groups = fixCoercions $ filterOutDefs $ ruleGroupsInternals cf+ filterOutDefs = map $ second $ filter $ not . isDefinedRule . funRule {- **** Header (.h) File Methods **** -} @@ -170,10 +174,11 @@ [ "/*** BNFC-Generated Pretty Printer and Abstract Syntax Viewer ***/", "",- "#include \"Printer.h\"",+ "#include <ctype.h> /* isspace */", "#include <stdio.h>", "#include <string.h>", "#include <stdlib.h>",+ "#include \"Printer.h\"", "", "#define INDENT_WIDTH 2", "",@@ -187,27 +192,35 @@ [ "void ppInteger(Integer n, int i)", "{",- " char tmp[16];",+ -- https://stackoverflow.com/questions/10536207/ansi-c-maximum-number-of-characters-printing-a-decimal-int+ -- A buffer of 20 characters is sufficient to print the decimal representation+ -- of a 64bit integer. Might not be needed here, but does not hurt.+ " char tmp[20];", " sprintf(tmp, \"%d\", n);",- " bufAppendS(tmp);",+ " renderS(tmp);", "}", "void ppDouble(Double d, int i)", "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppendS(tmp);",+ -- https://stackoverflow.com/questions/1701055/what-is-the-maximum-length-in-chars-needed-to-represent-any-double-value+ -- Recommended buffer size is 24 for doubles (IEEE-754):+ -- (*) 17 digits for the decimal representation of the integral part+ -- (*) 5 digits for the exponent+ " char tmp[24];",+ " sprintf(tmp, \"%.15g\", d);",+ " renderS(tmp);", "}", "void ppChar(Char c, int i)", "{",- " bufAppendC('\\'');",- " bufAppendC(c);",- " bufAppendC('\\'');",+ " char tmp[4];",+ " sprintf(tmp, \"'%c'\", c);",+ " renderS(tmp);", "}", "void ppString(String s, int i)", "{", " bufAppendC('\\\"');", " bufAppendS(s);", " bufAppendC('\\\"');",+ " bufAppendC(' ');", "}", "void ppIdent(String s, int i)", "{",@@ -228,14 +241,14 @@ [ "void shInteger(Integer i)", "{",- " char tmp[16];",+ " char tmp[20];", " sprintf(tmp, \"%d\", i);", " bufAppendS(tmp);", "}", "void shDouble(Double d)", "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",+ " char tmp[24];",+ " sprintf(tmp, \"%.15g\", d);", " bufAppendS(tmp);", "}", "void shChar(Char c)",@@ -348,52 +361,53 @@ -- Generates methods for the Pretty Printer prPrintData :: (Cat, [Rule]) -> String-prPrintData (cat, rules) = unlines $- if isList cat- then- [- "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)",- "{",- " while(" ++ vname +++ "!= 0)",- " {",- " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)",- " {",- visitMember,- optsep,- " " ++ vname +++ "= 0;",- " }",- " else",- " {",- visitMember,- render (nest 6 (renderListSepByPrecedence "i" renderX- (getSeparatorByPrecedence rules))),- " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;",- " }",- " }",- "}",- ""- ] --Not a list:- else- [- "void pp" ++ cl ++ "(" ++ cl ++ " p, int _i_)",- "{",- " switch(p->kind)",- " {",- concatMap prPrintRule rules,- " default:",- " fprintf(stderr, \"Error: bad kind field when printing " ++ show cat ++ "!\\n\");",- " exit(1);",- " }",- "}\n"- ]+prPrintData (cat, rules)+ | isList cat = unlines $ concat+ [ [ "void pp" ++ cl ++ "("++ cl +++ vname ++ ", int i)"+ , "{"+ , " while(" ++ vname +++ "!= 0)"+ , " {"+ , " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)"+ , " {"+ , visitMember+ ]+ , unless (hasOneFunc rules)+ [ " " ++ render (renderX $ getCons rules) ++ ";" ]+ , [ " " ++ vname +++ "= 0;"+ , " }"+ , " else"+ , " {"+ , visitMember+ , render (nest 6 (renderListSepByPrecedence "i" renderX+ (getSeparatorByPrecedence rules)))+ , " " ++ vname +++ "=" +++ vname ++ "->" ++ vname ++ "_;"+ , " }"+ , " }"+ , "}"+ , ""+ ]+ ]+ | otherwise = unlines $ concat+ [ [ "void pp" ++ cl ++ "(" ++ cl ++ " p, int _i_)"+ , "{"+ , " switch(p->kind)"+ , " {"+ ]+ , concatMap prPrintRule rules+ , [ " default:"+ , " fprintf(stderr, \"Error: bad kind field when printing " ++ show cat ++ "!\\n\");"+ , " exit(1);"+ , " }"+ , "}"+ , ""+ ]+ ] where- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl- member = map toLower ecl+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl+ member = map toLower ecl visitMember = " pp" ++ ecl ++ "(" ++ vname ++ "->" ++ member ++ "_, i);"- sep' = getCons rules- optsep = if hasOneFunc rules then "" else " " ++ render (renderX sep') ++ ";" -- | Helper function that call the right c function (renderC or renderS) to -- render a literal string.@@ -411,33 +425,34 @@ -- | Pretty Printer methods for a rule. -prPrintRule :: Rule -> String-prPrintRule r@(Rule fun _ cats) | not (isCoercion fun) = unlines- [- " case is_" ++ fun ++ ":",- lparen,- cats',- rparen,- " break;\n"+prPrintRule :: Rule -> [String]+prPrintRule r@(Rule fun _ cats _) | not (isCoercion fun) = concat+ [ [ " case is_" ++ f ++ ":"+ , " if (_i_ > " ++ show p ++ ") renderC(_L_PAREN);"+ ]+ , map (prPrintCat f) $ numVars cats+ , [ " if (_i_ > " ++ show p ++ ") renderC(_R_PAREN);"+ , " break;"+ , ""+ ] ]- where+ where+ f = funName fun p = precRule r- (lparen, rparen) =- (" if (_i_ > " ++ show p ++ ") renderC(_L_PAREN);",- " if (_i_ > " ++ show p ++ ") renderC(_R_PAREN);")- cats' = concatMap (prPrintCat fun) (numVars cats)-prPrintRule _ = ""+prPrintRule _ = [] -- | This goes on to recurse to the instance variables. prPrintCat :: String -> Either (Cat, Doc) String -> String-prPrintCat fnm (c) = case c of- Right t -> " " ++ render (renderX t) ++ ";\n"- Left (cat, nt) | isTokenCat cat -> " pp" ++ basicFunName (render nt) ++ "(p->u." ++ v ++ "_." ++ render nt ++ ", " ++ show (precCat cat) ++ ");\n"- Left (InternalCat, _) -> " /* Internal Category */\n"- Left (cat, nt) -> " pp" ++ identCat (normCat cat) ++ "(p->u." ++ v ++ "_." ++ render nt ++ ", " ++ show (precCat cat) ++ ");\n"- where- v = map toLower (normFun fnm)+prPrintCat fnm = \case+ Right t -> " " ++ render (renderX t) ++ ";"+ Left (cat, nt) -> concat+ [ " pp"+ , maybe (identCat $ normCat cat) basicFunName $ maybeTokenCat cat+ , "(p->u."+ , map toLower fnm+ , "_.", render nt, ", ", show (precCat cat), ");"+ ] {- **** Abstract Syntax Tree Printer **** -} @@ -509,23 +524,24 @@ -- | Pretty Printer methods for a rule. prShowRule :: Rule -> String-prShowRule (Rule fun _ cats) | not (isCoercion fun) = unlines+prShowRule (Rule fun _ cats _) | not (isCoercion fun) = unlines [- " case is_" ++ fun ++ ":",+ " case is_" ++ f ++ ":", " " ++ lparen,- " bufAppendS(\"" ++ fun ++ "\");\n",+ " bufAppendS(\"" ++ f ++ "\");\n", " " ++ optspace, cats', " " ++ rparen, " break;" ] where+ f = funName fun (optspace, lparen, rparen) = if allTerms cats then ("","","") else (" bufAppendC(' ');\n", " bufAppendC('(');\n"," bufAppendC(')');\n") cats' = if allTerms cats then ""- else concat (insertSpaces (map (prShowCat fun) (lefts $ numVars cats)))+ else concat (insertSpaces (map (prShowCat f) (lefts $ numVars cats))) insertSpaces [] = [] insertSpaces (x:[]) = [x] insertSpaces (x:xs) = if x == ""@@ -536,29 +552,25 @@ allTerms (_:zs) = allTerms zs prShowRule _ = "" --- | This goes on to recurse to the instance variables.- prShowCat :: Fun -> (Cat, Doc) -> String-prShowCat fnm c = case c of- (cat,nt) | isTokenCat cat ->- " sh" ++ basicFunName (render nt) ++ "(p->u." ++ v ++ "_." ++ render nt ++ ");\n"- (InternalCat, _) -> " /* Internal Category */\n"- (cat,nt) ->- " sh" ++ identCat (normCat cat) ++ "(p->u." ++ v ++ "_." ++ render nt ++ ");\n"- where v = map toLower (normFun fnm)+prShowCat fnm (cat, nt) = concat+ [ " sh"+ , maybe (identCat $ normCat cat) basicFunName $ maybeTokenCat cat+ , "(p->u."+ , map toLower fnm+ , "_."+ , render nt+ , ");\n"+ ] {- **** Helper Functions Section **** -} -- | The visit-function name of a basic type. -basicFunName :: String -> String-basicFunName v- | "integer_" `isPrefixOf` v = "Integer"- | "char_" `isPrefixOf` v = "Char"- | "string_" `isPrefixOf` v = "String"- | "double_" `isPrefixOf` v = "Double"- | "ident_" `isPrefixOf` v = "Ident"- | otherwise = "Ident" --User-defined type+basicFunName :: TokenCat -> String+basicFunName k+ | k `elem` baseTokenCatNames = k+ | otherwise = "Ident" -- | An extremely simple @renderC@ for terminals. @@ -583,6 +595,7 @@ " {", " backup();", " bufAppendC(c);",+ " bufAppendC(' ');", " }", " else if (c == '}')", " {",@@ -608,37 +621,45 @@ " bufAppendC('\\n');", " indent();", " }",+ " else if (c == ' ') bufAppendC(c);", " else if (c == 0) return;", " else", " {",- " bufAppendC(' ');", " bufAppendC(c);", " bufAppendC(' ');", " }", "}",+ "",+ "int allIsSpace(String s)",+ "{",+ " char c;",+ " while ((c = *s++))",+ " if (! isspace(c)) return 0;",+ " return 1;",+ "}",+ "", "void renderS(String s)", "{",- " if(strlen(s) > 0)",+ " if (*s) /* s[0] != '\\0', string s not empty */", " {",- " bufAppendS(s);",- " bufAppendC(' ');",+ " if (allIsSpace(s)) {",+ " backup();",+ " bufAppendS(s);",+ " } else {",+ " bufAppendS(s);",+ " bufAppendC(' ');",+ " }", " }", "}", "void indent(void)", "{", " int n = _n_;",- " while (n > 0)",- " {",+ " while (--n >= 0)", " bufAppendC(' ');",- " n--;",- " }", "}", "void backup(void)", "{",- " if (buf_[cur_ - 1] == ' ')",- " {",- " buf_[cur_ - 1] = 0;",- " cur_--;",- " }",+ " if (cur_ && buf_[cur_ - 1] == ' ')",+ " buf_[--cur_] = 0;", "}" ]
src/BNFC/Backend/C/CFtoCSkel.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {- BNF Converter: C Skeleton generator@@ -41,7 +41,7 @@ module BNFC.Backend.C.CFtoCSkel (cf2CSkel) where -import Prelude'+import Prelude hiding ((<>)) import BNFC.CF import BNFC.Utils ( (+++) )@@ -55,7 +55,7 @@ cf2CSkel :: CF -> (String, String) cf2CSkel cf = (mkHFile cf groups, mkCFile cf groups) where- groups = fixCoercions (ruleGroups cf)+ groups = fixCoercions (ruleGroupsInternals cf) {- **** Header (.H) File Functions **** -}@@ -193,7 +193,7 @@ -- | Visits all the instance variables of a category. -- >>> let ab = Cat "ab"--- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab])+-- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab] Parsable) -- case is_abc: -- /* Code for abc Goes Here */ -- visitab(p->u.abc_.ab_1);@@ -201,13 +201,13 @@ -- break; -- <BLANKLINE> -- >>> let ab = TokenCat "ab"--- >>> prPrintRule (Rule "abc" undefined [Left ab])+-- >>> prPrintRule (Rule "abc" undefined [Left ab] Parsable) -- case is_abc: -- /* Code for abc Goes Here */ -- visitAb(p->u.abc_.ab_); -- break; -- <BLANKLINE>--- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab])+-- >>> prPrintRule (Rule "abc" undefined [Left ab, Left ab] Parsable) -- case is_abc: -- /* Code for abc Goes Here */ -- visitAb(p->u.abc_.ab_1);@@ -215,7 +215,9 @@ -- break; -- <BLANKLINE> prPrintRule :: Rule -> Doc-prPrintRule (Rule fun _c cats) | not (isCoercion fun) = nest 2 $ vcat+prPrintRule (Rule f _c cats _)+ | isCoercion f = ""+ | otherwise = nest 2 $ vcat [ text $ "case is_" ++ fun ++ ":" , nest 2 (vcat [ "/* Code for " <> text fun <> " Goes Here */"@@ -224,8 +226,8 @@ ]) ] where+ fun = funName f cats' = vcat $ map (prCat fun) (lefts (numVars cats))-prPrintRule (Rule _fun _ _) = "" -- Prints the actual instance-variable visiting. prCat :: Fun -> (Cat, Doc) -> Doc@@ -234,7 +236,7 @@ then basicFunName cat else text (identCat (normCat cat)) in visitf <> parens ("p->u." <> text v <> "_." <> vname ) <> ";"- where v = map toLower $ normFun fnm+ where v = map toLower fnm -- | The visit-function name of a basic type
src/BNFC/Backend/C/CFtoFlexC.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections #-} {- BNF Converter: C flex generator@@ -37,31 +38,33 @@ ************************************************************** -}-module BNFC.Backend.C.CFtoFlexC (cf2flex, lexComments, cMacros) where+module BNFC.Backend.C.CFtoFlexC (cf2flex, lexComments, cMacros, commentStates) where -import Prelude'+import Prelude hiding ((<>))+import Data.Bifunctor (first)+import Data.List (isInfixOf) import Data.Maybe (fromMaybe)+import qualified Data.Map as Map import BNFC.CF import BNFC.Backend.C.RegToFlex import BNFC.Backend.Common.NamedVariables import BNFC.PrettyPrint-import BNFC.Utils (cstring)+import BNFC.Utils (cstring, unless) ---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')+-- | Entrypoint.+cf2flex :: String -> CF -> (String, SymMap) -- The environment is reused by the parser.+cf2flex name cf = (, env) $ unlines+ [ prelude name+ , cMacros cf+ , lexSymbols env0+ , restOfFlex cf env+ ] where- env = makeSymEnv (cfgSymbols 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))+ env = Map.fromList env1+ env0 = makeSymEnv (cfgSymbols cf ++ reservedWords cf) [0 :: Int ..]+ env1 = map (first Keyword )env0 ++ makeSymEnv (map Tokentype $ tokenNames cf) [length env0 ..]+ makeSymEnv = zipWith $ \ s n -> (s, "_SYMB_" ++ show n) prelude :: String -> String prelude name = unlines@@ -82,7 +85,7 @@ "char YY_PARSED_STRING[YY_BUFFER_LENGTH];", "void YY_BUFFER_APPEND(char *s)", "{",- " strcat(YY_PARSED_STRING, s); //Do something better here!",+ " strcat(YY_PARSED_STRING, s); /* Do something better here! */", "}", "void YY_BUFFER_RESET(void)", "{",@@ -98,7 +101,8 @@ "{", " loc->first_line = loc->last_line;", " loc->first_column = loc->last_column;",- " for (int i = 0; text[i] != '\\0'; ++i) {",+ " int i = 0;", -- put this here as @for (int i...)@ is only allowed in C99+ " for (; text[i] != '\\0'; ++i) {", " if (text[i] == '\\n') {", " ++loc->last_line;", " loc->last_column = 0; ",@@ -114,19 +118,21 @@ -- 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",- "%%"+cMacros :: CF -> String+cMacros cf = unlines+ [ "LETTER [a-zA-Z]"+ , "CAPITAL [A-Z]"+ , "SMALL [a-z]"+ , "DIGIT [0-9]"+ , "IDENT [a-zA-Z0-9'_]"+ , unwords $ concat+ [ [ "%START YYINITIAL CHAR CHARESC CHAREND STRING ESCAPED" ]+ , take (numberOfBlockCommentForms cf) commentStates+ ]+ , "%%" ] -lexSymbols :: SymEnv -> String+lexSymbols :: KeywordEnv -> String lexSymbols ss = concatMap transSym ss where transSym (s,r) =@@ -134,61 +140,60 @@ where s' = escapeChars s -restOfFlex :: CF -> SymEnv -> String-restOfFlex cf env = concat- [- render $ lexComments Nothing (comments cf),- "\n\n",- userDefTokens,- ifC catString strStates,- ifC catChar chStates,- ifC catDouble "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval.double_ = atof(yytext); return _DOUBLE_;\n",- ifC catInteger "<YYINITIAL>{DIGIT}+ \t yylval.int_ = atoi(yytext); return _INTEGER_;\n",- ifC catIdent "<YYINITIAL>{LETTER}{IDENT}* \t yylval.string_ = strdup(yytext); return _IDENT_;\n",- "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",- "<YYINITIAL>. \t return _ERROR_;\n",- "%%\n",- footer+restOfFlex :: CF -> SymMap -> String+restOfFlex cf env = unlines $ concat+ [ [ render $ lexComments Nothing (comments cf)+ , ""+ ]+ , userDefTokens+ , ifC catString strStates+ , ifC catChar chStates+ , ifC catDouble [ "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t yylval._double = atof(yytext); return _DOUBLE_;" ]+ , ifC catInteger [ "<YYINITIAL>{DIGIT}+ \t yylval._int = atoi(yytext); return _INTEGER_;" ]+ , ifC catIdent [ "<YYINITIAL>{LETTER}{IDENT}* \t yylval._string = strdup(yytext); return _IDENT_;" ]+ , [ "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;"+ , "<YYINITIAL>. \t return _ERROR_;"+ , "%%"+ ]+ , footer ] where- ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""- userDefTokens = unlines $- ["<YYINITIAL>" ++ printRegFlex exp ++- " \t yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"- | (name, exp) <- tokenPragmas cf]- where- sName n = fromMaybe n $ lookup n env- strStates = unlines --These handle escaped characters in Strings.- [- "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",- "<STRING>\\\\ \t BEGIN ESCAPED;",- "<STRING>\\\" \t yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;",- "<STRING>. \t YY_BUFFER_APPEND(yytext);",- "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",- "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",- "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",- "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",- "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"+ ifC cat s = if isUsedCat cf (TokenCat cat) then s else []+ userDefTokens =+ [ "<YYINITIAL>" ++ printRegFlex exp +++ " \t yylval._string = strdup(yytext); return " ++ sName name ++ ";"+ | (name, exp) <- tokenPragmas cf ]- chStates = unlines --These handle escaped characters in Chars.- [- "<YYINITIAL>\"'\" \tBEGIN CHAR;",- "<CHAR>\\\\ \t BEGIN CHARESC;",- "<CHAR>[^'] \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",- "<CHARESC>n \t BEGIN CHAREND; yylval.char_ = '\\n'; return _CHAR_;",- "<CHARESC>t \t BEGIN CHAREND; yylval.char_ = '\\t'; return _CHAR_;",- "<CHARESC>. \t BEGIN CHAREND; yylval.char_ = yytext[0]; return _CHAR_;",- "<CHAREND>\"'\" \t BEGIN YYINITIAL;"+ where sName n = fromMaybe n $ Map.lookup (Tokentype n) env+ strStates = --These handle escaped characters in Strings.+ [ "<YYINITIAL>\"\\\"\" \t BEGIN STRING;"+ , "<STRING>\\\\ \t BEGIN ESCAPED;"+ , "<STRING>\\\" \t yylval._string = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return _STRING_;"+ , "<STRING>. \t YY_BUFFER_APPEND(yytext);"+ , "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;"+ , "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;"+ , "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;"+ , "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;"+ , "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;" ]- footer = unlines+ chStates = --These handle escaped characters in Chars.+ [ "<YYINITIAL>\"'\" \tBEGIN CHAR;"+ , "<CHAR>\\\\ \t BEGIN CHARESC;"+ , "<CHAR>[^'] \t BEGIN CHAREND; yylval._char = yytext[0]; return _CHAR_;"+ , "<CHARESC>n \t BEGIN CHAREND; yylval._char = '\\n'; return _CHAR_;"+ , "<CHARESC>t \t BEGIN CHAREND; yylval._char = '\\t'; return _CHAR_;"+ , "<CHARESC>. \t BEGIN CHAREND; yylval._char = yytext[0]; return _CHAR_;"+ , "<CHAREND>\"'\" \t BEGIN YYINITIAL;"+ ]+ footer = [ "void init_lexer(FILE *inp)", "{", " yyrestart(inp);",- " yylloc.first_line = 1;",+ " yylloc.first_line = 1;", " yylloc.first_column = 1;",- " yylloc.last_line = 1;",- " yylloc.last_column = 1;",+ " yylloc.last_line = 1;",+ " yylloc.last_column = 1;", " BEGIN YYINITIAL;", "}" ]@@ -205,31 +210,40 @@ -- delimiters. -- -- >>> lexComments (Just "myns.") ([("{-","-}")],["--"])--- <YYINITIAL>"--"[^\n]*\n /* skip */; // BNFC: comment "--";--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: comment "{-" "-}";+-- <YYINITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */+-- <YYINITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */ -- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] /* skip */; lexComments :: Maybe String -> ([(String, String)], [String]) -> Doc-lexComments _ (m,s) =- vcat (map lexSingleComment s ++ map lexMultiComment m)+lexComments _ (m,s) = vcat $ concat+ [ map lexSingleComment s+ , zipWith lexMultiComment m commentStates+ ] +-- | If we have several block comments, we need different COMMENT lexing states.+commentStates :: [String]+commentStates = map ("COMMENT" ++) $ "" : map show [1..]+ -- | Create a lexer rule for single-line comments. -- The first argument is -- an optional c++ namespace -- The second argument is the delimiter that marks the beginning of the -- comment. -- -- >>> lexSingleComment "--"--- <YYINITIAL>"--"[^\n]*\n /* skip */; // BNFC: comment "--";+-- <YYINITIAL>"--"[^\n]* /* skip */; /* BNFC: comment "--" */ -- -- >>> lexSingleComment "\""--- <YYINITIAL>"\""[^\n]*\n /* skip */; // BNFC: comment "\"";+-- <YYINITIAL>"\""[^\n]* /* skip */; /* BNFC: comment "\"" */ lexSingleComment :: String -> Doc lexSingleComment c =- "<YYINITIAL>" <> cstring c <> "[^\\n]*\\n"+ "<YYINITIAL>" <> cstring c <> "[^\\n]*" <+> "/* skip */;"- <+> "// BNFC: comment" <+> cstring c <> ";"+ <+> unless (containsCCommentMarker c) ("/* BNFC: comment" <+> cstring c <+> "*/") +containsCCommentMarker :: String -> Bool+containsCCommentMarker s = "/*" `isInfixOf` s || "*/" `isInfixOf` s+ -- | Create a lexer rule for multi-lines comments. -- The first argument is -- an optional c++ namespace -- The second arguments is the pair of delimiter for the multi-lines comment:@@ -238,39 +252,30 @@ -- comments. They could possibly start a comment with one character and end it -- with another. However this seems rare. ----- >>> lexMultiComment ("{-", "-}")--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: comment "{-" "-}";+-- >>> lexMultiComment ("{-", "-}") "COMMENT"+-- <YYINITIAL>"{-" BEGIN COMMENT; /* BNFC: block comment "{-" "-}" */ -- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] /* skip */; ----- >>> lexMultiComment ("\"'", "'\"")--- <YYINITIAL>"\"'" BEGIN COMMENT; // BNFC: comment "\"'" "'\"";+-- >>> lexMultiComment ("\"'", "'\"") "COMMENT"+-- <YYINITIAL>"\"'" BEGIN COMMENT; /* BNFC: block comment "\"'" "'\"" */ -- <COMMENT>"'\"" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] /* skip */;-lexMultiComment :: (String, String) -> Doc-lexMultiComment (b,e) = vcat- [ "<YYINITIAL>" <> cstring b <+> "BEGIN COMMENT;"- <+> "// BNFC: comment" <+> cstring b <+> cstring e <> ";"- , "<COMMENT>" <> cstring e <+> "BEGIN YYINITIAL;"- , "<COMMENT>. /* skip */;"- , "<COMMENT>[\\n] /* skip */;"+lexMultiComment :: (String, String) -> String -> Doc+lexMultiComment (b,e) comment = vcat+ [ "<YYINITIAL>" <> cstring b <+> "BEGIN" <+> text comment <> ";"+ <+> unless (containsCCommentMarker b || containsCCommentMarker e)+ ("/* BNFC: block comment" <+> cstring b <+> cstring e <+> "*/")+ , commentTag <> cstring e <+> "BEGIN YYINITIAL;"+ , commentTag <> ". /* skip */;"+ , commentTag <> "[\\n] /* skip */;" ]+ where+ commentTag = text $ "<" ++ comment ++ ">" --- --There might be a possible bug here if a language includes 2 multi-line comments.--- --They could possibly start a comment with one character and end it with another.--- --However this seems rare.--- ----- lexMultiComment :: Maybe String -> (String, String) -> String--- lexMultiComment inPackage (b,e) = unlines [--- "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",--- "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",--- "<COMMENT>. \t /* BNFC multi-line comment */;",--- "<COMMENT>[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;"--- ---- "\\n ++yy_mylinenumber ;"--- ]---Helper function that escapes characters in strings+-- | Helper function that escapes characters in strings. escapeChars :: String -> String escapeChars [] = [] escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))
src/BNFC/Backend/C/RegToFlex.hs view
@@ -4,6 +4,7 @@ import Data.Char (showLitChar) import AbsBNF+import BNFC.Backend.Common (flexEps) -- the top-level printing method printRegFlex :: Reg -> String@@ -43,8 +44,8 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of@@ -63,7 +64,7 @@ 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 (["[^.]"])+ REps -> prPrec i 3 [ flexEps ] 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))
src/BNFC/Backend/CPP/Makefile.hs view
@@ -5,8 +5,8 @@ makefile :: String -> String -> Doc makefile name basename = vcat- [ mkVar "CC" "g++"- , mkVar "CCFLAGS" "-g -W -Wall"+ [ mkVar "CC" "g++ -g"+ , mkVar "CCFLAGS" "--ansi -W -Wall -Wno-unused-parameter -Wno-unused-function -Wno-unneeded-internal-declaration" , "" , mkVar "FLEX" "flex" , mkVar "FLEX_OPTS" ("-P" ++ name)@@ -26,14 +26,14 @@ [ name ++ e | e <- [".aux", ".log", ".pdf",".dvi", ".ps", ""]] ] , mkRule "distclean" ["clean"] [ "rm -f " ++ unwords- [ "Absyn.C", "Absyn.H", "Test.C", "Parser.C", "Parser.H", "Lexer.C",+ [ "Absyn.C", "Absyn.H", "Test.C", "Parser.C", "Parser.H", "ParserError.H", "Lexer.C", "Skeleton.C", "Skeleton.H", "Printer.C", "Printer.H", basename, name ++ ".l", name ++ ".y", name ++ ".tex" ] ] , mkRule testName [ "${OBJS}", "Test.o" ] [ "@echo \"Linking " ++ testName ++ "...\""- , "${CC} ${CCFLAGS} ${OBJS} Test.o -o " ++ testName ]+ , "${CC} ${OBJS} Test.o -o " ++ testName ] , mkRule "Absyn.o" [ "Absyn.C", "Absyn.H" ] [ "${CC} ${CCFLAGS} -c Absyn.C" ] , mkRule "Lexer.C" [ name ++ ".l" ]
src/BNFC/Backend/CPP/NoSTL.hs view
@@ -21,16 +21,18 @@ import Data.Char import Data.List (nub)+import qualified Data.Map as Map import BNFC.Utils import BNFC.CF import BNFC.Options import BNFC.Backend.Base+import BNFC.Backend.C.CFtoBisonC (unionBuiltinTokens) import BNFC.Backend.CPP.Makefile 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.STL.CFtoCVisitSkelSTL import BNFC.Backend.CPP.PrettyPrinter import qualified BNFC.Backend.Common.Makefile as Makefile @@ -43,9 +45,9 @@ mkfile (name ++ ".l") flex let bison = cf2Bison name cf env mkfile (name ++ ".y") bison- let header = mkHeaderFile cf (allCats cf) (allEntryPoints cf) env+ let header = mkHeaderFile cf (allParserCats cf) (allEntryPoints cf) (Map.elems env) mkfile "Parser.H" header- let (skelH, skelC) = cf2CVisitSkel cf+ let (skelH, skelC) = cf2CVisitSkel False Nothing cf mkfile "Skeleton.H" skelH mkfile "Skeleton.C" skelC let (prinH, prinC) = cf2CPPPrinter False Nothing cf@@ -132,33 +134,35 @@ dat = identCat $ normCat cat def = identCat cat -mkHeaderFile cf cats eps env = unlines- [- "#ifndef PARSER_HEADER_FILE",- "#define PARSER_HEADER_FILE",- "",- concatMap mkForwardDec (nub $ map normCat 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 = "class " ++ identCat s ++ ";\n"- mkVar s | normCat s == s = " " ++ identCat s ++"*" +++ map toLower (identCat s) ++ "_;\n"- mkVar _ = ""+mkHeaderFile cf cats eps env = unlines $ concat+ [ [ "#ifndef PARSER_HEADER_FILE"+ , "#define PARSER_HEADER_FILE"+ , ""+ ]+ , map mkForwardDec $ nub $ map normCat cats+ , [ "typedef union"+ , "{"+ ]+ , map (" " ++) unionBuiltinTokens+ , concatMap mkVar cats+ , [ "} YYSTYPE;"+ , ""+ , "#define _ERROR_ 258"+ , mkDefines (259 :: Int) env+ , "extern YYSTYPE yylval;"+ , ""+ ]+ , map mkFunc eps+ , [ ""+ , "#endif"+ ]+ ]+ where+ mkForwardDec s = "class " ++ identCat s ++ ";"+ mkVar s | normCat s == s = [ " " ++ identCat s ++"*" +++ map toLower (identCat s) ++ "_;" ]+ mkVar _ = [] mkDefines n [] = mkString n- mkDefines n ((_,s):ss) = "#define " ++ s +++ show n ++ "\n" ++ mkDefines (n+1) ss+ mkDefines n (s:ss) = "#define " ++ s +++ show n ++ "\n" ++ mkDefines (n+1) ss mkString n = if isUsedCat cf (TokenCat catString) then ("#define _STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) else mkChar n@@ -174,4 +178,4 @@ mkIdent n = if isUsedCat cf (TokenCat catIdent) then "#define _IDENT_ " ++ show n ++ "\n" else ""- mkFunc s = identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);\n"+ mkFunc s = identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);"
src/BNFC/Backend/CPP/NoSTL/CFtoBison.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ {- BNF Converter: Bison generator Copyright (C) 2004 Author: Michael Pellauer@@ -17,25 +19,7 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, 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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA--}- {- ************************************************************** BNF Converter Module@@ -60,19 +44,18 @@ module BNFC.Backend.CPP.NoSTL.CFtoBison (cf2Bison) where -import Data.Char (toLower, isUpper)-import Data.List (intersperse, nub)-import Data.Maybe (fromMaybe)+import Data.Char ( toLower )+import Data.List ( intersperse, nub )+import Data.Maybe ( fromMaybe )+import qualified Data.Map as Map import BNFC.CF import BNFC.Backend.Common.NamedVariables hiding (varName)-import BNFC.Backend.C.CFtoBisonC (startSymbol)-import BNFC.Backend.CPP.STL.CFtoBisonSTL (union)+import BNFC.Backend.C.CFtoBisonC+ ( resultName, specialToks, startSymbol, typeName, varName )+import BNFC.Backend.CPP.STL.CFtoBisonSTL ( tokens, union, definedRules ) import BNFC.PrettyPrint-import BNFC.TypeChecker-import BNFC.Utils ((+++), when)--import ErrM+import BNFC.Utils ( (+++) ) --This follows the basic structure of CFtoHappy. @@ -83,11 +66,11 @@ type MetaVar = String --The environment comes from the CFtoFlex-cf2Bison :: String -> CF -> SymEnv -> String+cf2Bison :: String -> CF -> SymMap -> String cf2Bison name cf env = unlines [header name cf,- render $ union Nothing (allCats cf),+ render $ union Nothing (allParserCats cf), "%token _ERROR_", tokens user env, declarations cf,@@ -107,10 +90,13 @@ , "#include <stdio.h>" , "#include <string.h>" , "#include \"Absyn.H\""+ , ""+ , "#define YYMAXDEPTH 10000000" -- default maximum stack size is 10000, but right-recursion needs O(n) stack+ , "" , "int yyparse(void);" , "int yylex(void);" , "int yy_mylinenumber;" --- hack to get line number. AR 2006- , "int initialize_lexer(FILE * inp);"+ , "void initialize_lexer(FILE * inp);" , "int yywrap(void)" , "{" , " return 1;"@@ -123,62 +109,17 @@ , "}" , "" , definedRules cf+ , concatMap reverseList $ filter isList $ allParserCatsNorm cf , unlines $ map parseResult dats- , unlines $ map (parseMethod name) eps- , concatMap reverseList $ filter isList $ allCatsNorm cf+ , unlines $ map (parseMethod cf name) eps , "%}" ] where eps = allEntryPoints cf dats = nub $ map normCat eps -definedRules :: CF -> String-definedRules cf = unlines [ rule f xs e | FunDef f xs e <- cfgPragmas 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) ++ ")"-- -- | Generates declaration and initialization of the @YY_RESULT@ for a parser. -- -- Different parsers (for different precedences of the same category)@@ -193,10 +134,10 @@ --This generates a parser method for each entry point.-parseMethod :: String -> Cat -> String-parseMethod _ cat = unlines+parseMethod :: CF -> String -> Cat -> String+parseMethod cf _ cat = unlines [- cat' ++"* p" ++ par ++ "(FILE *inp)",+ dat ++"* p" ++ par ++ "(FILE *inp)", "{", " initialize_lexer(inp);", " if (yyparse())",@@ -205,13 +146,16 @@ " }", " else", " { /* Success */",- " return" +++ (resultName cat') ++ ";",+ " return" +++ res ++ ";", " }", "}" ] where- cat' = identCat (normCat cat)+ dat = identCat (normCat cat) par = identCat cat+ res0 = resultName dat+ revRes = "reverse" ++ dat ++ "(" ++ res0 ++ ")"+ res = if cat `elem` cfgReversibleCats cf then revRes else res0 --This method generates list reversal functions for each list type. reverseList :: Cat -> String@@ -237,35 +181,19 @@ --declares non-terminal types. declarations :: CF -> String-declarations cf = concatMap (typeNT cf) (allCats cf)+declarations cf = concatMap (typeNT cf) (allParserCats cf) where --don't define internal rules typeNT cf nt | rulesForCat cf nt /= [] = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n" typeNT _ _ = "" ---declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user = concatMap $ \ (s, r) ->- concat [ "%token", when (s `elem` user) "<string_>", " ", r, " // ", s, "\n" ]--specialToks :: CF -> String-specialToks cf = concat [- ifC catString "%token<string_> _STRING_\n",- ifC catChar "%token<char_> _CHAR_\n",- ifC catInteger "%token<int_> _INTEGER_\n",- ifC catDouble "%token<double_> _DOUBLE_\n",- ifC catIdent "%token<string_> _IDENT_\n"- ]- where- ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""- --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForBison :: String -> CF -> SymEnv -> Rules+rulesForBison :: String -> CF -> SymMap -> 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 -> SymMap -> [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@@ -273,7 +201,7 @@ else (False,r0), let (p,m) = generatePatterns cf env r]) where- ruleName r = case funRule r of+ ruleName r = case funName $ funRule r of "(:)" -> identCat (normCat nt) "(:[])" -> identCat (normCat nt) z -> z@@ -297,15 +225,15 @@ -- Generate patterns and a set of metavariables indicating -- where in the pattern the non-terminal-generatePatterns :: CF -> SymEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns :: CF -> SymMap -> 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 (TokenCat s) -> fromMaybe (typeName s) $ lookup s env+ Left (TokenCat s) -> fromMaybe (typeName s) $ Map.lookup (Tokentype s) env Left c -> identCat c- Right s -> fromMaybe s $ lookup s env+ Right s -> fromMaybe s $ Map.lookup (Keyword s) env 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 ++ ")")@@ -324,19 +252,3 @@ nt' = identCat nt pr [] = [] pr ((p,a):ls) = (unlines [(concat $ intersperse " " [" |", p, "{ $$ =", a , "}"])]) ++ pr ls----Some helper functions.-resultName :: String -> String-resultName s = "YY_RESULT_" ++ s ++ "_"----slightly stronger than the NamedVariable version.-varName :: Cat -> String-varName = (++ "_") . map toLower . identCat . normCat--typeName :: String -> String-typeName "Ident" = "_IDENT_"-typeName "String" = "_STRING_"-typeName "Char" = "_CHAR_"-typeName "Integer" = "_INTEGER_"-typeName "Double" = "_DOUBLE_"-typeName x = x
src/BNFC/Backend/CPP/NoSTL/CFtoCPPAbs.hs view
@@ -41,7 +41,7 @@ module BNFC.Backend.CPP.NoSTL.CFtoCPPAbs (cf2CPPAbs) where -import Prelude'+import Prelude hiding ((<>)) import BNFC.CF import BNFC.Utils((+++),(++++))@@ -80,9 +80,12 @@ "#endif" ] where- user = fst (unzip (tokenPragmas cf))+ user = fst (unzip (tokenPragmas cf)) -- includes position tokens+ -- user = [ name | TokenReg name False _ <- cfgPragmas cf ] -- position tokens are in allClasses already header = "/* ~~~ C++ Abstract Syntax Interface generated by the BNF Converter.\n ~~~ */"- classes = allClasses (cf2cabs cf)+ ca = cf2cabs cf+ classes = absclasses ca ++ conclasses ca ++ map fst (listtypes ca)+ -- classes = allClasses (cf2cabs cf) -- includes position tokens prForward s | isProperLabel s = "class " ++ s ++ ";\n" prForward _ = ""
− src/BNFC/Backend/CPP/NoSTL/CFtoCVisitSkel.hs
@@ -1,272 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--{-- 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, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, 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 Prelude'--import BNFC.CF-import BNFC.Utils ((+++))-import BNFC.Backend.Common.NamedVariables-import BNFC.Backend.CPP.Naming (mkVariable)-import Data.List-import Data.Char(toLower, toUpper)-import Data.Either (lefts)-import BNFC.PrettyPrint----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 isList cat- then concat [" void visit", cl, "(", cl, " *", vname, ");"]- else abstract ++ concatMap prRuleH rules- where- cl = identCat (normCat cat)- vname = mkVariable cl- abstract = case lookupRule (show cat) rules of- Just _ -> ""- Nothing -> " void visit" ++ cl ++ "(" ++ cl +++ "*" ++ vname ++ "); /* abstract class */\n"----Visit functions for a rule.-prRuleH :: Rule -> String-prRuleH (Rule fun _ _) | not (isCoercion fun) = concat- [" void visit", fun, "(", fun, " *", fnm, ");\n"]- where- fnm = mkVariable 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 isList 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 (render . prRule) rules)- where- cl = identCat (normCat cat)- vname = mkVariable cl- 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 _ -> ""- Nothing -> "void Skeleton::visit" ++ cl ++ "(" ++ cl +++ "*" ++ vname ++ ") {} //abstract class\n\n"---- | Visits all the instance variables of a category.--- >>> prRule (Rule "F" (Cat "S") [Right "X", Left (TokenCat "A"), Left (Cat "B")])--- void Skeleton::visitF(F *f)--- {--- /* Code For F Goes Here */--- <BLANKLINE>--- visitA(f->a_);--- f->b_->accept(this);--- }--- <BLANKLINE>-prRule :: Rule -> Doc-prRule (Rule fun _ cats) | not (isCoercion fun) = vcat- [ text ("void Skeleton::visit" ++ fun ++ "(" ++ fun +++ "*" ++ fnm ++ ")")- , codeblock 2- [ text ("/* Code For " ++ fun ++ " Goes Here */")- , ""- , cats'- ]- , ""- ]- where- cats' = vcat (map (prCat fnm) (lefts (numVars cats)))- fnm = mkVariable fun-prRule _ = ""---- | Prints the actual instance-variable visiting.--- >>> prCat "Myfun" (TokenCat "Integer", "integer_")--- visitInteger(Myfun->integer_);--- >>> prCat "Myfun" (ListCat (Cat "A"), "lista_")--- if (Myfun->lista_) {Myfun->lista_->accept(this);}--- >>> prCat "Myfun" (Cat "A", "a_")--- Myfun->a_->accept(this);-prCat :: String -> (Cat, Doc) -> Doc-prCat fnm (cat, nt)- | isTokenCat cat = "visit" <> text (funName (render nt)) <> parens (fname <> "->" <> nt) <> ";"- | isList cat = "if" <+> parens (fname <> "->" <> nt) <+> braces accept- | otherwise = accept- where accept = fname <> "->" <> nt <> "->accept(this);"- fname = text fnm----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 =- init v `elem` map (map toLower) user- || any (`isPrefixOf` v) [ "integer_" , "char_" , "string_" , "double_" , "ident_" ]----The visit-function name of a basic type-funName :: String -> String-funName v =- if "integer_" `isPrefixOf` v then "Integer"- else if "char_" `isPrefixOf` v then "Char"- else if "string_" `isPrefixOf` v then "String"- else if "double_" `isPrefixOf` v then "Double"- else if "ident_" `isPrefixOf` v then "Ident"- else toUpper (head v) : init (tail v) -- User-defined type
src/BNFC/Backend/CPP/NoSTL/CFtoFlex.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE TupleSections #-} {- BNF Converter: Flex generator@@ -39,11 +40,13 @@ -} module BNFC.Backend.CPP.NoSTL.CFtoFlex (cf2flex) where -import Prelude'+import Prelude hiding ((<>))+import Data.Bifunctor (first) import Data.Maybe (fromMaybe)+import qualified Data.Map as Map import BNFC.CF-import BNFC.Backend.C.CFtoFlexC (cMacros)+import BNFC.Backend.C.CFtoFlexC (cMacros, commentStates) import BNFC.Backend.C.RegToFlex import BNFC.Backend.Common.NamedVariables import BNFC.Backend.CPP.STL.STLUtils@@ -51,22 +54,21 @@ import BNFC.Utils (cstring) --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')+cf2flex :: Maybe String -> String -> CF -> (String, SymMap)+cf2flex inPackage _name cf = (, env) $ unlines+ [ prelude inPackage+ , cMacros cf+ , lexSymbols env0+ , restOfFlex inPackage cf env+ ] where- env = makeSymEnv (cfgSymbols 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))+ env = Map.fromList env1+ env0 = makeSymEnv (cfgSymbols cf ++ reservedWords cf) [0 :: Int ..]+ env1 = map (first Keyword) env0 ++ makeSymEnv (map Tokentype $ tokenNames cf) [length env0 ..]+ makeSymEnv = zipWith $ \ s n -> (s, "_SYMB_" ++ show n) -prelude :: Maybe String -> String -> String-prelude inPackage _ = unlines+prelude :: Maybe String -> String+prelude inPackage = unlines [ maybe "" (\ns -> "%option prefix=\"" ++ ns ++ "yy\"") inPackage, "/* This FLex file was machine-generated by the BNF converter */",@@ -76,14 +78,13 @@ "#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)",+ "static void YY_BUFFER_APPEND(const 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;",+ " memset(YY_PARSED_STRING, 0, YY_BUFFER_LENGTH);", "}", "", "%}"@@ -97,59 +98,57 @@ where s' = escapeChars s -restOfFlex :: Maybe String -> CF -> SymEnv -> String-restOfFlex inPackage cf env = concat- [- render $ lexComments inPackage (comments cf),- "\n\n",- userDefTokens,- ifC catString strStates,- ifC catChar chStates,- ifC catDouble ("<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval.double_ = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";\n"),- ifC catInteger ("<YYINITIAL>{DIGIT}+ \t " ++ ns ++ "yylval.int_ = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";\n"),- ifC catIdent ("<YYINITIAL>{LETTER}{IDENT}* \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";\n"),- "\\n ++" ++ ns ++ "yy_mylinenumber ;\n",- "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;\n",- "<YYINITIAL>. \t return " ++ nsDefine inPackage "_ERROR_" ++ ";\n",- "%%\n",- footer+restOfFlex :: Maybe String -> CF -> SymMap -> String+restOfFlex inPackage cf env = unlines $ concat+ [ [ render $ lexComments inPackage (comments cf)+ , ""+ ]+ , userDefTokens+ , ifC catString strStates+ , ifC catChar chStates+ , ifC catDouble [ "<YYINITIAL>{DIGIT}+\".\"{DIGIT}+(\"e\"(\\-)?{DIGIT}+)? \t " ++ ns ++ "yylval._double = atof(yytext); return " ++ nsDefine inPackage "_DOUBLE_" ++ ";" ]+ , ifC catInteger [ "<YYINITIAL>{DIGIT}+ \t " ++ ns ++ "yylval._int = atoi(yytext); return " ++ nsDefine inPackage "_INTEGER_" ++ ";" ]+ , ifC catIdent [ "<YYINITIAL>{LETTER}{IDENT}* \t " ++ ns ++ "yylval._string = strdup(yytext); return " ++ nsDefine inPackage "_IDENT_" ++ ";" ]+ , [ "\\n ++" ++ ns ++ "yy_mylinenumber ;"+ , "<YYINITIAL>[ \\t\\r\\n\\f] \t /* ignore white space. */;"+ , "<YYINITIAL>. \t return " ++ nsDefine inPackage "_ERROR_" ++ ";"+ , "%%"+ ]+ , footer ] where- ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""+ ifC cat s = if isUsedCat cf (TokenCat cat) then s else [] ns = nsString inPackage- userDefTokens = unlines $- ["<YYINITIAL>" ++ printRegFlex exp ++- " \t " ++ ns ++ "yylval.string_ = strdup(yytext); return " ++ sName name ++ ";"- | (name, exp) <- tokenPragmas cf]- where- sName n = fromMaybe n $ lookup n env- strStates = unlines --These handle escaped characters in Strings.- [- "<YYINITIAL>\"\\\"\" \t BEGIN STRING;",- "<STRING>\\\\ \t BEGIN ESCAPED;",- "<STRING>\\\" \t " ++ ns ++ "yylval.string_ = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";",- "<STRING>. \t YY_BUFFER_APPEND(yytext);",- "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;",- "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;",- "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;",- "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;",- "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"- ]- chStates = unlines --These handle escaped characters in Chars.- [- "<YYINITIAL>\"'\" \tBEGIN CHAR;",- "<CHAR>\\\\ \t BEGIN CHARESC;",- "<CHAR>[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHARESC>n \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHARESC>t \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHARESC>. \t BEGIN CHAREND; " ++ ns ++ "yylval.char_ = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";",- "<CHAREND>\"'\" \t BEGIN YYINITIAL;"- ]- footer = unlines- [- "void " ++ ns ++ "initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }",- "int yywrap(void) { return 1; }"- ]+ userDefTokens =+ [ "<YYINITIAL>" ++ printRegFlex exp +++ " \t " ++ ns ++ "yylval._string = strdup(yytext); return " ++ sName name ++ ";"+ | (name, exp) <- tokenPragmas cf+ ]+ where sName n = fromMaybe n $ Map.lookup (Tokentype n) env+ strStates = --These handle escaped characters in Strings.+ [ "<YYINITIAL>\"\\\"\" \t BEGIN STRING;"+ , "<STRING>\\\\ \t BEGIN ESCAPED;"+ , "<STRING>\\\" \t " ++ ns ++ "yylval._string = strdup(YY_PARSED_STRING); YY_BUFFER_RESET(); BEGIN YYINITIAL; return " ++ nsDefine inPackage "_STRING_" ++ ";"+ , "<STRING>. \t YY_BUFFER_APPEND(yytext);"+ , "<ESCAPED>n \t YY_BUFFER_APPEND(\"\\n\"); BEGIN STRING;"+ , "<ESCAPED>\\\" \t YY_BUFFER_APPEND(\"\\\"\"); BEGIN STRING ;"+ , "<ESCAPED>\\\\ \t YY_BUFFER_APPEND(\"\\\\\"); BEGIN STRING;"+ , "<ESCAPED>t \t YY_BUFFER_APPEND(\"\\t\"); BEGIN STRING;"+ , "<ESCAPED>. \t YY_BUFFER_APPEND(yytext); BEGIN STRING;"+ ]+ chStates = --These handle escaped characters in Chars.+ [ "<YYINITIAL>\"'\" \tBEGIN CHAR;"+ , "<CHAR>\\\\ \t BEGIN CHARESC;"+ , "<CHAR>[^'] \t BEGIN CHAREND; " ++ ns ++ "yylval._char = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";"+ , "<CHARESC>n \t BEGIN CHAREND; " ++ ns ++ "yylval._char = '\\n'; return " ++ nsDefine inPackage "_CHAR_" ++ ";"+ , "<CHARESC>t \t BEGIN CHAREND; " ++ ns ++ "yylval._char = '\\t'; return " ++ nsDefine inPackage "_CHAR_" ++ ";"+ , "<CHARESC>. \t BEGIN CHAREND; " ++ ns ++ "yylval._char = yytext[0]; return " ++ nsDefine inPackage "_CHAR_" ++ ";"+ , "<CHAREND>\"'\" \t BEGIN YYINITIAL;"+ ]+ footer =+ [ "void " ++ ns ++ "initialize_lexer(FILE *inp) { yyrestart(inp); BEGIN YYINITIAL; }"+ , "int yywrap(void) { return 1; }"+ ] -- ---------------------------------------------------------------------------@@ -164,14 +163,16 @@ -- delimiters. -- -- >>> lexComments (Just "myns.") ([("{-","-}")],["--"])--- <YYINITIAL>"--"[^\n]*\n ++myns.yy_mylinenumber; // BNFC: comment "--";--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: comment "{-" "-}";+-- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--";+-- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}"; -- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] ++myns.yy_mylinenumber; lexComments :: Maybe String -> ([(String, String)], [String]) -> Doc-lexComments ns (m,s) =- vcat (map (lexSingleComment ns) s ++ map (lexMultiComment ns) m)+lexComments ns (m,s) = vcat $ concat+ [ map (lexSingleComment ns) s+ , zipWith (lexMultiComment ns) m commentStates+ ] -- | Create a lexer rule for single-line comments. -- The first argument is -- an optional c++ namespace@@ -179,19 +180,38 @@ -- comment. -- -- >>> lexSingleComment (Just "mypackage.") "--"--- <YYINITIAL>"--"[^\n]*\n ++mypackage.yy_mylinenumber; // BNFC: comment "--";+-- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--"; -- -- >>> lexSingleComment Nothing "--"--- <YYINITIAL>"--"[^\n]*\n ++yy_mylinenumber; // BNFC: comment "--";+-- <YYINITIAL>"--"[^\n]* ; // BNFC: comment "--"; -- -- >>> lexSingleComment Nothing "\""--- <YYINITIAL>"\""[^\n]*\n ++yy_mylinenumber; // BNFC: comment "\"";+-- <YYINITIAL>"\""[^\n]* ; // BNFC: comment "\""; lexSingleComment :: Maybe String -> String -> Doc-lexSingleComment ns c =- "<YYINITIAL>" <> cstring c <> "[^\\n]*\\n"- <+> "++"<> text (fromMaybe "" ns)<>"yy_mylinenumber;"+lexSingleComment _ c =+ "<YYINITIAL>" <> cstring c <> "[^\\n]*"+ <+> ";" <+> "// BNFC: comment" <+> cstring c <> ";" +-- -- | Create a lexer rule for single-line comments.+-- -- The first argument is -- an optional c++ namespace+-- -- The second argument is the delimiter that marks the beginning of the+-- -- comment.+-- --+-- -- >>> lexSingleComment (Just "mypackage.") "--"+-- -- <YYINITIAL>"--"[^\n]*\n ++mypackage.yy_mylinenumber; // BNFC: comment "--";+-- --+-- -- >>> lexSingleComment Nothing "--"+-- -- <YYINITIAL>"--"[^\n]*\n ++yy_mylinenumber; // BNFC: comment "--";+-- --+-- -- >>> lexSingleComment Nothing "\""+-- -- <YYINITIAL>"\""[^\n]*\n ++yy_mylinenumber; // BNFC: comment "\"";+-- lexSingleComment :: Maybe String -> String -> Doc+-- lexSingleComment ns c =+-- "<YYINITIAL>" <> cstring c <> "[^\\n]*\\n"+-- <+> "++"<> text (fromMaybe "" ns)<>"yy_mylinenumber;"+-- <+> "// BNFC: comment" <+> cstring c <> ";"+ -- | Create a lexer rule for multi-lines comments. -- The first argument is -- an optional c++ namespace -- The second arguments is the pair of delimiter for the multi-lines comment:@@ -200,45 +220,35 @@ -- comments. They could possibly start a comment with one character and end it -- with another. However this seems rare. ----- >>> lexMultiComment Nothing ("{-", "-}")--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: comment "{-" "-}";+-- >>> lexMultiComment Nothing ("{-", "-}") "COMMENT"+-- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}"; -- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] ++yy_mylinenumber; ----- >>> lexMultiComment (Just "foo.") ("{-", "-}")--- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: comment "{-" "-}";+-- >>> lexMultiComment (Just "foo.") ("{-", "-}") "COMMENT"+-- <YYINITIAL>"{-" BEGIN COMMENT; // BNFC: block comment "{-" "-}"; -- <COMMENT>"-}" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] ++foo.yy_mylinenumber; ----- >>> lexMultiComment Nothing ("\"'", "'\"")--- <YYINITIAL>"\"'" BEGIN COMMENT; // BNFC: comment "\"'" "'\"";+-- >>> lexMultiComment Nothing ("\"'", "'\"") "COMMENT"+-- <YYINITIAL>"\"'" BEGIN COMMENT; // BNFC: block comment "\"'" "'\""; -- <COMMENT>"'\"" BEGIN YYINITIAL;--- <COMMENT>. /* skip */;+-- <COMMENT>. /* skip */; -- <COMMENT>[\n] ++yy_mylinenumber;-lexMultiComment :: Maybe String -> (String, String) -> Doc-lexMultiComment ns (b,e) = vcat- [ "<YYINITIAL>" <> cstring b <+> "BEGIN COMMENT;"- <+> "// BNFC: comment" <+> cstring b <+> cstring e <> ";"- , "<COMMENT>" <> cstring e <+> "BEGIN YYINITIAL;"- , "<COMMENT>. /* skip */;"- , "<COMMENT>[\\n] ++"<> text (fromMaybe "" ns) <>"yy_mylinenumber;"+lexMultiComment :: Maybe String -> (String, String) -> String -> Doc+lexMultiComment ns (b,e) comment = vcat+ [ "<YYINITIAL>" <> cstring b <+> "BEGIN" <+> text comment <> ";"+ <+> "// BNFC: block comment" <+> cstring b <+> cstring e <> ";"+ , commentTag <> cstring e <+> "BEGIN YYINITIAL;"+ , commentTag <> ". /* skip */;"+ , commentTag <> "[\\n] ++" <> text (fromMaybe "" ns) <> "yy_mylinenumber;" ]+ where+ commentTag = text $ "<" ++ comment ++ ">" --- --There might be a possible bug here if a language includes 2 multi-line comments.--- --They could possibly start a comment with one character and end it with another.--- --However this seems rare.--- ----- lexMultiComment :: Maybe String -> (String, String) -> String--- lexMultiComment inPackage (b,e) = unlines [--- "<YYINITIAL>\"" ++ b ++ "\" \t BEGIN COMMENT;",--- "<COMMENT>\"" ++ e ++ "\" \t BEGIN YYINITIAL;",--- "<COMMENT>. \t /* BNFC multi-line comment */;",--- "<COMMENT>[\\n] ++" ++ nsString inPackage ++ "yy_mylinenumber ; \t /* BNFC multi-line comment */;"--- ---- "\\n ++yy_mylinenumber ;"--- ]---Helper function that escapes characters in strings+-- | Helper function that escapes characters in strings. escapeChars :: String -> String escapeChars [] = [] escapeChars ('\\':xs) = '\\' : ('\\' : (escapeChars xs))
src/BNFC/Backend/CPP/PrettyPrinter.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- **************************************************************@@ -24,14 +25,15 @@ module BNFC.Backend.CPP.PrettyPrinter (cf2CPPPrinter, prRender) where -import Prelude'+import Prelude hiding ((<>)) +import Data.Char(toLower)+ import BNFC.CF-import BNFC.Utils ((+++))+import BNFC.Utils ((+++), when) import BNFC.Backend.Common import BNFC.Backend.Common.NamedVariables import BNFC.Backend.Common.StrUtils (renderCharOrString)-import Data.Char(toLower) import BNFC.Backend.CPP.STL.STLUtils import BNFC.PrettyPrint @@ -40,11 +42,12 @@ cf2CPPPrinter useStl inPackage cf = (mkHFile useStl inPackage cf groups, mkCFile useStl inPackage cf groups) where- groups = positionRules cf ++ fixCoercions (ruleGroupsInternals cf)+ groups = when useStl (positionRules cf) -- CPP/NoSTL treats position tokens as just tokens+ ++ fixCoercions (ruleGroupsInternals cf) positionRules :: CF -> [(Cat,[Rule])] positionRules cf =- [ (TokenCat cat, [Rule cat (TokenCat cat) $ map (Left . TokenCat) [catString, catInteger]])+ [ (TokenCat cat, [ Rule (noPosition cat) (noPosition $ TokenCat cat) (map (Left . TokenCat) [catString, catInteger]) Parsable ]) | cat <- filter (isPositionCat cf) $ map fst (tokenPragmas cf) ] @@ -53,16 +56,15 @@ --An extremely large function to make the Header File mkHFile :: Bool -> Maybe String -> CF -> [(Cat,[Rule])] -> String mkHFile useStl inPackage cf groups = unlines- [- printHeader,- concatMap prDataH groups,- classFooter,- showHeader,- concatMap prDataH groups,- classFooter,- footer- ]- where+ [ printHeader+ , content+ , classFooter+ , showHeader+ , content+ , classFooter+ , footer+ ]+ where printHeader = unlines [ "#ifndef " ++ hdef,@@ -97,6 +99,7 @@ " char *print(Visitable *v);" ] hdef = nsDefine inPackage "PRINTER_HEADER"+ content = concatMap prDataH groups classFooter = unlines $ [ " void visitInteger(Integer i);",@@ -112,30 +115,25 @@ "", " 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];",+ " int end = cur_ + strlen(s);",+ " if (end >= buf_size) {",+ " do buf_size *= 2; /* Double the buffer size */",+ " while (end >= buf_size);",+ " resizeBuffer();", " }",- " cur_ += len;",- " buf_[cur_] = 0;",+ " strcpy(&buf_[cur_], s);",+ " cur_ = end;", " }", "", " void inline bufAppend(const char c)", " {",- " if (cur_ >= buf_size)",+ " if (cur_ + 1 >= buf_size)", " {", " buf_size *= 2; /* Double the buffer size */", " resizeBuffer();", " }", " buf_[cur_] = c;",- " cur_++;",- " buf_[cur_] = 0;",+ " buf_[++cur_] = 0;", " }", "", if useStl then render (nest 2 bufAppendString) else "",@@ -175,7 +173,8 @@ "void inline bufAppend(String str)" $$ codeblock 2 [ "const char *s = str.c_str();"- , "bufAppend(s);"]+ , "bufAppend(s);"+ ] showHeader = unlines [ "",@@ -201,14 +200,14 @@ else abstract ++ concatMap prRuleH rules where cl = identCat (normCat cat)- abstract = case lookupRule (show cat) rules of+ abstract = case lookupRule (noPosition $ show cat) rules of Just _ -> "" Nothing -> " void visit" ++ cl ++ "(" ++ cl ++ " *p); /* abstract class */\n" --Prints all the methods to visit a rule.-prRuleH :: Rule -> String-prRuleH (Rule fun _ _) | isProperLabel fun = concat- [" void visit", fun, "(", fun, " *p);\n"]+prRuleH :: IsFun f => Rul f -> String+prRuleH (Rule fun _ _ _) | isProperLabel fun = concat+ [" void visit", funName fun, "(", funName fun, " *p);\n"] prRuleH _ = "" {- **** Implementation (.C) File Methods **** -}@@ -286,23 +285,23 @@ [ "void PrintAbsyn::visitInteger(Integer i)", "{",- " char tmp[16];",+ " char tmp[20];", " sprintf(tmp, \"%d\", i);",- " bufAppend(tmp);",+ " render(tmp);", "}", "", "void PrintAbsyn::visitDouble(Double d)", "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",- " bufAppend(tmp);",+ " char tmp[24];",+ " sprintf(tmp, \"%.15g\", d);",+ " render(tmp);", "}", "", "void PrintAbsyn::visitChar(Char c)", "{",- " bufAppend('\\'');",- " bufAppend(c);",- " bufAppend('\\'');",+ " char tmp[4];",+ " sprintf(tmp, \"'%c'\", c);",+ " render(tmp);", "}", "", "void PrintAbsyn::visitString(String s)",@@ -310,6 +309,7 @@ " bufAppend('\\\"');", " bufAppend(s);", " bufAppend('\\\"');",+ " bufAppend(' ');", "}", "", "void PrintAbsyn::visitIdent(String s)",@@ -333,14 +333,14 @@ [ "void ShowAbsyn::visitInteger(Integer i)", "{",- " char tmp[16];",+ " char tmp[20];", " sprintf(tmp, \"%d\", i);", " bufAppend(tmp);", "}", "void ShowAbsyn::visitDouble(Double d)", "{",- " char tmp[16];",- " sprintf(tmp, \"%g\", d);",+ " char tmp[24];",+ " sprintf(tmp, \"%.15g\", d);", " bufAppend(tmp);", "}", "void ShowAbsyn::visitChar(Char c)",@@ -388,7 +388,7 @@ -- Not a list : prPrintData _ _inPackage cf (TokenCat cat, _rules) | isPositionCat cf cat = unlines $ -- a position token- [ "void PrintAbsyn::visit" ++ show cat ++ "(" ++ show cat ++ " *p)"+ [ "void PrintAbsyn::visit" ++ cat ++ "(" ++ cat ++ " *p)" , "{" , " visitIdent(p->string_);" , "}"@@ -398,14 +398,14 @@ abstract ++ concatMap (prPrintRule inPackage) rules where cl = identCat (normCat cat)- abstract = case lookupRule (show cat) rules of+ abstract = case lookupRule (noPosition $ show cat) rules of Just _ -> "" Nothing -> "void PrintAbsyn::visit" ++ cl ++ "(" ++ cl +++ "*p) {} //abstract class\n\n" -- | Generate pretty printer visitor for a list category: -- -- >>> let c = Cat "C" ; lc = ListCat c--- >>> let rules = [Rule "[]" lc [], Rule "(:)" lc [Left c, Right "-", Left lc]]+-- >>> let rules = [npRule "[]" lc [] Parsable, npRule "(:)" lc [Left c, Right "-", Left lc] Parsable] -- >>> genPrintVisitorList (lc, rules) -- void PrintAbsyn::visitListC(ListC *listc) -- {@@ -417,7 +417,7 @@ -- } -- -- >>> let c2 = CoercCat "C" 2 ; lc2 = ListCat c2--- >>> let rules2 = rules ++ [Rule "[]" lc2 [], Rule "(:)" lc2 [Left c2, Right "+", Left lc2]]+-- >>> let rules2 = rules ++ [npRule "[]" lc2 [] Parsable, npRule "(:)" lc2 [Left c2, Right "+", Left lc2] Parsable] -- >>> genPrintVisitorList (lc, rules2) -- void PrintAbsyn::visitListC(ListC *listc) -- {@@ -433,7 +433,7 @@ -- } genPrintVisitorList :: (Cat, [Rule]) -> Doc genPrintVisitorList (cat@(ListCat c), rules) =- "void PrintAbsyn::visit" <> text cl <> "("<> text cl <> " *" <> vname <> ")"+ "void PrintAbsyn::visit" <> text cl <> "(" <> text cl <> " *" <> vname <> ")" $$ codeblock 2 [ "for ("<> text cl <> "::const_iterator i = " <> vname <> "->begin() ; i != " <> vname <> "->end() ; ++i)" , codeblock 2@@ -446,26 +446,28 @@ <+> renderListSepByPrecedence "_i_" renderSep separators ] ]- where- separators = getSeparatorByPrecedence rules- cl = identCat (normCat cat)- vname = text $ map toLower cl+ where+ separators = getSeparatorByPrecedence rules+ cl = identCat (normCat cat)+ vname = text $ map toLower cl renderSep s = "render(" <> text (snd (renderCharOrString s)) <> ")"+ genPrintVisitorList _ = error "genPrintVisitorList expects a ListCat" -- | This is the only part of the pretty printer that differs significantly -- between the versions with and without STL. genPrintVisitorListNoStl :: (Cat, [Rule]) -> String-genPrintVisitorListNoStl (cat@(ListCat c), rules) = unlines- [ "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")"+genPrintVisitorListNoStl (cat@(ListCat c), rules) = unlines $ concat+ [ [ "void PrintAbsyn::visit" ++ cl ++ "("++ cl ++ " *" ++ vname ++ ")" , "{" , " while(" ++ vname +++ "!= 0)" , " {" , " if (" ++ vname ++ "->" ++ vname ++ "_ == 0)" , " {" , visitMember- , optsep- , " " ++ vname +++ "= 0;"+ ]+ , optsep+ , [ " " ++ vname +++ "= 0;" , " }" , " else" , " {"@@ -477,26 +479,29 @@ , "}" , "" ]+ ] where- visitMember = if isTokenCat c- then " visit" ++ funName c ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"- cl = identCat (normCat cat)- ecl = identCat (normCatOfList cat)- vname = map toLower cl+ visitMember+ | Just t <- maybeTokenCat c =+ " visit" ++ t ++ "(" ++ vname ++ "->" ++ member ++ ");"+ | otherwise =+ " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ cl = identCat (normCat cat)+ ecl = identCat (normCatOfList cat)+ vname = map toLower cl member = map toLower ecl ++ "_"- optsep = if hasOneFunc rules then "" else " render(" ++ sep ++ ");"- sep = snd (renderCharOrString sep')- sep' = getCons rules- renderSep s = "render(" <> text (snd (renderCharOrString s)) <> ")"+ optsep = if hasOneFunc rules || null sep' then []+ else [ " render(" ++ sep' ++ ");" ]+ sep' = snd $ renderCharOrString $ getCons rules+ renderSep s = "render(" <> text (snd $ renderCharOrString s) <> ")" separators = getSeparatorByPrecedence rules genPrintVisitorListNoStl _ = error "genPrintVisitorListNoStl expects a ListCat" --Pretty Printer methods for a rule. prPrintRule :: Maybe String -> Rule -> String-prPrintRule inPackage r@(Rule fun _ cats) | isProperLabel fun = unlines+prPrintRule inPackage r@(Rule fun _ cats _) | isProperLabel fun = unlines [- "void PrintAbsyn::visit" ++ fun ++ "(" ++ fun +++ "*" ++ fnm ++ ")",+ "void PrintAbsyn::visit" ++ funName fun ++ "(" ++ funName fun +++ "*" ++ fnm ++ ")", "{", " int oldi = _i_;", lparen,@@ -520,13 +525,13 @@ prPrintCat _ (Right t) = " render(" ++ t' ++ ");\n" where t' = snd (renderCharOrString t) prPrintCat fnm (Left (c, nt))- | isTokenCat c = " visit" ++ funName c ++ "(" ++ fnm ++ "->" ++ render nt ++ ");\n"- | isList c = " if(" ++ fnm ++ "->" ++ render nt ++ ") {" ++ accept ++ "}\n"- | otherwise = " " ++ accept ++ "\n"+ | Just t <- maybeTokenCat c+ = " visit" ++ t ++ "(" ++ fnm ++ "->" ++ s ++ ");\n"+ | isList c = " if(" ++ fnm ++ "->" ++ s ++ ") {" ++ accept ++ "}\n"+ | otherwise = " " ++ accept ++ "\n" where- accept- | c == InternalCat = "/* Internal Category */\n"- | otherwise = setI (precCat c) ++ fnm ++ "->" ++ render nt ++ "->accept(this);"+ s = render nt+ accept = setI (precCat c) ++ fnm ++ "->" ++ s ++ "->accept(this);" {- **** Abstract Syntax Tree Printer **** -} @@ -577,20 +582,22 @@ ecl = identCat (normCatOfList cat) vname = map toLower cl member = map toLower ecl ++ "_"- visitMember = if isTokenCat c- then " visit" ++ funName c ++ "(" ++ vname ++ "->" ++ member ++ ");"- else " " ++ vname ++ "->" ++ member ++ "->accept(this);"+ visitMember+ | Just t <- maybeTokenCat c =+ " visit" ++ t ++ "(" ++ vname ++ "->" ++ member ++ ");"+ | otherwise =+ " " ++ vname ++ "->" ++ member ++ "->accept(this);" prShowData _ (cat, rules) = --Not a list: abstract ++ concatMap prShowRule rules where cl = identCat (normCat cat)- abstract = case lookupRule (show cat) rules of+ abstract = case lookupRule (noPosition $ show cat) rules of Just _ -> "" Nothing -> "void ShowAbsyn::visit" ++ cl ++ "(" ++ cl ++ " *p) {} //abstract class\n\n" --This prints all the methods for Abstract Syntax tree rules.-prShowRule :: Rule -> String-prShowRule (Rule fun _ cats) | isProperLabel fun = concat+prShowRule :: IsFun f => Rul f -> String+prShowRule (Rule f _ cats _) | isProperLabel f = concat [ "void ShowAbsyn::visit" ++ fun ++ "(" ++ fun +++ "*" ++ fnm ++ ")\n", "{\n",@@ -602,38 +609,41 @@ "}\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 fnm) (numVars cats)))+ fun = funName f+ (optspace, lparen, rparen, cats')+ | null [ () | Left _ <- cats ] -- @all isRight cats@, but Data.Either.isRight requires base >= 4.7+ = ("", "", "", "")+ | otherwise = (" bufAppend(' ');\n", " bufAppend('(');\n"," bufAppend(')');\n"+ , concat (insertSpaces (map (prShowCat fnm) (numVars cats)))) insertSpaces [] = [] insertSpaces (x:[]) = [x] insertSpaces (x:xs) = if x == "" then insertSpaces xs else x : " bufAppend(' ');\n" : insertSpaces xs- allTerms [] = True- allTerms (Left _:_) = False- allTerms (_:zs) = allTerms zs fnm = "p" --other names could cause conflicts prShowRule _ = "" -- This recurses to the instance variables of a class. prShowCat :: String -> Either (Cat, Doc) String -> String-prShowCat _ (Right _) = ""-prShowCat fnm (Left (cat,nt))- | isTokenCat cat =- " visit" ++ funName cat ++ "(" ++ fnm ++ "->" ++ render nt ++ ");\n"- | cat == InternalCat = "/* Internal Category */\n"- | show (normCat $ strToCat $ render nt) /= render nt = accept- | otherwise =- concat [- " bufAppend('[');\n",- " if (" ++ fnm ++ "->" ++ render nt ++ ")" ++ accept,- " bufAppend(']');\n"- ]- where accept = " " ++ fnm ++ "->" ++ render nt ++ "->accept(this);\n"+prShowCat _ (Right _) = ""+prShowCat fnm (Left (cat, nt))+ | Just t <- maybeTokenCat cat =+ unlines+ [ " visit" ++ t ++ "(" ++ fnm ++ "->" ++ s ++ ");"+ ]+ | catToStr (normCat $ strToCat s) /= s =+ unlines+ [ accept+ ]+ | otherwise =+ unlines+ [ " bufAppend('[');"+ , " if (" ++ fnm ++ "->" ++ s ++ ")" ++ accept+ , " bufAppend(']');"+ ]+ where+ s = render nt+ accept = " " ++ fnm ++ "->" ++ s ++ "->accept(this);" {- **** Helper Functions Section **** -} @@ -641,29 +651,14 @@ baseName = drop 4 ---The visit-function name of a basic type-funName :: Cat -> String-funName (TokenCat c) | c `elem` builtin = c- where builtin = ["Integer", "Char", "String", "Double", "Ident" ]-funName _ = "Ident" --User-defined type---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 :: Bool -> String-prRender useStl = unlines- [+prRender useStl = unlines $ concat+ [ [ "//You may wish to change render", "void PrintAbsyn::render(Char c)", "{",@@ -682,6 +677,7 @@ " {", " backup();", " bufAppend(c);",+ " bufAppend(' ');", " }", " else if (c == '}')", " {",@@ -707,48 +703,60 @@ " bufAppend('\\n');", " indent();", " }",+ " else if (c == ' ') bufAppend(c);", " else if (c == 0) return;", " else", " {",- " bufAppend(' ');", " bufAppend(c);", " bufAppend(' ');", " }", "}",- "",- let renderString = "void PrintAbsyn::render(String s_)" $$ codeblock 2- [ "const char *s = s_.c_str() ;"- , "if(strlen(s) > 0)"- , codeblock 2- [ "bufAppend(s);"- , "bufAppend(' ');" ] ]- in if useStl then render renderString else "",- "void PrintAbsyn::render(const char *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_--;",- " }",- "}", ""+ ]+ , when useStl+ [ render $ vcat+ [ "void PrintAbsyn::render(String s)"+ , codeblock 2+ [ "render(s.c_str());"+ ]+ , ""+ ]+ ]+ , [ "bool allIsSpace(const char *s)"+ , "{"+ , " char c;"+ , " while ((c = *s++))"+ , " if (! isspace(c)) return false;"+ , " return true;"+ , "}"+ , ""+ ]+ , [ "void PrintAbsyn::render(const char *s)"+ , "{"+ , " if (*s) /* C string not empty */"+ , " {"+ , " if (allIsSpace(s)) {"+ , " backup();"+ , " bufAppend(s);"+ , " } else {"+ , " bufAppend(s);"+ , " bufAppend(' ');"+ , " }"+ , " }"+ , "}"+ , ""+ , "void PrintAbsyn::indent()"+ , "{"+ , " int n = _n_;"+ , " while (--n >= 0)"+ , " bufAppend(' ');"+ , "}"+ , ""+ , "void PrintAbsyn::backup()"+ , "{"+ , " if (buf_[cur_ - 1] == ' ')"+ , " buf_[--cur_] = 0;"+ , "}"+ , ""+ ] ]
src/BNFC/Backend/CPP/STL.hs view
@@ -23,11 +23,13 @@ import Data.Char import Data.List (nub)+import qualified Data.Map as Map import BNFC.Utils import BNFC.CF import BNFC.Options import BNFC.Backend.Base+import BNFC.Backend.C.CFtoBisonC (unionBuiltinTokens) import BNFC.Backend.CPP.Makefile import BNFC.Backend.CPP.STL.CFtoSTLAbs import BNFC.Backend.CPP.NoSTL.CFtoFlex@@ -46,9 +48,10 @@ 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+ let header = mkHeaderFile (inPackage opts) cf (allParserCats cf) (allEntryPoints cf) (Map.elems env) mkfile "Parser.H" header- let (skelH, skelC) = cf2CVisitSkel (inPackage opts) cf+ mkfile "ParserError.H" $ printParseErrHeader (inPackage opts)+ let (skelH, skelC) = cf2CVisitSkel True (inPackage opts) cf mkfile "Skeleton.H" skelH mkfile "Skeleton.C" skelC let (prinH, prinC) = cf2CPPPrinter True (inPackage opts) cf@@ -58,6 +61,29 @@ Makefile.mkMakefile opts $ makefile name where name = lang opts +printParseErrHeader :: Maybe String -> String+printParseErrHeader inPackage =+ unlines+ [+ " #pragma once "+ , " #include <string>"+ , " #include <stdexcept>"+ , ""+ , nsStart inPackage+ , " class parse_error : public std::runtime_error"+ , " {"+ , " public:"+ , " parse_error(int line, std::string str)"+ , " : std::runtime_error(str)"+ , " , m_line(line) {}"+ , " int getLine() {"+ , " return m_line;"+ , " } "+ , " private:"+ , " int m_line;"+ , " }; "+ , nsEnd inPackage+ ] cpptest :: Maybe String -> CF -> String cpptest inPackage cf =@@ -69,11 +95,13 @@ "/* pretty-print the result. */", "/* */", "/****************************************************************************/",- "#include <stdio.h>",- "#include <string.h>",+ "#include <cstdio>",+ "#include <string>",+ "#include <iostream>", "#include \"Parser.H\"", "#include \"Printer.H\"", "#include \"Absyn.H\"",+ "#include \"ParserError.H\"", "", "void usage() {", " printf(\"usage: Call with one of the following argument " ++@@ -112,7 +140,12 @@ " }", " } else input = stdin;", " /* The default entry point is used. For other options see Parser.H */",- " " ++ scope ++ dat ++ " *parse_tree = " ++ scope ++ "p" ++ def ++ "(input);",+ " " ++ scope ++ dat ++ " *parse_tree = nullptr;",+ " try { ",+ " parse_tree = " ++ scope ++ "p" ++ def ++ "(input);",+ " } catch( " ++ scope ++ "parse_error &e) {",+ " std::cout << \"Parse error on line \" << e.getLine(); ",+ " }", " if (parse_tree)", " {", " printf(\"\\nParse Successful!\\n\");",@@ -136,40 +169,41 @@ def = identCat cat scope = nsScope inPackage -mkHeaderFile inPackage cf cats eps env = unlines- [- "#ifndef " ++ hdef,- "#define " ++ hdef,- "",- "#include<vector>",- "#include<string>",- "",- nsStart inPackage,- concatMap mkForwardDec $ nub $ map normCat 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+mkHeaderFile inPackage cf cats eps env = unlines $ concat+ [ [ "#ifndef " ++ hdef+ , "#define " ++ hdef+ , ""+ , "#include<vector>"+ , "#include<string>"+ , ""+ , nsStart inPackage+ ]+ , map mkForwardDec $ nub $ map normCat cats+ , [ "typedef union"+ , "{"+ ]+ , map (" " ++) unionBuiltinTokens+ , 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 = "class " ++ identCat s ++ ";\n"- mkVar s | normCat s == s = " " ++ identCat s ++"*" +++ map toLower (identCat s) ++ "_;\n"- mkVar _ = ""+ mkForwardDec s = "class " ++ identCat s ++ ";"+ mkVar s | normCat s == s = [ " " ++ identCat s ++"*" +++ map toLower (identCat s) ++ "_;" ]+ 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)+ 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 (TokenCat catString) then ("#define " ++ nsDefine inPackage "_STRING_ " ++ show n ++ "\n") ++ mkChar (n+1) else mkChar n@@ -185,5 +219,7 @@ mkIdent n = if isUsedCat cf (TokenCat catIdent) then "#define " ++ nsDefine inPackage "_IDENT_ " ++ show n ++ "\n" else ""- mkFuncs s = identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);\n" ++- identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(const char *str);\n"+ mkFuncs s =+ [ identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(FILE *inp);"+ , identCat (normCat s) ++ "*" +++ "p" ++ identCat s ++ "(const char *str);"+ ]
src/BNFC/Backend/CPP/STL/CFtoBisonSTL.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-@@ -46,15 +47,21 @@ -} -module BNFC.Backend.CPP.STL.CFtoBisonSTL (cf2Bison, union) where+module BNFC.Backend.CPP.STL.CFtoBisonSTL+ ( cf2Bison+ , tokens, union+ , definedRules+ ) where -import Prelude'+import Prelude hiding ((<>)) -import Data.Char (toLower,isUpper)-import Data.List (nub, intercalate)-import Data.Maybe (fromMaybe)+import Data.Char ( isUpper )+import Data.List ( nub, intercalate )+import Data.Maybe ( fromMaybe )+import qualified Data.Map as Map -import BNFC.Backend.C.CFtoBisonC (startSymbol)+import BNFC.Backend.C.CFtoBisonC+ ( resultName, specialToks, startSymbol, typeName, unionBuiltinTokens, varName ) import BNFC.Backend.CPP.STL.STLUtils import BNFC.Backend.Common.NamedVariables hiding (varName) import BNFC.CF@@ -62,7 +69,6 @@ import BNFC.PrettyPrint import BNFC.TypeChecker import BNFC.Utils ((+++), when)-import ErrM --This follows the basic structure of CFtoHappy. @@ -73,11 +79,11 @@ type MetaVar = String --The environment comes from the CFtoFlex-cf2Bison :: RecordPositions -> Maybe String -> String -> CF -> SymEnv -> String+cf2Bison :: RecordPositions -> Maybe String -> String -> CF -> SymMap -> String cf2Bison rp inPackage name cf env = unlines [header inPackage name cf,- render $ union inPackage (map TokenCat (positionCats cf) ++ allCats cf),+ render $ union inPackage (map TokenCat (positionCats cf) ++ allParserCats cf), maybe "" (\ns -> "%define api.prefix {" ++ ns ++ "yy}") inPackage, "%token _ERROR_", tokens user env,@@ -85,7 +91,7 @@ startSymbol cf, specialToks cf, "%%",- prRules (rulesForBison rp inPackage name cf env)+ prRules (rulesForBison rp inPackage cf env) ] where user = fst (unzip (tokenPragmas cf))@@ -101,14 +107,18 @@ , "#include <stdio.h>" , "#include <string.h>" , "#include <algorithm>"+ , "#include \"ParserError.H\"" , "#include \"Absyn.H\""+ , ""+ , "#define YYMAXDEPTH 10000000" -- default maximum stack size is 10000, but right-recursion needs O(n) stack+ , "" , "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);"+ , "void " ++ ns ++ "initialize_lexer(FILE * inp);" , "int " ++ ns ++ "yywrap(void)" , "{" , " return 1;"@@ -116,14 +126,13 @@ , "void " ++ ns ++ "yyerror(const char *str)" , "{" , " extern char *"++ns++"yytext;"- , " fprintf(stderr,\"error: line %d: %s at %s\\n\", "- , " "++ns++"yy_mylinenumber, str, "++ns++"yytext);"+ , " throw "++ns++"::parse_error("++ ns ++ "yy_mylinenumber,str);" , "}" , ""- , definedRules cf , nsStart inPackage+ , definedRules cf , unlines $ map parseResult dats- , unlines $ map (parseMethod inPackage name) eps+ , unlines $ map (parseMethod cf inPackage name) eps , nsEnd inPackage , "%}" ]@@ -144,10 +153,10 @@ 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 ++ "_ (" +++ case runTypeChecker $ checkDefinition' list ctx f xs e of+ Left err -> error $ "Panic! This should have been caught already:\n" ++ err+ Right (args,(e',t)) -> unlines+ [ cppType t ++ " " ++ funName f ++ "_ (" ++ intercalate ", " (map cppArg args) ++ ") {" , " return " ++ cppExp e' ++ ";" , "}"@@ -157,6 +166,7 @@ cppType (ListT (BaseT x)) = "List" ++ show (normCat $ strToCat x) ++ " *" cppType (ListT t) = cppType t ++ " *" cppType (BaseT x)+ | x `elem` baseTokenCatNames = x | isToken x ctx = "String" | otherwise = show (normCat $ strToCat x) ++ " *" @@ -164,9 +174,8 @@ cppArg (x,t) = cppType t ++ " " ++ x ++ "_" cppExp :: Exp -> String- cppExp (App "[]" []) = "0"- cppExp (App x [])- | x `elem` xs = x ++ "_" -- argument+ cppExp (App "[]" []) = "0"+ cppExp (Var x) = x ++ "_" -- argument cppExp (App t [e]) | isToken t ctx = cppExp e cppExp (App x es)@@ -193,46 +202,53 @@ cat' = identCat cat --This generates a parser method for each entry point.-parseMethod :: Maybe String -> String -> Cat -> String-parseMethod inPackage _ cat = unlines- [- cat' ++ "* p" ++ par ++ "(FILE *inp)",- "{",- " " ++ ns ++ "yy_mylinenumber = 1;", -- O.F.- " " ++ ns ++ "initialize_lexer(inp);",- " if (yyparse())",- " { /* Failure */",- " return 0;",- " }",- " else",- " { /* Success */",- " return" +++ resultName cat' ++ ";",- " }",- "}",- cat' ++ "* p" ++ par ++ "(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' ++ ";",- " }",- "}"+parseMethod :: CF -> Maybe String -> String -> Cat -> String+parseMethod cf inPackage _ cat = unlines $ concat+ [ [ cat' ++ "* p" ++ par ++ "(FILE *inp)"+ , "{"+ , " " ++ ns ++ "yy_mylinenumber = 1;"+ , " " ++ ns ++ "initialize_lexer(inp);"+ , " if (yyparse())"+ , " { /* Failure */"+ , " return 0;"+ , " }"+ , " else"+ , " { /* Success */"+ ]+ , revOpt+ , [ " return" +++ res ++ ";"+ , " }"+ , "}"+ , cat' ++ "* p" ++ par ++ "(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 */"+ ]+ , revOpt+ , [ " return" +++ res ++ ";"+ , " }"+ , "}"+ ] ]- where+ where cat' = identCat (normCat cat) par = identCat cat- ns = nsString inPackage-+ ns = nsString inPackage+ res = resultName cat'+ -- Vectors are snoc lists+ revOpt = when (isList cat && cat `notElem` cfgReversibleCats cf)+ [ "std::reverse(" ++ res ++ "->begin(), " ++ res ++"->end());" ] -- | 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.@@ -241,10 +257,10 @@ -- >>> union Nothing [foo, ListCat foo] -- %union -- {--- int int_;--- char char_;--- double double_;--- char* string_;+-- int _int;+-- char _char;+-- double _double;+-- char* _string; -- Foo* foo_; -- ListFoo* listfoo_; -- }@@ -258,21 +274,18 @@ -- >>> union Nothing [foo, ListCat foo, foo2, ListCat foo2] -- %union -- {--- int int_;--- char char_;--- double double_;--- char* string_;+-- int _int;+-- char _char;+-- double _double;+-- char* _string; -- Foo* foo_; -- ListFoo* listfoo_; -- } union :: Maybe String -> [Cat] -> Doc-union inPackage cats =- "%union" $$ codeblock 2 (- [ "int int_;"- , "char char_;"- , "double double_;"- , "char* string_;" ]- ++ map mkPointer normCats )+union inPackage cats = vcat+ [ "%union"+ , codeblock 2 $ map text unionBuiltinTokens ++ map mkPointer normCats+ ] where normCats = nub (map normCat cats) mkPointer s = scope <> text (identCat s) <> "*" <+> text (varName s) <> ";"@@ -282,41 +295,38 @@ declarations :: CF -> String declarations cf = concatMap typeNT $ map TokenCat (positionCats cf) ++- filter (not . null . rulesForCat cf) (allCats cf) -- don't define internal rules+ filter (not . null . rulesForCat cf) (allParserCats cf) -- don't define internal rules where typeNT nt = "%type <" ++ varName nt ++ "> " ++ identCat nt ++ "\n" --declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user = concatMap $ \ (s, r) ->- concat [ "%token", when (s `elem` user) "<string_>", " ", r, " // ", s, "\n" ]--specialToks :: CF -> String-specialToks cf = concat [- ifC catString "%token<string_> _STRING_\n",- ifC catChar "%token<char_> _CHAR_\n",- ifC catInteger "%token<int_> _INTEGER_\n",- ifC catDouble "%token<double_> _DOUBLE_\n",- ifC catIdent "%token<string_> _IDENT_\n"- ]- where- ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""+tokens :: [UserDef] -> SymMap -> String+tokens user env = unlines $ map declTok $ Map.toList env+ where+ declTok (Keyword s, r) = tok "" s r+ declTok (Tokentype s, r) = tok (if s `elem` user then "<_string>" else "") s r+ tok t s r = concat [ "%token", t, " ", r, " // ", s ] --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForBison :: RecordPositions -> Maybe String -> String -> CF -> SymEnv -> Rules-rulesForBison rp inPackage _ cf env = map mkOne (ruleGroups cf) ++ posRules where++rulesForBison :: RecordPositions -> Maybe String -> CF -> SymMap -> Rules+rulesForBison rp inPackage cf env = map mkOne (ruleGroups cf) ++ posRules+ where mkOne (cat,rules) = constructRule rp inPackage cf env rules cat posRules = (`map` positionCats cf) $ \ n -> (TokenCat n,- [( fromMaybe n $ lookup n env- , concat [ "$$ = new " , n , "($1," , nsString inPackage , "yy_mylinenumber) ; YY_RESULT_" , n , "_= $$ ;" ]+ [( fromMaybe n $ Map.lookup (Tokentype n) env+ , concat+ [ "$$ = new ", nsScope inPackage, n, "($1, ", nsString inPackage, "yy_mylinenumber); "+ , nsScope inPackage, "YY_RESULT_", n, "_= $$;"+ ] )]) -- For every non-terminal, we construct a set of rules. constructRule ::- RecordPositions -> Maybe String -> CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+ RecordPositions -> Maybe String -> CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) constructRule rp inPackage cf env rules nt =- (nt,[(p, generateAction rp inPackage nt (ruleName r) b m +++ result) |+ (nt,[(p, generateAction rp inPackage nt (funName $ ruleName r) b m +++ result) | r0 <- rules, let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs then (True,revSepListRule r0)@@ -362,7 +372,7 @@ -- 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 -> SymMap -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) generatePatterns cf env r _ = case rhsRule r of [] -> ("/* empty */",[]) its -> (unwords (map mkIt its), metas its)@@ -370,9 +380,9 @@ mkIt = \case Left (TokenCat s) | isPositionCat cf s -> typeName s- | otherwise -> fromMaybe (typeName s) $ lookup s env+ | otherwise -> fromMaybe (typeName s) $ Map.lookup (Tokentype s) env Left c -> identCat c- Right s -> fromMaybe s $ lookup s env+ Right s -> fromMaybe s $ Map.lookup (Keyword s) env metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] -- notice: reversibility with push_back vectors is the opposite@@ -392,19 +402,3 @@ nt' = identCat nt pr [] = [] pr ((p,a):ls) = unlines [unwords [" |", p, "{ ", a , "}"]] ++ pr ls----Some helper functions.-resultName :: String -> String-resultName s = "YY_RESULT_" ++ s ++ "_"----slightly stronger than the NamedVariable version.-varName :: Cat -> String-varName = (++ "_") . map toLower . identCat . normCat--typeName :: String -> String-typeName "Ident" = "_IDENT_"-typeName "String" = "_STRING_"-typeName "Char" = "_CHAR_"-typeName "Integer" = "_INTEGER_"-typeName "Double" = "_DOUBLE_"-typeName x = x
src/BNFC/Backend/CPP/STL/CFtoCVisitSkelSTL.hs view
@@ -39,23 +39,28 @@ module BNFC.Backend.CPP.STL.CFtoCVisitSkelSTL (cf2CVisitSkel) where +import Data.Char+ import BNFC.CF-import BNFC.Utils ((+++))+import BNFC.Utils ((+++), unless) import BNFC.Backend.Common.OOAbstract import BNFC.Backend.CPP.Naming 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)+cf2CVisitSkel :: Bool -> Maybe String -> CF -> (String, String)+cf2CVisitSkel useSTL inPackage cf =+ ( mkHFile useSTL inPackage cab+ , mkCFile useSTL inPackage cab+ ) where cab = cf2cabs cf -- **** Header (.H) File Functions **** --Generates the Header File-mkHFile :: Maybe String -> CAbs -> String-mkHFile inPackage cf = unlines [+mkHFile :: Bool -> Maybe String -> CAbs -> String+mkHFile useSTL inPackage cf = unlines [ "#ifndef " ++ hdef, "#define " ++ hdef, "/* You might want to change the above name. */",@@ -67,8 +72,8 @@ "{", "public:", unlines [" void visit" ++ b ++ "(" ++ b ++ " *p);" |- b <- classes, notElem b (defineds cf)],- unlines [" void visit" ++ b ++ "(" ++ b ++ " x);" | b <- basics],+ b <- classes, notElem b (defineds cf), useSTL || notElem b (postokens cf) ],+ unlines [" void visit" ++ b ++ "(" ++ b ++ " x);" | b <- basics useSTL cf ], "};", nsEnd inPackage, "",@@ -77,24 +82,50 @@ where hdef = nsDefine inPackage "SKELETON_HEADER" classes = allClasses cf- basics = tokentypes cf ++ map fst basetypes +-- CPP/NoSTL treats 'position token' as just 'token'.+basics :: Bool -> CAbs -> [String]+basics useSTL cf = concat+ [ map fst basetypes+ , tokentypes cf+ , unless useSTL $ postokens cf+ ] + -- **** Implementation (.C) File Functions **** --Makes the .C File-mkCFile :: Maybe String -> CAbs -> String-mkCFile inPackage cf = unlines [+mkCFile :: Bool -> Maybe String -> CAbs -> String+mkCFile useSTL 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],+ unlines [ prCon r | (_,rs) <- signatures cf, r <- rs, useSTL || not (posRule r) ],+ unlines [ prList useSTL cb | cb <- listtypes cf ],+ unlines [ prBasic b | b <- base ], nsEnd inPackage ]+ where+ -- See OOAbstract 'posdata':+ posRule (c, _) = c `elem` postokens cf+ base = basics useSTL cf+ prCon (f,cs) = unlines [+ "void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")",+ "{",+ " /* Code For " ++ f ++ " Goes Here */",+ "",+ unlines [" " ++ visitArg c | c <- cs],+ "}"+ ]+ where+ v = mkVariable f+ visitArg (cat,isPt,var)+ | isPt && (useSTL || cat `notElem` base)+ = "if (" ++ field ++ ") " ++ field ++ "->accept(this);"+ | otherwise = "visit" ++ cat ++ "(" ++ field ++ ");"+ where field = v ++ "->" ++ var headerC = unlines [ "/*** BNFC-Generated Visitor Design Pattern Skeleton. ***/",@@ -114,7 +145,7 @@ "}" ] -prList (cl,b) = unlines [+prList True (cl,b) = unlines [ "void Skeleton::visit" ++ cl ++ "("++ cl +++ "*" ++ vname ++ ")", "{", " for ("++ cl ++"::iterator i = " ++@@ -129,17 +160,22 @@ where vname = mkVariable cl -prCon (f,cs) = unlines [- "void Skeleton::visit" ++ f ++ "(" ++ f ++ " *" ++ v ++ ")",- "{",- " /* Code For " ++ f ++ " Goes Here */",- "",- unlines [" " ++ visitArg c | c <- cs],- "}"- ]- where- v = mkVariable f- visitArg (cat,isPt,var) =- if isPt- then (v ++ "->" ++ var ++ "->accept(this);")- else ("visit" ++ cat ++ "(" ++ v ++ "->" ++ var ++ ");")+prList False (cl,b) = unlines+ [ "void Skeleton::visit" ++ cl ++ "("++ cl +++ "*" ++ vname ++ ")"+ , "{"+ , " while (" ++ vname ++ ")"+ , " {"+ , " /* Code For " ++ cl ++ " Goes Here */"+ , if b+ then " if (" ++ field ++ ") " ++ field ++ "->accept(this);"+ else " visit" ++ ecl ++ "(" ++ field ++ ");"+ , " " ++ vname ++ " = " ++ vname ++ "->" ++ next ++ "_;"+ , " }"+ , "}"+ ]+ where+ ecl = drop 4 cl -- drop "List"+ vname = mkVariable cl+ next = map toLower cl+ member = map toLower ecl ++ "_"+ field = vname ++ "->" ++ member
src/BNFC/Backend/CSharp/CAbstoCSharpAbs.hs view
@@ -119,7 +119,7 @@ prToken :: Namespace -> Bool -> String -> String prToken namespace useWCF name = unlinesInline [ prDataContract useWCF [],- " public class " ++ name ++ " : " ++ identifier namespace "TokenBaseType",+ " public class " ++ name ++ " : " ++ identifier namespace ("TokenBaseType" :: String), " {", " public " ++ name ++ "(string str) : base(str)", " {",
src/BNFC/Backend/CSharp/CFtoCSharpPrinter.hs view
@@ -288,11 +288,11 @@ entrypoints :: Namespace -> CF -> String entrypoints namespace cf = unlinesInline [ " #region Print Entry Points",- unlinesInlineMap prEntryPoint (allCats cf),+ unlinesInlineMap prEntryPoint (reallyAllCats cf), " #endregion", " ", " #region Show Entry Points",- unlinesInlineMap shEntryPoint (allCats cf),+ unlinesInlineMap shEntryPoint (reallyAllCats cf), " #endregion" ] where@@ -339,7 +339,7 @@ otherRules = tail rules' prRule :: Namespace -> Maybe String -> Rule -> String-prRule namespace maybeElse r@(Rule fun _c cats)+prRule namespace maybeElse r@(Rule fun _c cats _) | not (isCoercion fun || isDefinedRule fun) = unlinesInline [ " " ++ fromMaybe "" maybeElse ++ "if(p is " ++ identifier namespace fun ++ ")", " {",@@ -354,7 +354,7 @@ cats' = case cats of [] -> "" _ -> unlinesInline $ map (prCat fnm) (zip (fixOnes (numProps [] cats)) (map getPrec cats))- fnm = '_' : map toLower fun+ fnm = '_' : map toLower (funName fun) getPrec (Right {}) = 0 getPrec (Left c) = precCat c@@ -384,7 +384,6 @@ Right t -> " Render(\"" ++ escapeChars t ++ "\");" Left nt | "string" `isPrefixOf` nt -> " PrintQuoted(" ++ fnm ++ "." ++ nt ++ ");"- | isInternalVar nt -> "" | otherwise -> " PrintInternal(" ++ fnm ++ "." ++ nt ++ ", " ++ show p ++ ");" @@ -406,7 +405,7 @@ ] shRule :: Namespace -> Rule -> String-shRule namespace (Rule fun _c cats)+shRule namespace (Rule f _c cats _) | not (isCoercion fun || isDefinedRule fun) = unlinesInline [ " if(p is " ++ identifier namespace fun ++ ")", " {",@@ -418,6 +417,7 @@ " }" ] where+ fun = funName f cats' | allTerms cats = "" | otherwise = unlinesInline $ map (shCat fnm) (fixOnes (numProps [] cats)) lparen | allTerms cats = ""@@ -427,7 +427,7 @@ allTerms [] = True allTerms ((Left {}):_) = False allTerms (_:zs) = allTerms zs- fnm = '_' : map toLower fun+ fnm = '_' : map toLower (funName fun) shRule _nm _ = "" shList :: [UserDef] -> Cat -> [Rule] -> String@@ -449,7 +449,4 @@ " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");", " Render(\"]\");" ]- | isInternalVar nt -> "" | otherwise -> " ShowInternal(" ++ fnm ++ "." ++ nt ++ ");"--isInternalVar x = x == show InternalCat ++ "_"
src/BNFC/Backend/CSharp/CFtoGPLEX.hs view
@@ -36,10 +36,14 @@ ************************************************************** -} +{-# LANGUAGE TupleSections #-}+ module BNFC.Backend.CSharp.CFtoGPLEX (cf2gplex) where +import Data.Bifunctor (first) import Data.List import Data.Maybe+import qualified Data.Map as Map import BNFC.CF import BNFC.Backend.CSharp.RegToGPLEX@@ -47,19 +51,20 @@ import BNFC.Backend.CSharp.CSharpUtils --The environment must be returned for the parser to use.-cf2gplex :: Namespace -> CF -> (String, SymEnv)-cf2gplex namespace cf = (unlines [+cf2gplex :: Namespace -> CF -> (String, SymMap)+cf2gplex namespace cf = (,env) $ unlines [ prelude namespace, cMacros,- prettyprinter $ (lexSymbols env) ++ (gplex namespace cf env'),+ prettyprinter $ (lexSymbols env0) ++ (gplex namespace cf env), "%%"- ], env')+ ] where- env = makeSymEnv (cfgSymbols cf ++ reservedWords cf) (0 :: Int)- env' = env ++ (makeSymEnv (tokenNames cf) (length env))+ env = Map.fromList env1+ env0 = makeSymMap (cfgSymbols cf ++ reservedWords cf) (0 :: Int)+ env1 = map (first Keyword) env0 ++ makeSymMap (map Tokentype $ tokenNames cf) (length env0) -- 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))+ makeSymMap [] _ = []+ makeSymMap (s:symbs) n = (s, "SYMB_" ++ (show n)) : (makeSymMap symbs (n+1)) prelude :: Namespace -> String prelude namespace = unlines [@@ -152,7 +157,7 @@ where s' = escapeChars s -gplex :: Namespace -> CF -> SymEnv -> [(String, String)]+gplex :: Namespace -> CF -> SymMap -> [(String, String)] gplex namespace cf env = concat [ lexComments (comments cf), userDefTokens,@@ -170,7 +175,7 @@ where tokenline (name, exp) = ("<YYINITIAL>" ++ printRegGPLEX exp , action name) action n = "if(Trace) System.Console.Error.WriteLine(yytext); yylval." ++ varName n ++ " = new " ++ identifier namespace n ++ "(yytext); return (int)Tokens." ++ sName n ++ ";"- sName n = fromMaybe n $ lookup n env+ sName n = fromMaybe n $ Map.lookup (Tokentype n) env -- These handle escaped characters in Strings. strStates = [ ("<YYINITIAL>\"\\\"\"" , "BEGIN(STRING);"),
src/BNFC/Backend/CSharp/CFtoGPPG.hs view
@@ -43,6 +43,7 @@ import Data.Char (toLower) import Data.List (intersperse) import Data.Maybe (fromMaybe)+import qualified Data.Map as Map import BNFC.CF import BNFC.Backend.Common.NamedVariables hiding (varName)@@ -51,8 +52,6 @@ import BNFC.TypeChecker import BNFC.Utils ((+++)) -import ErrM- --This follows the basic structure of CFtoHappy. -- Type declarations@@ -63,12 +62,12 @@ type MetaVar = String --The environment comes from the CFtoGPLEX-cf2gppg :: Namespace -> CF -> SymEnv -> String+cf2gppg :: Namespace -> CF -> SymMap -> String cf2gppg namespace cf env = unlines $ [ header namespace cf , union namespace $ concat $ [ positionCats cf- , allCats cf+ , allParserCats cf , map strToCat $ tokentypes $ cf2cabs cf ] , tokens (map fst $ tokenPragmas cf) env@@ -90,7 +89,7 @@ "%namespace " ++ namespace, "%{", definedRules namespace cf,- unlinesInline $ map (parseMethod namespace) (allCatsNorm cf ++ positionCats cf),+ unlinesInline $ map (parseMethod namespace) (allParserCatsNorm cf ++ positionCats cf), "%}" ] @@ -109,9 +108,9 @@ 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 (_,(_,_)) -> unlinesInline [+ case runTypeChecker $ checkDefinition' list ctx f xs e of+ Left err -> error $ "Panic! This should have been caught already:\n" ++ err+ Right (_,(_,_)) -> unlinesInline [ "Defined Rule goes here" ] @@ -159,18 +158,18 @@ declarations :: CF -> String declarations cf = unlinesInline $ map typeNT $ positionCats cf ++- filter (not . null . rulesForCat cf) (allCats cf) -- don't define internal rules+ filter (not . null . rulesForCat cf) (allParserCats cf) -- don't define internal rules where typeNT nt = "%type <" ++ varName x ++ "> " ++ x where x = show $ normCat nt --declares terminal types.-tokens :: [UserDef] -> SymEnv -> String-tokens user ts = concatMap declTok ts+tokens :: [UserDef] -> SymMap -> String+tokens user env = unlines $ map declTok $ Map.toList env where- declTok (s, r) = if s `elem` user- then "%token<" ++ varName (show$normCat$strToCat s) ++ "> " ++ r ++ " // " ++ s ++ "\n"- else "%token " ++ r ++ " // " ++ s ++ "\n"+ declTok (Keyword s, r) = tok "" s r+ declTok (Tokentype s, r) = tok (if s `elem` user then "<" ++ varName (show $ normCat $ strToCat s) ++ ">" else "") s r+ tok t s r = "%token" ++ t ++ " " ++ r ++ " // " ++ s ++ "\n" specialToks :: CF -> String specialToks cf = unlinesInline [@@ -185,17 +184,17 @@ --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForGPPG :: Namespace -> CF -> SymEnv -> Rules+rulesForGPPG :: Namespace -> CF -> SymMap -> 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 -> OneRule- mkPos cat = (cat, [(fromMaybe s $ lookup s env, "$$ = new " ++ s ++ "($1);")])+ mkPos cat = (cat, [(fromMaybe s $ Map.lookup (Tokentype s) env, "$$ = new " ++ s ++ "($1);")]) where s = show cat -- | For every non-terminal, we construct a set of rules. constructRule :: Namespace ->- CF -> SymEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)])+ CF -> SymMap -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) constructRule namespace cf env rules nt = (nt,[(p,(generateAction namespace nt (ruleName r) b m) +++ result) | r0 <- rules,@@ -204,7 +203,7 @@ else (False,r0), let (p,m) = generatePatterns cf env r b]) where- ruleName r = case funRule r of+ ruleName r = case funName $ funRule r of ---- "(:)" -> identCat nt ---- "(:[])" -> identCat nt z -> z@@ -235,7 +234,7 @@ -- 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 -> SymMap -> Rule -> Bool -> (Pattern,[(MetaVar,Bool)]) generatePatterns cf env r _ = case rhsRule r of [] -> ("/* empty */",[]) its -> (unwords (map mkIt its), metas its)@@ -244,10 +243,10 @@ Left c | TokenCat tok <- c, isPositionCat cf tok -> fallback | show c `elem` map fst basetypes -> fallback- | otherwise -> fromMaybe fallback $ lookup (show c) env+ | otherwise -> fromMaybe fallback $ Map.lookup (Tokentype $ show c) env -- 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... _ -> fallback where fallback = typeName (identCat c)- Right s -> fromMaybe s $ lookup s env+ Right s -> fromMaybe s $ Map.lookup (Keyword s) env metas its = [('$': show i,revert c) | (i,Left c) <- zip [1 :: Int ..] its] -- notice: reversibility with push_back vectors is the opposite
src/BNFC/Backend/CSharp/CSharpUtils.hs view
@@ -84,10 +84,12 @@ 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+identifier :: IsFun a => Namespace -> a -> String+identifier namespace f | typ `elem` (map snd basetypes) = typ | otherwise = namespace ++ ".Absyn." ++ typ+ where+ typ = funName f -- 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.
src/BNFC/Backend/CSharp/RegToGPLEX.hs view
@@ -3,6 +3,7 @@ -- modified from RegToFlex import AbsBNF+import BNFC.Backend.Common (flexEps) -- the top-level printing method printRegGPLEX :: Reg -> String@@ -42,8 +43,8 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of@@ -53,7 +54,7 @@ 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 (["[^.]"])+ REps -> prPrec i 3 [ flexEps ] 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))
src/BNFC/Backend/Common.hs view
@@ -1,12 +1,30 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} -- | Functions common to different backends. -module BNFC.Backend.Common (renderListSepByPrecedence) where+module BNFC.Backend.Common where -import Prelude'+import Prelude hiding ((<>)) +import Data.Char++import BNFC.CF import BNFC.PrettyPrint++-- Andreas, 2020-10-08, issue #292:+-- Since the produced lexer for Haskell and Ocaml only recognizes ASCII identifiers,+-- but cfgKeywords also contains those using unicode characters,+-- we have to reclassify any keyword using non-ASCII characters+-- as symbol.+unicodeAndSymbols :: CF -> [String]+unicodeAndSymbols cf = filter (not . all isAscii) (cfgKeywords cf) ++ cfgSymbols cf++asciiKeywords :: CF -> [String]+asciiKeywords = filter (all isAscii) . cfgKeywords++-- | Representation of the empty word as Flex regular expression+flexEps :: String+flexEps = "[^.\\n]?" -- | Helper function for c-like languages that generates the code printing -- the list separator according to the given precedence level:
src/BNFC/Backend/Common/Makefile.hs view
@@ -2,7 +2,7 @@ module BNFC.Backend.Common.Makefile where -import Prelude'+import Prelude hiding ((<>)) import BNFC.Options (SharedOptions(..)) import BNFC.Backend.Base (mkfile, Backend)
src/BNFC/Backend/Common/NamedVariables.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Named instance variables Copyright (C) 2004 Author: Michael Pellauer@@ -68,14 +66,16 @@ module BNFC.Backend.Common.NamedVariables where -import Prelude'+import Control.Arrow (left, (&&&))+import Data.Char (toLower)+import Data.Either (lefts)+import Data.List (nub)+import Data.Map (Map) +import Text.PrettyPrint (Doc)+import qualified Text.PrettyPrint as P+ import BNFC.CF-import Data.Char (toLower)-import Data.List (nub)-import Text.PrettyPrint-import Control.Arrow (left, (&&&))-import Data.Either (lefts) type IVar = (String, Int) --The type of an instance variable@@ -83,10 +83,19 @@ type UserDef = TokenCat --user-defined types +-- | A symbol-mapping environment.+type SymEnv = KeywordEnv ---A symbol-mapping environment.-type SymEnv = [(String, String)]+-- | Map keywords to their token name.+type KeywordEnv = [(String, String)] +-- | Map keywords and user-defined token types to their token name.+type SymMap = Map SymKey String+data SymKey+ = Keyword String -- ^ Keyword like "(", "while", "true", ...+ | Tokentype String -- ^ Token type like "Integer", "Char", ...+ deriving (Eq, Ord, Show)+ -- | 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:@@ -95,7 +104,6 @@ -- [("A",1),("B",0),("A",2)] -- getVars :: [Cat] -> [IVar]-getVars [] = [] getVars cs = foldl addVar [] (map identCat cs) where addVar vs = addVar' vs 0@@ -131,7 +139,7 @@ let i = maybe 1 (+1) (lookup n env) -- Is there more use of the name u_ ? thereIsMore = n `elem` map snd (lefts xs)- vname = text n <> if i > 1 || thereIsMore then int i else empty+ vname = P.text n P.<> if i > 1 || thereIsMore then P.int i else P.empty in Left (c, vname) : f' ((n,i):env) xs --This makes numbers a little nicer.@@ -157,7 +165,7 @@ else fixCoercion cat cats fixAll :: [(Cat, [Rule])] -> [(Cat, [Rule])] -> [(Cat, [Rule])] fixAll _ [] = []- fixAll top ((cat,_):cats) = if isCoercion (show cat) -- This is weird: isCoercion is supposed to be applied to functions!!!!+ fixAll top ((cat,_):cats) = if isCoercion (noPosition $ 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
src/BNFC/Backend/Common/OOAbstract.hs view
@@ -78,23 +78,23 @@ absclasses = nub $ map (show.normCat) cats, conclasses = [f | Just f <- map testRule (cfgRules cf)], signatures = posdata ++ map normSig (cf2data cf),- postokens = map show pos,+ postokens = pos, defineds = defs } where (pos, toks) = partition (isPositionCat cf) $ map fst $ tokenPragmas cf (lists,cats) = partition isList $ allCatsNorm cf- testRule (Rule f c _)- | isList c = Nothing- | f == "_" = Nothing- | otherwise = Just f+ testRule (Rule f c _ _)+ | isList (wpThing c) = Nothing+ | funName f == "_" = Nothing+ | otherwise = Just $ funName 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 _ _ <- cfgPragmas cf]+ defs = [ funName f | FunDef f _ _ <- cfgPragmas cf] classVars :: [(String,Bool)] -> [(String,Bool,String)] classVars cs =
src/BNFC/Backend/Common/StrUtils.hs view
@@ -1,5 +1,7 @@ module BNFC.Backend.Common.StrUtils where +import Data.Char (ord)+ -- | 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@@ -15,8 +17,8 @@ -- >>> renderCharOrString "\"\\'" -- ('S',"\"\\\"\\\\\\'\"") renderCharOrString :: String -> (Char, String)-renderCharOrString [char] = ('C', show char) -- using show shoud quote '-renderCharOrString s =('S', "\"" ++ escapeChars s ++ "\"")+renderCharOrString [c] | ord c <= 255 = ('C', show c) -- using show should quote '+renderCharOrString s = ('S', "\"" ++ escapeChars s ++ "\"") -- | Helper function that escapes characters in strings -- >>> escapeChars "\\"@@ -31,5 +33,3 @@ escapeChars ('\"':xs) = '\\' : '\"' : escapeChars xs escapeChars ('\'':xs) = '\\' : '\'' : escapeChars xs escapeChars (x:xs) = x : escapeChars xs--
src/BNFC/Backend/Haskell.hs view
@@ -20,7 +20,6 @@ module BNFC.Backend.Haskell (makeHaskell, AlexVersion(..), makefile, testfile) where import qualified Control.Monad as Ctrl-import Data.Functor ((<$>)) import System.FilePath ((<.>), (</>), pathSeparator) import Text.Printf (printf) import Text.PrettyPrint@@ -39,14 +38,14 @@ import BNFC.Backend.Haskell.MkErrM import BNFC.Backend.Haskell.MkSharedString import BNFC.Backend.Haskell.ToCNF as ToCNF-import BNFC.Backend.Haskell.Utils (parserName)+import BNFC.Backend.Haskell.Utils import BNFC.Backend.Txt2Tag import BNFC.Backend.XML import qualified BNFC.Backend.Common.Makefile as Makefile import BNFC.CF import BNFC.Options hiding (Backend)-import BNFC.Utils (when, unless, getZonedTimeTruncatedToSeconds)+import BNFC.Utils (when, unless, table, getZonedTimeTruncatedToSeconds) -- | Entrypoint for the Haskell backend.@@ -65,34 +64,35 @@ shareMod = shareFileM opts do -- Generate abstract syntax and pretty printer.- mkfile (absFile opts) $ cf2Abstract (byteStrings opts) (ghcExtensions opts) (functor opts) absMod cf- mkfile (printerFile opts) $ cf2Printer (byteStrings opts) (functor opts) False prMod absMod cf+ mkfile (absFile opts) $ cf2Abstract (tokenText opts) (generic opts) (functor opts) absMod cf+ mkfile (printerFile opts) $ cf2Printer (tokenText opts) (functor opts) False prMod absMod cf -- Generate Alex lexer. Layout is resolved after lexing. case alexMode opts of Alex1 -> do- mkfile (alexFile opts) $ cf2alex lexMod errMod cf+ mkfile (alexFile opts) $ cf2alex lexMod 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)+ mkfile (alexFile opts) $ cf2alex2 lexMod shareMod (shareStrings opts) (tokenText opts) cf+ liftIO $ printf "Use Alex 2 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)+ mkfile (alexFile opts) $ cf2alex3 lexMod shareMod (shareStrings opts) (tokenText opts) cf+ liftIO $ printf "Use Alex 3 to compile %s.\n" (alexFile opts) - Ctrl.when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf- Ctrl.when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alex1 opts) (inDir opts) layMod lexMod cf+ Ctrl.when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (tokenText opts) cf+ Ctrl.when (hasLayout cf) $ mkfile (layoutFile opts) $+ cf2Layout (tokenText opts) (alex1 opts) layMod lexMod cf -- Generate Happy parser and matching test program unless --cnf. Ctrl.unless (cnf opts) $ do mkfile (happyFile opts) $- cf2Happy parMod absMod lexMod errMod (glr opts) (byteStrings opts) (functor opts) cf+ cf2Happy parMod absMod lexMod (glr opts) (tokenText opts) (functor opts) cf -- liftIO $ printf "%s Tested with Happy 1.15\n" (happyFile opts) mkfile (tFile opts) $ testfile opts cf -- Both Happy parser and skeleton (template) rely on Err.- mkfile (errFile opts) $ mkErrM errMod (ghcExtensions opts)- mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod (functor opts) cf+ mkfile (errFile opts) $ mkErrM errMod+ mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod (functor opts) cf -- Generate txt2tags documentation. mkfile (txtFile opts) $ cfToTxt (lang opts) cf@@ -315,98 +315,124 @@ ] 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 render (parserName 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 System.Exit ( exitFailure, exitSuccess )",- "import Control.Monad (when)",- "",- "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 = when (v > 1) $ putStrLn s",- "",- "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 runGlr else runStd 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",- "",- "usage :: IO ()",- "usage = do",- " putStrLn $ unlines",- " [ \"usage: Call with one of the following argument combinations:\"",- " , \" --help Display this help message.\"",- " , \" (no arguments) Parse stdin verbosely.\"",- " , \" (files) Parse content of files verbosely.\"",- " , \" -s (files) Silent mode. Parse content of files silently.\"",- " ]",- " exitFailure",- "",- "main :: IO ()",- "main = do",- " args <- getArgs",- " case args of",- " [\"--help\"] -> usage",- " [] -> getContents >>= run 2 " ++ firstParser,- " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs",- " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs",- "",- if_glr $ "the_parser :: ParseFun " ++ show topType,- if_glr $ "the_parser = lift_parser " ++ render (parserName topType),- if_glr "",- if_glr liftParser- ]+testfile opts cf = unlines $ concat $+ [ [ "-- Program to test parser, automatically generated by BNF Converter."+ , ""+ , "module Main where"+ , ""+ ]+ , case tokenText opts of+ StringToken -> []+ TextToken ->+ [ "import Prelude hiding ( getContents, readFile )"+ , "import Data.Text.IO ( getContents, readFile )"+ , "import qualified Data.Text"+ ]+ ByteStringToken ->+ [ "import Prelude hiding ( getContents, readFile )"+ , "import Data.ByteString.Char8 ( getContents, readFile )"+ , "import qualified Data.ByteString.Char8 as BS"+ ]+ , [ "import System.Environment ( getArgs, getProgName )"+ , "import System.Exit ( exitFailure, exitSuccess )"+ , "import Control.Monad ( when )"+ , ""+ ]+ , table "" $ concat+ [ [ [ "import " , alexFileM opts , " ( Token )" ]+ , [ "import " , happyFileM opts , " ( " ++ firstParser ++ ", myLexer )" ]+ , [ "import " , templateFileM opts , " ()" ]+ , [ "import " , printerFileM opts , " ( Print, printTree )" ]+ , [ "import " , absFileM opts , " ()" ]+ ]+ , [ [ "import " , layoutFileM opts , " ( resolveLayout )" ] | lay ]+ , [ [ "import " , xmlFileM opts , " ( XPrint, printXML )" ] | use_xml ]+ ]+ , [ "import qualified Data.Map ( Map, lookup, toList )" | use_glr ]+ , [ "import Data.Maybe ( fromJust )" | use_glr ]+ , [ ""+ , "type Err = Either String"+ , 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 = when (v > 1) $ putStrLn s"+ , ""+ , "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 -> " ++ tokenTextType (tokenText opts) ++ " -> IO ()"+ , if use_glr then runGlr else runStd 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"+ , ""+ , "usage :: IO ()"+ , "usage = do"+ , " putStrLn $ unlines"+ , " [ \"usage: Call with one of the following argument combinations:\""+ , " , \" --help Display this help message.\""+ , " , \" (no arguments) Parse stdin verbosely.\""+ , " , \" (files) Parse content of files verbosely.\""+ , " , \" -s (files) Silent mode. Parse content of files silently.\""+ , " ]"+ , " exitFailure"+ , ""+ , "main :: IO ()"+ , "main = do"+ , " args <- getArgs"+ , " case args of"+ , " [\"--help\"] -> usage"+ , " [] -> getContents >>= run 2 " ++ firstParser+ , " \"-s\":fs -> mapM_ (runFile 0 " ++ firstParser ++ ") fs"+ , " fs -> mapM_ (runFile 2 " ++ firstParser ++ ") fs"+ , ""+ ]+ , if use_glr then+ [ "the_parser :: ParseFun " ++ show topType+ , "the_parser = lift_parser " ++ render (parserName topType)+ , ""+ , liftParser+ ]+ else []+ ]+ where+ 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 render (parserName topType)+ topType = firstEntry cf + runStd 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"+ [ "run v p s = case p ts of"+ , " Left s -> do"+ , " putStrLn \"\\nParse Failed...\\n\""+ , " putStrV v \"Tokens:\""+ , " putStrV v $ show ts"+ , " putStrLn s"+ , " exitFailure"+ , " Right tree -> do"+ , " putStrLn \"\\nParse Successful!\""+ , " showTree v tree" , if xml then- " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree"+ " putStrV v $ \"\\n[XML]\\n\\n\" ++ printXML tree" else ""- , " exitSuccess"+ , " exitSuccess"+ , " where"+ , " ts = myLLexer s" ] runGlr@@ -421,9 +447,9 @@ , " 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"+ , " [] -> error \"No results but parse succeeded?\""+ , " [Right x] -> showTree v x"+ , " xs@(_:_) -> showSeveralTrees v xs" , " where" , " showSeveralTrees :: (Print b, Show b) => Int -> [Err b] -> IO ()" , " showSeveralTrees v trees"@@ -431,7 +457,7 @@ , " [ do putStrV v (replicate 40 '-')" , " putStrV v $ \"Parse number: \" ++ show n" , " showTree v t"- , " | (Ok t,n) <- zip trees [1..]"+ , " | (Right t,n) <- zip trees [1..]" , " ]" ]
src/BNFC/Backend/Haskell/CFtoAbstract.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Abstract syntax Generator Copyright (C) 2004 Author: Markus Forberg@@ -19,62 +17,102 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} -module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract) where+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} -import Prelude'+module BNFC.Backend.Haskell.CFtoAbstract (cf2Abstract, definedRules) where +import Prelude hiding ((<>))+import Data.Maybe+import qualified Data.List as List+ import BNFC.CF+import BNFC.Options ( TokenText(..) ) import BNFC.PrettyPrint import BNFC.Utils ( when ) -import BNFC.Backend.Haskell.Utils ( catToType, catvars )+import BNFC.Backend.Haskell.Utils+ ( avoidReservedWords, catToType, catvars, mkDefName+ , tokenTextImport, tokenTextType, typeToHaskell ) -- | Create a Haskell module containing data type definitions for the abstract syntax. cf2Abstract- :: Bool -- ^ Use ByteString instead of String- -> Bool -- ^ Use GHC specific extensions- -> Bool -- ^ Make the tree a functor- -> String -- ^ module name- -> CF -- ^ Grammar+ :: TokenText -- ^ Use @ByteString@ or @Text@ instead of @String@?+ -> Bool -- ^ Derive @Data@, Generic@, @Typeable@?+ -> Bool -- ^ Make the tree a functor?+ -> String -- ^ Module name.+ -> CF -- ^ Grammar. -> Doc-cf2Abstract byteStrings ghcExtensions functor name cf = vsep . concat $+cf2Abstract tokenText generic functor name cf = vsep . concat $ [ [ vcat [ "-- Haskell data types for the abstract syntax." , "-- Generated by the BNF converter." ] ]- , [ vcat- [ "{-# LANGUAGE DeriveDataTypeable #-}"- , "{-# LANGUAGE DeriveGeneric #-}"+ , [ vcat . concat $+ [ [ "{-# LANGUAGE DeriveDataTypeable #-}" | gen ]+ , [ "{-# LANGUAGE DeriveGeneric #-}" | gen ]+ , [ "{-# LANGUAGE GeneralizedNewtypeDeriving #-}" | hasIdentLike ] -- for IsString ]- | ghcExtensions ] , [ hsep [ "module", text name, "where" ] ] , [ vcat . concat $- [ [ "import qualified Data.ByteString.Char8 as BS" | byteStrings ]- , [ "import Data.Data (Data, Typeable)" | ghcExtensions ]- , [ "import GHC.Generics (Generic)" | ghcExtensions ]+ [ [ text $ "import Prelude (" ++ typeImports ++ functorImportsUnqual ++ ")" ]+ , [ text $ "import qualified Prelude as C (Eq, Ord, Show, Read" ++ functorImportsQual ++ ")" ]+ , [ "import qualified Data.String" | hasIdentLike ] -- for IsString ] ]- , map (\ c -> prSpecialData byteStrings (isPositionCat cf c) derivingClasses c) $ specialCats cf- , concatMap (prData functor derivingClasses) $ cf2data cf+ , [ vcat . concat $+ [ map text $ tokenTextImport tokenText+ , [ "import qualified Data.Data as C (Data, Typeable)" | gen ]+ , [ "import qualified GHC.Generics as C (Generic)" | gen ]+ ]+ ]+ , (`map` specialCats cf) $ \ c ->+ let hasPos = isPositionCat cf c+ in prSpecialData tokenText hasPos (derivingClassesTokenType hasPos) c+ , concatMap (prData functorName derivingClasses) datas+ , definedRules functor cf , [ "" ] -- ensure final newline ] where- derivingClasses = concat+ hasIdentLike = hasIdentLikeTokens cf+ datas = cf2data cf+ gen = generic && not (null datas)+ derivingClasses = map ("C." ++) $ concat [ [ "Eq", "Ord", "Show", "Read" ]- , when ghcExtensions ["Data","Typeable","Generic"]+ , when generic [ "Data", "Typeable", "Generic" ] ]+ derivingClassesTokenType hasPos = concat+ [ derivingClasses+ , [ "Data.String.IsString" | not hasPos ]+ ]+ typeImports = List.intercalate ", " $ concat+ [ [ "Char", "Double" ]+ , [ "Int" | hasPositionTokens cf ]+ , [ "Integer", "String" ]+ ]+ functorImportsUnqual+ | functor = ", map, fmap"+ | otherwise = ""+ functorImportsQual+ | functor = ", Functor"+ | otherwise = ""+ functorName+ | functor = "C.Functor"+ | otherwise = "" +type FunctorName = String+ -- | ----- >>> vsep $ prData False ["Eq", "Ord", "Show", "Read"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])])+-- >>> vsep $ prData "" ["Eq", "Ord", "Show", "Read"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [Cat "Ident"])]) -- data C = C1 C | CIdent Ident -- deriving (Eq, Ord, Show, Read) -- -- Note that the layout adapts if it does not fit in one line:--- >>> vsep $ prData False ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])])+-- >>> vsep $ prData "" ["Show"] (Cat "C", [("CAbracadabra",[]),("CEbrecedebre",[]),("CIbricidibri",[]),("CObrocodobro",[]),("CUbrucudubru",[])]) -- data C -- = CAbracadabra -- | CEbrecedebre@@ -83,8 +121,8 @@ -- | CUbrucudubru -- deriving (Show) ----- If the first argument is True, generate a functor:--- >>> vsep $ prData True ["Show"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])])+-- If the first argument is not null, generate a functor:+-- >>> vsep $ prData "Functor" ["Show"] (Cat "C", [("C1", [Cat "C"]), ("CIdent", [TokenCat "Ident"])]) -- data C a = C1 a (C a) | CIdent a Ident -- deriving (Show) -- <BLANKLINE>@@ -94,7 +132,7 @@ -- CIdent a ident -> CIdent (f a) ident -- -- The case for lists:--- >>> vsep $ prData True ["Show"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])])+-- >>> vsep $ prData "Functor" ["Show"] (Cat "ExpList", [("Exps", [ListCat (Cat "Exp")])]) -- data ExpList a = Exps a [Exp a] -- deriving (Show) -- <BLANKLINE>@@ -102,37 +140,38 @@ -- fmap f x = case x of -- Exps a exps -> Exps (f a) (map (fmap f) exps) ---prData :: Bool -> [String] -> Data -> [Doc]-prData functor derivingClasses (cat,rules) = concat+prData :: FunctorName -> [String] -> Data -> [Doc]+prData functorName derivingClasses (cat,rules) = concat [ [ hang ("data" <+> dataType) 4 (constructors rules) $+$ nest 2 (deriving_ derivingClasses) ]- , [ genFunctorInstance (cat, rules) | functor ]+ , [ genFunctorInstance functorName (cat, rules) | functor ] ] where+ functor = not $ null functorName prRule (fun, cats) = hsep $ concat [ [text fun], ["a" | functor], map prArg cats ] dataType = hsep $ concat [ [text (show cat)], ["a" | functor] ]- prArg = catToType $ if functor then Just "a" else Nothing+ prArg = catToType id $ if functor then "a" else empty constructors [] = empty constructors (h:t) = sep $ ["=" <+> prRule h] ++ map (("|" <+>) . prRule) t -- | Generate a functor instance declaration: ----- >>> genFunctorInstance (Cat "C", [("C1", [Cat "C", Cat "C"]), ("CIdent", [TokenCat "Ident"])])+-- >>> genFunctorInstance "Functor" (Cat "C", [("C1", [Cat "C", Cat "C"]), ("CIdent", [TokenCat "Ident"])]) -- instance Functor C where -- fmap f x = case x of -- C1 a c1 c2 -> C1 (f a) (fmap f c1) (fmap f c2) -- CIdent a ident -> CIdent (f a) ident ----- >>> genFunctorInstance (Cat "SomeLists", [("Ints", [ListCat (TokenCat "Integer")]), ("Exps", [ListCat (Cat "Exp")])])+-- >>> genFunctorInstance "Functor" (Cat "SomeLists", [("Ints", [ListCat (TokenCat "Integer")]), ("Exps", [ListCat (Cat "Exp")])]) -- instance Functor SomeLists where -- fmap f x = case x of -- Ints a integers -> Ints (f a) integers -- Exps a exps -> Exps (f a) (map (fmap f) exps) ---genFunctorInstance :: Data -> Doc-genFunctorInstance (cat, cons) =- "instance Functor" <+> text (show cat) <+> "where"+genFunctorInstance :: FunctorName -> Data -> Doc+genFunctorInstance functorName (cat, cons) =+ "instance" <+> text functorName <+> text (show cat) <+> "where" $+$ nest 4 ("fmap f x = case x of" $+$ nest 4 (vcat (map mkCase cons))) where mkCase (f, args) = hsep . concat $@@ -152,38 +191,40 @@ -- | Generate a newtype declaration for Ident types ----- >>> prSpecialData False False ["Show"] catIdent+-- >>> prSpecialData StringToken False ["Show","Data.String.IsString"] catIdent -- newtype Ident = Ident String+-- deriving (Show, Data.String.IsString)+--+-- >>> prSpecialData StringToken True ["Show"] catIdent+-- newtype Ident = Ident ((Int, Int), String) -- deriving (Show) ----- >>> prSpecialData False True ["Show"] catIdent--- newtype Ident = Ident ((Int,Int),String)+-- >>> prSpecialData TextToken False ["Show"] catIdent+-- newtype Ident = Ident Data.Text.Text -- deriving (Show) ----- >>> prSpecialData True False ["Show"] catIdent+-- >>> prSpecialData ByteStringToken False ["Show"] catIdent -- newtype Ident = Ident BS.ByteString -- deriving (Show) ----- >>> prSpecialData True True ["Show"] catIdent--- newtype Ident = Ident ((Int,Int),BS.ByteString)+-- >>> prSpecialData ByteStringToken True ["Show"] catIdent+-- newtype Ident = Ident ((Int, Int), BS.ByteString) -- deriving (Show) -- prSpecialData- :: Bool -- ^ If True, use ByteString instead of String- -> Bool -- ^ If True, store the token position- -> [String] -- ^ Derived classes- -> TokenCat -- ^ Token category name+ :: TokenText -- ^ Format of token content.+ -> Bool -- ^ If @True@, store the token position.+ -> [String] -- ^ Derived classes.+ -> TokenCat -- ^ Token category name. -> Doc-prSpecialData byteStrings position classes cat = vcat- [ hsep [ "newtype", ppcat, "=", ppcat, contentSpec ]+prSpecialData tokenText position classes cat = vcat+ [ hsep [ "newtype", text cat, "=", text cat, contentSpec ] , nest 2 $ deriving_ classes ] where- ppcat = text cat- contentSpec | position = parens ( "(Int,Int)," <> stringType)+ contentSpec | position = parens ( "(Int, Int), " <> stringType) | otherwise = stringType- stringType | byteStrings = "BS.ByteString"- | otherwise = "String"+ stringType = text $ tokenTextType tokenText -- | Generate 'deriving' clause --@@ -192,3 +233,27 @@ -- deriving_ :: [String] -> Doc deriving_ cls = "deriving" <+> parens (hsep $ punctuate "," $ map text cls)++-- | Generate Haskell code for the @define@d constructors.+definedRules :: Bool -> CF -> [Doc]+definedRules functor cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]+ where+ mkDef f xs e = vcat $ map text $ concat+ [ [ unwords [ mkDefName f, "::", typeToHaskell $ wpThing t ]+ | not functor -- TODO: make type signatures work with --functor+ , t <- maybeToList $ sigLookup f cf+ ]+ , [ unwords $ mkDefName f : xs' ++ [ "=", show $ sanitize e ] ]+ ]+ where xs' = addFunctorArg id $ map avoidReservedWords xs+ sanitize = \case+ App x es -> App x $ addFunctorArg (`App` []) $ map sanitize es+ Var x -> Var $ avoidReservedWords x+ e@LitInt{} -> e+ e@LitDouble{} -> e+ e@LitChar{} -> e+ e@LitString{} -> e+ -- Functor argument+ addFunctorArg g+ | functor = (g "_a" :)+ | otherwise = id
src/BNFC/Backend/Haskell/CFtoAlex.hs view
@@ -24,27 +24,8 @@ import BNFC.Backend.Haskell.RegToAlex import Data.List -cf2alex :: String -> String -> CF -> String-cf2alex name errMod cf = unlines $ intercalate [""] [- 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 [""] [+cf2alex name cf = unlines $ intercalate [""] [ prelude name, cMacros, rMacros cf,@@ -55,13 +36,12 @@ prelude name = [ "-- This Alex file was machine-generated by the BNF converter", "%{",- "module Lex" ++ name ++ " where",+ "module " ++ name ++ " where", "", "import Alex",- "import ErrM", "%}" ]--}+ cMacros :: [String] cMacros = [ "{ ^l = [a-zA-Z^192-^255] # [^215 ^247]} -- isolatin1 letter",
src/BNFC/Backend/Haskell/CFtoAlex2.hs view
@@ -32,35 +32,38 @@ ------------------------------------------------------------------- module BNFC.Backend.Haskell.CFtoAlex2 (cf2alex2) where -import BNFC.CF-import Data.List+import Data.Char+import Data.List (intercalate, intersperse, sort) --- For RegToAlex, see below. import AbsBNF-import Data.Char+import BNFC.CF+import BNFC.Options (TokenText(..))+import BNFC.Backend.Haskell.Utils -cf2alex2 :: String -> String -> String -> Bool -> Bool -> CF -> String-cf2alex2 name errMod shareMod shareStrings byteStrings cf =++cf2alex2 :: String -> String -> Bool -> TokenText -> CF -> String+cf2alex2 name shareMod shareStrings tokenText cf = unlines $ intercalate [""] [- prelude name errMod shareMod shareStrings byteStrings,+ prelude name shareMod shareStrings tokenText, cMacros, rMacros cf,- restOfAlex shareMod shareStrings byteStrings cf+ restOfAlex shareMod shareStrings tokenText cf ] -prelude :: String -> String -> String -> Bool -> Bool -> [String]-prelude name _ 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 "",- "}",- ""+prelude :: String -> String -> Bool -> TokenText -> [String]+prelude name shareMod shareStrings tokenText = concat+ [ [ "-- -*- haskell -*-"+ , "-- This Alex file was machine-generated by the BNF converter"+ , "{"+ , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"+ , "module " ++ name ++ " where"+ , ""+ ]+ , [ "import " ++ shareMod | shareStrings ]+ , tokenTextImport tokenText+ , [ "}"+ , ""+ ] ] cMacros :: [String]@@ -91,8 +94,8 @@ where s = if isPrint c then ['\\',c] else '\\':show (ord c) -restOfAlex :: String -> Bool -> Bool -> CF -> [String]-restOfAlex _ shareStrings byteStrings cf = [+restOfAlex :: String -> Bool -> TokenText -> CF -> [String]+restOfAlex _ shareStrings tokenText cf = [ ":-", lexComments (comments cf), "$white+ ;",@@ -213,9 +216,10 @@ "}" ] 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)" )+ (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP) = case tokenText of+ StringToken -> ("String", "take", "", "id", "id", "[]", "(c:s)" )+ ByteStringToken -> ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")+ TextToken -> ("Data.Text.Text", "Data.Text.take", "Data.Text.uncons", "Data.Text.pack", "Data.Text.unpack", "Nothing", "Just (c,s)") ifC :: TokenCat -> String -> String ifC cat s = if isUsedCat cf (TokenCat cat) then s else ""@@ -317,8 +321,8 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of
src/BNFC/Backend/Haskell/CFtoAlex3.hs view
@@ -1,5 +1,5 @@ {-- BNF Converter: Alex 3.0 Generator+ BNF Converter: Alex 3.x 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@@ -21,40 +21,47 @@ module BNFC.Backend.Haskell.CFtoAlex3 (cf2alex3) where -import BNFC.CF-import Data.List+import Data.Char+import qualified Data.List as List --- For BNFC.Backend.Haskell.RegToAlex, see below. import AbsBNF-import Data.Char+import BNFC.CF+import BNFC.Lexing (mkRegMultilineComment)+import BNFC.Options (TokenText(..))+-- import BNFC.Utils (unless) -cf2alex3 :: String -> String -> String -> Bool -> Bool -> CF -> String-cf2alex3 name errMod shareMod shareStrings byteStrings cf =- unlines $ intercalate [""] [- prelude name errMod shareMod shareStrings byteStrings,- cMacros,- rMacros cf,- restOfAlex shareMod shareStrings byteStrings cf- ]+import BNFC.Backend.Common (unicodeAndSymbols)+import BNFC.Backend.Haskell.Utils -prelude :: String -> String -> String -> Bool -> Bool -> [String]-prelude name _ 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"- , ""- , 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)"- , "import Data.Char (ord)"- , "}"- , ""+cf2alex3 :: String -> String -> Bool -> TokenText -> CF -> String+cf2alex3 name shareMod shareStrings tokenText cf =+ unlines $ concat $+ [ prelude name shareMod shareStrings tokenText+ , cMacros+ , rMacros cf+ , restOfAlex shareMod shareStrings tokenText cf ] +prelude :: String -> String -> Bool -> TokenText -> [String]+prelude name shareMod shareStrings tokenText = concat+ [ [ "-- -*- haskell -*-"+ , "-- This Alex file was machine-generated by the BNF converter"+ , "{"+ , "{-# OPTIONS -fno-warn-incomplete-patterns #-}"+ , "{-# OPTIONS_GHC -w #-}"+ , "module " ++ name ++ " where"+ , ""+ ]+ , [ "import " ++ shareMod | shareStrings ]+ , tokenTextImport tokenText+ , [ "import qualified Data.Bits"+ , "import Data.Word (Word8)"+ , "import Data.Char (ord)"+ , "}"+ , ""+ ]+ ]+ cMacros :: [String] cMacros = [ "$c = [A-Z\\192-\\221] # [\\215] -- capital isolatin1 letter (215 = \\times) FIXME"@@ -68,25 +75,26 @@ rMacros :: CF -> [String] rMacros cf = if null symbs then [] else [ "@rsyms = -- symbols and non-identifier-like reserved words"- , " " ++ unwords (intersperse "|" (map mkEsc symbs))+ , " " ++ List.intercalate " | " (map mkEsc symbs) ]- where- symbs = cfgSymbols cf+ where+ symbs = unicodeAndSymbols cf mkEsc = unwords . esc esc s = if null a then rest else show a : rest- where (a,r) = span isAlphaNum s+ where (a,r) = span (\ c -> isAscii c && isAlphaNum c) 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 _ shareStrings byteStrings cf = [+restOfAlex :: String -> Bool -> TokenText -> CF -> [String]+restOfAlex _ shareStrings tokenText cf = [ ":-",+ "", lexComments (comments cf), "$white+ ;",- pTSpec (cfgSymbols cf),+ pTSpec (unicodeAndSymbols cf), userDefTokenTypes, ident,@@ -99,7 +107,7 @@ "", "{", "",- "tok :: (Posn -> String -> Token) -> (Posn -> String -> Token)",+ "tok :: (Posn -> " ++ stringType ++ " -> Token) -> (Posn -> " ++ stringType ++ " -> Token)", "tok f p s = f p s", "", "share :: "++stringType++" -> "++stringType,@@ -137,19 +145,21 @@ "posLineCol :: Posn -> (Int, Int)", "posLineCol (Pn _ l c) = (l,c)", "",- "mkPosToken :: Token -> ((Int, Int), String)",- "mkPosToken t@(PT p _) = (posLineCol p, prToken t)",+ "mkPosToken :: Token -> ((Int, Int), " ++ stringType ++ ")",+ "mkPosToken t@(PT p _) = (posLineCol p, tokenText t)", "",- "prToken :: Token -> String",- "prToken t = case t of",+ "tokenText :: Token -> " ++ stringType,+ "tokenText t = case t of", " PT _ (TS s _) -> s",- " PT _ (TL s) -> show s",+ " PT _ (TL s) -> " ++ applyP stringPack "show s", " PT _ (TI s) -> s", " PT _ (TV s) -> s", " PT _ (TD s) -> s", " PT _ (TC s) -> s",- " Err _ -> \"#error\"",+ " Err _ -> " ++ apply stringPack "\"#error\"", userDefTokenPrint,+ "prToken :: Token -> String",+ "prToken t = " ++ applyP stringUnpack "tokenText t", "", "data BTree = N | B "++stringType++" Tok BTree BTree deriving (Show)", "",@@ -163,11 +173,12 @@ "", "resWords :: BTree", "resWords = " ++ show (sorted2tree $ cfTokens cf),- " where b s n = let bs = "++stringPack++" s",- " in B bs (TS bs n)",+ " where b s n = let bs = "++ apply stringPack "s",+ " in B bs (TS bs n)", "", "unescapeInitTail :: "++stringType++" -> "++stringType++"",- "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack++" where",+ "unescapeInitTail = "++stringPack++" . unesc . tail . "++stringUnpack,+ " where", " unesc s = case s of", " '\\\\':c:cs | elem c ['\\\"', '\\\\', '\\\''] -> c : unesc cs", " '\\\\':'n':cs -> '\\n' : unesc cs",@@ -215,7 +226,7 @@ "alexGetByte :: AlexInput -> Maybe (Byte,AlexInput)", "alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s))", "alexGetByte (p, _, [], s) =",- " case "++stringUncons++" s of",+ " case " ++ apply stringUncons "s" ++ " of", " "++stringNilP++" -> Nothing", " "++stringConsP++" ->", " let p' = alexMove p c",@@ -248,40 +259,66 @@ "}" ] 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)" )+ (stringType,stringTake,stringUncons,stringPack,stringUnpack,stringNilP,stringConsP) = case tokenText of+ StringToken -> ("String", "take", "", "id", "id", "[]", "(c:s)" )+ ByteStringToken -> ("BS.ByteString", "BS.take", "BS.uncons", "BS.pack", "BS.unpack", "Nothing", "Just (c,s)")+ TextToken -> ("Data.Text.Text", "Data.Text.take", "Data.Text.uncons", "Data.Text.pack", "Data.Text.unpack", "Nothing", "Just (c,s)") + apply :: String -> String -> String+ apply "" s = s+ apply "id" s = s+ apply f s = f ++ " " ++ s++ applyP :: String -> String -> String+ applyP "" s = s+ applyP "id" s = s+ applyP f s = f ++ " (" ++ s ++ ")"+ ifC :: TokenCat -> String -> String ifC cat s = if isUsedCat cf (TokenCat 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) + lexComments+ :: ( [(String, String)] -- block comment delimiters+ , [String] -- line comment initiators+ ) -> String -- Alex declarations+ lexComments (block, line) = unlines $ concat $+ [ [ "-- Line comments" | not (null line) ]+ , map lexLineComment line+ , [ "" | not (null line || null block) ]+ , [ "-- Block comments" | not (null block) ]+ , map (uncurry lexBlockComment) block+ ]++ lexLineComment+ :: String -- ^ Line comment start.+ -> String -- ^ Alex declaration.+ lexLineComment s = concat [ "\"", s, "\" [.]* ;" ]++ lexBlockComment+ :: String -- ^ Start of block comment.+ -> String -- ^ End of block comment.+ -> String -- ^ Alex declaration.+ lexBlockComment start end = printRegAlex (mkRegMultilineComment start end) ++ " ;"+ -- tokens consisting of special symbols pTSpec [] = "" pTSpec _ = "@rsyms\n { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }" userDefTokenTypes = unlines- [printRegAlex exp ++- "\n { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }"- | (name,exp) <- tokenPragmas cf]+ [ printRegAlex exp +++ "\n { tok (\\p s -> PT p (eitherResIdent (T_" ++ name ++ " . share) s)) }"+ | (name,exp) <- tokenPragmas cf+ ]+ userDefTokenConstrs = unlines- [" | T_" ++ name ++ " !"++stringType | name <- tokenNames cf]+ [ " | T_" ++ name ++ " !"++stringType+ | name <- tokenNames cf+ ]+ userDefTokenPrint = unlines- [" PT _ (T_" ++ name ++ " s) -> s" | name <- tokenNames cf]+ [ " PT _ (T_" ++ name ++ " s) -> s"+ | name <- tokenNames cf+ ] ident = "$l $i*\n { tok (\\p s -> PT p (eitherResIdent (TV . share) s)) }"@@ -291,15 +328,19 @@ 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+ showsPrec _ N = showString "N"+ showsPrec n (B s k l r) = mparens+ $ showString "b " . shows s+ . showChar ' ' . shows k+ . showChar ' ' . showsPrec 1 l+ . showChar ' ' . showsPrec 1 r+ where+ mparens 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+sorted2tree xs = B x n (sorted2tree t1) (sorted2tree t2)+ where (t1, (x,n) : t2) = splitAt (length xs `div` 2) xs @@ -346,7 +387,7 @@ '\r' -> ["\\r"] '\f' -> ["\\f"] c | isAlphaNum c -> [[c]]- c | isPrint c -> ['\\':[c]]+ c | isPrint c -> ['\\':[c]] -- ['\'':c:'\'':[]] -- Does not work for ) c -> ['\\':show (ord c)] prtList = map (concat . prt 0)@@ -354,23 +395,24 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (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 (prt 3 reg ++ ["*"])- RPlus reg -> prPrec i 3 (prt 3 reg ++ ["+"])- ROpt reg -> prPrec i 3 (prt 3 reg ++ ["?"])- REps -> prPrec i 3 ["()"]- RChar c -> prPrec i 3 (prt 0 c)- RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])- RSeqs str -> prPrec i 2 (concatMap (prt 0) str)- RDigit -> prPrec i 3 ["$d"]- RLetter -> prPrec i 3 ["$l"]- RUpper -> prPrec i 3 ["$c"]- RLower -> prPrec i 3 ["$s"]- RAny -> prPrec i 3 ["$u"]+ RSeq reg0 reg -> prPrec i 2 $ prt 2 reg0 ++ prt 3 reg+ RAlt reg0 reg -> prPrec i 1 $ concat [prt 1 reg0 , ["|"] , prt 2 reg]+ RStar reg -> prPrec i 3 $ prt 3 reg ++ ["*"]+ RPlus reg -> prPrec i 3 $ prt 3 reg ++ ["+"]+ ROpt reg -> prPrec i 3 $ prt 3 reg ++ ["?"]+ -- Atomic/parenthesized expressions+ RMinus reg0 reg -> concat [ ["["], prt 2 reg0 , ["#"] , prt 2 reg, ["]"] ]+ REps -> ["()"]+ RChar c -> prt 0 c+ RAlts str -> concat [["["],prt 0 str,["]"]]+ RSeqs str -> prPrec i 2 $ prt 0 str+ RDigit -> ["$d"]+ RLetter -> ["$l"]+ RUpper -> ["$c"]+ RLower -> ["$s"]+ RAny -> ["$u"]
src/BNFC/Backend/Haskell/CFtoHappy.hs view
@@ -17,15 +17,19 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+ module BNFC.Backend.Haskell.CFtoHappy (cf2Happy, convert) where -import Data.Char+import Prelude hiding ((<>))+ import Data.List (intersperse) import BNFC.CF import BNFC.Backend.Common.StrUtils (escapeChars)-import BNFC.Backend.Haskell.Utils (parserName, catToType)-import BNFC.Options (HappyMode(..))+import BNFC.Backend.Haskell.Utils+import BNFC.Options (HappyMode(..), TokenText(..)) import BNFC.PrettyPrint import BNFC.Utils @@ -43,37 +47,37 @@ -- | Generate a happy parser file from a grammar. cf2Happy- :: String -- ^ This module's name.- -> String -- ^ Abstract syntax module name.- -> String -- ^ Lexer module name.- -> String -- ^ ErrM module name.+ :: ModuleName -- ^ This module's name.+ -> ModuleName -- ^ Abstract syntax module name.+ -> ModuleName -- ^ Lexer module name. -> HappyMode -- ^ Happy mode.- -> Bool -- ^ Use bytestring?+ -> TokenText -- ^ Use @ByteString@ or @Text@? -> Bool -- ^ AST is a functor? -> CF -- ^ Grammar. -> String -- ^ Generated code.-cf2Happy name absName lexName errName mode byteStrings functor cf = unlines- [ header name absName lexName errName byteStrings+cf2Happy name absName lexName mode tokenText functor cf = unlines+ [ header name absName lexName tokenText , render $ declarations mode (allEntryPoints cf) , render $ tokens cf , delimiter- , specialRules byteStrings cf- , render $ prRules functor (rulesForHappy absName functor cf)- , finalize byteStrings cf+ , specialRules absName tokenText cf+ , render $ prRules absName functor (rulesForHappy absName functor cf)+ , footer ] -- | Construct the header.-header :: String -> String -> String -> String -> Bool -> String-header modName absName lexName errName byteStrings = unlines- [ "-- This Happy file was machine-generated by the BNF converter"- , "{"- , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}"- , "module " ++ modName ++ " where"- , "import " ++ absName- , "import " ++ lexName- , "import " ++ errName- , if byteStrings then "import qualified Data.ByteString.Char8 as BS" else ""- , "}"+header :: ModuleName -> ModuleName -> ModuleName -> TokenText -> String+header modName absName lexName tokenText = unlines $ concat+ [ [ "-- This Happy file was machine-generated by the BNF converter"+ , "{"+ , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}"+ , "module " ++ modName ++ " where"+ , "import qualified " ++ absName+ , "import " ++ lexName+ ]+ , tokenTextImport tokenText+ , [ "}"+ ] ] -- | The declarations of a happy file.@@ -82,15 +86,15 @@ -- %name pB B -- %name pListB ListB -- -- no lexer declaration--- %monad { Err } { thenM } { returnM }+-- %monad { Either String } { (>>=) } { return } -- %tokentype {Token} declarations :: HappyMode -> [Cat] -> Doc declarations mode ns = vcat [ vcat $ map generateP ns , case mode of Standard -> "-- no lexer declaration"- GLR -> "%lexer { myLexer } { Err _ }",- "%monad { Err } { thenM } { returnM }",+ GLR -> "%lexer { myLexer } { Either String _ }",+ "%monad { Either String } { (>>=) } { return }", "%tokentype" <+> braces (text tokenName) ] where@@ -116,90 +120,73 @@ convert :: String -> Doc convert = quotes . text . escapeChars -rulesForHappy :: String -> Bool -> CF -> Rules-rulesForHappy absM functor cf = map mkOne $ ruleGroups cf- where- mkOne (cat,rules) = (cat, map (constructRule absM functor reversibles) rules)- reversibles = cfgReversibleCats cf+rulesForHappy :: ModuleName -> Bool -> CF -> Rules+rulesForHappy absM functor cf = for (ruleGroups cf) $ \ (cat, rules) ->+ (cat, map (constructRule absM functor) rules) -- | 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 "Foo" False [] (Rule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")])+-- >>> constructRule "Foo" False (npRule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")] Parsable) -- ("Exp '+' Exp","Foo.EPlus $1 $3") -- -- If we're using functors, it adds void value: ----- >>> constructRule "Foo" True [] (Rule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")])+-- >>> constructRule "Foo" True (npRule "EPlus" (Cat "Exp") [Left (Cat "Exp"), Right "+", Left (Cat "Exp")] Parsable) -- ("Exp '+' Exp","Foo.EPlus () $1 $3") -- -- List constructors should not be prefixed by the abstract module name: ----- >>> constructRule "Foo" False [] (Rule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))])+-- >>> constructRule "Foo" False (npRule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))] Parsable) -- ("A ',' ListA","(:) $1 $3") ----- >>> constructRule "Foo" False [] (Rule "(:[])" (ListCat (Cat "A")) [Left (Cat "A")])+-- >>> constructRule "Foo" False (npRule "(:[])" (ListCat (Cat "A")) [Left (Cat "A")] Parsable) -- ("A","(:[]) $1") -- -- Coercion are much simpler: ----- >>> constructRule "Foo" True [] (Rule "_" (Cat "Exp") [Right "(", Left (Cat "Exp"), Right ")"])+-- >>> constructRule "Foo" True (npRule "_" (Cat "Exp") [Right "(", Left (Cat "Exp"), Right ")"] Parsable) -- ("'(' Exp ')'","$2") ----- 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 "Foo" False [ListCat (Cat "A")] (Rule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))])--- ("ListA A ','","flip (:) $1 $2")------ Note that functors don't concern list constructors:------ >>> constructRule "Abs" True [ListCat (Cat "A")] (Rule "(:)" (ListCat (Cat "A")) [Left (Cat "A"), Right",", Left (ListCat (Cat "A"))])--- ("ListA A ','","flip (:) $1 $2")----constructRule :: String -> Bool -> [Cat] -> Rule -> (Pattern, Action)-constructRule absName functor revs r0@(Rule fun cat _) = (pattern, action)+constructRule :: IsFun f => String -> Bool -> Rul f -> (Pattern, Action)+constructRule absName functor (Rule fun0 _cat rhs Parsable) = (pattern, action) where- (pattern,metavars) = generatePatterns revs r+ fun = funName fun0+ (pattern, metavars) = generatePatterns rhs action | isCoercion fun = unwords metavars- | isConsFun fun && elem cat revs = unwords ("flip" : fun : metavars) | isNilCons fun = unwords (qualify fun : metavars) | functor = unwords (qualify fun : "()" : metavars) | otherwise = unwords (qualify fun : metavars)- r | isConsFun (funRule r0) && elem (valCat r0) revs = revSepListRule r0- | otherwise = r0 qualify f | isConsFun f || isNilCons f = f- | isDefinedRule f = f ++ "_" -- Definitions are local to Par.hs, not in Abs.hs+ | isDefinedRule f = absName ++ "." ++ mkDefName f | otherwise = absName ++ "." ++ f+constructRule _ _ (Rule _ _ _ Internal) = undefined -- impossible --- Generate patterns and a set of metavariables indicating--- where in the pattern the non-terminal -generatePatterns :: [Cat] -> Rule -> (Pattern,[MetaVar])-generatePatterns revs 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 -> render (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+-- | Generate patterns and a set of metavariables (de Bruijn indices) indicating+-- where in the pattern the non-terminal are locate.+--+-- >>> generatePatterns [ Left (Cat "Exp"), Right "+", Left (Cat "Exp") ]+-- ("Exp '+' Exp",["$1","$3"])+--+generatePatterns :: SentForm -> (Pattern, [MetaVar])+generatePatterns [] = ("{- empty -}", [])+generatePatterns its =+ ( unwords $ for its $ either {-non-term:-} identCat {-term:-} (render . convert)+ , [ ('$' : show i) | (i, Left{}) <- 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 False [(Cat "Expr", [("Integer", "EInt $1"), ("Expr '+' Expr", "EPlus $1 $3")])]--- Expr :: { Expr }--- Expr : Integer { EInt $1 } | Expr '+' Expr { EPlus $1 $3 }+-- >>> prRules "Foo" False [(Cat "Expr", [("Integer", "Foo.EInt $1"), ("Expr '+' Expr", "Foo.EPlus $1 $3")])]+-- Expr :: { Foo.Expr }+-- Expr : Integer { Foo.EInt $1 } | Expr '+' Expr { Foo.EPlus $1 $3 } -- -- if there's a lot of cases, print on several lines:--- >>> prRules False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5")])]+-- >>> prRules "" False [(Cat "Expr", [("Abcd", "Action"), ("P2", "A2"), ("P3", "A3"), ("P4", "A4"), ("P5","A5")])] -- Expr :: { Expr } -- Expr : Abcd { Action } -- | P2 { A2 }@@ -207,78 +194,63 @@ -- | P4 { A4 } -- | P5 { A5 } ----- >>> prRules False [(Cat "Internal", [])] -- nt has only internal use+-- >>> prRules "" False [(Cat "Internal", [])] -- nt has only internal use -- <BLANKLINE> -- -- The functor case:--- >>> prRules True [(Cat "Expr", [("Integer", "EInt () $1"), ("Expr '+' Expr", "EPlus () $1 $3")])]+-- >>> prRules "" True [(Cat "Expr", [("Integer", "EInt () $1"), ("Expr '+' Expr", "EPlus () $1 $3")])] -- Expr :: { (Expr ()) } -- Expr : Integer { EInt () $1 } | Expr '+' Expr { EPlus () $1 $3 } -- -- A list with coercion: in the type signature we need to get rid of the -- coercion. ----- >>> prRules True [(ListCat (CoercCat "Exp" 2), [("Exp2", "(:[]) $1"), ("Exp2 ',' ListExp2","(:) $1 $3")])]+-- >>> prRules "" True [(ListCat (CoercCat "Exp" 2), [("Exp2", "(:[]) $1"), ("Exp2 ',' ListExp2","(:) $1 $3")])] -- ListExp2 :: { [Exp ()] } -- ListExp2 : Exp2 { (:[]) $1 } | Exp2 ',' ListExp2 { (:) $1 $3 } ---prRules :: Bool -> Rules -> Doc-prRules functor = vcat . map prOne+prRules :: ModuleName -> Bool -> Rules -> Doc+prRules absM functor = vsep . map prOne where- type' = catToType (if functor then Just "()" else Nothing)- prOne (_,[]) = empty -- nt has only internal use- prOne (nt,(p,a):ls) =- hsep [ nt', "::", "{", type' nt, "}" ]- $$ nt' <+> sep (pr ":" (p, a) : map (pr "|") ls)- where- nt' = text (identCat nt)- pr pre (p,a) = hsep [pre, text p, "{", text a , "}"]+ prOne (_ , [] ) = empty -- nt has only internal use+ prOne (nt, (p,a):ls) =+ hsep [ nt', "::", "{", type' nt, "}" ]+ $$ nt' <+> sep (pr ":" (p, a) : map (pr "|") ls)+ where+ nt' = text (identCat nt)+ pr pre (p,a) = hsep [pre, text p, "{", text a , "}"]+ type' = catToType qualify $ if functor then "()" else empty+ qualify+ | null absM = id+ | otherwise = ((text absM <> ".") <>) -- Finally, some haskell code. -finalize :: Bool -> CF -> String-finalize byteStrings cf = unlines $- [ "{"- , ""- , "returnM :: a -> Err a"- , "returnM = return"- , ""- , "thenM :: Err a -> (a -> Err b) -> Err b"- , "thenM = (>>=)"- , ""- , "happyError :: [" ++ tokenName ++ "] -> Err a"- , "happyError ts ="- , " Bad $ \"syntax error at \" ++ tokenPos ts ++ "- , " case ts of"- , " [] -> []"- , " [Err _] -> \" due to lexer error\""- , " t:_ -> \" before `\" ++ " ++ stringUnpack ++ "(prToken t) ++ \"'\""- , ""- , "myLexer = tokens"- ] ++ definedRules cf ++- [ "}"- ]- where- stringUnpack- | byteStrings = "BS.unpack"- | otherwise = "id"---definedRules cf = [ mkDef f xs e | FunDef f xs e <- cfgPragmas 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+footer :: String+footer = unlines $+ [ "{"+ , ""+ , "happyError :: [" ++ tokenName ++ "] -> Either String a"+ , "happyError ts = Left $"+ , " \"syntax error at \" ++ tokenPos ts ++ "+ , " case ts of"+ , " [] -> []"+ , " [Err _] -> \" due to lexer error\""+ , unwords+ [ " t:_ -> \" before `\" ++"+ , "(prToken t)"+ -- , tokenTextUnpack tokenText "(prToken t)"+ , "++ \"'\""+ ]+ , ""+ , "myLexer = tokens"+ , "}"+ ] -- | GF literals. specialToks :: CF -> [String] specialToks cf = (`map` literals cf) $ \case- "Ident" -> "L_ident { PT _ (TV $$) }"+ "Ident" -> "L_Ident { PT _ (TV $$) }" "String" -> "L_quoted { PT _ (TL $$) }" "Integer" -> "L_integ { PT _ (TI $$) }" "Double" -> "L_doubl { PT _ (TD $$) }"@@ -286,22 +258,23 @@ own -> "L_" ++ own ++ " { PT _ (T_" ++ own ++ " " ++ posn ++ ") }" where posn = if isPositionCat cf own then "_" else "$$" -specialRules :: Bool -> CF -> String-specialRules byteStrings cf = unlines . intersperse "" . (`map` literals cf) $ \case- "Ident" -> "Ident :: { Ident }"- ++++ "Ident : L_ident { Ident $1 }"+specialRules :: ModuleName -> TokenText -> CF -> String+specialRules absName tokenText cf = unlines . intersperse "" . (`map` literals cf) $ \case+ -- "Ident" -> "Ident :: { Ident }"+ -- ++++ "Ident : L_ident { Ident $1 }" "String" -> "String :: { String }"- ++++ "String : L_quoted { "++stringUnpack++" $1 }"+ ++++ "String : L_quoted { " ++ stringUnpack "$1" ++ " }" "Integer" -> "Integer :: { Integer }"- ++++ "Integer : L_integ { (read ("++stringUnpack++" $1)) :: Integer }"+ ++++ "Integer : L_integ { (read (" ++ stringUnpack "$1" ++ ")) :: Integer }" "Double" -> "Double :: { Double }"- ++++ "Double : L_doubl { (read ("++stringUnpack++" $1)) :: Double }"+ ++++ "Double : L_doubl { (read (" ++ stringUnpack "$1" ++ ")) :: Double }" "Char" -> "Char :: { Char }"- ++++ "Char : L_charac { (read ("++stringUnpack++" $1)) :: Char }"- own -> own ++ " :: { " ++ own ++ "}"- ++++ own ++ " : L_" ++ own ++ " { " ++ own ++ " ("++ posn ++ "$1)}"- where posn = if isPositionCat cf own then "mkPosToken " else ""+ ++++ "Char : L_charac { (read (" ++ stringUnpack "$1" ++ ")) :: Char }"+ own -> own ++ " :: { " ++ qualify own ++ "}"+ ++++ own ++ " : L_" ++ own ++ " { " ++ qualify own ++ posn ++ " }"+ where posn = if isPositionCat cf own then " (mkPosToken $1)" else " $1" where- stringUnpack- | byteStrings = "BS.unpack"- | otherwise = ""+ stringUnpack = tokenTextUnpack tokenText+ qualify+ | null absName = id+ | otherwise = ((absName ++ ".") ++)
src/BNFC/Backend/Haskell/CFtoLayout.hs view
@@ -22,21 +22,21 @@ import Data.List (sort) import BNFC.CF+import BNFC.Options (TokenText(..))+import BNFC.Backend.Haskell.Utils layoutOpen = "{" layoutClose = "}" layoutSep = ";" -cf2Layout :: Bool -> Bool -> String -> String -> CF -> String-cf2Layout alex1 _ layName lexName cf =- let- (top,lay,stop) = layoutPragmas cf- in unlines $ [+cf2Layout :: TokenText -> Bool -> String -> String -> CF -> String+cf2Layout tokenText alex1 layName lexName cf = unlines $ [ "module " ++ layName ++ " where", "", "import " ++ lexName, if alex1 then "import Alex" else "", "",+ if tokenText == TextToken then "import qualified Data.Text" else "", "import Data.Maybe (isNothing, fromJust)", "", "-- Generated by the BNF Converter",@@ -246,7 +246,7 @@ "", "-- | Create a symbol token.", "sToken :: Position -> String -> Token",- "sToken p s = PT p (TS s i)",+ "sToken p s = PT p (TS " ++ tokenTextPackParens tokenText "s" ++ " i)", " where", " i = case s of"] ++ [ " " ++ show s ++ " -> " ++ show i@@ -271,7 +271,7 @@ "-- | Check if a token is one of the given symbols.", "isTokenIn :: [String] -> Token -> Bool", "isTokenIn ts t = case t of",- " PT _ (TS r _) | r `elem` ts -> True",+ " PT _ (TS r _) | " ++ tokenTextUnpack tokenText "r" ++ " `elem` ts -> True", " _ -> False", "", "-- | Check if a word is a layout start token.",@@ -297,4 +297,5 @@ "" ] where- resws = sort (reservedWords cf ++ cfgSymbols cf)+ resws = sort $ reservedWords cf ++ cfgSymbols cf+ (top,lay,stop) = layoutPragmas cf
src/BNFC/Backend/Haskell/CFtoPrinter.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Pretty-printer generator Copyright (C) 2004 Author: Aarne Ranta@@ -19,17 +17,23 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module BNFC.Backend.Haskell.CFtoPrinter (cf2Printer, compareRules) where -import Prelude'+import Prelude hiding ((<>)) -import BNFC.Backend.Haskell.Utils (hsReservedWords)+import BNFC.Backend.Haskell.Utils import BNFC.CF+import BNFC.Options (TokenText(..)) import BNFC.Utils -import Data.Char (toLower)-import Data.Either (lefts)-import Data.List (sortBy, intersperse)+import Data.Char (toLower)+import Data.Either (lefts)+import Data.Function (on)+import Data.List (sortBy, intersperse) -- import Debug.Trace (trace) import Text.PrettyPrint@@ -40,113 +44,124 @@ -- | Derive pretty-printer from a BNF grammar. cf2Printer- :: Bool -- ^ Are identifiers @ByteString@s rather than @String@s? (Option @--bytestrings@)+ :: TokenText -- ^ Are identifiers @ByteString@s or @Text@ rather than @String@s? (Option @--bytestrings@ and @--text@) -> Bool -- ^ Option @--functor@? -> Bool -- ^ @--haskell-gadt@? -> String -- ^ Name of created Haskell module. -> AbsMod -- ^ Name of Haskell module for abstract syntax. -> CF -- ^ Grammar. -> String-cf2Printer byteStrings functor useGadt name absMod cf = unlines $ concat $+cf2Printer tokenText functor useGadt name absMod cf = unlines $ concat $ -- Each of the following list entries is itself a list of lines- [ prologue byteStrings useGadt name absMod+ [ prologue tokenText useGadt name absMod , integerRule absMod cf , doubleRule absMod cf- , if hasIdent cf then identRule absMod byteStrings cf else []- ] ++ [ ownPrintRule absMod byteStrings cf own | (own,_) <- tokenPragmas cf ] +++ , if hasIdent cf then identRule absMod tokenText cf else []+ ] ++ [ ownPrintRule absMod tokenText cf own | (own,_) <- tokenPragmas cf ] ++ [ rules absMod functor cf ] -prologue :: Bool -> Bool -> String -> AbsMod -> [String]-prologue byteStrings useGadt name absMod =- [ "{-# LANGUAGE CPP #-}"- , "#if __GLASGOW_HASKELL__ <= 708"- , "{-# LANGUAGE OverlappingInstances #-}"- , "#endif"- ] ++- [ "{-# LANGUAGE GADTs, TypeSynonymInstances #-}" | useGadt ] ++- [ "{-# LANGUAGE FlexibleInstances #-}"- , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"- , ""- , "-- | Pretty-printer for " ++ takeWhile ('.' /=) name ++ "."- , "-- Generated by the BNF converter."- , ""- , "module " ++ name +++ "where"- , ""- , "import qualified " ++ absMod- , "import Data.Char"- ] ++ [ "import qualified Data.ByteString.Char8 as BS" | byteStrings ] ++- [ ""- , "-- | 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@(p:_) | closingOrPunctuation p -> showString t . 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)"- , ""- , " closingOrPunctuation :: String -> Bool"- , " closingOrPunctuation [c] = c `elem` closerOrPunct"- , " closingOrPunctuation _ = False"- , ""- , " closerOrPunct :: String"- , " closerOrPunct = \")],;\""- , ""- , "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 :: Int -> [a] -> Doc"- , " prtList i = concatD . map (prt i)"- , ""- , "instance {-# OVERLAPPABLE #-} Print a => Print [a] where"- , " prt = prtList"- , ""- , "instance Print Char where"- , " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')"- , " prtList _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')"- , ""- , "mkEsc :: Char -> Char -> ShowS"- , "mkEsc q s = case s of"- , " _ | s == q -> showChar '\\\\' . showChar s"- , " '\\\\'-> showString \"\\\\\\\\\""- , " '\\n' -> showString \"\\\\n\""- , " '\\t' -> showString \"\\\\t\""- , " _ -> showChar s"- , ""- , "prPrec :: Int -> Int -> Doc -> Doc"- , "prPrec i j = if j < i then parenth else id"- , ""+prologue :: TokenText -> Bool -> String -> AbsMod -> [String]+prologue tokenText useGadt name absMod = concat+ [ [ "{-# LANGUAGE CPP #-}"+ , "#if __GLASGOW_HASKELL__ <= 708"+ , "{-# LANGUAGE OverlappingInstances #-}"+ , "#endif"+ ]+ , [ "{-# LANGUAGE GADTs, TypeSynonymInstances #-}" | useGadt ]+ , [ "{-# LANGUAGE FlexibleInstances #-}"+ , "{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}"+ , ""+ , "-- | Pretty-printer for " ++ takeWhile ('.' /=) name ++ "."+ , "-- Generated by the BNF converter."+ , ""+ , "module " ++ name +++ "where"+ , ""+ , "import qualified " ++ absMod+ , "import Data.Char"+ ]+ , tokenTextImport tokenText+ , [ ""+ , "-- | 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"+ , " [\";\"] -> showChar ';'"+ , " \";\" :ts -> showChar ';' . new i . rend i ts"+ , " t : ts@(p:_) | closingOrPunctuation p -> showString t . rend i ts"+ , " t :ts -> space t . rend i ts"+ , " _ -> id"+ , " new i = showChar '\\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace"+ , " space t s ="+ , " case (all isSpace t', null spc, null rest) of"+ , " (True , _ , True ) -> [] -- remove trailing space"+ , " (False, _ , True ) -> t' -- remove trailing space"+ , " (False, True, False) -> t' ++ ' ' : s -- add space if none"+ , " _ -> t' ++ s"+ , " where"+ , " t' = showString t []"+ , " (spc, rest) = span isSpace s"+ , ""+ , " closingOrPunctuation :: String -> Bool"+ , " closingOrPunctuation [c] = c `elem` closerOrPunct"+ , " closingOrPunctuation _ = False"+ , ""+ , " closerOrPunct :: String"+ , " closerOrPunct = \")],;\""+ , ""+ , "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 :: Int -> [a] -> Doc"+ , " prtList i = concatD . map (prt i)"+ , ""+ , "instance {-# OVERLAPPABLE #-} Print a => Print [a] where"+ , " prt = prtList"+ , ""+ , "instance Print Char where"+ , " prt _ s = doc (showChar '\\'' . mkEsc '\\'' s . showChar '\\'')"+ , " prtList _ s = doc (showChar '\"' . concatS (map (mkEsc '\"') s) . showChar '\"')"+ , ""+ , "mkEsc :: Char -> Char -> ShowS"+ , "mkEsc q s = case s of"+ , " _ | s == q -> showChar '\\\\' . showChar s"+ , " '\\\\'-> showString \"\\\\\\\\\""+ , " '\\n' -> showString \"\\\\n\""+ , " '\\t' -> showString \"\\\\t\""+ , " _ -> showChar s"+ , ""+ , "prPrec :: Int -> Int -> Doc -> Doc"+ , "prPrec i j = if j < i then parenth else id"+ , ""+ ] ] -- | Printing instance for @Integer@, and possibly @[Integer]@.@@ -175,7 +190,6 @@ Cat{} -> qualified ListCat c -> concat [ "[", qualifiedCat absMod c, "]" ] CoercCat{} -> impossible- InternalCat -> impossible where unqualified = catToStr t qualified = qualify absMod unqualified@@ -185,24 +199,23 @@ qualify absMod s = concat [ absMod, "." , s ] -- | Printing instance for @Ident@, and possibly @[Ident]@.-identRule :: AbsMod -> Bool -> CF -> [String]-identRule absMod byteStrings cf = ownPrintRule absMod byteStrings cf catIdent+identRule :: AbsMod -> TokenText -> CF -> [String]+identRule absMod tokenText cf = ownPrintRule absMod tokenText cf catIdent -- | Printing identifiers and terminals.-ownPrintRule :: AbsMod -> Bool -> CF -> TokenCat -> [String]-ownPrintRule absMod byteStrings cf own =- [ "instance Print " ++ q ++ " where"- , " prt _ (" ++ q ++ posn ++ ") = doc (showString " ++ stringUnpack ++ ")"- ] ++ ifList cf (TokenCat own) ++- [ ""+ownPrintRule :: AbsMod -> TokenText -> CF -> TokenCat -> [String]+ownPrintRule absMod tokenText cf own = concat+ [ [ "instance Print " ++ q ++ " where"+ , " prt _ (" ++ q ++ posn ++ ") = doc $ showString $ " ++ tokenTextUnpack tokenText "i"+ ]+ , ifList cf (TokenCat own)+ , [ ""+ ] ] where q = qualifiedCat absMod $ TokenCat own posn = if isPositionCat cf own then " (_,i)" else " i" - stringUnpack | byteStrings = "(BS.unpack i)"- | otherwise = "i"- -- | Printing rules for the AST nodes. rules :: AbsMod -> Bool -> CF -> [String] rules absMod functor cf = do@@ -211,7 +224,7 @@ where toArgs :: Cat -> (Fun, [Cat]) -> Rule toArgs cat (cons, _) =- case filter (\ (Rule f c _rhs) -> cons == f && cat == normCat c) (cfgRules cf)+ case filter (\ (Rule f c _rhs _internal) -> cons == funName f && cat == normCat (wpThing c)) (cfgRules cf) of (r : _) -> r -- 2018-01-14: Currently, there can be overlapping rules like@@ -221,7 +234,7 @@ [] -> error $ "CFToPrinter.rules: no rhs found for: " ++ cons ++ ". " ++ show cat ++ " ::= ?" -- |--- >>> case_fun "Abs" False (Cat "A") [ (Rule "AA" (Cat "AB") [Right "xxx"]) ]+-- >>> case_fun "Abs" False (Cat "A") [ (npRule "AA" (Cat "AB") [Right "xxx"]) Parsable ] -- instance Print Abs.A where -- prt i e = case e of -- Abs.AA -> prPrec i 0 (concatD [doc (showString "xxx")])@@ -250,43 +263,43 @@ -- | When writing the Print instance for a category (in case_fun), we have -- a different case for each constructor for this category. ----- >>> mkPrintCase "Abs" False (Rule "AA" (Cat "A") [Right "xxx"])+-- >>> mkPrintCase "Abs" False (npRule "AA" (Cat "A") [Right "xxx"] Parsable) -- Abs.AA -> prPrec i 0 (concatD [doc (showString "xxx")]) -- -- Coercion levels are passed to @prPrec@. ----- >>> mkPrintCase "Abs" False (Rule "EInt" (CoercCat "Expr" 2) [Left (TokenCat "Integer")])+-- >>> mkPrintCase "Abs" False (npRule "EInt" (CoercCat "Expr" 2) [Left (TokenCat "Integer")] Parsable) -- Abs.EInt n -> prPrec i 2 (concatD [prt 0 n]) ----- >>> mkPrintCase "Abs" False (Rule "EPlus" (CoercCat "Expr" 1) [Left (Cat "Expr"), Right "+", Left (Cat "Expr")])+-- >>> mkPrintCase "Abs" False (npRule "EPlus" (CoercCat "Expr" 1) [Left (Cat "Expr"), Right "+", Left (Cat "Expr")] Parsable) -- Abs.EPlus expr1 expr2 -> prPrec i 1 (concatD [prt 0 expr1, doc (showString "+"), prt 0 expr2]) -- -- If the AST is a functor, ignore first argument. ----- >>> mkPrintCase "Abs" True (Rule "EInt" (CoercCat "Expr" 2) [Left (TokenCat "Integer")])+-- >>> mkPrintCase "Abs" True (npRule "EInt" (CoercCat "Expr" 2) [Left (TokenCat "Integer")] Parsable) -- Abs.EInt _ n -> prPrec i 2 (concatD [prt 0 n]) -- -- Skip internal categories. ----- >>> mkPrintCase "Abs" True (Rule "EInternal" (Cat "Expr") [Left InternalCat, Left (Cat "Expr")])+-- >>> mkPrintCase "Abs" True $ npRule "EInternal" (Cat "Expr") [Left (Cat "Expr")] Internal -- Abs.EInternal _ expr -> prPrec i 0 (concatD [prt 0 expr]) -- mkPrintCase :: AbsMod -> Bool -> Rule -> Doc-mkPrintCase absMod functor (Rule f cat rhs) =+mkPrintCase absMod functor (Rule f cat rhs _internal) = pattern <+> "->"- <+> "prPrec i" <+> integer (precCat cat) <+> parens (mkRhs (map render variables) rhs)+ <+> "prPrec i" <+> integer (precCat $ wpThing cat) <+> parens (mkRhs (map render variables) rhs) where pattern :: Doc pattern | isOneFun f = text "[" <+> head variables <+> "]" | isConsFun f = hsep $ intersperse (text ":") variables- | otherwise = text (qualify absMod f) <+> (if functor then "_" else empty) <+> hsep variables+ | otherwise = text (qualify absMod $ funName f) <+> (if functor then "_" else empty) <+> hsep variables -- Creating variables names used in pattern matching. In addition to -- haskell's reserved words, `e` and `i` are used in the printing function -- and should be avoided- names = map var (filter (/=InternalCat) $ lefts rhs)+ names = map var (lefts rhs) variables :: [Doc]- variables = map text $ mkNames ("e":"i":hsReservedWords) LowerCase names+ variables = map text $ mkNames ("e" : "i" : hsReservedWords) LowerCase names var (ListCat c) = var c ++ "s" var (TokenCat "Ident") = "id" var (TokenCat "Integer") = "n"@@ -300,7 +313,7 @@ -- trace ("ifList cf = " ++ show cf ) $ -- trace ("ifList cat = " ++ show cat ) $ -- trace ("ifList rules = " ++ show rules) $- -- trace ("ifList rulesForCat cf (ListCat cat) = " ++ show (rulesForCat cf (ListCat cat))) $+ -- trace ("ifList rulesForCat' cf (ListCat cat) = " ++ show (rulesForCat' cf (ListCat cat))) $ -- trace "" $ map (render . nest 2) cases where@@ -309,26 +322,26 @@ -- | Pattern match on the list constructor and the coercion level ----- >>> mkPrtListCase (Rule "[]" (ListCat (Cat "Foo")) [])+-- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable) -- prtList _ [] = concatD [] ----- >>> mkPrtListCase (Rule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")])+-- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "FOO")] Parsable) -- prtList _ [x] = concatD [prt 0 x] ----- >>> mkPrtListCase (Rule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))])+-- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable) -- prtList _ (x:xs) = concatD [prt 0 x, prt 0 xs] ----- >>> mkPrtListCase (Rule "[]" (ListCat (CoercCat "Foo" 2)) [])+-- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable) -- prtList 2 [] = concatD [] ----- >>> mkPrtListCase (Rule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)])+-- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable) -- prtList 2 [x] = concatD [prt 2 x] ----- >>> mkPrtListCase (Rule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))])+-- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable) -- prtList 2 (x:xs) = concatD [prt 2 x, prt 2 xs] -- mkPrtListCase :: Rule -> Doc-mkPrtListCase (Rule f (ListCat c) rhs)+mkPrtListCase (Rule f (WithPosition _ (ListCat c)) rhs _internal) | isNilFun f = "prtList" <+> precPattern <+> "[]" <+> "=" <+> body | isOneFun f = "prtList" <+> precPattern <+> "[x]" <+> "=" <+> body | isConsFun f = "prtList" <+> precPattern <+> "(x:xs)" <+> "=" <+> body@@ -350,31 +363,36 @@ -- This is desiged to correctly order the rules in the prtList function so that -- the pattern matching works as expectd. ----- >>> compareRules (Rule "[]" (ListCat (CoercCat "Foo" 3)) []) (Rule "[]" (ListCat (CoercCat "Foo" 1)) [])+-- >>> compareRules (npRule "[]" (ListCat (CoercCat "Foo" 3)) [] Parsable) (npRule "[]" (ListCat (CoercCat "Foo" 1)) [] Parsable) -- LT ----- >>> compareRules (Rule "[]" (ListCat (CoercCat "Foo" 3)) []) (Rule "[]" (ListCat (Cat "Foo")) [])+-- >>> compareRules (npRule "[]" (ListCat (CoercCat "Foo" 3)) [] Parsable) (npRule "[]" (ListCat (Cat "Foo")) [] Parsable) -- LT ----- >>> compareRules (Rule "[]" (ListCat (Cat "Foo")) []) (Rule "(:[])" (ListCat (Cat "Foo")) [])+-- >>> compareRules (npRule "[]" (ListCat (Cat "Foo")) [] Parsable) (npRule "(:[])" (ListCat (Cat "Foo")) [] Parsable) -- LT ----- >>> compareRules (Rule "(:[])" (ListCat (Cat "Foo")) []) (Rule "(:)" (ListCat (Cat "Foo")) [])+-- >>> compareRules (npRule "(:[])" (ListCat (Cat "Foo")) [] Parsable) (npRule "(:)" (ListCat (Cat "Foo")) [] Parsable) -- LT ---compareRules :: Rule -> Rule -> Ordering-compareRules r1 r2 | precRule r1 > precRule r2 = LT-compareRules r1 r2 | precRule r1 < precRule r2 = GT-compareRules (Rule "[]" _ _) (Rule "[]" _ _) = EQ-compareRules (Rule "[]" _ _) _ = LT-compareRules (Rule "(:[])" _ _) (Rule "[]" _ _) = GT-compareRules (Rule "(:[])" _ _) (Rule "(:[])" _ _) = EQ-compareRules (Rule "(:[])" _ _) (Rule "(:)" _ _) = LT-compareRules (Rule "(:)" _ _) (Rule "(:)" _ _) = EQ-compareRules (Rule "(:)" _ _) _ = GT-compareRules _ _ = EQ+compareRules :: IsFun f => Rul f -> Rul f -> Ordering+compareRules r1 r2+ | precRule r1 > precRule r2 = LT+ | precRule r1 < precRule r2 = GT+ | otherwise = (compareFunNames `on` (funName . funRule)) r1 r2 +compareFunNames :: String -> String -> Ordering+compareFunNames = curry $ \case+ ("[]" , "[]" ) -> EQ+ ("[]" , _ ) -> LT+ ("(:[])" , "[]" ) -> GT+ ("(:[])" , "(:[])") -> EQ+ ("(:[])" , "(:)" ) -> LT+ ("(:)" , "(:)" ) -> EQ+ ("(:)" , _ ) -> GT+ (_ , _ ) -> EQ + -- | -- -- >>> mkRhs ["expr1", "n", "expr2"] [Left (Cat "Expr"), Right "-", Left (TokenCat "Integer"), Left (Cat "Expr")]@@ -392,7 +410,6 @@ mkRhs args its = "concatD" <+> brackets (hsep (punctuate "," (mk args its))) where- mk args (Left InternalCat : items) = mk args items mk (arg:args) (Left c : items) = (prt c <+> text arg) : mk args items mk args (Right s : items) = ("doc (showString" <+> text (show s) <> ")") : mk args items mk _ _ = []
src/BNFC/Backend/Haskell/CFtoTemplate.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Template Generator Copyright (C) 2004 Author: Markus Forberg@@ -19,84 +17,53 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE OverloadedStrings #-} module BNFC.Backend.Haskell.CFtoTemplate (cf2Template) where -import Prelude'+import Prelude hiding ((<>)) -import BNFC.Backend.Haskell.Utils (catvars) import BNFC.CF import BNFC.PrettyPrint--type ModuleName = String+import BNFC.Utils ( ModuleName )+import BNFC.Backend.Haskell.Utils ( catvars ) -cf2Template :: ModuleName -> ModuleName -> ModuleName -> Bool -> CF -> String-cf2Template skelName absName errName functor cf = unlines- [ "module "++ skelName ++ " where\n"- , "-- Haskell module generated by the BNF converter\n"- , "import " ++ absName- , "import " ++ errName- , "type Result = Err String\n"+cf2Template :: ModuleName -> ModuleName -> Bool -> CF -> String+cf2Template skelName absName functor cf = unlines+ [ "-- Haskell module generated by the BNF converter"+ , ""+ , "module "++ skelName ++ " where"+ , ""+ , "import qualified " ++ absName+ , ""+ , "type Err = Either String"+ , "type Result = Err String"+ , "" , "failure :: Show a => a -> Result"- , "failure x = Bad $ \"Undefined case: \" ++ show x\n"- , unlines $ map (render . \(s,xs) -> case_fun functor s xs) $ specialData cf ++ cf2data cf+ , "failure x = Left $ \"Undefined case: \" ++ show x\n"+ , unlines $ map (render . \(s,xs) -> case_fun absName functor s xs) $ specialData cf ++ cf2data cf ] -{- -----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 False (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]--- transExpr :: Expr -> Result+-- >>> case_fun "M" False (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]+-- transExpr :: M.Expr -> Result -- transExpr x = case x of--- EInt integer -> failure x--- EAdd expr1 expr2 -> failure x+-- M.EInt integer -> failure x+-- M.EAdd expr1 expr2 -> failure x ----- >>> case_fun True (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])]+-- >>> case_fun "" True (Cat "Expr") [("EInt", [TokenCat "Integer"]), ("EAdd", [Cat "Expr", Cat "Expr"])] -- transExpr :: Show a => Expr a -> Result -- transExpr x = case x of -- EInt _ integer -> failure x -- EAdd _ expr1 expr2 -> failure x -- -- TokenCat are not generated as functors:--- >>> case_fun True (TokenCat "MyIdent") [("MyIdent", [TokenCat "String"])]+-- >>> case_fun "" True (TokenCat "MyIdent") [("MyIdent", [TokenCat "String"])] -- transMyIdent :: MyIdent -> Result -- transMyIdent x = case x of -- MyIdent string -> failure x-case_fun :: Bool -> Cat -> [(Fun,[Cat])] -> Doc-case_fun functor' cat xs = vcat+case_fun :: ModuleName -> Bool -> Cat -> [(Fun,[Cat])] -> Doc+case_fun absName functor' cat xs = vcat [ fname <+> "::" <+> iffunctor "Show a =>" <+> type_ <+> "-> Result" , fname <+> "x = case x of" , nest 2 $ vcat (map mkOne xs)@@ -106,9 +73,13 @@ -- then the type is a functor. iffunctor doc | functor' && not (isTokenCat cat) = doc | otherwise = empty- type_ = cat' <+> iffunctor "a"+ type_ = qualify $ cat' <+> iffunctor "a" fname = "trans" <> cat' cat' = text (show cat) mkOne (cons, args) = let ns = catvars args -- names False (map (checkRes .var) args) 1- in text cons <+> iffunctor "_" <+> hsep ns <+> "-> failure x"+ in qualify (text cons) <+> iffunctor "_" <+> hsep ns <+> "-> failure x"+ qualify :: Doc -> Doc+ qualify+ | null absName = id+ | otherwise = (text absName <> "." <>)
src/BNFC/Backend/Haskell/MkErrM.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Haskell error monad Copyright (C) 2004-2007 Author: Markus Forberg, Peter Gammie, Aarne Ranta, Björn Bringert+ Copyright (C) 2019 Author: Andreas Abel This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by@@ -19,31 +18,71 @@ along with this program; if not, write to the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -}-module BNFC.Backend.Haskell.MkErrM where -import Prelude'+module BNFC.Backend.Haskell.MkErrM where import BNFC.PrettyPrint -mkErrM :: String -> Bool -> Doc-mkErrM errMod ghc = vcat- [ if ghc then "{-# LANGUAGE CPP #-}" else empty- , "-- BNF Converter: Error Monad"- , "-- Copyright (C) 2004 Author: Aarne Ranta"+mkErrM :: String -> Doc+mkErrM errMod = vcat+ [ "{-# LANGUAGE CPP #-}" , ""+ , "#if __GLASGOW_HASKELL__ >= 708"+ , "---------------------------------------------------------------------------"+ , "-- Pattern synonyms exist since ghc 7.8."+ , ""+ , "-- | BNF Converter: Error Monad."+ , "--"+ , "-- Module for backwards compatibility."+ , "--"+ , "-- The generated parser now uses @'Either' String@ as error monad."+ , "-- This module defines a type synonym 'Err' and pattern synonyms"+ , "-- 'Bad' and 'Ok' for 'Left' and 'Right'."+ , ""+ , "{-# LANGUAGE PatternSynonyms #-}"+ , "{-# LANGUAGE FlexibleInstances #-}"+ , "{-# LANGUAGE TypeSynonymInstances #-}"+ , ""+ , "module" <+> text errMod <+> "where"+ , ""+ , "import Control.Monad (MonadPlus(..))"+ , "import Control.Applicative (Alternative(..))"+ , ""+ , "-- | Error monad with 'String' error messages."+ , "type Err = Either String"+ , ""+ , "pattern Bad msg = Left msg"+ , "pattern Ok a = Right a"+ , ""+ , "#if __GLASGOW_HASKELL__ >= 808"+ , "instance MonadFail Err where"+ , " fail = Bad"+ , "#endif"+ , ""+ , "instance Alternative Err where"+ , " empty = Left \"Err.empty\""+ , " (<|>) Left{} = id"+ , " (<|>) x@Right{} = const x"+ , ""+ , "instance MonadPlus Err where"+ , " mzero = empty"+ , " mplus = (<|>)"+ , ""+ , "#else"+ , "---------------------------------------------------------------------------"+ , "-- ghc 7.6 and before: use old definition as data type."+ , ""+ , "-- | BNF Converter: Error Monad"+ , ""+ , "-- Copyright (C) 2004 Author: Aarne Ranta" , "-- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE."- , "module " <> text errMod <> " where" , ""+ , "module" <+> text errMod <+> "where"+ , "" , "-- the Error monad: like Maybe type with error msgs" , ""- , "import Control.Monad (MonadPlus(..), liftM)"- -- From ghc-8.0 on, Applicative(..) is part of the Prelude,- -- thus, need not be imported:- , if ghc then "#if __GLASGOW_HASKELL__ < 710" else empty , "import Control.Applicative (Applicative(..), Alternative(..))"- , if ghc then "#else" else empty- , if ghc then "import Control.Applicative (Alternative(..))" else empty- , if ghc then "#endif" else empty+ , "import Control.Monad (MonadPlus(..), liftM)" , "" , "data Err a = Ok a | Bad String" , " deriving (Read, Show, Eq, Ord)"@@ -52,16 +91,6 @@ , " return = Ok" , " Ok a >>= f = f a" , " Bad s >>= _ = Bad s"- -- From ghc-8.8 on, fail is no longer part of Monad.- -- Thus, by default, we do not add it.- -- Only if --ghc, we add it either to Monad or MonadFail.- , if ghc then "#if __GLASGOW_HASKELL__ < 808" else empty- , if ghc then " fail = Bad" else empty- , if ghc then "#else" else empty- , if ghc then "" else empty- , if ghc then "instance MonadFail Err where" else empty- , if ghc then " fail = Bad" else empty- , if ghc then "#endif" else empty , "" , "instance Applicative Err where" , " pure = Ok"@@ -79,4 +108,6 @@ , "instance Alternative Err where" , " empty = mzero" , " (<|>) = mplus"+ , ""+ , "#endif" ]
@@ -18,10 +18,12 @@ -} module BNFC.Backend.Haskell.MkSharedString where -sharedString :: String -> Bool -> b -> String-sharedString shareMod byteString _ = unlines $- if byteString- then+import BNFC.Options (TokenText(..))++sharedString :: String -> TokenText -> b -> String+sharedString shareMod tokenText _ = unlines $+ case tokenText of+ ByteStringToken -> [ "module " ++ shareMod ++ " (shareString) where", "",@@ -44,7 +46,7 @@ " writeIORef stringPoolRef $! M.insert s' s' stringPool", " return s'" ]- else+ StringToken -> [ "module " ++ shareMod ++ " (shareString) where", "",@@ -57,6 +59,29 @@ "", "{-# 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"+ ]+ TextToken ->+ [+ "module " ++ shareMod ++ " (shareString) where",+ "",+ "import Data.Text (Text)",+ "import qualified Data.Text",+ "import Data.HashTable as H",+ "import System.IO.Unsafe (unsafePerformIO)",+ "",+ "{-# NOINLINE stringPool #-}",+ "stringPool :: HashTable Text Text",+ "stringPool = unsafePerformIO $ new (==) (hashString . Data.Text.unpack)",+ "",+ "{-# NOINLINE shareString #-}",+ "shareString :: Text -> Text", "shareString s = unsafePerformIO $ do", " mv <- H.lookup stringPool s", " case mv of",
src/BNFC/Backend/Haskell/RegToAlex.hs view
@@ -62,8 +62,8 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of
src/BNFC/Backend/Haskell/ToCNF.hs view
@@ -36,7 +36,7 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (Const) #endif-import qualified Data.Map as M+import qualified Data.Map as Map #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid #endif@@ -70,7 +70,7 @@ 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]+ pretty s = sep [pretty k <> " --> " <> pretty v | (k,x) <- Map.assocs s, v <- x] instance Pretty (Either Cat String) where pretty (Left x) = text $ show x@@ -81,7 +81,7 @@ prettyUnitSet units = vcat $ [ prettyExp f <> " : " <> catTag cat <> " --> " <> text (show cat')- | (cat, x) <- M.assocs units+ | (cat, x) <- Map.assocs units , (f, cat') <- x ] @@ -120,16 +120,18 @@ hang "showAst (cat, ast) = case cat of " 6 $ vcat $ [ vcat [ hsep [ catTag (Left cat), "->", "printTree", parens ("(unsafeCoerce# ast) ::" <+> text (show cat)) ]- | cat <- filter isDataCat $ allCats cf+ | cat <- filter isDataOrListCat $ reallyAllCats cf ] , "_ -> \"Unprintable category\"" ] genCatTags :: CFG Exp -> Doc genCatTags cf = vcat- [ "data CATEGORY = " <> punctuate' "|" (map catTag (allSyms cf))+ [ "data CATEGORY = " <> punctuate' " |" cs , " deriving (Eq, Ord, Show)" ]+ where+ cs = map catTag $ allSyms cf genDesc :: CFG Exp -> CatDescriptions -> Doc genDesc cf descs = vcat $@@ -139,7 +141,7 @@ where descOf :: Either Cat String -> String descOf (Right x) = "token " <> x- descOf (Left x) = maybe (show x) render $ M.lookup x descs+ descOf (Left x) = maybe (show x) render $ Map.lookup x descs genCombTable :: UnitRel Cat -> CFG Exp -> Doc genCombTable units cf = vcat@@ -150,7 +152,7 @@ allSyms :: CFG Exp -> [Either Cat String] allSyms cf = concat $- [ map Left $ allCats cf+ [ map Left $ reallyAllCats cf , map (Left . TokenCat) $ literals cf , map (Right . fst) $ cfTokens cf ]@@ -179,7 +181,7 @@ ] alt :: UnitRel Cat -> Rul Exp -> ((RHSEl,RHSEl),[(Cat,Exp)])-alt units (Rule f c [r1, r2]) = ((r1, r2), initial:others)+alt units (Rule f (WithPosition _ c) [r1, r2] _) = ((r1, r2), initial:others) where initial = (c, f `appMany` args) others = [ (c', f' `app'` (f `appMany` args))
src/BNFC/Backend/Haskell/Utils.hs view
@@ -1,18 +1,61 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} module BNFC.Backend.Haskell.Utils ( parserName- , hsReservedWords+ , hsReservedWords, avoidReservedWords, mkDefName+ , typeToHaskell, typeToHaskell' , catToType- , catvars+ , catToVar, catvars+ , tokenTextImport, tokenTextType+ , tokenTextPack, tokenTextPackParens, tokenTextUnpack ) where -import Prelude'+import Data.Char import BNFC.PrettyPrint-import BNFC.CF (Cat(..), identCat, normCat)-import BNFC.Utils (mkNames, NameStyle(..))+import qualified BNFC.PrettyPrint as P +import BNFC.CF (Cat(..), catToStr, identCat, baseTokenCatNames, Base, Type(FunT), IsFun(..))+import BNFC.Options (TokenText(..))+import BNFC.Utils (mkNames, NameStyle(..))++-- * Parameterization by 'TokenText'.++tokenTextImport :: TokenText -> [String]+tokenTextImport = \case+ StringToken -> []+ ByteStringToken -> [ "import qualified Data.ByteString.Char8 as BS" ]+ TextToken -> [ "import qualified Data.Text" ]++tokenTextType :: TokenText -> String+tokenTextType = \case+ StringToken -> "String"+ ByteStringToken -> "BS.ByteString"+ TextToken -> "Data.Text.Text"++tokenTextPack :: TokenText -> String -> String+tokenTextPack = \case+ StringToken -> id+ ByteStringToken -> ("BS.pack " ++)+ TextToken -> ("Data.Text.pack " ++)++tokenTextPackParens :: TokenText -> String -> String+tokenTextPackParens = \case+ StringToken -> id+ ByteStringToken -> parens . ("BS.pack " ++)+ TextToken -> parens . ("Data.Text.pack " ++)+ where+ parens s = "(" ++ s ++ ")"++tokenTextUnpack :: TokenText -> String -> String+tokenTextUnpack = \case+ StringToken -> id+ ByteStringToken -> ("BS.unpack " ++)+ TextToken -> ("Data.Text.unpack " ++)++-- * Other Utililites+ -- | Create a valid parser function name for a given category. -- -- >>> parserName (Cat "Abcd")@@ -22,7 +65,7 @@ -- pListXyz -- parserName :: Cat -> Doc-parserName = ("p" <>) . text . identCat+parserName = ("p" P.<>) . text . identCat -- | Haskell's reserved words. --@@ -36,6 +79,8 @@ , "deriving" , "do" , "else"+ , "family"+ , "forall" , "foreign" , "hiding" , "if"@@ -46,62 +91,100 @@ , "infixr" , "instance" , "let"+ , "mdo" , "module" , "newtype" , "of"+ , "pattern"+ , "proc" , "qualified"+ , "rec" , "then" , "type" , "where" ] +avoidReservedWords :: String -> String+avoidReservedWords x+ | x `elem` hsReservedWords = x ++ "'"+ | otherwise = x +-- | Modifier to avoid clashes in definition.+mkDefName :: IsFun f => f -> String+mkDefName = avoidReservedWords . funName+ -- | Render a category from the grammar to a Haskell type. ----- >>> catToType Nothing (Cat "A")+-- >>> catToType id empty (Cat "A") -- A--- >>> catToType Nothing (ListCat (Cat "A"))+-- >>> catToType id empty (ListCat (Cat "A")) -- [A]--- >>> catToType Nothing (TokenCat "Ident")--- Ident+-- >>> catToType ("Foo." P.<>) empty (TokenCat "Ident")+-- Foo.Ident -- -- Note that there is no haskell type for coerced categories: they should be normalized:--- >>> catToType Nothing (CoercCat "Expr" 2)+-- >>> catToType id empty (CoercCat "Expr" 2) -- Expr -- -- If a type parameter is given it is added to the type name:--- >>> catToType (Just "a") (Cat "A")+-- >>> catToType id (text "a") (Cat "A") -- (A a) ----- >>> catToType (Just "a") (ListCat (Cat "A"))+-- >>> catToType id (text "a") (ListCat (Cat "A")) -- [A a] -- -- but not added to Token categories:--- >>> catToType (Just "a") (TokenCat "Integer")+-- >>> catToType ("Foo." P.<>) (text "a") (TokenCat "Integer") -- Integer ----- >>> catToType (Just "a") (ListCat (TokenCat "Integer"))+-- >>> catToType id (text "a") (ListCat (TokenCat "Integer")) -- [Integer] ----- >>> catToType Nothing (ListCat (CoercCat "Exp" 2))+-- >>> catToType id empty (ListCat (CoercCat "Exp" 2)) -- [Exp] ----- >>> catToType (Just "()") (ListCat (CoercCat "Exp" 2))--- [Exp ()]+-- >>> catToType ("Foo." P.<>) (text "()") (ListCat (CoercCat "Exp" 2))+-- [Foo.Exp ()] ---catToType :: Maybe Doc -> Cat -> Doc-catToType param cat = parensIf isApp $ catToType' param cat+catToType :: (Doc -> Doc) -> Doc -> Cat -> Doc+catToType qualify param cat = parensIf isApp $ loop cat where- isApp = case (param, cat) of- (Just _, Cat _) -> True+ isApp = case cat of+ Cat _ -> not $ isEmpty param _ -> False- catToType' _ InternalCat = error "Can't create a haskell type for internal category"- catToType' Nothing c = text $ show $ normCat c- catToType' (Just p) (Cat c) = text c <+> p- catToType' (Just p) (CoercCat c _) = text c <+> p- catToType' (Just _) (TokenCat c) = text c- catToType' (Just p) (ListCat c) = brackets $ catToType' (Just p) c+ loop = \case+ ListCat c -> brackets $ loop c+ Cat c -> qualify (text c) <+> param -- note: <+> goes away if param==empty+ CoercCat c _ -> qualify (text c) <+> param+ TokenCat c+ | c `elem` baseTokenCatNames+ -> text c+ | otherwise -> qualify (text c) +-- | Convert a base type to Haskell syntax.+baseTypeToHaskell :: Base -> String+baseTypeToHaskell = show++-- | Convert a function type to Haskell syntax in curried form.+typeToHaskell :: Type -> String+typeToHaskell = typeToHaskell' "->"++typeToHaskell' :: String -> Type -> String+typeToHaskell' arr (FunT ts t) =+ foldr f (baseTypeToHaskell t) $ map baseTypeToHaskell ts+ where f a b = unwords [a, arr, b]++-- | Make a variable name for a category.+catToVar :: Cat -> String+catToVar = avoidReservedWords . var+ where+ var (ListCat cat) = var cat ++ "s"+ var (Cat "Ident") = "x"+ var (Cat "Integer") = "n"+ var (Cat "String") = "str"+ var (Cat "Char") = "c"+ var (Cat "Double") = "d"+ var xs = map toLower $ catToStr xs -- | Gives a list of variables usable for pattern matching. --
src/BNFC/Backend/HaskellGADT.hs view
@@ -54,27 +54,28 @@ errMod = errFileM opts shareMod = shareFileM opts do- mkfile (absFile opts) $ cf2Abstract (byteStrings opts) absMod cf composOpMod+ mkfile (absFile opts) $ cf2Abstract (tokenText opts) absMod cf composOpMod mkfile (composOpFile opts) $ composOp composOpMod case alexMode opts of Alex1 -> do- mkfile (alexFile opts) $ cf2alex lexMod errMod cf+ mkfile (alexFile opts) $ cf2alex lexMod 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.)"+ mkfile (alexFile opts) $ cf2alex2 lexMod shareMod (shareStrings opts) (tokenText opts) cf+ liftIO $ putStrLn " (Use Alex 2 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 (alexFile opts) $ cf2alex3 lexMod shareMod (shareStrings opts) (tokenText opts) cf+ liftIO $ putStrLn " (Use Alex 3 to compile.)" mkfile (happyFile opts) $- cf2Happy parMod absMod lexMod errMod (glr opts) (byteStrings opts) False cf- liftIO $ putStrLn " (Tested with Happy 1.15)"- mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod errMod cf- mkfile (printerFile opts) $ cf2Printer False False True prMod absMod cf- when (hasLayout cf) $ mkfile (layoutFile opts) $ cf2Layout (alexMode opts == Alex1) (inDir opts) layMod lexMod cf+ cf2Happy parMod absMod lexMod (glr opts) (tokenText opts) False cf+ liftIO $ putStrLn " (Tested with Happy 1.15 - 1.20)"+ mkfile (templateFile opts) $ cf2Template (templateFileM opts) absMod cf+ mkfile (printerFile opts) $ cf2Printer StringToken False True prMod absMod cf+ when (hasLayout cf) $ mkfile (layoutFile opts) $+ cf2Layout (tokenText opts) (alexMode opts == Alex1) layMod lexMod cf mkfile (tFile opts) $ Haskell.testfile opts cf- mkfile (errFile opts) $ mkErrM errMod (ghcExtensions opts)- when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (byteStrings opts) cf+ mkfile (errFile opts) $ mkErrM errMod+ when (shareStrings opts) $ mkfile (shareFile opts) $ sharedString shareMod (tokenText opts) cf Makefile.mkMakefile opts $ Haskell.makefile opts case xml opts of 2 -> makeXML opts True cf
src/BNFC/Backend/HaskellGADT/CFtoAbstractGADT.hs view
@@ -21,68 +21,92 @@ module BNFC.Backend.HaskellGADT.CFtoAbstractGADT (cf2Abstract) where -import BNFC.CF-import BNFC.Utils((+++))-import Data.List(intercalate, nub)+import qualified Data.List as List +import BNFC.CF import BNFC.Backend.HaskellGADT.HaskellGADTCommon+import BNFC.Backend.Haskell.Utils+import BNFC.Backend.Haskell.CFtoAbstract (definedRules)+import BNFC.Options+import BNFC.Utils ((+++), when) --- to produce a Haskell module-cf2Abstract :: Bool -> String -> CF -> String -> String-cf2Abstract byteStrings name cf composOpMod = unlines $ [- "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}",- "module" +++ name +++ "(" ++ intercalate ", " 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] +cf2Abstract :: TokenText -> String -> CF -> String -> String+cf2Abstract tokenText name cf composOpMod = unlines $ concat $+ [ [ "{-# LANGUAGE GADTs, KindSignatures, DataKinds #-}"+ , "{-# LANGUAGE EmptyCase #-}"+ , ""+ , "module" +++ name +++ "(" ++ List.intercalate ", " exports ++ ")" +++ "where"+ , ""+ , "import Prelude (" ++ typeImports ++ ", (.), (>), (&&), (==))"+ , "import qualified Prelude as P"+ , "import qualified Data.Monoid as P"+ , ""+ , "import " ++ composOpMod+ ]+ , tokenTextImport tokenText+ , [ ""+ , "-- Haskell module generated by the BNF converter"+ , ""+ ]+ , prDummyTypes cf+ , [""]+ , prTreeType tokenText cf+ , [""]+ , prCompos cf+ , [""]+ , prShow cf+ , [""]+ , prEq cf+ , [""]+ , prOrd cf+ , [""]+ , map ((++ "\n") . show) $ definedRules False cf+ ]+ where+ exports = concat $+ [ [ "Tree(..)" ]+ , getTreeCats cf+ , map mkDefName $ getDefinitions cf+ , [ "johnMajorEq"+ , "module " ++ composOpMod+ ]+ ]+ typeImports = List.intercalate ", " $ concat+ [ [ "Char", "Double" ]+ , [ "Int" | hasPositionTokens cf ]+ , [ "Integer", "String" ]+ ]+ getTreeCats :: CF -> [String]-getTreeCats cf = nub $ map show $ filter (not . isList) $ map consCat $ cf2cons cf+getTreeCats cf = List.nub $ map show $ filter (not . isList) $ map consCat $ cf2cons cf +getDefinitions :: CF -> [String]+getDefinitions cf = [ funName f | FunDef f _ _ <- cfgPragmas cf ]+ prDummyTypes :: CF -> [String] prDummyTypes cf = prDummyData : map prDummyType cats where cats = getTreeCats cf- prDummyData = "data Tag =" +++ intercalate " | " (map mkRealType cats)+ prDummyData+ | null cats = "data Tag"+ | otherwise = "data Tag =" +++ List.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 =+prTreeType :: TokenText -> CF -> [String]+prTreeType tokenText cf = "data Tree :: Tag -> * where" : map ((" " ++) . prTreeCons) (cf2cons cf) where prTreeCons c | TokenCat tok <- cat, isPositionCat cf tok =- fun +++ ":: ((Int,Int),"++stringType++") -> Tree" +++ mkRealType tok+ fun +++ ":: ((Int,Int),"++ tokenTextType tokenText ++") -> Tree" +++ mkRealType tok | 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 =@@ -98,55 +122,59 @@ 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 (\\ x z -> r (:) `a` f x `a` z) (r [])" +++ var+ | isList cat = "`a` P.foldr (\\ x z -> r (:) `a` f x `a` z) (r [])" +++ var | otherwise = "`a`" +++ "f" +++ var prShow :: CF -> [String]-prShow cf = ["instance Show (Tree c) where",+prShow cf = ["instance P.Show (Tree c) where", " showsPrec n t = case t of"] ++ map ((" "++) .prShowCons) cs- ++ [" where opar n = if n > 0 then showChar '(' else id",- " cpar n = if n > 0 then showChar ')' else id"]+ ++ [" where opar n = if n > 0 then P.showChar '(' else P.id",+ " cpar n = if n > 0 then P.showChar ')' else P.id"] where cs = cf2cons cf- prShowCons c | null vars = fun +++ "->" +++ "showString" +++ show fun+ prShowCons c | null vars = fun +++ "->" +++ "P.showString" +++ show fun | otherwise = fun +++ unwords (map snd vars) +++ "->"- +++ "opar n . showString" +++ show fun- +++ unwords [". showChar ' ' . showsPrec 1 " ++ x | (_,x) <- vars]+ +++ "opar n . P.showString" +++ show fun+ +++ unwords [". P.showChar ' ' . P.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",+prEq cf = ["instance P.Eq (Tree c) where (==) = johnMajorEq", "",- "johnMajorEq :: Tree a -> Tree b -> Bool"]+ "johnMajorEq :: Tree a -> Tree b -> P.Bool"] ++ map prEqCons (cf2cons cf)- ++ ["johnMajorEq _ _ = False"]+ ++ ["johnMajorEq _ _ = P.False"] where prEqCons c- | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "True"+ | null vars = "johnMajorEq" +++ fun +++ fun +++ "=" +++ "P.True" | otherwise = "johnMajorEq" +++ "(" ++ fun +++ unwords vars ++ ")" +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "="- +++ intercalate " && " (zipWith (\x y -> x +++ "==" +++ y) vars vars')+ +++ List.intercalate " && " (zipWith (\x y -> x +++ "==" +++ y) vars vars') where (fun, vars) = (consFun c, map snd (consVars c))- vars' = map (++"_") vars+ 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 mkIndex cs [0..] ++- ["compareSame :: Tree c -> Tree c -> Ordering"] ++- map mkCompareSame cs ++- ["compareSame x y = error \"BNFC error:\" compareSame"]+prOrd cf = concat+ [ [ "instance P.Ord (Tree c) where"+ , " compare x y = P.compare (index x) (index y) `P.mappend` compareSame x y"+ ]+ , [ "", "index :: Tree c -> P.Int" ]+ , zipWith mkIndex cs [0..]+ , when (null cs) [ "index = P.undefined" ]+ , [ "", "compareSame :: Tree c -> Tree c -> P.Ordering" ]+ , map mkCompareSame cs+ , [ "compareSame x y = P.error \"BNFC error:\" compareSame" ]+ ] where cs = cf2cons cf mkCompareSame c- | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "EQ"+ | null vars = "compareSame" +++ fun +++ fun +++ "=" +++ "P.EQ" | otherwise = "compareSame" +++ "(" ++ fun +++ unwords vars ++ ")" +++ "(" ++ fun +++ unwords vars' ++ ")" +++ "="- +++ foldr1 (\x y -> "mappend (" ++ x ++") ("++y++")") cc+ +++ foldr1 (\x y -> "P.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'+ cc = zipWith (\x y -> "P.compare"+++x+++y) vars vars' mkIndex c i = "index" +++ "(" ++ consFun c +++ unwords (replicate (length (consVars c)) "_") ++ ")" +++ "=" +++ show i
src/BNFC/Backend/HaskellGADT/CFtoTemplateGADT.hs view
@@ -20,45 +20,54 @@ module BNFC.Backend.HaskellGADT.CFtoTemplateGADT (cf2Template) where +import Data.List ( groupBy )+ import BNFC.CF-import BNFC.Utils((+++))-import Data.List (groupBy)+import BNFC.Utils ( ModuleName, (+++) ) import BNFC.Backend.HaskellGADT.HaskellGADTCommon -type ModuleName = String+cf2Template :: ModuleName -> ModuleName -> CF -> String+cf2Template skelName absName cf = unlines $ concat+ [ [ "{-# LANGUAGE GADTs #-}"+ , "{-# LANGUAGE EmptyCase #-}"+ , ""+ , "module "++ skelName ++ " where"+ , ""+ , "-- Haskell module generated by the BNF converter"+ , ""+ , "import qualified " ++ absName+ , ""+ , "type Err = Either String"+ , "type Result = Err String"+ , ""+ , "failure :: Show a => a -> Result"+ , "failure x = Left $ \"Undefined case: \" ++ show x"+ , ""+ , "transTree :: " ++ qualify "Tree" ++ " c -> Result"+ , "transTree t = case t of"+ ]+ , map prConsCase (cf2cons cf)+ , [ "" ]+ , concatMap ((++ [""]) . uncurry prCatTrans) (catCons cf)+ ]+ where+ prCatTrans :: Cat -> [Constructor] -> [String]+ prCatTrans cat cs = concat+ [ [ "trans" ++ show cat +++ "::" +++ qualify (show cat) +++ "-> Result"+ , "trans" ++ show cat +++ "t = case t of"+ ]+ , map prConsCase cs+ ] -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 =+ " " ++ qualify (consFun c) +++ unwords (map snd (consVars c)) +++ "-> failure t" -prConsCase :: Constructor -> String-prConsCase c =- " " ++ consFun c +++ unwords (map snd (consVars c)) +++ "-> failure t"+ qualify x = concat [ absName, ".", x ] catCons :: CF -> [(Cat,[Constructor])] catCons cf = [ (consCat (head cs),cs) | cs <- groupBy catEq $ cf2cons cf] catEq :: Constructor -> Constructor -> Bool catEq c1 c2 = consCat c1 == consCat c2--prCatTrans :: Cat -> [Constructor] -> [String]-prCatTrans cat cs = ["trans" ++ show cat +++ "::" +++ show cat +++ "-> Result"- , "trans" ++ show cat +++ "t = case t of"]- ++ map prConsCase cs
src/BNFC/Backend/HaskellGADT/HaskellGADTCommon.hs view
@@ -20,8 +20,8 @@ module BNFC.Backend.HaskellGADT.HaskellGADTCommon (Constructor(..), cf2cons, isTreeType) where import BNFC.CF +import BNFC.Backend.Haskell.Utils ( catToVar ) -import Data.Char data Constructor = Constructor { consCat :: Cat @@ -48,26 +48,9 @@ mkUnique (x:xs) n | x `elem` 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 | s `elem` 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) $ cfgRules cf +ruleFun cf f = head $ filter ((f ==) . funName . funRule) $ cfgRules cf -- | Get the precedence of a function. precFun :: CF -> Fun -> Integer @@ -81,4 +64,4 @@ isTreeType cf (TokenCat c) = c `elem` specialCats cf isTreeType cf c | isList c = isTreeType cf (catOfList c) - | otherwise = c `elem` allCats cf + | otherwise = c `elem` reallyAllCats cf
src/BNFC/Backend/HaskellProfile.hs view
@@ -28,6 +28,7 @@ import BNFC.Backend.HaskellProfile.CFtoHappyProfile import BNFC.Backend.Haskell.CFtoAlex import BNFC.Backend.Haskell.CFtoAlex2+import BNFC.Backend.Haskell.CFtoAlex3 import BNFC.Backend.Haskell.MkErrM -- naming conventions@@ -65,14 +66,18 @@ let cf = cfp2cf cfp do ---- mkfile (absFile (inDir opts) name) $ cf2Abstract (absFileM (inDir opts) name) cf- if alexMode opts == Alex1 then do- mkfile (alexFile (inDir opts) name) $ cf2alex lexMod errMod cf- liftIO $ putStrLn " (Use Alex 1.1 to compile.)"- else do- mkfile (alexFile (inDir opts) name) $ cf2alex2 lexMod errMod "" False False cf- liftIO $ putStrLn " (Use Alex 2.0 to compile.)"+ case alexMode opts of+ Alex1 -> do+ mkfile (alexFile (inDir opts) name) $ cf2alex lexMod cf+ liftIO $ putStrLn " (Use Alex 1.1 to compile.)"+ Alex2 -> do+ mkfile (alexFile (inDir opts) name) $ cf2alex2 lexMod "" False StringToken cf+ liftIO $ putStrLn " (Use Alex 2 to compile.)"+ Alex3 -> do+ mkfile (alexFile (inDir opts) name) $ cf2alex3 lexMod "" False StringToken cf+ liftIO $ putStrLn " (Use Alex 3 to compile.)" mkfile (happyFile (inDir opts) name) $- cf2HappyProfileS parMod absMod lexMod errMod cfp+ cf2HappyProfileS parMod absMod lexMod cfp liftIO $ putStrLn " (Tested with Happy 1.13)" ---- mkfile (templateFile (inDir opts) name) $ ---- cf2Template tplMod absMod errMod cf@@ -81,7 +86,7 @@ ---- mkfile (layoutFile (inDir opts) name) $ cf2Layout alex1 (inDir opts) layMod lexMod cf ---- else return () mkfile (tFile (inDir opts) name) $ testfile (inDir opts) name (xml opts>0) cf- mkfile (errFile (inDir opts) name) $ mkErrM errMod (ghcExtensions opts)+ mkfile (errFile (inDir opts) name) $ mkErrM errMod when (isJust $ make opts) (mkfile (mFile (inDir opts) name) $ makefile (inDir opts) name) ---- case xml of@@ -128,10 +133,7 @@ testfile :: Bool -> String -> Bool -> CF -> String-testfile inDir name _ cf = makeA where-- makeA = let lay = hasLayout cf- in unlines+testfile inDir name _ cf = unlines ["-- automatically generated by BNF Converter", "module Main where\n", "",@@ -148,9 +150,9 @@ ---- "import " ++ absFileM inDir name, ---- if lay then ("import " ++ layoutFileM inDir name) else "", ---- if xml then ("import " ++ xmlFileM inDir name) else "",- "import " ++ errFileM inDir name,+---- "import " ++ errFileM inDir name, "",- "type ParseFun = [Token] -> Err CFTree",+ "type ParseFun = [Token] -> Either String CFTree", "", "myLLexer = " ++ if lay then "resolveLayout True . myLexer" else "myLexer",@@ -158,25 +160,25 @@ "runFile :: ParseFun -> FilePath -> IO ()", "runFile p f = readFile f >>= run p", "",- "run :: ParseFun -> String -> IO ()",+ "run :: ParseFun -> String -> IO ()", "run p s = do", " let ts = myLLexer s", " let etree = p ts", " case etree of",- " Ok tree -> do",+ " Right tree -> do", " case postParse tree of",- " Bad s -> do",+ " Left s -> do", " putStrLn \"\\nParse Failed... CFTree:\\n\"", " putStrLn $ prCFTree tree", " putStrLn s",- " Ok tree -> do",+ " Right tree -> do", " putStrLn \"\\nParse Successful!\"", " putStrLn $ \"\\n[Abstract Syntax]\\n\\n\" ++ prt tree",- " Bad s -> do",+ " Left s -> do", " putStrLn s", " putStrLn \"\\nParse failed... tokenization:\"", " print ts",- "",+ "", "usage :: IO ()", "usage = do", " putStrLn $ unlines",@@ -197,4 +199,6 @@ " _ -> do progName <- getProgName", " putStrLn $ progName ++ \": excess arguments.\"" ]- where firstParser = 'p' : identCat (firstEntry cf)+ where+ firstParser = 'p' : identCat (firstEntry cf)+ lay = hasLayout cf
src/BNFC/Backend/HaskellProfile/CFtoHappyProfile.hs view
@@ -19,10 +19,11 @@ module BNFC.Backend.HaskellProfile.CFtoHappyProfile (cf2HappyProfileS) where -import BNFC.CF---import Lexer import Data.List (intersperse) +import BNFC.CF+import BNFC.Utils (for)+ -- Type declarations type Rules = [(NonTerminal,[(Pattern,Action)])]@@ -36,13 +37,13 @@ -- 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 :: String -> String -> String -> CFP -> String cf2HappyProfileS = cf2Happy -cf2Happy :: String -> String -> String -> String -> CFP -> String-cf2Happy name absName lexName errName cf+cf2Happy :: String -> String -> String -> CFP -> String+cf2Happy name absName lexName cf = unlines- [header name absName lexName errName,+ [header name absName lexName, declarations (allEntryPoints cf), tokens (cfgSymbols cf ++ reservedWords cf), specialToks cf,@@ -52,14 +53,13 @@ finalize cf] -- construct the header.-header :: String -> String -> String -> String -> String-header modName _ lexName errName = unlines+header :: String -> String -> String -> String+header modName _ lexName = unlines [ "-- This Happy file was machine-generated by the BNF converter" , "{" , "module " ++ modName ++ " where" , "import Trees" , "import " ++ lexName- , "import " ++ errName , "}" ] @@ -67,12 +67,14 @@ -- 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+ [ generateP ns+ , "%monad { Either String } { (>>=) } { return }"+ , "%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@@ -97,26 +99,17 @@ escape (x:xs) = x:escape xs rulesForHappy :: CFP -> Rules-rulesForHappy cf = map mkOne $ ruleGroupsP cf where- mkOne (cat,rules) = constructRule cf rules cat+rulesForHappy cf = for (ruleGroupsP cf) $ \ (cat,rules) ->+ (cat, 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 _ = ---- if b then ("flip " ++ funRuleP r) else (funRuleP r)- funRule- revs = cfgReversibleCats cf+-- terminals and non-terminals, and an action to be performed.+constructRule :: CFP -> [RuleP] -> NonTerminal -> [(Pattern,Action)]+constructRule cf rules nt =+ [ (p, generateAction nt (funRule r) m)+ | r <- rules+ , let (p, m) = generatePatterns cf r+ ] -- Generates a string containing the semantic action. -- An action can for example be: Sum $1 $2, that is, construct an AST@@ -132,18 +125,14 @@ -- where in the pattern the non-terminal generatePatterns :: CFP -> RuleP -> (Pattern,[MetaVar])-generatePatterns cf r = case rhsRule r of+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 = cfgReversibleCats cf+ metas its = [ ('$': 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.@@ -167,13 +156,9 @@ finalize _ = 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 ++ " +++ "\nhappyError :: [" ++ tokenName ++ "] -> Either String a",+ "happyError ts = Left $",+ " \"syntax error at \" ++ tokenPos ts ++ " ++ "if null ts then [] else " ++ "(\" before \" ++ " ++ "unwords (map prToken (take 4 ts)))", "\nmyLexer = tokens",
src/BNFC/Backend/Java.hs view
@@ -37,7 +37,7 @@ module BNFC.Backend.Java ( makeJava ) where -import Prelude'+import Prelude hiding ((<>)) import System.FilePath (pathSeparator, isPathSeparator) import Data.List ( intersperse )@@ -68,12 +68,15 @@ -- | This creates the Java files. makeJava :: SharedOptions -> CF -> MkFiles ()-makeJava options@Options{..} cf = do+makeJava opt = makeJava' opt{ lang = mkName javaReserved SnakeCase $ lang opt }+ -- issue #212: make a legal package name, see also+ -- https://docs.oracle.com/javase/tutorial/java/package/namingpkgs.html++makeJava' :: SharedOptions -> CF -> MkFiles ()+makeJava' options@Options{..} cf = do -- Create the package directories if necessary.- let packageBase = case inPackage of- Nothing -> lang- Just p -> p ++ "." ++ lang- packageAbsyn = packageBase ++ "." ++ "Absyn"+ let packageBase = maybe id (+.+) inPackage lang+ packageAbsyn = packageBase +.+ "Absyn" dirBase = pkgToDir packageBase dirAbsyn = pkgToDir packageAbsyn javaex str = dirBase ++ str +.+ "java"@@ -111,8 +114,8 @@ let (lex, env) = lexfun packageBase cf -- Where the lexer file is created. lex is the content! mkfile (dirBase ++ inputfile lexmake ) lex- liftIO $ putStrLn $ " (Tested with "+++ toolname lexmake- +++ toolversion lexmake +++")"+ liftIO $ putStrLn $ " (Tested with" +++ toolname lexmake+ +++ toolversion lexmake ++ ")" -- where the parser file is created. mkfile (dirBase ++ inputfile parmake) $ parsefun packageBase packageAbsyn cf rp env@@ -120,8 +123,8 @@ if supportsEntryPoints parmake then "(Parser created for all categories)" else " (Parser created only for category " ++ show (firstEntry cf) ++ ")"- liftIO $ putStrLn $ " (Tested with " +++ toolname parmake- +++ toolversion parmake +++ ")"+ liftIO $ putStrLn $ " (Tested with" +++ toolname parmake+ +++ toolversion parmake ++ ")" Makefile.mkMakefile options $ makefile dirBase dirAbsyn absynFileNames parselexspec where@@ -227,6 +230,7 @@ absynJavaClass = unwords (dotClass absynFileNames) classes = prependPath dirBase lst lst = dotClass (results lexmake) ++ [ "PrettyPrinter.class", "Test.class"+ , "VisitSkel.class" , "ComposVisitor.class", "AbstractVisitor.class" , "FoldVisitor.class", "AllVisitor.class"]++ dotClass (results parmake) ++ ["Test.class"]@@ -307,15 +311,11 @@ , jtpInvocation = \ pbase pabs dat enti -> vcat [- let rulename = getRuleName (show enti)+ let rulename = getRuleName $ startSymbol $ render enti typename = text rulename methodname = text $ firstLowerCase rulename in pbase <> "." <> typename <> "Context pc = p." <> methodname <> "();"- , "org.antlr.v4.runtime.Token _tkn = p.getInputStream().getTokenSource().nextToken();"- , "if(_tkn.getType() != -1) throw new TestError"- <> "(\"Stream does not end with EOF\","- <> "_tkn.getLine(),_tkn.getCharPositionInLine());" , pabs <> "." <> dat <+> "ast = pc.result;" ] , jtpErrMsg =@@ -460,7 +460,7 @@ , filename = "Yylex" , fileextension = "" , toolname = "JLex"- , toolversion = "1.2.6."+ , toolversion = "1.2.6" , supportsEntryPoints = False , results = ["Yylex"] , other_results = []@@ -470,7 +470,7 @@ jflexmakedetails = jlexmakedetails { executable = "jflex" , toolname = "JFlex"- , toolversion = "1.4.3"+ , toolversion = "1.4.3 - 1.7.0" } cupmakedetails rp = MakeDetails@@ -577,11 +577,12 @@ cf = render $ vcat $ concat $ [ [ "package" <+> text packageBase <> ";"+ , "" , "import" <+> text packageBase <> ".*;"- , "import" <+> text packageAbsyn <> ".*;" , "import java.io.*;" ] , map importfun imports+ , [ "" ] , errhand err , [ "" , "public class Test"@@ -594,14 +595,13 @@ [ "try" , codeblock 2 [ "Reader input;"- , "if (args.length == 0)"- <> "input = new InputStreamReader(System.in);"+ , "if (args.length == 0) input = new InputStreamReader(System.in);" , "else input = new FileReader(args[0]);"- , "l = new "<>lexerconstruction lx "(input)"+ , "l = new " <> lexerconstruction lx "(input)" ] , "catch(IOException e)"- , codeblock 2 [ "System.err.println"- <>"(\"Error: File not found: \" + args[0]);"+ , codeblock 2+ [ "System.err.println(\"Error: File not found: \" + args[0]);" , "System.exit(1);" ] , "p = new "<> parserconstruction px "l"@@ -609,26 +609,32 @@ , "" , "public" <+> text packageAbsyn <> "." <> dat <+> "parse() throws Exception"- , codeblock 2- [ "/* The default parser is the first-defined entry point. */"- , "/* Other options are: */"- , "/* " <> fsep (punctuate "," (showOpts (tail eps))) <> " */"- , invocation px (text packageAbsyn) dat absentity- , printOuts [ "\"Parse Succesful!\""- , "\"[Abstract Syntax]\""- , "PrettyPrinter.show(ast)"- , "\"[Linearized Tree]\""- , "PrettyPrinter.print(ast)"- ]- , "return ast;"+ , codeblock 2 $ concat+ [ [ "/* The default parser is the first-defined entry point. */" ]+ , unlessNull (drop 1 eps) $ \ eps' ->+ [ "/* Other options are: */"+ , "/* " <> fsep (punctuate "," (showOpts eps')) <> " */"+ ]+ , [ invocation px (text packageAbsyn) dat absentity+ , printOuts+ [ "\"Parse Succesful!\""+ , "\"[Abstract Syntax]\""+ , "PrettyPrinter.show(ast)"+ , "\"[Linearized Tree]\""+ , "PrettyPrinter.print(ast)"+ ]+ , "return ast;"+ ] ] , "" , "public static void main(String args[]) throws Exception"- , codeblock 2 [ "Test t = new Test(args);"+ , codeblock 2+ [ "Test t = new Test(args);" , "try" , codeblock 2 [ "t.parse();" ]- ,"catch("<>text err<+>"e)"- , codeblock 2 [ "System.err.println(\""<>text errmsg<>"\");"+ ,"catch(" <> text err <+> "e)"+ , codeblock 2+ [ "System.err.println(\"" <> text errmsg <> "\");" , "System.err.println(\" \" + e.getMessage());" , "System.exit(1);" ]
src/BNFC/Backend/Java/CFtoAbstractVisitor.hs view
@@ -25,33 +25,37 @@ import BNFC.Backend.Common.NamedVariables cf2AbstractVisitor :: String -> String -> CF -> String-cf2AbstractVisitor packageBase packageAbsyn cf =- unlines [ "package" +++ packageBase ++ ";"- , "import" +++ packageAbsyn ++ ".*;"+cf2AbstractVisitor packageBase packageAbsyn cf = unlines+ [ "package" +++ packageBase ++ ";"+ , "" , "/** BNFC-Generated Abstract Visitor */"+ , "" , "public class AbstractVisitor<R,A> implements AllVisitor<R,A> {" , concatMap (prData packageAbsyn user) groups- , "}"]+ , "}"+ ] where- user = fst (unzip (tokenPragmas cf))+ user = map fst $ 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+prData packageAbsyn user (cat, rules) = unlines $ concat+ [ [ " /* " ++ identCat cat ++ " */" ]+ , concatMap (prRule packageAbsyn user cat) rules+ , [ " public R visitDefault(" ++ packageAbsyn ++ "." ++ identCat cat ++ " p, A arg) {"+ , " throw new IllegalArgumentException(this.getClass()" ++ ".getName() + \": \" + p);"+ , " }"+ ]+ ] --traverses a standard rule.-prRule :: String -> [UserDef] -> Cat -> Rule -> String-prRule packageAbsyn _ _ (Rule fun _ _)- | not (isCoercion fun || isDefinedRule fun) =- " public R visit(" ++ cls ++ " p, A arg) { return visitDefault(p, arg); }"- where cls = packageAbsyn ++ "." ++ fun-prRule _ _ _ _ = ""+prRule :: String -> [UserDef] -> Cat -> Rule -> [String]+prRule packageAbsyn _ _ (Rule fun _ _ _)+ | not (isCoercion fun || isDefinedRule fun) = return $ concat+ [ " public R visit("+ , packageAbsyn ++ "." ++ funName fun+ , " p, A arg) { return visitDefault(p, arg); }"+ ]+ | otherwise = []
src/BNFC/Backend/Java/CFtoAllVisitor.hs view
@@ -27,16 +27,16 @@ cf2AllVisitor :: String -> String -> CF -> String-cf2AllVisitor packageBase packageAbsyn cf =- unlines [- "package" +++ packageBase ++ ";",- "",- "import" +++ packageAbsyn ++ ".*;",- "",- "/** BNFC-Generated All Visitor */",- "public interface AllVisitor<R,A> extends",- intercalate ",\n" $ map (" "++) is,- "{}"]+cf2AllVisitor packageBase packageAbsyn cf = unlines $ concat+ [ [ "package" +++ packageBase ++ ";"+ , ""+ , "/** BNFC-Generated All Visitor */"+ , ""+ , "public interface AllVisitor<R,A>" ++ if null is then "" else " extends"+ ]+ , [ intercalate ",\n" $ map (" "++) is | not $ null is ]+ , [ "{}" ]+ ] where groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf), not (isList c) ]
src/BNFC/Backend/Java/CFtoAntlr4Lexer.hs view
@@ -40,7 +40,7 @@ module BNFC.Backend.Java.CFtoAntlr4Lexer ( cf2AntlrLex ) where -import Prelude'+import Prelude hiding ((<>)) import Text.PrettyPrint import BNFC.CF@@ -54,7 +54,7 @@ -- This introduces risks of clashes if somebody uses the same identifier for -- user defined tokens. This is not handled. -- returns the environment because the parser uses it.-cf2AntlrLex :: String -> CF -> (Doc, SymEnv)+cf2AntlrLex :: String -> CF -> (Doc, KeywordEnv) cf2AntlrLex packageBase cf = (vcat [ prelude packageBase , cMacros@@ -102,7 +102,7 @@ -- bar : '/' ; -- >>> lexSymbols [("~","bar")] -- bar : '~' ;-lexSymbols :: SymEnv -> Doc+lexSymbols :: KeywordEnv -> Doc lexSymbols ss = vcat $ map transSym ss where transSym (s,r) = text r <> " : '" <> text (escapeChars s) <> "' ;"
src/BNFC/Backend/Java/CFtoAntlr4Parser.hs view
@@ -37,29 +37,58 @@ ************************************************************** -}++{-# LANGUAGE LambdaCase #-}+ module BNFC.Backend.Java.CFtoAntlr4Parser ( cf2AntlrParse ) where -import Data.List+import Data.List ( intercalate )+import Data.Maybe+ import BNFC.CF+import BNFC.Options ( RecordPositions(..) )+import BNFC.Utils ( (+++), (+.+), applyWhen )+ import BNFC.Backend.Java.Utils import BNFC.Backend.Common.NamedVariables-import BNFC.Options (RecordPositions(..))-import BNFC.Utils ( (+++), (+.+))+import BNFC.Backend.Java.CFtoCup15 ( definedRules ) -- Type declarations-type Rules = [(NonTerminal,[(Pattern, Fun, Action)])]++-- | A definition of a non-terminal by all its rhss,+-- together with parse actions.+data PDef = PDef+ { _pdNT :: Maybe String+ -- ^ If given, the name of the lhss. Usually computed from 'pdCat'.+ , _pdCat :: Cat+ -- ^ The category to parse.+ , _pdAlts :: [(Pattern, Action, Maybe Fun)]+ -- ^ The possible rhss with actions. If 'null', skip this 'PDef'.+ -- Where 'Nothing', skip ANTLR rule label.+ }+type Rules = [PDef] type Pattern = String type Action = String type MetaVar = (String, Cat) -- | Creates the ANTLR parser grammar for this CF. --The environment comes from CFtoAntlr4Lexer-cf2AntlrParse :: String -> String -> CF -> RecordPositions -> SymEnv -> String-cf2AntlrParse packageBase packageAbsyn cf _ env = unlines- [ header+cf2AntlrParse :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String+cf2AntlrParse packageBase packageAbsyn cf _ env = unlines $ concat+ [ [ header , tokens- , prRules packageAbsyn (rulesForAntlr4 packageAbsyn cf env)+ , "@members {" ]+ , map (" " ++) $ definedRules packageAbsyn cf+ , [ "}"+ , ""+ -- Generate start rules [#272]+ -- _X returns [ dX result ] : x=X EOF { $result = $x.result; }+ , prRules packageAbsyn $ map entrypoint $ allEntryPoints cf+ -- Generate regular rules+ , prRules packageAbsyn $ rulesForAntlr4 packageAbsyn cf env+ ]+ ] where header :: String header = unlines@@ -74,9 +103,22 @@ ] identifier = getLastInPackage packageBase +-- | Generate start rule to help ANTLR.+--+-- @start_X returns [ X result ] : x=X EOF { $result = $x.result; } # Start_X@+--+entrypoint :: Cat -> PDef+entrypoint cat =+ PDef (Just nt) cat [(pat, act, fun)]+ where+ nt = firstLowerCase $ startSymbol $ identCat cat+ pat = "x=" ++ catToNT cat +++ "EOF"+ act = "$result = $x.result;"+ fun = Nothing -- No ANTLR Rule label, ("Start_" ++ identCat cat) conflicts with lhs.+ --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForAntlr4 :: String -> CF -> SymEnv -> Rules+rulesForAntlr4 :: String -> CF -> KeywordEnv -> Rules rulesForAntlr4 packageAbsyn cf env = map mkOne getrules where getrules = ruleGroups cf@@ -84,21 +126,27 @@ -- | 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, Fun, Action)])+constructRule :: String -> CF -> KeywordEnv -> [Rule] -> NonTerminal -> PDef constructRule packageAbsyn cf env rules nt =- (nt, [ (p , funRule r , generateAction packageAbsyn nt (funRule r) (revM b m) b)- | (index ,r0) <- zip [1..(length rules)] rules,- let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs- then (True, revSepListRule r0)- else (False, r0)- (p,m) = generatePatterns index env r])- where- revM False = id- revM True = reverse- revs = cfgReversibleCats cf+ PDef Nothing nt $+ [ ( p+ , generateAction packageAbsyn nt (funRule r) m b+ , Nothing -- labels not needed for BNFC-generated AST parser+ -- , Just label+ -- -- Did not work:+ -- -- , if firstLowerCase (getLabelName label)+ -- -- == getRuleName (firstLowerCase $ identCat nt) then Nothing else Just label+ )+ | (index, r0) <- zip [1..] rules+ , let b = isConsFun (funRule r0) && elem (valCat r0) (cfgReversibleCats cf)+ , let r = applyWhen b revSepListRule r0+ , let (p,m0) = generatePatterns index env r+ , let m = applyWhen b reverse m0+ -- , let label = funRule r+ ] -- Generates a string containing the semantic action.-generateAction :: String -> NonTerminal -> Fun -> [MetaVar]+generateAction :: IsFun f => String -> NonTerminal -> f -> [MetaVar] -> Bool -- ^ Whether the list should be reversed or not. -- Only used if this is a list rule. -> Action@@ -109,14 +157,14 @@ | isConsFun f = "$result = " ++ p_2 ++ "; " ++ "$result." ++ add ++ "(" ++ p_1 ++ ");" | isCoercion f = "$result = " ++ p_1 ++ ";"- | isDefinedRule f = "$result = parser." ++ f ++ "_"+ | isDefinedRule f = "$result = " ++ funName f ++ "_" ++ "(" ++ intercalate "," (map resultvalue ms) ++ ");" | otherwise = "$result = new " ++ c ++ "(" ++ intercalate "," (map resultvalue ms) ++ ");" where c = packageAbsyn ++ "." ++ if isNilFun f || isOneFun f || isConsFun f- then identCat (normCat nt) else f+ then identCat (normCat nt) else funName f p_1 = resultvalue $ ms!!0 p_2 = resultvalue $ ms!!1 add = if rev then "addLast" else "addFirst"@@ -136,67 +184,67 @@ -- | Generate patterns and a set of metavariables indicating -- where in the pattern the non-terminal--- >>> generatePatterns 2 [] (Rule "myfun" (Cat "A") [])+-- >>> generatePatterns 2 [] $ npRule "myfun" (Cat "A") [] Parsable -- (" /* empty */ ",[])--- >>> generatePatterns 3 [("def", "_SYMB_1")] (Rule "myfun" (Cat "A") [Right "def", Left (Cat "B")])--- ("_SYMB_1 p_3_2=b ",[("p_3_2",B)])-generatePatterns :: Int -> SymEnv -> Rule -> (Pattern,[MetaVar])-generatePatterns ind env r = case rhsRule r of- [] -> (" /* empty */ ",[])- its -> (mkIt 1 its, metas its)- where- mkIt _ [] = []- mkIt n (i:is) = case i of- Left c -> "p_" ++show ind++"_"++ show (n :: Int) ++ "="++ c'- +++ mkIt (n+1) is- where- c' = case c of- TokenCat "Ident" -> "IDENT"- TokenCat "Integer" -> "INTEGER"- TokenCat "Char" -> "CHAR"- TokenCat "Double" -> "DOUBLE"- TokenCat "String" -> "STRING"- _ -> if isTokenCat c- then identCat c- else firstLowerCase- (getRuleName (identCat c))- Right s -> case lookup s env of- (Just x) -> x +++ mkIt (n+1) is- (Nothing) -> mkIt n is- metas its = [("p_" ++ show ind ++"_"++ show i, category)- | (i,Left category) <- zip [1 :: Int ..] its]+-- >>> generatePatterns 3 [("def", "_SYMB_1")] $ npRule "myfun" (Cat "A") [Right "def", Left (Cat "B")] Parsable+-- ("_SYMB_1 p_3_2=b",[("p_3_2",B)])+generatePatterns :: Int -> KeywordEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns ind env r =+ case rhsRule r of+ [] -> (" /* empty */ ", [])+ its -> ( unwords $ mapMaybe (uncurry mkIt) nits+ , [ (var i, cat) | (i, Left cat) <- nits ]+ )+ where+ nits = zip [1 :: Int ..] its+ var i = "p_" ++ show ind ++"_"++ show i -- TODO: is ind needed for ANTLR?+ mkIt i = \case+ Left c -> Just $ var i ++ "=" ++ catToNT c+ Right s -> lookup s env +catToNT :: Cat -> String+catToNT = \case+ TokenCat "Ident" -> "IDENT"+ TokenCat "Integer" -> "INTEGER"+ TokenCat "Char" -> "CHAR"+ TokenCat "Double" -> "DOUBLE"+ TokenCat "String" -> "STRING"+ c | isTokenCat c -> identCat c+ | otherwise -> firstLowerCase $ getRuleName $ identCat c+ -- | Puts together the pattern and actions and returns a string containing all -- the rules. prRules :: String -> Rules -> String-prRules _ [] = []-prRules packabs ((_, []):rs) = prRules packabs rs-prRules packabs ((nt,(p, fun, a):ls):rs) =- preamble ++ ";\n" ++ prRules packabs rs- where- preamble = unwords [ nt'- , "returns"- , "["- , packabs+.+normcat- , "result"- , "]"- , ":"- , p- , "{"- , a- , "}"- , "#"- , antlrRuleLabel fun- , '\n' : pr ls- ]- alternative (p',fun',a')- = unwords [" |", p', "{", a' , "}", "#"- , antlrRuleLabel fun']- catid = identCat nt- normcat = identCat (normCat nt)- nt' = getRuleName $ firstLowerCase catid- pr [] = []- pr (k:ls) = unlines [alternative k] ++ pr ls+prRules packabs = concatMap $ \case++ -- No rules: skip.+ PDef _mlhs _nt [] -> ""++ -- At least one rule: print!+ PDef mlhs nt (rhs : rhss) -> unlines $ concat++ -- The definition header: lhs and type.+ [ [ unwords [ fromMaybe nt' mlhs+ , "returns" , "[" , packabs+.+normcat , "result" , "]"+ ]+ ]+ -- The first rhs.+ , alternative " :" rhs+ -- The other rhss.+ , concatMap (alternative " |") rhss+ -- The definition footer.+ , [ " ;" ]+ ]+ where+ alternative sep (p, a, label) = concat+ [ [ unwords [ sep , p ] ]+ , [ unwords [ " {" , a , "}" ] ]+ , [ unwords [ " #" , antlrRuleLabel l ] | Just l <- [label] ]+ ]+ catid = identCat nt+ normcat = identCat (normCat nt)+ nt' = getRuleName $ firstLowerCase catid+ antlrRuleLabel :: Fun -> String antlrRuleLabel fnc | isNilFun fnc = catid ++ "_Empty" | isOneFun fnc = catid ++ "_AppendLast"
src/BNFC/Backend/Java/CFtoComposVisitor.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Java 1.5 Compositional Vistor generator Copyright (C) 2006 Bjorn Bringert@@ -20,12 +18,15 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE OverloadedStrings #-}+ module BNFC.Backend.Java.CFtoComposVisitor (cf2ComposVisitor) where -import Prelude'+import Prelude hiding ((<>)) -import Data.List+import Data.List (intercalate) import Data.Either (lefts)+ import BNFC.CF import BNFC.Backend.Java.CFtoJavaAbs15 (typename) import BNFC.Utils ((+++))@@ -33,28 +34,28 @@ import BNFC.PrettyPrint cf2ComposVisitor :: String -> String -> CF -> String-cf2ComposVisitor packageBase packageAbsyn cf =- concat [- header,- concatMap (prData packageAbsyn user) groups,- "}"]+cf2ComposVisitor packageBase packageAbsyn cf = concat+ [ header+ , intercalate "\n" $ map (prData packageAbsyn user) groups+ , "}"+ ] where- user = fst (unzip (tokenPragmas cf))+ user = map fst $ tokenPragmas cf groups = [ g | g@(c,_) <- fixCoercions (ruleGroupsInternals cf) , not (isList c) ] is = map (prInterface packageAbsyn) groups- header = unlines- [ "package" +++ packageBase ++ ";"- , "import" +++ packageAbsyn ++ ".*;"- , "/** BNFC-Generated Composition Visitor"- , "*/"- , ""- , "public class ComposVisitor<A> implements"- , intercalate ",\n" $ map (" "++) is- , "{"+ header = unlines $ concat+ [ [ "package" +++ packageBase ++ ";"+ , "/** BNFC-Generated Composition Visitor"+ , "*/"+ , ""+ , "public class ComposVisitor<A>" ++ if null is then "" else " implements"+ ]+ , [ intercalate ",\n" $ map (" " ++) is | not $ null is ]+ , [ "{" ] ] @@ -67,69 +68,76 @@ prData :: String -> [UserDef] -> (Cat, [Rule]) -> String prData packageAbsyn user (cat, rules) = unlines- [ "/* " ++ identCat cat ++ " */"- , concatMap (render . prRule packageAbsyn user cat) rules+ [ " /* " ++ identCat cat ++ " */"+ , render $ vcat $ map (prRule packageAbsyn user cat) rules ] -- | Traverses a standard rule. ----- >>> prRule "lang.absyn" ["A"] (Cat "B") (Rule "F" (Cat "B") [Left (Cat "A"), Right "+", Left (ListCat (Cat "B"))])--- public B visit(lang.absyn.F p, A arg)+-- >>> prRule "lang.absyn" ["A"] (Cat "B") $ npRule "F" (Cat "B") [Left (Cat "A"), Right "+", Left (ListCat (Cat "B"))] Parsable+-- public lang.absyn.B visit(lang.absyn.F p, A arg) -- { -- String a_ = p.a_;--- ListB listb_ = new ListB();--- for (B x : p.listb_)+-- lang.absyn.ListB listb_ = new lang.absyn.ListB();+-- for (lang.absyn.B x : p.listb_) -- { -- listb_.add(x.accept(this,arg)); -- } -- return new lang.absyn.F(a_, listb_); -- } -prRule :: String -> [UserDef] -> Cat -> Rule -> Doc-prRule packageAbsyn user cat (Rule fun _ cats)+prRule :: IsFun f => String -> [UserDef] -> Cat -> Rul f -> Doc+prRule packageAbsyn user cat (Rule fun _ cats _) | not (isCoercion fun || isDefinedRule fun) = nest 4 $ vcat- [ "public " <> text(identCat cat) <> " visit(" <> cls <> " p, A arg)"+ [ "public " <> qual (identCat cat) <> " visit(" <> cls <> " p, A arg)" , codeblock 2- [ vcat (map (prCat user) cats')- , "return new" <+> cls <> parens (hsep (punctuate "," vnames)) <> ";" ] ]+ [ vcat (map (prCat packageAbsyn user) cats')+ , "return new" <+> cls <> parens (hsep (punctuate "," vnames)) <> ";"+ ]+ ] where- cats' = filter ((/= InternalCat) . fst) (lefts (numVars cats))- cls = text (packageAbsyn ++ "." ++ fun)+ cats' = lefts $ numVars cats+ cls = qual $ funName fun+ qual s = text (packageAbsyn ++ "." ++ s) vnames = map snd cats'-prRule _ _ _ _ = ""+prRule _ _ _ _ = empty -- | Traverses a class's instance variables. ----- >>> prCat ["A"] (Cat "A", "a_")+-- >>> prCat "lang.absyn" ["A"] (Cat "A", "a_") -- String a_ = p.a_; ----- >>> prCat [] (ListCat (Cat "Integer"), "listinteger_")--- ListInteger listinteger_ = p.listinteger_;+-- >>> prCat "lang.absyn" [] (ListCat (Cat "Integer"), "listinteger_")+-- lang.absyn.ListInteger listinteger_ = p.listinteger_; ----- >>> prCat [] (ListCat (Cat "N"), "listn_")--- ListN listn_ = new ListN();--- for (N x : p.listn_)+-- >>> prCat "lang.absyn" [] (ListCat (Cat "N"), "listn_")+-- lang.absyn.ListN listn_ = new lang.absyn.ListN();+-- for (lang.absyn.N x : p.listn_) -- { -- listn_.add(x.accept(this,arg)); -- } ----- >>> prCat [] (Cat "N", "n_")--- N n_ = p.n_.accept(this, arg);+-- >>> prCat "lang.absyn" [] (Cat "N", "n_")+-- lang.absyn.N n_ = p.n_.accept(this, arg); -prCat :: [UserDef] -- ^ User defined token categories- -> (Cat, Doc) -- ^ Variable category and names- -> Doc -- ^ Code for visiting the variable-prCat user (cat, nt)+prCat :: String -- ^ Name of package for abstract syntax.+ -> [UserDef] -- ^ User defined token categories.+ -> (Cat, Doc) -- ^ Variable category and names.+ -> Doc -- ^ Code for visiting the variable.+prCat packageAbsyn user (cat, nt) | isBasicType user varType || (isList cat && isBasicType user et) = decl var- | isList cat = decl ("new" <+> text varType <> "()")- $$ "for (" <> text et <> " x : " <> var <> ")"- $$ codeblock 2 [ nt <> ".add(x.accept(this,arg));" ]+ | isList cat = vcat+ [ decl ("new" <+> text varType <> "()")+ , "for (" <> text et <> " x : " <> var <> ")"+ , codeblock 2 [ nt <> ".add(x.accept(this,arg));" ]+ ] | otherwise = decl (var <> ".accept(this, arg)") where var = "p." <> nt- varType = typename (identCat (normCat cat)) user- et = typename (identCat (normCatOfList cat)) user+ varType = typename packageAbsyn user $ identCat $ normCat cat+ et = typename packageAbsyn user $ identCat $ normCatOfList cat decl v = text varType <+> nt <+> "=" <+> v <> ";"+ -- qual s = text (packageAbsyn ++ "." ++ s) -- | Just checks if something is a basic or user-defined type.
src/BNFC/Backend/Java/CFtoCup15.hs view
@@ -37,17 +37,16 @@ ************************************************************** -}-module BNFC.Backend.Java.CFtoCup15 ( cf2Cup ) where+module BNFC.Backend.Java.CFtoCup15 ( cf2Cup, definedRules ) where import BNFC.CF import Data.List import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.Java.CFtoJavaAbs15 (typename) import BNFC.Options (RecordPositions(..)) 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 Rules = [(NonTerminal,[(Pattern,Action)])]@@ -56,10 +55,10 @@ type MetaVar = String --The environment comes from the CFtoJLex-cf2Cup :: String -> String -> CF -> RecordPositions -> SymEnv -> String+cf2Cup :: String -> String -> CF -> RecordPositions -> KeywordEnv -> String cf2Cup packageBase packageAbsyn cf rp env = unlines [ header- , declarations packageAbsyn (allCats cf)+ , declarations packageAbsyn (allParserCats cf) , tokens env , specialToks cf , specialRules cf@@ -87,7 +86,7 @@ , parseMethod packageAbsyn (firstEntry cf) , "public <B,A extends java.util.LinkedList<? super B>> " ++ "A cons_(B x, A xs) { xs.addFirst(x); return xs; }"- , definedRules packageAbsyn cf+ , unlines $ definedRules packageAbsyn cf , "public void syntax_error(java_cup.runtime.Symbol cur_token)" , "{" , " report_error(\"Syntax Error, trying to recover and continue"@@ -103,9 +102,9 @@ , ":}" ] -definedRules :: String -> CF -> String+definedRules :: String -> CF -> [String] definedRules packageAbsyn cf =- unlines [ rule f xs e | FunDef f xs e <- cfgPragmas cf ]+ concat [ rule f xs e | FunDef f xs e <- cfgPragmas cf ] where ctx = buildContext cf @@ -115,12 +114,12 @@ unBase (BaseT x) = show $ normCat $ strToCat x rule f xs e =- case checkDefinition' list ctx f xs e of- Bad err ->+ case runTypeChecker $ checkDefinition' list ctx f xs e of+ Left err -> error $ "Panic! This should have been caught already:\n" ++ err- Ok (args,(e',t)) -> unlines- [ "public " ++ javaType t ++ " " ++ f ++ "_ (" +++ Right (args,(e',t)) ->+ [ "public " ++ javaType t ++ " " ++ funName f ++ "_ (" ++ intercalate ", " (map javaArg args) ++ ") {" , " return " ++ javaExp e' ++ ";" , "}"@@ -129,20 +128,17 @@ javaType :: Base -> String javaType (ListT (BaseT x)) = packageAbsyn ++ ".List"- ++ show (normCat $ strToCat x)+ ++ catToStr (normCat $ strToCat x) javaType (ListT t) = javaType t- javaType (BaseT x)- | isToken x ctx = "String"- | otherwise = packageAbsyn ++ "."- ++ show (normCat $ strToCat x)+ javaType (BaseT x) = typename packageAbsyn (ctxTokens ctx) $+ catToStr $ normCat $ strToCat x javaArg :: (String, Base) -> String javaArg (x,t) = javaType t ++ " " ++ x ++ "_" javaExp :: Exp -> String javaExp (App "null" []) = "null"- javaExp (App x [])- | x `elem` xs = x ++ "_" -- argument+ javaExp (Var x) = x ++ "_" -- argument javaExp (App t [e]) | isToken t ctx = call "new String" [e] javaExp (App x es)@@ -184,7 +180,7 @@ ++ identCat (normCat nt) +++ identCat nt ++ ";" --terminal types-tokens :: SymEnv -> String+tokens :: KeywordEnv -> String tokens ts = unlines (map declTok ts) where declTok (s,r) = "terminal" +++ r ++ "; // " ++ s@@ -206,16 +202,16 @@ --The following functions are a (relatively) straightforward translation --of the ones in CFtoHappy.hs-rulesForCup :: String -> CF -> RecordPositions -> SymEnv -> Rules+rulesForCup :: String -> CF -> RecordPositions -> KeywordEnv -> Rules rulesForCup packageAbsyn cf rp env = map mkOne $ ruleGroups cf where mkOne (cat,rules) = constructRule packageAbsyn cf rp 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 -> RecordPositions -> SymEnv -> [Rule] -> NonTerminal+constructRule :: String -> CF -> RecordPositions -> KeywordEnv -> [Rule] -> NonTerminal -> (NonTerminal,[(Pattern,Action)]) constructRule packageAbsyn cf rp env rules nt =- (nt, [ (p, generateAction packageAbsyn nt (funRule r) (revM b m) b rp)+ (nt, [ (p, generateAction packageAbsyn nt (funName $ funRule r) (revM b m) b rp) | r0 <- rules, let (b,r) = if isConsFun (funRule r0) && elem (valCat r0) revs then (True, revSepListRule r0)@@ -232,7 +228,7 @@ -- Only used if this is a list rule. -> RecordPositions -- ^ Record line and column info. -> Action-generateAction packageAbsyn nt f ms rev rp+generateAction packageAbsyn nt fun ms rev rp | isNilFun f = "RESULT = new " ++ c ++ "();" | isOneFun f = "RESULT = new " ++ c ++ "(); RESULT.addLast(" ++ p_1 ++ ");"@@ -244,6 +240,7 @@ | otherwise = "RESULT = new " ++ c ++ "(" ++ intercalate "," ms ++ ");" ++ lineInfo where+ f = funName fun c = packageAbsyn ++ "." ++ if isNilFun f || isOneFun f || isConsFun f then identCat (normCat nt) else f@@ -273,13 +270,13 @@ -- | Generate patterns and a set of metavariables indicating -- where in the pattern the non-terminal. ----- >>> generatePatterns [] (Rule "myfun" (Cat "A") [])+-- >>> generatePatterns [] (npRule "myfun" (Cat "A") [] Parsable) -- (" /* empty */ ",[]) ----- >>> generatePatterns [("def", "_SYMB_1")] (Rule "myfun" (Cat "A") [Right "def", Left (Cat "B")])+-- >>> generatePatterns [("def", "_SYMB_1")] (npRule "myfun" (Cat "A") [Right "def", Left (Cat "B")] Parsable) -- ("_SYMB_1:p_1 B:p_2 ",["p_2"]) -generatePatterns :: SymEnv -> Rule -> (Pattern,[MetaVar])+generatePatterns :: KeywordEnv -> Rule -> (Pattern,[MetaVar]) generatePatterns env r = case rhsRule r of [] -> (" /* empty */ ", []) its -> (mkIt 1 its, metas its)
src/BNFC/Backend/Java/CFtoFoldVisitor.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Java 1.5 Fold Vistor generator Copyright (C) 2006 Bjorn Bringert@@ -20,9 +18,11 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE OverloadedStrings #-}+ module BNFC.Backend.Java.CFtoFoldVisitor (cf2FoldVisitor) where -import Prelude'+import Prelude hiding ((<>)) import BNFC.CF import BNFC.Backend.Java.CFtoJavaAbs15 (typename)@@ -36,11 +36,6 @@ unlines ["package" +++ packageBase ++ ";", "",- "import" +++ packageAbsyn ++ ".*;",- "import java.util.Collections;",- "import java.util.List;",- "import java.util.ArrayList;",- "", "/** BNFC-Generated Fold Visitor */", "public abstract class FoldVisitor<R,A> implements AllVisitor<R,A> {", " public abstract R leaf(A arg);",@@ -61,7 +56,7 @@ --traverses a standard rule. prRule :: String -> [UserDef] -> Cat -> Rule -> String-prRule packageAbsyn user _ (Rule fun _ cats)+prRule packageAbsyn user _ (Rule fun _ cats _) | not (isCoercion fun || isDefinedRule fun) = unlines $ [" public R visit(" ++ cls ++ " p, A arg) {", " R r = leaf(arg);"]@@ -69,27 +64,28 @@ ++ [" return r;", " }"] where- cats' = filter ((/= InternalCat) . fst) (lefts (numVars cats))- cls = packageAbsyn ++ "." ++ fun- visitVars = lines $ render $ vcat $ map (prCat user) cats'+ cats' = lefts $ numVars cats+ cls = packageAbsyn ++ "." ++ funName fun+ visitVars = lines $ render $ vcat $ map (prCat packageAbsyn user) cats' prRule _ _ _ _ = "" -- | Traverses a class's instance variables.--- >>> prCat ["A"] (Cat "A", "a_")+-- >>> prCat "" ["A"] (Cat "A", "a_") -- <BLANKLINE>--- >>> prCat [] (ListCat (Cat "Integer"), "listinteger_")+-- >>> prCat "" [] (ListCat (Cat "Integer"), "listinteger_") -- <BLANKLINE>--- >>> prCat [] (ListCat (Cat "N"), "listn_")--- for (N x : p.listn_)+-- >>> prCat "absyn" [] (ListCat (Cat "N"), "listn_")+-- for (absyn.N x : p.listn_) -- { -- r = combine(x.accept(this, arg), r, arg); -- }--- >>> prCat [] (Cat "N", "n_")+-- >>> prCat "absyn" [] (Cat "N", "n_") -- r = combine(p.n_.accept(this, arg), r, arg);-prCat :: [UserDef]+prCat :: String -- ^ Absyn package name.+ -> [UserDef] -- ^ User-defined token categories. -> (Cat, Doc) -- ^ Variable category and name -> Doc -- ^ Code for visiting the variable-prCat user (cat,nt)+prCat packageAbsyn user (cat,nt) | isBasicType user varType || (isList cat && isBasicType user et) = empty | isList cat = vcat [ "for (" <> text et <> " x : " <> var <> ")"@@ -97,8 +93,8 @@ | 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+ varType = typename packageAbsyn user $ identCat $ normCat cat+ et = typename packageAbsyn user $ identCat $ normCatOfList cat --Just checks if something is a basic or user-defined type. isBasicType :: [UserDef] -> String -> Bool
src/BNFC/Backend/Java/CFtoJLex15.hs view
@@ -41,20 +41,22 @@ module BNFC.Backend.Java.CFtoJLex15 ( cf2jlex ) where -import Prelude'+import Prelude hiding ((<>)) import BNFC.CF import BNFC.Backend.Common.NamedVariables+import BNFC.Backend.C.CFtoFlexC ( commentStates ) import BNFC.Backend.Java.RegToJLex-import BNFC.Options (JavaLexerParser(..), RecordPositions(..))-import BNFC.Utils (cstring)+import BNFC.Options ( JavaLexerParser(..), RecordPositions(..) )+import BNFC.Utils ( cstring )+ import Text.PrettyPrint -- | The environment is returned for further use in the parser. cf2jlex :: JavaLexerParser -> RecordPositions -> String -> CF -> (Doc, SymEnv) cf2jlex jflex rp packageBase cf = (, env) . vcat $ [ prelude jflex rp packageBase- , cMacros+ , cMacros cf , lexSymbols jflex env , restOfJLex jflex rp cf ]@@ -64,7 +66,7 @@ -- | File prelude. prelude :: JavaLexerParser -> RecordPositions -> String -> Doc prelude jflex rp packageBase = vcat- [ "// This JLex file was machine-generated by the BNF converter"+ [ hsep [ "// This", lexerName, "file was machine-generated by the BNF converter" ] , "package" <+> text packageBase <> ";" , "" , "import java_cup.runtime.*;"@@ -110,6 +112,10 @@ else "" ] where+ lexerName = case jflex of+ JFlexCup -> "JFlex"+ JLexCup -> "JLex"+ Antlr4 -> undefined positionDeclarations -- JFlex always defines yyline, yychar, yycolumn, even if unused. | jflex == JFlexCup = ""@@ -123,33 +129,40 @@ --For now all categories are included. --Optimally only the ones that are used should be generated.-cMacros :: Doc-cMacros = vcat [- "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",- "%%"+cMacros :: CF -> Doc+cMacros cf = vcat $ concat+ [ [ "LETTER = ({CAPITAL}|{SMALL})"+ , "CAPITAL = [A-Z\\xC0-\\xD6\\xD8-\\xDE]"+ , "SMALL = [a-z\\xDF-\\xF6\\xF8-\\xFF]"+ , "DIGIT = [0-9]"+ , "IDENT = ({LETTER}|{DIGIT}|['_])"+ ]+ , map (text . ("%state " ++)) $ take (numberOfBlockCommentForms cf) commentStates+ , [ "%state CHAR"+ , "%state CHARESC"+ , "%state CHAREND"+ , "%state STRING"+ , "%state ESCAPED"+ , "%%"+ ] ] -- | -- >>> lexSymbols JLexCup [("foo","bar")] -- <YYINITIAL>foo { return cf.newSymbol("", sym.bar, left_loc(), right_loc()); }+-- -- >>> lexSymbols JLexCup [("\\","bar")] -- <YYINITIAL>\\ { return cf.newSymbol("", sym.bar, left_loc(), right_loc()); }+-- -- >>> lexSymbols JLexCup [("/","bar")] -- <YYINITIAL>/ { return cf.newSymbol("", sym.bar, left_loc(), right_loc()); }+-- -- >>> lexSymbols JFlexCup [("/","bar")] -- <YYINITIAL>\/ { return cf.newSymbol("", sym.bar, left_loc(), right_loc()); }+-- -- >>> lexSymbols JFlexCup [("~","bar")] -- <YYINITIAL>\~ { return cf.newSymbol("", sym.bar, left_loc(), right_loc()); }+-- lexSymbols :: JavaLexerParser -> SymEnv -> Doc lexSymbols jflex ss = vcat $ map transSym ss where@@ -186,7 +199,7 @@ ifC :: TokenCat -> Doc -> Doc ifC cat s = if isUsedCat cf (TokenCat cat) then s else "" userDefTokens = vcat- [ "<YYINITIAL>" <> text (printRegJLex exp)+ [ "<YYINITIAL>" <> text (printRegJLex jflex exp) <+> "{ return cf.newSymbol(\"\", sym." <> text name <> ", left_loc(), right_loc(), yytext().intern()); }" | (name, exp) <- tokenPragmas cf ]@@ -241,19 +254,21 @@ ] lexComments :: ([(String, String)], [String]) -> Doc-lexComments (m,s) =- vcat (map lexSingleComment s ++ map lexMultiComment m)+lexComments (m,s) = vcat $ concat+ [ map lexSingleComment s+ , zipWith lexMultiComment m commentStates+ ] -- | Create lexer rule for single-line comments. -- -- >>> lexSingleComment "--"--- <YYINITIAL>"--"[^\n]*\n { /* skip */ }+-- <YYINITIAL>"--"[^\n]* { /* skip */ } -- -- >>> lexSingleComment "\""--- <YYINITIAL>"\""[^\n]*\n { /* skip */ }+-- <YYINITIAL>"\""[^\n]* { /* skip */ } lexSingleComment :: String -> Doc lexSingleComment c =- "<YYINITIAL>" <> cstring c <> "[^\\n]*\\n { /* skip */ }"+ "<YYINITIAL>" <> cstring c <> "[^\\n]* { /* skip */ }" -- | Create lexer rule for multi-lines comments. --@@ -261,21 +276,24 @@ -- comments. They could possibly start a comment with one character and end it -- with another. However this seems rare. ----- >>> lexMultiComment ("{-", "-}")+-- >>> lexMultiComment ("{-", "-}") "COMMENT" -- <YYINITIAL>"{-" { yybegin(COMMENT); } -- <COMMENT>"-}" { yybegin(YYINITIAL); } -- <COMMENT>. { /* skip */ } -- <COMMENT>[\n] { /* skip */ } ----- >>> lexMultiComment ("\"'", "'\"")+-- >>> lexMultiComment ("\"'", "'\"") "COMMENT" -- <YYINITIAL>"\"'" { yybegin(COMMENT); } -- <COMMENT>"'\"" { yybegin(YYINITIAL); } -- <COMMENT>. { /* skip */ } -- <COMMENT>[\n] { /* skip */ }-lexMultiComment :: (String, String) -> Doc-lexMultiComment (b,e) = vcat- [ "<YYINITIAL>" <> cstring b <+> "{ yybegin(COMMENT); }"- , "<COMMENT>" <> cstring e <+> "{ yybegin(YYINITIAL); }"- , "<COMMENT>. { /* skip */ }"- , "<COMMENT>[\\n] { /* skip */ }"+--+lexMultiComment :: (String, String) -> String -> Doc+lexMultiComment (b,e) comment = vcat+ [ "<YYINITIAL>" <> cstring b <+> "{ yybegin(" <> text comment <> "); }"+ , commentTag <> cstring e <+> "{ yybegin(YYINITIAL); }"+ , commentTag <> ". { /* skip */ }"+ , commentTag <> "[\\n] { /* skip */ }" ]+ where+ commentTag = text $ "<" ++ comment ++ ">"
src/BNFC/Backend/Java/CFtoJavaAbs15.hs view
@@ -1,4 +1,7 @@-{-# LANGUAGE NoImplicitPrelude, OverloadedStrings #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}+ {- BNF Converter: Java 1.5 Abstract Syntax Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert@@ -46,8 +49,6 @@ module BNFC.Backend.Java.CFtoJavaAbs15 (cf2JavaAbs, typename, cat2JavaType) where -import Prelude'- import BNFC.CF import BNFC.Options (RecordPositions(..)) import BNFC.Utils((+++),(++++))@@ -57,6 +58,7 @@ import Data.Char(toLower) import Data.Maybe (mapMaybe) import Text.PrettyPrint+import qualified Text.PrettyPrint as P --Produces abstract data types in Java. --These follow Appel's "non-object oriented" version.@@ -152,7 +154,7 @@ prEquals :: String -> String -> [IVar] -> String prEquals pack fun vs =- unlines $ map (" "++) $ ["public boolean equals(Object o) {",+ unlines $ map (" "++) $ ["public boolean equals(java.lang.Object o) {", " if (this == o) return true;", " if (o instanceof " ++ fqn ++ ") {"] ++ (if null vs@@ -168,7 +170,7 @@ checkKid iv = "this." ++ v ++ ".equals(x." ++ v ++ ")" where v = render (iVarName iv) --- | Creates the equals() method.+-- | Creates the hashCode() method. prHashCode :: String -> String -> [IVar] -> String prHashCode _ _ vs =@@ -200,7 +202,7 @@ RecordPositions -> "public int line_num, col_num, offset;" NoRecordPositions -> empty prInstVars rp vars@((t,_,_):_) =- "public" <+> "final" <+> text t <+> uniques <> ";" $$ prInstVars rp vs'+ "public" <+> "final" <+> text t <+> uniques P.<> ";" $$ prInstVars rp vs' where (uniques, vs') = prUniques t vars --these functions group the types together nicely@@ -225,7 +227,7 @@ -- integer_ iVarName :: IVar -> Doc-iVarName (_,n,nm) = text (varName nm) <> text (showNum n)+iVarName (_,n,nm) = text (varName nm) P.<> text (showNum n) -- | The constructor just assigns the parameters to the corresponding instance -- variables.@@ -238,8 +240,8 @@ prConstructor :: String -> [UserDef] -> [IVar] -> [Cat] -> Doc prConstructor c u vs cats =- "public" <+> text c <> parens (interleave types params)- <+> "{" <+> text (prAssigns vs params) <> "}"+ "public" <+> text c P.<> parens (interleave types params)+ <+> "{" <+> text (prAssigns vs params) P.<> "}" where (types, params) = unzip (prParams cats u (length cats) (length cats+1)) interleave xs ys = hsep $ punctuate "," $ zipWith ((<+>) `on` text) xs ys@@ -247,9 +249,8 @@ -- | 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+prParams cs user n m = zipWith pr cs [m-n, m-n+1 ..]+ where pr c k = (typename "" user (identCat c), 'p' : show k) -- | This algorithm peeks ahead in the list so we don't use @map@ or @fold@. @@ -268,13 +269,15 @@ getVars :: [Cat] -> [UserDef] -> [IVar] getVars cs user = reverse $ singleToZero $ foldl addVar [] (map identCat cs)- where+ where addVar is c = (c', n, c):is- where c' = typename c user+ where c' = typename "" user c n = maximum (1:[n'+1 | (_,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]+ singleToZero is =+ [ (t,n',nm)+ | (t,n,nm) <- is+ , let n' = if length [n | (_,_,n) <- is, n == nm] == 1 then 0 else n+ ] varName :: String -- ^ category name -> String -- ^ Variable name@@ -282,12 +285,20 @@ -- | This makes up for the fact that there's no typedef in Java. -typename :: String -> [UserDef] -> String-typename t user+typename+ :: String -- ^ Qualification (can be empty).+ -> [UserDef] -- ^ User-defined token names.+ -> String -- ^ Category name.+ -> String+typename q user t | t == "Ident" = "String" | t == "Char" = "Character"+ | t == "Double" = "Double"+ | t == "Integer" = "Integer"+ | t == "String" = "String" | t `elem` user = "String"- | otherwise = t+ | null q = t+ | otherwise = q ++ "." ++ t -- | Print the Java type corresponding to a category. cat2JavaType :: [UserDef] -> Cat -> String@@ -296,7 +307,7 @@ loop = \case ListCat c -> "List" ++ loop c -- ListCat c -> "java.util.LinkedList<" ++ loop c ++ ">"- c -> typename (show $ normCat c) user+ c -> typename "" user $ identCat $ normCat c -- | Print the Java type corresponding to a category. -- The top list is printed as @java.util.LinkedList<...>@.
src/BNFC/Backend/Java/CFtoJavaPrinter15.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-} {- BNF Converter: Java Pretty Printer generator@@ -48,7 +49,7 @@ -} module BNFC.Backend.Java.CFtoJavaPrinter15 ( cf2JavaPrinter ) where -import Prelude'+import Prelude hiding ((<>)) import BNFC.Backend.Java.CFtoJavaAbs15 @@ -82,7 +83,6 @@ groups = fixCoercions (ruleGroupsInternals cf) header = unlines [ "package" +++ packageBase ++ ";",- "import" +++ packageAbsyn ++ ".*;", "", "public class PrettyPrinter", "{",@@ -96,12 +96,12 @@ ] 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(Double d, int _i_) { buf_.append(String.format(java.util.Locale.ROOT, \"%.15g \", d)); }", " 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(Double d) { render(String.format(java.util.Locale.ROOT, \"%.15g\", d)); }",+ " 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()",@@ -109,22 +109,29 @@ " int n = _n_;", " while (n > 0)", " {",- " buf_.append(\" \");",+ " buf_.append(\' \');", " n--;", " }", " }", " private static void backup()", " {",- " if (buf_.charAt(buf_.length() - 1) == ' ') {",- " buf_.setLength(buf_.length() - 1);",- " }",+ " int prev = buf_.length() - 1;",+ " if (buf_.charAt(prev) == ' ')",+ " buf_.setLength(prev);", " }", " 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);",+ " // Trim initial spaces",+ " int end = 0;",+ " int len = buf_.length();",+ " while (end < len && buf_.charAt(end) == ' ')",+ " end++; ",+ " buf_.delete(0, end);",+ " // Trim trailing spaces",+ " end = buf_.length();",+ " while (end > 0 && buf_.charAt(end-1) == ' ')",+ " end--; ",+ " buf_.setLength(end);", " }", " private static int _n_ = 0;", " private static StringBuilder buf_ = new StringBuilder(INITIAL_BUFFER_SIZE);",@@ -180,6 +187,11 @@ " indent();", " }", " else if (s.equals(\"\")) return;",+ " else if (s.trim().equals(\"\"))",+ " {",+ " backup();",+ " buf_.append(s);",+ " }", " else", " {", " buf_.append(s);",@@ -223,7 +235,7 @@ [" private static void pp(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo, int _i_)" , " {"- , render $ nest 5 $ prList user cat rules <> " }"+ , render $ nest 5 $ prList packageAbsyn user cat rules <> " }" ] else --not a list [@@ -237,7 +249,7 @@ prRule :: String -> Rule -> String-prRule packageAbsyn r@(Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = concat+prRule packageAbsyn r@(Rule f _c cats _) | not (isCoercion f || isDefinedRule f) = concat [ " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")\n" , " {\n" , " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("@@ -248,6 +260,7 @@ , " }\n" ] where+ fun = funName f p = precRule r (lparen, rparen) = (" if (_i_ > " ++ show p ++ ") render(_L_PAREN);\n",@@ -262,8 +275,8 @@ -- | -- -- >>> let lfoo = ListCat (Cat "Foo")--- >>> prList [] lfoo [Rule "[]" lfoo [], Rule "(:)" lfoo [Left (Cat "Foo"), Right ".", Left lfoo]]--- for (java.util.Iterator<Foo> it = foo.iterator(); it.hasNext();)+-- >>> prList "absyn" [] lfoo [npRule "[]" lfoo [] Parsable, npRule "(:)" lfoo [Left (Cat "Foo"), Right ".", Left lfoo] Parsable]+-- for (java.util.Iterator<absyn.Foo> it = foo.iterator(); it.hasNext();) -- { -- pp(it.next(), _i_); -- if (it.hasNext()) {@@ -273,8 +286,8 @@ -- } -- } -prList :: [UserDef] -> Cat -> [Rule] -> Doc-prList user c rules =+prList :: String -> [UserDef] -> Cat -> [Rule] -> Doc+prList packageAbsyn user c rules = "for (java.util.Iterator<" <> et <> "> it = foo.iterator(); it.hasNext();)" $$ codeblock 2 [ "pp(it.next(), _i_);"@@ -286,7 +299,7 @@ , "}" ] where- et = text $ cat2JavaType user $ normCatOfList c+ et = text $ typename packageAbsyn user $ identCat $ normCatOfList c sep = escapeChars $ getCons rules optsep = if hasOneFunc rules then "" else sep renderSep x = "render(\"" <> text x <>"\")"@@ -298,8 +311,6 @@ -- >>> prCat "F" (Left (TokenCat "String", "string_")) -- printQuoted(F.string_); -- <BLANKLINE>--- >>> prCat "F" (Left (InternalCat, "#_"))--- <BLANKLINE> -- >>> prCat "F" (Left (Cat "Abc", "abc_")) -- pp(F.abc_, 0); -- <BLANKLINE>@@ -307,7 +318,6 @@ prCat _ (Right t) = nest 7 ("render(\"" <> text(escapeChars t) <> "\");\n") prCat fnm (Left (TokenCat "String", nt)) = nest 7 ("printQuoted(" <> fnm <> "." <> nt <> ");\n")-prCat _ (Left (InternalCat, _)) = empty prCat fnm (Left (cat, nt)) = nest 7 ("pp(" <> fnm <> "." <> nt <> ", " <> integer (precCat cat) <> ");\n") @@ -321,7 +331,7 @@ [ " private static void sh(" ++ packageAbsyn ++ "." ++ identCat (normCat cat) +++ "foo)" , " {"- , shList user cat rules ++ " }"+ , shList packageAbsyn user cat rules ++ " }" ] else [ " private static void sh(" ++ packageAbsyn ++ "."@@ -332,7 +342,7 @@ shRule :: String -> Rule -> String-shRule packageAbsyn (Rule fun _c cats) | not (isCoercion fun || isDefinedRule fun) = unlines+shRule packageAbsyn (Rule f _c cats _) | not (isCoercion f || isDefinedRule f) = unlines [ " if (foo instanceof" +++ packageAbsyn ++ "." ++ fun ++ ")" , " {" , " " ++ packageAbsyn ++ "." ++ fun +++ fnm +++ "= ("@@ -340,6 +350,7 @@ , members ++ " }" ] where+ fun = funName f members = concat [ lparen , " render(\"" ++ escapeChars fun ++ "\");\n" , cats'@@ -356,8 +367,8 @@ fnm = '_' : map toLower fun shRule _nm _ = "" -shList :: [UserDef] -> Cat -> [Rule] -> String-shList user c _rules = unlines+shList :: String -> [UserDef] -> Cat -> [Rule] -> String+shList packageAbsyn user c _rules = unlines [ " for (java.util.Iterator<" ++ et ++ "> it = foo.iterator(); it.hasNext();)",@@ -368,7 +379,7 @@ " }" ] where- et = cat2JavaType user $ normCatOfList c+ et = typename packageAbsyn user $ identCat $ normCatOfList c -- | -- >>> shCat "F" (ListCat (Cat "A"), "lista_")@@ -376,8 +387,6 @@ -- sh(F.lista_); -- render("]"); -- <BLANKLINE>--- >>> shCat "F" (InternalCat, "#_")--- <BLANKLINE> -- >>> shCat "F" (Cat "A", "a_") -- sh(F.a_); -- <BLANKLINE>@@ -386,7 +395,6 @@ [ " render(\"[\");" , " sh(" <> fnm <> "." <> vname <> ");" , " render(\"]\");\n" ]-shCat _ (InternalCat, _) = empty shCat fname (_, vname) = " sh(" <> fname <> "." <> vname <> ");\n" --Helper function that escapes characters in strings
src/BNFC/Backend/Java/CFtoVisitSkel15.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Java Vistor skeleton generator Copyright (C) 2004 Author: Michael Pellauer, Bjorn Bringert@@ -40,16 +38,22 @@ ************************************************************** -}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+ module BNFC.Backend.Java.CFtoVisitSkel15 (cf2VisitSkel) where -import Prelude'+import Data.Bifunctor ( second )+import Data.Either ( lefts )+import Text.PrettyPrint+import qualified Text.PrettyPrint as P import BNFC.CF-import BNFC.Backend.Java.CFtoJavaAbs15 (typename)-import BNFC.Utils ((+++))+import BNFC.Utils ( (+++) )+ import BNFC.Backend.Common.NamedVariables-import Text.PrettyPrint-import Data.Either (lefts)+import BNFC.Backend.Java.CFtoJavaAbs15 ( typename ) --Produces a Skeleton using the Visitor Design Pattern. --Thus the user can choose which Skeleton to use.@@ -58,16 +62,16 @@ 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 (ruleGroupsInternals cf)+ user = fst $ unzip $ tokenPragmas cf+ groups = fixCoercions $ ruleGroupsInternals 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. ",@@ -85,64 +89,78 @@ | isList cat = "" | otherwise = unlines [" public class " ++ identCat cat ++ "Visitor<R,A> implements "- ++ identCat cat ++ ".Visitor<R,A>"+ ++ qual (identCat cat) ++ ".Visitor<R,A>" , " {"- , concatMap (render . nest 4 . prRule packageAbsyn user) rules+ , render $ vcat $ map (nest 4 . prRule packageAbsyn user) rules , " }" ]+ where+ qual x = packageAbsyn ++ "." ++ x -- | traverses a standard rule.--- >>> prRule "ABSYN" [] (Rule "EInt" undefined [Left (TokenCat "Integer"), Left (Cat "NT")])+-- >>> prRule "ABSYN" [] $ Rule "EInt" undefined [Left (TokenCat "Integer"), Left (Cat "NT")] Parsable -- public R visit(ABSYN.EInt p, A arg)--- { /* Code For EInt Goes Here */+-- { /* Code for EInt goes here */ -- //p.integer_; -- p.nt_.accept(new NTVisitor<R,A>(), arg); -- return null; -- } -- -- It skips the internal category (indicating that a rule is not parsable)--- >>> prRule "ABSYN" [] (Rule "EInt" undefined [Left (InternalCat), Left (TokenCat "Integer")])+-- >>> prRule "ABSYN" [] $ Rule "EInt" undefined [Left (TokenCat "Integer")] Internal -- public R visit(ABSYN.EInt p, A arg)--- { /* Code For EInt Goes Here */+-- { /* Code for EInt goes here */ -- //p.integer_; -- return null; -- }-prRule :: String -> [UserDef] -> Rule -> Doc-prRule packageAbsyn user (Rule fun _ cats)+prRule :: IsFun f => String -> [UserDef] -> Rul f -> Doc+prRule packageAbsyn user (Rule fun _ cats _) | not (isCoercion fun || isDefinedRule fun) = vcat- [ "public R visit(" <> text packageAbsyn <> "." <> fname <> " p, A arg)"+ [ "public R visit(" P.<> text packageAbsyn P.<> "." P.<> fname P.<> " p, A arg)" , "{"- , nest 2 ( "/* Code For " <> fname <> " Goes Here */"- $$ vcat (map (prCat user) cats')- $$ "return null;" )- , "}" ]+ , nest 2 $ vcat+ [ "/* Code for " P.<> fname P.<> " goes here */"+ , vcat $ map (prCat packageAbsyn user) cats'+ , "return null;"+ ]+ , "}"+ ] where- fname = text fun -- function name- cats' = filter ((/= InternalCat).fst) (lefts (numVars cats)) -- non-terminals in the rhs-prRule _ _ _ = ""+ fname = text $ funName fun -- function name+ cats' = map (second ("p." P.<>)) $ lefts $ numVars cats -- non-terminals in the rhs+prRule _ _ _ = empty -- | Traverses a class's instance variables.--- >>> prCat [] (Cat "A", "a_")+--+-- >>> prCat "ABSYN" [] (Cat "A", "p.a_") -- p.a_.accept(new AVisitor<R,A>(), arg);--- >>> prCat [] (TokenCat "Integer", "integer_")+--+-- >>> prCat "" [] (TokenCat "Integer", "p.integer_") -- //p.integer_;--- >>> prCat ["A"] (TokenCat "A", "a_")+--+-- >>> prCat "" ["A"] (TokenCat "A", "p.a_") -- //p.a_;--- >>> prCat ["A"] (TokenCat "A", "a_2")+--+-- >>> prCat "" ["A"] (TokenCat "A", "p.a_2") -- //p.a_2;--- >>> prCat [] (ListCat (Cat "A"), "lista_")--- for (A x: p.lista_)--- { /* ... */ }-prCat :: [UserDef] -- ^ User defined tokens- -> (Cat, Doc) -- ^ Variable category and name- -> Doc -- ^ Code for visiting the variable-prCat user (cat, nt)- | isTokenCat cat = "//" <> var <> ";"- | isList cat = "for" <+> parens (text et <+> "x:" <+> var)- $$ braces " /* ... */ "- | otherwise = accept+--+-- >>> prCat "ABSYN" [] (ListCat (Cat "A"), "p.lista_")+-- for (ABSYN.A x: p.lista_) {+-- x.accept(new AVisitor<R,A>(), arg);+-- }+prCat :: String -- ^ absyn package name.+ -> [UserDef] -- ^ User defined tokens.+ -> (Cat, Doc) -- ^ Variable category and name.+ -> Doc -- ^ Code for visiting the variable.+prCat packageAbsyn user (cat, var) =+ case cat of+ TokenCat{} -> "//" P.<> var P.<> ";"+ ListCat cat' -> vcat+ [ "for" <+> parens (text et <+> "x:" <+> var) <+> "{"+ , nest 2 $ prCat packageAbsyn user (cat', "x")+ , "}"+ ]+ _ -> var P.<> ".accept(new " P.<> text varType P.<> "Visitor<R,A>(), arg);" where- var = "p." <> nt- varType = typename (identCat (normCat cat)) user- accept = var <> ".accept(new " <> text varType <> "Visitor<R,A>(), arg);"- et = typename (show $ normCatOfList cat) user+ varType = typename "" user $ identCat $ normCat cat -- no qualification here!+ et = typename packageAbsyn user $ identCat $ normCatOfList cat
src/BNFC/Backend/Java/RegToAntlrLexer.hs view
@@ -2,6 +2,8 @@ -- modified from RegToJLex.hs +import Data.Char (ord, showLitChar)+ import AbsBNF -- the top-level printing method@@ -40,8 +42,10 @@ prtList = map (concat . prt 0) escapeChar :: Char -> String-escapeChar x | x `elem` reserved = '\\' : [x]-escapeChar x = [x]+escapeChar x+ | x `elem` reserved = '\\' : [x]+ | ord x >= 256 = [x]+ | otherwise = showLitChar x "" -- Characters that must be escaped in ANTLR regular expressions reserved :: [Char]@@ -50,8 +54,8 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of@@ -73,7 +77,7 @@ 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 (concatMap (prt 0) str)+ RSeqs str -> prPrec i 2 $ map show str RDigit -> prPrec i 3 ["DIGIT"] RLetter -> prPrec i 3 ["LETTER"] RUpper -> prPrec i 3 ["CAPITAL"]
src/BNFC/Backend/Java/RegToJLex.hs view
@@ -1,51 +1,35 @@ module BNFC.Backend.Java.RegToJLex (printRegJLex, escapeChar) where --- modified from pretty-printer generated by the BNF converter--import Data.Char (showLitChar)-import AbsBNF-import BNFC.Options (JavaLexerParser(..))---- the top-level printing method-printRegJLex :: Reg -> String-printRegJLex = render . prt 0+import Data.Char (ord, showLitChar) --- you may want to change render and parenth+import AbsBNF (Identifier(..), Reg(..))+import BNFC.Options (JavaLexerParser(..))+import BNFC.Backend.Common (flexEps) -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- space t s = if null s then t else t ++ s+-- | Print a regular expression for the Java lexers. -parenth :: [String] -> [String]-parenth ss = ["("] ++ ss ++ [")"]+printRegJLex :: JavaLexerParser -> Reg -> String+printRegJLex lexer reg = prt lexer 0 reg "" --- the printer class does the job class Print a where- prt :: Int -> a -> [String]- prtList :: [a] -> [String]- prtList = concatMap (prt 0)+ prt :: JavaLexerParser -> Int -> a -> ShowS+ prtList :: JavaLexerParser -> [a] -> ShowS+ prtList lexer xs s = foldr (prt lexer 0) s xs+ -- OR: prtList lexer = foldr (.) id . map (prt lexer 0) instance Print a => Print [a] where- prt _ = prtList+ prt lexer _ = prtList lexer instance Print Char where- prt _ c = [escapeChar JLexCup c]- prtList = map (concat . prt 0)+ prt lexer _ c = showString $ escapeChar lexer c escapeChar :: JavaLexerParser -> Char -> String escapeChar _ '^' = "\\x5E" -- special case, since \^ is a control character escape escapeChar JFlexCup x | x `elem` jflexReserved = '\\' : [x]-escapeChar _ x | x `elem` jlexReserved = '\\' : [x]-escapeChar _ x = showLitChar x ""+escapeChar _ x+ | x `elem` jlexReserved = '\\' : [x]+ | ord x >= 255 = [x]+ | otherwise = showLitChar x "" -- Characters that must be escaped in JLex regular expressions jlexReserved :: [Char]@@ -54,35 +38,30 @@ jflexReserved :: [Char] jflexReserved = '~':'!':'/':[] -- plus the @jlexReserved@, but they are tested separately --prPrec :: Int -> Int -> [String] -> [String]-prPrec i j = if j<i then parenth else id--instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ _ (Identifier (_, x)) = showString x instance Print Reg where- prt i e = case e of- RSeq reg0 reg -> prPrec i 2 (concat [prt 2 reg0 , prt 3 reg])- RAlt reg0 reg -> prPrec i 1 (concat [prt 1 reg0 , ["|"] , prt 2 reg])+ prt lexer i = \case+ RSeq reg1 reg2 -> showParen (i > 2) $ prt lexer 2 reg1 . prt lexer 3 reg2+ RAlt reg1 reg2 -> showParen (i > 1) $ prt lexer 1 reg1 . showChar '|' . prt lexer 2 reg2 - -- 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 _ _ -> error "JLex does not support general set difference"+ -- JLex does not support set difference in general+ RMinus reg0 REps -> prt lexer i reg0 -- REps is identity for set difference+ RMinus RAny reg@RChar{} -> showParen (i > 3) $ showString "[^" . prt lexer 0 reg . showString "]"+ RMinus RAny (RAlts str) -> showParen (i > 3) $ showString "[^" . prt lexer 0 str . showString "]"+ -- FIXME: maybe we could add cases for char - RDigit, RLetter etc.+ RMinus _ _ -> error $ "J[F]Lex 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 (prt 0 c)- RAlts str -> prPrec i 3 (concat [["["],prt 0 str,["]"]])- RSeqs str -> prPrec i 2 (concatMap (prt 0) str)- RDigit -> prPrec i 3 ["{DIGIT}"]- RLetter -> prPrec i 3 ["{LETTER}"]- RUpper -> prPrec i 3 ["{CAPITAL}"]- RLower -> prPrec i 3 ["{SMALL}"]- RAny -> prPrec i 3 ["."]+ RStar reg -> showParen (i > 3) $ prt lexer 3 reg . showChar '*'+ RPlus reg -> showParen (i > 3) $ prt lexer 3 reg . showChar '+'+ ROpt reg -> showParen (i > 3) $ prt lexer 3 reg . showChar '?'+ REps -> showParen (i > 3) $ showString flexEps+ RChar c -> showParen (i > 3) $ prt lexer 0 c+ RAlts str -> showParen (i > 3) $ showChar '[' . prt lexer 0 str . showChar ']'+ RSeqs str -> showParen (i > 2) $ prt lexer 0 str+ RDigit -> showParen (i > 3) $ showString "{DIGIT}"+ RLetter -> showParen (i > 3) $ showString "{LETTER}"+ RUpper -> showParen (i > 3) $ showString "{CAPITAL}"+ RLower -> showParen (i > 3) $ showString "{SMALL}"+ RAny -> showParen (i > 3) $ showChar '.'
src/BNFC/Backend/Java/Utils.hs view
@@ -1,25 +1,83 @@ module BNFC.Backend.Java.Utils where-import BNFC.Backend.Common.NamedVariables++import BNFC.CF import BNFC.Utils ( mkName, NameStyle(..))+import BNFC.Backend.Common.NamedVariables -javaReserved = [- "abstract" ,"continue" ,"for" ,"new" ,"switch"- ,"assert" ,"default" ,"goto" ,"package" ,"synchronized"- ,"boolean" ,"do" ,"if" ,"private" ,"this"- ,"break" ,"double" ,"implements" ,"protected" ,"throw"- ,"byte" ,"else" ,"import" ,"public" ,"throws"- ,"case" ,"enum" ,"instanceof" ,"return" ,"transient"- ,"catch" ,"extends" ,"int" ,"short" ,"try"- ,"char" ,"final" ,"interface" ,"static" ,"void"- ,"class" ,"finally" ,"long" ,"strictfp" ,"volatile"- ,"const" ,"float" ,"native" ,"super" ,"while"- ]+javaReserved =+ [ "abstract"+ , "assert"+ , "boolean"+ , "break"+ , "byte"+ , "case"+ , "catch"+ , "char"+ , "class"+ , "const"+ , "continue"+ , "default"+ , "do"+ , "double"+ , "else"+ , "enum"+ , "extends"+ , "false" -- there for Java/ANTLR backend+ , "final"+ , "finally"+ , "float"+ , "for"+ , "goto"+ , "if"+ , "implements"+ , "import"+ , "instanceof"+ , "int"+ , "interface"+ , "long"+ , "native"+ , "new"+ , "null" -- there for Java/ANTLR backend+ -- , "Object"+ , "package"+ , "private"+ , "protected"+ , "public"+ , "return"+ , "short"+ , "static"+ , "strictfp"+ , "super"+ , "switch"+ , "synchronized"+ , "true" -- there for Java/ANTLR backend+ , "this"+ , "throw"+ , "throws"+ , "transient"+ , "try"+ , "void"+ , "volatile"+ , "while"+ ] -getRuleName z = if x `elem` ("grammar" : javaReserved) then z ++ "_" else z- where x = firstLowerCase z+-- | Append an underscore if there is a clash with a java or ANTLR keyword.+-- E.g. "Grammar" clashes with ANTLR keyword "grammar" since+-- we sometimes need the upper and sometimes the lower case version+-- of "Grammar" in the generated parser.+getRuleName :: String -> String+getRuleName z+ | firstLowerCase z `elem` ("grammar" : javaReserved) = z ++ "_"+ | otherwise = z +getLabelName :: Fun -> String getLabelName = mkName ["Rule"] CamelCase getLastInPackage :: String -> String getLastInPackage = last . words . map (\c -> if c == '.' then ' ' else c)++-- | Make a new entrypoint NT for an existing NT.++startSymbol :: String -> String+startSymbol = ("Start_" ++)
src/BNFC/Backend/OCaml.hs view
@@ -57,7 +57,7 @@ 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)+ where pref = maybe "" (\ p -> pkgToDir p </> "") (inPackage opts) ext' = if null ext then "" else "." ++ ext absFile, absFileM, ocamllexFile, ocamllexFileM, ocamlyaccFile, ocamlyaccFileM,@@ -113,7 +113,9 @@ makefile :: SharedOptions -> String -> Doc makefile opts basename = vcat [ mkVar "OCAMLC" "ocamlc"- , mkVar "OCAMLYACC" "ocamlyacc"+ , mkVar "OCAMLYACC" $ case ocamlParser opts of+ OCamlYacc -> "ocamlyacc"+ Menhir -> "menhir" , mkVar "OCAMLLEX" "ocamllex" , mkVar "OCAMLCFLAGS" "" , mkRule "all" []
src/BNFC/Backend/OCaml/CFtoOCamlLex.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-} {- BNF Converter: ocamllex Generator@@ -24,23 +24,23 @@ module BNFC.Backend.OCaml.CFtoOCamlLex (cf2ocamllex) where -import Prelude'+import Prelude hiding ((<>)) -import Control.Arrow ((&&&))-import Data.List-import Data.Char+import qualified Data.List as List import Text.PrettyPrint hiding (render) import qualified Text.PrettyPrint as PP import AbsBNF import BNFC.CF+import BNFC.Backend.Common (asciiKeywords, unicodeAndSymbols) import BNFC.Backend.OCaml.CFtoOCamlYacc (terminal)-import BNFC.Backend.OCaml.OCamlUtil (mkEsc)-import BNFC.Utils (cstring, cchar, unless)+import BNFC.Backend.OCaml.OCamlUtil (mkEsc, ocamlTokenName)+import BNFC.Lexing (mkRegMultilineComment)+import BNFC.Utils (cstring, unless) cf2ocamllex :: String -> String -> CF -> String cf2ocamllex _ parserMod cf =- unlines $ intercalate [""] [+ unlines $ List.intercalate [""] [ header parserMod cf, definitions cf, [PP.render (rules cf)]@@ -88,14 +88,14 @@ -- | set up hashtables for reserved symbols and words hashtables :: CF -> String hashtables cf = unlines . concat $- [ ht "symbol_table" $ cfgSymbols cf- , ht "resword_table" $ reservedWords cf+ [ ht "symbol_table" $ unicodeAndSymbols cf+ , ht "resword_table" $ asciiKeywords cf ] where ht table syms = unless (null syms) $ [ unwords [ "let", table, "= Hashtbl.create", show (length syms) ] , unwords [ "let _ = List.iter (fun (kwd, tok) -> Hashtbl.add", table, "kwd tok)" ]- , concat [ " [", concat (intersperse ";" keyvals), "]" ]+ , concat [ " [", concat (List.intersperse ";" keyvals), "]" ] ] where keyvals = map (\ s -> concat [ "(", mkEsc s, ", ", terminal cf s, ")" ]) syms@@ -119,24 +119,26 @@ ] rMacros :: CF -> [String]-rMacros cf =- let symbs = cfgSymbols cf- in- (if null symbs then [] else [- "let rsyms = (* reserved words consisting of special symbols *)",- " " ++ unwords (intersperse "|" (map mkEsc symbs))- ])+rMacros cf+ | null symbs = []+ | otherwise =+ [ "let rsyms = (* reserved words consisting of special symbols *)"+ , " " ++ unwords (List.intersperse "|" (map mkEsc symbs))+ ]+ where symbs = unicodeAndSymbols cf -- 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 =- [ (map toLower name, printRegOCaml reg, name) | (name, reg) <- tokenPragmas cf ]+uMacros cf = ["let " ++ name ++ " = " ++ rep | (name, rep, _, _) <- userTokens cf] +-- | Returns the tuple of @(reg_name, reg_representation, token_name, is_position_token)@. +userTokens :: CF -> [(String, String, String, Bool)]+userTokens cf =+ [ (ocamlTokenName name, printRegOCaml reg, name, pos)+ | TokenReg n pos reg <- cfgPragmas cf+ , let name = wpThing n+ ] -- | Make OCamlLex rule -- >>> mkRule "token" [("REGEX1","ACTION1"),("REGEX2","ACTION2"),("...","...")]@@ -165,25 +167,14 @@ mkRegexSingleLineComment :: String -> Doc mkRegexSingleLineComment s = cstring s <+> "(_ # '\\n')*" --- | Create regex for multiline comments+-- | Create regex for multiline comments. -- >>> mkRegexMultilineComment "<!--" "-->"--- "<!--" ((u # ['-']) | '-' (u # ['-']) | "--" (u # ['>']))* '-'* "-->"+-- "<!--" (u # '-')* '-' ((u # '-')+ '-')* '-' ((u # ['-''>']) (u # '-')* '-' ((u # '-')+ '-')* '-' | '-')* '>' -- -- >>> mkRegexMultilineComment "\"'" "'\""--- "\"'" ((u # ['\'']) | '\'' (u # ['"']))* '\''* "'\""+-- "\"'" (u # '\'')* '\'' ((u # ['"''\'']) (u # '\'')* '\'' | '\'')* '"' mkRegexMultilineComment :: String -> String -> Doc-mkRegexMultilineComment b e =- lit b- <+> parens ( hsep $ intersperse "|" subregexs ) <> "*"- <+> lit [head e] <> "*"- <+> lit e- where- lit :: String -> Doc- lit "" = empty- lit [c] = cchar c- lit s = cstring s- prefix = map (init &&& last) (drop 1 (inits e))- subregexs = [ lit ss <+> parens ("u #" <+> brackets (lit [s])) | (ss,s) <- prefix]+mkRegexMultilineComment b e = text $ printRegOCaml $ mkRegMultilineComment b e -- | Uses the function from above to make a lexer rule from the CF grammar rules :: CF -> Doc@@ -199,10 +190,10 @@ | not (null (cfgSymbols cf))] ++ -- user tokens- [ (text n , tokenAction (text t)) | (n,_,t) <- userTokens cf]+ [ (text n , tokenAction pos (text t)) | (n,_,t,pos) <- userTokens cf] ++ -- predefined tokens- [ ( "l i*", tokenAction "Ident" ) ]+ [ ( "l i*", tokenAction False "Ident" ) ] ++ -- integers [ ( "d+", "let i = lexeme lexbuf in TOK_Integer (int_of_string i)" )@@ -224,9 +215,12 @@ ] where (multilineC, singleLineC) = comments cf- tokenAction t = case reservedWords cf of- [] -> "let l = lexeme lexbuf in TOK_" <> t <>" l"- _ -> "let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_" <> t <+> "l"+ tokenAction pos t = case asciiKeywords cf of+ [] -> "let l = lexeme lexbuf in TOK_" <> t <+> arg+ _ -> "let l = lexeme lexbuf in try Hashtbl.find resword_table l with Not_found -> TOK_" <> t <+> arg+ where+ arg | pos = "((lexeme_start lexbuf, lexeme_end lexbuf), l)"+ | otherwise = "l" ------------------------------------------------------------------- -- Modified from the inlined version of @RegToAlex@.@@ -274,8 +268,8 @@ prPrec :: Int -> Int -> [String] -> [String] prPrec i j = if j<i then parenth else id -instance Print Ident where- prt _ (Ident i) = [i]+instance Print Identifier where+ prt _ (Identifier (_, i)) = [i] instance Print Reg where prt i e = case e of@@ -288,7 +282,8 @@ 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))+ RSeqs str -> [ 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"]])
src/BNFC/Backend/OCaml/CFtoOCamlPrinter.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE NoImplicitPrelude #-}- {- BNF Converter: Pretty-printer generator Copyright (C) 2005 Author: Kristofer Johannisson@@ -21,9 +19,11 @@ -- based on BNFC Haskell backend +{-# LANGUAGE OverloadedStrings #-}+ module BNFC.Backend.OCaml.CFtoOCamlPrinter (cf2Printer, prtFun) where -import Prelude'+import Prelude hiding ((<>)) import Data.Char(toLower) import Data.List (intersperse, sortBy)@@ -37,23 +37,23 @@ -- derive pretty-printer from a BNF grammar. AR 15/2/2002-cf2Printer :: String -> String -> CF -> String-cf2Printer name absMod cf = unlines [- prologue name absMod,+cf2Printer :: String -> ModuleName -> CF -> String+cf2Printer _name absMod cf = unlines [+ prologue, charRule cf, integerRule cf, doubleRule cf, stringRule cf,- if hasIdent cf then identRule cf else "",- unlines [ownPrintRule cf own | (own,_) <- tokenPragmas cf],- rules cf+ if hasIdent cf then identRule absMod cf else "",+ unlines [ownPrintRule absMod cf own | (own,_) <- tokenPragmas cf],+ rules absMod cf ] -prologue :: String -> String -> String-prologue _ absMod = unlines [- "(* pretty-printer generated by the BNF converter *)\n",- "open " ++ absMod,+prologue :: String+prologue = unlines [+ "(* pretty-printer generated by the BNF converter *)",+ "", "open Printf", "", "(* We use string buffers for efficient string concatenation.",@@ -64,7 +64,7 @@ "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 *)",+ " let buffer_init_size = 64 (* 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 *)",@@ -74,6 +74,12 @@ "", "let indent (i: int) : string = \"\\n\" ^ String.make i ' '", "",+ "(* To avoid dependency on package extlib, which has",+ " Extlib.ExtChar.Char.is_whitespace, we employ the following awkward",+ " way to check a character for whitespace.",+ " Note: String.trim exists in the core libraries since Ocaml 4.00. *)",+ "let isWhiteSpace (c: char) : bool = String.trim (String.make 1 c) = \"\"",+ "", "(* 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 *)",@@ -87,9 +93,9 @@ " | _ -> indent i)", " | Some ';' -> indent i", " | (Some '[') | (Some '(') -> \"\"",- " | Some _ -> (match s with",+ " | Some c -> if isWhiteSpace c then \"\" else (match s with", " \",\" | \")\" | \"]\" -> \"\"",- " | _ -> \" \") in",+ " | _ -> if String.trim s = \"\" then \"\" else \" \") in", " let newindent = match s with", " \"{\" -> i + indent_width", " | \"}\" -> i - indent_width",@@ -122,7 +128,7 @@ ] doubleRule cf = unlines [- "let rec prtFloat (_:int) (f:float) : doc = render (sprintf \"%f\" f)",+ "let rec prtFloat (_:int) (f:float) : doc = render (sprintf \"%.15g\" f)", ifList cf (TokenCat catDouble), "" ]@@ -133,11 +139,11 @@ "" ] -identRule cf = ownPrintRule cf catIdent+identRule absMod cf = ownPrintRule absMod cf catIdent -ownPrintRule :: CF -> TokenCat -> String-ownPrintRule cf own = unlines $ [- "let rec" +++ prtFun (TokenCat own) +++ "_ (" ++ own ++ posn ++ ") : doc = render i",+ownPrintRule :: ModuleName -> CF -> TokenCat -> String+ownPrintRule absMod cf own = unlines $ [+ "let rec" +++ prtFun (TokenCat own) +++ "_ (" ++ absMod ++ "." ++ own ++ posn ++ ") : doc = render i", ifList cf (TokenCat own) ] where@@ -145,9 +151,9 @@ -- copy and paste from CFtoTemplate -rules :: CF -> String-rules cf = unlines $ mutualDefs $- map (\(s,xs) -> case_fun s (map toArgs xs) ++ ifList cf s) $ cf2data cf+rules :: ModuleName -> CF -> String+rules absMod cf = unlines $ mutualDefs $+ map (\(s,xs) -> case_fun absMod s (map toArgs xs) ++ ifList cf s) $ cf2data cf where reserved = "i":"e":reservedOCaml toArgs (cons,args) = ((cons, mkNames reserved LowerCase (map var args)), ruleOf cons)@@ -158,14 +164,14 @@ var (Cat "Char") = "c" var (Cat "Double") = "d" var xs = map toLower (show xs)- ruleOf s = fromJust $ lookupRule s (cfgRules cf)+ ruleOf s = fromJust $ lookupRule (noPosition s) (cfgRules cf) --- case_fun :: Cat -> [(Constructor,Rule)] -> String-case_fun cat xs = unlines [+case_fun absMod cat xs = unlines [ -- "instance Print" +++ cat +++ "where",- prtFun cat +++"(i:int)" +++ "(e:" ++ fixType cat ++ ") : doc = match e with",+ prtFun cat +++"(i:int)" +++ "(e : " ++ fixTypeQual absMod cat ++ ") : doc = match e with", unlines $ insertBar $ map (\ ((c,xx),r) ->- " " ++ c +++ mkTuple xx +++ "->" ++++ " " ++ absMod ++ "." ++ c +++ mkTuple xx +++ "->" +++ "prPrec i" +++ show (precCat (fst r)) +++ mkRhs xx (snd r)) xs ] @@ -194,26 +200,26 @@ -- | Pattern match on the list constructor and the coercion level ----- >>> mkPrtListCase (Rule "[]" (ListCat (Cat "Foo")) [])+-- >>> mkPrtListCase (npRule "[]" (ListCat (Cat "Foo")) [] Parsable) -- (_,[]) -> (concatD []) ----- >>> mkPrtListCase (Rule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")])+-- >>> mkPrtListCase (npRule "(:[])" (ListCat (Cat "Foo")) [Left (Cat "Foo")] Parsable) -- (_,[x]) -> (concatD [prtFoo 0 x]) ----- >>> mkPrtListCase (Rule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))])+-- >>> mkPrtListCase (npRule "(:)" (ListCat (Cat "Foo")) [Left (Cat "Foo"), Left (ListCat (Cat "Foo"))] Parsable) -- (_,x::xs) -> (concatD [prtFoo 0 x ; prtFooListBNFC 0 xs]) ----- >>> mkPrtListCase (Rule "[]" (ListCat (CoercCat "Foo" 2)) [])+-- >>> mkPrtListCase (npRule "[]" (ListCat (CoercCat "Foo" 2)) [] Parsable) -- (2,[]) -> (concatD []) ----- >>> mkPrtListCase (Rule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)])+-- >>> mkPrtListCase (npRule "(:[])" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2)] Parsable) -- (2,[x]) -> (concatD [prtFoo 2 x]) ----- >>> mkPrtListCase (Rule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))])+-- >>> mkPrtListCase (npRule "(:)" (ListCat (CoercCat "Foo" 2)) [Left (CoercCat "Foo" 2), Left (ListCat (CoercCat "Foo" 2))] Parsable) -- (2,x::xs) -> (concatD [prtFoo 2 x ; prtFooListBNFC 2 xs]) -- mkPrtListCase :: Rule -> Doc-mkPrtListCase (Rule f (ListCat c) rhs)+mkPrtListCase (Rule f (WithPosition _ (ListCat c)) rhs _) | isNilFun f = parens (precPattern <> "," <> "[]") <+> "->" <+> body | isOneFun f = parens (precPattern <> "," <> "[x]") <+> "->" <+> body | isConsFun f = parens (precPattern <> "," <>"x::xs") <+> "->" <+> body@@ -226,7 +232,6 @@ 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 " ++ mkEsc s) : mk args items mk _ _ = []
src/BNFC/Backend/OCaml/CFtoOCamlShow.hs view
@@ -20,6 +20,7 @@ -- there is no "deriving Show" in OCaml, although there are solutions based -- on camlp4. Here we generate our own "show module". +{-# LANGUAGE LambdaCase #-} module BNFC.Backend.OCaml.CFtoOCamlShow (cf2show, showsFunQual) where @@ -31,21 +32,20 @@ import BNFC.Utils 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+cf2show :: String -> ModuleName -> CF -> String+cf2show _name absMod cf = unlines+ [ prologue+ , integerRule+ , doubleRule+ , if hasIdent cf then identRule absMod cf else ""+ , unlines [ ownPrintRule absMod cf own | (own,_) <- tokenPragmas cf ]+ , rules absMod cf ] -prologue :: String -> String -> String-prologue _ absMod = unlines [+prologue :: String+prologue = unlines [ "(* show functions generated by the BNF converter *)\n",- "open " ++ absMod, "", "(* use string buffers for efficient string concatenations *)", "type showable = Buffer.t -> unit",@@ -81,26 +81,26 @@ "" ] -integerRule _ = "let showInt (i:int) : showable = s2s (string_of_int i)"+integerRule = "let showInt (i:int) : showable = s2s (string_of_int i)" -doubleRule _ = "let showFloat (f:float) : showable = s2s (string_of_float f)"+doubleRule = "let showFloat (f:float) : showable = s2s (string_of_float f)" -identRule cf = ownPrintRule cf catIdent+identRule absMod cf = ownPrintRule absMod cf catIdent -ownPrintRule :: CF -> TokenCat -> String-ownPrintRule cf own =- "let rec" +++ showsFun (TokenCat own) +++ "(" ++ own ++ posn ++ ") : showable = s2s \""+ownPrintRule :: ModuleName -> CF -> TokenCat -> String+ownPrintRule absMod cf own =+ "let rec" +++ showsFun (TokenCat own) +++ "(" ++ absMod ++ "." ++ 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+rules :: ModuleName -> CF -> String+rules absMod cf = unlines $ mutualDefs $+ map (\ (s, xs) -> case_fun absMod s $ map toArgs xs) $ cf2data cf+ where toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons) names [] _ = []@@ -117,13 +117,13 @@ checkRes s | elem s reservedOCaml = s ++ "'" | otherwise = s- ruleOf s = fromJust $ lookupRule s (cfgRules cf)+ ruleOf s = fromJust $ lookupRule (noPosition s) (cfgRules cf) -- case_fun :: Cat -> [(Constructor,Rule)] -> String-case_fun cat xs = unlines [- showsFun cat +++ "(e:" ++ fixType cat ++ ") : showable = match e with",+case_fun absMod cat xs = unlines [+ showsFun cat +++ "(e : " ++ fixTypeQual absMod cat ++ ") : showable = match e with", unlines $ insertBar $ map (\ ((c,xx),r) ->- " " ++ c +++ mkTuple xx +++ "->" ++++ " " ++ absMod ++ "." ++ c +++ mkTuple xx +++ "->" +++ "s2s" +++ show c +++ case mkRhs xx (snd r) of {[] -> []; str -> ">> c2s ' ' >> " ++ str} )@@ -136,7 +136,6 @@ [] -> "" 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 _ : items) = mk args items mk _ _ = []
src/BNFC/Backend/OCaml/CFtoOCamlTest.hs view
@@ -21,7 +21,7 @@ module BNFC.Backend.OCaml.CFtoOCamlTest where -import Prelude'+import Prelude hiding ((<>)) import Text.PrettyPrint @@ -56,7 +56,7 @@ , text $ qualify showM "show" , parens $ text (showsFunQual (qualify showM) cat) <+> "x" ]- topType = text absM <> "." <> text (fixType $ normCat cat)+ topType = text (fixTypeQual absM $ normCat cat) in vcat [ comment "automatically generated by the BNF Converter" , ""
src/BNFC/Backend/OCaml/CFtoOCamlYacc.hs view
@@ -19,6 +19,7 @@ -- based on BNFC Haskell backend +{-# LANGUAGE LambdaCase #-} module BNFC.Backend.OCaml.CFtoOCamlYacc (@@ -26,11 +27,11 @@ ) where -import BNFC.CF-import Data.List (intersperse,nub) import Data.Char +import BNFC.CF import BNFC.Utils ((+++))+import BNFC.Backend.Common import BNFC.Backend.OCaml.OCamlUtil -- Type declarations@@ -63,43 +64,54 @@ ] definedRules :: CF -> String-definedRules cf = unlines [mkDef f xs e | FunDef f xs e <- cfgPragmas cf]- where- mkDef f xs e =- "let " ++ f ++ " " ++ mkTuple xs ++ " = " ++ ocamlExp e- where- ocamlExp :: Exp -> String- ocamlExp (App s es) = s ++ ' ' : mkTuple (map ocamlExp es)- ocamlExp (LitInt i) = show i- ocamlExp (LitDouble d) = show d- ocamlExp (LitChar c) = "\'" ++ c : "\'"- ocamlExp (LitString s) = "\"" ++ s ++ "\""+definedRules cf = unlines [ mkDef f xs e | FunDef f xs e <- cfgPragmas cf ]+ where+ mkDef f xs e = "let " ++ funName f ++ " " ++ mkTuple xs ++ " = " ++ ocamlExp e + ocamlExp :: Exp -> String+ ocamlExp = \case+ Var s -> s+ App s es -> s ++ ' ' : mkTuple (map ocamlExp es)+ LitInt i -> show i+ LitDouble d -> show d+ LitChar c -> "\'" ++ c : "\'"+ LitString s -> "\"" ++ s ++ "\""+ declarations :: String -> CF -> String-declarations absName cf = unlines- [tokens (cfgSymbols cf) (reservedWords cf),- specialTokens cf,- entryPoints absName cf+declarations absName cf =+ unlines+ [ tokens (unicodeAndSymbols cf) (asciiKeywords cf)+ , specialTokens cf+ , entryPoints absName cf ] +-- | Declare keyword and symbol tokens.+ 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..])+tokens symbols reswords =+ unlines $ concat+ [ [ unwords $ "%token" : map ("KW_" ++) reswords | hasReserved ]+ , [ "" | hasReserved ]+ , (`map` zip symbols [1..]) $ \ (s, n) ->+ "%token SYMB" ++ show n +++ "/*" +++ s +++ "*/" ]+ where+ hasReserved = not $ null reswords -- | 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 (cfgSymbols cf) [1..]) of- Just i -> "SYMB" ++ show i- Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF."-+terminal cf = \ s ->+ -- Use a lambda here to make sure that kws is computed before the+ -- second argument is applied.+ -- The GHC manual says that let-floating is not consistently applied+ -- so just writing @terminal cf s = ...@ could result in computing+ -- kws for every @s@ anew.+ if s `elem` kws then "KW_" ++ s+ else case lookup s (zip (unicodeAndSymbols cf) [1..]) of+ Just i -> "SYMB" ++ show i+ Nothing -> error $ "CFtoOCamlYacc: terminal " ++ show s ++ " not defined in CF."+ where+ kws = asciiKeywords cf -- | map a CF nonterminal into a ocamlyacc symbol nonterminal :: Cat -> String@@ -108,21 +120,27 @@ spaceToUnderscore x = x specialTokens :: CF -> String-specialTokens cf = unlines . ("%token TOK_EOF" :) $- map (\ n -> "%token" +++ aux n +++ "TOK_" ++ n) $ nub $ specialCatsP ++ literals cf+specialTokens cf = unlines $ concat $+ [ [ "%token TOK_EOF" ]+ , [ prToken (ty n) n | n <- specialCatsP ]+ , [ prToken (posTy pos) n | TokenReg n0 pos _ <- cfgPragmas cf, let n = wpThing n0 ]+ ] where- aux = \case+ prToken t n = "%token" +++ t +++ "TOK_" ++ n+ ty = \case "Ident" -> "<string>" "String" -> "<string>" "Integer" -> "<int>" "Double" -> "<float>" "Char" -> "<char>"- _ -> "<string>"+ posTy = \case+ True -> "<(int * int) * string>"+ False -> "<string>" + entryPoints :: String -> CF -> String entryPoints absName cf = unlines $- ("%start" +++- concat (intersperse " " (map epName eps)))+ ("%start" +++ unwords (map epName eps)) : (map typing eps) where eps = allEntryPoints cf@@ -158,7 +176,7 @@ specialRules cf ] where- mkOne (cat,rules) = constructRule cf rules cat+ mkOne (cat,rules) = (cat, constructRule (terminal cf) rules cat) prOne (_,[]) = [] -- nt has only internal use prOne (nt,((p,a):ls)) = unwords [nt', ":" , p, "{", a, "}", "\n" ++ pr ls] ++ ";\n"@@ -166,55 +184,42 @@ nt' = nonterminal nt pr [] = [] pr ((p,a):ls) =- unlines [(concat $ intersperse " " [" |", p, "{", a , "}"])] ++ pr ls+ unlines [ unwords [ " |", 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 = cfgReversibleCats cf- mkFlip doit xs = case xs of- a:b:rest | doit -> b:a:rest- _ -> xs+constructRule :: (String -> String) -> [Rule] -> NonTerminal -> [(Pattern,Action)]+constructRule terminal rules nt =+ [ (p, generateAction nt (funRule r) m)+ | r <- rules+ , let (p, m) = generatePatterns terminal r+ ] -- 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 :: IsFun a => NonTerminal -> a -> [MetaVar] -> Action generateAction _ 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+ where+ f' = case funName f of -- ocaml cons is somehow not a standard infix oper, right?+ "(:[])" -> "(fun x -> [x])"+ "(:)" -> "(fun (x,xs) -> x::xs)"+ x -> x -generatePatterns :: CF -> Rule -> (Pattern,[MetaVar])-generatePatterns cf r = case rhsRule r of+generatePatterns :: (String -> String) -> Rule -> (Pattern,[MetaVar])+generatePatterns terminal 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 = cfgReversibleCats cf-+ Right s -> terminal s+ metas its = [ ('$': show i) | (i, Left _c) <- zip [1 ::Int ..] its ] specialRules :: CF -> String specialRules cf = unlines $ (`map` literals cf) $ \case
src/BNFC/Backend/OCaml/OCamlUtil.hs view
@@ -17,6 +17,8 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE LambdaCase #-}+ module BNFC.Backend.OCaml.OCamlUtil where import BNFC.CF@@ -26,13 +28,23 @@ -- Translate Haskell types to OCaml types -- Note: OCaml (data-)types start with lowercase letter fixType :: Cat -> String-fixType (ListCat c) = fixType c +++ "list"-fixType (TokenCat "Integer") = "int"-fixType (TokenCat "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+fixType = fixTypeQual "" +fixTypeQual :: String -- ^ Module name (or empty string for no qualification).+ -> Cat -> String+fixTypeQual m = \case+ ListCat c -> fixTypeQual m c +++ "list"+ -- unqualified base types+ TokenCat "Integer" -> "int"+ TokenCat "Double" -> "float"+ TokenCat "String" -> "string"+ TokenCat "Char" -> "char"+ cat -> if null m then base else concat [ m, ".", base ]+ where+ c:cs = identCat cat+ ls = toLower c : cs+ base = if ls `elem` reservedOCaml then ls ++ "T" else ls+ -- as fixType, but leave first character in upper case fixTypeUpper :: Cat -> String fixTypeUpper c = case fixType c of@@ -48,9 +60,31 @@ "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"]+ "new","nonrec","object","of","open","or",+ "private","rec","sig","struct","then","to",+ "true","try","type","val","virtual","when",+ "while","with"]++-- | Keywords of @ocamllex@.+reservedOCamlLex :: [String]+reservedOCamlLex =+ [ "and"+ , "as"+ , "eof"+ , "let"+ , "parse"+ , "refill"+ , "rule"+ , "shortest"+ ]++-- | Heuristics to produce name for ocamllex token definition that+-- does not clash with the ocamllex keywords.+ocamlTokenName :: String -> String+ocamlTokenName x0+ | x `elem` reservedOCamlLex = x ++ "_"+ | otherwise = x+ where x = mapHead toLower x0 mkTuple :: [String] -> String mkTuple [] = ""
src/BNFC/Backend/Pygments.hs view
@@ -9,7 +9,7 @@ - -} module BNFC.Backend.Pygments where -import Prelude'+import Prelude hiding ((<>)) import AbsBNF (Reg(..)) import BNFC.Backend.Base (mkfile, Backend)@@ -157,4 +157,3 @@ escape c = [c] pyRegex' r@(RAlt{}) = parens (pyRegex r) pyRegex' r = pyRegex r-
src/BNFC/Backend/XML.hs view
@@ -20,15 +20,16 @@ module BNFC.Backend.XML ---- (cf2DTD, cf2XML) where +import Data.Bifunctor ( second )+import Data.List ( intercalate )+ import BNFC.CF import BNFC.Utils import BNFC.Backend.Base-import BNFC.Options hiding (Backend)+import BNFC.Options hiding ( Backend ) import BNFC.Backend.Haskell.CFtoTemplate ()-import BNFC.Backend.Haskell.HsOpts (xmlFile, xmlFileM, absFileM)-import Data.List (intersperse, intercalate)-import Data.Char(toLower)-import Data.Maybe (fromJust)+import BNFC.Backend.Haskell.HsOpts ( xmlFile, xmlFileM, absFileM )+import BNFC.Backend.Haskell.Utils ( catToVar ) type Coding = Bool ---- change to at least three values @@ -74,9 +75,7 @@ elemEmp t = elemAtt t "value" [] alts :: [String] -> String-alts ts =- if null ts then "EMPTY" else parenth (unwords (intersperse "|" ts))-+alts ts = if null ts then "EMPTY" else parenth $ intercalate " | " ts -- choose between these two encodings: @@ -129,7 +128,7 @@ where funs k = case lookup k (cf2data cf) of Just [] -> "EMPTY"- Just fcs -> parenth $ unwords $ intersperse "|" $ map fst fcs+ Just fcs -> parenth $ intercalate " | " $ map fst fcs _ -> parenth (show k) ---- parenth s = "(" ++ s ++ ")"@@ -205,36 +204,22 @@ rules :: CF -> String rules cf = unlines $- map (\(s,xs) -> case_fun s (map toArgs xs)) $ cf2data cf+ map (\ (s, xs) -> case_fun s (map (second toArgs) xs)) $ cf2data cf where- toArgs (cons,args) = ((cons, names (map (checkRes . var) args) (0 :: Int)), ruleOf cons)+ toArgs args = names (map catToVar args) (0 :: Int) names [] _ = [] names (x:xs) n | x `elem` 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- | s `elem` 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 = fromJust $ lookupRule s (cfgRules cf)+ | otherwise = x : names xs n --- 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),_) ->+case_fun :: Cat -> [(String, [String])] -> String+case_fun cat xs = unlines $ concat+ [ [ "instance XPrint" +++ show cat +++ "where"+ , " prt i" +++ "e = case e of"+ ]+ , (`map` xs) $ \ (c, xx) -> " " ++ c +++ unwords xx +++ "-> concat $ " +++ "elemFun i \"" ++ show cat ++ "\" \"" ++ c ++ "\"" +++ unwords [": prt (i+1)" +++ x | x <- xx] +++ ":" +++ "[[replicate (i+i) ' ' ++ endtag \"" ++ c ++ "\" \"" ++ show cat ++ "\"]]"- ) xs ]
src/BNFC/CF.hs view
@@ -1,7 +1,11 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-} {- BNF Converter: Abstract syntax@@ -26,25 +30,26 @@ -- Types. CF, CFG(..),- Rule, Rul(..), lookupRule,+ Rule, Rul(..), npRule, valCat, lookupRule, InternalRule(..), Pragma(..), Exp(..),+ Base(..), Type(..), Signature, Literal, Symbol, KeyWord,+ Position(..), noPosition, prettyPosition, npIdentifier,+ WithPosition(..), blendInPosition,+ RString, RCat, Cat(..), strToCat, catToStr, TokenCat, catString, catInteger, catDouble, catChar, catIdent,- NonTerminal,- Fun,- Tree(..),- prTree, -- print an abstract syntax tree+ NonTerminal, SentForm,+ Fun, RFun, IsFun(..), 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. getAbstractSyntax, -- Literal categories, constants,- firstCat, -- the first value category in the grammar. firstEntry, -- the first entry or the first value category baseTokenCatNames, -- "Char", "Double", "Integer", "String" specialCats, -- ident@@ -54,6 +59,8 @@ isDefinedRule, -- defined rules (allows syntactic sugar) isProperLabel, -- not coercion or defined rule allCats, -- all categories of a grammar+ allParserCats, allParserCatsNorm,+ reallyAllCats, allCatsNorm, allCatsIdNorm, allEntryPoints,@@ -70,7 +77,7 @@ allNames, -- Checking for non-unique names, like @Name. Name ::= Ident;@. filterNonUnique, isList, -- Checks if a category is a list category.- isTokenCat,+ isTokenCat, maybeTokenCat, sameCat, -- Information functions for list functions. isNilFun, -- empty list function? ([])@@ -83,22 +90,24 @@ isEmptyListCat, -- checks if the list permits [] revSepListRule, -- reverse a rule, if it is of form C t [C]. normCat,- isDataCat,+ isDataCat, isDataOrListCat, normCatOfList, -- Removes precendence information and enclosed List. C1 => C, C2 => C catOfList, comments, -- translates the pragmas into two list containing the s./m. comments+ numberOfBlockCommentForms, 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,+ isUsedCat, usedTokenCats, isPositionCat,- hasIdent,+ hasPositionTokens,+ hasIdent, hasIdentLikeTokens, hasLayout, layoutPragmas,- normFun,+ sigLookup, -- Get the type of a rule label. CFP, -- CF with profiles RuleP,@@ -111,20 +120,26 @@ funRuleP, ruleGroupsP, allCatsP, allEntryPointsP ) where -import BNFC.Utils (prParenth,(+++)) import Control.Monad (guard)-import Data.List (nub, intersperse, sort, group, intercalate, find, sortBy) import Data.Char+import Data.Function (on)+import Data.List (nub, intersperse, sort, group, intercalate, find)+import qualified Data.List as List+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.String (IsString(..))+ import AbsBNF (Reg()) import ParBNF (pCat) import LexBNF (tokens)-import qualified AbsBNF-import ErrM+import qualified AbsBNF as Abs -- | A context free grammar consists of a set of rules and some extended -- information (e.g. pragmas, literals, symbols, keywords). -type CF = CFG Fun+type CF = CFG RFun -- | A rule consists of a function name, a main category and a sequence of -- terminals and non-terminals.@@ -132,7 +147,7 @@ -- function_name . Main_Cat ::= sequence -- @ -type Rule = Rul Fun+type Rule = Rul RFun -- | Polymorphic rule type for common type signatures for CF and CFP. @@ -141,17 +156,29 @@ -- ^ 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+ , valRCat :: RCat -- ^ The value category, i.e., the defined non-terminal.- , rhsRule :: [Either Cat String]+ , rhsRule :: SentForm -- ^ The sentential form, i.e., -- the list of (non)terminals in the right-hand-side of a rule.+ , internal :: InternalRule+ -- ^ Is this an "internal" rule only for the AST and printing,+ -- not for parsing? } deriving (Eq, Functor) +data InternalRule+ = Internal -- ^ @internal@ rule (only for AST & printer)+ | Parsable -- ^ ordinary rule (also for parser)+ deriving (Eq)+ instance (Show function) => Show (Rul function) where- show (Rule f cat rhs) =- unwords (show f : "." : show cat : "::=" : map (either show id) rhs)+ show (Rule f cat rhs internal) = unwords $+ (if internal == Internal then ("internal" :) else id) $+ show f : "." : show cat : "::=" : map (either show id) rhs +-- | A sentential form is a sequence of non-terminals or terminals.+type SentForm = [Either Cat String]+ -- | Polymorphic CFG type for common type signatures for CF and CFP. data CFG function = CFG@@ -163,20 +190,41 @@ , cfgKeywords :: [KeyWord] -- ^ Reserved words, e.g. 'if' 'while'. , cfgReversibleCats :: [Cat] -- ^ Categories that can be made left-recursive. , cfgRules :: [Rul function]+ , cfgSignature :: Signature -- ^ Types of rule labels, computed from 'cfgRules'. } deriving (Functor) instance (Show function) => Show (CFG function) where show CFG{..} = unlines $ map show cfgRules +-- | Types of the rule labels, together with the position of the rule label.+type Signature = Map String (WithPosition Type) +-- | Type of a non-terminal.+data Base = BaseT String+ | ListT Base+ deriving (Eq, Ord)++-- | Type of a rule label.+data Type = FunT [Base] Base+ deriving (Eq, Ord)++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]+ -- | Expressions for function definitions. -data Exp = App String [Exp]- | LitInt Integer- | LitDouble Double- | LitChar Char- | LitString String+data Exp+ = App String [Exp] -- ^ (Possibly defined) label applied to expressions.+ | Var String -- ^ Function parameter.+ | LitInt Integer+ | LitDouble Double+ | LitChar Char+ | LitString String deriving (Eq) instance Show Exp where@@ -186,6 +234,7 @@ showString "[" . foldr (.) id (intersperse (showString ", ") $ map shows es) . showString "]"+ Left (Var x) -> showString x Left (App x []) -> showString x Left (App "(:)" [e1,e2]) -> showParen (p>0)@@ -211,18 +260,18 @@ data Pragma = CommentS String -- ^ for single line comments | CommentM (String,String) -- ^ for multiple-line comments.- | TokenReg String Bool Reg -- ^ for tokens- | EntryPoints [Cat]+ | TokenReg RString Bool Reg -- ^ for tokens+ | EntryPoints [RCat] | Layout [String] | LayoutStop [String] | LayoutTop- | FunDef String [String] Exp+ | FunDef RFun [String] Exp -- ... deriving (Show) -- | User-defined regular expression tokens tokenPragmas :: CFG f -> [(TokenCat,Reg)]-tokenPragmas cf = [ (name, e) | TokenReg name _ e <- cfgPragmas cf ]+tokenPragmas cf = [ (wpThing name, e) | TokenReg name _ e <- cfgPragmas cf ] -- | The names of all user-defined tokens. tokenNames :: CFG f -> [String]@@ -245,15 +294,70 @@ type KeyWord = String ------------------------------------------------------------------------------+-- Identifiers with position information+------------------------------------------------------------------------------++-- | Source positions.+data Position+ = NoPosition+ | Position+ { posFile :: FilePath -- ^ Name of the grammar file.+ , posLine :: Int -- ^ Line in the grammar file.+ , posColumn :: Int -- ^ Column in the grammar file.+ } deriving (Show, Eq, Ord)++prettyPosition :: Position -> String+prettyPosition = \case+ NoPosition -> ""+ Position file line col -> List.intercalate ":" [ file, show line, show col, "" ]++data WithPosition a = WithPosition+ { wpPosition :: Position+ , wpThing :: a+ } deriving (Show, Functor, Foldable, Traversable)++-- | Ignore position in equality and ordering.+instance Eq a => Eq (WithPosition a) where (==) = (==) `on` wpThing+instance Ord a => Ord (WithPosition a) where compare = compare `on` wpThing++noPosition :: a -> WithPosition a+noPosition = WithPosition NoPosition++-- | A "ranged string" (terminology from Agda code base).+type RString = WithPosition String++-- | Prefix string with pretty-printed position information.+blendInPosition :: RString -> String+blendInPosition (WithPosition pos msg)+ | null p = msg+ | otherwise = unwords [ p, msg ]+ where+ p = prettyPosition pos++type RCat = WithPosition Cat++valCat :: Rul fun -> Cat+valCat = wpThing . valRCat++npRule :: Fun -> Cat -> SentForm -> InternalRule -> Rule+npRule f c r internal = Rule (noPosition f) (noPosition c) r internal++npIdentifier :: String -> Abs.Identifier+npIdentifier x = Abs.Identifier ((0, 0), x)++-- identifierName :: Identifier -> String+-- identifierName (Identifier (_, x)) = x++-- identifierPosition :: String -> Identifier -> Position+-- identifierPosition file (Identifier ((line, col), _)) = Position file line col++------------------------------------------------------------------------------ -- Categories ------------------------------------------------------------------------------ -- | 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 -- ^ Ordinary non-terminal.+ = Cat String -- ^ Ordinary non-terminal. | TokenCat TokenCat -- ^ Token types (like @Ident@, @Integer@, ..., user-defined). | ListCat Cat -- ^ List non-terminals, e.g., @[Ident]@, @[Exp]@, @[Exp1]@. | CoercCat String Integer -- ^ E.g. @Exp1@, @Exp2.@@ -267,7 +371,6 @@ -- | Render category symbols as strings catToStr :: Cat -> String catToStr = \case- InternalCat -> "#" Cat s -> s TokenCat s -> s ListCat c -> "[" ++ catToStr c ++ "]"@@ -281,18 +384,17 @@ -- categories are parsed in the grammar already. To be on the safe side here, -- we still call the parser function that parses categries. strToCat :: String -> Cat-strToCat "#" = InternalCat strToCat s = case pCat (tokens s) of- Ok c -> cat2cat c- Bad _ -> Cat s -- error $ "Error parsing cat " ++ s ++ " (" ++ e ++ ")"+ Right c -> cat2cat c+ Left _ -> 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 i)) =+ where cat2cat (Abs.IdCat (Abs.Identifier (_pos, i))) = case span isDigit (reverse i) of ([],c') -> Cat (reverse c') (d,c') -> CoercCat (reverse c') (read (reverse d))- cat2cat (AbsBNF.ListCat c) = ListCat (cat2cat c)+ cat2cat (Abs.ListCat c) = ListCat (cat2cat c) -- Build-in categories contants catString, catInteger, catDouble, catChar, catIdent :: TokenCat@@ -347,7 +449,7 @@ -- Latex) identCat :: Cat -> String identCat (ListCat c) = "List" ++ identCat c-identCat c = show c+identCat c = catToStr c isList :: Cat -> Bool isList (ListCat _) = True@@ -357,6 +459,11 @@ isTokenCat (TokenCat _) = True isTokenCat _ = False +maybeTokenCat :: Cat -> Maybe TokenCat+maybeTokenCat = \case+ TokenCat c -> Just c+ _ -> Nothing+ -- | Unwraps the list constructor from the category name. -- E.g. @[C1] => C1@. catOfList :: Cat -> Cat@@ -369,62 +476,73 @@ -- | Fun is the function name of a rule. type Fun = String+type RFun = RString --- | Is this function just a coercion? (I.e. the identity)-isCoercion :: Fun -> Bool-isCoercion = (== "_") -- perhaps this should be changed to "id"?+instance IsString RFun where+ fromString = noPosition -isDefinedRule :: Fun -> Bool-isDefinedRule (x:_) = isLower x-isDefinedRule [] = error "isDefinedRule: empty function name"+class IsFun a where+ funName :: a -> String -isProperLabel :: Fun -> Bool-isProperLabel f = not (isCoercion f || isDefinedRule f)+instance IsFun String where+ funName = id +instance IsFun a => IsFun (WithPosition a) where+ funName = funName . wpThing --- | 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+funNameSatisfies :: IsFun a => (String -> Bool) -> a -> Bool+funNameSatisfies f = f . funName -isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: Fun -> Bool+-- | Is this function just a coercion? (I.e. the identity)+isCoercion :: IsFun a => a -> Bool+isCoercion = funNameSatisfies (== "_") -- perhaps this should be changed to "id"?++isDefinedRule :: IsFun a => a -> Bool+isDefinedRule = funNameSatisfies $ \case+ (x:_) -> isLower x+ [] -> error "isDefinedRule: empty function name"++-- isDefinedRule :: Fun -> Bool+-- isDefinedRule (WithPosition _ (x:_)) = isLower x+-- isDefinedRule (WithPosition pos []) = error $+-- unwords [ prettyPosition pos, "isDefinedRule: empty function name" ]++isProperLabel :: IsFun a => a -> Bool+isProperLabel f = not (isCoercion f || isDefinedRule f)++isNilFun, isOneFun, isConsFun, isNilCons,isConcatFun :: IsFun a => a -> Bool isNilCons f = isNilFun f || isOneFun f || isConsFun f || isConcatFun f-isNilFun f = f == "[]"-isOneFun f = f == "(:[])"-isConsFun f = f == "(:)"-isConcatFun f = f == "(++)"+isNilFun = funNameSatisfies (== "[]")+isOneFun = funNameSatisfies (== "(:[])")+isConsFun = funNameSatisfies (== "(:)")+isConcatFun = funNameSatisfies (== "(++)") ------------------------------------------------------------------------------ --- | Abstract syntax tree.-newtype Tree = Tree (Fun,[Tree])- -- | The abstract syntax of a grammar.-type Data = (Cat, [(Fun,[Cat])])+type Data = (Cat, [(String, [Cat])]) --- | @firstCat@ returns the first @Cat@egory appearing in the grammar.-firstCat :: CF -> Cat-firstCat = valCat . head . cfgRules+-- | @firstEntry@ returns the first entrypoint+-- or (if none), the first @Cat@egory appearing in the grammar. firstEntry :: CF -> Cat-firstEntry cf = case allEntryPoints cf of- (x:_) -> x- _ -> firstCat cf+firstEntry cf =+ case allEntryPoints cf of+ (x:_) -> x+ [] -> valCat . head . cfgRules $ cf -- aggressively ban nonunique names (AR 31/5/2012) --- | Categories and constructors.-allNames :: CF -> [Fun]-allNames cf = allCatsIdNorm cf +++-- | Constructors and categories.+allNames :: CF -> [RString]+allNames cf = [ f | f <- map funRule $ cfgRules cf , not $ isNilCons f , not $ isCoercion f- ]+ ] +++ allCatsIdNorm cf+ -- Put the categories after the labels so that the error location+ -- for a non-unique name is at the label rather than the category. -- | Get all elements with more than one occurrence. filterNonUnique :: (Ord a) => [a] -> [a]@@ -438,14 +556,24 @@ isComment (CommentM _) = True isComment _ = False -lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, [Either Cat String])+lookupRule :: Eq f => f -> [Rul f] -> Maybe (Cat, SentForm) lookupRule f = lookup f . map unRule- where unRule (Rule f' c rhs) = (f',(c,rhs))+ where unRule (Rule f' c rhs _internal) = (f', (wpThing c, rhs)) --- | Returns all normal rules that constructs the given Cat.+-- | Returns all parseable rules that construct the given Cat.+-- Whitespace separators have been removed. rulesForCat :: CF -> Cat -> [Rule]-rulesForCat cf cat = [r | r <- cfgRules cf, isParsable r, valCat r == cat]+rulesForCat cf cat =+ [ removeWhiteSpaceSeparators r | r <- cfgRules cf, isParsable r, valCat r == cat] +removeWhiteSpaceSeparators :: Rul f -> Rul f+removeWhiteSpaceSeparators = mapRhs $ mapMaybe $ either (Just . Left) $ \ sep ->+ if all isSpace sep then Nothing else Just (Right sep)++-- | Modify the 'rhsRule' part of a 'Rule'.+mapRhs :: (SentForm -> SentForm) -> Rul f -> Rul f+mapRhs f r = r { rhsRule = f $ rhsRule r }+ -- | Like rulesForCat but for normalized value categories. -- I.e., `rulesForCat (Cat "Exp")` will return rules for category Exp but also -- Exp1, Exp2... in case of coercion@@ -457,29 +585,50 @@ rulesForCat' :: CF -> Cat -> [Rule] rulesForCat' cf cat = [r | r <- cfgRules 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 . cfgRules+-- | Get all categories of a grammar matching the filter.+-- (No Cat w/o production returned; no duplicates.)+allCats :: (InternalRule -> Bool) -> CFG f -> [Cat]+allCats pred = nub . map valCat . filter (pred . internal) . cfgRules +-- | Get all categories of a grammar.+-- (No Cat w/o production returned; no duplicates.)+reallyAllCats :: CFG f -> [Cat]+reallyAllCats = allCats $ const True++allParserCats :: CFG f -> [Cat]+allParserCats = allCats (== Parsable)+ -- | Gets all normalized identified Categories-allCatsIdNorm :: CF -> [String]-allCatsIdNorm = nub . map (identCat . normCat . valCat) . cfgRules+allCatsIdNorm :: CF -> [RString]+allCatsIdNorm = nub . map (fmap (identCat . normCat) . valRCat) . cfgRules -- | Get all normalized Cat allCatsNorm :: CF -> [Cat] allCatsNorm = nub . map (normCat . valCat) . cfgRules +-- | Get all normalized Cat+allParserCatsNorm :: CFG f -> [Cat]+allParserCatsNorm = nub . map normCat . allParserCats+ -- | Is the category is used on an rhs?+-- Includes internal rules. isUsedCat :: CFG f -> Cat -> Bool-isUsedCat cf cat = cat `elem` [c | r <- cfgRules cf, Left c <- rhsRule r]+isUsedCat cf = (`elem` [ c | Rule _ _ rhs _ <- cfgRules cf, Left c <- rhs ])+ -- TODO: isUsedCat is used in some places where the internal rules should be ignored. --- | Group all categories with their rules.+-- | All token categories used in the grammar.+-- Includes internal rules.+usedTokenCats :: CFG f -> [TokenCat]+usedTokenCats cf = [ c | Rule _ _ rhs _ <- cfgRules cf, Left (TokenCat c) <- rhs ]++-- | Group all parsable categories with their rules.+-- Deletes whitespace separators, as they will not become part of the parsing rules. ruleGroups :: CF -> [(Cat,[Rule])]-ruleGroups cf = [(c, rulesForCat cf c) | c <- allCats cf]+ruleGroups cf = [(c, rulesForCat cf c) | c <- allParserCats cf] -- | Group all categories with their rules including internal rules. ruleGroupsInternals :: CF -> [(Cat,[Rule])]-ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- allCats cf]+ruleGroupsInternals cf = [(c, rulesForCat' cf c) | c <- reallyAllCats cf] -- | Get all literals of a grammar. (e.g. String, Double) literals :: CFG f -> [TokenCat]@@ -497,10 +646,15 @@ -- | Comments can be defined by the 'comment' pragma comments :: CF -> ([(String,String)],[String])-comments cf = case commentPragmas (cfgPragmas cf) of- xs -> ([p | CommentM p <- xs],- [s | CommentS s <- xs])+comments cf = ([p | CommentM p <- xs], [s | CommentS s <- xs])+ where+ xs = commentPragmas (cfgPragmas cf) +-- | Number of block comment forms defined in the grammar file.+numberOfBlockCommentForms :: CF -> Int+numberOfBlockCommentForms = length . fst . comments++ -- built-in categories (corresponds to lexer) -- | Whether the grammar uses the predefined Ident type.@@ -515,15 +669,7 @@ specialCats :: CF -> [TokenCat] specialCats cf = (if hasIdent cf then (catIdent:) else id) (map fst (tokenPragmas cf)) --- 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 -- -- The abstract syntax, instantiated by the Data type, is the type signatures@@ -542,8 +688,8 @@ guard $ not (isDefinedRule f) guard $ not (isCoercion f) guard $ normCat (valCat rule) == cat- let cs = [normCat c | Left c <- rhsRule rule, c /= InternalCat]- return (f, cs)+ let cs = [normCat c | Left c <- rhsRule rule ]+ return (wpThing f, cs) -- | All the functions below implement the idea of getting the@@ -557,9 +703,9 @@ let f = funRule r, not (isDefinedRule f), not (isCoercion f), sameCat cat (valCat r)]))- | cat <- nub $ map normCat $ filter predicate $ allCats cf ]+ | cat <- nub $ map normCat $ filter predicate $ reallyAllCats cf ] where- mkData (Rule f _ its) = (f, [normCat c | Left c <- its, c /= InternalCat])+ mkData (Rule f _ its _) = (wpThing f, [normCat c | Left c <- its ]) cf2data :: CF -> [Data] cf2data = cf2data' $ isDataCat . normCat@@ -570,17 +716,14 @@ specialData :: CF -> [Data] specialData cf = [(TokenCat name, [(name, [TokenCat catString])]) | name <- specialCats cf] --- to deal with coercions---- the Haskell convention: the wildcard _ is not a constructor-+-- | Get the type of a rule label.+sigLookup :: IsFun a => a -> CF -> Maybe (WithPosition Type)+sigLookup f = Map.lookup (funName f) . cfgSignature -- | Checks if the rule is parsable. isParsable :: Rul f -> Bool-isParsable (Rule _ _ (Left c:_)) = c /= InternalCat-isParsable _ = True-+isParsable = (Parsable ==) . internal -- | Checks if the list has a non-empty rule.@@ -590,7 +733,7 @@ -- | Gets the separator for a list. getCons :: [Rule] -> String getCons rs = case find (isConsFun . funRule) rs of- Just (Rule _ _ cats) -> seper cats+ Just (Rule _ _ cats _) -> seper cats Nothing -> error $ "getCons: no construction function found in " ++ intercalate ", " (map (show . funRule) rs) where@@ -602,11 +745,11 @@ getSeparatorByPrecedence :: [Rule] -> [(Integer,String)] getSeparatorByPrecedence rules = [ (p, getCons (getRulesFor p)) | p <- precedences ] where- precedences = sortBy (flip compare) $ nub $ map precRule rules+ precedences = Set.toDescList . Set.fromList $ map precRule rules getRulesFor p = [ r | r <- rules, precRule r == p ] isEmptyListCat :: CF -> Cat -> Bool-isEmptyListCat cf c = elem "[]" $ map funRule $ rulesForCat' cf c+isEmptyListCat cf c = elem "[]" $ map (wpThing . funRule) $ rulesForCat' cf c isNonterm :: Either Cat String -> Bool isNonterm (Left _) = True@@ -615,7 +758,7 @@ -- 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+revSepListRule (Rule f c ts internal) = Rule f c (xs : x : sep) internal where (x,sep,xs) = (head ts, init (tail ts), last ts) -- invariant: test in findAllReversibleCats have been performed @@ -626,12 +769,12 @@ then tryRev r2 r1 else isConsFun (funRule r1) && tryRev r1 r2 _ -> False- tryRev (Rule f _ ts@(x:_:_)) r = isEmptyNilRule r &&+ tryRev (Rule f _ ts@(x:_:_) _) r = isEmptyNilRule r && isConsFun f && isNonterm x && isNonterm (last ts) tryRev _ _ = False -isEmptyNilRule :: Rul Fun -> Bool-isEmptyNilRule (Rule f _ ts) = isNilFun f && null ts+isEmptyNilRule :: IsFun a => Rul a -> Bool+isEmptyNilRule (Rule f _ ts _) = isNilFun f && null ts -- | Returns the precedence of a category symbol. -- E.g.@@ -642,43 +785,51 @@ precCat (ListCat c) = precCat c precCat _ = 0 -precRule :: Rule -> Integer+precRule :: Rul f -> Integer precRule = precCat . valCat precLevels :: CF -> [Integer]-precLevels cf = sort $ nub [ precCat c | c <- allCats cf]+precLevels cf = Set.toAscList $ Set.fromList [ precCat c | c <- reallyAllCats cf] precCF :: CF -> Bool precCF cf = length (precLevels cf) > 1 +-- | Defines or uses the grammar token types like @Ident@?+-- Excludes position tokens.+hasIdentLikeTokens :: CFG g -> Bool+hasIdentLikeTokens cf = hasIdent cf || or [ not b | TokenReg _ b _ <- cfgPragmas cf ] +-- | Is there a @position token@ declaration in the grammar?+hasPositionTokens :: CFG g -> Bool+hasPositionTokens cf = or [ b | TokenReg _ b _ <- cfgPragmas cf ]+ -- | Does the category have a position stored in AST? isPositionCat :: CFG f -> TokenCat -> Bool-isPositionCat cf cat = or [ b | TokenReg name b _ <- cfgPragmas cf, name == cat]+isPositionCat cf cat = or [ b | TokenReg name b _ <- cfgPragmas cf, wpThing name == cat] -- | Grammar with permutation profile à la GF. AR 22/9/2004 type CFP = CFG FunP-type FunP = (Fun,Prof)+type FunP = (RFun,Prof) type RuleP = Rul FunP -- | Pair of: the original function name, profile-type Prof = (Fun, [([[Int]],[Int])])+type Prof = (RFun, [([[Int]],[Int])]) cf2cfp :: CF -> CFP cf2cfp cfg@CFG{..} = cfg { cfgRules = map cf2cfpRule cfgRules } cf2cfpRule :: Rule -> RuleP-cf2cfpRule (Rule f c its) = Rule (f, (f, trivialProf its)) c its+cf2cfpRule (Rule f c its internal) = Rule (f, (f, trivialProf its)) c its internal cfp2cf :: CFP -> CF cfp2cf = fmap fst -trivialProf :: [Either Cat String] -> [([[Int]],[Int])]+trivialProf :: SentForm -> [([[Int]],[Int])] trivialProf its = [([],[i]) | (i,_) <- zip [0..] [c | Left c <- its]] {-# DEPRECATED allCatsP, allEntryPointsP "Use the version without P postfix instead" #-} -funRuleP :: RuleP -> Fun+funRuleP :: RuleP -> RFun funRuleP = fst . funRule ruleGroupsP :: CFP -> [(Cat,[RuleP])]@@ -688,14 +839,15 @@ rulesForCatP cf cat = [r | r <- cfgRules cf, isParsable r, valCat r == cat] allCatsP :: CFP -> [Cat]-allCatsP = allCats+allCatsP = reallyAllCats -- | Categories that are entry points to the parser allEntryPoints :: CFG f -> [Cat]-allEntryPoints cf = case concat [cats | EntryPoints cats <- cfgPragmas cf] of- [] -> allCats cf- cs -> cs+allEntryPoints cf =+ case concat [ cats | EntryPoints cats <- cfgPragmas cf ] of+ [] -> allParserCats cf+ cs -> map wpThing cs allEntryPointsP :: CFP -> [Cat] allEntryPointsP = allEntryPoints
src/BNFC/GetCF.hs view
@@ -17,19 +17,33 @@ Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1335, USA -} +{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} -module BNFC.GetCF where+-- | Check LBNF input file and turn it into the 'CF' internal representation. +module BNFC.GetCF+ ( parseCF, parseCFP+ , checkRule, transItem+ ) where+ import Control.Arrow (left)+import Control.Monad.Reader (Reader, runReader, MonadReader(..), asks) import Control.Monad.State (State, evalState, get, modify)+import Control.Monad.Except (MonadError(..)) import Data.Char import Data.Either (partitionEithers)-import Data.Functor ((<$>))+import Data.Functor (($>)) -- ((<&>)) -- only from ghc 8.4 import Data.List (nub, partition)+import qualified Data.List as List import Data.Maybe (mapMaybe) import qualified Data.Foldable as Fold+import qualified Data.Set as Set import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr)@@ -38,133 +52,192 @@ import qualified AbsBNF as Abs import ParBNF-import ErrM import BNFC.CF import BNFC.Options+import BNFC.Regex (nullable, simpReg) import BNFC.TypeChecker import BNFC.Utils +type Err = Either String -- $setup -- >>> import PrintBNF +-- | Entrypoint.+ parseCF :: SharedOptions -> Target -> String -> IO CF parseCF opts t s = cfp2cf <$> parseCFP opts t s +-- | Entrypoint (profiles).+ parseCFP :: SharedOptions -> Target -> String -> IO CFP parseCFP opts target content = do cfp <- runErr $ pGrammar (myLexer content)- >>= expandRules- >>= getCFP (cnf opts)- >>= markTokenCategories+ -- <&> expandRules -- <&> from ghc 8.4+ >>= return . expandRules+ >>= getCFP opts+ >>= return . markTokenCategories let cf = cfp2cf cfp- runErr $ checkDefinitions cf+ either dieUnlessForce return $ runTypeChecker $ checkDefinitions cf -- Some backends do not allow the grammar name to coincide with -- one of the category or constructor names. let names = allNames cf- () <- when (target == TargetJava && lang opts `elem` names) $- die $ unwords $- [ "ERROR of backend", show target ++ ":"- , "the language name"- , lang opts- , "conflicts with a name defined in the grammar."+ when (target == TargetJava) $+ case List.find ((lang opts ==) . wpThing) names of+ Nothing -> return ()+ Just px ->+ dieUnlessForce $ unlines+ [ unwords $+ [ "ERROR of backend", show target ++ ":"+ , "the language name"+ , lang opts+ , "conflicts with a name defined in the grammar:"+ ]+ , blendInPosition px+ ]++ -- Some (most) backends do not support layout.+ when (hasLayout cf && target `notElem`+ [ TargetHaskell, TargetHaskellGadt, TargetLatex, TargetPygments, TargetCheck ]) $+ dieUnlessForce $ unwords+ [ "ERROR: the grammar uses layout, which is not supported by backend"+ , show target ++ "." ] - -- Warn of fail if the grammar uses non unique names+ -- Warn or fail if the grammar uses non unique names. case filter (not . isDefinedRule) $ filterNonUnique names of [] -> return ()- ns | target `notElem` [TargetHaskell,TargetHaskellGadt,TargetOCaml]- -> die $ unlines $- [ "ERROR: names not unique: " ++ unwords ns- , "This is an error in the backend " ++ show target+ ns | target `elem` [ TargetCpp , TargetCppNoStl , TargetJava ]+ -> dieUnlessForce $ unlines $ concat+ [ [ "ERROR: names not unique:" ]+ , printNames ns+ , [ "This is an error in the backend " ++ show target ++ "." ] ] | otherwise- -> putStrLn $ unlines $- [ "Warning: names not unique: " ++ unwords ns- , "This can be an error in other back ends."+ -> putStrLn $ unlines $ concat+ [ [ "Warning: names not unique:" ]+ , printNames ns+ , [ "This can be an error in some backends." ] ] + -- Warn or fail if the grammar uses names not unique modulo upper/lowercase.+ case filter (not . isDefinedRule) $ duplicatesOn (map toLower . wpThing) names of+ [] -> return ()+ ns | target `elem` [ TargetJava ]+ -> dieUnlessForce $ unlines $ concat+ [ [ "ERROR: names not unique ignoring case:" ]+ , printNames ns+ , [ "This is an error in the backend " ++ show target ++ "."]+ ]+ | otherwise+ -> putStr $ unlines $ concat+ [ [ "Warning: names not unique ignoring case:" ]+ , printNames ns+ , [ "This can be an error in some backends." ]+ ]++ -- Note: the following @() <-@ works around an @Ambiguous type variable@+ () <- when (hasPositionTokens cf && target == TargetCppNoStl) $+ putStrLn $ unwords+ [ "Warning: the backend"+ , show target+ , "ignores the qualifier `position` in token definitions."+ ]++ -- Fail if the grammar uses defined constructors which are not actually defined.+ let definedConstructor = \case+ FunDef x _ _ -> Just x+ _ -> Nothing+ let definedConstructors = Set.fromList $ mapMaybe definedConstructor $ cfgPragmas cf+ let undefinedConstructor x = isDefinedRule x && x `Set.notMember` definedConstructors+ case filter undefinedConstructor $ map funRule $ cfgRules cf of+ [] -> return ()+ xs -> dieUnlessForce $ unlines $ concat+ [ [ "Lower case rule labels need a definition."+ , "ERROR: undefined rule label(s):"+ ]+ , printNames xs+ ]+ -- Print warnings if user defined nullable tokens. Fold.mapM_ putStrLn $ checkTokens cf - -- Print the number of rules+ -- Check for empty grammar. let nRules = length (cfgRules cf) -- Note: the match against () is necessary for type class instance resolution.- () <- when (nRules == 0) $ die $ "ERROR: the grammar contains no rules."- putStrLn $ show nRules +++ "rules accepted\n"+ when (nRules == 0) $ dieUnlessForce $ "ERROR: the grammar contains no rules." - -- Print a warning if comment delimiter are bigger than 2 characters- let c3s = [(b,e) | (b,e) <- fst (comments cf), length b > 2 || length e > 2]- unless (null c3s) $ do- putStrLn "Warning: comment delimiters longer than 2 characters ignored in Haskell:"- mapM_ putStrLn [b +++ "-" +++ e | (b,e) <- c3s]+ -- Check whether one of the parsers could consume at least one token. [#213]+ when (null (usedTokenCats cf) && null (cfTokens cf)) $+ dieUnlessForce $+ "ERROR: the languages defined by this grammar are empty since it mentions no terminals."++ -- Passed the tests: Print the number of rules.+ putStrLn $ show nRules +++ "rules accepted\n" return cfp where- runErr (Ok a) = return a- runErr (Bad msg) = die msg+ runErr = either die return + dieUnlessForce :: String -> IO ()+ dieUnlessForce msg = do+ hPutStrLn stderr msg+ if force opts then do+ hPutStrLn stderr+ "Ignoring error... (thanks to --force)"+ else do+ hPutStrLn stderr+ "Aborting. (Use option --force to continue despite errors.)"+ exitFailure++ printNames :: [RString] -> [String]+ printNames = map ((" " ++) . blendInPosition) . List.sortOn lexicoGraphic+ where+ lexicoGraphic (WithPosition pos x) = (pos,x)+ die :: String -> IO a-die msg = hPutStrLn stderr msg >> exitFailure+die msg = do+ hPutStrLn stderr msg+ exitFailure -{-- 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)--}+-- | Translate the parsed grammar file into a context-free grammar 'CFP'.+-- Desugars and type-checks. -getCFP :: Bool -> Abs.Grammar -> Err CFP-getCFP cnf (Abs.Grammar defs0) = do- let rules = inlineDelims rules0- cf0 = revs srt- srt = let literals = nub [lit | xs <- map rhsRule rules,- Left (Cat lit) <- xs,- lit `elem` 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, isParsable r, Right t <- rhsRule r]- -- Issue #204: exclude keywords from internal rules- in CFG pragma literals symbols keywords [] rules- case mapMaybe (checkRule (cfp2cf cf0)) (cfgRules cf0) of+getCFP :: SharedOptions -> Abs.Grammar -> Err CFP+getCFP opts (Abs.Grammar defs0) = do+ let (defs,inlineDelims)= if cnf opts then (defs0,id) else removeDelims defs0+ (pragma,rules0) = partitionEithers $ concat $ mapM transDef defs `runTrans` opts+ rules = inlineDelims rules0+ reservedWords = nub [t | r <- rules, isParsable r, Right t <- rhsRule r, not $ all isSpace t]+ -- Issue #204: exclude keywords from internal rules+ -- Issue #70: whitespace separators should be treated like "", at least in the parser+ literals = nub+ [ lit | xs <- map rhsRule rules+ , Left (Cat lit) <- xs+ , lit `elem` specialCatsP+ ]+ (symbols,keywords) = partition notIdent reservedWords+ sig <- runTypeChecker $ buildSignature $ map (fmap fst) rules+ let cf = revs $ CFG pragma literals symbols keywords [] rules sig+ case mapMaybe (checkRule (cfp2cf cf)) rules of [] -> return ()- msgs -> fail (unlines msgs)- return cf0+ msgs -> throwError $ unlines msgs+ return cf where- (pragma,rules0) = partitionEithers $ concatMap transDef defs- (defs,inlineDelims) = if cnf then (defs0,id) else removeDelims defs0- revs cf1@CFG{..} =- cf1 { cfgReversibleCats = findAllReversibleCats (cfp2cf cf1) }+ notIdent s = null s || not (isAlpha (head s)) || any (not . isIdentRest) s+ isIdentRest c = isAlphaNum c || c == '_'+ revs cfp@CFG{..} =+ cfp { cfgReversibleCats = findAllReversibleCats (cfp2cf cfp) } -- | This function goes through each rule of a grammar and replace Cat "X" with -- TokenCat "X" when "X" is a token type.-markTokenCategories :: CFP -> Err CFP-markTokenCategories cf@CFG{..} = return $ cf { cfgRules = newRules }+markTokenCategories :: CFP -> CFP+markTokenCategories cf@CFG{..} = cf { cfgRules = newRules } where- newRules = [ Rule f (mark c) (map (left mark) rhs) | Rule f c rhs <- cfgRules ]- tokenCatNames = [ n | TokenReg n _ _ <- cfgPragmas ] ++ specialCatsP+ newRules = [ Rule f (fmap mark c) (map (left mark) rhs) internal | Rule f c rhs internal <- cfgRules ]+ tokenCatNames = [ wpThing n | TokenReg n _ _ <- cfgPragmas ] ++ specialCatsP mark = toTokenCat tokenCatNames @@ -193,13 +266,13 @@ inlineDelim :: Abs.Def -> Either Cat String -> [Either Cat String] inlineDelim (Abs.Delimiters cat open close _ _) (Left c)- | c == ListCat (transCat cat) = [Right open, Left c, Right close]+ | 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)+ inlineDelim' d@(Abs.Delimiters cat _ _ _ _) r@(Rule f c rhs internal)+ | wpThing c == ListCat (transCat' cat) = r+ | otherwise = Rule f c (concatMap (inlineDelim d) rhs) internal inlineDelim' _ _ = error "Not a delimiters pragma" @@ -208,110 +281,161 @@ delimToSep (Abs.Delimiters cat _ _ 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) (concatMap 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:concatMap 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)]+-- | Translation monad.+newtype Trans a = Trans { unTrans :: Reader SharedOptions a }+ deriving (Functor, Applicative, Monad, MonadReader SharedOptions) -delimiterRules :: Abs.Cat -> String -> String -> Abs.Separation -> Abs.MinimumSize -> [Rule]+runTrans :: Trans a -> SharedOptions -> a+runTrans m opts = unTrans m `runReader` opts++transDef :: Abs.Def -> Trans [Either Pragma RuleP]+transDef = \case+ Abs.Rule label cat items -> do+ f <- transLabel label+ c <- transCat cat+ return $ [ Right $ Rule f c (concatMap transItem items) Parsable ]+ Abs.Internal label cat items -> do+ f <- transLabel label+ c <- transCat cat+ return $ [ Right $ Rule f c (concatMap transItem items) Internal ]++ Abs.Comment str -> return [ Left $ CommentS str ]+ Abs.Comments str1 str2 -> return [ Left $ CommentM (str1, str2) ]++ Abs.Token ident reg -> do x <- transIdent ident; return [Left $ TokenReg x False $ simpReg reg]+ Abs.PosToken ident reg -> do x <- transIdent ident; return [Left $ TokenReg x True $ simpReg reg]+ Abs.Entryp idents -> do xs <- mapM transIdent idents; return [Left $ EntryPoints $ map (fmap strToCat) xs]+ 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 -> return [ Left $ Layout ss ]+ Abs.LayoutStop ss -> return [ Left $ LayoutStop ss]+ Abs.LayoutTop -> return [ Left $ LayoutTop ]+ Abs.Function ident xs e -> do+ f <- transIdent ident+ let xs' = map transArg xs+ return [ Left $ FunDef f xs' $ transExp xs' e ]++delimiterRules :: Abs.Cat -> String -> String -> Abs.Separation -> Abs.MinimumSize -> Trans [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 = [+delimiterRules a0 l r sep size = do+ WithPosition pos a <- transCat a0+ let as = ListCat a+ a' = '@':'@':show a+ c = '@':'{':show a+ d = '@':'}':show a+ let wp = WithPosition pos+ rule f c = Rule (wp f) (wp c)+ return $ concat -- recognizing a single element- Rule "(:[])" (strToCat a') (Left a : termin), -- optional terminator/separator+ [ [ rule "(:[])" (strToCat a') (Left a : termin) Parsable -- optional terminator/separator - -- glueing two sublists- Rule "(++)" (strToCat a') [Left (strToCat a'), Left (strToCat a')],+ -- glueing two sublists+ , rule "(++)" (strToCat a') [Left (strToCat a'), Left (strToCat a')] Parsable - -- starting on either side with a delimiter- Rule "[]" (strToCat c) [Right l],- Rule (if optFinal then "(:[])" else- "[]")- (strToCat d) ([Left a | optFinal] ++ [Right r]),+ -- starting on either side with a delimiter+ , rule "[]" (strToCat c) [Right l] Parsable+ , rule (if optFinal then "(:[])" else "[]")+ (strToCat d) ([Left a | optFinal] ++ [Right r]) Parsable - -- gathering chains- Rule "(++)" (strToCat c) [Left (strToCat c), Left (strToCat a')],- Rule "(++)" (strToCat d) [Left (strToCat a'), Left (strToCat d)],+ -- gathering chains+ , rule "(++)" (strToCat c) [Left (strToCat c), Left (strToCat a')] Parsable+ , rule "(++)" (strToCat d) [Left (strToCat a'), Left (strToCat d)] Parsable - -- 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.- termin = case sep of- Abs.SepSepar t -> [Right t]- Abs.SepTerm t -> [Right t]- _ -> []- optFinal = case (sep,size) of- (Abs.SepSepar _,_) -> True- (Abs.SepTerm _,Abs.MNonempty) -> True- (Abs.SepNone,Abs.MNonempty) -> True- _ -> False- optEmpty = case sep of- Abs.SepSepar _ -> size == Abs.MEmpty- _ -> False+ -- finally, put together left and right chains+ , rule "(++)" as [Left (strToCat c), Left (strToCat d)] Parsable+ ]+ -- special rule for the empty list if necessary+ , [ rule "[]" as [Right l, Right r] Parsable | optEmpty ]+ ]+ where+ -- optionally separated concat. of x and y categories.+ termin = case sep of+ Abs.SepSepar t -> [Right t]+ Abs.SepTerm t -> [Right t]+ _ -> []+ optFinal = case (sep, size) of+ (Abs.SepSepar _, _ ) -> True+ (Abs.SepTerm _ , Abs.MNonempty ) -> True+ (Abs.SepNone , Abs.MNonempty) -> True+ _ -> False+ optEmpty = case sep of+ Abs.SepSepar _ -> size == Abs.MEmpty+ _ -> False +-- | Translate @separator [nonempty] C "s"@.+-- The position attached to the generated rules is taken from @C@.+--+-- (Ideally, we would take them from the @terminator@ keyword.+-- But BNFC does not deliver position information there.)+--+-- If the user-provided separator consists of white space only,+-- we turn it into a terminator rule to prevent reduce/reduce conflicts. -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+separatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> Trans [Rule]+separatorRules size c0 s+ | all isSpace s = terminatorRules size c0 s+ | otherwise = do+ WithPosition pos c <- transCat c0+ let wp = WithPosition pos+ let cs = ListCat c+ let rule x rhs = Rule (wp x) (wp cs) rhs Parsable+ return $ concat+ [ [ rule "[]" [] | size == Abs.MEmpty ]+ , [ rule "(:[])" [Left c] ]+ , [ rule "(:)" [Left c, Right s, Left cs] ]+ ] -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 []+-- | Translate @terminator [nonempty] C "s"@.+-- The position attached to the generated rules is taken from @C@.+--+-- (Ideally, we would take them from the @terminator@ keyword.+-- But BNFC does not deliver position information there.) -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 ")"]]+terminatorRules :: Abs.MinimumSize -> Abs.Cat -> String -> Trans [Rule]+terminatorRules size c0 s = do+ WithPosition pos c <- transCat c0+ let wp = WithPosition pos+ let cs = ListCat c+ let rule x rhs = Rule (wp x) (wp cs) rhs Parsable+ return+ [ case size of+ Abs.MNonempty ->+ rule "(:[])" (Left c : term [])+ Abs.MEmpty ->+ rule "[]" []+ , rule "(:)" (Left c : term [Left cs])+ ]+ where+ term = if null s then id else (Right s :) -ebnfRules :: Abs.Ident -> [Abs.RHS] -> [Rule]-ebnfRules (Abs.Ident c) rhss =- [Rule (mkFun k its) (strToCat c) (concatMap transItem its)- | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss]+coercionRules :: Abs.Identifier -> Integer -> Trans [Rule]+coercionRules c0 n = do+ WithPosition pos c <- transIdent c0+ let wp = WithPosition pos+ let urule x rhs = Rule (wp "_") (wp x) rhs Parsable+ return $ concat+ [ [ urule (Cat c) [Left (CoercCat c 1)] ]+ , [ urule (CoercCat c (i-1)) [Left (CoercCat c i)] | i <- [2..n] ]+ , [ urule (CoercCat c n) [Right "(", Left (Cat c), Right ")"] ]+ ]++ebnfRules :: Abs.Identifier -> [Abs.RHS] -> Trans [Rule]+ebnfRules (Abs.Identifier ((line, col), c)) rhss = do+ file <- asks lbnfFile+ let wp = WithPosition $ Position file line col+ let rule x rhs = Rule (wp x) (wp $ strToCat c) rhs Parsable+ return+ [ rule (mkFun k its) (concatMap transItem its)+ | (k, Abs.RHS its) <- zip [1 :: Int ..] rhss+ ] where- mkFun k i = case i of+ mkFun k = \case [Abs.Terminal s] -> c' ++ "_" ++ mkName k s- [Abs.NTerminal n] -> c' ++ identCat (transCat n)+ [Abs.NTerminal n] -> c' ++ identCat (transCat' n) _ -> c' ++ "_" ++ show k c' = c --- normCat c mkName k s = if all (\c -> isAlphaNum c || elem c ("_'" :: String)) s@@ -325,50 +449,64 @@ -- is equivalent to -- Foo. S ::= "foo" "bar" transItem :: Abs.Item -> [Either Cat String]-transItem (Abs.Terminal str) = [Right w | w <- words str]-transItem (Abs.NTerminal cat) = [Left (transCat cat)]+transItem (Abs.Terminal str) = [ Right w | w <- words str ]+transItem (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+transCat' :: Abs.Cat -> Cat+transCat' = \case+ Abs.ListCat cat -> ListCat $ transCat' cat+ Abs.IdCat (Abs.Identifier (_pos, 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) =+transCat :: Abs.Cat -> Trans (WithPosition Cat)+transCat = \case+ Abs.ListCat cat -> fmap ListCat <$> transCat cat+ Abs.IdCat (Abs.Identifier ((line, col), c)) -> do+ file <- asks lbnfFile+ return $ WithPosition (Position file line col) $ strToCat c++transLabel :: Abs.Label -> Trans (RFun, Prof)+transLabel = \case+ Abs.LabNoP f -> do g <- transLabelId f; return (g,(g,[])) ---- should be Nothing+ Abs.LabP f p -> do g <- transLabelId f; return (g,(g, map transProf p))+ Abs.LabPF f g p -> (,) <$> transLabelId f <*> do (,map transProf p) <$> transLabelId g+ Abs.LabF f g -> (,) <$> transLabelId f <*> do (,[]) <$> transLabelId g+ where+ transLabelId = \case+ Abs.Id id -> transIdent id+ Abs.Wild -> return $ noPosition $ "_"+ Abs.ListE -> return $ noPosition $ "[]"+ Abs.ListCons -> return $ noPosition $ "(:)"+ Abs.ListOne -> return $ noPosition $ "(:[])"+ 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+transIdent :: Abs.Identifier -> Trans RString+transIdent (Abs.Identifier ((line, col), str)) = do+ file <- asks lbnfFile+ return $ WithPosition (Position file line col) str transArg :: Abs.Arg -> String-transArg (Abs.Arg x) = transIdent x+transArg (Abs.Arg (Abs.Identifier (_pos, x))) = 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)+transExp+ :: [String] -- ^ Arguments of definition (in scope in expression).+ -> Abs.Exp -- ^ Expression.+ -> Exp -- ^ Translated expression.+transExp xs = loop+ where+ loop = \case+ Abs.App x es -> App (transIdent' x) (map loop es)+ Abs.Var x -> let x' = transIdent' x in+ if x' `elem` xs then Var x' else App x' []+ Abs.Cons e1 e2 -> cons e1 (loop 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 "[]" []+ cons e1 e2 = App "(:)" [loop e1, e2]+ nil = App "[]" []+ transIdent' (Abs.Identifier (_pos, x)) = x -------------------------------------------------------------------------------- @@ -385,47 +523,28 @@ 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 _ (Rule _ (Cat ('@':_)) _) = 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\n " ++ s+checkRule cf (Rule (f,_) (WithPosition _ cat) rhs _)+ | Cat ('@':_) <- cat = Nothing -- Generated by a pragma; it's a trusted category+ | badCoercion = failure $ "Bad coercion in rule" +++ s+ | badNil = failure $ "Bad empty list rule" +++ s+ | badOne = failure $ "Bad one-element list rule" +++ s+ | badCons = failure $ "Bad list construction rule" +++ s+ | badList = failure $ "Bad list formation rule" +++ s+ | badSpecial = failure $ "Bad special category rule" +++ s+ | badTypeName = failure $ "Bad type name" +++ unwords (map show badtypes) +++ "in" +++ s+ | badFunName = failure $ "Bad constructor name" +++ fun +++ "in" +++ s+ | badMissing = failure $ "no production for" +++ unwords missing ++ ", appearing in rule\n " ++ s | otherwise = Nothing where- s = f ++ "." +++ show cat +++ "::=" +++ unwords (map (either show show) rhs) -- Todo: consider using the show instance of Rule+ failure = Just . blendInPosition . (f $>)+ fun = wpThing f+ s = fun ++ "." +++ 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 && [c] /= cs@@ -437,33 +556,30 @@ badSpecial = elem c [ Cat x | x <- specialCatsP] && not (isCoercion f) badMissing = not (null missing)- missing = filter nodef [show c | Left c <- rhs]- nodef t = t `notElem` defineds- defineds =- show InternalCat : tokenNames cf ++ specialCatsP ++ map (show . valCat) (cfgRules cf)+ missing = filter (`notElem` defineds) [show c | Left c <- rhs]+ defineds = tokenNames cf ++ specialCatsP ++ map (show . valCat) (cfgRules 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 isBadType (TokenCat 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)-}+ isBadCatName s = not $ isUpper (head s) || (head s == '@')+ badFunName = not (all (\c -> isAlphaNum c || c == '_') (wpThing f) {-isUpper (head f)-} || isCoercion f || isNilCons f) -- | Pre-processor that converts the `rules` macros to regular rules -- by creating unique function names for them. -- >>> :{--- let rules1 = Abs.Rules (Abs.Ident "Foo")+-- let rules1 = Abs.Rules (Abs.Identifier ((0, 0), "Foo")) -- [ Abs.RHS [Abs.Terminal "abc"]--- , Abs.RHS [Abs.NTerminal (Abs.IdCat (Abs.Ident "A"))]+-- , Abs.RHS [Abs.NTerminal (Abs.IdCat (Abs.Identifier ((0, 0), "A")))] -- , Abs.RHS [Abs.Terminal "foo", Abs.Terminal "bar"] -- , Abs.RHS [Abs.Terminal "++"] -- ] -- in--- let Ok tree = expandRules (Abs.Grammar [rules1])+-- let tree = expandRules (Abs.Grammar [rules1]) -- in putStrLn (printTree tree) -- :} -- Foo_abc . Foo ::= "abc";@@ -474,35 +590,47 @@ -- Note that if there are two `rules` macro with the same category, the -- generated names should be uniques: -- >>> :{--- let rules1 = Abs.Rules (Abs.Ident "Foo")+-- let rules1 = Abs.Rules (Abs.Identifier ((0, 0), "Foo")) -- [ Abs.RHS [Abs.Terminal "foo", Abs.Terminal "bar"] ] -- in--- let rules2 = Abs.Rules (Abs.Ident "Foo")+-- let rules2 = Abs.Rules (Abs.Identifier ((0, 0), "Foo")) -- [ Abs.RHS [Abs.Terminal "foo", Abs.Terminal "foo"] ] -- in--- let Ok tree = expandRules (Abs.Grammar [rules1, rules2])+-- let tree = expandRules (Abs.Grammar [rules1, rules2]) -- in putStrLn (printTree tree) -- :} -- Foo1 . Foo ::= "foo" "bar"; -- Foo2 . Foo ::= "foo" "foo" -- -- This is using a State monad to remember the last used index for a category.-expandRules :: Abs.Grammar -> Err Abs.Grammar+expandRules :: Abs.Grammar -> Abs.Grammar expandRules (Abs.Grammar defs) =- return $ Abs.Grammar (concat (evalState (mapM expand defs) []))+ Abs.Grammar . concat $ mapM expand defs `evalState` [] where- expand (Abs.Rules ident rhss) = mapM (mkRule ident) rhss- expand other = return [other]- mkRule :: Abs.Ident -> Abs.RHS -> State [(String, Int)] Abs.Def+ expand :: Abs.Def -> State [(String, Int)] [Abs.Def]+ expand = \case+ Abs.Rules ident rhss -> mapM (mkRule ident) rhss+ other -> return [ other ]++ mkRule :: Abs.Identifier -> Abs.RHS -> State [(String, Int)] Abs.Def mkRule ident (Abs.RHS rhs) = do- fun <- Abs.LabNoP . Abs.Id . Abs.Ident <$> mkName ident rhs- return (Abs.Rule fun (Abs.IdCat ident) rhs)- mkName :: Abs.Ident -> [Abs.Item] -> State [(String, Int)] String- mkName (Abs.Ident cat) [Abs.Terminal s]- | all (\c -> isAlphaNum c || elem c ("_'" :: String)) s = return (cat ++ "_" ++ s)- mkName (Abs.Ident cat) [Abs.NTerminal (Abs.IdCat (Abs.Ident s))] =- return (cat ++ s)- mkName (Abs.Ident cat) _ = do+ fun <- Abs.LabNoP . Abs.Id <$> mkName ident rhs+ return $ Abs.Rule fun (Abs.IdCat ident) rhs++ mkName :: Abs.Identifier -> [Abs.Item] -> State [(String, Int)] Abs.Identifier+ mkName (Abs.Identifier (pos, cat)) = \case++ -- A string that is a valid identifier.+ [ Abs.Terminal s ] | all (\ c -> isAlphaNum c || c == '_') s ->+ return $ Abs.Identifier (pos, cat ++ "_" ++ s)++ -- Same but without double quotes.+ [ Abs.NTerminal (Abs.IdCat (Abs.Identifier (pos', s))) ] ->+ return $ Abs.Identifier (pos', cat ++ s)++ -- Something else that does not immediately give a valid rule name.+ -- Just number!+ _ -> do i <- maybe 1 (+1) . lookup cat <$> get modify ((cat, i):)- return (cat ++ show i)+ return $ Abs.Identifier (pos, cat ++ show i)
src/BNFC/Lexing.hs view
@@ -1,44 +1,44 @@-{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PatternGuards #-} module BNFC.Lexing- ( mkLexer, LexType(..) ) where+ ( mkLexer, LexType(..), mkRegMultilineComment ) where -import Prelude'+import Prelude hiding ((<>)) -import Control.Arrow ((&&&))-import Data.List (inits)-import AbsBNF (Reg(..))+-- import Control.Arrow ( (&&&) )+import Data.List ( inits, tails )++import AbsBNF ( Reg(..) )+import PrintBNF ( printTree ) -- for debug printing import BNFC.CF+import BNFC.Regex ( simpReg )+import BNFC.Utils ( unless ) --- $setup--- >>> import PrintBNF--- >>> let p = putStrLn . concat . words . printTree :: Reg -> IO ()+debugPrint :: Reg -> IO ()+debugPrint = putStrLn . concat . words . printTree -- Abstract lexer data LexType = LexComment | LexToken String | LexSymbols mkLexer :: CF -> [(Reg, LexType)]-mkLexer cf =+mkLexer cf = concat -- comments- [ (mkRegSingleLineComment s, LexComment) | s <- snd (comments cf) ]- ++- [ (mkRegMultilineComment b e, LexComment) | (b,e) <- fst (comments cf) ]- +++ [ [ (mkRegSingleLineComment s, LexComment) | s <- snd (comments cf) ]+ , [ (mkRegMultilineComment b e, LexComment) | (b,e) <- fst (comments cf) ] -- user tokens- [ (reg, LexToken name) | (name, reg) <- tokenPragmas cf]- +++ , [ (reg, LexToken name) | (name, reg) <- tokenPragmas cf] -- predefined tokens- [ ( regIdent, LexToken "Ident" ) ]- +++ , [ ( regIdent, LexToken "Ident" ) ] -- Symbols- [ (foldl1 RAlt (map RSeqs (cfgSymbols cf)), LexSymbols ) ]- +++ , unless (null $ cfgSymbols cf) [ (foldl1 RAlt (map RSeqs (cfgSymbols cf)), LexSymbols ) ] -- Built-ins- [ ( regInteger, LexToken "Integer")- , ( regDouble, LexToken "Double" )- , ( regString, LexToken "String" )- , ( regChar, LexToken "Char" ) ]+ , [ ( regInteger, LexToken "Integer")+ , ( regDouble , LexToken "Double" )+ , ( regString , LexToken "String" )+ , ( regChar , LexToken "Char" )+ ]+ ] (<>) = RSeq@@ -48,28 +48,28 @@ -- the tests make sure that they correspond to what is in the LBNF reference -- | Ident regex--- >>> p regIdent+-- >>> debugPrint regIdent -- letter(letter|digit|'_'|'\'')* regIdent :: Reg regIdent = RLetter <> RStar (RLetter <|> RDigit <|> RChar '_' <|> RChar '\'') -- | Integer regex--- >>> p regInteger+-- >>> debugPrint regInteger -- digit+ regInteger :: Reg regInteger = RPlus RDigit -- | String regex--- >>> p regString+-- >>> debugPrint regString -- '"'(char-["\"\\"]|'\\'["\"\\nt"])*'"' regString :: Reg regString = RChar '"'- <> RStar ( RMinus RAny (RAlts "\"\\")+ <> RStar ((RAny `RMinus` RAlts "\"\\") <|> (RChar '\\' <> RAlts "\"\\nt")) <> RChar '"' -- | Char regex--- >>> p regChar+-- >>> debugPrint regChar -- '\''(char-["'\\"]|'\\'["'\\nt"])'\'' regChar :: Reg regChar = RChar '\''@@ -77,35 +77,184 @@ <> RChar '\'' -- | Double regex--- >>> p regDouble+-- >>> debugPrint regDouble -- digit+'.'digit+('e''-'?digit+)? regDouble :: Reg regDouble = RPlus RDigit <> RChar '.' <> RPlus RDigit <> ROpt (RChar 'e' <> ROpt (RChar '-') <> RPlus RDigit) -- | Create regex for single line comments--- >>> p $ mkRegSingleLineComment "--"--- {"--"}(char*'\n')+-- >>> debugPrint $ mkRegSingleLineComment "--"+-- {"--"}char*'\n' mkRegSingleLineComment :: String -> Reg-mkRegSingleLineComment s = RSeq (RSeqs s) (RSeq (RStar RAny) (RChar '\n'))+mkRegSingleLineComment s = RSeqs s <> RStar RAny <> RChar '\n' --- | Create regex for multiline comments--- >>> p $ mkRegMultilineComment "<" ">"--- '<'((char|'\n')-'>')*'>'--- >>> p $ mkRegMultilineComment "<!--" "-->"--- {"<!--"}((char|'\n')-'-'|'-'((char|'\n')-'-')|{"--"}((char|'\n')-'>'))*'-'*{"-->"}++-- -- | Create regex for multiline comments.+-- --+-- -- >>> debugPrint $ mkRegMultilineComment "<" ">"+-- -- '<'(char-'>')*'>'+-- --+-- -- >>> debugPrint $ mkRegMultilineComment "<!--" "-->"+-- -- {"<!--"}(char-'-')*'-'((char-'-')+'-')*'-'('-'|(char-["->"])(char-'-')*'-'((char-'-')+'-')*'-')*'>'+-- --+-- mkRegMultilineComment :: String -> String -> Reg+-- mkRegMultilineComment b [] = RSeqs b+-- mkRegMultilineComment b (a:rest) = simpReg $ RSeqs b `RSeq` fromStart+-- where+-- notA = RAny `RMinus` RChar a+-- goA = RStar notA `RSeq` RChar a+-- (fromStart, _, _) = foldl f (goA, REps, []) rest+-- -- Build up automaton states Start, A, ...ys..., x, ...+-- f (fromStart, fromA, ys) x = (advance fromStart, advance fromA, x:ys)+-- where+-- advance from = (from `RSeq` RStar idle) `RSeq` RChar x+-- idle = foldl1 RAlt $ concat+-- -- cannot advance, ...+-- [ [ RChar a | a /= x, all (a ==) ys ] -- but can stay+-- , [ RChar a `RSeq` fromA | a /= x, null ys || any (a /=) ys ] -- but can fall back to A+-- , [ (RAny `RMinus` RAlts [x,a]) `RSeq` fromStart ] -- neither, need to restart+-- ]+++-- | Create regex for multiline comments.+--+-- >>> debugPrint $ mkRegMultilineComment "<" ">"+-- '<'(char-'>')*'>'+--+-- >>> debugPrint $ mkRegMultilineComment "/*" "*/"+-- {"/*"}(char-'*')*'*'((char-["*/"])(char-'*')*'*'|'*')*'/'+--+-- >>> debugPrint $ mkRegMultilineComment "<!--" "-->"+-- {"<!--"}(char-'-')*'-'((char-'-')+'-')*'-'((char-["->"])(char-'-')*'-'((char-'-')+'-')*'-'|'-')*'>'+-- mkRegMultilineComment :: String -> String -> Reg-mkRegMultilineComment b e =- rseq $ concat [- lit b- , [RStar (foldl1 RAlt subregex)]- , [ RStar (RChar (head e)) | length e > 1 ]- , lit e]+mkRegMultilineComment begin end = simpReg $ joinSteps (RSeqs begin) allSteps where- rseq = foldl1 RSeq- lit :: String -> [Reg]- lit "" = []- lit [c] = [RChar c]- lit s = [RSeqs s]- prefixes = map (init &&& last) (drop 1 (inits e))- subregex = [rseq (lit ss ++ [RMinus (RAlt RAny (RChar '\n')) (RChar s)]) | (ss,s) <- prefixes]++ -- This handles cases beyond comment terminators such as "*/" and "-->".+ -- In the general but unlikely case, a comment terminator may have+ -- non-trivial internal repetitions, like in "ananas". While lexing+ -- "anananas", we need, after having seen "anana", fall back to state+ -- "ana", to correctly handle the rest "nas" of the input and recognize the+ -- comment terminator.++ -- See the Knuth-Morris-Pratt algorithm of complexity O(n+m) to recognize a+ -- keyword of length m in a text of length n.+ -- (Dragon book second edition section 3.4.5;+ -- Knuth/Morris/Pratt (J. Computing 1977),+ -- "Fast pattern matching on strings").++ -- The basic idea is to construct the regular expression to recognize+ -- a text not containing @end@ but ending in @end@ from this DFA:+ --+ -- * DFA-states: the prefixes of @end@, formally @inits end@,+ -- written a(1..i) for @i <= length end@.+ --+ -- * Primary transitions ("spine") take us from state a(1..i) (called @ys@)+ -- to a(1..i+1) (called @x:ys@), consuming character a(i+1) (called @x@).+ --+ -- * Fallback transitions take us from state a(1..i) (@ys@) to some previous+ -- state a(1..j) with j <= i, consuming character @z@=a(j) (unless j=0).+ -- The main condition for fallbacks is a(i-j+2..i)=a(1..j-1) ("suffix = prefix"),+ -- because then we can append a(j) to our truncated history a(i-j+2..i)+ -- and end up in a(1..j).+ -- The secondary condition is that we are obliged to not fall back further+ -- than we must: If consuming @z@ can get us to a(1..k) with k > j,+ -- we cannot fall back to a(1..j).+ --+ -- The final @Reg@ transitions along the spine also involve "idling" on a state,+ -- meaning transition sequences bringing us back to the same state.+ -- The list @steps@ will contain the "spine" transitions (a(1..i)->a(1..i+1))+ -- _including_ the idling. The first entry in the list is the last transition+ -- computed so far. @allSteps@ is then the complete @steps@ list, which can be+ -- joined by @RSeq@ (function @joinSteps@).+ --+ -- Remark:+ -- Note that the generated regex can be too big for lexers to handle.+ -- For the example @end == "ananas"@, ocamllex uses up ~30.000 of its+ -- 32.767 maximal automaton transitions, which prevents comments+ -- ending in "ananas" to be part of a ocamllex lexer definition in practice.+ -- The Haskell lexer generator Alex is slow as well on this example,+ -- although the produced lexer is unproblematic in the end.+ --+ -- Lexer generators _should_ be able to handle the regex we are producing here+ -- because the DFA has only O(n) states and O(n²) transitions where @n = length end@+ -- is the length of the comment terminator @end@.+ --+ -- It is just an awkward way to generate this DFA via the detour over a regex+ -- which in turn is dictated by the interface of lexer generators.+ -- The size of the regex tree seems to be O(n³)!?+ -- It would be much smaller as DAG (tree with sharing).+ -- Lexer generators often support regex definitions; we could make each entry+ -- in @steps@ a defined regex. However, it is not clear whether this sharing+ -- is utilized in the regex → NFA construction in the lexer generators.+ joinSteps :: Reg -> [Reg] -> Reg+ joinSteps = foldr (flip RSeq)+ -- Transitions of the spine of the automaton, with last transition first in the list.+ allSteps :: [Reg]+ allSteps = fst $ foldl next ([],[]) end++ -- @next (steps, ys) x@ calculates the next step,+ -- taking us from state @ys@ to state @x:ys@.+ next :: ([Reg],[Char]) -> Char -> ([Reg],[Char])+ next+ ( steps -- [r(i-1,i), ..., r(0,1)], empty if i == 0+ , ys -- [a(i),...,a(1)] , empty if i == 0+ ) x -- a(i+1)+ = (step : steps, x:ys)+ where++ -- step = r(i,i+1) is the regular expression to go to next state.+ -- We can idle on state a(1..i) and then take the transition to a(1..i+1).+ step :: Reg+ step = RStar idle `RSeq` RChar x+ -- @idle@ presents all the possibilities to stay on the current state+ -- or fall back to a previous state and then again advance to the present state.+ -- We consider first the possibility to fall back to the start state a(1..0),+ -- and then the possibility to fall back to a(1..1), then, to a(1..2), etc.,+ -- until staying on a(1..i).+ -- We are obliged to stay as far advanced as possible, we can only fall+ -- father back if we cannot stay more upfront.+ -- Transitioning to state a(1..j) is possible if+ -- * the next character is not x (a(i+1)),+ -- * the next character is a(j),+ -- * the last j-1 characters we processed, a(i-j+2..j) are a(1..j-1),+ -- * we cannot transition to a(1..j+1), a(1..j+2), ..., a(1..i).+ idle :: Reg+ idle = foldl RAlt toStart $ map snd possibilities+ where+ -- List of possibilities to go back to a previous state upon+ -- the given character and how to return to the present state.+ -- We calculate the possibilities in order of:+ -- * staying on the current state+ -- * falling back one state+ -- * falling back two states+ -- * ...+ -- * falling back to the start.+ -- The reason is that falling back further than necessary is not allowed.+ possibilities :: [(Char,Reg)]+ possibilities = foldl addPoss [] (zip3 ys conds $ inits steps)+ -- Fall back to the beginning and come back to the present state.+ toStart :: Reg+ toStart = joinSteps (RAny `RMinus` RAlts (x : map fst possibilities)) steps+ -- Adding a possiblity on top of the existing ones.+ addPoss :: [(Char,Reg)] -> (Char,Bool,[Reg]) -> [(Char,Reg)]+ addPoss+ poss -- List of possibilities (a(k),r) of falling back to a(k) and recovering to a(i) via r.+ (z, cond, steps) -- Investigating possibility to fall back to a(1..j) where cond says this is in principle+ -- possible if we read @z@, not @x@, and none of the previous possibilities.+ -- @steps@ brings us back to the current state (after falling back).+ | cond, z `notElem` exclude = (z, joinSteps (RChar z) steps) : poss+ | otherwise = poss+ where+ -- To fall back with @z@, we need to exclude the possibility of+ -- advancing (via character @x@) and falling back less.+ exclude :: [Char]+ exclude = x : map fst poss+ -- Conditions of whether a fallback is in principle possible,+ -- starting with the state we have been in previously, ending in the first state.+ -- If we are in state a(1..i), the possibility of falling back to a(1..j)+ -- is constrained on a(1..j-1) = a(i-j+2..i).+ conds :: [Bool]+ conds = zipWith (==) (tail $ reverse $ inits ys) (tail $ tails ys)
src/BNFC/MultiView.hs view
@@ -25,14 +25,13 @@ import ParBNF import PrintBNF import AbsBNF-import ErrM 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+ Right g -> return g+ Left s -> error s let name = takeWhile (/='.') f let grs = extract name gr let entryp = entrypoint gr@@ -44,10 +43,10 @@ [(file lang,Grammar $ mapMaybe (getDef lang) ldefs) | lang <- views] where- views = [lang | LDefView langs <- ldefs, Ident lang <- langs]+ views = [lang | LDefView langs <- ldefs, Identifier (_, lang) <- langs] getDef lang ldef = case ldef of DefAll d -> Just d- DefSome ids d | elem (Ident lang) ids -> Just d+ DefSome ids d | lang `elem` map (\ (Identifier (_,x)) -> x) ids -> Just d _ -> Nothing file lang = name ++ "_" ++ lang ++ ".cf" @@ -55,8 +54,8 @@ entrypoint :: LGrammar -> String entrypoint (LGr rs0) = head $- [c | Entryp (Ident c:_) <- rs] ++- [c | Rule _ (IdCat (Ident c)) _ <- rs]+ [c | Entryp (Identifier (_,c) :_) <- rs] +++ [c | Rule _ (IdCat (Identifier (_,c))) _ <- rs] where rs = mapMaybe getR rs0 getR d = case d of@@ -99,7 +98,6 @@ ["import qualified Par" ++ cnc | cnc <- cncs] ++ ["import qualified Print" ++ cnc | cnc <- cncs] ++ ["import Abs" ++ abs,- "import ErrM", "import System.Environment (getArgs)", "", "main :: IO ()",@@ -107,8 +105,8 @@ " i:o:f:_ <- getArgs", " s <- readFile f", " case parse i s of",- " Ok t -> putStrLn $ prin o t",- " Bad s -> error s",+ " Right t -> putStrLn $ prin o t",+ " Left s -> error s", "", "parse i = case i of" ] ++
src/BNFC/Options.hs view
@@ -1,9 +1,25 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-} -module BNFC.Options where+module BNFC.Options+ ( Mode(..), Target(..), Backend+ , parseMode, usage, help+ , SharedOptions(..)+ , defaultOptions, isDefault, printOptions+ , AlexVersion(..), HappyMode(..), OCamlParser(..), JavaLexerParser(..)+ , RecordPositions(..), TokenText(..)+ , translateOldOptions+ )+ where +import qualified Control.Monad as Ctrl+import Control.Monad.Writer (WriterT, runWriterT, tell)+import Control.Monad.Except (MonadError(..))++import qualified Data.Map as Map+import qualified Data.List as List import Data.Maybe (fromMaybe, maybeToList)-import Data.Monoid (Monoid) -- ghc 7.8 import Data.Version (showVersion ) import System.Console.GetOpt@@ -35,12 +51,9 @@ data Target = TargetC | TargetCpp | TargetCppNoStl | TargetCSharp | TargetHaskell | TargetHaskellGadt | TargetLatex | TargetJava | TargetOCaml | TargetProfile | TargetPygments+ | TargetCheck deriving (Eq, Bounded, Enum, Ord) --- | List of all targets (using the enum and bounded classes).-targets :: [Target]-targets = [minBound..]- -- | List of Haskell target. haskellTargets :: [Target] haskellTargets = [ TargetHaskell, TargetHaskellGadt, TargetProfile ]@@ -57,6 +70,7 @@ show TargetOCaml = "OCaml" show TargetProfile = "Haskell (with permutation profiles)" show TargetPygments = "Pygments"+ show TargetCheck = "Check LBNF file" -- | Which version of Alex is targeted? data AlexVersion = Alex1 | Alex2 | Alex3@@ -66,33 +80,49 @@ data HappyMode = Standard | GLR deriving (Eq,Show,Bounded,Enum,Ord) +-- | Which parser generator for ocaml?+data OCamlParser = OCamlYacc | Menhir+ deriving (Eq,Show,Ord)++-- | Which Java backend? data JavaLexerParser = JLexCup | JFlexCup | Antlr4 deriving (Eq,Show,Ord) data RecordPositions = RecordPositions | NoRecordPositions deriving (Eq,Show,Ord) +-- | How to represent token content in the Haskell backend?++data TokenText+ = StringToken -- ^ Represent strings as @String@.+ | ByteStringToken -- ^ Represent strings as @ByteString@.+ | TextToken -- ^ Represent strings as @Data.Text@.+ deriving (Eq, Ord, Show)+ -- | This is the option record that is passed to the different backends. data SharedOptions = Options --- Option shared by at least 2 backends { lbnfFile :: FilePath -- ^ The input file BNFC processes. , lang :: String -- ^ The language we generate: the basename of 'lbnfFile'. , outDir :: FilePath -- ^ Target directory for generated files.+ , force :: Bool -- ^ Ignore errors as much as possible? , target :: Target -- ^ E.g. @--haskell@. , 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. , linenumbers :: RecordPositions -- ^ Add and set line_number field for syntax classes --- Haskell specific: , inDir :: Bool -- ^ Option @-d@.- , ghcExtensions :: Bool -- ^ Option @--ghc@. , functor :: Bool -- ^ Option @--functor@. Make AST functorial?+ , generic :: Bool -- ^ Option @--generic@. Derive Data, Generic, Typeable? , alexMode :: AlexVersion -- ^ Options @--alex@. , shareStrings :: Bool -- ^ Option @--sharestrings@.- , byteStrings :: Bool -- ^ Option @--bytestrings@.+ , tokenText :: TokenText -- ^ Options @--bytestrings@, @--string-token@, and @--text-token@. , glr :: HappyMode -- ^ Happy option @--glr@. , xml :: Int -- ^ Options @--xml@, generate DTD and XML printers. , cnf :: Bool -- ^ Option @--cnf@. Generate CNF-like tables? , agda :: Bool -- ^ Option @--agda@. Create bindings for Agda?+ --- OCaml specific+ , ocamlParser :: OCamlParser -- ^ Option @--menhir@ to switch to @Menhir@. --- Java specific , javaLexerParser :: JavaLexerParser --- C# specific@@ -100,7 +130,7 @@ , wcf :: Bool -- ^ Windows Communication Foundation. } deriving (Eq, Ord, Show) --- | We take this oportunity to define the type of the backend functions.+-- We take this opportunity to define the type of the backend functions. type Backend = SharedOptions -- ^ Options -> CF -- ^ Grammar -> IO ()@@ -110,21 +140,24 @@ { lbnfFile = error "lbnfFile not set" , lang = error "lang not set" , outDir = "."+ , force = False , target = TargetHaskell , make = Nothing , inPackage = Nothing , linenumbers = NoRecordPositions -- Haskell specific , inDir = False- , ghcExtensions = False , functor = False+ , generic = False , alexMode = Alex3 , shareStrings = False- , byteStrings = False+ , tokenText = StringToken , glr = Standard , xml = 0 , cnf = False , agda = False+ -- OCaml specific+ , ocamlParser = OCamlYacc -- Java specific , javaLexerParser = JLexCup -- C# specific@@ -172,11 +205,13 @@ , unlessDefault linenumbers opts $ const [ "-l" ] -- Haskell options: , [ "-d" | inDir opts ]- , [ "--ghc" | ghcExtensions opts ] , [ "--functor" | functor opts ]+ , [ "--generic" | generic opts ] , unlessDefault alexMode opts $ \ o -> [ printAlexOption o ] , [ "--sharestrings" | shareStrings opts ]- , [ "--bytestrings" | byteStrings opts ]+ , [ "--bytestrings" | tokenText opts == ByteStringToken ]+ , [ "--text-token" | tokenText opts == TextToken, not (agda opts) ] -- default for --agda+ , [ "--string-token" | tokenText opts == StringToken, agda opts ] -- default unless --agda , [ "--glr" | glr opts == GLR ] , [ "--xml" | xml opts == 1 ] , [ "--xmlt" | xml opts == 2 ]@@ -187,12 +222,14 @@ , [ "--wfc" | wcf opts ] -- Java options: , unlessDefault javaLexerParser opts $ \ o -> [ printJavaLexerParserOption o ]+ -- Java options:+ , unlessDefault ocamlParser opts $ \ o -> [ printOCamlParserOption o ] -- Grammar file: , [ lbnfFile opts ] ] where tgt = target opts- haskell = tgt `elem` haskellTargets+ -- haskell = tgt `elem` haskellTargets -- | Print target as an option to BNFC. printTargetOption :: Target -> String@@ -208,6 +245,7 @@ TargetOCaml -> "ocaml" TargetProfile -> "profile" TargetPygments -> "pygments"+ TargetCheck -> "check" printAlexOption :: AlexVersion -> String printAlexOption = ("--" ++) . \case@@ -221,6 +259,11 @@ JFlexCup -> "jflex" Antlr4 -> "antlr4" +printOCamlParserOption :: OCamlParser -> String+printOCamlParserOption = ("--" ++) . \case+ OCamlYacc -> "yacc"+ Menhir -> "menhir"+ -- ~~~ Option definition ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- This defines bnfc's "global" options, like --help globalOptions :: [ OptDescr Mode ]@@ -234,6 +277,8 @@ targetOptions = [ Option "" ["java"] (NoArg (\o -> o {target = TargetJava})) "Output Java code [default: for use with JLex and CUP]"+ , Option "" ["java-antlr"] (NoArg (\ o -> o{ target = TargetJava, javaLexerParser = Antlr4 }))+ "Output Java code for use with ANTLR (short for --java --antlr)" , 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}))@@ -247,25 +292,31 @@ , 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"+ "Output C# code for use with GPLEX and GPPG [deprecated]" , Option "" ["ocaml"] (NoArg (\o -> o {target = TargetOCaml})) "Output OCaml code for use with ocamllex and ocamlyacc"+ , Option "" ["ocaml-menhir"] (NoArg (\ o -> o{ target = TargetOCaml, ocamlParser = Menhir }))+ "Output OCaml code for use with ocamllex and menhir (short for --ocaml --menhir)" , Option "" ["profile"] (NoArg (\o -> o {target = TargetProfile}))- "Output Haskell code for rules with permutation profiles"+ "Output Haskell code for rules with permutation profiles [deprecated]" , Option "" ["pygments"] (NoArg (\o -> o {target = TargetPygments})) "Output a Python lexer for Pygments"+ , Option "" ["check"] (NoArg (\ o -> o{target = TargetCheck }))+ "No output. Just check input LBNF file" ] -- | 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 = RecordPositions}))- "Add and set line_number field for all syntax classes\nJava requires cup 0.11b-2014-06-11 or greater"+ [ ( Option ['l'] ["line-numbers"] (NoArg (\o -> o {linenumbers = RecordPositions})) $ unlines+ [ "Add and set line_number field for all syntax classes"+ , "(Note: Java requires cup version 0.11b-2014-06-11 or greater.)"+ ] , [TargetC, TargetCpp, TargetJava] )- , ( Option ['p'] []- (ReqArg (\n o -> o {inPackage = Just n}) "<namespace>")- "Prepend <namespace> to the package/module name"+ , ( Option ['p'] ["name-space"]+ (ReqArg (\n o -> o {inPackage = Just n}) "NAMESPACE")+ "Prepend NAMESPACE to the package/module name" , [TargetCpp, TargetCSharp, TargetJava] ++ haskellTargets) -- Java backend: , ( Option [] ["jlex" ] (NoArg (\o -> o {javaLexerParser = JLexCup}))@@ -277,6 +328,13 @@ , ( Option [] ["antlr4"] (NoArg (\o -> o {javaLexerParser = Antlr4})) "Lex and parse with antlr4" , [TargetJava] )+ -- OCaml backend:+ , ( Option [] ["yacc" ] (NoArg (\ o -> o { ocamlParser = OCamlYacc }))+ "Generate parser with ocamlyacc (default)"+ , [TargetOCaml] )+ , ( Option [] ["menhir"] (NoArg (\ o -> o { ocamlParser = Menhir }))+ "Generate parser with menhir"+ , [TargetOCaml] ) -- C++ backend: , ( Option [] ["vs"] (NoArg (\o -> o {visualStudio = True})) "Generate Visual Studio solution/project files"@@ -286,32 +344,39 @@ , [TargetCSharp] ) -- Haskell backends: , ( Option ['d'] [] (NoArg (\o -> o {inDir = True}))- "Put Haskell code in modules Lang.* instead of Lang*"+ "Put Haskell code in modules LANG.* instead of LANG* (recommended)" , haskellTargets ) , ( Option [] ["alex1"] (NoArg (\o -> o {alexMode = Alex1}))- "Use Alex 1.1 as Haskell lexer tool"+ "Use Alex 1.1 as Haskell lexer tool [deprecated]" , haskellTargets ) , ( Option [] ["alex2"] (NoArg (\o -> o {alexMode = Alex2}))- "Use Alex 2 as Haskell lexer tool"+ "Use Alex 2 as Haskell lexer tool [deprecated]" , haskellTargets ) , ( Option [] ["alex3"] (NoArg (\o -> o {alexMode = Alex3})) "Use Alex 3 as Haskell lexer tool (default)" , haskellTargets ) , ( Option [] ["sharestrings"] (NoArg (\o -> o {shareStrings = True}))- "Use string sharing in Alex 2 lexer"+ "Use string sharing in Alex 2 lexer [deprecated]" , haskellTargets )- , ( Option [] ["bytestrings"] (NoArg (\o -> o {byteStrings = True}))- "Use byte string in Alex 2 lexer"+ , ( Option [] ["bytestrings"] (NoArg (\o -> o { tokenText = ByteStringToken }))+ "Use ByteString in Alex lexer" , haskellTargets )- , ( Option [] ["glr"] (NoArg (\o -> o {glr = GLR}))- "Output Happy GLR parser"+ , ( Option [] ["text-token"] (NoArg (\o -> o { tokenText = TextToken }))+ "Use Text in Alex lexer"+ -- "Use Text in Alex lexer (default for --agda)" , haskellTargets )- , ( Option [] ["ghc"] (NoArg (\o -> o {ghcExtensions = True}))- "Use ghc-specific language extensions"+ , ( Option [] ["string-token"] (NoArg (\o -> o { tokenText = StringToken }))+ "Use String in Alex lexer (default)" , haskellTargets )+ , ( Option [] ["glr"] (NoArg (\o -> o {glr = GLR}))+ "Output Happy GLR parser [deprecated]"+ , haskellTargets ) , ( Option [] ["functor"] (NoArg (\o -> o {functor = True})) "Make the AST a functor and use it to store the position of the nodes" , haskellTargets ) -- TODO: ok with --profile?+ , ( Option [] ["generic"] (NoArg (\o -> o {generic = True}))+ "Derive Data, Generic, and Typeable instances for AST types"+ , haskellTargets ) -- TODO: ok with --profile? , ( Option [] ["xml"] (NoArg (\o -> o {xml = 1})) "Also generate a DTD and an XML printer" , haskellTargets )@@ -322,7 +387,7 @@ , ( Option [] ["cnf"] (NoArg (\o -> o {cnf = True})) "Use the CNF parser instead of happy" , [TargetHaskell] )- , ( Option [] ["agda"] (NoArg (\o -> o {agda = True}))+ , ( Option [] ["agda"] (NoArg (\o -> o { agda = True, tokenText = TextToken })) "Also generate Agda bindings for the abstract syntax" , [TargetHaskell] ) ]@@ -337,6 +402,8 @@ "generate Makefile" , Option "o" ["outputdir"] (ReqArg (\n o -> o {outDir = n}) "DIR") "Redirects all generated files into DIR"+ , Option "" ["force"] (NoArg (\ o -> o { force = True }))+ "Ignore errors in the grammar (may produce ill-formed output or crash)" ] where setMakefile mf o = o { make = Just mf } @@ -358,24 +425,27 @@ , "" ] -oldContributors :: [String]-oldContributors =- [ "(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."- ]+-- oldContributors :: [String]+-- oldContributors =+-- [ "(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."+-- ] usage :: String-usage = "usage: bnfc [--version] [--help] <target language> [<args>] file.cf"+usage = unlines+ [ "usage: bnfc [--TARGET] [OPTIONS] LANG.cf"+ , " or: bnfc --[numeric-]version"+ , " or: bnfc [--help]"+ ] help :: String help = unlines $ title ++ [ usage- , "" , usageInfo "Global options" globalOptions , usageInfo "Common options" commonOptions- , usageInfo "Target languages" targetOptions+ , usageInfo "TARGET languages" targetOptions ] ++ map targetUsage helpTargets where helpTargets = [ TargetHaskell, TargetJava, TargetC, TargetCpp, TargetCSharp ]@@ -386,74 +456,163 @@ -- ~~~ Parsing machinery ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- | Main parsing function-parseMode :: [String] -> Mode-parseMode [] = Help+parseMode :: [String] -> (Mode, UsageWarnings) parseMode args =+ case runWriterT $ parseMode' =<< translateOldOptions args of+ Left err -> (UsageError err, [])+ Right res -> res++type ParseOpt = WriterT UsageWarnings (Either String)+type UsageWarnings = [String]++parseMode' :: [String] -> ParseOpt Mode+parseMode' [] = return Help+parseMode' args = -- First, check for global options like --help or --version- case getOpt' Permute globalOptions args' of- (mode:_,_,_,_) -> mode+ case getOpt' Permute globalOptions args of+ (mode:_,_,_,_) -> return mode -- Then, check for unrecognized options.- _ -> case getOpt' Permute allOptions args' of- (_, _, [u], _) -> UsageError $ unwords [ "Unrecognized option:" , u ]- (_, _, us@(_:_), _) -> UsageError $ unwords $ "Unrecognized options:" : us+ _ -> do+ let (_, _, unknown, _) = getOpt' Permute allOptions args+ processUnknownOptions unknown -- Then, determine target language.- _ -> case getOpt' Permute targetOptions args' of- -- ([] ,_,_,_) -> UsageError "No target selected" -- --haskell is default target- (_:_:_,_,_,_) -> UsageError "At most one target is allowed"+ case getOpt' Permute targetOptions args of+ -- ([] ,_,_,_) -> usageError "No target selected" -- --haskell is default target+ (_:_:_,_,_,_) -> usageError "At most one target is allowed" -- Finally, parse options with known target.- (optionUpdates,_,_,_) -> let- -- Compute target and valid options for this target.- tgt = target (options optionUpdates)- opts = allOptions' tgt- in- case getOpt' Permute opts args' of- (_, _, _, e:_) -> UsageError e- (_, _, [u], _) -> UsageError $ unwords $ [ "Backend", show tgt, "does not support option", u ]- (_, _, us@(_:_), _) -> UsageError $ unwords $ [ "Backend", show tgt, "does not support options" ] ++ us- (_, [], _, _) -> UsageError "Missing grammar file"- (optionsUpdates, [grammarFile], [], []) ->+ (optionUpdates,_,_,_) -> do+ let tgt = target (options optionUpdates)+ case getOpt' Permute (allOptions' tgt) args of+ (_, _, _, e:_) -> usageError e+ (_, _, [u], _) -> usageError $ unwords $ [ "Backend", show tgt, "does not support option", u ]+ (_, _, us@(_:_), _) -> usageError $ unwords $ [ "Backend", show tgt, "does not support options" ] ++ us+ (_, [], _, _) -> usageError "Missing grammar file"+ (optionsUpdates, [grammarFile], [], []) -> do let opts = (options optionsUpdates) { lbnfFile = grammarFile , lang = takeBaseName grammarFile }- in Target opts grammarFile- (_, _, _, _) -> UsageError "Too many arguments"+ warnDeprecatedBackend tgt+ warnDeprecatedOptions opts+ return $ Target opts grammarFile+ (_, _, _, _) -> usageError "Too many arguments" where- args' = translateOldOptions args options optionsUpdates = foldl (.) id optionsUpdates defaultOptions+ usageError = return . UsageError +-- * Deprecation++class Maintained a where+ maintained :: a -> Bool+ printFeature :: a -> String++instance Maintained Target where+ printFeature = printTargetOption+ maintained = \case+ TargetC -> True+ TargetCpp -> True+ TargetCppNoStl -> True+ TargetCSharp -> False+ TargetHaskell -> True+ TargetHaskellGadt -> True+ TargetLatex -> True+ TargetJava -> True+ TargetOCaml -> True+ TargetProfile -> False+ TargetPygments -> True+ TargetCheck -> True++instance Maintained AlexVersion where+ printFeature = printAlexOption+ maintained = \case+ Alex1 -> False+ Alex2 -> False+ Alex3 -> True++instance Maintained HappyMode where+ printFeature = \case+ Standard -> undefined+ GLR -> "--glr"+ maintained = \case+ Standard -> True+ GLR -> False++warnDeprecatedBackend :: Maintained a => a -> ParseOpt ()+warnDeprecatedBackend backend =+ Ctrl.unless (maintained backend) $ warnDeprecated $ unwords [ "backend", printFeature backend ]++warnDeprecated :: String -> ParseOpt ()+warnDeprecated feature =+ tell+ [ unwords [ "Warning:", feature, "is deprecated and no longer maintained." ]+ -- , "Should it be broken, try an older version of BNFC."+ ]++warnDeprecatedOptions :: SharedOptions -> ParseOpt ()+warnDeprecatedOptions Options{..} = do+ warnDeprecatedBackend alexMode+ warnDeprecatedBackend glr+ Ctrl.when shareStrings $ warnDeprecated $ "feature --sharestrings"+ -- * Backward compatibility +-- | Produce a warning for former options that are now obsolete.+-- Throw an error for properly unknown options.+--+-- Note: this only works properly for former options that had no arguments.+processUnknownOptions :: [String] -> ParseOpt ()+processUnknownOptions os = do+ case List.partition (`elem` obsoleteOptions) os of+ -- Throw an error for properly unknown options.+ (_, us@[_] ) -> throwError $ unwords $ "Unrecognized option:" : us+ (_, us@(_:_)) -> throwError $ unwords $ "Unrecognized options:" : us+ -- Generate warning for former options that are now obsolete.+ (os@[_] , _) -> tell [ unwords $ "Warning: ignoring obsolete options:" : os ]+ (os@(_:_), _) -> tell [ unwords $ "Warning: ignoring obsolete options:" : os ]+ ([], []) -> return ()+ where+ obsoleteOptions = []+ -- | A translation function to maintain backward compatibility -- with the old option syntax. -translateOldOptions :: [String] -> [String]-translateOldOptions = map $ \case- "-agda" -> "--agda"- "-java" -> "--java"- "-java1.5" -> "--java"- "-c" -> "--c"- "-cpp" -> "--cpp"- "-cpp_stl" -> "--cpp"- "-cpp_no_stl" -> "--cpp-nostl"- "-csharp" -> "--csharp"- "-ocaml" -> "--ocaml"- "-fsharp" -> "fsharp"- "-haskell" -> "--haskell"- "-prof" -> "--profile"- "-gadt" -> "--haskell-gadt"- "-alex1" -> "--alex1"- "-alex2" -> "--alex2"- "-alex3" -> "--alex3"- "-sharestrings" -> "--sharestring"- "-bytestrings" -> "--bytestring"- "-glr" -> "--glr"- "-xml" -> "--xml"- "-xmlt" -> "--xmlt"- "-vs" -> "--vs"- "-wcf" -> "--wcf"- other -> other+translateOldOptions :: [String] -> ParseOpt [String]+translateOldOptions = mapM $ \ o -> do+ case Map.lookup o translation of+ Nothing -> return o+ Just o' -> do+ tell [ unwords [ "Warning: unrecognized option", o, "treated as if", o', "was provided." ] ]+ return o'+ where+ translation = Map.fromList $+ [ ("-agda" , "--agda")+ , ("-java" , "--java")+ , ("-java1.5" , "--java")+ , ("-c" , "--c")+ , ("-cpp" , "--cpp")+ , ("-cpp_stl" , "--cpp")+ , ("-cpp_no_stl" , "--cpp-nostl")+ , ("-csharp" , "--csharp")+ , ("-ocaml" , "--ocaml")+ , ("-haskell" , "--haskell")+ , ("-prof" , "--profile")+ , ("-gadt" , "--haskell-gadt")+ , ("-alex1" , "--alex1")+ , ("-alex2" , "--alex2")+ , ("-alex3" , "--alex3")+ , ("-sharestrings" , "--sharestring")+ , ("-bytestrings" , "--bytestring")+ , ("-glr" , "--glr")+ , ("-xml" , "--xml")+ , ("-xmlt" , "--xmlt")+ , ("-vs" , "--vs")+ , ("-wcf" , "--wcf")+ , ("-generic" , "--generic")+ , ("--ghc" , "--generic")+ , ("--deriveGeneric" , "--generic")+ , ("--deriveDataTypeable" , "--generic")+ ]
+ src/BNFC/Regex.hs view
@@ -0,0 +1,342 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternGuards #-}++-- | Tools to manipulate regular expressions.++module BNFC.Regex ( nullable, simpReg ) where++import Data.Semigroup (Semigroup(..))+import Data.Set (Set)+import qualified Data.Set as Set+import qualified Data.List as List++import AbsBNF++-- | Check if a regular expression is nullable (accepts the empty string)+nullable :: Reg -> Bool+nullable = \case+ RSeq r1 r2 -> nullable r1 && nullable r2+ RAlt r1 r2 -> nullable r1 || nullable r2+ RMinus r1 r2 -> nullable r1 && not (nullable r2)+ RStar _ -> True+ RPlus r1 -> nullable r1+ ROpt _ -> True+ REps -> True+ RChar _ -> False+ RAlts _ -> False+ RSeqs s -> null s+ RDigit -> False+ RLetter -> False+ RUpper -> False+ RLower -> False+ RAny -> False++-- | Simplification of regular expression, mostly for the purpose+-- of simplifying character alternatives (character classes).+--+-- This may help lexer backends, since often lexer generators+-- have a limited syntax for character classes.+--+simpReg :: Reg -> Reg+simpReg = rloop+ where+ rloop = rx . loop+ loop :: Reg -> RC+ loop = \case+ -- Definitely not character classes:+ -- RSeq r1 r2 -> Rx $ rloop r1 `rSeq` rloop r2+ RStar r -> Rx $ rStar $ rloop r+ RPlus r -> Rx $ rPlus $ rloop r+ ROpt r -> Rx $ rOpt $ rloop r+ REps -> Rx $ REps+ RSeqs "" -> Rx $ REps+ RSeqs [c] -> CC $ cChar c+ RSeqs s -> Rx $ RSeqs s+ -- Possibly character classes:+ RSeq r1 r2 -> loop r1 `rcSeq` loop r2+ RAlt r1 r2 -> loop r1 `rcAlt` loop r2+ RMinus r1 r2 -> loop r1 `rcMinus` loop r2+ -- Definitely character classes:+ RChar c -> CC $ cChar c+ RAlts s -> CC $ cAlts s+ RDigit -> CC $ cDigit+ RLetter -> CC $ cLetter+ RUpper -> CC $ cUpper+ RLower -> CC $ cLower+ RAny -> CC $ cAny+++-- | Character classes are regular expressions that recognize+-- character sequences of length exactly one. These are often+-- distinguished from arbitrary regular expressions in lexer+-- generators, e.g. in @alex@.+--+-- We represent character classes as a difference of unions of atomic+-- character classes.++data CharClass = CMinus { ccYes, ccNo :: CharClassUnion }+ deriving (Eq, Ord, Show)++data CharClassUnion+ = CAny -- ^ Any character.+ | CAlt (Set CharClassAtom) -- ^ Any of the given (≥0) alternatives.+ deriving (Eq, Ord, Show)++data CharClassAtom+ = CChar Char -- ^ A single character.+ | CDigit -- ^ @0-9@.+ | CLower -- ^ Lower case character.+ | CUpper -- ^ Upper case character.+ deriving (Eq, Ord, Show)++-- -- | Regular expressions are constructed over character classes.+-- --+-- -- We do not simplify at the level of regular expressions;+-- -- this is left to the backend.+-- data Regex+-- = RxAlt Reg Reg+-- | RxMinus Reg Reg+-- | RxSeq Reg Reg+-- | RxStar Reg+-- | RxPlus Reg+-- | RxOpt Reg+-- | RxEps+-- | RxChar CharClass+-- deriving (Eq, Ord, Show)++-- | A regular expression that might be a character class.+data RC+ = Rx Reg+ | CC CharClass++-- * Smart constructors for regular expressions.++rSeq :: Reg -> Reg -> Reg+rSeq = curry $ \case+ -- 0r = 0+ (RAlts "", _ ) -> RAlts ""+ (_ , RAlts "") -> RAlts ""+ -- 1r = r+ (REps , r ) -> r+ (RSeqs "", r ) -> r+ (r , REps ) -> r+ (r , RSeqs "") -> r+ -- r*r* = r*+ (RStar r1, RStar r2) | r1 == r2 -> rStar r1+ -- r+r* = r*r+ = r++ (RPlus r1, RStar r2) | r1 == r2 -> rPlus r1+ (RStar r1, RPlus r2) | r1 == r2 -> rPlus r1+ -- rr* = r*r = r++ (r1 , RStar r2) | r1 == r2 -> rPlus r1+ (RStar r1, r2 ) | r1 == r2 -> rPlus r1+ -- character sequences+ (RSeqs s1, RSeqs s2) -> RSeqs $ s1 ++ s2+ (RChar c1, RSeqs s2) -> RSeqs $ c1 : s2+ (RSeqs s1, RChar c2) -> RSeqs $ s1 ++ [c2]+ (RChar c1, RChar c2) -> RSeqs [ c1, c2 ]+ -- Associate to the left+ (r1 , RSeq r2 r3) -> (r1 `rSeq` r2) `rSeq` r3+ -- general sequences+ (r1 , r2 ) -> r1 `RSeq` r2++rAlt :: Reg -> Reg -> Reg+rAlt = curry $ \case+ -- 0 + r = r+ (RAlts "", r ) -> r+ -- r + 0 = r+ (r , RAlts "") -> r+ -- join character alternatives+ (RAlts s1, RAlts s2) -> RAlts $ s1 ++ s2+ (RChar c1, RAlts s2) -> RAlts $ c1 : s2+ (RAlts s1, RChar c2) -> RAlts $ s1 ++ [c2]+ (RChar c1, RChar c2) -> RAlts [ c1, c2 ]+ -- Associate to the left+ (r1 , RAlt r2 r3) -> (r1 `rAlt` r2) `rAlt` r3+ -- general alternatives+ (r1, r2)+ | r1 == r2 -> r1 -- idempotency, but not the general case+ | otherwise -> r1 `RAlt` r2++rMinus :: Reg -> Reg -> Reg+rMinus = curry $ \case+ -- 0 - r = 0+ (RAlts "", _ ) -> RAlts ""+ -- r - 0 = r+ (r , RAlts "") -> r+ -- join character alternatives+ (RAlts s1, RAlts s2) -> case s1 List.\\ s2 of+ [c] -> RChar c+ s -> RAlts s+ (r1, r2)+ | r1 == r2 -> RAlts ""+ | otherwise -> r1 `RMinus` r2++rStar :: Reg -> Reg+rStar = \case+ REps -> REps+ RSeqs "" -> REps+ RAlts "" -> REps+ ROpt r -> RStar r+ RStar r -> RStar r+ RPlus r -> RStar r+ r -> RStar r++rPlus :: Reg -> Reg+rPlus = \case+ REps -> REps+ RSeqs "" -> REps+ RAlts "" -> RAlts ""+ ROpt r -> RStar r+ RStar r -> RStar r+ RPlus r -> RPlus r+ r -> RPlus r++rOpt :: Reg -> Reg+rOpt = \case+ REps -> REps+ RSeqs "" -> REps+ RAlts "" -> REps+ RStar r -> RStar r+ RPlus r -> RStar r+ ROpt r -> ROpt r+ r -> ROpt r++rcSeq :: RC -> RC -> RC+rcSeq = curry $ \case+ (Rx REps , r ) -> r+ (Rx (RSeqs ""), r ) -> r+ (r , Rx REps ) -> r+ (r , Rx (RSeqs "")) -> r+ (r1 , r2 ) -> Rx $ rx r1 `rSeq` rx r2++rcAlt :: RC -> RC -> RC+rcAlt = curry $ \case+ -- 0 + r = r + 0 = r+ (Rx (RAlts ""), r) -> r+ (r, Rx (RAlts "")) -> r+ -- other cases+ (CC c1, CC c2) -> c1 `cAlt` c2+ (c1 , c2 ) -> Rx $ rx c1 `rAlt` rx c2++rcMinus :: RC -> RC -> RC+rcMinus = curry $ \case+ -- r - 0 = r+ (r , Rx (RAlts "")) -> r+ (CC c1, CC c2 ) -> c1 `cMinus` c2+ (c1 , c2 ) -> Rx $ rx c1 `rMinus` rx c2++class ToReg a where+ rx :: a -> Reg++instance ToReg RC where+ rx (Rx r) = r+ rx (CC c) = rx c++instance ToReg CharClass where+ rx (CMinus p m)+ | m == mempty = rx p+ | p == mempty = RAlts ""+ | otherwise = rx p `RMinus` rx m++instance ToReg CharClassUnion where+ rx CAny = RAny+ rx (CAlt cs) = case rs of+ [] -> RAlts ""+ [r] -> r+ rs -> foldr1 RAlt rs+ where+ -- collect elements of cs into St+ start = St False False False ""+ step st = \case+ CChar c -> st { stAlts = c : stAlts st }+ CDigit -> st { stDigit = True }+ CLower -> st { stLower = True }+ CUpper -> st { stUpper = True }+ (St digit upper lower alts) = foldl step start $ Set.toDescList cs+ rs = concat+ [ [ RChar c | [c] <- [alts] ]+ , [ RAlts alts | (_:_:_) <- [alts] ]+ , [ RDigit | digit ]+ , [ RLetter | upper && lower ]+ , [ RUpper | upper && not lower ]+ , [ RLower | lower && not upper ]+ ]++ -- Local state type+data St = St { stDigit, stUpper, stLower :: Bool, stAlts :: String }++-- UNUSED:+-- instance ToReg CharClassAtom where+-- rx = \case+-- CChar c -> RChar c+-- CDigit -> RDigit+-- CLower -> RLower+-- CUpper -> RUpper++-- * Constructors for character classes.++-- |+-- @(p1 \ m1) ∪ (p2 \ m2) = (p1 ∪ p2) \ (m1 ∪ m2)@ if @p1 ⊥ m2@ and @p2 ⊥ m1@+cAlt :: CharClass -> CharClass -> RC+cAlt c1@(CMinus p1 m1) c2@(CMinus p2 m2)+ | c1 == cAny || c2 == cAny = CC cAny+ | p1 `ccuMinus` m2 == Right p1,+ p2 `ccuMinus` m1 == Right p2 = CC $ either id ccu $ (p1 <> p2) `ccuMinus` (m1 <> m2)+ | otherwise = Rx $ rx c1 `RAlt` rx c2++ -- -- | ccuDisjoint p1 m2, ccuDisjoint p2 m1 = CC $ either id ccu $ (p1 <> p2) `ccuMinus` (m1 <> m2)+ -- -- | null m1, null m2 = CC $ ccu (p1 <> p2)++-- |+-- @(p1 \ m1) \ (0 \ m2) = p1 \ m1@+-- @(p1 \ m1) \ (p2 \ m2) = p1 \ (m1 ∪ p2)@ if @p1 \ m2 = p1@+cMinus :: CharClass -> CharClass -> RC+cMinus c1@(CMinus p1 m1) c2@(CMinus p2 m2)+ | p2 == mempty = CC c1+ | p1 `ccuMinus` m2 == Right p1 = CC $ either id ccu $ p1 `ccuMinus` (m1 <> p2)+ | otherwise = Rx $ rx c1 `RMinus` rx c2++cChar :: Char -> CharClass+cChar c = cAlts [c]++cAlts :: String -> CharClass+cAlts cs = ccu $ CAlt $ Set.fromList $ map CChar cs++cDigit, cLower, cUpper, cLetter, cAny :: CharClass+cDigit = cAtom CDigit+cLower = cAtom CLower+cUpper = cAtom CUpper+cLetter = ccu $ CAlt $ Set.fromList [ CLower, CUpper ]+cAny = ccu CAny++cAtom :: CharClassAtom -> CharClass+cAtom = ccu . CAlt . Set.singleton++ccu :: CharClassUnion -> CharClass+ccu = (`CMinus` mempty)++-- (A \ B) \ (C \ D) = A \ (B ∪ (C \ D))++-- | Mutually reduce: @(A - B) = (A \ B) - (B \ A)@+ccuMinus :: CharClassUnion -> CharClassUnion -> Either CharClass CharClassUnion+ccuMinus = curry $ \case+ (_ , CAny) -> Right mempty+ (c1@CAny, c2 )+ | c2 == mempty -> Right $ c1+ | otherwise -> Left $ c1 `CMinus` c2+ (CAlt cs1, CAlt cs2)+ | Set.null cs1' ||+ Set.null cs2' -> Right $ CAlt cs1'+ | otherwise -> Left $ CAlt cs1' `CMinus` CAlt cs2'+ where+ cs1' = cs1 Set.\\ cs2+ cs2' = cs2 Set.\\ cs1++instance Semigroup CharClassUnion where+ CAny <> _ = CAny+ _ <> CAny = CAny+ CAlt cs <> CAlt cs' = CAlt (cs <> cs')++instance Monoid CharClassUnion where+ mempty = CAlt Set.empty+ mappend = (<>)
src/BNFC/ToCNFCore.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TypeSynonymInstances, FlexibleInstances, CPP #-}+{-# LANGUAGE RecordWildCards #-} {- Copyright (C) 2012 Authors: Jean-Philippe Bernardy.@@ -37,35 +38,38 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (Const) #endif-import qualified Data.Map as M-import Data.List (nub,sortBy,sort)-import Data.Function (on)-import Data.Char (isAlphaNum,ord)++import Data.Bifunctor (second)+import Data.Char (isAlphaNum, ord)+import Data.Function (on)+import Data.Functor (($>))+import Data.List (nub, sortBy, sort)+import Data.Map (Map)+import qualified Data.Map as Map import Data.Pair-import Text.PrettyPrint.HughesPJ hiding (first,(<>)) -(f *** g) (a,b) = (f a, g b)-second g = id *** g+import Text.PrettyPrint.HughesPJ hiding (first, (<>)) +onRules ::([Rul f] -> [Rul g]) -> CFG f -> CFG g onRules f cfg@CFG{..} = cfg { cfgRules = f cfgRules } +toCNF :: IsFun a => CFG a+ -> (CFG Exp, CFG Exp, UnitRel Cat, CatDescriptions,+ [(Either Cat String, [Either Cat String])]) toCNF cf0 = (cf1,cf2,units,descriptions,neighbors)- where cf01 = funToExp . onRules delInternal $ cf0+ where cf01 = funToExp . onRules (filter isParsable) $ cf0 (rules',descriptions) = toBin (cfgRules cf01) cf1 = cf01 { cfgRules = rules' } cf2 = delNull cf1 units = unitSet cf2 neighbors = neighborSet cf2 -funToExp :: CFG Fun -> CFG Exp+funToExp :: IsFun a => CFG a -> CFG Exp funToExp = fmap toExp +toExp :: IsFun a => a -> Exp toExp f | isCoercion f = Id- | otherwise = Con f--delInternal = filter (not . isInternalRhs . rhsRule)- where isInternalRhs (Left c:_) = c == InternalCat- isInternalRhs _ = False+ | otherwise = Con $ funName f isCat (Right _) = False isCat (Left _) = True@@ -81,7 +85,7 @@ catTag :: Either Cat String -> Doc catTag (Left c) = "CAT_" <> text (concatMap escape (show c))-catTag (Right t) = "TOK_" <> text (concatMap escape t)+catTag (Right t) = "TOK_" <> text (concatMap escapeToken t) escape c | isAlphaNum c || c == '_' = [c] escape '[' = ""@@ -89,8 +93,37 @@ escape '{' = "OPEN_" escape '}' = "CLOS_" escape '@' = "BIN_"-escape c = show $ ord c+escape c = show (ord c) ++ "_" +escapeToken c | isAlphaNum c || c == '_' = [c]+escapeToken '(' = "LPAREN_"+escapeToken ')' = "RPAREN_"+escapeToken '[' = "LBRACKET_"+escapeToken ']' = "RBRACKET_"+escapeToken '{' = "LBRACE_"+escapeToken '}' = "RBRACE_"+escapeToken '~' = "TILDE_"+escapeToken '^' = "CARET_"+escapeToken '*' = "STAR_"+escapeToken '+' = "PLUS_"+escapeToken '-' = "DASH_"+escapeToken '/' = "SLASH_"+escapeToken '.' = "DOT_"+escapeToken ',' = "COMMA_"+escapeToken ';' = "SEMI_"+escapeToken ':' = "COLON_"+escapeToken '=' = "EQ_"+escapeToken '<' = "LT_"+escapeToken '>' = "GT_"+escapeToken '&' = "AMP_"+escapeToken '|' = "BAR_"+escapeToken '%' = "PERCENT_"+escapeToken '?' = "QUESTION_"+escapeToken '!' = "BANG_"+-- add more if you have fun+-- or fall back to ASCII code:+escapeToken c = show (ord c) ++ "_"+ punctuate' p = cat . punctuate p -------------------------------------------------------------- -- BIN: make sure no rule has more than 2 symbols on the rhs@@ -104,17 +137,17 @@ toBin cf = (a,w) where (a,_,w) = runRWS (concat <$> forM cf toBinRul) () 0 -type CatDescriptions = M.Map Cat Doc+type CatDescriptions = 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+toBinRul (Rule f cat rhs internal) | 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' <- toBinRul $ Rule f (cat $> cat') p internal+ tell $ Map.singleton cat' (int (length p) <> "-prefix of " <> prettyExp f <> " " <> parens (prettyRHS p))+ return $ Rule (Con "($)") cat [Left cat',l] internal : r' where l = last rhs p = init rhs@@ -127,15 +160,15 @@ x ∪ y = sort $ nub (x ++ y) -lookupMulti cat nullset = maybe [] id (M.lookup cat nullset)+lookupMulti cat nullset = maybe [] id (Map.lookup cat nullset) -type Set k x = M.Map k [x]+type Set k x = 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+fixpointOnGrammar name f cf = case fixn 100 step Map.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) (cfgRules cf))+ where step curSet = Map.unionsWith (∪) (map (f curSet) (cfgRules cf)) fixn :: Eq a => Int -> (a -> a) -> a -> Either a a fixn 0 _ x = Left x@@ -152,25 +185,25 @@ cross (x:xs) = [y:ys | y <- x, ys <- cross xs] nullRule :: Nullable -> Rul Exp -> (Cat,[Exp])-nullRule nullset (Rule f c rhs) = (c, map (appMany f) (cross (map nulls rhs)))+nullRule nullset (Rule f c rhs _) = (wpThing c, map (appMany f) (cross (map nulls rhs))) where nulls (Right _) = [] nulls (Left cat) = lookupMulti cat nullset nullSet :: CFG Exp -> Nullable-nullSet = fixpointOnGrammar "nullable" (\s r -> uncurry M.singleton (nullRule s r))+nullSet = fixpointOnGrammar "nullable" (\s r -> uncurry Map.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+delNullable nullset r@(Rule f cat rhs internal) = 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]+ [r1,r2] -> [r] ++ [Rule (app' f x) cat [r2] internal | x <- lk' r1]+ ++ [Rule (app2 (isCat r1) f x) cat [r1] internal | x <- lk' r2] _ -> error $ "Panic:" ++ show r ++ "should have at most two elements." where lk' (Right _) = [] lk' (Left cat) = lookupMulti cat nullset -+delNull :: CFG Exp -> CFG Exp delNull cf = onRules (concatMap (delNullable (nullSet cf))) cf @@ -184,13 +217,14 @@ 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]+unitRule unitSet (Rule f (WithPosition _ c) [r] _internal) = Map.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+unitRule _ _ = Map.empty -isUnitRule (Rule _ _ [_]) = True+isUnitRule (Rule _ _ [_] _) = True isUnitRule _ = False @@ -199,10 +233,10 @@ type RHSEl = Either Cat String isOnLeft, isOnRight :: RHSEl -> Rul f -> Bool-isOnLeft c (Rule _ _ [c',_]) = c == c'+isOnLeft c (Rule _ _ [c',_] _) = c == c' isOnLeft _ _ = False -isOnRight c (Rule _ _ [_,c']) = c == c'+isOnRight c (Rule _ _ [_,c'] _) = c == c' isOnRight _ _ = False isEntryPoint cf el = either (`elem` allEntryPoints cf) (const False) el@@ -234,14 +268,14 @@ -- Error reporting -- leftOf C = ⋃ { {X} ∪ leftOf X | C ::= X B ∈ Grammar or C ::= X ∈ Grammar }-leftRight pos s (Rule _ c rhs) = M.singleton (show c) (lkCat x s)+leftRight pos s (Rule _ c rhs _) = Map.singleton (show c) (lkCat x s) where x = pos rhs lkCat (Right t) _ = [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] <- cfgRules cf, x' <- lkCat x rightSet]+neighborSet cf = map (second (nub . sort)) $ group' [(x',lkCat y leftSet) | Rule _ _ [x,y] _ <- cfgRules cf, x' <- lkCat x rightSet] where leftSet = fixpointOnGrammar "left set" (leftRight head) cf rightSet = fixpointOnGrammar "right set" (leftRight last) cf
src/BNFC/TypeChecker.hs view
@@ -1,100 +1,68 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeSynonymInstances #-} -module BNFC.TypeChecker where+-- | Type checker for defined syntax constructors @define f xs = e@. +module BNFC.TypeChecker+ ( -- * Type checker entry point+ runTypeChecker+ , checkDefinitions+ , Base(..)+ -- * Backdoor for rechecking defined syntax constructors for list types+ , checkDefinition'+ , buildSignature, buildContext, ctxTokens, isToken+ , ListConstructors(LC)+ ) where+ import Control.Monad+import Control.Monad.Except (MonadError(..))+import Control.Monad.Reader +import Data.Bifunctor import Data.Char-import Data.Function (on)-import Data.List -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]+import qualified Data.Map as Map+import qualified Data.Set as Set -data Context = Ctx- { ctxLabels :: [(String, Type)]- , ctxTokens :: [String]- }+import BNFC.CF -catchErr :: Err a -> (String -> Err a) -> Err a-catchErr (Bad s) f = f s-catchErr (Ok x) _ = Ok x+-- * Error monad -buildContext :: CF -> Context-buildContext cf@CFG{..} = Ctx- { ctxLabels =- [ (f, mkType cat args)- | Rule f cat args <- cfgRules- , not (isCoercion f)- , not (isNilCons f)- ]- , ctxTokens =- ("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+type TCError = WithPosition String -isToken :: String -> Context -> Bool-isToken x ctx = elem x $ ctxTokens ctx+-- | Type checking monad, reports errors.+newtype Err a = Err { unErr :: ReaderT Position (Either TCError) a }+ deriving (Functor, Applicative, Monad, MonadReader Position) -extendContext :: Context -> [(String,Type)] -> Context-extendContext ctx xs = ctx { ctxLabels = xs ++ ctxLabels ctx }+instance MonadError String Err where+ throwError msg = Err $ do+ pos <- ask+ throwError $ WithPosition pos msg+ catchError m h = Err $ do+ unErr m `catchError` \ (WithPosition _ msg) -> unErr (h msg) -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+withPosition :: Position -> Err a -> Err a+withPosition pos = local (const pos) -checkDefinitions :: CF -> Err ()-checkDefinitions cf =- do checkContext ctx- sequence_ [checkDefinition ctx f xs e | FunDef f xs e <- cfgPragmas cf]- where- ctx = buildContext cf+runTypeChecker :: Err a -> Either String a+runTypeChecker m = first blendInPosition $ unErr m `runReaderT` NoPosition -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 (\ ps -> (fst (head ps), map snd ps))- . groupBy ((==) `on` fst)- . sortBy (compare `on` fst)+-- * Types and context - checkEntry (f,ts) =- case nub ts of- [_] -> return ()- ts' ->- fail $ "The symbol '" ++ f ++ "' is used at conflicting types:\n" ++- unlines (map ((" " ++) . show) ts')+-- | Function arguments with type.+type Telescope = [(String, Base)] -checkDefinition :: Context -> String -> [String] -> Exp -> Err ()-checkDefinition ctx f xs e =- void $ checkDefinition' dummyConstructors ctx f xs e+data Context = Ctx+ { ctxLabels :: Signature -- ^ Types of labels, extracted from rules.+ , ctxTokens :: [String] -- ^ User-defined token types.+ , ctxLocals :: Telescope -- ^ Types of local variables of a definition.+ } data ListConstructors = LC { nil :: Base -> String@@ -104,43 +72,138 @@ 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."++-- * Type checker for definitions and expressions++-- | Entry point.+checkDefinitions :: CF -> Err ()+checkDefinitions cf = do+ let ctx = buildContext cf+ sequence_ [ checkDefinition ctx f xs e | FunDef f xs e <- cfgPragmas cf ]++checkDefinition :: Context -> RFun -> [String] -> Exp -> Err ()+checkDefinition ctx f xs e =+ void $ checkDefinition' dummyConstructors ctx f xs e++checkDefinition'+ :: ListConstructors -- ^ Translation of the list constructors.+ -> Context -- ^ Signature (types of labels).+ -> RFun -- ^ Function name.+ -> [String] -- ^ Function arguments.+ -> Exp -- ^ Function body.+ -> Err (Telescope, (Exp, Base)) -- ^ Typed arguments, translated body, type of body.+checkDefinition' list ctx ident xs e =+ withPosition (wpPosition ident) $+ do unless (isLower $ head f) $ throwError $+ "Defined functions must start with a lowercase letter."+ t@(FunT ts t') <- lookupCtx f ctx `catchError` \_ ->+ throwError $ "'" ++ 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'+ unless (expect == given) $ throwError $ concat+ [ "'", f, "' is used with type ", show t+ , " but defined with ", show given, " argument", plural given ++ "."+ ]+ e' <- checkExp list (setLocals ctx $ zip xs ts) e t' return (zip xs ts, (e', t'))- `catchErr` \err -> fail $ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err+ `catchError` \ err -> throwError $+ "In the definition " ++ unwords (f : xs ++ ["=",show e,";"]) ++ "\n " ++ err where+ f = wpThing ident plural 1 = "" plural _ = "s" checkExp :: ListConstructors -> Context -> Exp -> Base -> Err Exp-checkExp list _ (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 ts- unless (t == t') $ fail $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected."- return $ App x es'+checkExp list ctx = curry $ \case+ (App "[]" [] , ListT t ) -> return (App (nil list t) [])+ (App "[]" _ , _ ) -> throwError $+ "[] is applied to too many arguments."++ (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']++ (App "(:)" es , _ ) -> throwError $+ "(:) takes 2 arguments, but has been given " ++ show (length es) ++ "."++ (e@(App x es) , t ) -> checkApp e x es t+ (e@(Var x) , t ) -> e <$ checkApp e x [] t+ (e@LitInt{} , BaseT "Integer") -> return e+ (e@LitDouble{} , BaseT "Double" ) -> return e+ (e@LitChar{} , BaseT "Char" ) -> return e+ (e@LitString{} , BaseT "String" ) -> return e+ (e , t ) -> throwError $+ show e ++ " does not have type " ++ show t ++ "."+ where+ checkApp e x es t = do+ FunT ts t' <- lookupCtx x ctx+ es' <- matchArgs ts+ unless (t == t') $ throwError $ show e ++ " has type " ++ show t' ++ ", but something of type " ++ show t ++ " was expected."+ return $ App x es' where- matchArgs 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 ++ "."+ matchArgs ts+ | expect /= given = throwError $ "'" ++ 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++-- * Context handling++-- | Create context containing the types of all labels,+-- computed from the rules.+--+-- Fail if a label is used at different types.+--+buildSignature :: [Rule] -> Err Signature+buildSignature rules = do+ -- Build label signature with duplicates+ let sig0 = Map.fromListWith mappend $ map (second Set.singleton) labels+ -- Check for duplicates; extract from singleton sets.+ sig <- forM (Map.toAscList sig0) $ \ (f,ts) ->+ case Set.toList ts of+ [] -> undefined -- impossible+ [t] -> return (f,t)+ ts' -> throwError $ unlines $ concat+ [ [ "The label '" ++ f ++ "' is used at conflicting types:" ]+ , map ((" " ++) . blendInPosition . fmap show) ts'+ ]+ return $ Map.fromAscList sig+ where+ mkType cat args = FunT [ mkBase t | Left t <- args ]+ (mkBase cat)+ mkBase t+ | isList t = ListT $ mkBase $ normCatOfList t+ | otherwise = BaseT $ catToStr $ normCat t++ labels =+ [ (x, WithPosition pos $ mkType (wpThing cat) args)+ | Rule f@(WithPosition pos x) cat args _ <- rules+ , not (isCoercion f)+ , not (isNilCons f)+ ]++buildContext :: CF -> Context+buildContext cf = Ctx+ { ctxLabels = cfgSignature cf+ , ctxTokens = ("Ident" : tokenNames cf)+ , ctxLocals = []+ }++isToken :: String -> Context -> Bool+isToken x ctx = elem x $ ctxTokens ctx++setLocals :: Context -> [(String,Base)] -> Context+setLocals ctx xs = ctx { ctxLocals = xs }++lookupCtx :: String -> Context -> Err Type+lookupCtx x ctx+ | isToken x ctx = return $ FunT [BaseT "String"] (BaseT x)+ | otherwise = do+ case lookup x $ ctxLocals ctx of+ Just b -> return $ FunT [] b+ Nothing -> do+ case Map.lookup x $ ctxLabels ctx of+ Nothing -> throwError $ "Undefined symbol '" ++ x ++ "'."+ Just t -> return $ wpThing t
src/BNFC/Utils.hs view
@@ -19,10 +19,18 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-} module BNFC.Utils- ( when, unless, unlessNull+ ( ModuleName+ , when, unless, unlessNull, unlessNull'+ , applyWhen, applyUnless+ , for+ , curry3, uncurry3+ , mapHead+ , duplicatesOn , (+++), (++++), (+-+), (+.+)+ , pad, table , mkName, mkNames, NameStyle(..) , lowerCase, upperCase, mixedCase, camelCase, snakeCase , replace, prParenth@@ -35,18 +43,22 @@ import Control.DeepSeq (rnf) import Data.Char-import Data.Functor ((<$>)) import Data.List (intercalate)-import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..)) import Data.Time -import Data.Semigroup (Semigroup(..))+import qualified Data.Foldable as Fold+import qualified Data.Map as Map+import qualified Data.Set as Set import System.IO (IOMode(ReadMode),hClose,hGetContents,openFile) import System.IO.Error (tryIOError) import BNFC.PrettyPrint hiding ((<>)) +-- | The name of a module, e.g. "Foo.Abs", "Foo.Print" etc.+type ModuleName = String+ -- * Control flow. -- The following Monoid instance conflicts with Monoid a => Monoid (IO a)@@ -72,12 +84,44 @@ unless False m = m unless True _ = mempty +-- | 'when' for the monoid of endofunctions 'a -> a'.+applyWhen :: Bool -> (a -> a) -> a -> a+applyWhen True f = f+applyWhen False _ = id++-- | 'unless' for the monoid of endofunctions 'a -> a'.+applyUnless :: Bool -> (a -> a) -> a -> a+applyUnless False f = f+applyUnless True _ = id+ -- | Invoke continuation for non-empty list.-unlessNull :: Monoid m => [a] -> (a -> [a] -> m) -> m+unlessNull :: Monoid m => [a] -> ([a] -> m) -> m unlessNull l k = case l of+ [] -> mempty+ as -> k as++-- | Invoke continuation for non-empty list.+unlessNull' :: Monoid m => [a] -> (a -> [a] -> m) -> m+unlessNull' l k = case l of [] -> mempty (a:as) -> k a as +-- | Non-monadic 'forM'.+for :: [a] -> (a -> b) -> [b]+for = flip map++-- * Tuple utilities.++-- From https://hackage.haskell.org/package/extra-1.6.18/docs/Data-Tuple-Extra.html++-- | Converts an uncurried function to a curried function.+curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 f a b c = f (a,b,c)++-- | Converts a curried function to a function on a triple.+uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)+uncurry3 f ~(a,b,c) = f a b c+ -- * String operations for printing. infixr 5 +++, ++++, +-+, +.+@@ -102,14 +146,60 @@ prParenth :: String -> String prParenth s = if s == "" then "" else "(" ++ s ++ ")" +-- | Pad a string on the right by spaces to reach the desired length.+pad :: Int -> String -> String+pad n s = s ++ drop (length s) (replicate n ' ')++-- | Make a list of rows with left-aligned columns from a matrix.+table :: String -> [[String]] -> [String]+table sep m = map (intercalate sep . zipWith pad widths) m+ where+ -- Column widths.+ widths :: [Int]+ widths = columns maximum $ map (map length) m+ -- Aggregate columns (works even for a ragged matrix with rows of different length).+ columns :: ([a] -> b) -> [[a]] -> [b]+ columns f rows =+ -- Take the values of the first column+ case concat (map (take 1) rows) of+ -- Matrix was empty:+ [] -> []+ -- Matrix was non-empty:+ col -> f col : columns f (map (drop 1) rows)+ -- * List utilities +-- | Give a telling name to the electric monkey.+singleton :: a -> [a]+singleton = (:[])++-- | Apply a function to the head of a list.+mapHead :: (a -> a) -> [a] -> [a]+mapHead f = \case+ [] -> []+ a:as -> f a : as+ -- | 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]++-- | Returns all elements whose normal form appears more than once.+--+-- E.g. @duplicatesOn abs [5,-5,1] = [-5,5]@.+duplicatesOn :: (Foldable t, Ord a, Ord b) => (a -> b) -> t a -> [a]+duplicatesOn nf+ -- Flatten.+ = concat+ -- Keep groups of size >= 2.+ . filter ((2 <=) . length)+ -- Turn into a list of lists: elements grouped by their normal form.+ . map Set.toList+ . Map.elems+ -- Partition elements by their normal form.+ . Fold.foldl (\ m a -> Map.insertWith Set.union (nf a) (Set.singleton a) m) Map.empty -- * Time utilities
− src/BNFC/WarningM.hs
@@ -1,26 +0,0 @@-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 (_,warnings) = run c in not (null warnings)---- Output a warning-warn :: String -> WithWarnings ()-warn s = W.tell [s]
− src/ErrM.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}--- BNF Converter: Error Monad--- Copyright (C) 2004 Author: Aarne Ranta---- This file comes with NO WARRANTY and may be used FOR ANY PURPOSE.-module ErrM where---- the Error monad: like Maybe type with error msgs--import Control.Monad (MonadPlus(..), liftM)-#if __GLASGOW_HASKELL__ < 710-import Control.Applicative (Applicative(..), Alternative(..))-#else-import Control.Applicative (Alternative(..))-#endif--data Err a = Ok a | Bad String- deriving (Read, Show, Eq, Ord)--instance Monad Err where- return = Ok- Ok a >>= f = f a- Bad s >>= _ = Bad s-#if __GLASGOW_HASKELL__ < 808- fail = Bad-#else--instance MonadFail Err where- fail = Bad-#endif--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
+ src/LexBNF.hs view
@@ -0,0 +1,8786 @@+{-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-}+{-# LANGUAGE CPP #-}+{-# LINE 3 "LexBNF.x" #-}+{-# OPTIONS -fno-warn-incomplete-patterns #-}+{-# OPTIONS_GHC -w #-}+module LexBNF where++import qualified Data.Bits+import Data.Word (Word8)+import Data.Char (ord)+#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+alex_tab_size :: Int+alex_tab_size = 8+alex_base :: Array Int Int+alex_base = listArray (0 :: Int, 63)+ [ -8+ , 73+ , -55+ , -32+ , 201+ , 412+ , 45+ , 540+ , 668+ , 796+ , 924+ , 1052+ , 1180+ , 1293+ , 0+ , 1421+ , 0+ , 1534+ , 0+ , 1647+ , 0+ , 267+ , 0+ , 1712+ , 0+ , 1777+ , 2033+ , 1969+ , 0+ , 0+ , 2082+ , 2338+ , 2274+ , 0+ , 2491+ , 2747+ , 2497+ , 2683+ , 0+ , 0+ , 2748+ , -37+ , 71+ , 114+ , 2994+ , 2877+ , 3122+ , 3314+ , 3250+ , 0+ , 3496+ , 0+ , 120+ , -36+ , -35+ , 0+ , -33+ , 3713+ , 3812+ , 0+ , 0+ , 126+ , 2489+ , 140+ ]++alex_table :: Array Int Int+alex_table = listArray (0 :: Int, 4067)+ [ 0+ , 52+ , 52+ , 52+ , 52+ , 52+ , 55+ , 60+ , 43+ , 50+ , 5+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 0+ , 0+ , 0+ , 52+ , 2+ , 44+ , 0+ , 0+ , 0+ , 0+ , 34+ , 55+ , 55+ , 55+ , 55+ , 55+ , 53+ , 55+ , 0+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 56+ , 55+ , 0+ , 55+ , 0+ , 55+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 55+ , 3+ , 55+ , 0+ , 55+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 54+ , 55+ , 55+ , 1+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 52+ , 52+ , 52+ , 52+ , 52+ , 0+ , 0+ , 0+ , 3+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 3+ , 0+ , 0+ , 0+ , 0+ , 52+ , 0+ , 0+ , 3+ , 0+ , 0+ , 0+ , 3+ , 0+ , 3+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 42+ , 0+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 61+ , 0+ , 0+ , 0+ , 46+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 63+ , 51+ , 0+ , 0+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 26+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 27+ , 10+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 21+ , 15+ , 14+ , 14+ , 14+ , 13+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 47+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 1+ , 27+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 26+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 27+ , 10+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 21+ , 15+ , 14+ , 14+ , 14+ , 13+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 4+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 35+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 31+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 26+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 28+ , 8+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 9+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 21+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 10+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 20+ , 23+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 25+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 32+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 37+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 40+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 44+ , 0+ , 0+ , 0+ , 0+ , 44+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 62+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 6+ , 0+ , 0+ , 0+ , 0+ , 0+ , 44+ , 41+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 44+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 44+ , 0+ , 0+ , 0+ , 44+ , 0+ , 44+ , 0+ , 0+ , 0+ , 0+ , 0+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 31+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 33+ , 32+ , 9+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 22+ , 23+ , 12+ , 16+ , 16+ , 16+ , 17+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 48+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 59+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 0+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 36+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 35+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 38+ , 37+ , 8+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 24+ , 25+ , 11+ , 18+ , 18+ , 18+ , 19+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 47+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 49+ , 48+ , 4+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 39+ , 40+ , 7+ , 29+ , 29+ , 29+ , 30+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 58+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 0+ , 0+ , 0+ , 0+ , 57+ , 0+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 57+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 58+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 0+ , 0+ , 0+ , 0+ , 58+ , 46+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 58+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 45+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ , 0+ ]++alex_check :: Array Int Int+alex_check = listArray (0 :: Int, 4067)+ [ -1+ , 9+ , 10+ , 11+ , 12+ , 13+ , 61+ , 39+ , 45+ , 45+ , 45+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , -1+ , -1+ , -1+ , 32+ , 58+ , 34+ , -1+ , -1+ , -1+ , -1+ , 39+ , 40+ , 41+ , 42+ , 43+ , 44+ , 45+ , 46+ , -1+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 58+ , 59+ , -1+ , 61+ , -1+ , 63+ , -1+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , 91+ , 39+ , 93+ , -1+ , 95+ , -1+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , 123+ , 124+ , 125+ , 45+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 9+ , 10+ , 11+ , 12+ , 13+ , -1+ , -1+ , -1+ , 92+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 102+ , -1+ , -1+ , -1+ , -1+ , 32+ , -1+ , -1+ , 110+ , -1+ , -1+ , -1+ , 114+ , -1+ , 116+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 46+ , -1+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , -1+ , -1+ , -1+ , 195+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 125+ , -1+ , -1+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 45+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 0+ , 1+ , 2+ , 3+ , 4+ , 5+ , 6+ , 7+ , 8+ , 9+ , 10+ , 11+ , 12+ , 13+ , 14+ , 15+ , 16+ , 17+ , 18+ , 19+ , 20+ , 21+ , 22+ , 23+ , 24+ , 25+ , 26+ , 27+ , 28+ , 29+ , 30+ , 31+ , 32+ , 33+ , 34+ , 35+ , 36+ , 37+ , 38+ , 39+ , 40+ , 41+ , 42+ , 43+ , 44+ , 45+ , 46+ , 47+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 58+ , 59+ , 60+ , 61+ , 62+ , 63+ , 64+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , 91+ , 92+ , 93+ , 94+ , 95+ , 96+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , 123+ , 124+ , 125+ , 126+ , 127+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 0+ , 1+ , 2+ , 3+ , 4+ , 5+ , 6+ , 7+ , 8+ , 9+ , 10+ , 11+ , 12+ , 13+ , 14+ , 15+ , 16+ , 17+ , 18+ , 19+ , 20+ , 21+ , 22+ , 23+ , 24+ , 25+ , 26+ , 27+ , 28+ , 29+ , 30+ , 31+ , 32+ , 33+ , 34+ , 35+ , 36+ , 37+ , 38+ , 39+ , 40+ , 41+ , 42+ , 43+ , 44+ , 45+ , 46+ , 47+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 58+ , 59+ , 60+ , 61+ , 62+ , 63+ , 64+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , 91+ , 92+ , 93+ , 94+ , 95+ , 96+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , 123+ , 124+ , 125+ , 126+ , 127+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 39+ , 34+ , -1+ , -1+ , -1+ , -1+ , 39+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 92+ , -1+ , -1+ , -1+ , -1+ , -1+ , 92+ , 101+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 102+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 110+ , -1+ , -1+ , -1+ , 114+ , -1+ , 116+ , -1+ , -1+ , -1+ , -1+ , -1+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 0+ , 1+ , 2+ , 3+ , 4+ , 5+ , 6+ , 7+ , 8+ , 9+ , 10+ , 11+ , 12+ , 13+ , 14+ , 15+ , 16+ , 17+ , 18+ , 19+ , 20+ , 21+ , 22+ , 23+ , 24+ , 25+ , 26+ , 27+ , 28+ , 29+ , 30+ , 31+ , 32+ , 33+ , 34+ , 35+ , 36+ , 37+ , 38+ , 39+ , 40+ , 41+ , 42+ , 43+ , 44+ , 45+ , 46+ , 47+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 58+ , 59+ , 60+ , 61+ , 62+ , 63+ , 64+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , 91+ , 92+ , 93+ , 94+ , 95+ , 96+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , 123+ , 124+ , 125+ , 126+ , 127+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 10+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 34+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , -1+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 92+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , -1+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , -1+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 0+ , 1+ , 2+ , 3+ , 4+ , 5+ , 6+ , 7+ , 8+ , 9+ , 10+ , 11+ , 12+ , 13+ , 14+ , 15+ , 16+ , 17+ , 18+ , 19+ , 20+ , 21+ , 22+ , 23+ , 24+ , 25+ , 26+ , 27+ , 28+ , 29+ , 30+ , 31+ , 32+ , 33+ , 34+ , 35+ , 36+ , 37+ , 38+ , 39+ , 40+ , 41+ , 42+ , 43+ , 44+ , 45+ , 46+ , 47+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , 58+ , 59+ , 60+ , 61+ , 62+ , 63+ , 64+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , 91+ , 92+ , 93+ , 94+ , 95+ , 96+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , 123+ , 124+ , 125+ , 126+ , 127+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 10+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 128+ , 129+ , 130+ , 131+ , 132+ , 133+ , 134+ , 135+ , 136+ , 137+ , 138+ , 139+ , 140+ , 141+ , 142+ , 143+ , 144+ , 145+ , 146+ , 147+ , 148+ , 149+ , 150+ , 151+ , 152+ , 153+ , 154+ , 155+ , 156+ , 157+ , 158+ , 159+ , 160+ , 161+ , 162+ , 163+ , 164+ , 165+ , 166+ , 167+ , 168+ , 169+ , 170+ , 171+ , 172+ , 173+ , 174+ , 175+ , 176+ , 177+ , 178+ , 179+ , 180+ , 181+ , 182+ , 183+ , 184+ , 185+ , 186+ , 187+ , 188+ , 189+ , 190+ , 191+ , 192+ , 193+ , 194+ , 195+ , 196+ , 197+ , 198+ , 199+ , 200+ , 201+ , 202+ , 203+ , 204+ , 205+ , 206+ , 207+ , 208+ , 209+ , 210+ , 211+ , 212+ , 213+ , 214+ , 215+ , 216+ , 217+ , 218+ , 219+ , 220+ , 221+ , 222+ , 223+ , 224+ , 225+ , 226+ , 227+ , 228+ , 229+ , 230+ , 231+ , 232+ , 233+ , 234+ , 235+ , 236+ , 237+ , 238+ , 239+ , 240+ , 241+ , 242+ , 243+ , 244+ , 245+ , 246+ , 247+ , 248+ , 249+ , 250+ , 251+ , 252+ , 253+ , 254+ , 255+ , 39+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , -1+ , -1+ , -1+ , -1+ , 95+ , -1+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 39+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 48+ , 49+ , 50+ , 51+ , 52+ , 53+ , 54+ , 55+ , 56+ , 57+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 65+ , 66+ , 67+ , 68+ , 69+ , 70+ , 71+ , 72+ , 73+ , 74+ , 75+ , 76+ , 77+ , 78+ , 79+ , 80+ , 81+ , 82+ , 83+ , 84+ , 85+ , 86+ , 87+ , 88+ , 89+ , 90+ , -1+ , -1+ , -1+ , -1+ , 95+ , 195+ , 97+ , 98+ , 99+ , 100+ , 101+ , 102+ , 103+ , 104+ , 105+ , 106+ , 107+ , 108+ , 109+ , 110+ , 111+ , 112+ , 113+ , 114+ , 115+ , 116+ , 117+ , 118+ , 119+ , 120+ , 121+ , 122+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 195+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ ]++alex_deflt :: Array Int Int+alex_deflt = listArray (0 :: Int, 63)+ [ -1+ , 5+ , -1+ , -1+ , -1+ , 5+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , 20+ , 20+ , -1+ , 22+ , 22+ , 24+ , 24+ , 28+ , 28+ , 33+ , 33+ , 38+ , 38+ , 5+ , 5+ , 5+ , 39+ , 39+ , 3+ , 3+ , 3+ , 3+ , 44+ , -1+ , 44+ , 44+ , 49+ , 49+ , -1+ , -1+ , -1+ , 44+ , -1+ , -1+ , 50+ , 50+ , 50+ , 50+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ , -1+ ]++alex_accept = listArray (0 :: Int, 63)+ [ AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccNone+ , AlexAccSkip+ , AlexAccSkip+ , AlexAccSkip+ , AlexAcc 10+ , AlexAcc 9+ , AlexAcc 8+ , AlexAcc 7+ , AlexAcc 6+ , AlexAcc 5+ , AlexAcc 4+ , AlexAcc 3+ , AlexAcc 2+ , AlexAcc 1+ , AlexAcc 0+ ]++alex_actions = array (0 :: Int, 11)+ [ (10,alex_action_3)+ , (9,alex_action_3)+ , (8,alex_action_3)+ , (7,alex_action_3)+ , (6,alex_action_4)+ , (5,alex_action_5)+ , (4,alex_action_6)+ , (3,alex_action_7)+ , (2,alex_action_8)+ , (1,alex_action_9)+ , (0,alex_action_9)+ ]++{-# LINE 49 "LexBNF.x" #-}+tok :: (Posn -> String -> Token) -> (Posn -> String -> Token)+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+ | T_Identifier !String++ deriving (Eq,Show,Ord)++data Token =+ PT Posn Tok+ | Err Posn+ deriving (Eq,Show,Ord)++printPosn :: Posn -> String+printPosn (Pn _ l c) = "line " ++ show l ++ ", column " ++ show c++tokenPos :: [Token] -> String+tokenPos (t:_) = printPosn (tokenPosn t)+tokenPos [] = "end of file"++tokenPosn :: Token -> Posn+tokenPosn (PT p _) = p+tokenPosn (Err p) = p++tokenLineCol :: Token -> (Int, Int)+tokenLineCol = posLineCol . tokenPosn++posLineCol :: Posn -> (Int, Int)+posLineCol (Pn _ l c) = (l,c)++mkPosToken :: Token -> ((Int, Int), String)+mkPosToken t@(PT p _) = (posLineCol p, tokenText t)++tokenText :: Token -> String+tokenText t = case t of+ PT _ (TS s _) -> s+ PT _ (TL s) -> show s+ PT _ (TI s) -> s+ PT _ (TV s) -> s+ PT _ (TD s) -> s+ PT _ (TC s) -> s+ Err _ -> "#error"+ PT _ (T_Identifier s) -> s++prToken :: Token -> String+prToken t = tokenText t++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 :: BTree+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 = 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+ '\\':'r':cs -> '\r' : unesc cs+ '\\':'f':cs -> '\f' : 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 (T_Identifier . share) s))+alex_action_5 = tok (\p s -> PT p (eitherResIdent (TV . share) s))+alex_action_6 = tok (\p s -> PT p (TL $ share $ unescapeInitTail s))+alex_action_7 = tok (\p s -> PT p (TC $ share s))+alex_action_8 = tok (\p s -> PT p (TI $ share s))+alex_action_9 = tok (\p s -> PT p (TD $ share s))++{-# 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++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++alexIndexInt16OffAddr arr off = arr ! off+++++++++++++++++++++alexIndexInt32OffAddr arr off = arr ! off++++++++++++quickIndex arr i = arr ! i+++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+ = AlexEOF+ | AlexError !AlexInput+ | AlexSkip !AlexInput !Int+ | AlexToken !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input__ (sc)+ = alexScanUser undefined input__ (sc)++alexScanUser user__ input__ (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 (alex_actions ! 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` (s)))+ in+ new_acc `seq`+ case alexGetByte input__ of+ Nothing -> (new_acc, input__)+ Just (c, new_input) ->++++ case fromIntegral c of { (ord_c) ->+ let+ base = alexIndexInt32OffAddr alex_base s+ 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 (AlexAccNone) = last_acc+ check_accs (AlexAcc a ) = AlexLastAcc a input__ (len)+ check_accs (AlexAccSkip) = AlexLastSkip input__ (len)++++++++++++++data AlexLastAcc+ = AlexNone+ | AlexLastAcc !Int !AlexInput !Int+ | AlexLastSkip !AlexInput !Int++data AlexAcc user+ = AlexAccNone+ | AlexAcc Int+ | AlexAccSkip+++++++++++++++++++++++++++++
src/LexBNF.x view
@@ -5,8 +5,6 @@ {-# OPTIONS_GHC -w #-} module LexBNF where -- import qualified Data.Bits import Data.Word (Word8) import Data.Char (ord)@@ -24,12 +22,18 @@ \: | \; | \, | \. | \: \: \= | \[ | \] | \_ | \( | \) | \= | \| | \- | \* | \+ | \? | \{ | \} :--"--" [.]* ; -- Toss single line comments-"{-" ([$u # \-] | \-+ [$u # [\- \}]])* ("-")+ "}" ; +-- Line comments+"--" [.]* ;++-- Block comments+\{ \- [$u # \-]* \- ([$u # [\- \}]] [$u # \-]* \- | \-)* \} ;+ $white+ ; @rsyms { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }+$l (\_ | ($d | $l)) *+ { tok (\p s -> PT p (eitherResIdent (T_Identifier . share) s)) } $l $i* { tok (\p s -> PT p (eitherResIdent (TV . share) s)) }@@ -57,6 +61,7 @@ | TV !String -- identifiers | TD !String -- double precision float literals | TC !String -- character literals+ | T_Identifier !String deriving (Eq,Show,Ord) @@ -83,10 +88,10 @@ posLineCol (Pn _ l c) = (l,c) mkPosToken :: Token -> ((Int, Int), String)-mkPosToken t@(PT p _) = (posLineCol p, prToken t)+mkPosToken t@(PT p _) = (posLineCol p, tokenText t) -prToken :: Token -> String-prToken t = case t of+tokenText :: Token -> String+tokenText t = case t of PT _ (TS s _) -> s PT _ (TL s) -> show s PT _ (TI s) -> s@@ -94,7 +99,10 @@ PT _ (TD s) -> s PT _ (TC s) -> s Err _ -> "#error"+ PT _ (T_Identifier s) -> s +prToken :: Token -> String+prToken t = tokenText t data BTree = N | B String Tok BTree BTree deriving (Show) @@ -108,11 +116,12 @@ resWords :: BTree 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)+ where b s n = let bs = s+ in B bs (TS bs n) unescapeInitTail :: String -> String-unescapeInitTail = id . unesc . tail . id where+unescapeInitTail = id . unesc . tail . id+ where unesc s = case s of '\\':c:cs | elem c ['\"', '\\', '\''] -> c : unesc cs '\\':'n':cs -> '\n' : unesc cs@@ -160,7 +169,7 @@ alexGetByte :: AlexInput -> Maybe (Byte,AlexInput) alexGetByte (p, c, (b:bs), s) = Just (b, (p, c, bs, s)) alexGetByte (p, _, [], s) =- case s of+ case s of [] -> Nothing (c:s) -> let p' = alexMove p c
src/Main.hs view
@@ -61,13 +61,22 @@ main :: IO () main = do args <- getArgs- case parseMode args of+ let (mode, warnings) = parseMode args + -- Print command-line argument warnings (if any).+ mapM_ (hPutStrLn stderr) warnings++ case mode of+ UsageError e -> printUsageErrors [e] Help -> putStrLn help >> exitSuccess Version -> putStrLn (showVersion version) >> exitSuccess Target options file+ | target options == TargetCheck ->+ readFile file+ >>= parseCFP options TargetCheck+ >> return () | target options == TargetProfile -> readFile file >>= parseCFP options TargetProfile@@ -90,3 +99,4 @@ TargetOCaml -> makeOCaml TargetProfile -> error "impossible" TargetPygments -> makePygments+ TargetCheck -> error "impossible"
+ src/ParBNF.hs view
@@ -0,0 +1,3273 @@+{-# OPTIONS_GHC -w #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-}+module ParBNF where+import qualified AbsBNF+import LexBNF+import qualified Data.Array as Happy_Data_Array+import qualified Data.Bits as Bits+import Control.Applicative(Applicative(..))+import Control.Monad (ap)++-- parser produced by Happy Version 1.20.0++data HappyAbsSyn + = HappyTerminal (Token)+ | HappyErrorToken Prelude.Int+ | HappyAbsSyn36 (String)+ | HappyAbsSyn37 (Integer)+ | HappyAbsSyn38 (Char)+ | HappyAbsSyn39 (Double)+ | HappyAbsSyn40 (AbsBNF.Identifier)+ | HappyAbsSyn41 (AbsBNF.LGrammar)+ | HappyAbsSyn42 (AbsBNF.LDef)+ | HappyAbsSyn43 ([AbsBNF.LDef])+ | HappyAbsSyn44 ([AbsBNF.Identifier])+ | HappyAbsSyn45 (AbsBNF.Grammar)+ | HappyAbsSyn46 ([AbsBNF.Def])+ | HappyAbsSyn47 (AbsBNF.Def)+ | HappyAbsSyn48 (AbsBNF.Item)+ | HappyAbsSyn49 ([AbsBNF.Item])+ | HappyAbsSyn50 (AbsBNF.Cat)+ | HappyAbsSyn51 (AbsBNF.Label)+ | HappyAbsSyn52 (AbsBNF.LabelId)+ | HappyAbsSyn53 (AbsBNF.ProfItem)+ | HappyAbsSyn54 (AbsBNF.IntList)+ | HappyAbsSyn55 ([Integer])+ | HappyAbsSyn56 ([AbsBNF.IntList])+ | HappyAbsSyn57 ([AbsBNF.ProfItem])+ | HappyAbsSyn58 (AbsBNF.Arg)+ | HappyAbsSyn59 ([AbsBNF.Arg])+ | HappyAbsSyn60 (AbsBNF.Separation)+ | HappyAbsSyn61 ([String])+ | HappyAbsSyn62 (AbsBNF.Exp)+ | HappyAbsSyn65 ([AbsBNF.Exp])+ | HappyAbsSyn67 (AbsBNF.RHS)+ | HappyAbsSyn68 ([AbsBNF.RHS])+ | HappyAbsSyn69 (AbsBNF.MinimumSize)+ | HappyAbsSyn70 (AbsBNF.Reg)++{- to allow type-synonyms as our monads (likely+ - with explicitly-specified bind and return)+ - in Haskell98, it seems that with+ - /type M a = .../, then /(HappyReduction M)/+ - is not allowed. But Happy is a+ - code-generator that can just substitute it.+type HappyReduction m = + Prelude.Int + -> (Token)+ -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)+ -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> m HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> m HappyAbsSyn+-}++action_0,+ action_1,+ action_2,+ action_3,+ action_4,+ action_5,+ action_6,+ action_7,+ action_8,+ action_9,+ action_10,+ action_11,+ action_12,+ action_13,+ action_14,+ action_15,+ action_16,+ action_17,+ action_18,+ action_19,+ action_20,+ action_21,+ action_22,+ action_23,+ action_24,+ action_25,+ action_26,+ action_27,+ action_28,+ action_29,+ action_30,+ action_31,+ action_32,+ action_33,+ action_34,+ action_35,+ action_36,+ action_37,+ action_38,+ action_39,+ action_40,+ action_41,+ action_42,+ action_43,+ action_44,+ action_45,+ action_46,+ action_47,+ action_48,+ action_49,+ action_50,+ action_51,+ action_52,+ action_53,+ action_54,+ action_55,+ action_56,+ action_57,+ action_58,+ action_59,+ action_60,+ action_61,+ action_62,+ action_63,+ action_64,+ action_65,+ action_66,+ action_67,+ action_68,+ action_69,+ action_70,+ action_71,+ action_72,+ action_73,+ action_74,+ action_75,+ action_76,+ action_77,+ action_78,+ action_79,+ action_80,+ action_81,+ action_82,+ action_83,+ action_84,+ action_85,+ action_86,+ action_87,+ action_88,+ action_89,+ action_90,+ action_91,+ action_92,+ action_93,+ action_94,+ action_95,+ action_96,+ action_97,+ action_98,+ action_99,+ action_100,+ action_101,+ action_102,+ action_103,+ action_104,+ action_105,+ action_106,+ action_107,+ action_108,+ action_109,+ action_110,+ action_111,+ action_112,+ action_113,+ action_114,+ action_115,+ action_116,+ action_117,+ action_118,+ action_119,+ action_120,+ action_121,+ action_122,+ action_123,+ action_124,+ action_125,+ action_126,+ action_127,+ action_128,+ action_129,+ action_130,+ action_131,+ action_132,+ action_133,+ action_134,+ action_135,+ action_136,+ action_137,+ action_138,+ action_139,+ action_140,+ action_141,+ action_142,+ action_143,+ action_144,+ action_145,+ action_146,+ action_147,+ action_148,+ action_149,+ action_150,+ action_151,+ action_152,+ action_153,+ action_154,+ action_155,+ action_156,+ action_157,+ action_158,+ action_159,+ action_160,+ action_161,+ action_162,+ action_163,+ action_164,+ action_165,+ action_166,+ action_167,+ action_168,+ action_169,+ action_170,+ action_171,+ action_172,+ action_173,+ action_174,+ action_175,+ action_176,+ action_177,+ action_178,+ action_179,+ action_180,+ action_181,+ action_182,+ action_183,+ action_184,+ action_185,+ action_186,+ action_187,+ action_188,+ action_189,+ action_190,+ action_191,+ action_192,+ action_193,+ action_194,+ action_195,+ action_196,+ action_197,+ action_198,+ action_199,+ action_200,+ action_201,+ action_202,+ action_203,+ action_204,+ action_205,+ action_206,+ action_207,+ action_208,+ action_209,+ action_210,+ action_211,+ action_212,+ action_213,+ action_214,+ action_215,+ action_216,+ action_217,+ action_218,+ action_219,+ action_220,+ action_221,+ action_222,+ action_223,+ action_224,+ action_225,+ action_226,+ action_227,+ action_228,+ action_229,+ action_230,+ action_231,+ action_232,+ action_233,+ action_234,+ action_235,+ action_236,+ action_237,+ action_238,+ action_239,+ action_240,+ action_241,+ action_242,+ action_243,+ action_244,+ action_245,+ action_246,+ action_247,+ action_248,+ action_249,+ action_250,+ action_251,+ action_252,+ action_253,+ action_254 :: () => Prelude.Int -> ({-HappyReduction (Either String) = -}+ Prelude.Int + -> (Token)+ -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either String) HappyAbsSyn)+ -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either String) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Either String) HappyAbsSyn)++happyReduce_33,+ happyReduce_34,+ happyReduce_35,+ happyReduce_36,+ happyReduce_37,+ happyReduce_38,+ happyReduce_39,+ happyReduce_40,+ happyReduce_41,+ happyReduce_42,+ happyReduce_43,+ happyReduce_44,+ happyReduce_45,+ happyReduce_46,+ happyReduce_47,+ happyReduce_48,+ happyReduce_49,+ happyReduce_50,+ happyReduce_51,+ happyReduce_52,+ happyReduce_53,+ happyReduce_54,+ happyReduce_55,+ happyReduce_56,+ happyReduce_57,+ happyReduce_58,+ happyReduce_59,+ happyReduce_60,+ happyReduce_61,+ happyReduce_62,+ happyReduce_63,+ happyReduce_64,+ happyReduce_65,+ happyReduce_66,+ happyReduce_67,+ happyReduce_68,+ happyReduce_69,+ happyReduce_70,+ happyReduce_71,+ happyReduce_72,+ happyReduce_73,+ happyReduce_74,+ happyReduce_75,+ happyReduce_76,+ happyReduce_77,+ happyReduce_78,+ happyReduce_79,+ happyReduce_80,+ happyReduce_81,+ happyReduce_82,+ happyReduce_83,+ happyReduce_84,+ happyReduce_85,+ happyReduce_86,+ happyReduce_87,+ happyReduce_88,+ happyReduce_89,+ happyReduce_90,+ happyReduce_91,+ happyReduce_92,+ happyReduce_93,+ happyReduce_94,+ happyReduce_95,+ happyReduce_96,+ happyReduce_97,+ happyReduce_98,+ happyReduce_99,+ happyReduce_100,+ happyReduce_101,+ happyReduce_102,+ happyReduce_103,+ happyReduce_104,+ happyReduce_105,+ happyReduce_106,+ happyReduce_107,+ happyReduce_108,+ happyReduce_109,+ happyReduce_110,+ happyReduce_111,+ happyReduce_112,+ happyReduce_113,+ happyReduce_114,+ happyReduce_115,+ happyReduce_116,+ happyReduce_117,+ happyReduce_118,+ happyReduce_119,+ happyReduce_120,+ happyReduce_121,+ happyReduce_122,+ happyReduce_123,+ happyReduce_124,+ happyReduce_125,+ happyReduce_126,+ happyReduce_127,+ happyReduce_128,+ happyReduce_129,+ happyReduce_130,+ happyReduce_131,+ happyReduce_132,+ happyReduce_133,+ happyReduce_134,+ happyReduce_135,+ happyReduce_136,+ happyReduce_137,+ happyReduce_138,+ happyReduce_139,+ happyReduce_140,+ happyReduce_141 :: () => ({-HappyReduction (Either String) = -}+ Prelude.Int + -> (Token)+ -> HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either String) HappyAbsSyn)+ -> [HappyState (Token) (HappyStk HappyAbsSyn -> [(Token)] -> (Either String) HappyAbsSyn)] + -> HappyStk HappyAbsSyn + -> [(Token)] -> (Either String) HappyAbsSyn)++happyExpList :: Happy_Data_Array.Array Prelude.Int Prelude.Int+happyExpList = Happy_Data_Array.listArray (0,638) ([0,0,0,0,512,24228,9955,32,0,0,0,0,20481,29103,4115,0,0,0,0,128,55209,2488,8,0,0,0,0,0,0,1024,0,0,0,0,16416,13802,110,2,0,0,0,4096,62752,14106,256,0,0,0,0,32776,36218,32795,0,0,0,0,0,64,0,68,0,0,0,0,8192,0,8704,0,0,0,0,0,16,0,16,0,0,0,32768,10240,0,2048,0,0,0,0,64,20,0,4,0,0,0,8192,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,16,0,0,0,0,16384,0,0,0,0,0,0,512,0,0,0,0,0,0,0,0,0,4096,0,0,0,0,0,0,0,8,0,0,0,0,0,20480,0,0,0,0,0,0,0,8192,0,0,0,0,4096,256,0,496,0,0,0,0,32776,0,63488,0,0,0,0,1024,64,0,124,0,0,0,0,8194,0,15872,0,0,0,0,256,16,0,31,0,0,0,0,2048,0,2176,0,0,0,0,0,4,16384,4,0,0,0,0,0,256,0,0,0,0,0,16,25865,17024,0,0,0,0,2048,33920,16434,33,0,0,0,0,16388,6466,4256,0,0,0,0,512,41248,20492,8,0,0,0,0,0,0,256,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,384,1,0,0,0,0,0,4096,2304,32869,66,0,0,0,0,0,0,2048,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4096,0,0,0,0,0,0,0,0,0,0,0,0,16388,6466,4256,0,0,0,0,6144,16,0,0,0,0,0,0,32,0,0,0,0,0,0,128,10312,5123,2,0,0,0,0,0,0,16,0,0,0,0,1024,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16,0,17,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8,0,0,0,0,0,0,0,0,0,0,0,0,128,0,128,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32776,0,63488,0,0,0,0,0,0,0,0,0,0,0,0,8194,0,15872,0,0,0,0,256,16,0,31,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8192,512,0,992,0,0,0,0,256,0,0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,512,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4,0,0,0,0,0,0,512,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2048,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16384,0,0,0,0,0,0,8192,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32768,0,0,0,0,0,0,0,4096,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16,5,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8192,0,0,0,0,0,0,0,0,0,1024,0,0,0,0,0,0,8192,0,0,0,0,0,0,0,256,0,0,0,0,32768,0,32768,0,0,0,0,0,0,0,64,0,0,0,0,40962,0,8192,0,0,0,0,0,0,1152,1,0,0,0,0,0,0,1,0,0,0,0,0,0,0,4,0,0,0,0,0,256,0,0,0,0,0,0,32768,0,0,0,0,0,0,0,0,128,0,0,0,0,0,0,0,0,0,0,0,0,4,0,0,0,0,0,0,20993,29103,4099,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,512,0,0,0,0,0,0,0,0,0,0,0,0,0,0,128,0,0,0,0,0,0,0,8,0,0,0,0,0,0,0,0,0,0,0,0,0,32768,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32832,27604,1244,4,0,0,0,0,0,0,512,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,128,55208,440,8,0,0,0,16384,54400,56427,1028,0,0,0,0,0,0,0,2,0,0,0,0,0,0,0,0,0,0,0,36872,36218,32795,0,0,0,0,1024,16960,40985,16,0,0,0,0,8192,0,8192,0,0,0,0,0,16,0,16,0,0,0,0,128,0,0,0,0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,4096,0,0,0,0,0,0,0,0,0,0,0,0,256,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,256,0,0,0,0,0,0,0,8,0,0,0,0,0,0,64,0,0,0,0,0,0,16384,0,0,0,0,0,256,0,256,0,0,0,0,8,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8448,0,0,0,0,0,0,0,0,0,0,0,0,0,0,2049,0,0,0,0,0,0,0,0,32768,0,0,0,0,0,1024,0,0,0,0,0,0,0,1,0,0,0,0,0,0,128,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,64,0,0,0,0,32,2,57344,3,0,0,0,4096,256,0,496,0,0,0,0,0,0,0,0,0,0,0,0,128,0,0,0,0,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,4096,0,0,0,0,0,0,0,4,16384,4,0,0,0,0,0,0,0,0,0,0,0,16,25865,17024,0,0,0,0,2048,33920,16434,33,0,0,0,0,8240,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32,0,0,0,0,0,4,0,0,0,0,0,8192,0,0,4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8192,0,0,0,0,0,0,32768,18432,808,532,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,128,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,128,0,0,0,0,0,0,0,0,4096,0,0,0,0,0,128,0,128,0,0,0,0,0,0,0,0,0,0,0,512,41248,20492,8,0,0,0,0,4096,0,4352,0,0,0,0,0,0,32768,0,0,0,0,0,0,0,64,0,0,0,0,0,0,2048,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,8,0,0,0,0,4096,0,0,0,0,0,0,0,0,2560,0,0,0,0,0,16388,0,31744,0,0,0,0,0,32,0,34,0,0,0,0,2,0,0,0,0,0,0,2048,0,0,0,0,0,0,0,1024,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32,0,0,0,0,0,8192,0,8704,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,32768,0,0,0,0,0,1024,0,0,0,0,0,0,32,0,0,0,0,0,0,0,0,0,0,0+ ])++{-# NOINLINE happyExpListPerState #-}+happyExpListPerState st =+ token_strs_expected+ where token_strs = ["error","%dummy","%start_pLGrammar","%start_pLDef","%start_pListLDef","%start_pListIdentifier","%start_pGrammar","%start_pListDef","%start_pDef","%start_pItem","%start_pListItem","%start_pCat","%start_pLabel","%start_pLabelId","%start_pProfItem","%start_pIntList","%start_pListInteger","%start_pListIntList","%start_pListProfItem","%start_pArg","%start_pListArg","%start_pSeparation","%start_pListString","%start_pExp","%start_pExp1","%start_pExp2","%start_pListExp","%start_pListExp2","%start_pRHS","%start_pListRHS","%start_pMinimumSize","%start_pReg","%start_pReg1","%start_pReg2","%start_pReg3","String","Integer","Char","Double","Identifier","LGrammar","LDef","ListLDef","ListIdentifier","Grammar","ListDef","Def","Item","ListItem","Cat","Label","LabelId","ProfItem","IntList","ListInteger","ListIntList","ListProfItem","Arg","ListArg","Separation","ListString","Exp","Exp1","Exp2","ListExp","ListExp2","RHS","ListRHS","MinimumSize","Reg","Reg1","Reg2","Reg3","'('","')'","'*'","'+'","','","'-'","'.'","':'","'::='","';'","'='","'?'","'['","']'","'_'","'char'","'coercions'","'comment'","'define'","'delimiters'","'digit'","'entrypoints'","'eps'","'internal'","'layout'","'letter'","'lower'","'nonempty'","'position'","'rules'","'separator'","'stop'","'terminator'","'token'","'toplevel'","'upper'","'views'","'{'","'|'","'}'","L_quoted","L_integ","L_charac","L_doubl","L_Identifier","%eof"]+ bit_start = st Prelude.* 119+ bit_end = (st Prelude.+ 1) Prelude.* 119+ read_bit = readArrayBit happyExpList+ bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]+ bits_indexed = Prelude.zip bits [0..118]+ token_strs_expected = Prelude.concatMap f bits_indexed+ f (Prelude.False, _) = []+ f (Prelude.True, nr) = [token_strs Prelude.!! nr]++action_0 (74) = happyShift action_105+action_0 (83) = happyShift action_139+action_0 (86) = happyShift action_106+action_0 (88) = happyShift action_107+action_0 (90) = happyShift action_115+action_0 (91) = happyShift action_116+action_0 (92) = happyShift action_117+action_0 (93) = happyShift action_118+action_0 (95) = happyShift action_119+action_0 (97) = happyShift action_120+action_0 (98) = happyShift action_121+action_0 (102) = happyShift action_122+action_0 (103) = happyShift action_123+action_0 (104) = happyShift action_124+action_0 (106) = happyShift action_125+action_0 (107) = happyShift action_126+action_0 (110) = happyShift action_140+action_0 (118) = happyShift action_63+action_0 (40) = happyGoto action_134+action_0 (41) = happyGoto action_142+action_0 (42) = happyGoto action_135+action_0 (43) = happyGoto action_143+action_0 (44) = happyGoto action_137+action_0 (47) = happyGoto action_138+action_0 (51) = happyGoto action_114+action_0 (52) = happyGoto action_109+action_0 _ = happyReduce_42++action_1 (74) = happyShift action_105+action_1 (86) = happyShift action_106+action_1 (88) = happyShift action_107+action_1 (90) = happyShift action_115+action_1 (91) = happyShift action_116+action_1 (92) = happyShift action_117+action_1 (93) = happyShift action_118+action_1 (95) = happyShift action_119+action_1 (97) = happyShift action_120+action_1 (98) = happyShift action_121+action_1 (102) = happyShift action_122+action_1 (103) = happyShift action_123+action_1 (104) = happyShift action_124+action_1 (106) = happyShift action_125+action_1 (107) = happyShift action_126+action_1 (110) = happyShift action_140+action_1 (118) = happyShift action_63+action_1 (40) = happyGoto action_134+action_1 (42) = happyGoto action_141+action_1 (44) = happyGoto action_137+action_1 (47) = happyGoto action_138+action_1 (51) = happyGoto action_114+action_1 (52) = happyGoto action_109+action_1 _ = happyFail (happyExpListPerState 1)++action_2 (74) = happyShift action_105+action_2 (83) = happyShift action_139+action_2 (86) = happyShift action_106+action_2 (88) = happyShift action_107+action_2 (90) = happyShift action_115+action_2 (91) = happyShift action_116+action_2 (92) = happyShift action_117+action_2 (93) = happyShift action_118+action_2 (95) = happyShift action_119+action_2 (97) = happyShift action_120+action_2 (98) = happyShift action_121+action_2 (102) = happyShift action_122+action_2 (103) = happyShift action_123+action_2 (104) = happyShift action_124+action_2 (106) = happyShift action_125+action_2 (107) = happyShift action_126+action_2 (110) = happyShift action_140+action_2 (118) = happyShift action_63+action_2 (40) = happyGoto action_134+action_2 (42) = happyGoto action_135+action_2 (43) = happyGoto action_136+action_2 (44) = happyGoto action_137+action_2 (47) = happyGoto action_138+action_2 (51) = happyGoto action_114+action_2 (52) = happyGoto action_109+action_2 _ = happyReduce_42++action_3 (118) = happyShift action_63+action_3 (40) = happyGoto action_132+action_3 (44) = happyGoto action_133+action_3 _ = happyFail (happyExpListPerState 3)++action_4 (74) = happyShift action_105+action_4 (83) = happyShift action_129+action_4 (86) = happyShift action_106+action_4 (88) = happyShift action_107+action_4 (90) = happyShift action_115+action_4 (91) = happyShift action_116+action_4 (92) = happyShift action_117+action_4 (93) = happyShift action_118+action_4 (95) = happyShift action_119+action_4 (97) = happyShift action_120+action_4 (98) = happyShift action_121+action_4 (102) = happyShift action_122+action_4 (103) = happyShift action_123+action_4 (104) = happyShift action_124+action_4 (106) = happyShift action_125+action_4 (107) = happyShift action_126+action_4 (118) = happyShift action_63+action_4 (40) = happyGoto action_103+action_4 (45) = happyGoto action_130+action_4 (46) = happyGoto action_131+action_4 (47) = happyGoto action_128+action_4 (51) = happyGoto action_114+action_4 (52) = happyGoto action_109+action_4 _ = happyReduce_49++action_5 (74) = happyShift action_105+action_5 (83) = happyShift action_129+action_5 (86) = happyShift action_106+action_5 (88) = happyShift action_107+action_5 (90) = happyShift action_115+action_5 (91) = happyShift action_116+action_5 (92) = happyShift action_117+action_5 (93) = happyShift action_118+action_5 (95) = happyShift action_119+action_5 (97) = happyShift action_120+action_5 (98) = happyShift action_121+action_5 (102) = happyShift action_122+action_5 (103) = happyShift action_123+action_5 (104) = happyShift action_124+action_5 (106) = happyShift action_125+action_5 (107) = happyShift action_126+action_5 (118) = happyShift action_63+action_5 (40) = happyGoto action_103+action_5 (46) = happyGoto action_127+action_5 (47) = happyGoto action_128+action_5 (51) = happyGoto action_114+action_5 (52) = happyGoto action_109+action_5 _ = happyReduce_49++action_6 (74) = happyShift action_105+action_6 (86) = happyShift action_106+action_6 (88) = happyShift action_107+action_6 (90) = happyShift action_115+action_6 (91) = happyShift action_116+action_6 (92) = happyShift action_117+action_6 (93) = happyShift action_118+action_6 (95) = happyShift action_119+action_6 (97) = happyShift action_120+action_6 (98) = happyShift action_121+action_6 (102) = happyShift action_122+action_6 (103) = happyShift action_123+action_6 (104) = happyShift action_124+action_6 (106) = happyShift action_125+action_6 (107) = happyShift action_126+action_6 (118) = happyShift action_63+action_6 (40) = happyGoto action_103+action_6 (47) = happyGoto action_113+action_6 (51) = happyGoto action_114+action_6 (52) = happyGoto action_109+action_6 _ = happyFail (happyExpListPerState 6)++action_7 (86) = happyShift action_62+action_7 (114) = happyShift action_34+action_7 (118) = happyShift action_63+action_7 (36) = happyGoto action_55+action_7 (40) = happyGoto action_56+action_7 (48) = happyGoto action_112+action_7 (50) = happyGoto action_59+action_7 _ = happyFail (happyExpListPerState 7)++action_8 (86) = happyShift action_62+action_8 (114) = happyShift action_34+action_8 (118) = happyShift action_63+action_8 (36) = happyGoto action_55+action_8 (40) = happyGoto action_56+action_8 (48) = happyGoto action_57+action_8 (49) = happyGoto action_111+action_8 (50) = happyGoto action_59+action_8 _ = happyReduce_71++action_9 (86) = happyShift action_62+action_9 (118) = happyShift action_63+action_9 (40) = happyGoto action_56+action_9 (50) = happyGoto action_110+action_9 _ = happyFail (happyExpListPerState 9)++action_10 (74) = happyShift action_105+action_10 (86) = happyShift action_106+action_10 (88) = happyShift action_107+action_10 (118) = happyShift action_63+action_10 (40) = happyGoto action_103+action_10 (51) = happyGoto action_108+action_10 (52) = happyGoto action_109+action_10 _ = happyFail (happyExpListPerState 10)++action_11 (74) = happyShift action_105+action_11 (86) = happyShift action_106+action_11 (88) = happyShift action_107+action_11 (118) = happyShift action_63+action_11 (40) = happyGoto action_103+action_11 (52) = happyGoto action_104+action_11 _ = happyFail (happyExpListPerState 11)++action_12 (74) = happyShift action_95+action_12 (53) = happyGoto action_102+action_12 _ = happyFail (happyExpListPerState 12)++action_13 (86) = happyShift action_98+action_13 (54) = happyGoto action_101+action_13 _ = happyFail (happyExpListPerState 13)++action_14 (115) = happyShift action_74+action_14 (37) = happyGoto action_99+action_14 (55) = happyGoto action_100+action_14 _ = happyReduce_86++action_15 (86) = happyShift action_98+action_15 (54) = happyGoto action_96+action_15 (56) = happyGoto action_97+action_15 _ = happyReduce_89++action_16 (74) = happyShift action_95+action_16 (53) = happyGoto action_93+action_16 (57) = happyGoto action_94+action_16 _ = happyFail (happyExpListPerState 16)++action_17 (118) = happyShift action_63+action_17 (40) = happyGoto action_89+action_17 (58) = happyGoto action_92+action_17 _ = happyFail (happyExpListPerState 17)++action_18 (118) = happyShift action_63+action_18 (40) = happyGoto action_89+action_18 (58) = happyGoto action_90+action_18 (59) = happyGoto action_91+action_18 _ = happyReduce_95++action_19 (104) = happyShift action_87+action_19 (106) = happyShift action_88+action_19 (60) = happyGoto action_86+action_19 _ = happyReduce_97++action_20 (114) = happyShift action_34+action_20 (36) = happyGoto action_84+action_20 (61) = happyGoto action_85+action_20 _ = happyFail (happyExpListPerState 20)++action_21 (74) = happyShift action_72+action_21 (86) = happyShift action_73+action_21 (114) = happyShift action_34+action_21 (115) = happyShift action_74+action_21 (116) = happyShift action_46+action_21 (117) = happyShift action_75+action_21 (118) = happyShift action_63+action_21 (36) = happyGoto action_65+action_21 (37) = happyGoto action_66+action_21 (38) = happyGoto action_67+action_21 (39) = happyGoto action_68+action_21 (40) = happyGoto action_76+action_21 (62) = happyGoto action_83+action_21 (63) = happyGoto action_78+action_21 (64) = happyGoto action_79+action_21 _ = happyFail (happyExpListPerState 21)++action_22 (74) = happyShift action_72+action_22 (86) = happyShift action_73+action_22 (114) = happyShift action_34+action_22 (115) = happyShift action_74+action_22 (116) = happyShift action_46+action_22 (117) = happyShift action_75+action_22 (118) = happyShift action_63+action_22 (36) = happyGoto action_65+action_22 (37) = happyGoto action_66+action_22 (38) = happyGoto action_67+action_22 (39) = happyGoto action_68+action_22 (40) = happyGoto action_76+action_22 (63) = happyGoto action_82+action_22 (64) = happyGoto action_79+action_22 _ = happyFail (happyExpListPerState 22)++action_23 (74) = happyShift action_72+action_23 (86) = happyShift action_73+action_23 (114) = happyShift action_34+action_23 (115) = happyShift action_74+action_23 (116) = happyShift action_46+action_23 (117) = happyShift action_75+action_23 (118) = happyShift action_63+action_23 (36) = happyGoto action_65+action_23 (37) = happyGoto action_66+action_23 (38) = happyGoto action_67+action_23 (39) = happyGoto action_68+action_23 (40) = happyGoto action_69+action_23 (64) = happyGoto action_81+action_23 _ = happyFail (happyExpListPerState 23)++action_24 (74) = happyShift action_72+action_24 (86) = happyShift action_73+action_24 (114) = happyShift action_34+action_24 (115) = happyShift action_74+action_24 (116) = happyShift action_46+action_24 (117) = happyShift action_75+action_24 (118) = happyShift action_63+action_24 (36) = happyGoto action_65+action_24 (37) = happyGoto action_66+action_24 (38) = happyGoto action_67+action_24 (39) = happyGoto action_68+action_24 (40) = happyGoto action_76+action_24 (62) = happyGoto action_77+action_24 (63) = happyGoto action_78+action_24 (64) = happyGoto action_79+action_24 (65) = happyGoto action_80+action_24 _ = happyReduce_113++action_25 (74) = happyShift action_72+action_25 (86) = happyShift action_73+action_25 (114) = happyShift action_34+action_25 (115) = happyShift action_74+action_25 (116) = happyShift action_46+action_25 (117) = happyShift action_75+action_25 (118) = happyShift action_63+action_25 (36) = happyGoto action_65+action_25 (37) = happyGoto action_66+action_25 (38) = happyGoto action_67+action_25 (39) = happyGoto action_68+action_25 (40) = happyGoto action_69+action_25 (64) = happyGoto action_70+action_25 (66) = happyGoto action_71+action_25 _ = happyFail (happyExpListPerState 25)++action_26 (86) = happyShift action_62+action_26 (114) = happyShift action_34+action_26 (118) = happyShift action_63+action_26 (36) = happyGoto action_55+action_26 (40) = happyGoto action_56+action_26 (48) = happyGoto action_57+action_26 (49) = happyGoto action_58+action_26 (50) = happyGoto action_59+action_26 (67) = happyGoto action_64+action_26 _ = happyReduce_71++action_27 (86) = happyShift action_62+action_27 (114) = happyShift action_34+action_27 (118) = happyShift action_63+action_27 (36) = happyGoto action_55+action_27 (40) = happyGoto action_56+action_27 (48) = happyGoto action_57+action_27 (49) = happyGoto action_58+action_27 (50) = happyGoto action_59+action_27 (67) = happyGoto action_60+action_27 (68) = happyGoto action_61+action_27 _ = happyReduce_71++action_28 (101) = happyShift action_54+action_28 (69) = happyGoto action_53+action_28 _ = happyReduce_122++action_29 (74) = happyShift action_37+action_29 (86) = happyShift action_38+action_29 (89) = happyShift action_39+action_29 (94) = happyShift action_40+action_29 (96) = happyShift action_41+action_29 (99) = happyShift action_42+action_29 (100) = happyShift action_43+action_29 (109) = happyShift action_44+action_29 (111) = happyShift action_45+action_29 (116) = happyShift action_46+action_29 (38) = happyGoto action_35+action_29 (70) = happyGoto action_51+action_29 (71) = happyGoto action_52+action_29 (72) = happyGoto action_50+action_29 (73) = happyGoto action_48+action_29 _ = happyFail (happyExpListPerState 29)++action_30 (74) = happyShift action_37+action_30 (86) = happyShift action_38+action_30 (89) = happyShift action_39+action_30 (94) = happyShift action_40+action_30 (96) = happyShift action_41+action_30 (99) = happyShift action_42+action_30 (100) = happyShift action_43+action_30 (109) = happyShift action_44+action_30 (111) = happyShift action_45+action_30 (116) = happyShift action_46+action_30 (38) = happyGoto action_35+action_30 (71) = happyGoto action_49+action_30 (72) = happyGoto action_50+action_30 (73) = happyGoto action_48+action_30 _ = happyFail (happyExpListPerState 30)++action_31 (74) = happyShift action_37+action_31 (86) = happyShift action_38+action_31 (89) = happyShift action_39+action_31 (94) = happyShift action_40+action_31 (96) = happyShift action_41+action_31 (99) = happyShift action_42+action_31 (100) = happyShift action_43+action_31 (109) = happyShift action_44+action_31 (111) = happyShift action_45+action_31 (116) = happyShift action_46+action_31 (38) = happyGoto action_35+action_31 (72) = happyGoto action_47+action_31 (73) = happyGoto action_48+action_31 _ = happyFail (happyExpListPerState 31)++action_32 (74) = happyShift action_37+action_32 (86) = happyShift action_38+action_32 (89) = happyShift action_39+action_32 (94) = happyShift action_40+action_32 (96) = happyShift action_41+action_32 (99) = happyShift action_42+action_32 (100) = happyShift action_43+action_32 (109) = happyShift action_44+action_32 (111) = happyShift action_45+action_32 (116) = happyShift action_46+action_32 (38) = happyGoto action_35+action_32 (73) = happyGoto action_36+action_32 _ = happyFail (happyExpListPerState 32)++action_33 (114) = happyShift action_34+action_33 _ = happyFail (happyExpListPerState 33)++action_34 _ = happyReduce_33++action_35 _ = happyReduce_133++action_36 (76) = happyShift action_192+action_36 (77) = happyShift action_193+action_36 (85) = happyShift action_194+action_36 (119) = happyAccept+action_36 _ = happyFail (happyExpListPerState 36)++action_37 (74) = happyShift action_37+action_37 (86) = happyShift action_38+action_37 (89) = happyShift action_39+action_37 (94) = happyShift action_40+action_37 (96) = happyShift action_41+action_37 (99) = happyShift action_42+action_37 (100) = happyShift action_43+action_37 (109) = happyShift action_44+action_37 (111) = happyShift action_45+action_37 (116) = happyShift action_46+action_37 (38) = happyGoto action_35+action_37 (70) = happyGoto action_197+action_37 (71) = happyGoto action_52+action_37 (72) = happyGoto action_50+action_37 (73) = happyGoto action_48+action_37 _ = happyFail (happyExpListPerState 37)++action_38 (114) = happyShift action_34+action_38 (36) = happyGoto action_196+action_38 _ = happyFail (happyExpListPerState 38)++action_39 _ = happyReduce_140++action_40 _ = happyReduce_136++action_41 _ = happyReduce_132++action_42 _ = happyReduce_137++action_43 _ = happyReduce_139++action_44 _ = happyReduce_138++action_45 (114) = happyShift action_34+action_45 (36) = happyGoto action_195+action_45 _ = happyFail (happyExpListPerState 45)++action_46 _ = happyReduce_35++action_47 (74) = happyShift action_37+action_47 (86) = happyShift action_38+action_47 (89) = happyShift action_39+action_47 (94) = happyShift action_40+action_47 (96) = happyShift action_41+action_47 (99) = happyShift action_42+action_47 (100) = happyShift action_43+action_47 (109) = happyShift action_44+action_47 (111) = happyShift action_45+action_47 (116) = happyShift action_46+action_47 (119) = happyAccept+action_47 (38) = happyGoto action_35+action_47 (73) = happyGoto action_191+action_47 _ = happyFail (happyExpListPerState 47)++action_48 (76) = happyShift action_192+action_48 (77) = happyShift action_193+action_48 (85) = happyShift action_194+action_48 _ = happyReduce_128++action_49 (79) = happyShift action_189+action_49 (119) = happyAccept+action_49 _ = happyFail (happyExpListPerState 49)++action_50 (74) = happyShift action_37+action_50 (86) = happyShift action_38+action_50 (89) = happyShift action_39+action_50 (94) = happyShift action_40+action_50 (96) = happyShift action_41+action_50 (99) = happyShift action_42+action_50 (100) = happyShift action_43+action_50 (109) = happyShift action_44+action_50 (111) = happyShift action_45+action_50 (116) = happyShift action_46+action_50 (38) = happyGoto action_35+action_50 (73) = happyGoto action_191+action_50 _ = happyReduce_126++action_51 (112) = happyShift action_190+action_51 (119) = happyAccept+action_51 _ = happyFail (happyExpListPerState 51)++action_52 (79) = happyShift action_189+action_52 _ = happyReduce_124++action_53 (119) = happyAccept+action_53 _ = happyFail (happyExpListPerState 53)++action_54 _ = happyReduce_121++action_55 _ = happyReduce_69++action_56 _ = happyReduce_74++action_57 (86) = happyShift action_62+action_57 (114) = happyShift action_34+action_57 (118) = happyShift action_63+action_57 (36) = happyGoto action_55+action_57 (40) = happyGoto action_56+action_57 (48) = happyGoto action_57+action_57 (49) = happyGoto action_188+action_57 (50) = happyGoto action_59+action_57 _ = happyReduce_71++action_58 _ = happyReduce_118++action_59 _ = happyReduce_70++action_60 (112) = happyShift action_187+action_60 _ = happyReduce_119++action_61 (119) = happyAccept+action_61 _ = happyFail (happyExpListPerState 61)++action_62 (86) = happyShift action_62+action_62 (118) = happyShift action_63+action_62 (40) = happyGoto action_56+action_62 (50) = happyGoto action_186+action_62 _ = happyFail (happyExpListPerState 62)++action_63 _ = happyReduce_37++action_64 (119) = happyAccept+action_64 _ = happyFail (happyExpListPerState 64)++action_65 _ = happyReduce_109++action_66 _ = happyReduce_107++action_67 _ = happyReduce_108++action_68 _ = happyReduce_110++action_69 _ = happyReduce_106++action_70 (74) = happyShift action_72+action_70 (86) = happyShift action_73+action_70 (114) = happyShift action_34+action_70 (115) = happyShift action_74+action_70 (116) = happyShift action_46+action_70 (117) = happyShift action_75+action_70 (118) = happyShift action_63+action_70 (36) = happyGoto action_65+action_70 (37) = happyGoto action_66+action_70 (38) = happyGoto action_67+action_70 (39) = happyGoto action_68+action_70 (40) = happyGoto action_69+action_70 (64) = happyGoto action_70+action_70 (66) = happyGoto action_185+action_70 _ = happyReduce_116++action_71 (119) = happyAccept+action_71 _ = happyFail (happyExpListPerState 71)++action_72 (74) = happyShift action_72+action_72 (86) = happyShift action_73+action_72 (114) = happyShift action_34+action_72 (115) = happyShift action_74+action_72 (116) = happyShift action_46+action_72 (117) = happyShift action_75+action_72 (118) = happyShift action_63+action_72 (36) = happyGoto action_65+action_72 (37) = happyGoto action_66+action_72 (38) = happyGoto action_67+action_72 (39) = happyGoto action_68+action_72 (40) = happyGoto action_76+action_72 (62) = happyGoto action_184+action_72 (63) = happyGoto action_78+action_72 (64) = happyGoto action_79+action_72 _ = happyFail (happyExpListPerState 72)++action_73 (74) = happyShift action_72+action_73 (86) = happyShift action_73+action_73 (114) = happyShift action_34+action_73 (115) = happyShift action_74+action_73 (116) = happyShift action_46+action_73 (117) = happyShift action_75+action_73 (118) = happyShift action_63+action_73 (36) = happyGoto action_65+action_73 (37) = happyGoto action_66+action_73 (38) = happyGoto action_67+action_73 (39) = happyGoto action_68+action_73 (40) = happyGoto action_76+action_73 (62) = happyGoto action_77+action_73 (63) = happyGoto action_78+action_73 (64) = happyGoto action_79+action_73 (65) = happyGoto action_183+action_73 _ = happyReduce_113++action_74 _ = happyReduce_34++action_75 _ = happyReduce_36++action_76 (74) = happyShift action_72+action_76 (86) = happyShift action_73+action_76 (114) = happyShift action_34+action_76 (115) = happyShift action_74+action_76 (116) = happyShift action_46+action_76 (117) = happyShift action_75+action_76 (118) = happyShift action_63+action_76 (36) = happyGoto action_65+action_76 (37) = happyGoto action_66+action_76 (38) = happyGoto action_67+action_76 (39) = happyGoto action_68+action_76 (40) = happyGoto action_69+action_76 (64) = happyGoto action_70+action_76 (66) = happyGoto action_182+action_76 _ = happyReduce_106++action_77 (78) = happyShift action_181+action_77 _ = happyReduce_114++action_78 (81) = happyShift action_180+action_78 _ = happyReduce_103++action_79 _ = happyReduce_105++action_80 (119) = happyAccept+action_80 _ = happyFail (happyExpListPerState 80)++action_81 (119) = happyAccept+action_81 _ = happyFail (happyExpListPerState 81)++action_82 (119) = happyAccept+action_82 _ = happyFail (happyExpListPerState 82)++action_83 (119) = happyAccept+action_83 _ = happyFail (happyExpListPerState 83)++action_84 (78) = happyShift action_179+action_84 _ = happyReduce_100++action_85 (119) = happyAccept+action_85 _ = happyFail (happyExpListPerState 85)++action_86 (119) = happyAccept+action_86 _ = happyFail (happyExpListPerState 86)++action_87 (114) = happyShift action_34+action_87 (36) = happyGoto action_178+action_87 _ = happyFail (happyExpListPerState 87)++action_88 (114) = happyShift action_34+action_88 (36) = happyGoto action_177+action_88 _ = happyFail (happyExpListPerState 88)++action_89 _ = happyReduce_94++action_90 (118) = happyShift action_63+action_90 (40) = happyGoto action_89+action_90 (58) = happyGoto action_90+action_90 (59) = happyGoto action_176+action_90 _ = happyReduce_95++action_91 (119) = happyAccept+action_91 _ = happyFail (happyExpListPerState 91)++action_92 (119) = happyAccept+action_92 _ = happyFail (happyExpListPerState 92)++action_93 (74) = happyShift action_95+action_93 (53) = happyGoto action_93+action_93 (57) = happyGoto action_175+action_93 _ = happyReduce_92++action_94 (119) = happyAccept+action_94 _ = happyFail (happyExpListPerState 94)++action_95 (86) = happyShift action_174+action_95 _ = happyFail (happyExpListPerState 95)++action_96 (78) = happyShift action_173+action_96 _ = happyReduce_90++action_97 (119) = happyAccept+action_97 _ = happyFail (happyExpListPerState 97)++action_98 (115) = happyShift action_74+action_98 (37) = happyGoto action_99+action_98 (55) = happyGoto action_172+action_98 _ = happyReduce_86++action_99 (78) = happyShift action_171+action_99 _ = happyReduce_87++action_100 (119) = happyAccept+action_100 _ = happyFail (happyExpListPerState 100)++action_101 (119) = happyAccept+action_101 _ = happyFail (happyExpListPerState 101)++action_102 (119) = happyAccept+action_102 _ = happyFail (happyExpListPerState 102)++action_103 _ = happyReduce_79++action_104 (119) = happyAccept+action_104 _ = happyFail (happyExpListPerState 104)++action_105 (81) = happyShift action_170+action_105 _ = happyFail (happyExpListPerState 105)++action_106 (87) = happyShift action_169+action_106 _ = happyFail (happyExpListPerState 106)++action_107 _ = happyReduce_80++action_108 (119) = happyAccept+action_108 _ = happyFail (happyExpListPerState 108)++action_109 (74) = happyShift action_168+action_109 (86) = happyShift action_106+action_109 (88) = happyShift action_107+action_109 (118) = happyShift action_63+action_109 (40) = happyGoto action_103+action_109 (52) = happyGoto action_166+action_109 (53) = happyGoto action_93+action_109 (57) = happyGoto action_167+action_109 _ = happyReduce_75++action_110 (119) = happyAccept+action_110 _ = happyFail (happyExpListPerState 110)++action_111 (119) = happyAccept+action_111 _ = happyFail (happyExpListPerState 111)++action_112 (119) = happyAccept+action_112 _ = happyFail (happyExpListPerState 112)++action_113 (119) = happyAccept+action_113 _ = happyFail (happyExpListPerState 113)++action_114 (80) = happyShift action_165+action_114 _ = happyFail (happyExpListPerState 114)++action_115 (118) = happyShift action_63+action_115 (40) = happyGoto action_164+action_115 _ = happyFail (happyExpListPerState 115)++action_116 (114) = happyShift action_34+action_116 (36) = happyGoto action_163+action_116 _ = happyFail (happyExpListPerState 116)++action_117 (118) = happyShift action_63+action_117 (40) = happyGoto action_162+action_117 _ = happyFail (happyExpListPerState 117)++action_118 (86) = happyShift action_62+action_118 (118) = happyShift action_63+action_118 (40) = happyGoto action_56+action_118 (50) = happyGoto action_161+action_118 _ = happyFail (happyExpListPerState 118)++action_119 (118) = happyShift action_63+action_119 (40) = happyGoto action_132+action_119 (44) = happyGoto action_160+action_119 _ = happyFail (happyExpListPerState 119)++action_120 (74) = happyShift action_105+action_120 (86) = happyShift action_106+action_120 (88) = happyShift action_107+action_120 (118) = happyShift action_63+action_120 (40) = happyGoto action_103+action_120 (51) = happyGoto action_159+action_120 (52) = happyGoto action_109+action_120 _ = happyFail (happyExpListPerState 120)++action_121 (105) = happyShift action_157+action_121 (108) = happyShift action_158+action_121 (114) = happyShift action_34+action_121 (36) = happyGoto action_84+action_121 (61) = happyGoto action_156+action_121 _ = happyFail (happyExpListPerState 121)++action_122 (107) = happyShift action_155+action_122 _ = happyFail (happyExpListPerState 122)++action_123 (118) = happyShift action_63+action_123 (40) = happyGoto action_154+action_123 _ = happyFail (happyExpListPerState 123)++action_124 (101) = happyShift action_54+action_124 (69) = happyGoto action_153+action_124 _ = happyReduce_122++action_125 (101) = happyShift action_54+action_125 (69) = happyGoto action_152+action_125 _ = happyReduce_122++action_126 (118) = happyShift action_63+action_126 (40) = happyGoto action_151+action_126 _ = happyFail (happyExpListPerState 126)++action_127 (119) = happyAccept+action_127 _ = happyFail (happyExpListPerState 127)++action_128 (83) = happyShift action_150+action_128 _ = happyReduce_50++action_129 (74) = happyShift action_105+action_129 (83) = happyShift action_129+action_129 (86) = happyShift action_106+action_129 (88) = happyShift action_107+action_129 (90) = happyShift action_115+action_129 (91) = happyShift action_116+action_129 (92) = happyShift action_117+action_129 (93) = happyShift action_118+action_129 (95) = happyShift action_119+action_129 (97) = happyShift action_120+action_129 (98) = happyShift action_121+action_129 (102) = happyShift action_122+action_129 (103) = happyShift action_123+action_129 (104) = happyShift action_124+action_129 (106) = happyShift action_125+action_129 (107) = happyShift action_126+action_129 (118) = happyShift action_63+action_129 (40) = happyGoto action_103+action_129 (46) = happyGoto action_149+action_129 (47) = happyGoto action_128+action_129 (51) = happyGoto action_114+action_129 (52) = happyGoto action_109+action_129 _ = happyReduce_49++action_130 (119) = happyAccept+action_130 _ = happyFail (happyExpListPerState 130)++action_131 _ = happyReduce_48++action_132 (78) = happyShift action_148+action_132 _ = happyReduce_46++action_133 (119) = happyAccept+action_133 _ = happyFail (happyExpListPerState 133)++action_134 (78) = happyShift action_148+action_134 (81) = happyReduce_46+action_134 _ = happyReduce_79++action_135 (83) = happyShift action_147+action_135 _ = happyReduce_43++action_136 (119) = happyAccept+action_136 _ = happyFail (happyExpListPerState 136)++action_137 (81) = happyShift action_146+action_137 _ = happyFail (happyExpListPerState 137)++action_138 _ = happyReduce_39++action_139 (74) = happyShift action_105+action_139 (83) = happyShift action_139+action_139 (86) = happyShift action_106+action_139 (88) = happyShift action_107+action_139 (90) = happyShift action_115+action_139 (91) = happyShift action_116+action_139 (92) = happyShift action_117+action_139 (93) = happyShift action_118+action_139 (95) = happyShift action_119+action_139 (97) = happyShift action_120+action_139 (98) = happyShift action_121+action_139 (102) = happyShift action_122+action_139 (103) = happyShift action_123+action_139 (104) = happyShift action_124+action_139 (106) = happyShift action_125+action_139 (107) = happyShift action_126+action_139 (110) = happyShift action_140+action_139 (118) = happyShift action_63+action_139 (40) = happyGoto action_134+action_139 (42) = happyGoto action_135+action_139 (43) = happyGoto action_145+action_139 (44) = happyGoto action_137+action_139 (47) = happyGoto action_138+action_139 (51) = happyGoto action_114+action_139 (52) = happyGoto action_109+action_139 _ = happyReduce_42++action_140 (118) = happyShift action_63+action_140 (40) = happyGoto action_132+action_140 (44) = happyGoto action_144+action_140 _ = happyFail (happyExpListPerState 140)++action_141 (119) = happyAccept+action_141 _ = happyFail (happyExpListPerState 141)++action_142 (119) = happyAccept+action_142 _ = happyFail (happyExpListPerState 142)++action_143 _ = happyReduce_38++action_144 _ = happyReduce_41++action_145 _ = happyReduce_45++action_146 (74) = happyShift action_105+action_146 (86) = happyShift action_106+action_146 (88) = happyShift action_107+action_146 (90) = happyShift action_115+action_146 (91) = happyShift action_116+action_146 (92) = happyShift action_117+action_146 (93) = happyShift action_118+action_146 (95) = happyShift action_119+action_146 (97) = happyShift action_120+action_146 (98) = happyShift action_121+action_146 (102) = happyShift action_122+action_146 (103) = happyShift action_123+action_146 (104) = happyShift action_124+action_146 (106) = happyShift action_125+action_146 (107) = happyShift action_126+action_146 (118) = happyShift action_63+action_146 (40) = happyGoto action_103+action_146 (47) = happyGoto action_232+action_146 (51) = happyGoto action_114+action_146 (52) = happyGoto action_109+action_146 _ = happyFail (happyExpListPerState 146)++action_147 (74) = happyShift action_105+action_147 (83) = happyShift action_139+action_147 (86) = happyShift action_106+action_147 (88) = happyShift action_107+action_147 (90) = happyShift action_115+action_147 (91) = happyShift action_116+action_147 (92) = happyShift action_117+action_147 (93) = happyShift action_118+action_147 (95) = happyShift action_119+action_147 (97) = happyShift action_120+action_147 (98) = happyShift action_121+action_147 (102) = happyShift action_122+action_147 (103) = happyShift action_123+action_147 (104) = happyShift action_124+action_147 (106) = happyShift action_125+action_147 (107) = happyShift action_126+action_147 (110) = happyShift action_140+action_147 (118) = happyShift action_63+action_147 (40) = happyGoto action_134+action_147 (42) = happyGoto action_135+action_147 (43) = happyGoto action_231+action_147 (44) = happyGoto action_137+action_147 (47) = happyGoto action_138+action_147 (51) = happyGoto action_114+action_147 (52) = happyGoto action_109+action_147 _ = happyReduce_42++action_148 (118) = happyShift action_63+action_148 (40) = happyGoto action_132+action_148 (44) = happyGoto action_230+action_148 _ = happyFail (happyExpListPerState 148)++action_149 _ = happyReduce_52++action_150 (74) = happyShift action_105+action_150 (83) = happyShift action_129+action_150 (86) = happyShift action_106+action_150 (88) = happyShift action_107+action_150 (90) = happyShift action_115+action_150 (91) = happyShift action_116+action_150 (92) = happyShift action_117+action_150 (93) = happyShift action_118+action_150 (95) = happyShift action_119+action_150 (97) = happyShift action_120+action_150 (98) = happyShift action_121+action_150 (102) = happyShift action_122+action_150 (103) = happyShift action_123+action_150 (104) = happyShift action_124+action_150 (106) = happyShift action_125+action_150 (107) = happyShift action_126+action_150 (118) = happyShift action_63+action_150 (40) = happyGoto action_103+action_150 (46) = happyGoto action_229+action_150 (47) = happyGoto action_128+action_150 (51) = happyGoto action_114+action_150 (52) = happyGoto action_109+action_150 _ = happyReduce_49++action_151 (74) = happyShift action_37+action_151 (86) = happyShift action_38+action_151 (89) = happyShift action_39+action_151 (94) = happyShift action_40+action_151 (96) = happyShift action_41+action_151 (99) = happyShift action_42+action_151 (100) = happyShift action_43+action_151 (109) = happyShift action_44+action_151 (111) = happyShift action_45+action_151 (116) = happyShift action_46+action_151 (38) = happyGoto action_35+action_151 (70) = happyGoto action_228+action_151 (71) = happyGoto action_52+action_151 (72) = happyGoto action_50+action_151 (73) = happyGoto action_48+action_151 _ = happyFail (happyExpListPerState 151)++action_152 (86) = happyShift action_62+action_152 (118) = happyShift action_63+action_152 (40) = happyGoto action_56+action_152 (50) = happyGoto action_227+action_152 _ = happyFail (happyExpListPerState 152)++action_153 (86) = happyShift action_62+action_153 (118) = happyShift action_63+action_153 (40) = happyGoto action_56+action_153 (50) = happyGoto action_226+action_153 _ = happyFail (happyExpListPerState 153)++action_154 (82) = happyShift action_225+action_154 _ = happyFail (happyExpListPerState 154)++action_155 (118) = happyShift action_63+action_155 (40) = happyGoto action_224+action_155 _ = happyFail (happyExpListPerState 155)++action_156 _ = happyReduce_66++action_157 (114) = happyShift action_34+action_157 (36) = happyGoto action_84+action_157 (61) = happyGoto action_223+action_157 _ = happyFail (happyExpListPerState 157)++action_158 _ = happyReduce_68++action_159 (80) = happyShift action_222+action_159 _ = happyFail (happyExpListPerState 159)++action_160 _ = happyReduce_59++action_161 (114) = happyShift action_34+action_161 (36) = happyGoto action_221+action_161 _ = happyFail (happyExpListPerState 161)++action_162 (118) = happyShift action_63+action_162 (40) = happyGoto action_89+action_162 (58) = happyGoto action_90+action_162 (59) = happyGoto action_220+action_162 _ = happyReduce_95++action_163 (114) = happyShift action_34+action_163 (36) = happyGoto action_219+action_163 _ = happyReduce_54++action_164 (115) = happyShift action_74+action_164 (37) = happyGoto action_218+action_164 _ = happyFail (happyExpListPerState 164)++action_165 (86) = happyShift action_62+action_165 (118) = happyShift action_63+action_165 (40) = happyGoto action_56+action_165 (50) = happyGoto action_217+action_165 _ = happyFail (happyExpListPerState 165)++action_166 (74) = happyShift action_95+action_166 (53) = happyGoto action_93+action_166 (57) = happyGoto action_216+action_166 _ = happyReduce_78++action_167 _ = happyReduce_76++action_168 (81) = happyShift action_170+action_168 (86) = happyShift action_174+action_168 _ = happyFail (happyExpListPerState 168)++action_169 _ = happyReduce_81++action_170 (75) = happyShift action_214+action_170 (86) = happyShift action_215+action_170 _ = happyFail (happyExpListPerState 170)++action_171 (115) = happyShift action_74+action_171 (37) = happyGoto action_99+action_171 (55) = happyGoto action_213+action_171 _ = happyReduce_86++action_172 (87) = happyShift action_212+action_172 _ = happyFail (happyExpListPerState 172)++action_173 (86) = happyShift action_98+action_173 (54) = happyGoto action_96+action_173 (56) = happyGoto action_211+action_173 _ = happyReduce_89++action_174 (86) = happyShift action_98+action_174 (54) = happyGoto action_96+action_174 (56) = happyGoto action_210+action_174 _ = happyReduce_89++action_175 _ = happyReduce_93++action_176 _ = happyReduce_96++action_177 _ = happyReduce_98++action_178 _ = happyReduce_99++action_179 (114) = happyShift action_34+action_179 (36) = happyGoto action_84+action_179 (61) = happyGoto action_209+action_179 _ = happyFail (happyExpListPerState 179)++action_180 (74) = happyShift action_72+action_180 (86) = happyShift action_73+action_180 (114) = happyShift action_34+action_180 (115) = happyShift action_74+action_180 (116) = happyShift action_46+action_180 (117) = happyShift action_75+action_180 (118) = happyShift action_63+action_180 (36) = happyGoto action_65+action_180 (37) = happyGoto action_66+action_180 (38) = happyGoto action_67+action_180 (39) = happyGoto action_68+action_180 (40) = happyGoto action_76+action_180 (62) = happyGoto action_208+action_180 (63) = happyGoto action_78+action_180 (64) = happyGoto action_79+action_180 _ = happyFail (happyExpListPerState 180)++action_181 (74) = happyShift action_72+action_181 (86) = happyShift action_73+action_181 (114) = happyShift action_34+action_181 (115) = happyShift action_74+action_181 (116) = happyShift action_46+action_181 (117) = happyShift action_75+action_181 (118) = happyShift action_63+action_181 (36) = happyGoto action_65+action_181 (37) = happyGoto action_66+action_181 (38) = happyGoto action_67+action_181 (39) = happyGoto action_68+action_181 (40) = happyGoto action_76+action_181 (62) = happyGoto action_77+action_181 (63) = happyGoto action_78+action_181 (64) = happyGoto action_79+action_181 (65) = happyGoto action_207+action_181 _ = happyReduce_113++action_182 _ = happyReduce_104++action_183 (87) = happyShift action_206+action_183 _ = happyFail (happyExpListPerState 183)++action_184 (75) = happyShift action_205+action_184 _ = happyFail (happyExpListPerState 184)++action_185 _ = happyReduce_117++action_186 (87) = happyShift action_204+action_186 _ = happyFail (happyExpListPerState 186)++action_187 (86) = happyShift action_62+action_187 (114) = happyShift action_34+action_187 (118) = happyShift action_63+action_187 (36) = happyGoto action_55+action_187 (40) = happyGoto action_56+action_187 (48) = happyGoto action_57+action_187 (49) = happyGoto action_58+action_187 (50) = happyGoto action_59+action_187 (67) = happyGoto action_60+action_187 (68) = happyGoto action_203+action_187 _ = happyReduce_71++action_188 _ = happyReduce_72++action_189 (74) = happyShift action_37+action_189 (86) = happyShift action_38+action_189 (89) = happyShift action_39+action_189 (94) = happyShift action_40+action_189 (96) = happyShift action_41+action_189 (99) = happyShift action_42+action_189 (100) = happyShift action_43+action_189 (109) = happyShift action_44+action_189 (111) = happyShift action_45+action_189 (116) = happyShift action_46+action_189 (38) = happyGoto action_35+action_189 (72) = happyGoto action_202+action_189 (73) = happyGoto action_48+action_189 _ = happyFail (happyExpListPerState 189)++action_190 (74) = happyShift action_37+action_190 (86) = happyShift action_38+action_190 (89) = happyShift action_39+action_190 (94) = happyShift action_40+action_190 (96) = happyShift action_41+action_190 (99) = happyShift action_42+action_190 (100) = happyShift action_43+action_190 (109) = happyShift action_44+action_190 (111) = happyShift action_45+action_190 (116) = happyShift action_46+action_190 (38) = happyGoto action_35+action_190 (71) = happyGoto action_201+action_190 (72) = happyGoto action_50+action_190 (73) = happyGoto action_48+action_190 _ = happyFail (happyExpListPerState 190)++action_191 (76) = happyShift action_192+action_191 (77) = happyShift action_193+action_191 (85) = happyShift action_194+action_191 _ = happyReduce_127++action_192 _ = happyReduce_129++action_193 _ = happyReduce_130++action_194 _ = happyReduce_131++action_195 (113) = happyShift action_200+action_195 _ = happyFail (happyExpListPerState 195)++action_196 (87) = happyShift action_199+action_196 _ = happyFail (happyExpListPerState 196)++action_197 (75) = happyShift action_198+action_197 (112) = happyShift action_190+action_197 _ = happyFail (happyExpListPerState 197)++action_198 _ = happyReduce_141++action_199 _ = happyReduce_134++action_200 _ = happyReduce_135++action_201 (79) = happyShift action_189+action_201 _ = happyReduce_123++action_202 (74) = happyShift action_37+action_202 (86) = happyShift action_38+action_202 (89) = happyShift action_39+action_202 (94) = happyShift action_40+action_202 (96) = happyShift action_41+action_202 (99) = happyShift action_42+action_202 (100) = happyShift action_43+action_202 (109) = happyShift action_44+action_202 (111) = happyShift action_45+action_202 (116) = happyShift action_46+action_202 (38) = happyGoto action_35+action_202 (73) = happyGoto action_191+action_202 _ = happyReduce_125++action_203 _ = happyReduce_120++action_204 _ = happyReduce_73++action_205 _ = happyReduce_112++action_206 _ = happyReduce_111++action_207 _ = happyReduce_115++action_208 _ = happyReduce_102++action_209 _ = happyReduce_101++action_210 (87) = happyShift action_242+action_210 _ = happyFail (happyExpListPerState 210)++action_211 _ = happyReduce_91++action_212 _ = happyReduce_85++action_213 _ = happyReduce_88++action_214 _ = happyReduce_82++action_215 (87) = happyShift action_241+action_215 _ = happyFail (happyExpListPerState 215)++action_216 _ = happyReduce_77++action_217 (82) = happyShift action_240+action_217 _ = happyFail (happyExpListPerState 217)++action_218 _ = happyReduce_63++action_219 _ = happyReduce_55++action_220 (84) = happyShift action_239+action_220 _ = happyFail (happyExpListPerState 220)++action_221 (114) = happyShift action_34+action_221 (36) = happyGoto action_238+action_221 _ = happyFail (happyExpListPerState 221)++action_222 (86) = happyShift action_62+action_222 (118) = happyShift action_63+action_222 (40) = happyGoto action_56+action_222 (50) = happyGoto action_237+action_222 _ = happyFail (happyExpListPerState 222)++action_223 _ = happyReduce_67++action_224 (74) = happyShift action_37+action_224 (86) = happyShift action_38+action_224 (89) = happyShift action_39+action_224 (94) = happyShift action_40+action_224 (96) = happyShift action_41+action_224 (99) = happyShift action_42+action_224 (100) = happyShift action_43+action_224 (109) = happyShift action_44+action_224 (111) = happyShift action_45+action_224 (116) = happyShift action_46+action_224 (38) = happyGoto action_35+action_224 (70) = happyGoto action_236+action_224 (71) = happyGoto action_52+action_224 (72) = happyGoto action_50+action_224 (73) = happyGoto action_48+action_224 _ = happyFail (happyExpListPerState 224)++action_225 (86) = happyShift action_62+action_225 (114) = happyShift action_34+action_225 (118) = happyShift action_63+action_225 (36) = happyGoto action_55+action_225 (40) = happyGoto action_56+action_225 (48) = happyGoto action_57+action_225 (49) = happyGoto action_58+action_225 (50) = happyGoto action_59+action_225 (67) = happyGoto action_60+action_225 (68) = happyGoto action_235+action_225 _ = happyReduce_71++action_226 (114) = happyShift action_34+action_226 (36) = happyGoto action_234+action_226 _ = happyFail (happyExpListPerState 226)++action_227 (114) = happyShift action_34+action_227 (36) = happyGoto action_233+action_227 _ = happyFail (happyExpListPerState 227)++action_228 (112) = happyShift action_190+action_228 _ = happyReduce_57++action_229 _ = happyReduce_51++action_230 _ = happyReduce_47++action_231 _ = happyReduce_44++action_232 _ = happyReduce_40++action_233 _ = happyReduce_61++action_234 _ = happyReduce_60++action_235 _ = happyReduce_64++action_236 (112) = happyShift action_190+action_236 _ = happyReduce_58++action_237 (82) = happyShift action_248+action_237 _ = happyFail (happyExpListPerState 237)++action_238 (104) = happyShift action_87+action_238 (106) = happyShift action_88+action_238 (60) = happyGoto action_247+action_238 _ = happyReduce_97++action_239 (74) = happyShift action_72+action_239 (86) = happyShift action_73+action_239 (114) = happyShift action_34+action_239 (115) = happyShift action_74+action_239 (116) = happyShift action_46+action_239 (117) = happyShift action_75+action_239 (118) = happyShift action_63+action_239 (36) = happyGoto action_65+action_239 (37) = happyGoto action_66+action_239 (38) = happyGoto action_67+action_239 (39) = happyGoto action_68+action_239 (40) = happyGoto action_76+action_239 (62) = happyGoto action_246+action_239 (63) = happyGoto action_78+action_239 (64) = happyGoto action_79+action_239 _ = happyFail (happyExpListPerState 239)++action_240 (86) = happyShift action_62+action_240 (114) = happyShift action_34+action_240 (118) = happyShift action_63+action_240 (36) = happyGoto action_55+action_240 (40) = happyGoto action_56+action_240 (48) = happyGoto action_57+action_240 (49) = happyGoto action_245+action_240 (50) = happyGoto action_59+action_240 _ = happyReduce_71++action_241 (75) = happyShift action_244+action_241 _ = happyFail (happyExpListPerState 241)++action_242 (78) = happyShift action_243+action_242 _ = happyFail (happyExpListPerState 242)++action_243 (86) = happyShift action_251+action_243 _ = happyFail (happyExpListPerState 243)++action_244 _ = happyReduce_83++action_245 _ = happyReduce_53++action_246 _ = happyReduce_65++action_247 (101) = happyShift action_54+action_247 (69) = happyGoto action_250+action_247 _ = happyReduce_122++action_248 (86) = happyShift action_62+action_248 (114) = happyShift action_34+action_248 (118) = happyShift action_63+action_248 (36) = happyGoto action_55+action_248 (40) = happyGoto action_56+action_248 (48) = happyGoto action_57+action_248 (49) = happyGoto action_249+action_248 (50) = happyGoto action_59+action_248 _ = happyReduce_71++action_249 _ = happyReduce_56++action_250 _ = happyReduce_62++action_251 (115) = happyShift action_74+action_251 (37) = happyGoto action_99+action_251 (55) = happyGoto action_252+action_251 _ = happyReduce_86++action_252 (87) = happyShift action_253+action_252 _ = happyFail (happyExpListPerState 252)++action_253 (75) = happyShift action_254+action_253 _ = happyFail (happyExpListPerState 253)++action_254 _ = happyReduce_84++happyReduce_33 = happySpecReduce_1 36 happyReduction_33+happyReduction_33 (HappyTerminal (PT _ (TL happy_var_1)))+ = HappyAbsSyn36+ (happy_var_1+ )+happyReduction_33 _ = notHappyAtAll ++happyReduce_34 = happySpecReduce_1 37 happyReduction_34+happyReduction_34 (HappyTerminal (PT _ (TI happy_var_1)))+ = HappyAbsSyn37+ ((read (happy_var_1)) :: Integer+ )+happyReduction_34 _ = notHappyAtAll ++happyReduce_35 = happySpecReduce_1 38 happyReduction_35+happyReduction_35 (HappyTerminal (PT _ (TC happy_var_1)))+ = HappyAbsSyn38+ ((read (happy_var_1)) :: Char+ )+happyReduction_35 _ = notHappyAtAll ++happyReduce_36 = happySpecReduce_1 39 happyReduction_36+happyReduction_36 (HappyTerminal (PT _ (TD happy_var_1)))+ = HappyAbsSyn39+ ((read (happy_var_1)) :: Double+ )+happyReduction_36 _ = notHappyAtAll ++happyReduce_37 = happySpecReduce_1 40 happyReduction_37+happyReduction_37 (HappyTerminal happy_var_1)+ = HappyAbsSyn40+ (AbsBNF.Identifier (mkPosToken happy_var_1)+ )+happyReduction_37 _ = notHappyAtAll ++happyReduce_38 = happySpecReduce_1 41 happyReduction_38+happyReduction_38 (HappyAbsSyn43 happy_var_1)+ = HappyAbsSyn41+ (AbsBNF.LGr happy_var_1+ )+happyReduction_38 _ = notHappyAtAll ++happyReduce_39 = happySpecReduce_1 42 happyReduction_39+happyReduction_39 (HappyAbsSyn47 happy_var_1)+ = HappyAbsSyn42+ (AbsBNF.DefAll happy_var_1+ )+happyReduction_39 _ = notHappyAtAll ++happyReduce_40 = happySpecReduce_3 42 happyReduction_40+happyReduction_40 (HappyAbsSyn47 happy_var_3)+ _+ (HappyAbsSyn44 happy_var_1)+ = HappyAbsSyn42+ (AbsBNF.DefSome happy_var_1 happy_var_3+ )+happyReduction_40 _ _ _ = notHappyAtAll ++happyReduce_41 = happySpecReduce_2 42 happyReduction_41+happyReduction_41 (HappyAbsSyn44 happy_var_2)+ _+ = HappyAbsSyn42+ (AbsBNF.LDefView happy_var_2+ )+happyReduction_41 _ _ = notHappyAtAll ++happyReduce_42 = happySpecReduce_0 43 happyReduction_42+happyReduction_42 = HappyAbsSyn43+ ([]+ )++happyReduce_43 = happySpecReduce_1 43 happyReduction_43+happyReduction_43 (HappyAbsSyn42 happy_var_1)+ = HappyAbsSyn43+ ((:[]) happy_var_1+ )+happyReduction_43 _ = notHappyAtAll ++happyReduce_44 = happySpecReduce_3 43 happyReduction_44+happyReduction_44 (HappyAbsSyn43 happy_var_3)+ _+ (HappyAbsSyn42 happy_var_1)+ = HappyAbsSyn43+ ((:) happy_var_1 happy_var_3+ )+happyReduction_44 _ _ _ = notHappyAtAll ++happyReduce_45 = happySpecReduce_2 43 happyReduction_45+happyReduction_45 (HappyAbsSyn43 happy_var_2)+ _+ = HappyAbsSyn43+ (happy_var_2+ )+happyReduction_45 _ _ = notHappyAtAll ++happyReduce_46 = happySpecReduce_1 44 happyReduction_46+happyReduction_46 (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn44+ ((:[]) happy_var_1+ )+happyReduction_46 _ = notHappyAtAll ++happyReduce_47 = happySpecReduce_3 44 happyReduction_47+happyReduction_47 (HappyAbsSyn44 happy_var_3)+ _+ (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn44+ ((:) happy_var_1 happy_var_3+ )+happyReduction_47 _ _ _ = notHappyAtAll ++happyReduce_48 = happySpecReduce_1 45 happyReduction_48+happyReduction_48 (HappyAbsSyn46 happy_var_1)+ = HappyAbsSyn45+ (AbsBNF.Grammar happy_var_1+ )+happyReduction_48 _ = notHappyAtAll ++happyReduce_49 = happySpecReduce_0 46 happyReduction_49+happyReduction_49 = HappyAbsSyn46+ ([]+ )++happyReduce_50 = happySpecReduce_1 46 happyReduction_50+happyReduction_50 (HappyAbsSyn47 happy_var_1)+ = HappyAbsSyn46+ ((:[]) happy_var_1+ )+happyReduction_50 _ = notHappyAtAll ++happyReduce_51 = happySpecReduce_3 46 happyReduction_51+happyReduction_51 (HappyAbsSyn46 happy_var_3)+ _+ (HappyAbsSyn47 happy_var_1)+ = HappyAbsSyn46+ ((:) happy_var_1 happy_var_3+ )+happyReduction_51 _ _ _ = notHappyAtAll ++happyReduce_52 = happySpecReduce_2 46 happyReduction_52+happyReduction_52 (HappyAbsSyn46 happy_var_2)+ _+ = HappyAbsSyn46+ (happy_var_2+ )+happyReduction_52 _ _ = notHappyAtAll ++happyReduce_53 = happyReduce 5 47 happyReduction_53+happyReduction_53 ((HappyAbsSyn49 happy_var_5) `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn50 happy_var_3) `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn51 happy_var_1) `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Rule happy_var_1 happy_var_3 happy_var_5+ ) `HappyStk` happyRest++happyReduce_54 = happySpecReduce_2 47 happyReduction_54+happyReduction_54 (HappyAbsSyn36 happy_var_2)+ _+ = HappyAbsSyn47+ (AbsBNF.Comment happy_var_2+ )+happyReduction_54 _ _ = notHappyAtAll ++happyReduce_55 = happySpecReduce_3 47 happyReduction_55+happyReduction_55 (HappyAbsSyn36 happy_var_3)+ (HappyAbsSyn36 happy_var_2)+ _+ = HappyAbsSyn47+ (AbsBNF.Comments happy_var_2 happy_var_3+ )+happyReduction_55 _ _ _ = notHappyAtAll ++happyReduce_56 = happyReduce 6 47 happyReduction_56+happyReduction_56 ((HappyAbsSyn49 happy_var_6) `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn50 happy_var_4) `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn51 happy_var_2) `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Internal happy_var_2 happy_var_4 happy_var_6+ ) `HappyStk` happyRest++happyReduce_57 = happySpecReduce_3 47 happyReduction_57+happyReduction_57 (HappyAbsSyn70 happy_var_3)+ (HappyAbsSyn40 happy_var_2)+ _+ = HappyAbsSyn47+ (AbsBNF.Token happy_var_2 happy_var_3+ )+happyReduction_57 _ _ _ = notHappyAtAll ++happyReduce_58 = happyReduce 4 47 happyReduction_58+happyReduction_58 ((HappyAbsSyn70 happy_var_4) `HappyStk`+ (HappyAbsSyn40 happy_var_3) `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.PosToken happy_var_3 happy_var_4+ ) `HappyStk` happyRest++happyReduce_59 = happySpecReduce_2 47 happyReduction_59+happyReduction_59 (HappyAbsSyn44 happy_var_2)+ _+ = HappyAbsSyn47+ (AbsBNF.Entryp happy_var_2+ )+happyReduction_59 _ _ = notHappyAtAll ++happyReduce_60 = happyReduce 4 47 happyReduction_60+happyReduction_60 ((HappyAbsSyn36 happy_var_4) `HappyStk`+ (HappyAbsSyn50 happy_var_3) `HappyStk`+ (HappyAbsSyn69 happy_var_2) `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Separator happy_var_2 happy_var_3 happy_var_4+ ) `HappyStk` happyRest++happyReduce_61 = happyReduce 4 47 happyReduction_61+happyReduction_61 ((HappyAbsSyn36 happy_var_4) `HappyStk`+ (HappyAbsSyn50 happy_var_3) `HappyStk`+ (HappyAbsSyn69 happy_var_2) `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Terminator happy_var_2 happy_var_3 happy_var_4+ ) `HappyStk` happyRest++happyReduce_62 = happyReduce 6 47 happyReduction_62+happyReduction_62 ((HappyAbsSyn69 happy_var_6) `HappyStk`+ (HappyAbsSyn60 happy_var_5) `HappyStk`+ (HappyAbsSyn36 happy_var_4) `HappyStk`+ (HappyAbsSyn36 happy_var_3) `HappyStk`+ (HappyAbsSyn50 happy_var_2) `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Delimiters happy_var_2 happy_var_3 happy_var_4 happy_var_5 happy_var_6+ ) `HappyStk` happyRest++happyReduce_63 = happySpecReduce_3 47 happyReduction_63+happyReduction_63 (HappyAbsSyn37 happy_var_3)+ (HappyAbsSyn40 happy_var_2)+ _+ = HappyAbsSyn47+ (AbsBNF.Coercions happy_var_2 happy_var_3+ )+happyReduction_63 _ _ _ = notHappyAtAll ++happyReduce_64 = happyReduce 4 47 happyReduction_64+happyReduction_64 ((HappyAbsSyn68 happy_var_4) `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn40 happy_var_2) `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Rules happy_var_2 happy_var_4+ ) `HappyStk` happyRest++happyReduce_65 = happyReduce 5 47 happyReduction_65+happyReduction_65 ((HappyAbsSyn62 happy_var_5) `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn59 happy_var_3) `HappyStk`+ (HappyAbsSyn40 happy_var_2) `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn47+ (AbsBNF.Function happy_var_2 happy_var_3 happy_var_5+ ) `HappyStk` happyRest++happyReduce_66 = happySpecReduce_2 47 happyReduction_66+happyReduction_66 (HappyAbsSyn61 happy_var_2)+ _+ = HappyAbsSyn47+ (AbsBNF.Layout happy_var_2+ )+happyReduction_66 _ _ = notHappyAtAll ++happyReduce_67 = happySpecReduce_3 47 happyReduction_67+happyReduction_67 (HappyAbsSyn61 happy_var_3)+ _+ _+ = HappyAbsSyn47+ (AbsBNF.LayoutStop happy_var_3+ )+happyReduction_67 _ _ _ = notHappyAtAll ++happyReduce_68 = happySpecReduce_2 47 happyReduction_68+happyReduction_68 _+ _+ = HappyAbsSyn47+ (AbsBNF.LayoutTop+ )++happyReduce_69 = happySpecReduce_1 48 happyReduction_69+happyReduction_69 (HappyAbsSyn36 happy_var_1)+ = HappyAbsSyn48+ (AbsBNF.Terminal happy_var_1+ )+happyReduction_69 _ = notHappyAtAll ++happyReduce_70 = happySpecReduce_1 48 happyReduction_70+happyReduction_70 (HappyAbsSyn50 happy_var_1)+ = HappyAbsSyn48+ (AbsBNF.NTerminal happy_var_1+ )+happyReduction_70 _ = notHappyAtAll ++happyReduce_71 = happySpecReduce_0 49 happyReduction_71+happyReduction_71 = HappyAbsSyn49+ ([]+ )++happyReduce_72 = happySpecReduce_2 49 happyReduction_72+happyReduction_72 (HappyAbsSyn49 happy_var_2)+ (HappyAbsSyn48 happy_var_1)+ = HappyAbsSyn49+ ((:) happy_var_1 happy_var_2+ )+happyReduction_72 _ _ = notHappyAtAll ++happyReduce_73 = happySpecReduce_3 50 happyReduction_73+happyReduction_73 _+ (HappyAbsSyn50 happy_var_2)+ _+ = HappyAbsSyn50+ (AbsBNF.ListCat happy_var_2+ )+happyReduction_73 _ _ _ = notHappyAtAll ++happyReduce_74 = happySpecReduce_1 50 happyReduction_74+happyReduction_74 (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn50+ (AbsBNF.IdCat happy_var_1+ )+happyReduction_74 _ = notHappyAtAll ++happyReduce_75 = happySpecReduce_1 51 happyReduction_75+happyReduction_75 (HappyAbsSyn52 happy_var_1)+ = HappyAbsSyn51+ (AbsBNF.LabNoP happy_var_1+ )+happyReduction_75 _ = notHappyAtAll ++happyReduce_76 = happySpecReduce_2 51 happyReduction_76+happyReduction_76 (HappyAbsSyn57 happy_var_2)+ (HappyAbsSyn52 happy_var_1)+ = HappyAbsSyn51+ (AbsBNF.LabP happy_var_1 happy_var_2+ )+happyReduction_76 _ _ = notHappyAtAll ++happyReduce_77 = happySpecReduce_3 51 happyReduction_77+happyReduction_77 (HappyAbsSyn57 happy_var_3)+ (HappyAbsSyn52 happy_var_2)+ (HappyAbsSyn52 happy_var_1)+ = HappyAbsSyn51+ (AbsBNF.LabPF happy_var_1 happy_var_2 happy_var_3+ )+happyReduction_77 _ _ _ = notHappyAtAll ++happyReduce_78 = happySpecReduce_2 51 happyReduction_78+happyReduction_78 (HappyAbsSyn52 happy_var_2)+ (HappyAbsSyn52 happy_var_1)+ = HappyAbsSyn51+ (AbsBNF.LabF happy_var_1 happy_var_2+ )+happyReduction_78 _ _ = notHappyAtAll ++happyReduce_79 = happySpecReduce_1 52 happyReduction_79+happyReduction_79 (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn52+ (AbsBNF.Id happy_var_1+ )+happyReduction_79 _ = notHappyAtAll ++happyReduce_80 = happySpecReduce_1 52 happyReduction_80+happyReduction_80 _+ = HappyAbsSyn52+ (AbsBNF.Wild+ )++happyReduce_81 = happySpecReduce_2 52 happyReduction_81+happyReduction_81 _+ _+ = HappyAbsSyn52+ (AbsBNF.ListE+ )++happyReduce_82 = happySpecReduce_3 52 happyReduction_82+happyReduction_82 _+ _+ _+ = HappyAbsSyn52+ (AbsBNF.ListCons+ )++happyReduce_83 = happyReduce 5 52 happyReduction_83+happyReduction_83 (_ `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn52+ (AbsBNF.ListOne+ ) `HappyStk` happyRest++happyReduce_84 = happyReduce 9 53 happyReduction_84+happyReduction_84 (_ `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn55 happy_var_7) `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ (HappyAbsSyn56 happy_var_3) `HappyStk`+ _ `HappyStk`+ _ `HappyStk`+ happyRest)+ = HappyAbsSyn53+ (AbsBNF.ProfIt happy_var_3 happy_var_7+ ) `HappyStk` happyRest++happyReduce_85 = happySpecReduce_3 54 happyReduction_85+happyReduction_85 _+ (HappyAbsSyn55 happy_var_2)+ _+ = HappyAbsSyn54+ (AbsBNF.Ints happy_var_2+ )+happyReduction_85 _ _ _ = notHappyAtAll ++happyReduce_86 = happySpecReduce_0 55 happyReduction_86+happyReduction_86 = HappyAbsSyn55+ ([]+ )++happyReduce_87 = happySpecReduce_1 55 happyReduction_87+happyReduction_87 (HappyAbsSyn37 happy_var_1)+ = HappyAbsSyn55+ ((:[]) happy_var_1+ )+happyReduction_87 _ = notHappyAtAll ++happyReduce_88 = happySpecReduce_3 55 happyReduction_88+happyReduction_88 (HappyAbsSyn55 happy_var_3)+ _+ (HappyAbsSyn37 happy_var_1)+ = HappyAbsSyn55+ ((:) happy_var_1 happy_var_3+ )+happyReduction_88 _ _ _ = notHappyAtAll ++happyReduce_89 = happySpecReduce_0 56 happyReduction_89+happyReduction_89 = HappyAbsSyn56+ ([]+ )++happyReduce_90 = happySpecReduce_1 56 happyReduction_90+happyReduction_90 (HappyAbsSyn54 happy_var_1)+ = HappyAbsSyn56+ ((:[]) happy_var_1+ )+happyReduction_90 _ = notHappyAtAll ++happyReduce_91 = happySpecReduce_3 56 happyReduction_91+happyReduction_91 (HappyAbsSyn56 happy_var_3)+ _+ (HappyAbsSyn54 happy_var_1)+ = HappyAbsSyn56+ ((:) happy_var_1 happy_var_3+ )+happyReduction_91 _ _ _ = notHappyAtAll ++happyReduce_92 = happySpecReduce_1 57 happyReduction_92+happyReduction_92 (HappyAbsSyn53 happy_var_1)+ = HappyAbsSyn57+ ((:[]) happy_var_1+ )+happyReduction_92 _ = notHappyAtAll ++happyReduce_93 = happySpecReduce_2 57 happyReduction_93+happyReduction_93 (HappyAbsSyn57 happy_var_2)+ (HappyAbsSyn53 happy_var_1)+ = HappyAbsSyn57+ ((:) happy_var_1 happy_var_2+ )+happyReduction_93 _ _ = notHappyAtAll ++happyReduce_94 = happySpecReduce_1 58 happyReduction_94+happyReduction_94 (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn58+ (AbsBNF.Arg happy_var_1+ )+happyReduction_94 _ = notHappyAtAll ++happyReduce_95 = happySpecReduce_0 59 happyReduction_95+happyReduction_95 = HappyAbsSyn59+ ([]+ )++happyReduce_96 = happySpecReduce_2 59 happyReduction_96+happyReduction_96 (HappyAbsSyn59 happy_var_2)+ (HappyAbsSyn58 happy_var_1)+ = HappyAbsSyn59+ ((:) happy_var_1 happy_var_2+ )+happyReduction_96 _ _ = notHappyAtAll ++happyReduce_97 = happySpecReduce_0 60 happyReduction_97+happyReduction_97 = HappyAbsSyn60+ (AbsBNF.SepNone+ )++happyReduce_98 = happySpecReduce_2 60 happyReduction_98+happyReduction_98 (HappyAbsSyn36 happy_var_2)+ _+ = HappyAbsSyn60+ (AbsBNF.SepTerm happy_var_2+ )+happyReduction_98 _ _ = notHappyAtAll ++happyReduce_99 = happySpecReduce_2 60 happyReduction_99+happyReduction_99 (HappyAbsSyn36 happy_var_2)+ _+ = HappyAbsSyn60+ (AbsBNF.SepSepar happy_var_2+ )+happyReduction_99 _ _ = notHappyAtAll ++happyReduce_100 = happySpecReduce_1 61 happyReduction_100+happyReduction_100 (HappyAbsSyn36 happy_var_1)+ = HappyAbsSyn61+ ((:[]) happy_var_1+ )+happyReduction_100 _ = notHappyAtAll ++happyReduce_101 = happySpecReduce_3 61 happyReduction_101+happyReduction_101 (HappyAbsSyn61 happy_var_3)+ _+ (HappyAbsSyn36 happy_var_1)+ = HappyAbsSyn61+ ((:) happy_var_1 happy_var_3+ )+happyReduction_101 _ _ _ = notHappyAtAll ++happyReduce_102 = happySpecReduce_3 62 happyReduction_102+happyReduction_102 (HappyAbsSyn62 happy_var_3)+ _+ (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.Cons happy_var_1 happy_var_3+ )+happyReduction_102 _ _ _ = notHappyAtAll ++happyReduce_103 = happySpecReduce_1 62 happyReduction_103+happyReduction_103 (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn62+ (happy_var_1+ )+happyReduction_103 _ = notHappyAtAll ++happyReduce_104 = happySpecReduce_2 63 happyReduction_104+happyReduction_104 (HappyAbsSyn65 happy_var_2)+ (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.App happy_var_1 happy_var_2+ )+happyReduction_104 _ _ = notHappyAtAll ++happyReduce_105 = happySpecReduce_1 63 happyReduction_105+happyReduction_105 (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn62+ (happy_var_1+ )+happyReduction_105 _ = notHappyAtAll ++happyReduce_106 = happySpecReduce_1 64 happyReduction_106+happyReduction_106 (HappyAbsSyn40 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.Var happy_var_1+ )+happyReduction_106 _ = notHappyAtAll ++happyReduce_107 = happySpecReduce_1 64 happyReduction_107+happyReduction_107 (HappyAbsSyn37 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.LitInt happy_var_1+ )+happyReduction_107 _ = notHappyAtAll ++happyReduce_108 = happySpecReduce_1 64 happyReduction_108+happyReduction_108 (HappyAbsSyn38 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.LitChar happy_var_1+ )+happyReduction_108 _ = notHappyAtAll ++happyReduce_109 = happySpecReduce_1 64 happyReduction_109+happyReduction_109 (HappyAbsSyn36 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.LitString happy_var_1+ )+happyReduction_109 _ = notHappyAtAll ++happyReduce_110 = happySpecReduce_1 64 happyReduction_110+happyReduction_110 (HappyAbsSyn39 happy_var_1)+ = HappyAbsSyn62+ (AbsBNF.LitDouble happy_var_1+ )+happyReduction_110 _ = notHappyAtAll ++happyReduce_111 = happySpecReduce_3 64 happyReduction_111+happyReduction_111 _+ (HappyAbsSyn65 happy_var_2)+ _+ = HappyAbsSyn62+ (AbsBNF.List happy_var_2+ )+happyReduction_111 _ _ _ = notHappyAtAll ++happyReduce_112 = happySpecReduce_3 64 happyReduction_112+happyReduction_112 _+ (HappyAbsSyn62 happy_var_2)+ _+ = HappyAbsSyn62+ (happy_var_2+ )+happyReduction_112 _ _ _ = notHappyAtAll ++happyReduce_113 = happySpecReduce_0 65 happyReduction_113+happyReduction_113 = HappyAbsSyn65+ ([]+ )++happyReduce_114 = happySpecReduce_1 65 happyReduction_114+happyReduction_114 (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn65+ ((:[]) happy_var_1+ )+happyReduction_114 _ = notHappyAtAll ++happyReduce_115 = happySpecReduce_3 65 happyReduction_115+happyReduction_115 (HappyAbsSyn65 happy_var_3)+ _+ (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn65+ ((:) happy_var_1 happy_var_3+ )+happyReduction_115 _ _ _ = notHappyAtAll ++happyReduce_116 = happySpecReduce_1 66 happyReduction_116+happyReduction_116 (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn65+ ((:[]) happy_var_1+ )+happyReduction_116 _ = notHappyAtAll ++happyReduce_117 = happySpecReduce_2 66 happyReduction_117+happyReduction_117 (HappyAbsSyn65 happy_var_2)+ (HappyAbsSyn62 happy_var_1)+ = HappyAbsSyn65+ ((:) happy_var_1 happy_var_2+ )+happyReduction_117 _ _ = notHappyAtAll ++happyReduce_118 = happySpecReduce_1 67 happyReduction_118+happyReduction_118 (HappyAbsSyn49 happy_var_1)+ = HappyAbsSyn67+ (AbsBNF.RHS happy_var_1+ )+happyReduction_118 _ = notHappyAtAll ++happyReduce_119 = happySpecReduce_1 68 happyReduction_119+happyReduction_119 (HappyAbsSyn67 happy_var_1)+ = HappyAbsSyn68+ ((:[]) happy_var_1+ )+happyReduction_119 _ = notHappyAtAll ++happyReduce_120 = happySpecReduce_3 68 happyReduction_120+happyReduction_120 (HappyAbsSyn68 happy_var_3)+ _+ (HappyAbsSyn67 happy_var_1)+ = HappyAbsSyn68+ ((:) happy_var_1 happy_var_3+ )+happyReduction_120 _ _ _ = notHappyAtAll ++happyReduce_121 = happySpecReduce_1 69 happyReduction_121+happyReduction_121 _+ = HappyAbsSyn69+ (AbsBNF.MNonempty+ )++happyReduce_122 = happySpecReduce_0 69 happyReduction_122+happyReduction_122 = HappyAbsSyn69+ (AbsBNF.MEmpty+ )++happyReduce_123 = happySpecReduce_3 70 happyReduction_123+happyReduction_123 (HappyAbsSyn70 happy_var_3)+ _+ (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.RAlt happy_var_1 happy_var_3+ )+happyReduction_123 _ _ _ = notHappyAtAll ++happyReduce_124 = happySpecReduce_1 70 happyReduction_124+happyReduction_124 (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (happy_var_1+ )+happyReduction_124 _ = notHappyAtAll ++happyReduce_125 = happySpecReduce_3 71 happyReduction_125+happyReduction_125 (HappyAbsSyn70 happy_var_3)+ _+ (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.RMinus happy_var_1 happy_var_3+ )+happyReduction_125 _ _ _ = notHappyAtAll ++happyReduce_126 = happySpecReduce_1 71 happyReduction_126+happyReduction_126 (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (happy_var_1+ )+happyReduction_126 _ = notHappyAtAll ++happyReduce_127 = happySpecReduce_2 72 happyReduction_127+happyReduction_127 (HappyAbsSyn70 happy_var_2)+ (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.RSeq happy_var_1 happy_var_2+ )+happyReduction_127 _ _ = notHappyAtAll ++happyReduce_128 = happySpecReduce_1 72 happyReduction_128+happyReduction_128 (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (happy_var_1+ )+happyReduction_128 _ = notHappyAtAll ++happyReduce_129 = happySpecReduce_2 73 happyReduction_129+happyReduction_129 _+ (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.RStar happy_var_1+ )+happyReduction_129 _ _ = notHappyAtAll ++happyReduce_130 = happySpecReduce_2 73 happyReduction_130+happyReduction_130 _+ (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.RPlus happy_var_1+ )+happyReduction_130 _ _ = notHappyAtAll ++happyReduce_131 = happySpecReduce_2 73 happyReduction_131+happyReduction_131 _+ (HappyAbsSyn70 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.ROpt happy_var_1+ )+happyReduction_131 _ _ = notHappyAtAll ++happyReduce_132 = happySpecReduce_1 73 happyReduction_132+happyReduction_132 _+ = HappyAbsSyn70+ (AbsBNF.REps+ )++happyReduce_133 = happySpecReduce_1 73 happyReduction_133+happyReduction_133 (HappyAbsSyn38 happy_var_1)+ = HappyAbsSyn70+ (AbsBNF.RChar happy_var_1+ )+happyReduction_133 _ = notHappyAtAll ++happyReduce_134 = happySpecReduce_3 73 happyReduction_134+happyReduction_134 _+ (HappyAbsSyn36 happy_var_2)+ _+ = HappyAbsSyn70+ (AbsBNF.RAlts happy_var_2+ )+happyReduction_134 _ _ _ = notHappyAtAll ++happyReduce_135 = happySpecReduce_3 73 happyReduction_135+happyReduction_135 _+ (HappyAbsSyn36 happy_var_2)+ _+ = HappyAbsSyn70+ (AbsBNF.RSeqs happy_var_2+ )+happyReduction_135 _ _ _ = notHappyAtAll ++happyReduce_136 = happySpecReduce_1 73 happyReduction_136+happyReduction_136 _+ = HappyAbsSyn70+ (AbsBNF.RDigit+ )++happyReduce_137 = happySpecReduce_1 73 happyReduction_137+happyReduction_137 _+ = HappyAbsSyn70+ (AbsBNF.RLetter+ )++happyReduce_138 = happySpecReduce_1 73 happyReduction_138+happyReduction_138 _+ = HappyAbsSyn70+ (AbsBNF.RUpper+ )++happyReduce_139 = happySpecReduce_1 73 happyReduction_139+happyReduction_139 _+ = HappyAbsSyn70+ (AbsBNF.RLower+ )++happyReduce_140 = happySpecReduce_1 73 happyReduction_140+happyReduction_140 _+ = HappyAbsSyn70+ (AbsBNF.RAny+ )++happyReduce_141 = happySpecReduce_3 73 happyReduction_141+happyReduction_141 _+ (HappyAbsSyn70 happy_var_2)+ _+ = HappyAbsSyn70+ (happy_var_2+ )+happyReduction_141 _ _ _ = notHappyAtAll ++happyNewToken action sts stk [] =+ action 119 119 notHappyAtAll (HappyState action) sts stk []++happyNewToken action sts stk (tk:tks) =+ let cont i = action i i tk (HappyState action) sts stk tks in+ case tk of {+ PT _ (TS _ 1) -> cont 74;+ PT _ (TS _ 2) -> cont 75;+ PT _ (TS _ 3) -> cont 76;+ PT _ (TS _ 4) -> cont 77;+ PT _ (TS _ 5) -> cont 78;+ PT _ (TS _ 6) -> cont 79;+ PT _ (TS _ 7) -> cont 80;+ PT _ (TS _ 8) -> cont 81;+ PT _ (TS _ 9) -> cont 82;+ PT _ (TS _ 10) -> cont 83;+ PT _ (TS _ 11) -> cont 84;+ PT _ (TS _ 12) -> cont 85;+ PT _ (TS _ 13) -> cont 86;+ PT _ (TS _ 14) -> cont 87;+ PT _ (TS _ 15) -> cont 88;+ PT _ (TS _ 16) -> cont 89;+ PT _ (TS _ 17) -> cont 90;+ PT _ (TS _ 18) -> cont 91;+ PT _ (TS _ 19) -> cont 92;+ PT _ (TS _ 20) -> cont 93;+ PT _ (TS _ 21) -> cont 94;+ PT _ (TS _ 22) -> cont 95;+ PT _ (TS _ 23) -> cont 96;+ PT _ (TS _ 24) -> cont 97;+ PT _ (TS _ 25) -> cont 98;+ PT _ (TS _ 26) -> cont 99;+ PT _ (TS _ 27) -> cont 100;+ PT _ (TS _ 28) -> cont 101;+ PT _ (TS _ 29) -> cont 102;+ PT _ (TS _ 30) -> cont 103;+ PT _ (TS _ 31) -> cont 104;+ PT _ (TS _ 32) -> cont 105;+ PT _ (TS _ 33) -> cont 106;+ PT _ (TS _ 34) -> cont 107;+ PT _ (TS _ 35) -> cont 108;+ PT _ (TS _ 36) -> cont 109;+ PT _ (TS _ 37) -> cont 110;+ PT _ (TS _ 38) -> cont 111;+ PT _ (TS _ 39) -> cont 112;+ PT _ (TS _ 40) -> cont 113;+ PT _ (TL happy_dollar_dollar) -> cont 114;+ PT _ (TI happy_dollar_dollar) -> cont 115;+ PT _ (TC happy_dollar_dollar) -> cont 116;+ PT _ (TD happy_dollar_dollar) -> cont 117;+ PT _ (T_Identifier _) -> cont 118;+ _ -> happyError' ((tk:tks), [])+ }++happyError_ explist 119 tk tks = happyError' (tks, explist)+happyError_ explist _ tk tks = happyError' ((tk:tks), explist)++happyThen :: () => Either String a -> (a -> Either String b) -> Either String b+happyThen = ((>>=))+happyReturn :: () => a -> Either String a+happyReturn = (return)+happyThen1 m k tks = ((>>=)) m (\a -> k a tks)+happyReturn1 :: () => a -> b -> Either String a+happyReturn1 = \a tks -> (return) a+happyError' :: () => ([(Token)], [Prelude.String]) -> Either String a+happyError' = (\(tokens, _) -> happyError tokens)+pLGrammar tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_0 tks) (\x -> case x of {HappyAbsSyn41 z -> happyReturn z; _other -> notHappyAtAll })++pLDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_1 tks) (\x -> case x of {HappyAbsSyn42 z -> happyReturn z; _other -> notHappyAtAll })++pListLDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_2 tks) (\x -> case x of {HappyAbsSyn43 z -> happyReturn z; _other -> notHappyAtAll })++pListIdentifier tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_3 tks) (\x -> case x of {HappyAbsSyn44 z -> happyReturn z; _other -> notHappyAtAll })++pGrammar tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_4 tks) (\x -> case x of {HappyAbsSyn45 z -> happyReturn z; _other -> notHappyAtAll })++pListDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_5 tks) (\x -> case x of {HappyAbsSyn46 z -> happyReturn z; _other -> notHappyAtAll })++pDef tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_6 tks) (\x -> case x of {HappyAbsSyn47 z -> happyReturn z; _other -> notHappyAtAll })++pItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_7 tks) (\x -> case x of {HappyAbsSyn48 z -> happyReturn z; _other -> notHappyAtAll })++pListItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_8 tks) (\x -> case x of {HappyAbsSyn49 z -> happyReturn z; _other -> notHappyAtAll })++pCat tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_9 tks) (\x -> case x of {HappyAbsSyn50 z -> happyReturn z; _other -> notHappyAtAll })++pLabel tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_10 tks) (\x -> case x of {HappyAbsSyn51 z -> happyReturn z; _other -> notHappyAtAll })++pLabelId tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_11 tks) (\x -> case x of {HappyAbsSyn52 z -> happyReturn z; _other -> notHappyAtAll })++pProfItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_12 tks) (\x -> case x of {HappyAbsSyn53 z -> happyReturn z; _other -> notHappyAtAll })++pIntList tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_13 tks) (\x -> case x of {HappyAbsSyn54 z -> happyReturn z; _other -> notHappyAtAll })++pListInteger tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_14 tks) (\x -> case x of {HappyAbsSyn55 z -> happyReturn z; _other -> notHappyAtAll })++pListIntList tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_15 tks) (\x -> case x of {HappyAbsSyn56 z -> happyReturn z; _other -> notHappyAtAll })++pListProfItem tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_16 tks) (\x -> case x of {HappyAbsSyn57 z -> happyReturn z; _other -> notHappyAtAll })++pArg tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_17 tks) (\x -> case x of {HappyAbsSyn58 z -> happyReturn z; _other -> notHappyAtAll })++pListArg tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_18 tks) (\x -> case x of {HappyAbsSyn59 z -> happyReturn z; _other -> notHappyAtAll })++pSeparation tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_19 tks) (\x -> case x of {HappyAbsSyn60 z -> happyReturn z; _other -> notHappyAtAll })++pListString tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_20 tks) (\x -> case x of {HappyAbsSyn61 z -> happyReturn z; _other -> notHappyAtAll })++pExp tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_21 tks) (\x -> case x of {HappyAbsSyn62 z -> happyReturn z; _other -> notHappyAtAll })++pExp1 tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_22 tks) (\x -> case x of {HappyAbsSyn62 z -> happyReturn z; _other -> notHappyAtAll })++pExp2 tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_23 tks) (\x -> case x of {HappyAbsSyn62 z -> happyReturn z; _other -> notHappyAtAll })++pListExp tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_24 tks) (\x -> case x of {HappyAbsSyn65 z -> happyReturn z; _other -> notHappyAtAll })++pListExp2 tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_25 tks) (\x -> case x of {HappyAbsSyn65 z -> happyReturn z; _other -> notHappyAtAll })++pRHS tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_26 tks) (\x -> case x of {HappyAbsSyn67 z -> happyReturn z; _other -> notHappyAtAll })++pListRHS tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_27 tks) (\x -> case x of {HappyAbsSyn68 z -> happyReturn z; _other -> notHappyAtAll })++pMinimumSize tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_28 tks) (\x -> case x of {HappyAbsSyn69 z -> happyReturn z; _other -> notHappyAtAll })++pReg tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_29 tks) (\x -> case x of {HappyAbsSyn70 z -> happyReturn z; _other -> notHappyAtAll })++pReg1 tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_30 tks) (\x -> case x of {HappyAbsSyn70 z -> happyReturn z; _other -> notHappyAtAll })++pReg2 tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_31 tks) (\x -> case x of {HappyAbsSyn70 z -> happyReturn z; _other -> notHappyAtAll })++pReg3 tks = happySomeParser where+ happySomeParser = happyThen (happyParse action_32 tks) (\x -> case x of {HappyAbsSyn70 z -> happyReturn z; _other -> notHappyAtAll })++happySeq = happyDontSeq+++happyError :: [Token] -> Either String a+happyError ts = Left $+ "syntax error at " ++ tokenPos ts +++ case ts of+ [] -> []+ [Err _] -> " due to lexer error"+ t:_ -> " before `" ++ (prToken t) ++ "'"++myLexer = tokens+{-# LINE 1 "templates/GenericTemplate.hs" #-}+-- $Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp $+++++++++++++++++++++++++++++++++++++++++++data Happy_IntList = HappyCons Prelude.Int Happy_IntList+++++++++++++++++++++++++++++++++++++++++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 ERROR_TOK, 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 (1) tk st sts (_ `HappyStk` ans `HappyStk` _) =+ happyReturn1 ans+happyAccept j tk st sts (HappyStk ans _) = + (happyReturn1 ans)++-----------------------------------------------------------------------------+-- Arrays only: do the next action++++++++++++++++++++++++++++++++++++++++++indexShortOffAddr arr off = arr Happy_Data_Array.! off+++{-# INLINE happyLt #-}+happyLt x y = (x Prelude.< y)+++++++readArrayBit arr bit =+ Bits.testBit (indexShortOffAddr arr (bit `Prelude.div` 16)) (bit `Prelude.mod` 16)+++++++-----------------------------------------------------------------------------+-- HappyState data type (not arrays)++++newtype HappyState b c = HappyState+ (Prelude.Int -> -- token number+ Prelude.Int -> -- token number (yes, again)+ b -> -- token semantic value+ HappyState b c -> -- current state+ [HappyState b c] -> -- state stack+ c)++++-----------------------------------------------------------------------------+-- Shifting a token++happyShift new_state (1) tk st sts stk@(x `HappyStk` _) =+ let i = (case x of { HappyErrorToken (i) -> i }) in+-- trace "shifting the error token" $+ new_state i i tk (HappyState (new_state)) ((st):(sts)) (stk)++happyShift new_state i tk st sts stk =+ happyNewToken new_state ((st):(sts)) ((HappyTerminal (tk))`HappyStk`stk)++-- happyReduce is specialised for the common cases.++happySpecReduce_0 i fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happySpecReduce_0 nt fn j tk st@((HappyState (action))) sts stk+ = action nt j tk st ((st):(sts)) (fn `HappyStk` stk)++happySpecReduce_1 i fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happySpecReduce_1 nt fn j tk _ sts@(((st@(HappyState (action))):(_))) (v1`HappyStk`stk')+ = let r = fn v1 in+ happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_2 i fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happySpecReduce_2 nt fn j tk _ ((_):(sts@(((st@(HappyState (action))):(_))))) (v1`HappyStk`v2`HappyStk`stk')+ = let r = fn v1 v2 in+ happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happySpecReduce_3 i fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happySpecReduce_3 nt fn j tk _ ((_):(((_):(sts@(((st@(HappyState (action))):(_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')+ = let r = fn v1 v2 v3 in+ happySeq r (action nt j tk st sts (r `HappyStk` stk'))++happyReduce k i fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happyReduce k nt fn j tk st sts stk+ = case happyDrop (k Prelude.- ((1) :: Prelude.Int)) sts of+ sts1@(((st1@(HappyState (action))):(_))) ->+ let r = fn stk in -- it doesn't hurt to always seq here...+ happyDoSeq r (action nt j tk st1 sts1 r)++happyMonadReduce k nt fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happyMonadReduce k nt fn j tk st sts stk =+ case happyDrop k ((st):(sts)) of+ sts1@(((st1@(HappyState (action))):(_))) ->+ let drop_stk = happyDropStk k stk in+ happyThen1 (fn stk tk) (\r -> action nt j tk st1 sts1 (r `HappyStk` drop_stk))++happyMonad2Reduce k nt fn (1) tk st sts stk+ = happyFail [] (1) tk st sts stk+happyMonad2Reduce k nt fn j tk st sts stk =+ case happyDrop k ((st):(sts)) of+ sts1@(((st1@(HappyState (action))):(_))) ->+ let drop_stk = happyDropStk k stk++++++ _ = nt :: Prelude.Int+ new_state = action++ in+ happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))++happyDrop (0) l = l+happyDrop n ((_):(t)) = happyDrop (n Prelude.- ((1) :: Prelude.Int)) t++happyDropStk (0) l = l+happyDropStk n (x `HappyStk` xs) = happyDropStk (n Prelude.- ((1)::Prelude.Int)) xs++-----------------------------------------------------------------------------+-- Moving to a new state after a reduction++++++++++happyGoto action j tk st = action j j tk (HappyState action)+++-----------------------------------------------------------------------------+-- Error recovery (ERROR_TOK is the error token)++-- parse error if we are in recovery and we fail again+happyFail explist (1) tk old_st _ stk@(x `HappyStk` _) =+ let i = (case x of { HappyErrorToken (i) -> i }) in+-- trace "failing" $ + happyError_ explist 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 ERROR_TOK tk old_st CONS(HAPPYSTATE(action),sts) + (saved_tok `HappyStk` _ `HappyStk` stk) =+-- trace ("discarding state, depth " ++ show (length stk)) $+ DO_ACTION(action,ERROR_TOK,tk,sts,(saved_tok`HappyStk`stk))+-}++-- Enter error recovery: generate an error token,+-- save the old token and carry on.+happyFail explist i tk (HappyState (action)) sts stk =+-- trace "entering error recovery" $+ action (1) (1) tk (HappyState (action)) sts ((HappyErrorToken (i)) `HappyStk` stk)++-- Internal happy errors:++notHappyAtAll :: a+notHappyAtAll = Prelude.error "Internal Happy error\n"++-----------------------------------------------------------------------------+-- Hack to get the typechecker to accept our action functions++++++++-----------------------------------------------------------------------------+-- 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 `Prelude.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 happyShift #-}+{-# NOINLINE happySpecReduce_0 #-}+{-# NOINLINE happySpecReduce_1 #-}+{-# NOINLINE happySpecReduce_2 #-}+{-# NOINLINE happySpecReduce_3 #-}+{-# NOINLINE happyReduce #-}+{-# NOINLINE happyMonadReduce #-}+{-# NOINLINE happyGoto #-}+{-# NOINLINE happyFail #-}++-- end of Happy Template.
src/ParBNF.y view
@@ -2,16 +2,14 @@ { {-# OPTIONS_GHC -fno-warn-incomplete-patterns -fno-warn-overlapping-patterns #-} module ParBNF where-import AbsBNF+import qualified AbsBNF import LexBNF-import ErrM- } %name pLGrammar LGrammar %name pLDef LDef %name pListLDef ListLDef-%name pListIdent ListIdent+%name pListIdentifier ListIdentifier %name pGrammar Grammar %name pListDef ListDef %name pDef Def@@ -37,12 +35,12 @@ %name pRHS RHS %name pListRHS ListRHS %name pMinimumSize MinimumSize-%name pReg2 Reg2+%name pReg Reg %name pReg1 Reg1+%name pReg2 Reg2 %name pReg3 Reg3-%name pReg Reg -- no lexer declaration-%monad { Err } { thenM } { returnM }+%monad { Either String } { (>>=) } { return } %tokentype {Token} %token '(' { PT _ (TS _ 1) }@@ -85,141 +83,175 @@ '{' { PT _ (TS _ 38) } '|' { PT _ (TS _ 39) } '}' { PT _ (TS _ 40) }- L_ident { PT _ (TV $$) } L_quoted { PT _ (TL $$) } L_integ { PT _ (TI $$) } L_charac { PT _ (TC $$) } L_doubl { PT _ (TD $$) }+ L_Identifier { PT _ (T_Identifier _) } %% -Ident :: { Ident }-Ident : L_ident { Ident $1 }- String :: { String }-String : L_quoted { $1 }+String : L_quoted { $1 } Integer :: { Integer }-Integer : L_integ { (read ( $1)) :: Integer }+Integer : L_integ { (read ($1)) :: Integer } Char :: { Char }-Char : L_charac { (read ( $1)) :: Char }+Char : L_charac { (read ($1)) :: Char } Double :: { Double }-Double : L_doubl { (read ( $1)) :: Double }+Double : L_doubl { (read ($1)) :: Double } -LGrammar :: { LGrammar }+Identifier :: { AbsBNF.Identifier}+Identifier : L_Identifier { AbsBNF.Identifier (mkPosToken $1) }++LGrammar :: { AbsBNF.LGrammar } LGrammar : ListLDef { AbsBNF.LGr $1 }-LDef :: { LDef }++LDef :: { AbsBNF.LDef } LDef : Def { AbsBNF.DefAll $1 }- | ListIdent ':' Def { AbsBNF.DefSome $1 $3 }- | 'views' ListIdent { AbsBNF.LDefView $2 }-ListLDef :: { [LDef] }+ | ListIdentifier ':' Def { AbsBNF.DefSome $1 $3 }+ | 'views' ListIdentifier { AbsBNF.LDefView $2 }++ListLDef :: { [AbsBNF.LDef] } ListLDef : {- empty -} { [] } | LDef { (:[]) $1 } | LDef ';' ListLDef { (:) $1 $3 } | ';' ListLDef { $2 }-ListIdent :: { [Ident] }-ListIdent : Ident { (:[]) $1 } | Ident ',' ListIdent { (:) $1 $3 }-Grammar :: { Grammar }++ListIdentifier :: { [AbsBNF.Identifier] }+ListIdentifier : Identifier { (:[]) $1 }+ | Identifier ',' ListIdentifier { (:) $1 $3 }++Grammar :: { AbsBNF.Grammar } Grammar : ListDef { AbsBNF.Grammar $1 }-ListDef :: { [Def] }++ListDef :: { [AbsBNF.Def] } ListDef : {- empty -} { [] } | Def { (:[]) $1 } | Def ';' ListDef { (:) $1 $3 } | ';' ListDef { $2 }-Def :: { Def }-Def : Label '.' Cat '::=' ListItem { AbsBNF.Rule $1 $3 (reverse $5) }++Def :: { AbsBNF.Def }+Def : Label '.' Cat '::=' ListItem { AbsBNF.Rule $1 $3 $5 } | 'comment' String { AbsBNF.Comment $2 } | 'comment' String String { AbsBNF.Comments $2 $3 }- | 'internal' Label '.' Cat '::=' ListItem { AbsBNF.Internal $2 $4 (reverse $6) }- | 'token' Ident Reg { AbsBNF.Token $2 $3 }- | 'position' 'token' Ident Reg { AbsBNF.PosToken $3 $4 }- | 'entrypoints' ListIdent { AbsBNF.Entryp $2 }+ | 'internal' Label '.' Cat '::=' ListItem { AbsBNF.Internal $2 $4 $6 }+ | 'token' Identifier Reg { AbsBNF.Token $2 $3 }+ | 'position' 'token' Identifier Reg { AbsBNF.PosToken $3 $4 }+ | 'entrypoints' ListIdentifier { AbsBNF.Entryp $2 } | 'separator' MinimumSize Cat String { AbsBNF.Separator $2 $3 $4 } | 'terminator' MinimumSize Cat String { AbsBNF.Terminator $2 $3 $4 } | 'delimiters' Cat String String Separation MinimumSize { AbsBNF.Delimiters $2 $3 $4 $5 $6 }- | 'coercions' Ident Integer { AbsBNF.Coercions $2 $3 }- | 'rules' Ident '::=' ListRHS { AbsBNF.Rules $2 $4 }- | 'define' Ident ListArg '=' Exp { AbsBNF.Function $2 (reverse $3) $5 }+ | 'coercions' Identifier Integer { AbsBNF.Coercions $2 $3 }+ | 'rules' Identifier '::=' ListRHS { AbsBNF.Rules $2 $4 }+ | 'define' Identifier ListArg '=' Exp { AbsBNF.Function $2 $3 $5 } | 'layout' ListString { AbsBNF.Layout $2 } | 'layout' 'stop' ListString { AbsBNF.LayoutStop $3 } | 'layout' 'toplevel' { AbsBNF.LayoutTop }-Item :: { Item }++Item :: { AbsBNF.Item } Item : String { AbsBNF.Terminal $1 } | Cat { AbsBNF.NTerminal $1 }-ListItem :: { [Item] }-ListItem : {- empty -} { [] } | ListItem Item { flip (:) $1 $2 }-Cat :: { Cat }-Cat : '[' Cat ']' { AbsBNF.ListCat $2 } | Ident { AbsBNF.IdCat $1 }-Label :: { Label }++ListItem :: { [AbsBNF.Item] }+ListItem : {- empty -} { [] } | Item ListItem { (:) $1 $2 }++Cat :: { AbsBNF.Cat }+Cat : '[' Cat ']' { AbsBNF.ListCat $2 }+ | Identifier { AbsBNF.IdCat $1 }++Label :: { AbsBNF.Label } Label : LabelId { AbsBNF.LabNoP $1 } | LabelId ListProfItem { AbsBNF.LabP $1 $2 } | LabelId LabelId ListProfItem { AbsBNF.LabPF $1 $2 $3 } | LabelId LabelId { AbsBNF.LabF $1 $2 }-LabelId :: { LabelId }-LabelId : Ident { AbsBNF.Id $1 }++LabelId :: { AbsBNF.LabelId }+LabelId : Identifier { AbsBNF.Id $1 } | '_' { AbsBNF.Wild } | '[' ']' { AbsBNF.ListE } | '(' ':' ')' { AbsBNF.ListCons } | '(' ':' '[' ']' ')' { AbsBNF.ListOne }-ProfItem :: { ProfItem }++ProfItem :: { AbsBNF.ProfItem } ProfItem : '(' '[' ListIntList ']' ',' '[' ListInteger ']' ')' { AbsBNF.ProfIt $3 $7 }-IntList :: { IntList }++IntList :: { AbsBNF.IntList } IntList : '[' ListInteger ']' { AbsBNF.Ints $2 }+ ListInteger :: { [Integer] } ListInteger : {- empty -} { [] } | Integer { (:[]) $1 } | Integer ',' ListInteger { (:) $1 $3 }-ListIntList :: { [IntList] }++ListIntList :: { [AbsBNF.IntList] } ListIntList : {- empty -} { [] } | IntList { (:[]) $1 } | IntList ',' ListIntList { (:) $1 $3 }-ListProfItem :: { [ProfItem] }++ListProfItem :: { [AbsBNF.ProfItem] } ListProfItem : ProfItem { (:[]) $1 } | ProfItem ListProfItem { (:) $1 $2 }-Arg :: { Arg }-Arg : Ident { AbsBNF.Arg $1 }-ListArg :: { [Arg] }-ListArg : {- empty -} { [] } | ListArg Arg { flip (:) $1 $2 }-Separation :: { Separation }++Arg :: { AbsBNF.Arg }+Arg : Identifier { AbsBNF.Arg $1 }++ListArg :: { [AbsBNF.Arg] }+ListArg : {- empty -} { [] } | Arg ListArg { (:) $1 $2 }++Separation :: { AbsBNF.Separation } Separation : {- empty -} { AbsBNF.SepNone } | 'terminator' String { AbsBNF.SepTerm $2 } | 'separator' String { AbsBNF.SepSepar $2 }+ ListString :: { [String] } ListString : String { (:[]) $1 } | String ',' ListString { (:) $1 $3 }-Exp :: { Exp }++Exp :: { AbsBNF.Exp } Exp : Exp1 ':' Exp { AbsBNF.Cons $1 $3 } | Exp1 { $1 }-Exp1 :: { Exp }-Exp1 : Ident ListExp2 { AbsBNF.App $1 $2 } | Exp2 { $1 }-Exp2 :: { Exp }-Exp2 : Ident { AbsBNF.Var $1 }++Exp1 :: { AbsBNF.Exp }+Exp1 : Identifier ListExp2 { AbsBNF.App $1 $2 } | Exp2 { $1 }++Exp2 :: { AbsBNF.Exp }+Exp2 : Identifier { AbsBNF.Var $1 } | Integer { AbsBNF.LitInt $1 } | Char { AbsBNF.LitChar $1 } | String { AbsBNF.LitString $1 } | Double { AbsBNF.LitDouble $1 } | '[' ListExp ']' { AbsBNF.List $2 } | '(' Exp ')' { $2 }-ListExp :: { [Exp] }++ListExp :: { [AbsBNF.Exp] } ListExp : {- empty -} { [] } | Exp { (:[]) $1 } | Exp ',' ListExp { (:) $1 $3 }-ListExp2 :: { [Exp] }++ListExp2 :: { [AbsBNF.Exp] } ListExp2 : Exp2 { (:[]) $1 } | Exp2 ListExp2 { (:) $1 $2 }-RHS :: { RHS }-RHS : ListItem { AbsBNF.RHS (reverse $1) }-ListRHS :: { [RHS] }++RHS :: { AbsBNF.RHS }+RHS : ListItem { AbsBNF.RHS $1 }++ListRHS :: { [AbsBNF.RHS] } ListRHS : RHS { (:[]) $1 } | RHS '|' ListRHS { (:) $1 $3 }-MinimumSize :: { MinimumSize }++MinimumSize :: { AbsBNF.MinimumSize } MinimumSize : 'nonempty' { AbsBNF.MNonempty } | {- empty -} { AbsBNF.MEmpty }-Reg2 :: { Reg }++Reg :: { AbsBNF.Reg }+Reg : Reg '|' Reg1 { AbsBNF.RAlt $1 $3 } | Reg1 { $1 }++Reg1 :: { AbsBNF.Reg }+Reg1 : Reg1 '-' Reg2 { AbsBNF.RMinus $1 $3 } | Reg2 { $1 }++Reg2 :: { AbsBNF.Reg } Reg2 : Reg2 Reg3 { AbsBNF.RSeq $1 $2 } | Reg3 { $1 }-Reg1 :: { Reg }-Reg1 : Reg1 '|' Reg2 { AbsBNF.RAlt $1 $3 }- | Reg2 '-' Reg2 { AbsBNF.RMinus $1 $3 }- | Reg2 { $1 }-Reg3 :: { Reg }++Reg3 :: { AbsBNF.Reg } Reg3 : Reg3 '*' { AbsBNF.RStar $1 } | Reg3 '+' { AbsBNF.RPlus $1 } | Reg3 '?' { AbsBNF.ROpt $1 }@@ -233,23 +265,15 @@ | 'lower' { AbsBNF.RLower } | 'char' { AbsBNF.RAny } | '(' Reg ')' { $2 }-Reg :: { Reg }-Reg : Reg1 { $1 } { -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 +++happyError :: [Token] -> Either String a+happyError ts = Left $+ "syntax error at " ++ tokenPos ts ++ case ts of [] -> [] [Err _] -> " due to lexer error"- t:_ -> " before `" ++ id(prToken t) ++ "'"+ t:_ -> " before `" ++ (prToken t) ++ "'" myLexer = tokens }
src/PrintBNF.hs view
@@ -31,12 +31,21 @@ "{" :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+ [";"] -> showChar ';' ";" :ts -> showChar ';' . new i . rend i ts t : ts@(p:_) | closingOrPunctuation p -> showString t . 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)+ new i = showChar '\n' . replicateS (2*i) (showChar ' ') . dropWhile isSpace+ space t s =+ case (all isSpace t', null spc, null rest) of+ (True , _ , True ) -> [] -- remove trailing space+ (False, _ , True ) -> t' -- remove trailing space+ (False, True, False) -> t' ++ ' ' : s -- add space if none+ _ -> t' ++ s+ where+ t' = showString t []+ (spc, rest) = span isSpace s closingOrPunctuation :: String -> Bool closingOrPunctuation [c] = c `elem` closerOrPunct@@ -91,8 +100,8 @@ instance Print Double where prt _ x = doc (shows x) -instance Print AbsBNF.Ident where- prt _ (AbsBNF.Ident i) = doc (showString i)+instance Print AbsBNF.Identifier where+ prt _ (AbsBNF.Identifier (_,i)) = doc $ showString $ i prtList _ [x] = concatD [prt 0 x] prtList _ (x:xs) = concatD [prt 0 x, doc (showString ","), prt 0 xs] @@ -103,8 +112,8 @@ instance Print AbsBNF.LDef where prt i e = case e of AbsBNF.DefAll def -> prPrec i 0 (concatD [prt 0 def])- AbsBNF.DefSome ids def -> prPrec i 0 (concatD [prt 0 ids, doc (showString ":"), prt 0 def])- AbsBNF.LDefView ids -> prPrec i 0 (concatD [doc (showString "views"), prt 0 ids])+ AbsBNF.DefSome identifiers def -> prPrec i 0 (concatD [prt 0 identifiers, doc (showString ":"), prt 0 def])+ AbsBNF.LDefView identifiers -> prPrec i 0 (concatD [doc (showString "views"), prt 0 identifiers]) prtList _ [] = concatD [] prtList _ [x] = concatD [prt 0 x] @@ -113,7 +122,7 @@ instance Print [AbsBNF.LDef] where prt = prtList -instance Print [AbsBNF.Ident] where+instance Print [AbsBNF.Identifier] where prt = prtList instance Print AbsBNF.Grammar where@@ -129,15 +138,15 @@ AbsBNF.Comment str -> prPrec i 0 (concatD [doc (showString "comment"), prt 0 str]) AbsBNF.Comments str1 str2 -> prPrec i 0 (concatD [doc (showString "comment"), prt 0 str1, prt 0 str2]) AbsBNF.Internal label cat items -> prPrec i 0 (concatD [doc (showString "internal"), prt 0 label, doc (showString "."), prt 0 cat, doc (showString "::="), prt 0 items])- AbsBNF.Token id reg -> prPrec i 0 (concatD [doc (showString "token"), prt 0 id, prt 0 reg])- AbsBNF.PosToken id reg -> prPrec i 0 (concatD [doc (showString "position"), doc (showString "token"), prt 0 id, prt 0 reg])- AbsBNF.Entryp ids -> prPrec i 0 (concatD [doc (showString "entrypoints"), prt 0 ids])+ AbsBNF.Token identifier reg -> prPrec i 0 (concatD [doc (showString "token"), prt 0 identifier, prt 0 reg])+ AbsBNF.PosToken identifier reg -> prPrec i 0 (concatD [doc (showString "position"), doc (showString "token"), prt 0 identifier, prt 0 reg])+ AbsBNF.Entryp identifiers -> prPrec i 0 (concatD [doc (showString "entrypoints"), prt 0 identifiers]) AbsBNF.Separator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "separator"), prt 0 minimumsize, prt 0 cat, prt 0 str]) AbsBNF.Terminator minimumsize cat str -> prPrec i 0 (concatD [doc (showString "terminator"), prt 0 minimumsize, prt 0 cat, prt 0 str]) AbsBNF.Delimiters cat str1 str2 separation minimumsize -> prPrec i 0 (concatD [doc (showString "delimiters"), prt 0 cat, prt 0 str1, prt 0 str2, prt 0 separation, prt 0 minimumsize])- AbsBNF.Coercions id n -> prPrec i 0 (concatD [doc (showString "coercions"), prt 0 id, prt 0 n])- AbsBNF.Rules id rhss -> prPrec i 0 (concatD [doc (showString "rules"), prt 0 id, doc (showString "::="), prt 0 rhss])- AbsBNF.Function id args exp -> prPrec i 0 (concatD [doc (showString "define"), prt 0 id, prt 0 args, doc (showString "="), prt 0 exp])+ AbsBNF.Coercions identifier n -> prPrec i 0 (concatD [doc (showString "coercions"), prt 0 identifier, prt 0 n])+ AbsBNF.Rules identifier rhss -> prPrec i 0 (concatD [doc (showString "rules"), prt 0 identifier, doc (showString "::="), prt 0 rhss])+ AbsBNF.Function identifier args exp -> prPrec i 0 (concatD [doc (showString "define"), prt 0 identifier, prt 0 args, doc (showString "="), prt 0 exp]) AbsBNF.Layout strs -> prPrec i 0 (concatD [doc (showString "layout"), prt 0 strs]) AbsBNF.LayoutStop strs -> prPrec i 0 (concatD [doc (showString "layout"), doc (showString "stop"), prt 0 strs]) AbsBNF.LayoutTop -> prPrec i 0 (concatD [doc (showString "layout"), doc (showString "toplevel")])@@ -159,7 +168,7 @@ instance Print AbsBNF.Cat where prt i e = case e of AbsBNF.ListCat cat -> prPrec i 0 (concatD [doc (showString "["), prt 0 cat, doc (showString "]")])- AbsBNF.IdCat id -> prPrec i 0 (concatD [prt 0 id])+ AbsBNF.IdCat identifier -> prPrec i 0 (concatD [prt 0 identifier]) instance Print AbsBNF.Label where prt i e = case e of@@ -170,7 +179,7 @@ instance Print AbsBNF.LabelId where prt i e = case e of- AbsBNF.Id id -> prPrec i 0 (concatD [prt 0 id])+ AbsBNF.Id identifier -> prPrec i 0 (concatD [prt 0 identifier]) AbsBNF.Wild -> prPrec i 0 (concatD [doc (showString "_")]) AbsBNF.ListE -> prPrec i 0 (concatD [doc (showString "["), doc (showString "]")]) AbsBNF.ListCons -> prPrec i 0 (concatD [doc (showString "("), doc (showString ":"), doc (showString ")")])@@ -200,7 +209,7 @@ instance Print AbsBNF.Arg where prt i e = case e of- AbsBNF.Arg id -> prPrec i 0 (concatD [prt 0 id])+ AbsBNF.Arg identifier -> prPrec i 0 (concatD [prt 0 identifier]) prtList _ [] = concatD [] prtList _ (x:xs) = concatD [prt 0 x, prt 0 xs] @@ -219,8 +228,8 @@ instance Print AbsBNF.Exp where prt i e = case e of AbsBNF.Cons exp1 exp2 -> prPrec i 0 (concatD [prt 1 exp1, doc (showString ":"), prt 0 exp2])- AbsBNF.App id exps -> prPrec i 1 (concatD [prt 0 id, prt 2 exps])- AbsBNF.Var id -> prPrec i 2 (concatD [prt 0 id])+ AbsBNF.App identifier exps -> prPrec i 1 (concatD [prt 0 identifier, prt 2 exps])+ AbsBNF.Var identifier -> prPrec i 2 (concatD [prt 0 identifier]) AbsBNF.LitInt n -> prPrec i 2 (concatD [prt 0 n]) AbsBNF.LitChar c -> prPrec i 2 (concatD [prt 0 c]) AbsBNF.LitString str -> prPrec i 2 (concatD [prt 0 str])@@ -251,9 +260,9 @@ instance Print AbsBNF.Reg where prt i e = case e of+ AbsBNF.RAlt reg1 reg2 -> prPrec i 0 (concatD [prt 0 reg1, doc (showString "|"), prt 1 reg2])+ AbsBNF.RMinus reg1 reg2 -> prPrec i 1 (concatD [prt 1 reg1, doc (showString "-"), prt 2 reg2]) AbsBNF.RSeq reg1 reg2 -> prPrec i 2 (concatD [prt 2 reg1, prt 3 reg2])- AbsBNF.RAlt reg1 reg2 -> prPrec i 1 (concatD [prt 1 reg1, doc (showString "|"), prt 2 reg2])- AbsBNF.RMinus reg1 reg2 -> prPrec i 1 (concatD [prt 2 reg1, doc (showString "-"), prt 2 reg2]) AbsBNF.RStar reg -> prPrec i 3 (concatD [prt 3 reg, doc (showString "*")]) AbsBNF.RPlus reg -> prPrec i 3 (concatD [prt 3 reg, doc (showString "+")]) AbsBNF.ROpt reg -> prPrec i 3 (concatD [prt 3 reg, doc (showString "?")])
+ stack-7.10.3.yaml view
@@ -0,0 +1,1 @@+resolver: lts-6.35
+ stack-8.0.2.yaml view
@@ -0,0 +1,1 @@+resolver: lts-9.21
+ stack-8.10.2.yaml view
@@ -0,0 +1,35 @@+resolver: ghc-8.10.2+compiler: ghc-8.10.2+# compiler-check: match-exact++extra-deps:+- alex-3.2.5+- happy-1.19.12+- semigroups-0.19.1++# For --test:+- HUnit-1.6.0.0+- QuickCheck-2.13.2+- ansi-terminal-0.11+- base-compat-0.11.2+- call-stack-0.2.0+- clock-0.8+- code-page-0.2+- colour-2.3.5+- doctest-0.17+- ghc-paths-0.1.0.12+- hspec-2.7.4+- hspec-core-2.7.4+- hspec-discover-2.7.4+- hspec-expectations-0.8.2+- primitive-0.7.1.0+- quickcheck-io-0.2.0+- random-1.1+- setenv-0.1.1.3+- splitmix-0.0.5+- syb-0.7.1+- temporary-1.3+- tf-random-0.5+++
+ stack-8.2.2.yaml view
@@ -0,0 +1,1 @@+resolver: lts-11.22
+ stack-8.4.4.yaml view
@@ -0,0 +1,1 @@+resolver: lts-12.26
+ stack-8.6.4.yaml view
@@ -0,0 +1,2 @@+resolver: lts-13.19+
+ stack-8.6.5.yaml view
@@ -0,0 +1,1 @@+resolver: lts-14.27
+ stack-8.8.2.yaml view
@@ -0,0 +1,2 @@+resolver: lts-15.3+
+ stack-8.8.3.yaml view
@@ -0,0 +1,2 @@+resolver: lts-15.8+
+ stack-8.8.4.yaml view
@@ -0,0 +1,4 @@+resolver: lts-16.2+compiler: ghc-8.8.4+compiler-check: match-exact+
test/BNFC/Backend/BaseSpec.hs view
@@ -1,15 +1,12 @@ {-# LANGUAGE FlexibleInstances, UndecidableInstances #-} {-# LANGUAGE ExtendedDefaultRules #-}+ module BNFC.Backend.BaseSpec where -import Control.Monad (liftM, liftM2)-import Data.List (intercalate)-import Data.Maybe (fromJust) import System.Directory-import System.FilePath ((<.>), takeBaseName) import System.IO.Temp (withSystemTempDirectory)+ import Test.Hspec-import Test.QuickCheck import BNFC.Backend.Base -- SUT
test/BNFC/Backend/HaskellSpec.hs view
@@ -5,7 +5,6 @@ import BNFC.Hspec import BNFC.Options hiding (Backend) import BNFC.Backend.Base-import Text.Printf (printf) import BNFC.Backend.Haskell -- SUT
test/BNFC/CFSpec.hs view
@@ -2,7 +2,7 @@ import Test.Hspec --- SUT:+-- SUT ("System/software Under Test"): import BNFC.CF spec :: Spec@@ -60,8 +60,8 @@ describe "getSeparatorByPrecedence" $ do let c0 = CoercCat "C" 0 c1 = CoercCat "C" 1- rule0 = Rule "(:)" (ListCat c0) [Left c0, Right ",", Left (ListCat c0)]- rule1 = Rule "(:)" (ListCat c1) [Left c1, Right ";", Left (ListCat c1)]+ rule0 = Rule (noPosition "(:)") (noPosition $ ListCat c0) [Left c0, Right ",", Left (ListCat c0)] Parsable+ rule1 = Rule (noPosition "(:)") (noPosition $ ListCat c1) [Left c1, Right ";", Left (ListCat c1)] Parsable it "returns a single value for a simple list" $ getSeparatorByPrecedence [rule0] `shouldBe` [(0,",")]@@ -71,4 +71,3 @@ it "ignores additional rules with the same precedence" $ getSeparatorByPrecedence [rule0, rule1, rule0] `shouldBe` [(1,";"),(0,",")]-
test/BNFC/GetCFSpec.hs view
@@ -13,7 +13,7 @@ describe "transItem" $ do it "translate a non-terminal" $- transItem (Abs.NTerminal (Abs.IdCat (Abs.Ident "Foo3")))+ transItem (Abs.NTerminal (Abs.IdCat (npIdentifier "Foo3"))) `shouldBe` [Left (CoercCat "Foo" 3)] it "translate a terminal" $@@ -28,9 +28,9 @@ describe "checkRule" $ do it "returns an error if the rule uses an unknown category" $ do- let rulep = Rule ("Foo", ("Foo", [])) (Cat "Bar") [Left (Cat "Baz")]- rule = Rule "Foo" (Cat "Bar") [Left (Cat "Baz")]- cf = CFG [] [] [] [] [] [rule]+ let rulep = Rule ("Foo", ("Foo", [])) (noPosition $ Cat "Bar") [Left (Cat "Baz")] Parsable+ rule = npRule "Foo" (Cat "Bar") [Left (Cat "Baz")] Parsable+ cf = CFG [] [] [] [] [] [rule] mempty expected = "no production for Baz, appearing in rule\n Foo. Bar ::= Baz" checkRule cf rulep `shouldBe` Just expected
test/BNFC/OptionsSpec.hs view
@@ -1,16 +1,15 @@ {-# 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 Control.Monad.Writer (WriterT(..))+import Data.List (intercalate)+import System.FilePath ((<.>), takeBaseName)+ import Test.Hspec import Test.QuickCheck -import BNFC.Options -- SUT-import BNFC.WarningM+import BNFC.Options -- Expectation that a particular option has a particular value@@ -23,57 +22,61 @@ describe "parseMode" $ do it "returns Help on an empty list of arguments" $- parseMode [] `shouldBe` Help+ parseMode_ [] `shouldBe` Help it "returns Help if given --help" $- parseMode ["--help"] `shouldBe` Help+ parseMode_ ["--help"] `shouldBe` Help it "returns Version if given --version" $- parseMode ["--version"] `shouldBe` Version+ parseMode_ ["--version"] `shouldBe` Version it "returns an error if help is given an argument" $- isUsageError (parseMode ["--help=2"]) `shouldBe` True+ isUsageError (parseMode_ ["--help=2"]) `shouldBe` True it "If no language is specified, it should default to haskell" $- parseMode["file.cf"] `shouldSet` (target, TargetHaskell)+ parseMode_ ["file.cf"] `shouldSet` (target, TargetHaskell) it "returns an error if the grammar file is missing" $- parseMode["--haskell"] `shouldBe` UsageError "Missing grammar file"+ parseMode_ ["--haskell"] `shouldBe` UsageError "Missing grammar file" it "returns an error if multiple grammar files are given" $- parseMode["--haskell", "file1.cf", "file2.cf"]+ 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")+ parseMode_ ["foo.cf"] `shouldSet` (lang, "foo") it "accept 'old style' options" $ do- parseMode["-haskell", "-m", "-glr", "file.cf"]+ parseMode_ ["-haskell", "-m", "-glr", "file.cf"] `shouldSet` (target, TargetHaskell)- parseMode["-haskell", "-m", "-glr", "file.cf"]+ parseMode_ ["-haskell", "-m", "-glr", "file.cf"] `shouldSet` (make, Just "Makefile")- parseMode["-haskell", "-m", "-glr", "file.cf"]+ parseMode_ ["-haskell", "-m", "-glr", "file.cf"] `shouldSet` (glr, GLR) it "accept latex as a target language" $- parseMode["--latex", "file.cf"] `shouldSet` (target, TargetLatex)+ parseMode_ ["--latex", "file.cf"] `shouldSet` (target, TargetLatex) describe "Old option translation" $ do it "translate -haskell to --haskell" $- translateOldOptions ["-haskell"] `shouldBe` ["--haskell"]+ translateOldOptions ["-haskell"] `shouldBe`+ (WriterT $ Right (["--haskell"]+ ,["Warning: unrecognized option -haskell treated as if --haskell was provided."])) describe "--makefile" $ do it "is off by default" $- parseMode["--c", "foo.cf"] `shouldSet` (make, Nothing)+ parseMode_ ["--c", "foo.cf"] `shouldSet` (make, Nothing) it "uses the file name 'Makefile' by default" $- parseMode["--c", "-m", "foo.cf"] `shouldSet` (make, Just "Makefile")+ 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"]+ parseMode_ ["--c", "-mMyMakefile", "foo.cf"] `shouldSet` (make, Just "MyMakefile")+ where+ parseMode_ = fst . parseMode isUsageError :: Mode -> Bool isUsageError = \case@@ -85,7 +88,7 @@ randomOption :: Gen String randomOption = oneof [ nonOption, noArg, withArg ] where nonOption = stringOf1 ['a'..'z'] -- non-option argument- noArg = liftM ("--"++) nonOption -- flag+ noArg = ("--"++) <$> nonOption -- flag withArg = do arg <- nonOption flag <- noArg@@ -102,7 +105,8 @@ stringOf1 = listOf1 . elements -instance Arbitrary Target where arbitrary = elements [minBound .. ]+instance Arbitrary Target where+ arbitrary = elements [minBound .. maxBound] -- creates a filepath with the given extension arbitraryFilePath :: String -> Gen FilePath@@ -116,15 +120,16 @@ -- 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'])+ where+ arbitraryShortOption = ('-':) . (:[]) <$> elements ['x'..'z']+ arbitraryLongOption = ("--" ++) <$> 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+ , UsageError <$> arbitrary -- generates a random error message , do target' <- arbitrary -- random target cfFile <- arbitraryFilePath "cf" let args = defaultOptions { lang = takeBaseName cfFile, target = target'}
− test/BNFC/WarningMSpec.hs
@@ -1,28 +0,0 @@-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 produces warnings" $- hasWarnings computationWithWarnings `shouldBe` True-- it "returns False if the computation does not produce any warnings" $- hasWarnings (return ()) `shouldBe` False-- where computationWithWarnings = warn "Coucou" >> warn "Hi" >> return 3