diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,44 +19,40 @@ embedding of arbitrary (including IO) actions without breaking the predictive parsing abstraction. +More info can be found here: +[https://www.cronburg.com/2018/antlr-haskell-project/](https://www.cronburg.com/2018/antlr-haskell-project/) + ## Build instructions The library can be built with: -``` -stack build # stack version 1.9.1.1 -stack test antlr-haskell:simpl +```bash +stack build # stack version 2.3.3 +stack test :simple ``` -Or with cabal-2.4.0.1 like: +Or with cabal-3.0.1.0 like: -``` +```bash cabal configure cabal install --only-dependencies --enable-tests cabal build cabal test sexpression ``` -### sample grammar for ALL(\*) - -S -> Ac | Ad - -A -> aA | b - -#### ALL(\*) Input/output examples +Here's a good one to run when making changes to the library, and you're unsure +of what may become affected by those changes: -```haskell -*Test.AllStarTests> parse ['a', 'b', 'c'] (NT 'S') atnEnv -(Just True, Node 'S' [Node 'A' [Leaf 'a', Node 'A' [Leaf 'b']], Leaf 'c']) +```bash +stack test :simple :atn :ll :lr :sexpression :allstar :c ``` -```haskell -*Test.AllStarTests> parse ['b', 'd'] (NT 'S') atnEnv -(Just True, Node 'S' [Node 'A' [Leaf 'b'], Leaf 'd']) -``` +And then compare the results with that of this upstream branch. Some of the +GLR features (incremental and partial tokenization, notably) are still experimental, +and so there are known test cases which currently fail. -```haskell -*Test.AllStarTests> parse ['a', 'a', 'a', 'a', 'b', 'c'] (NT 'S') atnEnv -(Just True, Node 'S' [Node 'A' [Leaf 'a', Node 'A' [Leaf 'a', Node 'A' [Leaf 'a', Node 'A' [Leaf 'a', Node 'A' [Leaf 'b']]]]], Leaf 'c']) -``` +## Version History + +- September 25th, 2020. Released version 0.1.0.1: bug fixes, documentation, and + library versioning updates. diff --git a/antlr-haskell.cabal b/antlr-haskell.cabal --- a/antlr-haskell.cabal +++ b/antlr-haskell.cabal @@ -1,24 +1,27 @@ -cabal-version: 1.12 -name: antlr-haskell -version: 0.1.0.0 -license: BSD3 -license-file: LICENSE -copyright: MIT -maintainer: karl@cs.tufts.edu -author: Karl Cronburg & Matthew Ahrens -homepage: https://github.com/cronburg/antlr-haskell#readme -bug-reports: https://github.com/cronburg/antlr-haskell/issues -synopsis: A Haskell implementation of the ANTLR top-down parser generator +cabal-version: 1.12 +name: antlr-haskell +version: 0.1.0.1 +license: BSD3 +license-file: LICENSE +copyright: MIT +maintainer: karl@cs.tufts.edu +author: Karl Cronburg & Matthew Ahrens +homepage: https://github.com/cronburg/antlr-haskell#readme +bug-reports: https://github.com/cronburg/antlr-haskell/issues +synopsis: + A Haskell implementation of the ANTLR top-down parser generator + description: Please see the README on Github at and . -category: Library -build-type: Simple + +category: Library +build-type: Simple extra-source-files: README.md ChangeLog.md source-repository head - type: git + type: git location: https://github.com/cronburg/antlr-haskell library @@ -46,7 +49,8 @@ Language.ANTLR4.G4 Language.ANTLR4.Syntax Language.ANTLR4.FileOpener - hs-source-dirs: src + + hs-source-dirs: src other-modules: Data.Set.Monad Language.ANTLR4.Boot.SplicedParser @@ -54,404 +58,543 @@ Text.ANTLR.Common Text.ANTLR.Language Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - other-extensions: QuasiQuotes TemplateHaskell ScopedTypeVariables - DeriveLift + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + other-extensions: + QuasiQuotes TemplateHaskell ScopedTypeVariables DeriveLift + build-depends: base >=4.11 && <5, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite allstar - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/allstar test/shared + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/allstar test/shared test/shared-hunit other-modules: AllStarTests - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + ConvertDFA + ConvertP + Example.Grammar + Text.ANTLR.HUnit Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite atn - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/atn test/shared + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/atn test/shared other-modules: - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + ATN + Example.Grammar Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* +test-suite c + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/c test/shared test/shared-hunit + other-modules: + CParser + Example.Grammar + Text.ANTLR.HUnit + Paths_antlr_haskell + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit ==1.6.*, + QuickCheck >=2.11 && <2.14, + antlr-haskell -any, + base >=4.11 && <5, + call-stack >=0.1 && <0.3, + containers ==0.6.*, + deepseq ==1.4.*, + hashable >=1.2 && <1.4, + haskell-src-meta ==0.8.*, + mtl ==2.2.*, + template-haskell >=2.14 && <2.16, + test-framework ==0.8.*, + test-framework-hunit ==0.3.*, + test-framework-quickcheck2 ==0.3.*, + text ==1.2.*, + th-lift >=0.7.11 && <0.9, + transformers ==0.5.*, + unordered-containers ==0.2.* + test-suite chisel - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/chisel test/shared-hunit + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/chisel test/shared-hunit other-modules: Language.Chisel.Grammar Language.Chisel.Parser Language.Chisel.Syntax Text.ANTLR.HUnit Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite coreg4 - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/coreg4 test/shared + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/coreg4 test/shared other-modules: - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + G4 + G4Fast + G4Parser + Hello + HelloParser + Example.Grammar Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite g4 - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/g4 test/shared test/shared-hunit + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/g4 test/shared test/shared-hunit other-modules: - G4 - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + DoubleSemi + DoubleSemiP + Empty + EmptyP + Optional + OptionalParser + Example.Grammar Text.ANTLR.HUnit Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite lexer - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/lexer test/shared + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/lexer test/shared other-modules: - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + Example.Grammar Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite ll - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/ll test/shared test/shared-hunit + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/ll test/shared test/shared-hunit other-modules: - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + Example.Grammar Text.ANTLR.HUnit Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite lr - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/lr test/shared test/shared-hunit + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/lr test/shared test/shared-hunit other-modules: - Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + EOF + EOFGrammar + GLRInc + GLRIncGrammar + GLRPartial + GLRPartialGrammar + Example.Grammar Text.ANTLR.HUnit Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite sexpression - type: exitcode-stdio-1.0 - main-is: sexpression.hs - hs-source-dirs: test/sexpression + type: exitcode-stdio-1.0 + main-is: sexpression.hs + hs-source-dirs: test/sexpression other-modules: Grammar Parser Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: antlr-haskell -any, base >=4.11 && <5, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* test-suite simple - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/simple + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/simple other-modules: Grammar Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* -test-suite template - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test/template test/shared +test-suite swift + type: exitcode-stdio-1.0 + main-is: swift.hs + hs-source-dirs: test/swift other-modules: Grammar - Language.ANTLR4.Example.G4 - Language.ANTLR4.Example.Hello - Language.ANTLR4.Example.Optionals - Text.ANTLR.Allstar.Example.ATN - Text.ANTLR.Example.Grammar + Parser Paths_antlr_haskell - default-language: Haskell2010 - default-extensions: DeriveLift DeriveDataTypeable DeriveGeneric - DeriveAnyClass - ghc-options: -threaded -rtsopts -with-rtsopts=-N + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: + antlr-haskell -any, + base >=4.11 && <5, + containers ==0.6.*, + deepseq ==1.4.*, + hashable >=1.2 && <1.4, + haskell-src-meta ==0.8.*, + mtl ==2.2.*, + template-haskell >=2.14 && <2.16, + text ==1.2.*, + th-lift >=0.7.11 && <0.9, + transformers ==0.5.*, + unordered-containers ==0.2.* + +test-suite template + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/template test/shared + other-modules: + Example.Grammar + Paths_antlr_haskell + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: HUnit ==1.6.*, - QuickCheck ==2.11.*, + QuickCheck >=2.11 && <2.14, antlr-haskell -any, base >=4.11 && <5, - call-stack ==0.1.*, + call-stack >=0.1 && <0.3, containers ==0.6.*, deepseq ==1.4.*, - hashable ==1.2.*, + hashable >=1.2 && <1.4, haskell-src-meta ==0.8.*, mtl ==2.2.*, - template-haskell ==2.14.*, + template-haskell >=2.14 && <2.16, test-framework ==0.8.*, test-framework-hunit ==0.3.*, test-framework-quickcheck2 ==0.3.*, text ==1.2.*, - th-lift >=0.7.11 && <0.8, + th-lift >=0.7.11 && <0.9, + transformers ==0.5.*, + unordered-containers ==0.2.* + +test-suite unit + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/unit + other-modules: + PlusBug0 + Paths_antlr_haskell + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit ==1.6.*, + QuickCheck >=2.11 && <2.14, + antlr-haskell -any, + base >=4.11 && <5, + call-stack >=0.1 && <0.3, + containers ==0.6.*, + deepseq ==1.4.*, + hashable >=1.2 && <1.4, + haskell-src-meta ==0.8.*, + mtl ==2.2.*, + template-haskell >=2.14 && <2.16, + test-framework ==0.8.*, + test-framework-hunit ==0.3.*, + test-framework-quickcheck2 ==0.3.*, + text ==1.2.*, + th-lift >=0.7.11 && <0.9, + transformers ==0.5.*, + unordered-containers ==0.2.* + +test-suite unit0 + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/unit0 + other-modules: + DupTerms + DupTermsGrammar + Star0 + Star0Grammar + Star1 + Star1Grammar + Paths_antlr_haskell + + default-language: Haskell2010 + default-extensions: + DeriveLift DeriveDataTypeable DeriveGeneric DeriveAnyClass + + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit ==1.6.*, + QuickCheck >=2.11 && <2.14, + antlr-haskell -any, + base >=4.11 && <5, + call-stack >=0.1 && <0.3, + containers ==0.6.*, + deepseq ==1.4.*, + hashable >=1.2 && <1.4, + haskell-src-meta ==0.8.*, + mtl ==2.2.*, + template-haskell >=2.14 && <2.16, + test-framework ==0.8.*, + test-framework-hunit ==0.3.*, + test-framework-quickcheck2 ==0.3.*, + text ==1.2.*, + th-lift >=0.7.11 && <0.9, transformers ==0.5.*, unordered-containers ==0.2.* diff --git a/src/Language/ANTLR4.hs b/src/Language/ANTLR4.hs --- a/src/Language/ANTLR4.hs +++ b/src/Language/ANTLR4.hs @@ -24,7 +24,7 @@ -- 'Language.ANTLR4.Regex' which are regexes used for G4 parsing: , module Text.ANTLR.Lex.Regex -- | The G4 quasiquoter and accompanying grammar: - , module Language.ANTLR4.G4 + , g4, g4_parsers -- | For defining pretty-printable instances of quasiquoter-generated data types: , module Text.ANTLR.Pretty -- | Tokenizer: @@ -34,6 +34,8 @@ , Hashable(..), Generic(..), Data(..), Lift(..) -- | Parser interface data types: , S.Set(..), T.Token(..), LRResult(..) + -- | Grammar interface data types: + , Directive(..), PRHS(..), TermAnnot(..) ) where @@ -50,8 +52,12 @@ import Text.ANTLR.Lex.Regex import Language.ANTLR4.G4 -import Language.ANTLR4.Boot.Quote (mkLRParser) +import Language.ANTLR4.Parser +import Language.ANTLR4.Boot.Quote (mkLRParser, g4_parsers) import Data.Data (Data(..)) import Language.Haskell.TH.Lift (Lift(..)) + +import Language.ANTLR4.Boot.Syntax + (Directive(..), PRHS(..), TermAnnot(..), ProdElem(..)) diff --git a/src/Language/ANTLR4/Boot/Quote.hs b/src/Language/ANTLR4/Boot/Quote.hs --- a/src/Language/ANTLR4/Boot/Quote.hs +++ b/src/Language/ANTLR4/Boot/Quote.hs @@ -12,1011 +12,1120 @@ module Language.ANTLR4.Boot.Quote ( antlr4 , g4_decls - , mkLRParser - ) where -import Prelude hiding (exp, init) -import System.IO.Unsafe (unsafePerformIO) -import Data.List (nub, elemIndex, groupBy, sortBy, sort) -import Data.Ord (comparing) -import Data.Char (toLower, toUpper, isLower, isUpper) -import Data.Maybe (fromJust, catMaybes) - -import qualified Debug.Trace as D - -import qualified Language.Haskell.TH as TH -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (lift, Exp(..)) -import Language.Haskell.TH.Quote (QuasiQuoter(..)) -import qualified Language.Haskell.Meta as LHM - -import Control.Monad (mapM) -import qualified Language.ANTLR4.Boot.Syntax as G4S - ---import qualified Language.ANTLR4.Boot.Parser as G4P -import qualified Language.ANTLR4.Boot.SplicedParser as G4P - -import Text.ANTLR.Grammar -import Text.ANTLR.Parser (AST(..), StripEOF(..)) -import Text.ANTLR.Pretty -import Text.ANTLR.Lex.Tokenizer as T -import Text.ANTLR.LR as LR -import qualified Text.ANTLR.Allstar as ALL -import qualified Text.ANTLR.LL1 as LL -import qualified Text.ANTLR.Set as S - -import qualified Text.ANTLR.MultiMap as M -import qualified Data.Map as M1 -import Text.ANTLR.Set (Set(..)) -import qualified Text.ANTLR.Set as Set -import qualified Text.ANTLR.Lex.Regex as R - ---trace s = D.trace ("[Language.ANTLR4.Boot.Quote] " ++ s) ---traceM s = D.traceM ("[Language.ANTLR4.Boot.Quote] " ++ s) - -trace s x = x -traceM s x = x - -haskellParseExp :: (Monad m) => String -> m TH.Exp -haskellParseExp s = case LHM.parseExp s of - Left err -> error err - Right expTH -> return expTH - -haskellParseType :: (Monad m) => String -> m TH.Type -haskellParseType s = case LHM.parseType s of - Left err -> trace s (error err) - Right tyTH -> return tyTH - -type2returnType :: TH.Type -> TH.Type -type2returnType = let - - t2rT :: TH.Type -> TH.Type - t2rT (ForallT xs ys t) = t2rT t - t2rT ((AppT (AppT ArrowT from) to)) = t2rT to - t2rT t@(VarT _) = t - t2rT t@(AppT ListT as) = t - t2rT t@(ConT _) = t - t2rT t@(AppT (ConT _) _) = t - t2rT x = error (show x) - - in t2rT - -info2returnType :: Info -> TH.Type -info2returnType i = let - - in case i of - (VarI _ t _) -> type2returnType t - _ -> error (show i) - ---trace s = id ---traceM = return - --- | There are three different quasiquoters in antlr-haskell, each with varying --- support for different G4 features. If you're looking for the user-facing --- quasiquoter then turn back now, because here-be-dragons. The user-facing --- quasiquoter can be found in 'Language.ANTLR4.G4' as @g4@. --- --- * __User-facing__ QuasiQuoter is in 'Language.ANTLR4.G4' --- * __Spliced__ QuasiQuoter is here --- * __Boot__ parser is in @src/Language/ANTLR4/Boot/Parser.hs.boot@ --- --- The spliced quasiquoter, as packaged and shipped with distributions of --- antlr-haskell, allows for bootstrapping of the user-facing quasiquoter --- without requiring parsec as a dependency. The boot quasiquoter on the --- other hand is written entirely in parsec. -antlr4 :: QuasiQuoter -antlr4 = QuasiQuoter - (error "parse exp") - (error "parse pattern") - (error "parse type") - aparse --(error "parse decl") - --- e.g. Named ("Num", "Int") where 'Num' was a G4 lexeme and 'Int' was given --- as a directive specifying the desired type to read (must instance Read). -data LexemeType = - Literal Int -- A literal lexeme somewhere in the grammar, e.g. ';' - | AString -- Type was unspecified in the G4 lexeme or specified as a String - | Named String TH.TypeQ -- Type was specified as a directive in the G4 lexeme - -aparse :: String -> TH.Q [TH.Dec] -aparse input = do - loc <- TH.location - let fileName = TH.loc_filename loc - let (line,column) = TH.loc_start loc - - case G4P.parseANTLR input of - r@(LR.ResultAccept ast) -> codeGen r - LR.ResultSet s -> - if S.size s == 1 - then codeGen (S.findMin s) - else error $ pshow' s - err -> error $ pshow' err - -codeGen (LR.ResultAccept ast) = g4_decls $ G4P.ast2decls ast - -{- --- parser in quasiquotation monad -aparse :: String -> TH.Q [TH.Dec] -aparse input = do - -- TODO: replace bad error showing with - -- debugging information (filename, line #, column) in parser - loc <- TH.location - let fileName = TH.loc_filename loc - let (line,column) = TH.loc_start loc - - case G4P.parseANTLR fileName line column input of - Left err -> unsafePerformIO $ fail $ show err - Right x -> g4_decls x --} - -data BaseType = List | Mybe - deriving (Eq, Ord, Show) - -baseType (G4S.Regular '?') = Mybe -baseType (G4S.Regular '*') = List - --- Find the (first) name of the grammar -grammarName :: [G4S.G4] -> String -grammarName [] = error "Grammar missing a name" -grammarName (G4S.Grammar{G4S.gName = gName}:_) = gName -grammarName (_:xs) = grammarName xs - -mkLower [] = [] -mkLower (a:as) = toLower a : as - -mkUpper [] = [] -mkUpper (a:as) = toUpper a : as - -justGrammarTy ast s = [t| Grammar $(s) $(ntConT ast) $(tConT ast) |] -justGrammarTy' ast s = [t| Grammar $(s) $(ntConT ast) (StripEOF (Sym $(tConT ast))) |] - -ntConT ast = conT $ mkName $ ntDataName ast -tConT ast = conT $ mkName $ tDataName ast - -ntDataName ast = gName ast ++ "NTSymbol" -tDataName ast = gName ast ++ "TSymbol" - -gName ast = grammarName ast - --- | This function does the heavy-lifting of Haskell code generation, most notably --- generating non-terminal, terminal, and grammar data types as well as accompanying --- parsing functions. -g4_decls :: [G4S.G4] -> TH.Q [TH.Dec] -- exp :: G4 -g4_decls ast = let - - -- Ordered (arbitrary) list of the terminal literals found in production - -- rules of the grammar: - --terminalLiterals :: [String] - --terminalLiterals = nub $ concatMap getTLs ast - - -- Get Terminal Literals - --getTLs :: G4S.G4 -> [String] - --getTLs G4S.Prod{G4S.patterns = ps} = concatMap (justLiterals . G4S.alphas) ps - --getTLs _ = [] - - --justLiterals :: [G4S.ProdElem] -> [String] - --justLiterals [] = [] - --justLiterals ( - - -- A list of all the G4 literal terminals scattered across production rules - terminalLiterals :: [String] - terminalLiterals = (nub $ concatMap getTerminals ast) - - -- A list of all the terminals in the grammar (both literal G4 terminals and - -- G4 lexical terminals) - terminals :: [String] - terminals = terminalLiterals ++ lexemeNames - - -- A list of all the G4 lexeme names specified in the grammar - lexemeNames :: [String] - lexemeNames = map fst lexemeTypes - - nonterms :: [String] - nonterms = nub $ concatMap getNTs ast - - -- Find all terminals *literals* in a production like '(' and ')' and ';' - justTerms :: [G4S.ProdElem] -> [String] - justTerms [] = [] - justTerms ((G4S.GTerm _ s) : as) = s : justTerms as - justTerms (_:as) = justTerms as - - -- Find all nonterminals in a production like 'exp' and 'decl' - justNonTerms :: [G4S.ProdElem] -> [String] - justNonTerms [] = [] - justNonTerms (G4S.GNonTerm _ s:as) - | (not . null) s && isLower (head s) = s : justNonTerms as - | otherwise = justNonTerms as - justNonTerms (_:as) = justNonTerms as - - -- Find all terminal literals in a G4 grammar rule like '(' and ')' and ';' - getTerminals :: G4S.G4 -> [String] - getTerminals G4S.Prod{G4S.patterns = ps} = concatMap (justTerms . G4S.alphas) ps - getTerminals _ = [] - - -- Find all the nonterminals referenced in the production(s) of the given grammar rule - getNTs :: G4S.G4 -> [String] - getNTs G4S.Prod{G4S.pName = pName, G4S.patterns = ps} = pName : concatMap (justNonTerms . G4S.alphas) ps - getNTs _ = [] - - -- Things Symbols must derive: - symbolDerives = derivClause Nothing $ map (conT . mkName) - [ "Eq", "Ord", "Show", "Hashable", "Generic", "Bounded", "Enum", "Data", "Lift"] - - -- Nonterminal symbol data type (enum) for this grammar: - ntDataDeclQ :: DecQ - ntDataDeclQ = - dataD (cxt []) - (mkName $ ntDataName ast) - [] - Nothing - (map (\s -> normalC (mkName $ "NT_" ++ s) []) $ nonterms ++ regexNonTermSymbols) - [symbolDerives] - - -- E.g. ['(', ')', ';', 'exp', 'decl'] - allLexicalSymbols :: [String] - allLexicalSymbols = map (lookupTName "") terminalLiterals ++ lexemeNames - - -- E.g. [('(', Literal 0), (')', Literal 1), (';', Literal 2), ('exp', - -- AString), ('decl', AString')] - allLexicalTypes :: [(String, LexemeType)] - allLexicalTypes = (map lookupLiteralType terminalLiterals) ++ lexemeTypes - - -- E.g. [('(', Literal 0), ...] - lookupLiteralType :: String -> (String, LexemeType) - lookupLiteralType s = - case s `elemIndex` terminalLiterals of - Nothing -> undefined - Just i -> (s, Literal i) - - -- Terminal symbol data type (enum) for this grammar: - tDataDeclQ :: DecQ - tDataDeclQ = - dataD (cxt []) - (mkName $ tDataName ast) - [] - Nothing - (map (\s -> normalC (mkName s) []) (map ("T_" ++) allLexicalSymbols)) - --(\s -> normalC (mkName $ lookupTName "T_" s) []) lexemes) ++ (lexemeNames "T_")) - [symbolDerives] - - -- THIS EXCLUDES LEXEME FRAGMENTS: - -- e.g. [('UpperID', AString), ('SetChar', Named String)] - lexemeTypes :: [(String, LexemeType)] - lexemeTypes = let - - nullID (G4S.UpperD xs) = null xs - nullID (G4S.LowerD xs) = null xs - nullID (G4S.HaskellD _) = False - - lN :: G4S.G4 -> [(String, LexemeType)] - lN (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Nothing}}) = [(lName, AString)] - lN (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Just s}}) - | s == (G4S.UpperD "String") = [(lName, AString)] - | nullID s = [(lName, AString)] -- quirky G4 parser - | otherwise = case s of - (G4S.UpperD s) -> [(lName, Named s (conT $ mkName s))] - (G4S.LowerD s) -> [(lName, Named s (info2returnType <$> reify (mkName s)))] - (G4S.HaskellD s) -> [] -- TODO? - lN _ = [] - in concatMap lN ast - --map (\s -> normalC (mkName s) []) lN' - - -- Map from a terminal's syntax to the name of the data type instance from - -- tDataDeclQ: - lookupTName :: String -> String -> String - lookupTName pfx s = pfx ++ - (case s `elemIndex` terminalLiterals of - Nothing -> s - Just i -> show i) - - strBangType = (defBang, conT $ mkName "String") - - mkCon = conE . mkName . mkUpper - mkConNT = conE . mkName . ("NT_" ++) - - -- - genTermAnnotProds :: [G4S.G4] -> [G4S.G4] - genTermAnnotProds [] = [] - genTermAnnotProds (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) = let - - withAlphas newName d a = G4S.Prod {G4S.pName = newName, G4S.patterns = - [ G4S.PRHS - { G4S.pred = Nothing - , G4S.alphas = a - , G4S.mutator = Nothing - , G4S.pDirective = Just d - } - ]} - - gTAP :: G4S.ProdElem -> [G4S.G4] - gTAP (G4S.GNonTerm (G4S.Regular '?') nt) = trace (show nt) - [ withAlphas (nt ++ "_quest") (G4S.UpperD "Maybe") [G4S.GNonTerm G4S.NoAnnot nt] - , withAlphas (nt ++ "_quest") (G4S.UpperD "Maybe") [] -- epsilon - ] - gTAP (G4S.GNonTerm (G4S.Regular '*') nt) = - [ withAlphas (nt ++ "_star") (G4S.LowerD "cons") [G4S.GNonTerm G4S.NoAnnot nt, G4S.GNonTerm G4S.NoAnnot (nt ++ "_star")] - , withAlphas (nt ++ "_star") (G4S.LowerD "list") [G4S.GNonTerm G4S.NoAnnot nt] - , withAlphas (nt ++ "_star") (G4S.LowerD "list") [] - ] - gTAP (G4S.GNonTerm (G4S.Regular '+') nt) = - [ withAlphas (nt ++ "_plus") (G4S.LowerD "cons") [G4S.GNonTerm G4S.NoAnnot nt, G4S.GNonTerm G4S.NoAnnot (nt ++ "_plus")] - , withAlphas (nt ++ "_plus") (G4S.LowerD "list") [G4S.GNonTerm G4S.NoAnnot nt] - ] - gTAP (G4S.GNonTerm G4S.NoAnnot nt) = [] - gTAP (G4S.GTerm _ t) = [] - gTAP term = error $ show term - in concat (concatMap (map gTAP) (map G4S.alphas ps)) ++ genTermAnnotProds xs - genTermAnnotProds (_:xs) = genTermAnnotProds xs - - annotName G4S.NoAnnot s = s - annotName (G4S.Regular '?') s = s ++ "_quest" - annotName (G4S.Regular '*') s = s ++ "_star" - annotName (G4S.Regular '+') s = s ++ "_plus" - annotName (G4S.Regular c) s = s ++ [c] -- TODO: warning on unknown character annotation - - annotName' (G4S.GTerm annot s) = annotName annot s - annotName' (G4S.GNonTerm annot s) = annotName annot s - - regexNonTermSymbols = let - - rNTS (G4S.Prod {G4S.patterns = ps}) = Just $ map G4S.alphas ps - rNTS _ = Nothing - - in nub $ map annotName' $ filter (not . G4S.isNoAnnot . G4S.annot) (concat $ concat $ catMaybes $ map rNTS ast) - - toElem :: G4S.ProdElem -> TH.ExpQ - toElem (G4S.GTerm annot s) = [| $(mkCon "T") $(mkCon $ lookupTName "T_" (annotName annot s)) |] - toElem (G4S.GNonTerm annot s) - | (not . null) s && isLower (head s) = [| $(mkCon "NT") $(mkConNT (annotName annot s)) |] - | otherwise = toElem (G4S.GTerm G4S.NoAnnot s) - - mkProd :: String -> [TH.ExpQ] -> TH.ExpQ - mkProd n [] = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") [Eps]) |] - mkProd n es = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") $(listE es)) |] - - getProds :: [G4S.G4] -> [TH.ExpQ] - getProds [] = [] - getProds (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) - = map (mkProd n . map toElem . G4S.alphas) ps ++ getProds xs - getProds (_:xs) = getProds xs - - -- The first NonTerminal in the grammar (TODO: head of list) - s0 :: TH.ExpQ - s0 = conE $ mkName $ "NT_" ++ head nonterms - - grammar gTy = [| (defaultGrammar $(s0) :: $(return gTy)) - { ns = Set.fromList [minBound .. maxBound :: $(ntConT ast)] - , ts = Set.fromList [minBound .. maxBound :: $(tConT ast)] - , ps = $(listE $ getProds $ ast ++ genTermAnnotProds ast) - } |] - - --grammarTy s = [t| forall $(s). (Prettify $(s)) => $(justGrammarTy s) |] - grammarTy s = [t| (Prettify $(s)) => $(justGrammarTy ast s) |] - - {----------------------- Tokenizer -----------------------} - - tokenNameTypeQ = tySynD (mkName "TokenName") [] (conT $ mkName $ tDataName ast) - - defBang = bang noSourceUnpackedness noSourceStrictness - - lexemeValueDerives = derivClause Nothing $ map (conT . mkName) - ["Show", "Ord", "Eq", "Generic", "Hashable", "Data"] - - -- - lexemeTypeConstructors = let - nullD (G4S.UpperD s) = null s - nullD (G4S.LowerD s) = null s - nullD (G4S.HaskellD s) = null s - - lTC (i, lex@(G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Just d}})) - | null lName = error $ "null lexeme name: " ++ show lex - | nullD d = Just $ normalC (mkName $ "V_" ++ lName) [bangType defBang (conT $ mkName "String")] - | otherwise = case d of - (G4S.UpperD d) -> Just $ normalC (mkName $ "V_" ++ lName) [bangType defBang (conT $ mkName d)] - (G4S.LowerD d) -> Just $ do - info <- reify $ mkName d - normalC (mkName $ "V_" ++ lName) [bangType defBang (return $ info2returnType info)] - --Just $ [|| $$(haskellParseExp d) ||] --error $ "unimplemented use of function in G4 directive: " ++ show d - (G4S.HaskellD s) -> Nothing -- TODO? - lTC _ = Nothing - in ((catMaybes $ map lTC (zip [0 .. length ast - 1] ast)) - ++ (map (\s -> normalC (mkName $ lookupTName "V_" s) []) terminalLiterals)) - - tokenValueTypeQ = - dataD (cxt []) (mkName "TokenValue") [] Nothing - lexemeTypeConstructors - [lexemeValueDerives] - - mkTyVar s f = return $ f $ mkName s - - lookupTokenFncnDecl = let - lTFD t = clause [litP $ stringL t] - (normalB $ [| Token $(conE $ mkName $ lookupTName "T_" t) - $(conE $ mkName $ lookupTName "V_" t) - $(litE $ integerL $ fromIntegral $ length t) |]) - [] - in funD (mkName "lookupToken") - ( map lTFD terminalLiterals - ++ [clause [varP $ mkName "s"] - (normalB $ [| error ("Error: '" ++ s ++ "' is not a token") |]) - []] - ) - - -- Construct the function that takes in a lexeme (string) and the token name - -- (T_*) and constructs a token value type instance using 'read' where - -- appropriate based on the directives given in the grammar. - lexeme2ValueQ lName = let - - l2VQ (_, Literal i) = - clause [varP lName, conP (mkName $ "T_" ++ show i) []] - (normalB [| $(conE $ mkName $ "V_" ++ show i) |]) [] - l2VQ (s, AString) = - clause [varP lName, conP (mkName $ "T_" ++ s) []] - (normalB [| $(conE $ mkName $ "V_" ++ s) $(varE lName) |]) [] - l2VQ (s, Named n t) - | isLower (head n) = - clause [varP lName, conP (mkName $ "T_" ++ s) []] - (normalB [| $(conE $ mkName $ "V_" ++ s) (trace $(varE lName) ($(varE $ mkName n) $(varE lName) :: $t)) |]) [] - | otherwise = - clause [varP lName, conP (mkName $ "T_" ++ s) []] - (normalB [| $(conE $ mkName $ "V_" ++ s) (trace $(varE lName) (read $(varE lName) :: $t)) |]) [] - - --info <- reify $ mkName d - --normalC (mkName $ "V_" ++ lName) [bangType defBang (return $ info2returnType info)] - - in funD (mkName "lexeme2value") (map l2VQ allLexicalTypes) - - -- Convert a G4 regex into the backend regex type (for constructing token - -- recognizers as DFAs): - convertRegex :: (Show c) => (String -> G4S.Regex c) -> G4S.Regex c -> R.Regex c - convertRegex getNamedR = let - cR G4S.Epsilon = R.Epsilon - cR (G4S.Literal []) = R.Epsilon - cR (G4S.Literal [c]) = R.Symbol c - cR (G4S.Literal cs) = R.Literal cs - cR (G4S.Union rs) = R.MultiUnion $ map cR rs - cR (G4S.Concat rs) = R.Concat $ map cR rs - cR (G4S.Kleene r) = R.Kleene $ cR r - cR (G4S.PosClos r) = R.PosClos $ cR r - cR (G4S.Question r) = R.Question $ cR r - cR (G4S.CharSet cs) = R.Class cs - cR (G4S.Negation (G4S.CharSet cs)) = R.NotClass cs - cR (G4S.Negation (G4S.Literal s)) = R.NotClass s - cR r@(G4S.Negation _) = error $ "unimplemented: " ++ show r - cR (G4S.Named n) = convertRegex getNamedR $ getNamedR n - in cR - - getNamedRegex :: String -> G4S.Regex Char - getNamedRegex n = let - -- Only the lexeme (fragments) with the given name: - gNR (G4S.Lex{G4S.annotation = Just G4S.Fragment, G4S.lName = lName}) = lName == n - gNR _ = False - in case filter gNR ast of - [] -> error $ "No fragment named '" ++ n ++ "'" - [(G4S.Lex{G4S.pattern = G4S.LRHS{G4S.regex = r}})] -> r - xs -> error $ "Too many fragments named '" ++ n ++ "', i.e.: " ++ show xs - - -- Make the list of tuples containing regexes, one for each terminal. - mkRegexesQ = let - mkLitR :: String -> ExpQ - mkLitR s = [| ($( conE $ mkName $ lookupTName "T_" s) - , $(lift $ convertRegex getNamedRegex $ G4S.Literal s)) |] - - mkLexR :: G4S.G4 -> Maybe ExpQ - mkLexR (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.regex = r}}) = Just - [| ($(conE $ mkName $ lookupTName "T_" lName), $(lift $ convertRegex getNamedRegex r)) |] - mkLexR _ = Nothing - in valD (varP $ mkName $ mkLower $ gName ast ++ "Regexes") - (normalB $ listE (map mkLitR terminalLiterals ++ (catMaybes $ map mkLexR ast))) - [] - - prettyTFncnQ fncnName = let - pTFLit lexeme = - clause [conP (mkName $ lookupTName "T_" lexeme) []] - (normalB [| pStr $(litE $ stringL $ "'" ++ lexeme ++ "'") |]) - [] - - pTFName lexeme = - clause [conP (mkName $ lookupTName "T_" lexeme) []] - (normalB [| pStr $(litE $ stringL $ lexeme) |]) - [] - in funD fncnName (map pTFLit terminalLiterals ++ map pTFName lexemeNames) - - prettyVFncnQ fncnName = let - pVFLit lexeme = - clause [conP (mkName $ lookupTName "V_" lexeme) []] - (normalB [| pStr $(litE $ stringL $ "'" ++ lexeme ++ "'") |]) - [] - - pVFName lexeme = - clause [conP (mkName $ lookupTName "V_" lexeme) [varP (mkName "v")]] - (normalB [| pChr '\'' >> prettify v >> pChr '\'' |]) - [] - in funD fncnName (map pVFLit terminalLiterals ++ map pVFName lexemeNames) - - -- Pattern matches on an AST to produce a Maybe DataType - ast2DTFncnsQ nameAST = let - - astFncnName s = mkName $ "ast2" ++ s - - a2d G4S.Lex{G4S.annotation = Nothing, G4S.lName = _A, G4S.pattern = G4S.LRHS{G4S.directive = dir}} - = Just [(mkName $ "ast2" ++ _A - ,[ clause [ conP (mkName "Leaf") - [ conP (mkName $ "Token") - [ wildP - , conP (mkName $ lookupTName "V_" _A) - [ varP $ mkName "t"] - , wildP]]] - (normalB (varE $ mkName "t")) - [] - ] - )] - {- - a2d G4S.Lex{G4S.lName = _A, G4S.pattern = G4S.LRHS{G4S.directive = Just s}} - | s == "String" = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName "id")) [] ]] - | null s = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName "id")) [] ]] - | otherwise = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName s)) [] ]] - -} - a2d G4S.Prod{G4S.pName = _A, G4S.patterns = ps} = let - - mkConP (G4S.GNonTerm annot nt) - -- Some nonterminals are really terminal tokens (regular expressions): - | isUpper (head nt) = conP (mkName "T") [conP (mkName $ lookupTName "T_" $ annotName annot nt) []] - | otherwise = conP (mkName "NT") [conP (mkName $ "NT_" ++ annotName annot nt) []] - mkConP (G4S.GTerm annot t) = conP (mkName "T") [conP (mkName $ lookupTName "T_" $ annotName annot t) []] - - justStr (G4S.GNonTerm annot s) = annotName annot s - justStr (G4S.GTerm _ s) = s - - vars as = catMaybes - [ if G4S.isGNonTerm a - then Just (a, mkName $ "v" ++ show i ++ "_" ++ justStr a, varE $ mkName $ "ast2" ++ justStr a) - else Nothing - | (i, a) <- zip [0 .. length as] as - ] - - astListPattern as = listP $ - [ if G4S.isGNonTerm a - then varP $ mkName $ "v" ++ show i ++ "_" ++ justStr a - else wildP - | (i, a) <- zip [0 .. length as] as - ] - - astAppRec b (alpha, varName, recName) = case G4S.annot alpha of - G4S.NoAnnot -> appE b (appE recName $ varE varName) - (G4S.Regular '?') -> appE b (appE recName $ varE varName) - -- TODO: Below two cases: - (G4S.Regular '*') -> appE b (appE recName $ varE varName) - (G4S.Regular '+') -> appE b (appE recName $ varE varName) - otherwise -> error $ show alpha - - clauses = [ clause [ [p| AST $(conP (mkName $ "NT_" ++ _A) []) - $(listP $ map mkConP as) - $(astListPattern as) - |] - ] - (case (dir, vars as) of - (Just (G4S.UpperD d), vs) -> normalB $ foldl astAppRec (conE $ mkName d) vs - (Just (G4S.LowerD d), vs) -> normalB $ foldl astAppRec (varE $ mkName d) vs - (Just (G4S.HaskellD d), vs) -> normalB $ foldl astAppRec (haskellParseExp d) vs - (Nothing, []) -> normalB $ tupE [] - (Nothing, [(a,v0,rec)]) -> normalB $ appE rec (varE v0) - (Nothing, vs) -> normalB $ tupE $ map (\(a,vN,rN) -> appE rN $ varE vN) vs - ) [] - | G4S.PRHS{G4S.alphas = as, G4S.pDirective = dir} <- ps - ] - - retType = let - rT G4S.PRHS{G4S.alphas = as, G4S.pDirective = dir} - = case (dir, vars as) of - (Just (G4S.UpperD d), vs) -> - (do i <- reify $ mkName d - (case i of - DataConI _ t n -> return $ type2returnType t - VarI n t _ -> return t - TyConI (DataD _ n _ _ _ _) -> conT n - other -> error $ show other)) - (Just (G4S.LowerD d), vs) -> info2returnType <$> reify (mkName d) - (Just (G4S.HaskellD d), vs) -> error "unimplemented" -- TODO if we ever add back the fncnSig below - (Nothing, []) -> tupleT 0 - (Nothing, [(a,v0,rec)]) -> tupleT 0 - (Nothing, vs) -> tupleT $ length vs - in rT (head ps) - - fncnSig - = do rT <- retType - (case rT of - ForallT vs c t -> forallT vs (cxt []) [t| $(conT nameAST) -> $(return t) |] - t -> forallT [] (cxt []) [t| $(conT nameAST) -> $(return t) |]) - - in Just $ [ --sigD fncnName fncnSig - (astFncnName _A, clauses) - ] - a2d _ = Nothing - - -- ast2* functions necessary to support '?', '+', and '*' in G4 syntax. - -- This assumes productions look like how LL.removeEpsilons generates - -- them - --regex_a2d :: G4S.G4 -> [DecQ] - regex_a2d :: G4S.G4 -> [(Name, [ClauseQ])] - regex_a2d G4S.Prod{G4S.pName = _A, G4S.patterns = ps} = let - - clauses = [ clause [ [p| ast2 |] ] (normalB [| error (show ast2) |]) [] ] - - - eachAlpha (G4S.GNonTerm (G4S.Regular '?') s) = let -- "_quest" - ntName = "NT_" ++ s - in - [( astFncnName $ s ++ "_quest", - [ -- First, the "zero or more" base case (returns a singleton list): - do let n = mkName ntName - nQuest = mkName $ ntName ++ "_quest" - base = varE $ astFncnName s - param <- newName "param" - clause [ [p| AST $(conP nQuest []) [NT $(conP n [])] [$(varP param)] |] ] - (normalB [| Just ($(base) $(varE param)) |]) - [] - , do param <- newName "param" - clause [ [p| $(varP param) |] ] - (normalB [| error $ $(litE $ stringL ntName) ++ ": " ++ show $(varE param) |]) - [] - ] - )] - {- - [( astFncnName $ s ++ "_quest", - [ do param <- newName "param" - let base = varE $ astFncnName s - clause [ [p| $(varP param) |] ] (normalB [| Just $ $(base) ($(varE param) :: $(conT nameAST))|]) [] - ])] - -} - eachAlpha (G4S.GNonTerm (G4S.Regular '*') s) = let -- "_star" - ntName = "NT_" ++ s - - in - [( astFncnName $ s ++ "_star", - [ -- First, the "zero or more" base case (returns a singleton list): - do let n = mkName ntName - nStar = mkName $ ntName ++ "_star" - base = varE $ astFncnName s - param <- newName "param" - clause [ [p| AST $(conP nStar []) [NT $(conP n [])] [$(varP param)] |] ] - (normalB [| [$(base) $(varE param)] |]) - [] - -- Second, the "zero or more" recursive case (cons the current - -- thing onto a recursive call) - , do let n = mkName ntName - nStar = mkName $ ntName ++ "_star" - first <- newName "x" - rest <- newName "xs" - let me = varE $ astFncnName $ s ++ "_star" - base = varE $ astFncnName s - clause [ [p| AST $(conP nStar []) [NT $(conP n []), NT $(conP nStar [])] [ $(varP first), $(varP rest) ] |] ] - (normalB [| ($(base) $(varE first)) : ($(me) $(varE rest)) |]) - [] - , do param <- newName "param" - clause [ [p| $(varP param) |] ] - (normalB [| error $ $(litE $ stringL ntName) ++ ": " ++ show $(varE param) |]) - [] - ])] - eachAlpha (G4S.GNonTerm (G4S.Regular '+') s) = let -- "_plus" - ntName = "NT_" ++ s - - in - [( astFncnName $ s ++ "_plus", - [ -- First, the "zero or more" base case (returns a singleton list): - do let n = mkName ntName - nPlus = mkName $ ntName ++ "_plus" - base = varE $ astFncnName s - param <- newName "param" - clause [ [p| AST $(conP nPlus []) [NT $(conP n [])] [$(varP param)] |] ] - (normalB [| [$(base) $(varE param)] |]) - [] - -- Second, the "zero or more" recursive case (cons the current - -- thing onto a recursive call) - , do let n = mkName ntName - nPlus = mkName $ ntName ++ "_plus" - first <- newName "x" - rest <- newName "xs" - let me = varE $ astFncnName $ s ++ "_plus" - base = varE $ astFncnName s - clause [ [p| AST $(conP nPlus []) [NT $(conP n []), NT $(conP nPlus [])] [ $(varP first), $(varP rest) ] |] ] - (normalB [| ($(base) $(varE first)) : ($(me) $(varE rest)) |]) - [] - , do param <- newName "param" - clause [ [p| $(varP param) |] ] - (normalB [| error $ $(litE $ stringL ntName) ++ ": " ++ show $(varE param) |]) - [] - ])] - eachAlpha (G4S.GNonTerm G4S.NoAnnot s) = [] - eachAlpha (G4S.GTerm annot s) = [] - - mkFncn s = map (\c -> (astFncnName s, [c])) clauses - - -- TODO - makeEpsilonClauses _ = [] - - in (concatMap eachAlpha . concatMap G4S.alphas) ps - --in concatMap makeEpsilonClauses ps - regex_a2d _ = [] - - a2d_error_clauses G4S.Prod{G4S.pName = _A} = - [(astFncnName _A, [ clause [ [p| ast2 |] ] (normalB [| error (show ast2) |]) [] ])] - a2d_error_clauses _ = [] - - --concat $ (concatMap eachAlpha . map G4S.alphas) ps - - epsilon_a2d (G4S.Prod{G4S.pName = _A, G4S.patterns = ps}) = let - - mkConP (G4S.GNonTerm annot nt) - -- Some nonterminals are really terminal tokens (regular expressions): - | isUpper (head nt) = conP (mkName "T") [conP (mkName $ lookupTName "T_" $ annotName annot nt) []] - | otherwise = conP (mkName "NT") [conP (mkName $ "NT_" ++ annotName annot nt) []] - mkConP (G4S.GTerm annot t) = conP (mkName "T") [conP (mkName $ lookupTName "T_" $ annotName annot t) []] - - justStr (G4S.GNonTerm annot s) = annotName annot s - justStr (G4S.GTerm _ s) = s - - justStr' (Left a) = Just $ justStr a - justStr' _ = Nothing - - maybeBaseType (Left _) = Nothing - maybeBaseType (Right x) = Just x - - isValid (Left x) = G4S.isGNonTerm x - isValid (Right _) = True - --isValid _ = False - - vars :: [Either G4S.ProdElem BaseType] -> [(Maybe BaseType, String, String)] - vars as = let - vars' (base_type, i, Just s) = (base_type, "v" ++ show i ++ "_" ++ s, "ast2" ++ s) - vars' (Just Mybe, i, Nothing) = (Just Mybe, "Nothing", "undefined") - vars' (Just List, i, Nothing) = (Just List, "[]", "undefined") - --vars' (base_type, i, Nothing) = (base_type, "[]", "undefined") - - - in (map vars' . map (\(i,a) -> (maybeBaseType a, i, justStr' a)) . filter (isValid . snd) . zip [0 .. length as]) as - - astListPattern as = listP - [ case a of - (G4S.GNonTerm annot s) -> varP $ mkName $ "v" ++ show i ++ "_" ++ annotName annot s - otherwise -> wildP - | (i, a) <- catLeftsTuple $ zip [0 .. length as] as - ] - - catLeftsTuple :: [(i, Either a b)] -> [(i,a)] - catLeftsTuple [] = [] - catLeftsTuple ((i, Left x):rst) = (i, x) : catLeftsTuple rst - catLeftsTuple (_:rst) = catLeftsTuple rst - - astAppRec b (Just Mybe, varName, _) = appE b (conE $ mkName varName) - astAppRec b (Just List, varName, _) = appE b (listE []) - astAppRec b (base_type, varName@(v:_), recName) - | isLower v = appE b (appE (varE $ mkName recName) $ varE $ mkName varName) - | otherwise = appE b (appE (varE $ mkName recName) $ conE $ mkName varName) - {- - G4S.NoAnnot -> appE b (appE recName $ varE $ mkName varName) - (G4S.Regular '?') -> appE b (appE recName $ varE $ mkName varName) - (G4S.Regular '*') -> appE b (appE recName $ varE $ mkName varName) - (G4S.Regular '+') -> appE b (appE recName $ varE $ mkName varName) - otherwise -> error $ show (b,(varName,recName)) - -} - - catLefts [] = [] - catLefts (((Left x)):rst) = x : catLefts rst - catLefts (_:rst) = catLefts rst - - pats as = [ [p| AST $(conP (mkName $ "NT_" ++ _A) []) - $(listP $ map mkConP $ catLefts as) - $(astListPattern as) - |] - ] - - appBodyType (base_type, vN@(v:_), rN) - | isLower v = appE (varE $ mkName rN) $ varE $ mkName vN - | otherwise = conE $ mkName vN - - body dir as = (case (dir, vars as) of - (Just (G4S.UpperD d), vs) -> foldl astAppRec (conE $ mkName d) vs - (Just (G4S.LowerD d), vs) -> foldl astAppRec (varE $ mkName d) vs - (Just (G4S.HaskellD d), vs) -> foldl astAppRec (haskellParseExp d) vs - (Nothing, []) -> tupE [] - (Nothing, [(Just Mybe, varName, _)]) -> conE $ mkName varName - (Nothing, [(Just List, varName, _)]) -> listE [] - (Nothing, [(base_type, v0@(v:_), rec)]) - | isUpper v -> conE $ mkName v0 -- 'Nothing' base case - | otherwise -> appE (varE $ mkName rec) (varE $ mkName v0) - (Nothing, vs) -> tupE $ map appBodyType vs - ) - - e_a2d (G4S.PRHS{G4S.alphas = as0, G4S.pDirective = dir}) = let - - isEpsilonAnnot (G4S.Regular '?') = True - isEpsilonAnnot (G4S.Regular '*') = True - isEpsilonAnnot _ = False - - combos' :: [Either G4S.ProdElem BaseType] -> [Either G4S.ProdElem BaseType] -> [[Either G4S.ProdElem BaseType]] - combos' ys [] = [] - combos' ys (a@(Left a'):as) - | (isEpsilonAnnot . G4S.annot) a' - = (reverse ys ++ (Right $ baseType $ G4S.annot a'):as) -- Production with epsilon-able alpha 'a' removed - : (reverse ys ++ a:as) -- Production without epsilon-able alpha 'a' removed - : ( combos' ((Right $ baseType $ G4S.annot a'):ys) as -- Recursively with epsilon-able alpha 'a' removed - ++ combos' (a:ys) as) -- Recursively *without* it removed - | otherwise = combos' (a:ys) as - combos' ys ((Right _):as) = error "Can't have 'Right' in second list" - - orderNub ps p1 - | p1 `elem` ps = ps - | otherwise = p1 : ps - - combos xs = foldl orderNub [] (combos' [] $ map Left xs) - - in [(astFncnName _A, - map (\as' -> clause (pats as') (normalB $ body dir as') []) $ combos as0 - )] - - in concatMap e_a2d ps - epsilon_a2d _ = [] - - allClauses :: [(Name, [ClauseQ])] - allClauses = (concat . catMaybes . map a2d) ast -- standard clauses ignoring optionals (?,+,*) syntax - ++ (concatMap regex_a2d) ast -- Epsilon-removed optional ast conversion functions - ++ (concatMap epsilon_a2d) ast -- Clauses for productions with epsilons - ++ (concatMap a2d_error_clauses) ast -- Catch-all error clauses - - funDecls lst@((name, _):_) = Just $ funD name $ concatMap snd lst - funDecls [] = error "groupBy can't return an empty list" - - in (catMaybes . map funDecls . groupBy (\a b -> fst a == fst b) . sortBy (comparing fst)) allClauses - - -- terminaLiterals, lexemeNames - - -- IMPORTANT: Creating type variables in two different haskell type - -- quasiquoters with the same variable name produces two (uniquely) named type - -- variables. In order to achieve the same type variable you need to run one - -- in the Q monad first then pass the resulting type to other parts of the - -- code that need it (thus capturing the type variable). - in do - - let tokVal = mkName "TokenValue" - tokName = mkName "TokenName" - ntSym = mkName $ ntDataName ast - tSym = mkName $ tDataName ast - nameAST = mkName (mkUpper $ gName ast ++ "AST") - nameToken = mkName (mkUpper $ gName ast ++ "Token") - nameDFAs = mkName (mkLower $ gName ast ++ "DFAs") - name = mkName $ mkLower (gName ast ++ "Grammar'") - nameUnit = mkName $ mkLower (gName ast ++ "Grammar") - prettyTFncnName <- newName "prettifyT" - prettyValueFncnName <- newName "prettifyValue" - - stateTypeName <- newName "s" - let stateType = varT stateTypeName - - let unitTy = [t| () |] - - gTyUnit <- justGrammarTy ast unitTy - gUnitFunD <- funD nameUnit [clause [] (normalB $ [| LL.removeEpsilons $(varE name) |]) []] - gTySigUnit <- sigD nameUnit (return gTyUnit) - - ntDataDecl <- ntDataDeclQ - tDataDecl <- tDataDeclQ - gTy <- grammarTy stateType - gTy' <- justGrammarTy ast stateType - gTySig <- sigD name (return gTy) - g <- grammar gTy' - gFunD <- funD name [clause [] (normalB (return g)) []] - prettyNT:_ <- [d| instance Prettify $(ntConT ast) where prettify = rshow |] - prettyT:_ <- [d| instance Prettify $(tConT ast) where prettify = $(varE prettyTFncnName) |] - prettyValue:_ <- [d| instance Prettify $(conT tokVal) where prettify = $(varE prettyValueFncnName) |] - lookupTokenD <- lookupTokenFncnDecl - - tokenNameType <- tokenNameTypeQ - tokenValueType <- tokenValueTypeQ - - let lName = mkName "l" - lexeme2Value <- lexeme2ValueQ lName - - regexes <- mkRegexesQ - let dfasName = mkName $ mkLower (gName ast) ++ "DFAs" - let regexesE = varE $ mkName $ mkLower (gName ast) ++ "Regexes" - dfas <- funD dfasName [clause [] (normalB [| map (fst &&& regex2dfa . snd) $(regexesE) |]) []] - - astDecl <-tySynD nameAST [] [t| AST $(conT ntSym) $(conT nameToken) |] - tokDecl <- tySynD nameToken [] [t| Token $(conT tSym) $(conT tokVal) |] - - decls <- [d| - instance Ref $(conT ntSym) where - type Sym $(conT ntSym) = $(conT ntSym) - getSymbol = id - - tokenize :: String -> [$(conT nameToken)] --Token $(conT tokName) $(conT tokVal)] - tokenize = T.tokenize $(varE nameDFAs) lexeme2value - - slrParse :: [$(conT nameToken)] -> LR.LRResult (LR.CoreSLRState $(conT ntSym) (StripEOF (Sym $(conT nameToken)))) $(conT nameToken) $(conT nameAST) - slrParse = (LR.slrParse $(varE nameUnit) event2ast) - - --glrParse :: [$(conT nameToken)] -> LR.LRResult $(conT ntSym) (StripEOF (Sym $(conT nameToken))) $(conT nameToken) $(conT nameAST) - glrParse :: ($(conT tokName) -> Bool) -> [Char] - -> LR.LR1Result - --(LR.CoreLR1State $(conT ntSym) (StripEOF (Sym $(conT nameToken)))) - Int - Char - $(conT nameAST) - glrParse filterF = (LR.glrParseInc2 $(varE nameUnit) event2ast (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value)) - - instance ALL.Token $(conT nameToken) where - type Label $(conT nameToken) = StripEOF (Sym $(conT nameToken)) - getLabel = fromJust . stripEOF . getSymbol - - type Literal $(conT nameToken) = $(conT tokVal) - getLiteral = T.tokenValue - - allstarParse :: [$(conT nameToken)] -> Either String $(conT nameAST) - allstarParse inp = ALL.parse inp (ALL.NT $(s0)) (ALL.atnOf ($(varE nameUnit) :: $(justGrammarTy ast unitTy))) True - - the_ast = $(lift ast) - |] - - prettyTFncn <- prettyTFncnQ prettyTFncnName - prettyVFncn <- prettyVFncnQ prettyValueFncnName - - ast2DTFncns <- sequence $ ast2DTFncnsQ nameAST - - return $ - [ ntDataDecl, tDataDecl - , gTySig, gFunD - , gTySigUnit, gUnitFunD - , tokenNameType, tokenValueType - , prettyTFncn, prettyVFncn - , prettyNT, prettyT, prettyValue - , lookupTokenD - , lexeme2Value - , regexes - , dfas, astDecl, tokDecl - ] ++ decls ++ ast2DTFncns - --- | Support for this is __very__ experimental. This function allows you --- to splice in compile-time computed versions of the LR1 data structures --- so as to decrease the runtime of at-runtime parsing. --- See @test/g4/G4.hs@ and @test/g4/Main.hs@ in the antlr-haskell source for --- example usage of the @glrParseFast@ function generated. -mkLRParser ast g = - let - nameDFAs = mkName (mkLower $ gName ast ++ "DFAs") - tokName = mkName "TokenName" - nameAST = mkName (mkUpper $ grammarName ast ++ "AST") - name = mkName $ mkLower (grammarName ast ++ "Grammar") - is = sort $ S.toList $ LR.lr1Items g - tbl = LR.lr1Table g - - tblInt = LR.convTableInt tbl is - (_lr1Table', errs) = LR.disambiguate tblInt - lr1Table' = M.toList tblInt -- _lr1Table' - lr1S0' = LR.convStateInt is $ LR.lr1Closure g $ LR.lr1S0 g - - unitTy = [t| () |] - name' = [e| $(varE name) |] -- :: $(justGrammarTy' ast unitTy) |] - in do --D.traceM $ pshow' is - D.traceM $ "lr1S0 = " ++ (pshow' $ LR.lr1S0 g) - --D.traceM $ "lr1Table = " ++ (pshow' $ LR.lr1Table g) - D.traceM $ "lr1S0' = " ++ (pshow' lr1S0') - D.traceM $ "lr1Table' = " ++ (pshow' lr1Table') - D.traceM $ "Total LR1 conflicts: " ++ (pshow' errs) - -- - --glrParse filterF = (LR.glrParseInc2 $(varE nameUnit) event2ast (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value)) - --D.traceM $ "disambiguate tbl = " ++ (pshow' $ disambiguate tbl) - [d| lr1ItemsList = sort $ S.toList $ LR.lr1Items $(name') - lr1Table = $(lift lr1Table') - lr1Goto = LR.convGotoStatesInt (LR.convGoto $(name') (LR.lr1Goto $(name')) lr1ItemsList) lr1ItemsList - lr1Closure = convState $ LR.lr1Closure $(name') (LR.lr1S0 $(name')) - lr1S0 = $(lift lr1S0') - convState = LR.convStateInt lr1ItemsList - - glrParseFast :: ($(conT tokName) -> Bool) -> [Char] - -> LR.LR1Result - --(LR.CoreLR1State $(conT ntSym) (StripEOF (Sym $(conT nameToken)))) - Int - Char + , g4_parsers + , mkLRParser + ) where +import Prelude hiding (exp, init) +import System.IO.Unsafe (unsafePerformIO) +import Data.List (nub, elemIndex, groupBy, sortBy, sort, intersperse) +import Data.Ord (comparing) +import Data.Char (toLower, toUpper, isLower, isUpper) +import Data.Maybe (fromJust, catMaybes) + +import qualified Debug.Trace as D + +import qualified Language.Haskell.TH as TH +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (lift, Exp(..)) +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import qualified Language.Haskell.Meta as LHM + +import Control.Monad (mapM) +import qualified Language.ANTLR4.Boot.Syntax as G4S + +--import qualified Language.ANTLR4.Boot.Parser as G4P +import qualified Language.ANTLR4.Boot.SplicedParser as G4P + +import Text.ANTLR.Grammar hiding (getNTs, getProds, s0) +import Text.ANTLR.Parser (AST(..), StripEOF(..)) +import Text.ANTLR.Pretty +import Text.ANTLR.Lex.Tokenizer as T +import Text.ANTLR.LR as LR +import qualified Text.ANTLR.Allstar as ALL +import qualified Text.ANTLR.LL1 as LL +import qualified Text.ANTLR.Set as S + +import qualified Text.ANTLR.MultiMap as M +import qualified Data.Map as M1 +import Text.ANTLR.Set (Set(..)) +import qualified Text.ANTLR.Set as Set +import qualified Text.ANTLR.Lex.Regex as R + +--trace s = D.trace ("[Language.ANTLR4.Boot.Quote] " ++ s) +--traceM s = D.traceM ("[Language.ANTLR4.Boot.Quote] " ++ s) + +trace s x = x +traceM s x = x + +haskellParseExp :: (Monad m) => String -> m TH.Exp +haskellParseExp s = --D.trace ("PARSING: " ++ show s) $ + case LHM.parseExp s of + Left err -> error err + Right expTH -> return expTH + +haskellParseType :: (Monad m) => String -> m TH.Type +haskellParseType s = case LHM.parseType s of + Left err -> trace s (error err) + Right tyTH -> return tyTH + +type2returnType :: TH.Type -> TH.Type +type2returnType = let + + t2rT :: TH.Type -> TH.Type + t2rT (ForallT xs ys t) = t2rT t + t2rT ((AppT (AppT ArrowT from) to)) = t2rT to + t2rT t@(VarT _) = t + t2rT t@(AppT ListT as) = t + t2rT t@(ConT _) = t + t2rT t@(AppT (ConT _) _) = t + t2rT x = error (show x) + + in t2rT + +info2returnType :: Info -> TH.Type +info2returnType i = let + + in case i of + (VarI _ t _) -> type2returnType t + _ -> error (show i) + +--trace s = id +--traceM = return + +-- | There are three different quasiquoters in antlr-haskell, each with varying +-- support for different G4 features. If you're looking for the user-facing +-- quasiquoter then turn back now, because here-be-dragons. The user-facing +-- quasiquoter can be found in 'Language.ANTLR4.G4' as @g4@. +-- +-- * __User-facing__ QuasiQuoter is in 'Language.ANTLR4.G4' +-- * __Spliced__ QuasiQuoter is here +-- * __Boot__ parser is in @src/Language/ANTLR4/Boot/Parser.hs.boot@ +-- +-- The spliced quasiquoter, as packaged and shipped with distributions of +-- antlr-haskell, allows for bootstrapping of the user-facing quasiquoter +-- without requiring parsec as a dependency. The boot quasiquoter on the +-- other hand is written entirely in parsec. +antlr4 :: QuasiQuoter +antlr4 = QuasiQuoter + (error "parse exp") + (error "parse pattern") + (error "parse type") + aparse --(error "parse decl") + +-- e.g. Named ("Num", "Int") where 'Num' was a G4 lexeme and 'Int' was given +-- as a directive specifying the desired type to read (must instance Read). +data LexemeType = + Literal Int -- A literal lexeme somewhere in the grammar, e.g. ';' + | AString -- Type was unspecified in the G4 lexeme or specified as a String + | Named String TH.TypeQ -- Type was specified as a directive in the G4 lexeme + +aparse :: String -> TH.Q [TH.Dec] +aparse input = do + loc <- TH.location + let fileName = TH.loc_filename loc + let (line,column) = TH.loc_start loc + + case G4P.parseANTLR input of + r@(LR.ResultAccept ast) -> codeGen r + LR.ResultSet s -> + if S.size s == 1 + then codeGen (S.findMin s) + else error $ pshow' s + err -> error $ pshow' err + +codeGen (LR.ResultAccept ast) = g4_decls $ G4P.ast2decls ast + +{- +-- parser in quasiquotation monad +aparse :: String -> TH.Q [TH.Dec] +aparse input = do + -- TODO: replace bad error showing with + -- debugging information (filename, line #, column) in parser + loc <- TH.location + let fileName = TH.loc_filename loc + let (line,column) = TH.loc_start loc + + case G4P.parseANTLR fileName line column input of + Left err -> unsafePerformIO $ fail $ show err + Right x -> g4_decls x +-} + +data BaseType = List | Mybe + deriving (Eq, Ord, Show) + +baseType (G4S.Regular '?') = Mybe +baseType (G4S.Regular '*') = List + +-- Find the (first) name of the grammar +grammarName :: [G4S.G4] -> String +grammarName [] = error "Grammar missing a name" +grammarName (G4S.Grammar{G4S.gName = gName}:_) = gName +grammarName (_:xs) = grammarName xs + +mkLower [] = [] +mkLower (a:as) = toLower a : as + +mkUpper [] = [] +mkUpper (a:as) = toUpper a : as + +justGrammarTy ast s = [t| Grammar $(s) $(ntConT ast) $(tConT ast) G4S.Directive |] +justGrammarTy' ast s = [t| Grammar $(s) $(ntConT ast) (StripEOF (Sym $(tConT ast))) G4S.Directive |] + +ntConT ast = conT $ mkName $ ntDataName ast +tConT ast = conT $ mkName $ tDataName ast + +ntDataName ast = gName ast ++ "NTSymbol" +tDataName ast = gName ast ++ "TSymbol" + +gName ast = grammarName ast + +type G4AST = [G4S.G4] + +-- A list of all the G4 literal terminals scattered across production rules +terminalLiterals :: G4AST -> [String] +terminalLiterals ast = (nub $ concatMap getTerminals ast) + +-- Find all terminal literals in a G4 grammar rule like '(' and ')' and ';' +getTerminals :: G4S.G4 -> [String] +getTerminals G4S.Prod{G4S.patterns = ps} = concatMap (justTerms . G4S.alphas) ps +getTerminals _ = [] + +-- THIS EXCLUDES LEXEME FRAGMENTS: +-- e.g. [('UpperID', AString), ('SetChar', Named String)] +lexemeTypes :: G4AST -> [(String, LexemeType)] +lexemeTypes ast = let + + nullID (G4S.UpperD xs) = null xs + nullID (G4S.LowerD xs) = null xs + nullID (G4S.HaskellD _) = False + + lN :: G4S.G4 -> [(String, LexemeType)] + lN (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Nothing}}) = [(lName, AString)] + lN (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Just s}}) + | s == (G4S.UpperD "String") = [(lName, AString)] + | nullID s = [(lName, AString)] -- quirky G4 parser + | otherwise = case s of + (G4S.UpperD s) -> [(lName, Named s (conT $ mkName s))] + (G4S.LowerD s) -> [(lName, Named s (info2returnType <$> reify (mkName s)))] + (G4S.HaskellD s) -> [] -- TODO? + lN _ = [] + in concatMap lN ast + --map (\s -> normalC (mkName s) []) lN' + +-- A list of all the G4 lexeme names specified in the grammar +lexemeNames :: G4AST -> [String] +lexemeNames ast = map fst (lexemeTypes ast) + +-- Find all terminals *literals* in a production like '(' and ')' and ';' +justTerms :: [G4S.ProdElem] -> [String] +justTerms [] = [] +justTerms ((G4S.GTerm _ s) : as) = s : justTerms as +justTerms (_:as) = justTerms as + +-- A list of all the terminals in the grammar (both literal G4 terminals and +-- G4 lexical terminals) +terminals :: G4AST -> [String] +terminals ast = terminalLiterals ast ++ (lexemeNames ast) + +nonterms :: G4AST -> [String] +nonterms ast = nub $ concatMap getNTs ast + +-- Find all nonterminals in a production like 'exp' and 'decl' +justNonTerms :: [G4S.ProdElem] -> [String] +justNonTerms [] = [] +justNonTerms (G4S.GNonTerm _ s:as) + | (not . null) s && isLower (head s) = s : justNonTerms as + | otherwise = justNonTerms as +justNonTerms (_:as) = justNonTerms as + +-- Find all the nonterminals referenced in the production(s) of the given grammar rule +getNTs :: G4S.G4 -> [String] +getNTs G4S.Prod{G4S.pName = pName, G4S.patterns = ps} = pName : concatMap (justNonTerms . G4S.alphas) ps +getNTs _ = [] + +-- Things Symbols must derive: +symbolDerives = derivClause Nothing $ map (conT . mkName) + [ "Eq", "Ord", "Show", "Hashable", "Generic", "Bounded", "Enum", "Data", "Lift"] + +-- Nonterminal symbol data type (enum) for this grammar: +ntDataDeclQ :: G4AST -> DecQ +ntDataDeclQ ast = + dataD (cxt []) + (mkName $ ntDataName ast) + [] + Nothing + (map (\s -> normalC (mkName $ "NT_" ++ s) []) $ (nonterms ast) ++ (regexNonTermSymbols ast)) + [symbolDerives] + +-- E.g. ['(', ')', ';', 'exp', 'decl'] +allLexicalSymbols :: G4AST -> [String] +allLexicalSymbols ast = map (lookupTName ast "") (terminalLiterals ast) ++ (lexemeNames ast) + +-- E.g. [('(', Literal 0), (')', Literal 1), (';', Literal 2), ('exp', +-- AString), ('decl', AString')] +allLexicalTypes :: G4AST -> [(String, LexemeType)] +allLexicalTypes ast = (map (lookupLiteralType ast) (terminalLiterals ast)) ++ (lexemeTypes ast) + +-- E.g. [('(', Literal 0), ...] +lookupLiteralType :: G4AST -> String -> (String, LexemeType) +lookupLiteralType ast s = + case s `elemIndex` (terminalLiterals ast) of + Nothing -> undefined + Just i -> (s, Literal i) + +-- Terminal symbol data type (enum) for this grammar: +tDataDeclQ :: G4AST -> DecQ +tDataDeclQ ast = + dataD (cxt []) + (mkName $ tDataName ast) + [] + Nothing + (map (\s -> normalC (mkName s) []) (map ("T_" ++) (allLexicalSymbols ast))) + --(\s -> normalC (mkName $ lookupTName ast "T_" s) []) lexemes) ++ (lexemeNames "T_")) + [symbolDerives] + +-- Map from a terminal's syntax to the name of the data type instance from +-- tDataDeclQ: +lookupTName :: G4AST -> String -> String -> String +lookupTName ast pfx s = pfx ++ + (case s `elemIndex` (terminalLiterals ast) of + Nothing -> s + Just i -> show i) + +defBang = bang noSourceUnpackedness noSourceStrictness + +strBangType = (defBang, conT $ mkName "String") + +mkCon = conE . mkName . mkUpper +mkConNT = conE . mkName . ("NT_" ++) + +-- | Regular expression term annotations are just syntactic sugar by any other name. +-- Computes the set of productions that need to be added to the grammar to support +-- surface-syntax-level annotations on production rule terms. +genTermAnnotProds :: [G4S.G4] -> [G4S.G4] +genTermAnnotProds [] = [] +genTermAnnotProds (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) = let + + withAlphas newName d a = G4S.Prod {G4S.pName = newName, G4S.patterns = + [ G4S.PRHS + { G4S.pred = Nothing + , G4S.alphas = a + , G4S.mutator = Nothing + , G4S.pDirective = Just d + } + ]} + + gTAP :: G4S.ProdElem -> [G4S.G4] + gTAP (G4S.GNonTerm (G4S.Regular '?') nt) = trace (show nt) + [ withAlphas (nt ++ "_quest") (G4S.UpperD "Just") [G4S.GNonTerm G4S.NoAnnot nt] + , withAlphas (nt ++ "_quest") (G4S.UpperD "Nothing") [] -- epsilon + ] + gTAP (G4S.GNonTerm (G4S.Regular '*') nt) = + [ withAlphas (nt ++ "_star") (G4S.HaskellD "(:)") [G4S.GNonTerm G4S.NoAnnot nt, G4S.GNonTerm G4S.NoAnnot (nt ++ "_star")] + , withAlphas (nt ++ "_star") (G4S.HaskellD "(\\x -> [x])") [G4S.GNonTerm G4S.NoAnnot nt] + , withAlphas (nt ++ "_star") (G4S.HaskellD "[]") [] + ] + gTAP (G4S.GNonTerm (G4S.Regular '+') nt) = + [ withAlphas (nt ++ "_plus") (G4S.HaskellD "(:)") [G4S.GNonTerm G4S.NoAnnot nt, G4S.GNonTerm G4S.NoAnnot (nt ++ "_plus")] + , withAlphas (nt ++ "_plus") (G4S.HaskellD "(\\x -> [x])") [G4S.GNonTerm G4S.NoAnnot nt] + ] + gTAP (G4S.GNonTerm G4S.NoAnnot nt) = [] + gTAP (G4S.GTerm _ t) = [] + gTAP term = error $ show term + in concat (concatMap (map gTAP) (map G4S.alphas ps)) ++ genTermAnnotProds xs +genTermAnnotProds (_:xs) = genTermAnnotProds xs + +annotName G4S.NoAnnot s = s +annotName (G4S.Regular '?') s = s ++ "_quest" +annotName (G4S.Regular '*') s = s ++ "_star" +annotName (G4S.Regular '+') s = s ++ "_plus" +annotName (G4S.Regular c) s = s ++ [c] -- TODO: warning on unknown character annotation + +annotName' (G4S.GTerm annot s) = annotName annot s +annotName' (G4S.GNonTerm annot s) = annotName annot s + +regexNonTermSymbols ast = let + + rNTS (G4S.Prod {G4S.patterns = ps}) = Just $ map G4S.alphas ps + rNTS _ = Nothing + + in nub $ map annotName' $ filter (not . G4S.isNoAnnot . G4S.annot) (concat $ concat $ catMaybes $ map rNTS ast) + +{- +toElem :: G4AST -> G4S.ProdElem, Maybe DataType) -> (TH.ExpQ +toElem ast (G4S.GTerm annot s, dt) = ([| $(mkCon "T") $(mkCon $ lookupTName ast "T_" (annotName annot s)) |], dt) +toElem ast (G4S.GNonTerm annot s, dt) + | (not . null) s && isLower (head s) = ([| $(mkCon "NT") $(mkConNT (annotName annot s)) |], dt) + | otherwise = toElem ast (G4S.GTerm G4S.NoAnnot s, dt) + +mkProd :: String -> [(TH.ExpQ, Maybe DataType)] -> TH.ExpQ +mkProd n [] = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") [Eps]) (Just "") |] +mkProd n es = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") $(listE es)) (Just "") |] + +getProds :: G4AST -> [G4S.G4] -> [TH.ExpQ] +getProds ast [] = [] +getProds ast (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) + = map (mkProd n . map (toElem ast) . (\p -> (G4S.alphas p, G4S.pDirective p))) ps ++ ((getProds ast) xs) +getProds ast (_:xs) = (getProds ast) xs +-} + +getProds :: G4AST -> [G4S.G4] -> [TH.ExpQ] +getProds ast [] = [] +getProds ast (G4S.Prod {G4S.pName = n, G4S.patterns = ps}:xs) = let + + toElem :: G4S.ProdElem -> TH.ExpQ + toElem (G4S.GTerm annot s) = [| $(mkCon "T") $(mkCon $ lookupTName ast "T_" (annotName annot s)) |] + toElem (G4S.GNonTerm annot s) + | (not . null) s && isLower (head s) = [| $(mkCon "NT") $(mkConNT (annotName annot s)) |] + | otherwise = toElem (G4S.GTerm G4S.NoAnnot s) + + mkProd :: Maybe G4S.Directive -> [TH.ExpQ] -> TH.ExpQ + mkProd dir [] = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") []) $(lift dir) |] + mkProd dir es = [| $(mkCon "Production") $(conE $ mkName $ "NT_" ++ n) ($(mkCon "Prod") $(mkCon "Pass") $(listE es)) $(lift dir) |] + + in map (\p -> mkProd (G4S.pDirective p) (map toElem $ G4S.alphas p)) ps ++ ((getProds ast) xs) +getProds ast (_:xs) = (getProds ast) xs + +-- The first NonTerminal in the grammar (TODO: head of list) +s0 :: G4AST -> TH.ExpQ +s0 ast = conE $ mkName $ "NT_" ++ head (nonterms ast) + +grammarProds ast = getProds ast (ast ++ ({- D.traceShowId -} (genTermAnnotProds ast))) + +grammar ast gTy = [| (defaultGrammar $(s0 ast) :: $(return gTy)) + { ns = Set.fromList [minBound .. maxBound :: $(ntConT ast)] + , ts = Set.fromList [minBound .. maxBound :: $(tConT ast)] + , ps = $(listE $ grammarProds ast) + } |] + +--grammarTy s = [t| forall $(s). (Prettify $(s)) => $(justGrammarTy s) |] +grammarTy ast s = [t| (Prettify $(s)) => $(justGrammarTy ast s) |] + +{----------------------- Tokenizer -----------------------} + +tokenNameTypeQ ast = tySynD (mkName "TokenName") [] (conT $ mkName $ tDataName ast) + +lexemeValueDerives = derivClause Nothing $ map (conT . mkName) + ["Show", "Ord", "Eq", "Generic", "Hashable", "Data"] + +-- +lexemeTypeConstructors ast = let + nullD (G4S.UpperD s) = null s + nullD (G4S.LowerD s) = null s + nullD (G4S.HaskellD s) = null s + + lTC (i, lex@(G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.directive = Just d}})) + | null lName = error $ "null lexeme name: " ++ show lex + | nullD d = Just $ normalC (mkName $ "V_" ++ lName) [bangType defBang (conT $ mkName "String")] + | otherwise = case d of + (G4S.UpperD d) -> Just $ normalC (mkName $ "V_" ++ lName) [bangType defBang (conT $ mkName d)] + (G4S.LowerD d) -> Just $ do + info <- reify $ mkName d + normalC (mkName $ "V_" ++ lName) [bangType defBang (return $ info2returnType info)] + --Just $ [|| $$(haskellParseExp d) ||] --error $ "unimplemented use of function in G4 directive: " ++ show d + (G4S.HaskellD s) -> Nothing -- TODO? + lTC _ = Nothing + in ((catMaybes $ map lTC (zip [0 .. length ast - 1] ast)) + ++ (map (\s -> normalC (mkName $ lookupTName ast "V_" s) []) (terminalLiterals ast))) + +tokenValueTypeQ ast = + dataD (cxt []) (mkName "TokenValue") [] Nothing + (lexemeTypeConstructors ast) + [lexemeValueDerives] + +mkTyVar s f = return $ f $ mkName s + +lookupTokenFncnDecl ast = let + lTFD t = clause [litP $ stringL t] + (normalB $ [| Token $(conE $ mkName $ lookupTName ast "T_" t) + $(conE $ mkName $ lookupTName ast "V_" t) + $(litE $ integerL $ fromIntegral $ length t) |]) + [] + in funD (mkName "lookupToken") + ( map lTFD (terminalLiterals ast) + ++ [clause [varP $ mkName "s"] + (normalB $ [| error ("Error: '" ++ s ++ "' is not a token") |]) + []] + ) + +-- Construct the function that takes in a lexeme (string) and the token name +-- (T_*) and constructs a token value type instance using 'read' where +-- appropriate based on the directives given in the grammar. +lexeme2ValueQ ast lName = let + + l2VQ (_, Literal i) = + clause [varP lName, conP (mkName $ "T_" ++ show i) []] + (normalB [| $(conE $ mkName $ "V_" ++ show i) |]) [] + l2VQ (s, AString) = + clause [varP lName, conP (mkName $ "T_" ++ s) []] + (normalB [| $(conE $ mkName $ "V_" ++ s) $(varE lName) |]) [] + l2VQ (s, Named n t) + | isLower (head n) = + clause [varP lName, conP (mkName $ "T_" ++ s) []] + (normalB [| $(conE $ mkName $ "V_" ++ s) (trace $(varE lName) ($(varE $ mkName n) $(varE lName) :: $t)) |]) [] + | otherwise = + clause [varP lName, conP (mkName $ "T_" ++ s) []] + (normalB [| $(conE $ mkName $ "V_" ++ s) (trace $(varE lName) (read $(varE lName) :: $t)) |]) [] + + --info <- reify $ mkName d + --normalC (mkName $ "V_" ++ lName) [bangType defBang (return $ info2returnType info)] + + in funD (mkName "lexeme2value") (map l2VQ (allLexicalTypes ast)) + +-- Convert a G4 regex into the backend regex type (for constructing token +-- recognizers as DFAs): +convertRegex :: (Show c) => (String -> G4S.Regex c) -> G4S.Regex c -> R.Regex c +convertRegex getNamedR = let + cR G4S.Epsilon = R.Epsilon + cR (G4S.Literal []) = R.Epsilon + cR (G4S.Literal [c]) = R.Symbol c + cR (G4S.Literal cs) = R.Literal cs + cR (G4S.Union rs) = R.MultiUnion $ map cR rs + cR (G4S.Concat rs) = R.Concat $ map cR rs + cR (G4S.Kleene r) = R.Kleene $ cR r + cR (G4S.PosClos r) = R.PosClos $ cR r + cR (G4S.Question r) = R.Question $ cR r + cR (G4S.CharSet cs) = R.Class cs + cR (G4S.Named n) = convertRegex getNamedR $ getNamedR n + cR (G4S.Negation (G4S.CharSet cs)) = R.NotClass cs + cR (G4S.Negation (G4S.Literal s)) = R.NotClass s + cR (G4S.Negation (G4S.Concat [G4S.Literal s])) = R.NotClass s + cR r@(G4S.Negation _) = error $ "unimplemented: " ++ show r + in cR + +getNamedRegex :: G4AST -> String -> G4S.Regex Char +getNamedRegex ast n = let + -- Only the lexeme (fragments) with the given name: + gNR (G4S.Lex{G4S.annotation = Just G4S.Fragment, G4S.lName = lName}) = lName == n + gNR _ = False + in case filter gNR ast of + [] -> error $ "No fragment named '" ++ n ++ "'" + [(G4S.Lex{G4S.pattern = G4S.LRHS{G4S.regex = r}})] -> r + xs -> error $ "Too many fragments named '" ++ n ++ "', i.e.: " ++ show xs + +-- Make the list of tuples containing regexes, one for each terminal. +mkRegexesQ ast = let + mkLitR :: String -> ExpQ + mkLitR s = [| ($( conE $ mkName $ lookupTName ast "T_" s) + , $(lift $ convertRegex (getNamedRegex ast) $ G4S.Literal s)) |] + + mkLexR :: G4S.G4 -> Maybe ExpQ + mkLexR (G4S.Lex{G4S.annotation = Nothing, G4S.lName = lName, G4S.pattern = G4S.LRHS{G4S.regex = r}}) = Just + [| ($(conE $ mkName $ lookupTName ast "T_" lName), $(lift $ convertRegex (getNamedRegex ast) r)) |] + mkLexR _ = Nothing + in valD (varP $ mkName $ mkLower $ gName ast ++ "Regexes") + (normalB $ listE (map mkLitR (terminalLiterals ast) ++ (catMaybes $ map mkLexR ast))) + [] + +prettyTFncnQ ast fncnName = let + pTFLit lexeme = + clause [conP (mkName $ lookupTName ast "T_" lexeme) []] + (normalB [| pStr $(litE $ stringL $ "'" ++ lexeme ++ "'") |]) + [] + + pTFName lexeme = + clause [conP (mkName $ lookupTName ast "T_" lexeme) []] + (normalB [| pStr $(litE $ stringL $ lexeme) |]) + [] + in funD fncnName (map pTFLit (terminalLiterals ast) ++ map pTFName (lexemeNames ast)) + +prettyVFncnQ ast fncnName = let + pVFLit lexeme = + clause [conP (mkName $ lookupTName ast "V_" lexeme) []] + (normalB [| pStr $(litE $ stringL $ "'" ++ lexeme ++ "'") |]) + [] + + pVFName lexeme = + clause [conP (mkName $ lookupTName ast "V_" lexeme) [varP (mkName "v")]] + (normalB [| pChr '\'' >> prettify v >> pChr '\'' |]) + [] + in funD fncnName (map pVFLit (terminalLiterals ast) ++ map pVFName (lexemeNames ast)) + +astFncnName s = mkName $ "ast2" ++ s + +a2d ast nameAST G4S.Lex{G4S.annotation = Nothing, G4S.lName = _A, G4S.pattern = G4S.LRHS{G4S.directive = dir}} + = Just [(mkName $ "ast2" ++ _A + ,[ clause [ conP (mkName "Leaf") + [ conP (mkName $ "Token") + [ wildP + , conP (mkName $ lookupTName ast "V_" _A) + [ varP $ mkName "t"] + , wildP]]] + (normalB (varE $ mkName "t")) + [] + ] + )] +{- +a2d G4S.Lex{G4S.lName = _A, G4S.pattern = G4S.LRHS{G4S.directive = Just s}} + | s == "String" = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName "id")) [] ]] + | null s = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName "id")) [] ]] + | otherwise = Just [funD (mkName $ "ast2" ++ _A) [ clause [] (normalB (varE $ mkName s)) [] ]] +-} +a2d ast nameAST G4S.Prod{G4S.pName = _A, G4S.patterns = ps} = let + + mkConP (G4S.GNonTerm annot nt) + -- Some nonterminals are really terminal tokens (regular expressions): + | isUpper (head nt) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot nt) []] + | otherwise = conP (mkName "NT") [conP (mkName $ "NT_" ++ annotName annot nt) []] + mkConP (G4S.GTerm annot t) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot t) []] + + justStr (G4S.GNonTerm annot s) = annotName annot s + justStr (G4S.GTerm _ s) = s + + vars as = catMaybes + [ if G4S.isGNonTerm a + then Just (a, mkName $ "v" ++ show i ++ "_" ++ justStr a, varE $ mkName $ "ast2" ++ justStr a) + else Nothing + | (i, a) <- zip [0 .. length as] as + ] + + astListPattern as = listP $ + [ if G4S.isGNonTerm a + then varP $ mkName $ "v" ++ show i ++ "_" ++ justStr a + else wildP + | (i, a) <- zip [0 .. length as] as + ] + + astAppRec b (alpha, varName, recName) = appE b (appE recName $ varE varName) + {- case G4S.annot alpha of + G4S.NoAnnot -> appE b (appE recName $ varE varName) + (G4S.Regular '?') -> appE b (appE recName $ varE varName) + -- TODO: Below two cases: + (G4S.Regular '*') -> appE b (appE recName $ varE varName) + (G4S.Regular '+') -> appE b (appE recName $ varE varName) + otherwise -> error $ show alpha -} + + clauses = [ clause [ [p| AST $(conP (mkName $ "NT_" ++ _A) []) + $(listP $ map mkConP as) + $(astListPattern as) + |] + ] + (case (dir, vars as) of + (Just (G4S.UpperD d), vs) -> normalB $ foldl astAppRec (conE $ mkName d) vs + (Just (G4S.LowerD d), vs) -> normalB $ foldl astAppRec (varE $ mkName d) vs + (Just (G4S.HaskellD d), vs) -> normalB $ foldl astAppRec (haskellParseExp d) vs + (Nothing, []) -> normalB $ tupE [] + (Nothing, [(a,v0,rec)]) -> normalB $ appE rec (varE v0) + (Nothing, vs) -> normalB $ tupE $ map (\(a,vN,rN) -> appE rN $ varE vN) vs + ) [] + | G4S.PRHS{G4S.alphas = as, G4S.pDirective = dir} <- ps + ] + + retType = let + rT G4S.PRHS{G4S.alphas = as, G4S.pDirective = dir} + = case (dir, vars as) of + (Just (G4S.UpperD d), vs) -> + (do i <- reify $ mkName d + (case i of + DataConI _ t n -> return $ type2returnType t + VarI n t _ -> return t + TyConI (DataD _ n _ _ _ _) -> conT n + other -> error $ show other)) + (Just (G4S.LowerD d), vs) -> info2returnType <$> reify (mkName d) + (Just (G4S.HaskellD d), vs) -> error "unimplemented" -- TODO if we ever add back the fncnSig below + (Nothing, []) -> tupleT 0 + (Nothing, [(a,v0,rec)]) -> tupleT 0 + (Nothing, vs) -> tupleT $ length vs + in rT (head ps) + + fncnSig + = do rT <- retType + (case rT of + ForallT vs c t -> forallT vs (cxt []) [t| $(conT nameAST) -> $(return t) |] + t -> forallT [] (cxt []) [t| $(conT nameAST) -> $(return t) |]) + + in Just $ [ --sigD fncnName fncnSig + (astFncnName _A, clauses) + ] +a2d ast nameAST _ = Nothing + +a2d_error_clauses G4S.Prod{G4S.pName = _A} = + [(astFncnName _A, [ clause [ [p| ast2 |] ] (normalB [| error $ "Failed pattern match on " ++ (show ast2) |]) [] ])] +a2d_error_clauses _ = [] + + --concat $ (concatMap eachAlpha . map G4S.alphas) ps + +{- +epsilon_a2d ast (G4S.Prod{G4S.pName = _A, G4S.patterns = ps}) = let + + mkConP (G4S.GNonTerm annot nt) + -- Some nonterminals are really terminal tokens (regular expressions): + | isUpper (head nt) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot nt) []] + | otherwise = conP (mkName "NT") [conP (mkName $ "NT_" ++ annotName annot nt) []] + mkConP (G4S.GTerm annot t) = conP (mkName "T") [conP (mkName $ lookupTName ast "T_" $ annotName annot t) []] + + justStr (G4S.GNonTerm annot s) = annotName annot s + justStr (G4S.GTerm _ s) = s + + justStr' (Left a) = Just $ justStr a + justStr' _ = Nothing + + maybeBaseType (Left _) = Nothing + maybeBaseType (Right x) = Just x + + isValid (Left x) = G4S.isGNonTerm x + isValid (Right _) = True + --isValid _ = False + + vars :: [Either G4S.ProdElem BaseType] -> [(Maybe BaseType, String, String)] + vars as = let + vars' (base_type, i, Just s) = (base_type, "v" ++ show i ++ "_" ++ s, "ast2" ++ s) + vars' (Just Mybe, i, Nothing) = (Just Mybe, "Nothing", "undefined") + vars' (Just List, i, Nothing) = (Just List, "[]", "undefined") + --vars' (base_type, i, Nothing) = (base_type, "[]", "undefined") + + + in (map vars' . map (\(i,a) -> (maybeBaseType a, i, justStr' a)) . filter (isValid . snd) . zip [0 .. length as]) as + + astListPattern as = listP + [ case a of + (G4S.GNonTerm annot s) -> varP $ mkName $ "v" ++ show i ++ "_" ++ annotName annot s + otherwise -> wildP + | (i, a) <- catLeftsTuple $ zip [0 .. length as] as + ] + + catLeftsTuple :: [(i, Either a b)] -> [(i,a)] + catLeftsTuple [] = [] + catLeftsTuple ((i, Left x):rst) = (i, x) : catLeftsTuple rst + catLeftsTuple (_:rst) = catLeftsTuple rst + + astAppRec b (Just Mybe, varName, _) = appE b (conE $ mkName varName) + astAppRec b (Just List, varName, _) = appE b (listE []) + astAppRec b (base_type, varName@(v:_), recName) + | isLower v = appE b (appE (varE $ mkName recName) $ varE $ mkName varName) + | otherwise = appE b (appE (varE $ mkName recName) $ conE $ mkName varName) + {- + G4S.NoAnnot -> appE b (appE recName $ varE $ mkName varName) + (G4S.Regular '?') -> appE b (appE recName $ varE $ mkName varName) + (G4S.Regular '*') -> appE b (appE recName $ varE $ mkName varName) + (G4S.Regular '+') -> appE b (appE recName $ varE $ mkName varName) + otherwise -> error $ show (b,(varName,recName)) + -} + + catLefts [] = [] + catLefts (((Left x)):rst) = x : catLefts rst + catLefts (_:rst) = catLefts rst + + pats as = [ [p| AST $(conP (mkName $ "NT_" ++ _A) []) + $(listP $ map mkConP $ catLefts as) + $(astListPattern as) + |] + ] + + appBodyType (base_type, vN@(v:_), rN) + | isLower v = appE (varE $ mkName rN) $ varE $ mkName vN + | otherwise = conE $ mkName vN + + body dir as = (case (dir, vars as) of + (Just (G4S.UpperD d), vs) -> foldl astAppRec (conE $ mkName d) vs + (Just (G4S.LowerD d), vs) -> foldl astAppRec (varE $ mkName d) vs + (Just (G4S.HaskellD d), vs) -> foldl astAppRec (haskellParseExp d) vs + (Nothing, []) -> tupE [] + (Nothing, [(Just Mybe, varName, _)]) -> conE $ mkName varName + (Nothing, [(Just List, varName, _)]) -> listE [] + (Nothing, [(base_type, v0@(v:_), rec)]) + | isUpper v -> conE $ mkName v0 -- 'Nothing' base case + | otherwise -> appE (varE $ mkName rec) (varE $ mkName v0) + (Nothing, vs) -> tupE $ map appBodyType vs + ) + + e_a2d (G4S.PRHS{G4S.alphas = as0, G4S.pDirective = dir}) = let + + isEpsilonAnnot (G4S.Regular '?') = True + isEpsilonAnnot (G4S.Regular '*') = True + isEpsilonAnnot _ = False + + combos' :: [Either G4S.ProdElem BaseType] -> [Either G4S.ProdElem BaseType] -> [[Either G4S.ProdElem BaseType]] + combos' ys [] = [] + combos' ys (a@(Left a'):as) + | (isEpsilonAnnot . G4S.annot) a' + = (reverse ys ++ (Right $ baseType $ G4S.annot a'):as) -- Production with epsilon-able alpha 'a' removed + : (reverse ys ++ a:as) -- Production without epsilon-able alpha 'a' removed + : ( combos' ((Right $ baseType $ G4S.annot a'):ys) as -- Recursively with epsilon-able alpha 'a' removed + ++ combos' (a:ys) as) -- Recursively *without* it removed + | otherwise = combos' (a:ys) as + combos' ys ((Right _):as) = error "Can't have 'Right' in second list" + + orderNub ps p1 + | p1 `elem` ps = ps + | otherwise = p1 : ps + + combos xs = foldl orderNub [] (combos' [] $ map Left xs) + + in [(astFncnName _A, + map (\as' -> clause (pats as') (normalB $ body dir as') []) $ combos as0 + )] + + in concatMap e_a2d ps +epsilon_a2d ast _ = [] +-} + +mkTupler n = let + xs = ["p" ++ show i | i <- [0 .. n - 1]] + xs_comma = intersperse "," xs + in "(\\" ++ concat (intersperse " " xs) ++ " -> (" ++ concat xs_comma ++ "))" + +-- | Post-condition: all TermAnnots in this production are NoAnnots, +-- and all directives are not Nothing (Nothings turn into Unit, identity function, or tupler). +wipeOutAnnots p@(G4S.Prod{G4S.pName = _A, G4S.patterns = ps}) = let + + wOA prhs@(G4S.PRHS { G4S.alphas = as0, G4S.pDirective = dir }) = let + + repAnnots pe@(G4S.GTerm G4S.NoAnnot _) = pe + repAnnots pe@(G4S.GNonTerm G4S.NoAnnot _) = pe + repAnnots (G4S.GTerm a s) = G4S.GTerm G4S.NoAnnot (annotName a s) + repAnnots (G4S.GNonTerm a s) = G4S.GNonTerm G4S.NoAnnot (annotName a s) + + dir' = let + as0' = filter G4S.isGNonTerm as0 + in case dir of + Just x -> Just x + Nothing + | length as0' == 0 -> Just $ G4S.HaskellD "()" + | length as0' == 1 -> Just $ G4S.HaskellD "(\\x -> x)" + | otherwise -> Just $ G4S.HaskellD $ mkTupler (length as0') + + in prhs { G4S.alphas = map repAnnots as0, G4S.pDirective = dir' } + + in p { G4S.patterns = map wOA ps } +wipeOutAnnots x = x + +--allClauses :: Grammar s nts t -> G4AST -> [(Name, [ClauseQ])] +allClauses gr ast' nameAST = let + + ast = genTermAnnotProds ast' ++ ast' + + in + (concat . catMaybes . map (a2d ast nameAST)) ast -- standard clauses ignoring optionals (?,+,*) syntax +{- ++ (concatMap regex_a2d) ast -- Epsilon-removed optional ast conversion functions -} +{- ++ (concatMap (epsilon_a2d ast)) ast -- Clauses for productions with epsilons -} + ++ (concatMap a2d_error_clauses) ast -- Catch-all error clauses + +funDecls lst@((name, _):_) = Just $ funD name $ concatMap snd lst +funDecls [] = error "groupBy can't return an empty list" + +-- Pattern matches on an AST to produce a Maybe DataType +ast2DTFncnsQ gr ast nameAST = + (catMaybes . map funDecls . groupBy (\a b -> fst a == fst b) . sortBy (comparing fst)) (allClauses gr ast nameAST) + +unitTy = [t| () |] + +removeEpsilonsAST :: [G4S.G4] -> [G4S.G4] +removeEpsilonsAST ast = let + + getPRHS (G4S.Prod { G4S.pName = s, G4S.patterns = ps }) = map (\as -> (s, as)) ps + getPRHS _ = [] + + epsNT (_A, G4S.PRHS { G4S.alphas = [], G4S.pDirective = dir}) = (:) (_A, dir) + epsNT _ = id + + epsNTs = foldr epsNT [] (concatMap getPRHS ast) + + -- Maintains order with a foldr + orderNub ast0 asts + | ast0 `elem` asts = asts + | otherwise = ast0 : asts + + replicateDeclFor (nts0, dflt) (G4S.Prod { G4S.pName = nt1, G4S.patterns = ps }) = let + + -- Reconstruct the directive such that we drop one symbol (NT or T) between ys xs + -- (starting with ys, ending with xs) + dropOne ys' xs' dir = + let ys = filter G4S.isGNonTerm ys' + xs = filter G4S.isGNonTerm xs' + + params_ys = map (\i -> " p" ++ show i ++ " ") [0 .. length ys - 1] + params_xs = map (\i -> " p" ++ show i ++ " ") [length ys .. length ys + length xs - 1] + + both = concat (intersperse "," $ params_ys ++ params_xs) + + ifNull s + | null s = "id" + | otherwise = s + + s_dir = case dir of + Just (G4S.UpperD s) -> "(" ++ ifNull s ++ ")" + Just (G4S.LowerD s) -> "(" ++ ifNull s ++ ")" + Just (G4S.HaskellD s) -> "(" ++ ifNull s ++ ")" + -- tuple-er: + Nothing + | length (params_ys ++ params_xs) == 0 -> "()" + | length (params_ys ++ params_xs) == 1 -> "(\\x -> x)" + | otherwise -> "(\\" ++ concat params_ys ++ concat params_xs ++ " -> (" + ++ both ++ "))" + + s_dflt = case dflt of + Just (G4S.UpperD s) -> s + Just (G4S.LowerD s) -> s + Just (G4S.HaskellD s) -> s + Nothing -> " () " + + ret + | length params_ys + length params_xs == 0 = Just $ G4S.HaskellD $ "(" ++ s_dir ++ " " ++ s_dflt ++ ")" + | otherwise = Just $ G4S.HaskellD $ "(\\" ++ concat params_ys ++ concat params_xs ++ " -> " ++ s_dir + ++ " " ++ concat params_ys ++ " " ++ s_dflt ++ " " ++ concat params_xs ++ ")" + + in ret + + rDF prhs ys [] = [ updatePRHS prhs $ reverse ys ] + rDF prhs ys (x:xs) = let + + newPRHS = prhs { G4S.pDirective = dropOne ys xs (G4S.pDirective prhs) } + + result + | G4S.prodElemSymbol x == nts0 -- String equality + = updatePRHS newPRHS (reverse ys ++ xs) + : updatePRHS prhs (reverse ys ++ x:xs) + : ( rDF newPRHS ys xs -- Recursively with nts0 removed + ++ rDF prhs (x:ys) xs) -- Recursively without nts0 removed + | otherwise = rDF prhs (x:ys) xs + + in result + + updatePRHS prhs xs = prhs { G4S.alphas = xs } + + in ( G4S.Prod + { G4S.pName = nt1 + -- TODO: nub by ignoring directives? Really the directives need to be types not strings... + , G4S.patterns = nub $ concatMap + (\prhs -> rDF prhs [] (G4S.alphas prhs)) + ps + } + ) + replicateDeclFor _ p = p + + eliminate nts prod@(G4S.Prod { G4S.pName = _A, G4S.patterns = ps }) = + if _A == nts + then prod { G4S.patterns = filter (not . null . G4S.alphas) ps } + else prod + eliminate nts prod = prod + + ast' = case {- D.trace ("epsNTs: " ++ show epsNTs) -} epsNTs of + [] -> ast + ((nts, dflt):ntss) -> removeEpsilonsAST $ + map (eliminate nts) (foldr orderNub [] (map (replicateDeclFor (nts, dflt)) ast)) + + in foldr orderNub [] ast' + +{- + epsNT (_A, G4S.PRHS { G4S.alphas = [] }) = (:) _A + epsNT prod = id + + ps_init = concatMap (\ + + epsNTs = foldr epsNT [] (map (second (filter (not . isEps))) ps_init) + + orderNub ps p1 + | p1 `elem` ps = ps + | otherwise = p1 : ps + + replicateProd nts0 (nt1, es) = let + + rP ys [] = [(nt1, reverse ys)] + rP + + in rP [] es + + ps' = case epsNTs of + [] -> ps_init + (nts:ntss) -> removeEpsilonsAST $ + foldl orderNub [ + [ p' + | (_A, as) <- ps_init + , p' <- replicateProd nts (_A, as) + , (not . null) as + ] + + + in ps' +-} + +-- | This function does the heavy-lifting of Haskell code generation, most notably +-- generating non-terminal, terminal, and grammar data types as well as accompanying +-- parsing functions. +g4_decls :: [G4S.G4] -> TH.Q [TH.Dec] -- exp :: G4 +g4_decls ast' = + -- terminaLiterals, lexemeNames + + -- IMPORTANT: Creating type variables in two different haskell type + -- quasiquoters with the same variable name produces two (uniquely) named type + -- variables. In order to achieve the same type variable you need to run one + -- in the Q monad first then pass the resulting type to other parts of the + -- code that need it (thus capturing the type variable). + do let ast = removeEpsilonsAST $ map wipeOutAnnots (ast' ++ genTermAnnotProds ast') -- Order of '++' matters here + + tokVal = mkName "TokenValue" + tokName = mkName "TokenName" + ntSym = mkName $ ntDataName ast + tSym = mkName $ tDataName ast + nameAST = mkName (mkUpper $ gName ast ++ "AST") + nameToken = mkName (mkUpper $ gName ast ++ "Token") + nameDFAs = mkName (mkLower $ gName ast ++ "DFAs") + name = mkName $ mkLower (gName ast ++ "Grammar'") + nameUnit = mkName $ mkLower (gName ast ++ "Grammar") + lowerASTName = mkName (mkLower $ gName ast ++ "AST") + + --D.traceM $ "AST=" ++ pshowList' ast + + prettyTFncnName <- newName "prettifyT" + prettyValueFncnName <- newName "prettifyValue" + + stateTypeName <- newName "s" + let stateType = varT stateTypeName + + gTyUnit <- justGrammarTy ast unitTy + --gUnitFunD <- funD nameUnit [clause [] (normalB $ [| LL.removeEpsilons $(varE name) |]) []] + gUnitFunD <- funD nameUnit [clause [] (normalB $ [| $(varE name) |]) []] + gTySigUnit <- sigD nameUnit (return gTyUnit) + + ntDataDecl <- ntDataDeclQ ast + tDataDecl <- tDataDeclQ ast + gTy <- grammarTy ast stateType + gTy' <- justGrammarTy ast stateType + gTySig <- sigD name (return gTy) + g <- grammar ast gTy' + gFunD <- funD name [clause [] (normalB (return g)) []] + prettyNT:_ <- [d| instance Prettify $(ntConT ast) where prettify = rshow |] + prettyT:_ <- [d| instance Prettify $(tConT ast) where prettify = $(varE prettyTFncnName) |] + prettyValue:_ <- [d| instance Prettify $(conT tokVal) where prettify = $(varE prettyValueFncnName) |] + lookupTokenD <- lookupTokenFncnDecl ast + + tokenNameType <- tokenNameTypeQ ast + tokenValueType <- tokenValueTypeQ ast + + let lName = mkName "l" + lexeme2Value <- lexeme2ValueQ ast lName + + regexes <- mkRegexesQ ast + let dfasName = mkName $ mkLower (gName ast) ++ "DFAs" + let regexesE = varE $ mkName $ mkLower (gName ast) ++ "Regexes" + dfas <- funD dfasName [clause [] (normalB [| map (fst &&& regex2dfa . snd) $(regexesE) |]) []] + + astDecl <-tySynD nameAST [] [t| AST $(conT ntSym) $(conT nameToken) |] + tokDecl <- tySynD nameToken [] [t| Token $(conT tSym) $(conT tokVal) |] + + prettyTFncn <- prettyTFncnQ ast prettyTFncnName + prettyVFncn <- prettyVFncnQ ast prettyValueFncnName + + the_ast <- funD lowerASTName [clause [] (normalB $ lift ast) []] -- [d| $(lowerASTName) = $(lift ast) |] + + return $ + [ ntDataDecl, tDataDecl + , gTySig, gFunD + , gTySigUnit, gUnitFunD + , tokenNameType, tokenValueType + , prettyTFncn, prettyVFncn + , prettyNT, prettyT, prettyValue + , lookupTokenD + , lexeme2Value + , regexes + , dfas, astDecl, tokDecl + , the_ast + ] + +g4_parsers ast gr = do + let tokVal = mkName "TokenValue" + tokName = mkName "TokenName" + ntSym = mkName $ ntDataName ast + tSym = mkName $ tDataName ast + nameAST = mkName (mkUpper $ gName ast ++ "AST") + nameToken = mkName (mkUpper $ gName ast ++ "Token") + nameDFAs = mkName (mkLower $ gName ast ++ "DFAs") + name = mkName $ mkLower (gName ast ++ "Grammar'") + nameUnit = mkName $ mkLower (gName ast ++ "Grammar") + + --D.traceM $ "This is the grammar: " ++ pshow' gr + ast2DTFncns <- sequence $ ast2DTFncnsQ gr ast nameAST + decls <- [d| + instance Ref $(conT ntSym) where + type Sym $(conT ntSym) = $(conT ntSym) + getSymbol = id + + tokenize :: String -> [$(conT nameToken)] --Token $(conT tokName) $(conT tokVal)] + tokenize = T.tokenize $(varE nameDFAs) lexeme2value + + slrParse :: [$(conT nameToken)] + -> LR.LRResult + (LR.CoreSLRState $(conT ntSym) (StripEOF (Sym $(conT nameToken)))) + $(conT nameToken) + $(conT nameToken) + $(conT nameAST) + slrParse = (LR.slrParse $(varE nameUnit) event2ast) + + --glrParse :: [$(conT nameToken)] -> LR.LRResult $(conT ntSym) (StripEOF (Sym $(conT nameToken))) $(conT nameToken) $(conT nameAST) + glrParse :: ($(conT tokName) -> Bool) -> [Char] + -> LR.GLRResult + --(LR.CoreLR1State $(conT ntSym) (StripEOF (Sym $(conT nameToken)))) + Int + Char + $(conT nameToken) + $(conT nameAST) + glrParse filterF = (LR.glrParseInc2 $(varE nameUnit) event2ast (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value)) + + {- instance ALL.Token $(conT nameToken) where + type Label $(conT nameToken) = StripEOF (Sym $(conT nameToken)) + getLabel = fromJust . stripEOF . getSymbol + + type Literal $(conT nameToken) = $(conT tokVal) + getLiteral = T.tokenValue -} + + allstarParse :: ($(conT tokName) -> Bool) -> String -- [$(conT nameToken)] + -> Either String $(conT nameAST) + allstarParse filterF inp = + ALL.parse' + (T.tokenizeIncAll filterF $(varE nameDFAs) lexeme2value (Set.fromList $ map fst $(varE nameDFAs))) + inp + (ALL.NT $(s0 ast)) + (ALL.atnOf ($(varE nameUnit) :: $(justGrammarTy ast unitTy))) + True + + |] + return $ decls ++ ast2DTFncns + +-- | Support for this is __very__ experimental. This function allows you +-- to splice in compile-time computed versions of the LR1 data structures +-- so as to decrease the runtime of at-runtime parsing. +-- See @test/g4/G4.hs@ and @test/g4/Main.hs@ in the antlr-haskell source for +-- example usage of the @glrParseFast@ function generated. +mkLRParser ast g = + let + nameDFAs = mkName (mkLower $ gName ast ++ "DFAs") + tokName = mkName "TokenName" + nameAST = mkName (mkUpper $ grammarName ast ++ "AST") + nameToken = mkName (mkUpper $ gName ast ++ "Token") + name = mkName $ mkLower (grammarName ast ++ "Grammar") + is = sort $ S.toList $ LR.lr1Items g + tbl = LR.lr1Table g + + tblInt = LR.convTableInt tbl is + (_lr1Table', errs) = LR.disambiguate tblInt + lr1Table' = M.toList tblInt -- _lr1Table' + lr1S0' = LR.convStateInt is $ LR.lr1Closure g $ LR.lr1S0 g + + unitTy = [t| () |] + name' = [e| $(varE name) |] -- :: $(justGrammarTy' ast unitTy) |] + in do --D.traceM $ pshow' is + D.traceM $ "lr1S0 = " ++ (pshow' $ LR.lr1S0 g) + --D.traceM $ "lr1Table = " ++ (pshow' $ LR.lr1Table g) + D.traceM $ "lr1S0' = " ++ (pshow' lr1S0') + D.traceM $ "lr1Table' = " ++ (pshow' lr1Table') + D.traceM $ "Total LR1 conflicts: " ++ (pshow' errs) + -- + --glrParse filterF = (LR.glrParseInc2 $(varE nameUnit) event2ast (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value)) + --D.traceM $ "disambiguate tbl = " ++ (pshow' $ disambiguate tbl) + [d| lr1ItemsList = sort $ S.toList $ LR.lr1Items $(name') + lr1Table = $(lift lr1Table') + lr1Goto = LR.convGotoStatesInt (LR.convGoto $(name') (LR.lr1Goto $(name')) lr1ItemsList) lr1ItemsList + lr1Closure = convState $ LR.lr1Closure $(name') (LR.lr1S0 $(name')) + lr1S0 = $(lift lr1S0') + convState = LR.convStateInt lr1ItemsList + + glrParseFast :: ($(conT tokName) -> Bool) -> [Char] + -> LR.GLRResult + --(LR.CoreLR1State $(conT ntSym) (StripEOF (Sym $(conT nameToken)))) + Int + Char + $(conT nameToken) $(conT nameAST) glrParseFast filterF = LR.glrParseInc' diff --git a/src/Language/ANTLR4/Boot/SplicedParser.hs b/src/Language/ANTLR4/Boot/SplicedParser.hs --- a/src/Language/ANTLR4/Boot/SplicedParser.hs +++ b/src/Language/ANTLR4/Boot/SplicedParser.hs @@ -47,6 +47,8 @@ prodDirective as d = G4S.PRHS as Nothing Nothing (Just d) prodNoDir as = G4S.PRHS as Nothing Nothing Nothing +prodNoAlphas d = G4S.PRHS [] Nothing Nothing (Just d) +prodNothing = G4S.PRHS [] Nothing Nothing Nothing list2 a b = [a,b] range a b = [a .. b] @@ -108,75 +110,66 @@ T_WS deriving (Eq, Ord, Show, Hashable, Generic, Bounded, Enum) g4Grammar' :: - Prettify s_aLE0 => Grammar s_aLE0 G4NTSymbol G4TSymbol + Prettify s_aLE0 => Grammar s_aLE0 G4NTSymbol G4TSymbol String g4Grammar' - = (defaultGrammar NT_decls :: Grammar s_aLE0 G4NTSymbol G4TSymbol) + = (defaultGrammar NT_decls :: Grammar s_aLE0 G4NTSymbol G4TSymbol String) {ns = S.fromList [minBound .. maxBound :: G4NTSymbol], ts = S.fromList [minBound .. maxBound :: G4TSymbol], - ps = [(Production NT_decls) ((Prod Pass) [NT NT_decl1, T T_0]), - (Production NT_decls) - ((Prod Pass) [NT NT_decl1, T T_0, NT NT_decls]), - (Production NT_decl1) ((Prod Pass) [T T_1, T T_UpperID]), - (Production NT_decl1) - ((Prod Pass) [T T_LowerID, T T_2, NT NT_prods]), - (Production NT_decl1) - ((Prod Pass) [T T_UpperID, T T_2, NT NT_lexemeRHS]), - (Production NT_decl1) - ((Prod Pass) [T T_3, T T_UpperID, T T_2, NT NT_lexemeRHS]), - (Production NT_prods) ((Prod Pass) [NT NT_prodRHS]), - (Production NT_prods) - ((Prod Pass) [NT NT_prodRHS, T T_4, NT NT_prods]), - (Production NT_lexemeRHS) - ((Prod Pass) [NT NT_regexes1, T T_5, NT NT_directive]), - (Production NT_lexemeRHS) ((Prod Pass) [NT NT_regexes1]), - (Production NT_prodRHS) - ((Prod Pass) [NT NT_alphas, T T_5, NT NT_directive]), - (Production NT_prodRHS) ((Prod Pass) [NT NT_alphas]), - (Production NT_directive) ((Prod Pass) [T T_UpperID]), - (Production NT_directive) ((Prod Pass) [T T_LowerID]), - (Production NT_directive) ((Prod Pass) [T T_UpperID, T T_14, NT NT_directive]), - (Production NT_alphas) ((Prod Pass) [NT NT_alpha]), - (Production NT_alphas) ((Prod Pass) [NT NT_alpha, NT NT_alphas]), - (Production NT_alpha) ((Prod Pass) [T T_Literal, T T_6]), - (Production NT_alpha) ((Prod Pass) [T T_LowerID, T T_6]), - (Production NT_alpha) ((Prod Pass) [T T_UpperID, T T_6]), - (Production NT_alpha) ((Prod Pass) [T T_Literal, T T_7]), - (Production NT_alpha) ((Prod Pass) [T T_LowerID, T T_7]), - (Production NT_alpha) ((Prod Pass) [T T_UpperID, T T_7]), - (Production NT_alpha) ((Prod Pass) [T T_Literal, T T_8]), - (Production NT_alpha) ((Prod Pass) [T T_LowerID, T T_8]), - (Production NT_alpha) ((Prod Pass) [T T_UpperID, T T_8]), - (Production NT_alpha) ((Prod Pass) [T T_Literal]), - (Production NT_alpha) ((Prod Pass) [T T_LowerID]), - (Production NT_alpha) ((Prod Pass) [T T_UpperID]), - (Production NT_regexes1) ((Prod Pass) [NT NT_regexes]), - (Production NT_regexes) ((Prod Pass) [NT NT_regex]), - (Production NT_regexes) ((Prod Pass) [NT NT_regex, NT NT_regexes]), - (Production NT_regex) ((Prod Pass) [NT NT_regex1, T T_6]), - (Production NT_regex) ((Prod Pass) [NT NT_regex1, T T_7]), - (Production NT_regex) ((Prod Pass) [NT NT_regex1, T T_8]), - (Production NT_regex) ((Prod Pass) [T T_9, NT NT_regex1]), - (Production NT_regex) ((Prod Pass) [NT NT_regex1]), - (Production NT_regex1) - ((Prod Pass) [T T_10, NT NT_charSet, T T_11]), - (Production NT_regex1) ((Prod Pass) [T T_Literal]), - (Production NT_regex1) ((Prod Pass) [T T_UpperID]), - (Production NT_regex1) - ((Prod Pass) [T T_12, NT NT_regexes1, T T_13]), - (Production NT_regex1) ((Prod Pass) [NT NT_unionR]), - (Production NT_regex1) ((Prod Pass) [T T_14]), - (Production NT_unionR) - ((Prod Pass) [NT NT_regex, T T_4, NT NT_regex]), - (Production NT_unionR) - ((Prod Pass) [NT NT_regex, T T_4, NT NT_unionR]), - (Production NT_charSet) ((Prod Pass) [NT NT_charSet1]), - (Production NT_charSet) - ((Prod Pass) [NT NT_charSet1, NT NT_charSet]), - (Production NT_charSet1) - ((Prod Pass) [T T_SetChar, T T_15, T T_SetChar]), - (Production NT_charSet1) ((Prod Pass) [T T_SetChar]), - (Production NT_charSet1) ((Prod Pass) [T T_EscapedChar])]} -g4Grammar :: Grammar () G4NTSymbol G4TSymbol + ps = [(Production NT_decls) ((Prod Pass) [NT NT_decl1, T T_0]) (Just ""), + (Production NT_decls) ((Prod Pass) [NT NT_decl1, T T_0, NT NT_decls]) (Just ""), + (Production NT_decl1) ((Prod Pass) [T T_1, T T_UpperID]) (Just ""), + (Production NT_decl1) ((Prod Pass) [T T_LowerID, T T_2, NT NT_prods]) (Just ""), + (Production NT_decl1) ((Prod Pass) [T T_UpperID, T T_2, NT NT_lexemeRHS]) (Just ""), + (Production NT_decl1) ((Prod Pass) [T T_3, T T_UpperID, T T_2, NT NT_lexemeRHS]) (Just ""), + (Production NT_prods) ((Prod Pass) [NT NT_prodRHS]) (Just ""), + (Production NT_prods) ((Prod Pass) [NT NT_prodRHS, T T_4, NT NT_prods]) (Just ""), + (Production NT_lexemeRHS) ((Prod Pass) [NT NT_regexes1, T T_5, NT NT_directive]) (Just ""), + (Production NT_lexemeRHS) ((Prod Pass) [NT NT_regexes1]) (Just ""), + (Production NT_prodRHS) ((Prod Pass) [NT NT_alphas, T T_5, NT NT_directive]) (Just ""), + (Production NT_prodRHS) ((Prod Pass) [NT NT_alphas]) (Just ""), + -- Can leave prodRHS empty (epsilon) with *no* directive: + (Production NT_prodRHS) ((Prod Pass) []) (Just ""), + -- Can leave prodRHS empty (epsilon) *with* a directive: + (Production NT_prodRHS) ((Prod Pass) [T T_5, NT NT_directive]) (Just ""), + (Production NT_directive) ((Prod Pass) [T T_UpperID]) (Just ""), + (Production NT_directive) ((Prod Pass) [T T_LowerID]) (Just ""), + (Production NT_directive) ((Prod Pass) [T T_UpperID, T T_14, NT NT_directive]) (Just ""), + (Production NT_alphas) ((Prod Pass) [NT NT_alpha]) (Just ""), + (Production NT_alphas) ((Prod Pass) [NT NT_alpha, NT NT_alphas]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_Literal, T T_6]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_LowerID, T T_6]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_UpperID, T T_6]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_Literal, T T_7]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_LowerID, T T_7]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_UpperID, T T_7]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_Literal, T T_8]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_LowerID, T T_8]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_UpperID, T T_8]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_Literal]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_LowerID]) (Just ""), + (Production NT_alpha) ((Prod Pass) [T T_UpperID]) (Just ""), + (Production NT_regexes1) ((Prod Pass) [NT NT_regexes]) (Just ""), + (Production NT_regexes) ((Prod Pass) [NT NT_regex]) (Just ""), + (Production NT_regexes) ((Prod Pass) [NT NT_regex, NT NT_regexes]) (Just ""), + (Production NT_regex) ((Prod Pass) [NT NT_regex1, T T_6]) (Just ""), + (Production NT_regex) ((Prod Pass) [NT NT_regex1, T T_7]) (Just ""), + (Production NT_regex) ((Prod Pass) [NT NT_regex1, T T_8]) (Just ""), + (Production NT_regex) ((Prod Pass) [T T_9, NT NT_regex1]) (Just ""), + (Production NT_regex) ((Prod Pass) [NT NT_regex1]) (Just ""), + (Production NT_regex1) ((Prod Pass) [T T_10, NT NT_charSet, T T_11]) (Just ""), + (Production NT_regex1) ((Prod Pass) [T T_Literal]) (Just ""), + (Production NT_regex1) ((Prod Pass) [T T_UpperID]) (Just ""), + (Production NT_regex1) ((Prod Pass) [T T_12, NT NT_regexes1, T T_13]) (Just ""), + (Production NT_regex1) ((Prod Pass) [NT NT_unionR]) (Just ""), + (Production NT_regex1) ((Prod Pass) [T T_14]) (Just ""), + (Production NT_unionR) ((Prod Pass) [NT NT_regex, T T_4, NT NT_regex]) (Just ""), + (Production NT_unionR) ((Prod Pass) [NT NT_regex, T T_4, NT NT_unionR]) (Just ""), + (Production NT_charSet) ((Prod Pass) [NT NT_charSet1]) (Just ""), + (Production NT_charSet) ((Prod Pass) [NT NT_charSet1, NT NT_charSet]) (Just ""), + (Production NT_charSet1) ((Prod Pass) [T T_SetChar, T T_15, T T_SetChar]) (Just ""), + (Production NT_charSet1) ((Prod Pass) [T T_SetChar]) (Just ""), + (Production NT_charSet1) ((Prod Pass) [T T_EscapedChar]) (Just "")]} +g4Grammar :: Grammar () G4NTSymbol G4TSymbol String g4Grammar = Text.ANTLR.LL1.removeEpsilons g4Grammar' type TokenName = G4TSymbol data TokenValue @@ -369,27 +362,27 @@ tokenize_aLE7 = (tokenize g4DFAs) lexeme2value slrParse_aLE6 :: [G4Token] - -> LR.LRResult (LR.CoreSLRState G4NTSymbol (StripEOF (Sym G4Token))) G4Token G4AST + -> LR.LRResult (LR.CoreSLRState G4NTSymbol (StripEOF (Sym G4Token))) G4Token G4Token G4AST slrParse_aLE6 = (LR.slrParse g4Grammar) event2ast glrParse_aLE5 :: (TokenName -> Bool) -> [Char] - -> LR.LR1Result (LR.CoreLR1State G4NTSymbol (StripEOF (Sym G4Token))) Char G4AST + -> LR.GLRResult (LR.CoreLR1State G4NTSymbol (StripEOF (Sym G4Token))) Char G4Token G4AST glrParse_aLE5 filterF_aLE8 = ((LR.glrParseInc g4Grammar) event2ast) (((tokenizeInc filterF_aLE8) g4DFAs) lexeme2value) -instance ALL.Token G4Token where +{- instance ALL.Token G4Token where type Label G4Token = StripEOF (Sym G4Token) type Literal G4Token = TokenValue getLabel = (Data.Maybe.fromJust . (stripEOF . getSymbol)) - getLiteral = tokenValue + getLiteral = tokenValue -} allstarParse_aLE4 :: [G4Token] -> Either String G4AST allstarParse_aLE4 inp_aLE9 = (((Text.ANTLR.Allstar.parse inp_aLE9) (ALL.NT NT_decls)) (Text.ANTLR.Allstar.atnOf - (g4Grammar :: Grammar () G4NTSymbol G4TSymbol))) + (g4Grammar :: Grammar () G4NTSymbol G4TSymbol String))) True ast2EscapedChar (Leaf (Token _ (V_EscapedChar t) _)) = t ast2LineComment (Leaf (Token _ (V_LineComment t) _)) = t @@ -498,6 +491,10 @@ (ast2directive v2_directive) ast2prodRHS (AST NT_prodRHS [NT NT_alphas] [v0_alphas]) = prodNoDir (ast2alphas v0_alphas) +-- (Production NT_prodRHS) ((Prod Pass) []) (Just ""), +ast2prodRHS (AST NT_prodRHS [] []) = prodNothing +-- (Production NT_prodRHS) ((Prod Pass) [T T_5, NT NT_directive]) (Just ""), +ast2prodRHS (AST NT_prodRHS [T T_5, NT NT_directive] [_, v1_directive]) = prodNoAlphas (ast2directive v1_directive) ast2prodRHS ast2 = error (show ast2) ast2prods (AST NT_prods [NT NT_prodRHS] [v0_prodRHS]) = list (ast2prodRHS v0_prodRHS) diff --git a/src/Language/ANTLR4/Boot/Syntax.hs b/src/Language/ANTLR4/Boot/Syntax.hs --- a/src/Language/ANTLR4/Boot/Syntax.hs +++ b/src/Language/ANTLR4/Boot/Syntax.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveLift, DeriveAnyClass, DeriveGeneric #-} +{-# LANGUAGE DeriveLift, DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} {-| Module : Language.ANTLR4.Boot.Syntax Description : Both the boot and core syntax data types for G4 @@ -13,6 +13,7 @@ , Directive(..) , LRHS(..), Regex(..), isGTerm, isGNonTerm , TermAnnot(..), isMaybeAnnot, isNoAnnot, annot + , prodElemSymbol ) where import Text.ANTLR.Grammar () import Language.Haskell.TH.Lift (Lift(..)) @@ -21,6 +22,7 @@ import qualified Language.Haskell.TH.Syntax as S import Text.ANTLR.Set ( Hashable(..), Generic(..) ) +import Text.ANTLR.Pretty -- (rshow, Prettify(..), pStr, pshow, pStr') -- | .g4 style syntax representation data G4 = -- | Grammar name declaration in g4 @@ -37,6 +39,27 @@ } deriving (Show, Eq, Lift, Generic, Hashable) +instance Prettify G4 where + prettify (Grammar gn) = do + pStr "grammar " + pStr' gn + prettify (Prod n ps) = do + pStr' n + pStr " -> " + incrIndent $ length n + 4 + pListLines ps + incrIndent $ 0 - (length n + 4) + prettify (Lex annot ln (LRHS regex dir)) = do + pStr' ln + pStr " -> " + incrIndent $ length ln + 4 + prettify regex + incrIndent $ 0 - (length ln + 4) + pStr "(" + prettify dir + pStr ")" + + instance Lift Exp -- | The right-hand side of a G4 production rule. @@ -47,14 +70,24 @@ , pDirective :: Maybe Directive -- ^ How to construct a Haskell type when this rules fires } deriving (Show, Eq, Lift, Generic) +instance Prettify PRHS where + prettify (PRHS as pred mut pDir) = do + prettify as + pStr "(" + pStr' $ show pred; pStr "," + pStr' $ show mut; pStr "," + prettify pDir; pStr ")" + -- | Antiquoted (or g4-embedded) string that goes to the right of an arrow in -- a g4 production rule. This specifies how to construct a Haskell type. data Directive = - UpperD String -- ^ Probably a Haskell data constructor - | LowerD String -- ^ Probably just a Haskell function to call - | HaskellD String -- ^ Arbitrary antiquoted Haskell code embedded in the G4 grammar - deriving (Show, Eq, Lift, Generic, Hashable) + UpperD String -- ^ Probably a Haskell data constructor + | LowerD String -- ^ Probably just a Haskell function to call + | HaskellD String -- ^ Arbitrary antiquoted Haskell code embedded in the G4 grammar + deriving (Show, Eq, Ord, Lift, Generic, Hashable) +instance Prettify Directive where prettify = rshow + instance Hashable PRHS where hashWithSalt salt prhs = salt `hashWithSalt` alphas prhs @@ -65,6 +98,10 @@ | NoAnnot -- ^ Term is not annotated with anything deriving (Show, Eq, Ord, Lift, Generic, Hashable) +instance Prettify TermAnnot where + prettify NoAnnot = return () + prettify (Regular c) = pStr' [c] + -- | Get the annotation from a 'ProdElem' annot :: ProdElem -> TermAnnot annot (GTerm a _) = a @@ -86,6 +123,17 @@ | GNonTerm TermAnnot String -- ^ G4 nonterminal deriving (Show, Eq, Ord, Lift, Generic, Hashable) +instance Prettify ProdElem where + prettify (GTerm annot s) = do + pStr' s + prettify annot + prettify (GNonTerm annot s) = do + pStr' s + prettify annot + +prodElemSymbol (GTerm _ s) = s +prodElemSymbol (GNonTerm _ s) = s + -- | Is this a terminal G4 element? isGTerm (GTerm _ _) = True isGTerm _ = False @@ -120,4 +168,12 @@ deriving (Lift, Eq, Show, Generic, Hashable) -- TODO: Lex regexs (e.g. complement sets, escape chars, ...) -- TODO: Set s, and ranges of characters + +instance (Show s, Prettify s) => Prettify (Regex s) where + prettify Epsilon = pStr "ε" + prettify (Literal ss) = do + pStr "\"" + mapM prettify ss + pStr "\"" + prettify rest = pStr' $ show rest diff --git a/src/Language/ANTLR4/G4.hs b/src/Language/ANTLR4/G4.hs --- a/src/Language/ANTLR4/G4.hs +++ b/src/Language/ANTLR4/G4.hs @@ -14,7 +14,7 @@ Until better haddock integration is developed, you'll need to look at the source for this module to see the G4 grammar for G4. -} -module Language.ANTLR4.G4 (g4) where +module Language.ANTLR4.G4 where import Control.Arrow ( (&&&) ) import Data.Char (isUpper) @@ -58,6 +58,8 @@ prodDirective as d = G4S.PRHS as Nothing Nothing (Just d) prodNoDir as = G4S.PRHS as Nothing Nothing Nothing +prodNoAlphas d = G4S.PRHS [] Nothing Nothing (Just d) +prodNothing = G4S.PRHS [] Nothing Nothing Nothing list2 a b = [a,b] range a b = [a .. b] @@ -85,6 +87,8 @@ qDir l u = [l,u] +haskellD = G4S.HaskellD + -- Force the above declarations (and their types) into scope: $( return [] ) @@ -111,12 +115,14 @@ prodRHS : alphas '->' directive -> prodDirective | alphas -> prodNoDir + | '->' directive -> prodNoAlphas + | -> prodNothing ; directive : qDirective -> dQual | UpperID -> G4S.UpperD | LowerID -> G4S.LowerD - | '${' HaskellExp '}' -> G4S.HaskellD + | '${' HaskellExp '}' -> haskellD ; qDirective : UpperID '.' qDot -> qDir @@ -126,8 +132,6 @@ | LowerID ; - HaskellExp : ( ~ '}' )+ -> String; - alphas : alpha -> list | alpha alphas -> cons | '(' alphas ')' @@ -189,43 +193,14 @@ UpperID : [A-Z][a-zA-Z0-9_]* -> String; LowerID : [a-z][a-zA-Z0-9_]* -> String; - Literal : '\'' (~ '\'')+ '\'' -> stripQuotesReadEscape; + Literal : '\'' ( ( '\\\'' ) | (~ ( '\'' ) ) )+ '\'' -> stripQuotesReadEscape; LineComment : '//' (~ '\n')* '\n' -> String; + HaskellExp : ( ~ '}' )+ -> String; + SetChar : ~ ']' -> char ; WS : [ \t\n\r\f\v]+ -> String; EscapedChar : '\\' [tnrfv] -> readEscape ; |] - -isWhitespace T_LineComment = True -isWhitespace T_WS = True -isWhitespace _ = False - -g4_codeGen :: String -> TH.Q [TH.Dec] -g4_codeGen input = do - loc <- TH.location - let fileName = TH.loc_filename loc - let (line,column) = TH.loc_start loc - - case glrParse isWhitespace input of - r@(LR.ResultAccept ast) -> codeGen r - LR.ResultSet s -> - if S.size s == 1 - then codeGen (S.findMin s) - else D.trace (pshow' s) $ codeGen (S.findMin s) - err -> error $ pshow' err - --- TODO: Convert a Universal AST into a [G4S.G4] -codeGen (LR.ResultAccept ast) = G4Q.g4_decls $ ast2decls ast - --- | Entrypoint to the G4 quasiquoer. Currently only supports declaration-level --- Haskell generation of G4 grammars using a GLR parser. The output grammars --- need not use a GLR parser themselves. -g4 :: QuasiQuoter -g4 = QuasiQuoter - (error "parse exp") - (error "parse pattern") - (error "parse type") - g4_codeGen diff --git a/src/Language/ANTLR4/Parser.hs b/src/Language/ANTLR4/Parser.hs --- a/src/Language/ANTLR4/Parser.hs +++ b/src/Language/ANTLR4/Parser.hs @@ -1,416 +1,85 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances - , FlexibleInstances, UndecidableInstances #-} + , FlexibleInstances, UndecidableInstances, DeriveDataTypeable + , TemplateHaskell #-} {-| - Module : Language.ANTLR4.G4 - Description : Version of G4 from public ANTLR repo of parsers - Copyright : (c) Karl Cronburg, 2018 + Module : Language.ANTLR4.Parser + Description : Core G4 quasiquoter (with parsers) for antlr-haskell + Copyright : (c) Karl Cronburg, 2019 License : BSD3 Maintainer : karl@cs.tufts.edu Stability : experimental Portability : POSIX - The rest of this module is taken from https://github.com/antlr/grammars-v4/tree/master/antlr4 - -} -module Language.ANTLR4.Parser where -import Language.ANTLR4 - -{- -/* - * [The "BSD license"] - * Copyright (c) 2012-2014 Terence Parr - * Copyright (c) 2012-2014 Sam Harwell - * Copyright (c) 2015 Gerald Rosenberg - * All rights reserved. - * - * Redistribution and use in source and binary forms, with or without - * modification, are permitted provided that the following conditions - * are met: - * - * 1. Redistributions of source code must retain the above copyright - * notice, this list of conditions and the following disclaimer. - * 2. Redistributions in binary form must reproduce the above copyright - * notice, this list of conditions and the following disclaimer in the - * documentation and/or other materials provided with the distribution. - * 3. The name of the author may not be used to endorse or promote products - * derived from this software without specific prior written permission. - * - * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR - * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES - * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. - * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, - * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT - * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, - * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY - * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT - * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF - * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - */ -/* A grammar for ANTLR v4 written in ANTLR v4. - * - * Modified 2015.06.16 gbr - * -- update for compatibility with Antlr v4.5 - * -- add mode for channels - * -- moved members to LexerAdaptor - * -- move fragments to imports - */ --} - - -{- -[g4| - -grammar ANTLR4; - -// The main entry point for parsing a v4 grammar. -grammarSpec - : DOC_COMMENT* grammarType identifier SEMI prequelConstruct* rules modeSpec* EOF - ; - -grammarType - : LEXER GRAMMAR | PARSER GRAMMAR | GRAMMAR - ; - -// This is the list of all constructs that can be declared before -// the set of rules that compose the grammar, and is invoked 0..n -// times by the grammarPrequel rule. -prequelConstruct - : optionsSpec - | delegateGrammars - | tokensSpec - | channelsSpec - | action - ; - -|] -// ------------ -// Options - things that affect analysis and/or code generation -optionsSpec - : OPTIONS LBRACE optionSemi* RBRACE - ; - -optionsSemi : option SEMI ; - -option - : identifier ASSIGN optionValue - ; - -optionValue - : identifier (DOT identifier)* - | STRING_LITERAL - | actionBlock - | INT - ; - -// ------------ -// Delegates -delegateGrammars - : IMPORT delegateGrammar commaDG* SEMI - ; - -commaDG : COMMA delegateGrammar ; - -delegateGrammar - : identifier ASSIGN identifier - | identifier - ; - -// ------------ -// Tokens & Channels -tokensSpec - : TOKENS LBRACE idList? RBRACE - ; - -channelsSpec - : CHANNELS LBRACE idList? RBRACE - ; - -idList - : identifier commaID* COMMA? - ; - -commaID : COMMA identifier ; - -// Match stuff like @parser::members {int i;} -action - : AT nameColon? identifier actionBlock - ; - -nameColon : actionScopeName COLONCOLON ; - -// Scope names could collide with keywords; allow them as ids for action scopes -actionScopeName - : identifier - | LEXER - | PARSER - ; - -actionBlock - : BEGIN_ACTION ACTION_CONTENT* END_ACTION - ; - -argActionBlock - : BEGIN_ARGUMENT ARGUMENT_CONTENT* END_ARGUMENT - ; - -modeSpec - : MODE identifier SEMI lexerRuleSpec* - ; - -rules - : ruleSpec* - ; - -ruleSpec - : parserRuleSpec - | lexerRuleSpec - ; - -parserRuleSpec - : DOC_COMMENT* ruleModifiers? RULE_REF argActionBlock? ruleReturns? throwsSpec? localsSpec? rulePrequel* COLON ruleBlock SEMI exceptionGroup - ; - -exceptionGroup - : exceptionHandler* finallyClause? - ; - -exceptionHandler - : CATCH argActionBlock actionBlock - ; - -finallyClause - : FINALLY actionBlock - ; - -rulePrequel - : optionsSpec - | ruleAction - ; - -ruleReturns - : RETURNS argActionBlock - ; - -// -------------- -// Exception spec -throwsSpec - : THROWS identifier commaID* - ; - -localsSpec - : LOCALS argActionBlock - ; - -/** Match stuff like @init {int i;} */ -ruleAction - : AT identifier actionBlock - ; - -ruleModifiers - : ruleModifier + - ; - -// An individual access modifier for a rule. The 'fragment' modifier -// is an internal indication for lexer rules that they do not match -// from the input but are like subroutines for other lexer rules to -// reuse for certain lexical patterns. The other modifiers are passed -// to the code generation templates and may be ignored by the template -// if they are of no use in that language. -ruleModifier - : PUBLIC - | PRIVATE - | PROTECTED - | FRAGMENT - ; - -ruleBlock - : ruleAltList - ; - -ruleAltList - : labeledAlt orAlt* - ; - -orAlt : OR labeledAlt ; - -labeledAlt - : alternative poundID? - ; - -poundID : POUND identifier ; - -// -------------------- -// Lexer rules -lexerRuleSpec - : DOC_COMMENT* FRAGMENT? TOKEN_REF COLON lexerRuleBlock SEMI - ; - -lexerRuleBlock - : lexerAltList - ; - -lexerAltList - : lexerAlt orLexerAlt* - ; - -orLexerAlt : OR lexerAlt ; - -lexerAlt - : lexerElements lexerCommands? - | - // explicitly allow empty alts - ; - -lexerElements - : lexerElement + - ; - -lexerElement - : labeledLexerElement ebnfSuffix? - | lexerAtom ebnfSuffix? - | lexerBlock ebnfSuffix? - | actionBlock QUESTION? - ; - -// but preds can be anywhere -labeledLexerElement - : identifier (ASSIGN | PLUS_ASSIGN) (lexerAtom | lexerBlock) - ; - -lexerBlock - : LPAREN lexerAltList RPAREN - ; - -// E.g., channel(HIDDEN), skip, more, mode(INSIDE), push(INSIDE), pop -lexerCommands - : RARROW lexerCommand (COMMA lexerCommand)* - ; - -lexerCommand - : lexerCommandName LPAREN lexerCommandExpr RPAREN - | lexerCommandName - ; - -lexerCommandName - : identifier - | MODE - ; - -lexerCommandExpr - : identifier - | INT - ; - -// -------------------- -// Rule Alts -altList - : alternative (OR alternative)* - ; - -alternative - : elementOptions? element + - | - // explicitly allow empty alts - ; - -element - : labeledElement (ebnfSuffix |) - | atom (ebnfSuffix |) - | ebnf - | actionBlock QUESTION? - ; - -labeledElement - : identifier (ASSIGN | PLUS_ASSIGN) (atom | block) - ; - -// -------------------- -// EBNF and blocks -ebnf - : block blockSuffix? - ; - -blockSuffix - : ebnfSuffix - ; +module Language.ANTLR4.Parser (g4) where -ebnfSuffix - : QUESTION QUESTION? - | STAR QUESTION? - | PLUS QUESTION? - ; +import Control.Arrow ( (&&&) ) +import Data.Char (isUpper) -lexerAtom - : characterRange - | terminal - | notSet - | LEXER_CHAR_SET - | DOT elementOptions? - ; +import Text.ANTLR.Common +import Text.ANTLR.Grammar +import Text.ANTLR.Parser +import qualified Text.ANTLR.LR as LR +import Text.ANTLR.Lex.Tokenizer as T hiding (tokenize) +import qualified Text.ANTLR.Set as S +import Text.ANTLR.Set (Hashable(..), Generic(..)) +import Text.ANTLR.Pretty +import Text.ANTLR.Lex.Regex (regex2dfa) +import Data.Data (Data(..)) +import Language.Haskell.TH.Lift (Lift(..)) -atom - : terminal - | ruleref - | notSet - | DOT elementOptions? - ; +import Language.Haskell.TH.Quote (QuasiQuoter(..)) +import qualified Language.Haskell.TH as TH +import Language.ANTLR4.Boot.Quote (antlr4, g4_parsers) +import Language.ANTLR4.Syntax +import qualified Language.ANTLR4.Boot.Syntax as G4S +import qualified Language.ANTLR4.Boot.Quote as G4Q +import Language.ANTLR4.G4 -// -------------------- -// Inverted element set -notSet - : NOT setElement - | NOT blockSet - ; +import Debug.Trace as D -blockSet - : LPAREN setElement (OR setElement)* RPAREN - ; +-- Splice the parsers for the grammar we defined in Language.ANTLR4.G4 +$(g4_parsers g4AST g4Grammar) -setElement - : TOKEN_REF elementOptions? - | STRING_LITERAL elementOptions? - | characterRange - | LEXER_CHAR_SET - ; +{- isWhitespace (Just T_LineComment) = True +isWhitespace (Just T_WS) = True +isWhitespace Nothing = True +isWhitespace _ = False -} -// ------------- -// Grammar Block -block - : LPAREN (optionsSpec? ruleAction* COLON)? altList RPAREN - ; +isWhitespace T_LineComment = True +isWhitespace T_WS = True +isWhitespace _ = False -// ---------------- -// Parser rule ref -ruleref - : RULE_REF argActionBlock? elementOptions? - ; +g4_codeGen :: String -> TH.Q [TH.Dec] +g4_codeGen input = do + loc <- TH.location + let fileName = TH.loc_filename loc + let (line,column) = TH.loc_start loc -// --------------- -// Character Range -characterRange - : STRING_LITERAL RANGE STRING_LITERAL - ; + {- case allstarParse (filter (not . isWhitespace . stripEOF . getSymbol) (tokenize input)) of + Left err -> error err + Right ast -> codeGen ast -} + case glrParse isWhitespace input of + (LR.ResultAccept ast) -> codeGen ast + LR.ResultSet s -> + if S.size s == 1 + then codeGen $ fromAccept (S.findMin s) + else D.trace (pshow' s) $ codeGen $ fromAccept (S.findMin s) + err -> error $ pshow' err -terminal - : TOKEN_REF elementOptions? - | STRING_LITERAL elementOptions? - ; +fromAccept (LR.ResultAccept ast) = ast +fromAccept err = error $ pshow' err -// Terminals may be adorned with certain options when -// reference in the grammar: TOK<,,,> -elementOptions - : LT elementOption (COMMA elementOption)* GT - ; +codeGen ast = G4Q.g4_decls $ ast2decls ast -elementOption - : identifier - | identifier ASSIGN (identifier | STRING_LITERAL) - ; +-- | Entrypoint to the G4 quasiquoter. Currently only supports declaration-level +-- Haskell generation of G4 grammars using a GLR parser. The output grammars +-- need not use a GLR parser themselves. +g4 :: QuasiQuoter +g4 = QuasiQuoter + (error "parse exp") + (error "parse pattern") + (error "parse type") + g4_codeGen -identifier - : RULE_REF - | TOKEN_REF - ; -|] --} diff --git a/src/Language/ANTLR4/Syntax.hs b/src/Language/ANTLR4/Syntax.hs --- a/src/Language/ANTLR4/Syntax.hs +++ b/src/Language/ANTLR4/Syntax.hs @@ -9,6 +9,7 @@ -} module Language.ANTLR4.Syntax where import Language.ANTLR4.Boot.Syntax +import Data.Char (readLitChar) import qualified Debug.Trace as D @@ -45,6 +46,10 @@ eC ('"':xs) = "\"" ++ sQRE xs eC ('\'':xs) = "\'" ++ sQRE xs eC ('\\':xs) = "\\" ++ sQRE xs + eC ('u':a:b:c:d:xs) = + case (readLitChar $ '\\' : 'x' : a : b : c : d : []) of + ((hex, "") : []) -> hex : sQRE xs + _ -> error $ "Invalid unicode character '\\u" ++ [a,b,c,d] ++ "' in string '" ++ s ++ "'" eC (x:xs) = error $ "Invalid escape character '" ++ [x] ++ "' in string '" ++ s ++ "'" sQRE [] = [] diff --git a/src/Text/ANTLR/Allstar.hs b/src/Text/ANTLR/Allstar.hs --- a/src/Text/ANTLR/Allstar.hs +++ b/src/Text/ANTLR/Allstar.hs @@ -13,8 +13,7 @@ this package. -} module Text.ANTLR.Allstar - ( parse, atnOf - , ALL.Token(..) + ( parse, parse', atnOf , ALL.GrammarSymbol(..) , ALL.ATNEnv ) where @@ -28,15 +27,17 @@ import qualified Data.Set as DS import qualified Text.ANTLR.Set as S +import Text.ANTLR.Pretty (Prettify(..)) + -- | Go from an Allstar AST to the AST type used internally in this package fromAllstarAST :: ALL.AST nts t -> P.AST nts t -fromAllstarAST (ALL.Node nt asts) = P.AST nt [] (map fromAllstarAST asts) +fromAllstarAST (ALL.Node nt ruleFired asts) = P.AST nt (map fromAllstarSymbol ruleFired) (map fromAllstarAST asts) fromAllstarAST (ALL.Leaf tok) = P.Leaf tok -- TODO: Handle predicate and mutator state during the conversion -- | Go from an antlr-haskell Grammar to an Allstar ATNEnv. ALL(*) does not --- current support predicates and mutators. -atnOf :: (Ord nt, Ord t, S.Hashable nt, S.Hashable t) => G.Grammar s nt t -> ALL.ATNEnv nt t +-- currently support predicates and mutators. +atnOf :: (Ord nt, Ord t, S.Hashable nt, S.Hashable t) => G.Grammar s nt t dt -> ALL.ATNEnv nt t atnOf g = DS.fromList (map convTrans (S.toList (ATN._Δ (ATN.atnOf g)))) -- | ATN Transition to AllStar version @@ -55,12 +56,38 @@ convEdge ATN.Epsilon = ALL.GS ALL.EPS -- | Entrypoint to the ALL(*) parsing algorithm. -parse inp s0 atns cache = fromAllstarAST <$> ALL.parse inp s0 atns cache +parse' + :: ( P.CanParse nts tok, Prettify chr ) + => ALL.Tokenizer chr tok + -> [chr] + -> ALL.GrammarSymbol nts (ALL.Label tok) + -> ALL.ATNEnv nts (ALL.Label tok) + -> Bool + -> Either String (P.AST nts tok) +parse' tokenizer inp s0 atns cache = fromAllstarAST <$> ALL.parse tokenizer inp s0 atns cache +-- | No tokenizer required (chr == tok): +parse + :: ( P.CanParse nts tok ) + => [tok] + -> ALL.GrammarSymbol nts (ALL.Label tok) + -> ALL.ATNEnv nts (ALL.Label tok) + -> Bool + -> Either String (P.AST nts tok) +parse = let + tokenizer [] = [] + tokenizer (t:ts) = [(t,ts)] + in parse' tokenizer + convSymbol s = ALL.NT s toAllstarSymbol :: G.ProdElem nts ts -> ALL.GrammarSymbol nts ts toAllstarSymbol (G.NT nts) = ALL.NT nts toAllstarSymbol (G.T ts) = ALL.T ts toAllstarSymbol (G.Eps) = ALL.EPS + +fromAllstarSymbol :: ALL.GrammarSymbol nts ts -> G.ProdElem nts ts +fromAllstarSymbol (ALL.NT nts) = (G.NT nts) +fromAllstarSymbol (ALL.T ts) = (G.T ts) +fromAllstarSymbol ALL.EPS = G.Eps diff --git a/src/Text/ANTLR/Allstar/ATN.hs b/src/Text/ANTLR/Allstar/ATN.hs --- a/src/Text/ANTLR/Allstar/ATN.hs +++ b/src/Text/ANTLR/Allstar/ATN.hs @@ -77,12 +77,12 @@ -- | Convert a G4 grammar into an ATN for parsing with ALL(*) atnOf - :: forall nt t s. (Eq nt, Eq t, Hashable nt, Hashable t) - => Grammar s nt t -> ATN s nt t + :: forall nt t s dt. (Eq nt, Eq t, Hashable nt, Hashable t) + => Grammar s nt t dt -> ATN s nt t atnOf g = let - _Δ :: Int -> Production s nt t -> [Transition s nt t] - _Δ i (Production lhs rhs) = let + _Δ :: Int -> Production s nt t dt -> [Transition s nt t] + _Δ i (Production lhs rhs _) = let --(Prod _α)) = let -- Construct an internal production state from the given ATN identifier diff --git a/src/Text/ANTLR/Allstar/ParserGenerator.hs b/src/Text/ANTLR/Allstar/ParserGenerator.hs --- a/src/Text/ANTLR/Allstar/ParserGenerator.hs +++ b/src/Text/ANTLR/Allstar/ParserGenerator.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, FlexibleContexts, BangPatterns, ScopedTypeVariables + , OverloadedStrings, StandaloneDeriving, UndecidableInstances #-} {-| Module : Text.ANTLR.Allstar.ParserGenerator Description : ALL(*) parsing algorithm @@ -11,16 +12,20 @@ -} module Text.ANTLR.Allstar.ParserGenerator - ( GrammarSymbol(..), Token(..), ATNEnv(..) + ( GrammarSymbol(..), ATNEnv(..) , AST(..), ATNState(..), ATNEdge(..) - , ATNEdgeLabel(..) - , parse + , ATNEdgeLabel(..), Label(..) + , parse, Tokenizer(..) ) where import Data.List import qualified Data.Set as DS -import Debug.Trace +import Debug.Trace as D +import Data.Maybe (fromJust) +import Text.ANTLR.Parser (HasEOF(..), CanParse(..) ) +import Text.ANTLR.Grammar (Ref(..)) +import Text.ANTLR.Pretty (pshow', Prettify(..), pStr) --------------------------------TYPE DEFINITIONS-------------------------------- -- Add another synonym for NT names @@ -30,6 +35,10 @@ -- | Grammar symbol types data GrammarSymbol nt t = NT nt | T t | EPS deriving (Eq, Ord, Show) +instance (Prettify nt, Prettify t) => Prettify (GrammarSymbol nt t) where + prettify (NT nt) = pStr "NT " >> prettify nt + prettify (T t) = pStr "T " >> prettify t + -- ATN types {- @@ -51,6 +60,11 @@ | Final nt -- ^ Accepting state deriving (Eq, Ord, Show) +instance (Prettify nt) => Prettify (ATNState nt) where + prettify (Init nt) = pStr "Init " >> prettify nt + prettify (Middle nt i0 i1) = pStr "Middle " >> prettify nt >> pStr " " >> prettify i0 >> pStr " " >> prettify i1 + prettify (Final nt) = pStr "Final " >> prettify nt + -- | Starting state, NT/T symbol to parse, and ending state. type ATNEdge nt t = (ATNState nt, ATNEdgeLabel nt t, ATNState nt) @@ -61,6 +75,10 @@ | PRED Bool -- ^ Unimplemented predicates in ALL(*) deriving (Eq, Ord, Show) +instance (Prettify nt, Prettify t) => Prettify (ATNEdgeLabel nt t) where + prettify (GS gs) = prettify gs + prettify (PRED b) = pStr "PRED " >> prettify b + -- | A set of ATN edges, defining the grammar over which the ALL(*) parsing -- algorithm operates. type ATNEnv nt t = DS.Set (ATNEdge nt t) @@ -69,7 +87,7 @@ isInit (Init nt) = True isInit _ = False -outgoingEdge :: (Eq nt, Show nt) => ATNState nt -> ATNEnv nt t -> ATNEdge nt t +outgoingEdge :: (Eq nt, Prettify nt) => ATNState nt -> ATNEnv nt t -> ATNEdge nt t outgoingEdge p atnEnv = let edges = outgoingEdges p atnEnv in case edges of [edge] -> edge @@ -77,7 +95,7 @@ -- Do I need to make sure there's at least one outgoing edge, or should that -- be handled by an earlier check to make sure the grammar/ATN is well-formed? -outgoingEdges :: (Eq nt, Show nt) => ATNState nt -> ATNEnv nt t -> [ATNEdge nt t] +outgoingEdges :: (Eq nt, Prettify nt) => ATNState nt -> ATNEnv nt t -> [ATNEdge nt t] outgoingEdges p atnEnv = DS.toList (DS.filter (\(p',_,_) -> p' == p) atnEnv) @@ -92,16 +110,42 @@ data DFAState nt = Dinit [ATNConfig nt] | D [ATNConfig nt] | F Int | Derror deriving (Eq, Ord, Show) type DFAEnv nt t = [(GrammarSymbol nt t, DFA nt t)] +instance (Prettify nt) => Prettify (DFAState nt) where + prettify (Dinit cfgs) = pStr "Dinit " >> prettify cfgs + prettify (D cfgs) = pStr "D " >> prettify cfgs + prettify (F i) = pStr "F " >> prettify i + prettify (Derror) = pStr "Derror" + +getLabel :: (Ref v, HasEOF (Sym v), Prettify v) => v -> (StripEOF (Sym v)) +getLabel v = {- D.trace (pshow' v) $ -} (fromJust . stripEOF . getSymbol) v + +type Label tok = StripEOF (Sym tok) + -- | Input sequence type -class Token t where +{-class Token t where type Label t :: * type Literal t :: * getLabel :: t -> Label t getLiteral :: t -> Literal t +-} -- | Return type of parse function -data AST nt tok = Node nt [AST nt tok] | Leaf tok deriving (Eq, Show) +data AST nt tok = Node nt [GrammarSymbol nt (Label tok)] [AST nt tok] | Leaf tok +--deriving (Eq, Show) +deriving instance (Eq nt, Eq tok, Eq (Label tok)) => Eq (AST nt tok) +deriving instance (Show nt, Show tok, Show (Label tok)) => Show (AST nt tok) + +instance (Prettify nt, Prettify tok, Prettify (Label tok)) => Prettify (AST nt tok) where + prettify (Node nt ruleFired asts) = do + pStr "Node " + prettify nt + pStr " <" + prettify ruleFired + pStr "> " + prettify asts + prettify (Leaf tok) = prettify tok + --------------------------------CONSTANTS--------------------------------------- emptyEnv = [] @@ -166,41 +210,62 @@ bind k v [] = [(k, v)] bind k v ((k', v') : al') = if k == k' then (k, v) : al' else (k', v') : bind k v al' +type Tokenizer chr tok = [chr] -> [(tok, [chr])] + --------------------------------ALL(*) FUNCTIONS-------------------------------- -- should parse() also return residual input sequence? +getMe :: (Ref tok, HasEOF (Sym tok), Prettify tok) => AST nt tok -> GrammarSymbol nt (Label tok) +getMe (Leaf tok) = T $ getLabel tok +getMe (Node nt _ _) = NT nt + -- | ALL(*) parsing algorithm. This is __not__ the entrypoint as used by -- user-facing code. See 'Text.ANTLR.Allstar.parse' instead. -parse :: (Eq nt, Show nt, Ord nt, Eq (Label tok), Show (Label tok), Ord (Label tok), Token tok, Show tok) => - [tok] -> GrammarSymbol nt (Label tok) -> ATNEnv nt (Label tok) -> Bool -> Either String (AST nt tok) -parse input startSym atnEnv useCache = - let parseLoop input currState stack dfaEnv subtrees astStack = +parse :: forall chr tok nt. ( CanParse nt tok, Prettify chr ) => +--(Eq nt, Show nt, Ord nt, Eq (Label tok), Show (Label tok), Ord (Label tok), Show tok +-- , Ref tok, HasEOF (Sym tok), Show chr) => + Tokenizer chr tok -> + [chr] -> GrammarSymbol nt (Label tok) -> ATNEnv nt (Label tok) -> Bool -> Either String (AST nt tok) +parse tokenizer input startSym atnEnv useCache = + let + --parseLoop :: (tok, [chr]) -> GrammarSymbol nt (Label tok) -> ATNEnv nt (Label tok) -> Bool -> Either String (AST nt tok) + parseLoop + :: (tok, [chr]) + -> ATNState nt + -> [ATNState nt] + -> DFAEnv nt (Label tok) -- [(GrammarSymbol nt (Label tok), DFA nt (Label tok))] --ATNEnv nt (Label tok) + -> [AST nt tok] + -> [[AST nt tok]] + -> Either String (AST nt tok) + parseLoop (t, chrs) currState stack dfaEnv subtrees astStack = + --D.trace (pshow' (t,chrs) ++ ", " ++ pshow' currState ++ ", " ++ pshow' stack ++ ", " ++ pshow' subtrees ++ ", " ++ pshow' astStack) $ case (currState, startSym) of (Final c, NT c') -> if c == c' then - Right (Node c subtrees) + Right (Node c (map getMe subtrees) subtrees) else case (stack, astStack) of (q : stack', leftSiblings : astStack') -> - parseLoop input q stack' dfaEnv (leftSiblings ++ [Node c subtrees]) astStack' + parseLoop (t, chrs) q stack' dfaEnv (leftSiblings ++ [Node c (map getMe subtrees) subtrees]) astStack' _ -> error ("Reached a final ATN state, but parse is incomplete " ++ "and there's no ATN state to return to") (_, _) -> case (outgoingEdge currState atnEnv) of -- Nothing -> error ("No matching edge found for " ++ (show currState)) - (p, t, q) -> - case (t, input) of - (GS (T b), []) -> error "Input has been exhausted" - (GS (T b), c : cs) -> if b == getLabel c then - parseLoop cs q stack dfaEnv (subtrees ++ [Leaf c]) astStack -- changed from Leaf b + (p, term, q) -> + case (term, t) of + (GS (T b), t) -> if b == getLabel t then + case tokenizer chrs of + [] -> parseLoop (t, chrs) q stack dfaEnv (subtrees ++ [Leaf t]) astStack --Left $ "No more tokenization possible on input <" ++ pshow' chrs ++ ">" + ((t', chrs'):ts') -> parseLoop (t', chrs') q stack dfaEnv (subtrees ++ [Leaf t]) astStack -- changed from Leaf b else - Left ("remaining input: " ++ show input) + Left ("remaining input: " ++ pshow' (t, chrs)) (GS (NT b), _) -> let stack' = q : stack - in case adaptivePredict (NT b) input stack' dfaEnv of -- Pattern for referring to (NT b)? - Nothing -> Left ("Couldn't find a path through ATN " ++ show b ++ - " with input " ++ show input) - Just (i, dfaEnv') -> parseLoop input (Middle b i 0) stack' dfaEnv' [] (subtrees : astStack) -- was (CHOICE b i) - (GS EPS, _) -> parseLoop input q stack dfaEnv subtrees astStack + in case adaptivePredict (NT b) (t, chrs) stack' dfaEnv of -- Pattern for referring to (NT b)? + Nothing -> Left ("Couldn't find a path through ATN " ++ pshow' b ++ + " with input " ++ pshow' (t, chrs)) + Just (i, dfaEnv') -> parseLoop (t, chrs) (Middle b i 0) stack' dfaEnv' [] (subtrees : astStack) -- was (CHOICE b i) + (GS EPS, _) -> parseLoop (t, chrs) q stack dfaEnv subtrees astStack (PRED _, _) -> error "not implemented" initialDfaEnv = DS.toList (DS.foldr (\(p,_,_) ntNames -> @@ -209,23 +274,28 @@ DS.empty atnEnv) - in case startSym of (NT c) -> - case adaptivePredict startSym input emptyStack initialDfaEnv of - Nothing -> Left ("Couldn't find a path through ATN " ++ show c ++ - " with input " ++ show input) - Just (iStart, initialDfaEnv') -> parseLoop input (Middle c iStart 0) emptyStack initialDfaEnv' [] emptyStack - _ -> error "Start symbol must be a nonterminal" + tokens = tokenizer input + in case tokens of + [] -> Left $ "Tokenizer returned nothing on input: " ++ pshow' input + ((t, chrs):ts) -> + case startSym of + (NT c) -> case adaptivePredict startSym (t, chrs) emptyStack initialDfaEnv of + Nothing -> + Left ("Couldn't find a path through ATN " ++ pshow' c ++ " with input " ++ pshow' input) + Just (iStart, initialDfaEnv') -> + parseLoop (t, chrs) (Middle c iStart 0) emptyStack initialDfaEnv' [] emptyStack + _ -> Left "Start symbol must be a nonterminal" where -- adaptivePredict :: (GrammarSymbol nt (Label tok)) -> [tok] -> ATNStack nt -> DFAEnv nt (Label tok) -> Maybe (Int, DFAEnv nt (Label tok)) - adaptivePredict sym input stack dfaEnv = + adaptivePredict sym (t, chrs) stack dfaEnv = case lookup sym dfaEnv of - Nothing -> error ("No DFA found for " ++ show sym) + Nothing -> error ("No DFA found for " ++ pshow' sym) Just dfa -> let d0 = case findInitialState dfa of Just d0 -> d0 Nothing -> startState sym emptyStack - in sllPredict sym input d0 stack dfaEnv + in sllPredict sym (t, chrs) d0 stack dfaEnv startState sym stack = case sym of @@ -263,15 +333,14 @@ (Final _, q : gamma') -> currConfig : closure busy' (q, i, gamma') _ -> currConfig : loopOverEdges pEdges - sllPredict sym input d0 stack initialDfaEnv = - let predictionLoop d tokens dfaEnv = - case tokens of - [] -> Nothing -- Does the empty token sequence ever indicate that the grammar is ambiguous? - t : ts -> + sllPredict sym (t, chrs) d0 stack initialDfaEnv = + let predictionLoop d (t, chrs) dfaEnv = + --[] -> Nothing -- Does the empty token sequence ever indicate that the grammar is ambiguous? + --t : ts -> let (d', dfaEnv') = if useCache then case lookup sym dfaEnv of - Nothing -> error ("No DFA found for nonterminal " ++ show sym ++ show dfaEnv) + Nothing -> error ("No DFA found for nonterminal " ++ pshow' sym ++ pshow' dfaEnv) Just dfa -> case dfaTrans d (getLabel t) dfa of Just (_, _, d2) -> (d2, dfaEnv) @@ -289,20 +358,20 @@ any (\cSet -> length cSet > 1) conflictSets && not (any (\pSet -> length pSet == 1) prodSets) in if stackSensitive then - Just (llPredict sym input stack, initialDfaEnv) -- Again, do we have to discard previous updates to the DFA? + Just (llPredict sym (t, chrs) stack, initialDfaEnv) -- Again, do we have to discard previous updates to the DFA? else - predictionLoop d' ts dfaEnv' - in predictionLoop d0 input initialDfaEnv + predictionLoop d' (case tokenizer chrs of + [] -> (t, chrs) --Nothing --error "Tokenizer really can't do it?" + ((t', chrs'):_) -> (t', chrs')) dfaEnv' + in predictionLoop d0 (t, chrs) initialDfaEnv -- This function looks a little fishy -- come back to it and think about what each case represents -- Also, maybe it should return a Maybe type so that it can propagate a Nothing value upwards -- instead of raising an error - llPredict sym input stack = + llPredict sym (t, chrs) stack = let d0 = startState sym stack - predictionLoop d tokens = - case tokens of - [] -> error ("Empty input in llPredict") - t : ts -> + predictionLoop d (t, chrs) = + --t : ts -> let mv = move d (getLabel t) d' = D (concat (map (closure []) mv)) in case d' of @@ -318,8 +387,10 @@ if allEqual altSets && length a > 1 then minimum (map (\(_, i, _) -> i) a) else - predictionLoop d' ts - in predictionLoop d0 input + predictionLoop d' (case tokenizer chrs of + [] -> error "Tokenizer can't do it." + ((t', chrs'):_) -> (t', chrs')) + in predictionLoop d0 (t, chrs) target d a = diff --git a/src/Text/ANTLR/Grammar.hs b/src/Text/ANTLR/Grammar.hs --- a/src/Text/ANTLR/Grammar.hs +++ b/src/Text/ANTLR/Grammar.hs @@ -18,7 +18,7 @@ , Production(..), ProdRHS(..), StateFncn(..) , Predicate(..), Mutator(..), Ref(..) -- * Basic setter / getter functions: - , getRHS, getLHS + , getRHS, getLHS, getDataType , isSem, isAction , sameNTs, sameTs , isNT, isT, isEps, getNTs, getTs, getEps @@ -171,12 +171,12 @@ -- | Get just the production elements from a bunch of production rules getProds = map (\(Prod _ ss) -> ss) --- | A single production rule -data Production s nts ts = Production nts (ProdRHS s nts ts) +-- | A single production rule with some datatype dt annotating what gets produced when this production rule fires. +data Production s nts ts dt = Production nts (ProdRHS s nts ts) (Maybe dt) deriving (Eq, Ord, Generic, Hashable, Data, Lift) -instance (Prettify s, Prettify nts, Prettify ts) => Prettify (Production s nts ts) where - prettify (Production nts (Prod sf ps)) = do +instance (Prettify s, Prettify nts, Prettify ts, Prettify dt) => Prettify (Production s nts ts dt) where + prettify (Production nts (Prod sf ps) dt) = do len <- pCount nts -- Put the indentation level after the nonterminal, or just incr by 2 if -- lazy... @@ -184,24 +184,28 @@ pStr " -> " prettify sf prettify ps + prettify dt incrIndent (-4) -instance (Show s, Show nts, Show ts) => Show (Production s nts ts) where - show (Production nts rhs) = show nts ++ " -> " ++ show rhs +instance (Show s, Show nts, Show ts, Show dt) => Show (Production s nts ts dt) where + show (Production nts rhs dt) = show nts ++ " -> " ++ show rhs ++ " (" ++ show dt ++ ")" -- | Inline get 'ProdRHS' of a 'Production' -getRHS :: Production s nts ts -> ProdRHS s nts ts -getRHS (Production lhs rhs) = rhs +getRHS :: Production s nts ts dt -> ProdRHS s nts ts +getRHS (Production lhs rhs dt) = rhs -- | Inline get the nonterminal symbol naming a 'Production' -getLHS :: Production s nts ts -> nts -getLHS (Production lhs rhs) = lhs +getLHS :: Production s nts ts dt -> nts +getLHS (Production lhs rhs dt) = lhs +getDataType :: Production s nts t dt -> Maybe dt +getDataType (Production lhs rhs dt) = dt + -- | Get only the productions for the given nonterminal symbol nts: -prodsFor :: forall s nts ts. (Eq nts) => Grammar s nts ts -> nts -> [Production s nts ts] +prodsFor :: forall s nts ts dt. (Eq nts) => Grammar s nts ts dt -> nts -> [Production s nts ts dt] prodsFor g nts = let - matchesNT :: Production s nts t -> Bool - matchesNT (Production nts' _) = nts' == nts + matchesNT :: Production s nts t dt -> Bool + matchesNT (Production nts' _ _) = nts' == nts in filter matchesNT (ps g) -- TODO: boiler plate auto deriving for "named" of a user defined type? @@ -253,17 +257,17 @@ hashWithSalt salt (Mutator m1 _) = salt `hashWithSalt` m1 -- | Core representation of a grammar, as used by the parsing algorithms. -data Grammar s nts ts = G +data Grammar s nts ts dt = G { ns :: Set nts , ts :: Set ts - , ps :: [Production s nts ts] + , ps :: [Production s nts ts dt] , s0 :: nts , _πs :: Set (Predicate s) , _μs :: Set (Mutator s) } deriving (Show, Lift) -instance (Eq s, Eq nts, Eq ts, Hashable nts, Hashable ts, Prettify s, Prettify nts, Prettify ts) - => Eq (Grammar s nts ts) where +instance (Eq s, Eq nts, Eq ts, Eq dt, Hashable nts, Hashable ts, Prettify s, Prettify nts, Prettify ts) + => Eq (Grammar s nts ts dt) where g1 == g2 = ns g1 == ns g2 && ts g1 == ts g2 && eqLists (nub $ ps g1) (nub $ ps g2) @@ -276,8 +280,8 @@ eqLists vs [] = False eqLists (v1:vs) vs2 = eqLists vs (filter (/= v1) vs2) -instance (Prettify s, Prettify nts, Prettify ts, Hashable ts, Eq ts, Hashable nts, Eq nts, Ord ts, Ord nts) - => Prettify (Grammar s nts ts) where +instance (Prettify s, Prettify nts, Prettify ts, Prettify dt, Hashable ts, Eq ts, Hashable nts, Eq nts, Ord ts, Ord nts, Ord dt) + => Prettify (Grammar s nts ts dt) where prettify G {ns = ns, ts = ts, ps = ps, s0 = s0, _πs = _πs, _μs = _μs} = do pLine "Grammar:" pStr "{ " @@ -294,14 +298,14 @@ -- | All possible production elements of a given grammar. symbols :: (Ord nts, Ord ts, Hashable s, Hashable nts, Hashable ts) - => Grammar s nts ts -> Set (ProdElem nts ts) + => Grammar s nts ts dt -> Set (ProdElem nts ts) symbols g = S.insert Eps $ S.map NT (ns g) `union` S.map T (ts g) -- | The empty grammar - accepts nothing, with one starting nonterminal -- and nowhere to go. defaultGrammar - :: forall s nts ts. (Ord ts, Hashable ts, Hashable nts, Eq nts) - => nts -> Grammar s nts ts + :: forall s nts ts dt. (Ord ts, Hashable ts, Hashable nts, Eq nts) + => nts -> Grammar s nts ts dt defaultGrammar start = G { ns = S.singleton start , ts = empty @@ -313,9 +317,9 @@ -- | Does the given grammar make any sense? validGrammar - :: forall s nts ts. + :: forall s nts ts dt. (Eq nts, Ord nts, Eq ts, Ord ts, Hashable nts, Hashable ts) - => Grammar s nts ts -> Bool + => Grammar s nts ts dt -> Bool validGrammar g = hasAllNonTerms g && hasAllTerms g @@ -325,21 +329,21 @@ -- | All nonterminals in production rules can be found in the nonterminals list. hasAllNonTerms :: (Eq nts, Ord nts, Hashable nts, Hashable ts) - => Grammar s nts ts -> Bool + => Grammar s nts ts dt -> Bool hasAllNonTerms g = ns g == (fromList . getNTs . concat . getProds . map getRHS $ ps g) -- | All terminals in production rules can be found in the terminal list. hasAllTerms :: (Eq ts, Ord ts, Hashable nts, Hashable ts) - => Grammar s nts ts -> Bool + => Grammar s nts ts dt -> Bool hasAllTerms g = ts g == (fromList . getTs . concat . getProds . map getRHS $ ps g) -- | The starting symbol is a valid nonterminal. startIsNonTerm :: (Ord nts, Hashable nts) - => Grammar s nts ts -> Bool + => Grammar s nts ts dt -> Bool startIsNonTerm g = s0 g `member` ns g --distinctTermsNonTerms g = diff --git a/src/Text/ANTLR/LL1.hs b/src/Text/ANTLR/LL1.hs --- a/src/Text/ANTLR/LL1.hs +++ b/src/Text/ANTLR/LL1.hs @@ -60,8 +60,8 @@ -- | First set of a grammar. first :: - forall sts nts. (Eq nts, Eq sts, Ord nts, Ord sts, Hashable nts, Hashable sts) - => Grammar () nts sts -> [ProdElem nts sts] -> Set (Icon sts) + forall sts nts dt. (Eq nts, Eq sts, Ord nts, Ord sts, Hashable nts, Hashable sts) + => Grammar () nts sts dt -> [ProdElem nts sts] -> Set (Icon sts) first g = let firstOne :: Set (ProdElem nts sts) -> ProdElem nts sts -> Set (Icon sts) firstOne _ t@(T x) = singleton $ Icon x @@ -73,7 +73,7 @@ [ firstOne (insert nts busy) y | y <- (\(Prod _ ss) -> ss) rhs ] - | Production _ rhs <- prodsFor g x ] + | Production _ rhs dt <- prodsFor g x ] firstMany :: [Set (Icon sts)] -> Set (Icon sts) firstMany [] = singleton IconEps @@ -84,8 +84,8 @@ -- | Follow set of a grammar. follow :: - forall nts sts. (Eq nts, Eq sts, Ord nts, Ord sts, Hashable nts, Hashable sts) - => Grammar () nts sts -> nts -> Set (Icon sts) + forall nts sts dt. (Eq nts, Eq sts, Ord nts, Ord sts, Hashable nts, Hashable sts) + => Grammar () nts sts dt -> nts -> Set (Icon sts) follow g = let follow' busy _B | _B `member` busy = empty @@ -121,7 +121,7 @@ `union` foldr union empty [ followProd lhs_nts ss - | Production lhs_nts (Prod _ ss) <- ps g + | Production lhs_nts (Prod _ ss) dt <- ps g ] in follow' empty @@ -135,7 +135,7 @@ -- @ isLL1 :: (Eq nts, Eq sts, Ord nts, Ord sts, Hashable nts, Hashable sts) - => Grammar () nts sts -> Bool + => Grammar () nts sts dt -> Bool isLL1 g = validGrammar g && and [ (first g α `intersection` first g β == empty) @@ -163,8 +163,8 @@ type ParseTable nts sts = M.Map (PTKey nts sts) (PTValue nts sts) parseTable' :: - forall nts sts. (Eq nts, Eq sts, Ord nts, Ord sts, Eq nts, Hashable sts, Hashable nts) - => (PTValue nts sts -> PTValue nts sts -> PTValue nts sts) -> Grammar () nts sts -> ParseTable nts sts + forall nts sts dt. (Eq nts, Eq sts, Ord nts, Ord sts, Eq nts, Hashable sts, Hashable nts) + => (PTValue nts sts -> PTValue nts sts -> PTValue nts sts) -> Grammar () nts sts dt -> ParseTable nts sts parseTable' fncn g = let insertMe :: @@ -175,7 +175,7 @@ foldr insertMe M.empty -- For each terminal a `member` FIRST(α), add A -> α to M[A,α] [ (_A, Icon a, α) - | Production _A (Prod _ α) <- ps g + | Production _A (Prod _ α) dt <- ps g , Icon a <- toList $ first g α ] `M.union` @@ -183,7 +183,7 @@ -- If Eps `member` FIRST(α), add A -> α to M[A,b] -- for each b `member` FOLLOW(A) [ (_A, Icon b, α) - | Production _A (Prod _ α) <- ps g + | Production _A (Prod _ α) dt <- ps g , IconEps `member` first g α , Icon b <- toList $ follow g _A ] @@ -193,15 +193,15 @@ -- , AND IconEOF `member` FOLLOW(_A) -- add A -> α to M[A,IconEOF] [ (_A, IconEOF, α) - | Production _A (Prod _ α) <- ps g + | Production _A (Prod _ α) dt <- ps g , IconEps `member` first g α , IconEOF `member` follow g _A ] -- | The algorithm for computing an LL parse table from a grammar. parseTable :: - forall nts sts. (Eq nts, Eq sts, Ord nts, Ord sts, Hashable sts, Hashable nts) - => Grammar () nts sts -> ParseTable nts sts + forall nts sts dt. (Eq nts, Eq sts, Ord nts, Ord sts, Hashable sts, Hashable nts) + => Grammar () nts sts dt -> ParseTable nts sts parseTable = parseTable' union @@ -246,19 +246,19 @@ , Ord nts, Ord t, Ord (Sym t), Ord (StripEOF (Sym t)) , Prettify nts, Prettify t, Prettify (Sym t), Prettify (StripEOF (Sym t)) , Hashable (Sym t), Hashable nts, Hashable (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> [t] -> Bool + => Grammar () nts (StripEOF (Sym t)) dt -> [t] -> Bool recognize g = (Nothing /=) . predictiveParse g (const ()) -- | Top-down predictive parsing algorithm. predictiveParse - :: forall nts t ast. + :: forall nts t ast dt. (Prettify nts, Prettify t, Prettify (Sym t), Prettify (StripEOF (Sym t)), Prettify ast , Eq nts, Eq (Sym t) , HasEOF (Sym t) , Ord (Sym t), Ord nts, Ord t, Ord (StripEOF (Sym t)) , Hashable (Sym t), Hashable nts, Hashable (StripEOF (Sym t)) , Ref t) - => Grammar () nts (StripEOF (Sym t)) -> Action ast nts t -> [t] -> Maybe ast + => Grammar () nts (StripEOF (Sym t)) dt -> Action ast nts t -> [t] -> Maybe ast predictiveParse g act w0 = let --reduce :: StackTree ast -> StackTree ast @@ -317,13 +317,13 @@ -- | Remove all epsilon productions, i.e. productions of the form "A -> eps", -- without affecting the language accepted. removeEpsilons' :: - forall s nts t. (Eq t, Eq nts, Prettify t, Prettify nts, Prettify s, Ord t, Ord nts, Hashable t, Hashable nts) - => [Production s nts t] -> [Production s nts t] + forall s nts t dt. (Eq t, Eq nts, Eq dt, Prettify t, Prettify nts, Prettify s, Ord t, Ord nts, Hashable t, Hashable nts) + => [Production s nts t dt] -> [Production s nts t dt] removeEpsilons' ps_init = let - epsNT :: Production s nts t -> [nts] -> [nts] - epsNT (Production nts (Prod _ [])) = (:) nts - epsNT (Production nts (Prod _ [Eps])) = (:) nts + epsNT :: Production s nts t dt -> [nts] -> [nts] + epsNT (Production nts (Prod _ []) dt) = (:) nts + epsNT (Production nts (Prod _ [Eps]) dt) = (:) nts epsNT prod = id -- All NTs with an epsilon production @@ -337,15 +337,15 @@ isEPsProd _ = False -} - replicateProd :: nts -> Production s nts t -> [Production s nts t] - replicateProd nts0 (Production nt1 (Prod sf es)) = let + replicateProd :: nts -> Production s nts t dt -> [Production s nts t dt] + replicateProd nts0 (Production nt1 (Prod sf es) dt) = let - rP :: ProdElems nts t -> ProdElems nts t -> [Production s nts t] - rP ys [] = [Production nt1 (Prod sf $ reverse ys)] + rP :: ProdElems nts t -> ProdElems nts t -> [Production s nts t dt] + rP ys [] = [Production nt1 (Prod sf $ reverse ys) dt] rP ys (x:xs) | NT nts0 == x - = Production nt1 (Prod sf (reverse ys ++ xs)) -- Production with nts0 removed - : Production nt1 (Prod sf (reverse ys ++ x:xs)) -- Production without nts0 removed + = Production nt1 (Prod sf (reverse ys ++ xs)) dt -- Production with nts0 removed + : Production nt1 (Prod sf (reverse ys ++ x:xs)) dt -- Production without nts0 removed : ( rP ys xs -- Recursively with nts0 removed ++ rP (x:ys) xs) -- Recursively without nts0 removed | otherwise = rP (x:ys) xs @@ -355,7 +355,7 @@ | p1 `elem` ps = ps | otherwise = p1 : ps - ps' :: [Production s nts t] + ps' :: [Production s nts t dt] ps' = case epsNTs of [] -> ps_init (nts:ntss) -> removeEpsilons' $ @@ -363,16 +363,16 @@ [ p' | p <- ps_init , p' <- replicateProd nts p - , p' /= Production nts (Prod Pass []) - , p' /= Production nts (Prod Pass [Eps])] + , p' /= Production nts (Prod Pass []) (getDataType p') + , p' /= Production nts (Prod Pass [Eps]) (getDataType p')] in ps' -- | Remove all epsilon productions, i.e. productions of the form "A -> eps", -- without affecting the language accepted. removeEpsilons :: - forall s nts t. (Eq t, Eq nts, Prettify t, Prettify nts, Prettify s, Ord t, Ord nts, Hashable t, Hashable nts) - => Grammar s nts t -> Grammar s nts t + forall s nts t dt. (Eq t, Eq nts, Eq dt, Prettify t, Prettify nts, Prettify s, Ord t, Ord nts, Ord dt, Hashable t, Hashable nts) + => Grammar s nts t dt -> Grammar s nts t dt removeEpsilons g = g { ps = removeEpsilons' $ ps g } -- | Add primes to nonterminal symbols. @@ -388,16 +388,16 @@ -- This adds 'Prime's to the nonterminal symbols in cases where we need to break up -- a production rule in order to left factor it. leftFactor :: - forall s nts t. (Eq t, Eq nts, Prettify t, Prettify nts, Ord t, Ord nts, Hashable nts) - => Grammar s nts t -> Grammar s (Prime nts) t + forall s nts t dt. (Eq t, Eq nts, Prettify t, Prettify nts, Ord t, Ord nts, Hashable nts) + => Grammar s nts t dt -> Grammar s (Prime nts) t dt leftFactor = let - primeify :: Grammar s nts t -> Grammar s (Prime nts) t + primeify :: Grammar s nts t dt -> Grammar s (Prime nts) t dt primeify g = G { ns = fromList $ [ Prime (nts, 0) | nts <- toList $ ns g ] , ts = ts g - , ps = [ Production (Prime (nts, 0)) (Prod sf $ map prmPE ss) - | Production nts (Prod sf ss) <- ps g ] + , ps = [ Production (Prime (nts, 0)) (Prod sf $ map prmPE ss) dt + | Production nts (Prod sf ss) dt <- ps g ] , s0 = Prime (s0 g, 0) , _πs = _πs g , _μs = _μs g @@ -408,7 +408,7 @@ prmPE (T x) = T x prmPE Eps = Eps - lF :: Grammar s (Prime nts) t -> Grammar s (Prime nts) t + lF :: Grammar s (Prime nts) t dt -> Grammar s (Prime nts) t dt lF g = let -- Longest common prefix of two lists lcp :: ProdElems (Prime nts) t -> ProdElems (Prime nts) t -> ProdElems (Prime nts) t @@ -421,8 +421,8 @@ lcps :: [(Prime nts, ProdElems (Prime nts) t)] lcps = [ (nts0, maximumBy (comparing length) [ lcp xs ys - | Production _ (Prod _ xs) <- filter ((== nts0) . getLHS) (ps g) - , Production _ (Prod _ ys) <- filter ((== nts0) . getLHS) (ps g) + | Production _ (Prod _ xs) _ <- filter ((== nts0) . getLHS) (ps g) + , Production _ (Prod _ ys) _ <- filter ((== nts0) . getLHS) (ps g) , xs /= ys ]) | nts0 <- toList $ ns g ] @@ -433,27 +433,27 @@ incr :: Prime nts -> Prime nts incr (Prime (nts, i)) = Prime (nts, i + 1) - ps' :: [(Prime nts, ProdElems (Prime nts) t)] -> [Production s (Prime nts) t] - ps' [] = ps g + ps' :: [(Prime nts, ProdElems (Prime nts) t)] -> [Production s (Prime nts) t dt] + ps' [] = ps g ps' ((nts, xs):_) = -- Unaffected productions - [ Production nts0 (Prod v rhs) - | Production nts0 (Prod v rhs) <- ps g + [ Production nts0 (Prod v rhs) dt + | Production nts0 (Prod v rhs) dt <- ps g , nts0 /= nts ] ++ -- Unaffected productions - [ Production nts0 (Prod v rhs) - | Production nts0 (Prod v rhs) <- ps g + [ Production nts0 (Prod v rhs) dt + | Production nts0 (Prod v rhs) dt <- ps g , nts == nts0 && not (xs `isPrefixOf` rhs) ] ++ -- Affected productions - [ Production (incr nts0) (Prod v (drop (length xs) rhs)) - | Production nts0 (Prod v rhs) <- ps g + [ Production (incr nts0) (Prod v (drop (length xs) rhs)) dt + | Production nts0 (Prod v rhs) dt <- ps g , nts == nts0 && xs `isPrefixOf` rhs ] - ++ [Production nts (Prod Pass $ xs ++ [NT $ incr nts])] + ++ [Production nts (Prod Pass $ xs ++ [NT $ incr nts]) Nothing] {- [ (prime nts, drop (length xs) ys) | (nt1, ys) <- ps g , nt1 == nts diff --git a/src/Text/ANTLR/LR.hs b/src/Text/ANTLR/LR.hs --- a/src/Text/ANTLR/LR.hs +++ b/src/Text/ANTLR/LR.hs @@ -1,6 +1,6 @@ {-# LANGUAGE ScopedTypeVariables, ExplicitForAll, DeriveGeneric, DeriveAnyClass , FlexibleContexts, StandaloneDeriving, OverloadedStrings, MonadComprehensions - , InstanceSigs, DeriveDataTypeable, DeriveLift #-} + , InstanceSigs, DeriveDataTypeable, DeriveLift, ConstraintKinds #-} {-| Module : Text.ANTLR.LR Description : Entrypoint for all parsing algorithms based on LR @@ -18,7 +18,7 @@ , lr1Closure, lr1Goto, lr1Items, lr1Table, lr1Parse, lr1Recognize , LR1LookAhead , CoreLRState, CoreLR1State, CoreSLRState, LRTable, LRTable', LRAction(..) - , lrParse, LRResult(..), LR1Result(..), glrParse, glrParseInc, isAccept, isError + , lrParse, GLRResult(..), LRResult(..), LR1Result(..), glrParse, glrParseInc, isAccept, isError , lr1S0, glrParseInc', glrParseInc2 , convGoto, convStateInt, convGotoStatesInt, convTableInt, tokenizerFirstSets , disambiguate @@ -84,8 +84,10 @@ type LR1Action nts sts lrstate = LRAction nts sts lrstate -- | An LR1 closure is just a regular LR 'Closure'. type LR1Closure lrstate = Closure lrstate --- | LR1 results are just 'LRResult's -type LR1Result lrstate t ast = LRResult lrstate t ast +-- | LR1 results are just 'LRResult's with identical tokens and characters +type LR1Result lrstate t ast = LRResult lrstate t t ast +-- | GLR results are just 'LRResult's +type GLRResult lrstate c t ast = LRResult lrstate c t ast -- | An LR1 item is an 'Item' with one lookahead symbol. type LR1Item nts sts = Item (LR1LookAhead sts) nts sts -- | An LR1 table is just an 'LRTable' in disguise. @@ -106,10 +108,10 @@ -- | The actions that an LR parser can tell the user about. data LRAction nts sts lrstate = - Shift lrstate -- ^ Shift @lrstate@ onto the stack. - | Reduce (Production () nts sts) -- ^ Reduce a production rule (and fire off any data constructor) - | Accept -- ^ The parser has accepted the input. - | Error -- ^ A parse error occured. + Shift lrstate -- ^ Shift @lrstate@ onto the stack. + | Reduce (Production () nts sts ()) -- ^ Reduce a production rule (and fire off any data constructor) + | Accept -- ^ The parser has accepted the input. + | Error -- ^ A parse error occured. deriving (Generic, Eq, Ord, Hashable, Show, Data, Lift) -- | An LR configurate telling you the current stack of states @[lrstate]@, @@ -117,12 +119,12 @@ type Config lrstate t = ([lrstate], [t]) -- | The different kinds of results an LR parser can return. -data LRResult lrstate t ast = - ErrorNoAction (Config lrstate t) [ast] -- ^ Parser got stuck (no action performable). - | ErrorAccept (Config lrstate t) [ast] -- ^ Parser accepted but still has @ast@s to consume. - | ResultSet (Set (LRResult lrstate t ast)) -- ^ The grammar / parse was ambiguously accepted. - | ResultAccept ast -- ^ Parse accepted and produced a single @ast@. - | ErrorTable (Config lrstate t) [ast] -- ^ The goto table was missing an entry. +data LRResult lrstate c t ast = + ErrorNoAction t (Config lrstate c) [ast] -- ^ Parser got stuck (no action performable). + | ErrorAccept (Config lrstate c) [ast] -- ^ Parser accepted but still has @ast@s to consume. + | ResultSet (Set (LRResult lrstate c t ast)) -- ^ The grammar / parse was ambiguously accepted. + | ResultAccept ast -- ^ Parse accepted and produced a single @ast@. + | ErrorTable (Config lrstate c) [ast] -- ^ The goto table was missing an entry. deriving (Eq, Ord, Show, Generic, Hashable) -- | A tokenizer is a function that, given a set of DFA names to try tokenizing, @@ -156,15 +158,16 @@ prettify Accept = pStr "Accept" prettify Error = pStr "Error" -instance ( Prettify t, Prettify ast, Prettify lrstate - , Eq t, Eq ast, Eq lrstate - , Hashable ast, Hashable t, Hashable lrstate) - => Prettify (LRResult lrstate t ast) where +instance ( Prettify c, Prettify t, Prettify ast, Prettify lrstate + , Eq c, Eq t, Eq ast, Eq lrstate + , Hashable c, Hashable ast, Hashable t, Hashable lrstate) + => Prettify (LRResult lrstate c t ast) where - prettify (ErrorNoAction (s:states, ws) asts) = do - pStr "ErrorNoAction: Current input = '" - if null ws then return () else prettify (head ws) - pLine "'" + prettify (ErrorNoAction t (s:states, ws) asts) = do + pStr "ErrorNoAction: Current input token = <" + prettify t + --if null ws then return () else prettify (head ws) + pLine ">" incrIndent 7 pStr "Current state = <" @@ -176,9 +179,9 @@ pLine "'" prettify (ErrorTable (s:states, ws) asts) = do - pStr "ErrorTable: Current input = '" + pStr "ErrorTable: Current input character = <" if null ws then return () else prettify (head ws) - pLine "'" + pLine ">" incrIndent 7 pStr "Current state = <" @@ -190,9 +193,9 @@ pLine "'" prettify (ErrorAccept (s:states, ws) asts) = do - pStr "ErrorAccept: Current input = " + pStr "ErrorAccept: Current input character = <" (if null ws then return () else prettify (head ws)) - pLine "" + pLine ">" incrIndent 7 pStr "Current state = " @@ -208,12 +211,8 @@ prettify (ResultAccept ast) = pStr "ResultAccept: " >> prettify ast -- | Algorithm for computing an SLR closure. -slrClosure :: - forall nts sts. - ( Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> SLRClosure (CoreSLRState nts sts) +slrClosure :: forall nts sts dt. ( CanParse' nts sts ) + => Grammar () nts sts dt -> SLRClosure (CoreSLRState nts sts) slrClosure g is' = let closure' :: SLRClosure (CoreSLRState nts sts) @@ -223,7 +222,7 @@ | Item _A α rst@(pe@(NT _B) : β) () <- toList _J , not $ null rst , isNT pe - , Production _ (Prod _ γ) <- prodsFor g _B + , Production _ (Prod _ γ) _ <- prodsFor g _B ] in case size $ add \\ _J of 0 -> _J `union` add @@ -232,12 +231,8 @@ in closure' is' -- | Algorithm for computing an LR(1) closure. -lr1Closure :: - forall nts sts. - ( Eq nts, Eq sts - , Ord nts, Ord sts, Ord sts - , Hashable sts, Hashable sts, Hashable nts) - => Grammar () nts sts -> Closure (CoreLR1State nts sts) +lr1Closure :: forall nts sts dt. ( Tabular nts, Tabular sts ) + => Grammar () nts sts dt -> Closure (CoreLR1State nts sts) lr1Closure g is' = let tokenToProdElem (Icon a) = [T a] @@ -251,7 +246,7 @@ | Item _A α rst@(pe@(NT _B) : β) a <- toList _J , not $ null rst , isNT pe - , Production _ (Prod _ γ) <- prodsFor g _B + , Production _ (Prod _ γ) _ <- prodsFor g _B , b <- toList $ LL.first g (β ++ tokenToProdElem a) ] in case size $ add \\ _J of @@ -268,10 +263,7 @@ convAction _ Error = Error -- | fmap over @lrstate@s of a 'LRTable'. -convTable :: - ( Ord lrstate, Ord lrstate', Ord sts - , Hashable nts, Hashable sts, Hashable lrstate, Hashable lrstate' - , Eq nts) +convTable :: ( IsState lrstate, IsState lrstate', Tabular nts, Tabular sts ) => (lrstate -> lrstate') -> LRTable nts sts lrstate -> LRTable nts sts lrstate' convTable fncn tbl = M.fromList' [ ((fncn state, icon), S.map (convAction fncn) action) @@ -279,47 +271,37 @@ ] -- | Convert the states in a 'LRTable' into integers. -convTableInt :: forall lrstate nts sts. - ( Ord lrstate, Ord sts - , Hashable nts, Hashable sts, Hashable lrstate - , Eq nts, Show lrstate) +convTableInt :: forall lrstate nts sts. ( IsState lrstate, Tabular nts, Tabular sts ) => LRTable nts sts lrstate -> [lrstate] -> LRTable nts sts Int convTableInt tbl ss = convTable (convStateInt $ ss) tbl -- | fmap over @lrstate@s of a 'Goto'. -convGotoStates :: - ( Ord lrstate, Ord lrstate', Ord sts, Ord nts - , Hashable nts, Hashable sts, Hashable lrstate - , Eq nts) +convGotoStates :: ( IsState lrstate, IsState lrstate', Tabular nts, Tabular sts ) => (lrstate -> lrstate') -> Goto nts sts lrstate -> Goto nts sts lrstate' convGotoStates fncn goto = M1.fromList [ ((fncn st0, e), fncn st1) | ((st0, e), st1) <- M1.toList goto ] -- | Convert the states in a goto to integers. -convGotoStatesInt :: forall lrstate nts sts. - ( Ord lrstate, Ord sts, Ord nts - , Hashable nts, Hashable sts, Hashable lrstate - , Eq nts, Show lrstate) +convGotoStatesInt :: forall lrstate nts sts. ( IsState lrstate, Tabular sts, Tabular nts ) => Goto nts sts lrstate -> [lrstate] -> Goto nts sts Int convGotoStatesInt goto ss = convGotoStates (convStateInt ss) goto -- | Create a function that, given the list of all possible @lrstate@ elements, -- converts an @lrstate@ into a unique integer. -convStateInt :: forall lrstate. - (Ord lrstate, Show lrstate) +convStateInt :: forall lrstate. ( IsState lrstate ) => [lrstate] -> (lrstate -> Int) convStateInt ss = let statemap :: M1.Map lrstate Int statemap = M1.fromList $ zip ss [0 .. ] - fromJust' st Nothing = error $ "woops: " ++ show st + fromJust' st Nothing = error $ "woops: " ++ pshow' st fromJust' _ (Just x) = x in (\st -> fromJust' st (st `M1.lookup` statemap)) -- | Convert a function-based goto to a map-based one once we know the set of -- all lrstates (sets of items for LR1) and all the production elements -convGoto :: (Hashable lrstate, Ord lrstate, Ord sts, Ord nts) - => Grammar () nts sts -> Goto' nts sts lrstate -> [lrstate] -> Goto nts sts lrstate +convGoto :: ( IsState lrstate, Ord sts, Ord nts) + => Grammar () nts sts dt -> Goto' nts sts lrstate -> [lrstate] -> Goto nts sts lrstate convGoto g goto states = M1.fromList [ ((st0, e), goto st0 e) | st0 <- states @@ -327,7 +309,7 @@ ] -- | Get a list of all possible production elements (no epsilon) for the given grammar. -allProdElems :: Grammar () nts ts -> [ProdElem nts ts] +allProdElems :: Grammar () nts ts dt -> [ProdElem nts ts] allProdElems g = map NT (S.toList $ ns g) ++ map T (S.toList $ ts g) @@ -340,10 +322,8 @@ -- | Compute the set of states we would go to by traversing the -- given nonterminal symbol @_X@. -goto :: - ( Ord a, Ord nts, Ord sts - , Hashable sts, Hashable nts, Hashable a) - => Grammar () nts sts -> Closure (CoreLRState a nts sts) -> Goto' nts sts (CoreLRState a nts sts) +goto :: ( CanParse' nts sts, Ord a, Hashable a ) + => Grammar () nts sts dt -> Closure (CoreLRState a nts sts) -> Goto' nts sts (CoreLRState a nts sts) goto g closure is _X = closure $ fromList [ Item _A (_X : α) β a | Item _A α (_X' : β) a <- toList is @@ -351,22 +331,14 @@ ] -- | Goto with an SLR closure, 'slrClosure'. -slrGoto :: - forall nts sts. - ( Eq nts, Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> Goto' nts sts (CoreSLRState nts sts) +slrGoto :: forall nts sts dt. ( CanParse' nts sts ) + => Grammar () nts sts dt -> Goto' nts sts (CoreSLRState nts sts) slrGoto g = goto g (slrClosure g) -- | Compute all possible LR items for a grammar by iteratively running -- goto until reaching a fixed point. -items :: - forall a nts sts. - ( Ord a, Ord nts, Ord sts - , Eq nts, Eq sts - , Hashable a, Hashable sts, Hashable nts) - => Grammar () nts sts -> Goto' nts sts (CoreLRState a nts sts) -> CoreLRState a nts sts -> Set (CoreLRState a nts sts) +items :: forall nts sts dt a. ( CanParse' nts sts, Ord a, Hashable a ) + => Grammar () nts sts dt -> Goto' nts sts (CoreLRState a nts sts) -> CoreLRState a nts sts -> Set (CoreLRState a nts sts) items g goto s0 = let items' :: Set (CoreLRState a nts sts) -> Set (CoreLRState a nts sts) items' _C = let @@ -385,9 +357,7 @@ -- | The kernel of a set items, namely the items where the dot is -- not at the left-most position of the RHS (also excluding the -- starting symbol). -kernel :: - ( Ord a, Ord sts, Ord nts - , Hashable a, Hashable sts, Hashable nts) +kernel :: ( Tabular nts, Tabular sts, Ord a, Hashable a ) => Set (Item a nts sts) -> Set (Item a nts sts) kernel = let kernel' (Item (Init _) _ _ _) = True @@ -396,12 +366,8 @@ in S.filter kernel' -- | Generate the set of all possible Items for a given grammar: -allSLRItems :: - forall nts sts. - ( Eq nts, Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> Set (SLRItem nts sts) +allSLRItems :: forall nts sts dt. ( CanParse' nts sts ) + => Grammar () nts sts dt -> Set (SLRItem nts sts) allSLRItems g = fromList [ Item (Init $ s0 g) [] [NT $ s0 g] () , Item (Init $ s0 g) [NT $ s0 g] [] () @@ -410,40 +376,28 @@ fromList [ Item (ItemNT nts) (reverse $ take n γ) (drop n γ) () | nts <- toList $ ns g - , Production _ (Prod _ γ) <- prodsFor g nts + , Production _ (Prod _ γ) _ <- prodsFor g nts , n <- [0..length γ] ] -- | The starting LR state of a grammar. -lrS0 :: - ( Ord a, Ord sts, Ord nts - , Hashable a, Hashable sts, Hashable nts) - => a -> Grammar () nts sts -> CoreLRState a nts sts +lrS0 :: ( Tabular nts, Tabular sts, Ord a, Hashable a ) + => a -> Grammar () nts sts dt -> CoreLRState a nts sts lrS0 a g = singleton $ Item (Init $ s0 g) [] [NT $ s0 g] a -- | SLR starting state. -slrS0 :: - ( Ord sts, Ord nts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> CoreLRState () nts sts +slrS0 :: ( Tabular sts, Tabular nts ) + => Grammar () nts sts dt -> CoreLRState () nts sts slrS0 = lrS0 () -- | Compute SLR table with appropriate 'slrGoto' and 'slrClosure'. -slrItems :: - forall nts sts. - ( Eq nts, Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> Set (Set (SLRItem nts sts)) +slrItems :: forall nts sts dt. (Tabular nts, Tabular sts ) + => Grammar () nts sts dt -> Set (Set (SLRItem nts sts)) slrItems g = items g (slrGoto g) (slrClosure g $ slrS0 g) -- | Algorithm for computing the SLR table. -slrTable :: - forall nts sts. - ( Eq nts, Eq sts - , Ord nts, Ord sts - , Hashable nts, Hashable sts) - => Grammar () nts sts -> SLRTable nts sts (CoreSLRState nts sts) +slrTable :: forall nts sts dt. ( Tabular nts, Tabular sts ) + => Grammar () nts sts dt -> SLRTable nts sts (CoreSLRState nts sts) slrTable g = let --slr' :: a -> b -> b @@ -455,7 +409,7 @@ [((_Ii, Icon a), Shift $ slrGoto g _Ii $ T a)] slr'' (Item (Init nts) α (T a:β) ()) = [((_Ii, Icon a), Shift $ slrGoto g _Ii $ T a)] slr'' (Item (ItemNT nts) α [] ()) = - [ ((_Ii, a), Reduce (Production nts (Prod Pass $ reverse α))) + [ ((_Ii, a), Reduce (Production nts (Prod Pass $ reverse α) Nothing)) | a <- (toList . LL.follow g) nts ] slr'' (Item (Init nts) α [] ()) = [((_Ii, IconEOF), Accept)] @@ -465,11 +419,8 @@ in M.fromList $ concat $ S.map slr' $ slrItems g -- | Algorithm for computing the LR(1) table. -lr1Table :: forall nts sts. - ( Eq nts, Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> LRTable nts sts (CoreLR1State nts sts) +lr1Table :: forall nts sts dt. ( Tabular nts, Tabular sts ) + => Grammar () nts sts dt -> LRTable nts sts (CoreLR1State nts sts) lr1Table g = let --lr1' :: LR1State nts sts -> LRTable nts sts lr1' _Ii = let @@ -477,7 +428,7 @@ lr1'' (Item (ItemNT nts) α (T a:β) _) = --uPIO (prints ("TABLE:", a, slrGoto g _Ii $ T a, _Ii)) `seq` Just ((_Ii, Icon a), Shift $ lr1Goto g _Ii $ T a) lr1'' (Item (Init nts) α (T a:β) _) = Just ((_Ii, Icon a), Shift $ lr1Goto g _Ii $ T a) - lr1'' (Item (ItemNT nts) α [] a) = Just ((_Ii, a), Reduce (Production nts (Prod Pass $ reverse α))) + lr1'' (Item (ItemNT nts) α [] a) = Just ((_Ii, a), Reduce (Production nts (Prod Pass $ reverse α) Nothing)) lr1'' (Item (Init nts) α [] IconEOF) = Just ((_Ii, IconEOF), Accept) lr1'' _ = Nothing in catMaybes (S.toList $ S.map lr1'' _Ii) @@ -485,10 +436,7 @@ in M.fromList $ concat (S.map lr1' $ lr1Items g) -- | Lookup a value in an 'LRTable'. -look :: - ( Ord lrstate, Ord nts, Ord sts - , Eq sts - , Hashable lrstate, Hashable sts, Hashable nts) +look :: ( IsState lrstate, Tabular nts, Tabular sts ) => (lrstate, Icon sts) -> LRTable nts sts lrstate -> Set (LRAction nts sts lrstate) look (s,a) tbl = --uPIO (prints ("lookup:", s, a, M.lookup (s, a) act)) `seq` M.lookup (s, a) tbl @@ -507,27 +455,23 @@ -- | The core LR parsing algorithm, parametrized for different variants -- (SLR, LR(1), ...). lrParse :: - forall ast a nts t lrstate. - ( Ord lrstate, Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)) - , Eq nts, Eq (Sym t), Eq (StripEOF (Sym t)) - , Ref t, HasEOF (Sym t) - , Hashable (Sym t), Hashable t, Hashable lrstate, Hashable nts, Hashable (StripEOF (Sym t)) - , Prettify lrstate, Prettify t, Prettify nts, Prettify (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> LRTable nts (StripEOF (Sym t)) lrstate -> Goto nts (StripEOF (Sym t)) lrstate + forall nts t dt ast lrstate. + ( CanParse nts t, IsState lrstate, IsAST ast ) + => Grammar () nts (StripEOF (Sym t)) dt -> LRTable nts (StripEOF (Sym t)) lrstate -> Goto nts (StripEOF (Sym t)) lrstate -> lrstate -> Action ast nts t - -> [t] -> LRResult lrstate t ast + -> [t] -> LRResult lrstate t t ast lrParse g tbl goto s_0 act w = let - lr :: Config lrstate t -> [ast] -> LRResult lrstate t ast + lr :: Config lrstate t -> [ast] -> LRResult lrstate t t ast lr (s:states, a:ws) asts = let - lr' :: LRAction nts (StripEOF (Sym t)) lrstate -> LRResult lrstate t ast + lr' :: LRAction nts (StripEOF (Sym t)) lrstate -> LRResult lrstate t t ast lr' Accept = case length asts of 1 -> ResultAccept $ head asts _ -> ErrorAccept (s:states, a:ws) asts - lr' Error = ErrorNoAction (s:states, a:ws) asts + lr' Error = ErrorNoAction a (s:states, ws) asts lr' (Shift t) = trace ("Shift: " ++ pshow' t) $ lr (t:s:states, ws) $ act (TermE a) : asts - lr' (Reduce p@(Production _A (Prod _ β))) = let + lr' (Reduce p@(Production _A (Prod _ β) _)) = let ss'@(t:_) = drop (length β) (s:states) result = case (t, NT _A) `M1.lookup` goto of @@ -541,107 +485,75 @@ Nothing -> look (s, IconEOF) tbl in if S.null lookVal - then ErrorNoAction (s:states, a:ws) asts + then ErrorNoAction a (s:states, ws) asts else lr' $ (head . S.toList) lookVal in lr ([s_0], w) [] -- | Entrypoint for SLR parsing. slrParse :: - ( Eq (Sym nts), Eq (Sym t), Eq (StripEOF (Sym t)) - , Ref t, HasEOF (Sym t) - , Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)) - , Hashable nts, Hashable (Sym t), Hashable t, Hashable (StripEOF (Sym t)) - , Prettify t, Prettify nts, Prettify (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> Action ast nts t -> [t] - -> LRResult (CoreSLRState nts (StripEOF (Sym t))) t ast + forall nts t dt ast. ( CanParse nts t, IsAST ast ) + => Grammar () nts (StripEOF (Sym t)) dt -> Action ast nts t -> [t] + -> LRResult (CoreSLRState nts (StripEOF (Sym t))) t t ast slrParse g = lrParse g (slrTable g) (convGoto g (slrGoto g) (sort $ S.toList $ slrItems g)) (slrClosure g $ slrS0 g) -- | SLR language recognizer. -slrRecognize :: - ( Eq (Sym nts), Eq (Sym t), Eq (StripEOF (Sym t)) - , Ref t, HasEOF (Sym t) - , Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)) - , Hashable nts, Hashable (Sym t), Hashable t, Hashable (StripEOF (Sym t)) - , Prettify t, Prettify nts, Prettify (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> [t] -> Bool -slrRecognize g w = isAccept $ slrParse g (const 0) w +slrRecognize :: forall nts t dt. ( CanParse nts t ) + => Grammar () nts (StripEOF (Sym t)) dt -> [t] -> Bool +slrRecognize g w = isAccept $ slrParse g (const ()) w -- | LR(1) language recognizer. -lr1Recognize :: - ( Eq (Sym nts), Eq (Sym t), Eq (StripEOF (Sym t)) - , Ref t, HasEOF (Sym t) - , Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)) - , Hashable nts, Hashable (Sym t), Hashable t, Hashable (StripEOF (Sym t)) - , Prettify t, Prettify nts, Prettify (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> [t] -> Bool -lr1Recognize g w = isAccept $ lr1Parse g (const 0) w +lr1Recognize :: forall nts t dt. ( CanParse nts t ) + => Grammar () nts (StripEOF (Sym t)) dt -> [t] -> Bool +lr1Recognize g w = isAccept $ lr1Parse g (const ()) w -- | Get just the lookahead symbols for a set of LR(1) items. -getLookAheads :: (Hashable sts, Hashable nts, Eq sts, Eq nts) => Set (LR1Item nts sts) -> Set sts +getLookAheads :: ( Tabular sts, Tabular nts ) => Set (LR1Item nts sts) -> Set sts getLookAheads = let gLA (Item _ _ _ IconEOF) = Nothing gLA (Item _ _ _ (Icon sts)) = Just sts in S.fromList . catMaybes . S.toList . S.map gLA -- | LR(1) goto table (function) of a grammar. -lr1Goto :: - ( Eq nts, Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> Goto' nts sts (CoreLR1State nts sts) +lr1Goto :: ( Tabular nts, Tabular sts ) + => Grammar () nts sts dt -> Goto' nts sts (CoreLR1State nts sts) lr1Goto g = goto g (lr1Closure g) -- | LR(1) start state of a grammar. -lr1S0 :: - ( Eq sts - , Ord sts, Ord nts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> CoreLRState (LR1LookAhead sts) nts sts +lr1S0 :: ( Tabular sts, Tabular nts ) + => Grammar () nts sts dt -> CoreLRState (LR1LookAhead sts) nts sts lr1S0 = lrS0 IconEOF -- | Items computed for LR(1) with an 'lr1Goto' and an 'lr1Closure'. -lr1Items :: - ( Eq sts, Eq sts - , Ord nts, Ord sts - , Hashable sts, Hashable nts) - => Grammar () nts sts -> Set (CoreLRState (LR1LookAhead sts) nts sts) +lr1Items :: ( CanParse' nts sts ) + => Grammar () nts sts dt -> Set (CoreLRState (LR1LookAhead sts) nts sts) lr1Items g = items g (lr1Goto g) (lr1Closure g $ lr1S0 g) -- | Entrypoint for LR(1) parser. -lr1Parse :: - ( Eq (Sym nts), Eq (Sym t), Eq (StripEOF (Sym t)) - , Ref t, HasEOF (Sym t) - , Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)) - , Hashable nts, Hashable (Sym t), Hashable t, Hashable (StripEOF (Sym t)) - , Prettify t, Prettify nts, Prettify (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> Action ast nts t -> [t] - -> LRResult (CoreLR1State nts (StripEOF (Sym t))) t ast +lr1Parse :: forall nts t dt ast. ( CanParse nts t, IsAST ast ) + => Grammar () nts (StripEOF (Sym t)) dt -> Action ast nts t -> [t] + -> LRResult (CoreLR1State nts (StripEOF (Sym t))) t t ast lr1Parse g = lrParse g (lr1Table g) (convGoto g (lr1Goto g) (sort $ S.toList $ lr1Items g)) (lr1Closure g $ lr1S0 g) -- | Non-incremental GLR parsing algorithm. glrParse' :: - forall ast nts t lrstate. - ( Ord lrstate, Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)), Ord ast - , Eq nts, Eq (Sym t), Eq (StripEOF (Sym t)), Eq ast - , Ref t, HasEOF (Sym t) - , Hashable (Sym t), Hashable t, Hashable lrstate, Hashable nts, Hashable (StripEOF (Sym t)), Hashable ast - , Prettify lrstate, Prettify t, Prettify nts, Prettify (StripEOF (Sym t))) - => Grammar () nts (StripEOF (Sym t)) -> LRTable nts (StripEOF (Sym t)) lrstate -> Goto nts (StripEOF (Sym t)) lrstate + forall nts t dt ast lrstate. + ( CanParse nts t, IsState lrstate, IsAST ast ) + => Grammar () nts (StripEOF (Sym t)) dt -> LRTable nts (StripEOF (Sym t)) lrstate -> Goto nts (StripEOF (Sym t)) lrstate -> lrstate -> Action ast nts t - -> [t] -> LRResult lrstate t ast + -> [t] -> LRResult lrstate t t ast glrParse' g tbl goto s_0 act w = let - lr :: Config lrstate t -> [ast] -> LRResult lrstate t ast + lr :: Config lrstate t -> [ast] -> LRResult lrstate t t ast lr (s:states, a:ws) asts = let - lr' :: LRAction nts (StripEOF (Sym t)) lrstate -> LRResult lrstate t ast + lr' :: LRAction nts (StripEOF (Sym t)) lrstate -> LRResult lrstate t t ast lr' Accept = case length asts of 1 -> ResultAccept $ head asts _ -> ErrorAccept (s:states, a:ws) asts - lr' Error = ErrorNoAction (s:states, a:ws) asts + lr' Error = ErrorNoAction a (s:states, ws) asts lr' (Shift t) = trace ("Shift: " ++ pshow' t) $ lr (t:s:states, ws) $ act (TermE a) : asts - lr' (Reduce p@(Production _A (Prod _ β))) = let + lr' (Reduce p@(Production _A (Prod _ β) _)) = let ss'@(t:_) = drop (length β) (s:states) result = case (t, NT _A) `M1.lookup` goto of @@ -657,7 +569,7 @@ justAccepts = getAccepts parseResults in if S.null lookVal - then ErrorNoAction (s:states, a:ws) asts + then ErrorNoAction a (s:states, ws) asts else (if S.null justAccepts then (case S.size parseResults of 0 -> undefined @@ -670,21 +582,15 @@ -- | Entrypoint for GLR parsing algorithm. glrParse g = glrParse' g (lr1Table g) (convGoto g (lr1Goto g) (sort $ S.toList $ lr1Items g)) (lr1Closure g $ lr1S0 g) --- | Internal algorithm for incremental GLR parser. glrParseInc' :: - forall ast nts t c lrstate. - ( Ord nts, Ord (Sym t), Ord t, Ord (StripEOF (Sym t)), Ord ast, Ord lrstate - , Eq nts, Eq (Sym t), Eq (StripEOF (Sym t)), Eq ast - , Ref t, HasEOF (Sym t) - , Hashable (Sym t), Hashable t, Hashable nts, Hashable (StripEOF (Sym t)), Hashable ast, Hashable lrstate - , Prettify t, Prettify nts, Prettify (StripEOF (Sym t)), Prettify lrstate - , Eq c, Ord c, Hashable c) - => Grammar () nts (StripEOF (Sym t)) -> LRTable nts (StripEOF (Sym t)) lrstate -> Goto nts (StripEOF (Sym t)) lrstate + forall nts t dt ast lrstate c. + ( CanParse nts t, IsState lrstate, IsAST ast, Tabular c ) + => Grammar () nts (StripEOF (Sym t)) dt -> LRTable nts (StripEOF (Sym t)) lrstate -> Goto nts (StripEOF (Sym t)) lrstate -> lrstate -> M1.Map lrstate (Set (StripEOF (Sym t))) -> Action ast nts t - -> Tokenizer t c -> [c] -> LR1Result lrstate c ast + -> Tokenizer t c -> [c] -> GLRResult lrstate c t ast glrParseInc' g tbl goto s_0 tokenizerFirstSets act tokenizer w = let - lr :: Config lrstate c -> [ast] -> LR1Result lrstate c ast + lr :: Config lrstate c -> [ast] -> GLRResult lrstate c t ast lr (s:states, cs) asts = let -- The set of token symbols that are feasible to be seen next given the @@ -693,16 +599,18 @@ -- it just so happens that the type stuffed inside an LR1 lookahead Icon -- is precisely the terminal symbol type that the tokenizer uses to name -- DFAs. - dfaNames = fromMaybe (error "Impossible") $ s `M1.lookup` tokenizerFirstSets + dfaNames = fromMaybe (error $ "Failed DFA lookup: " ++ pshow' (s, tokenizerFirstSets)) + $ s `M1.lookup` tokenizerFirstSets + (a, ws) = tokenizer dfaNames cs - lr' :: LR1Action nts (StripEOF (Sym t)) lrstate -> LR1Result lrstate c ast + lr' :: LR1Action nts (StripEOF (Sym t)) lrstate -> GLRResult lrstate c t ast lr' Accept = case length asts of 1 -> ResultAccept $ head asts _ -> ErrorAccept (s:states, cs) asts - lr' Error = ErrorNoAction (s:states, cs) asts + lr' Error = ErrorNoAction a (s:states, cs) asts lr' (Shift t) = trace ("Shift: " ++ pshow' t) $ lr (t:s:states, ws) $ act (TermE a) : asts - lr' (Reduce p@(Production _A (Prod _ β))) = let + lr' (Reduce p@(Production _A (Prod _ β) _)) = let ss'@(t:_) = drop (length β) (s:states) result = case (t, NT _A) `M1.lookup` goto of @@ -721,7 +629,7 @@ justAccepts = getAccepts parseResults in if S.null lookVal - then ErrorNoAction (s:states, cs) asts + then ErrorNoAction a (s:states, cs) asts else (if S.null justAccepts then (case S.size parseResults of 0 -> undefined @@ -771,11 +679,8 @@ -- | Returns the disambiguated LRTable, as well as the number of conflicts -- (Shift/Reduce, Reduce/Reduce, etc...) reported. disambiguate :: - ( Prettify lrstate, Prettify nts, Prettify sts - , Ord lrstate, Ord nts, Ord sts - , Hashable lrstate, Hashable nts, Hashable sts - , Data lrstate, Data nts, Data sts - , Show lrstate, Show nts, Show sts) + ( IsState lrstate, Tabular nts, Tabular sts + , Data lrstate, Data nts, Data sts) => LRTable nts sts lrstate -> (LRTable' nts sts lrstate, Int) disambiguate tbl = let diff --git a/src/Text/ANTLR/Lex/Tokenizer.hs b/src/Text/ANTLR/Lex/Tokenizer.hs --- a/src/Text/ANTLR/Lex/Tokenizer.hs +++ b/src/Text/ANTLR/Lex/Tokenizer.hs @@ -138,3 +138,36 @@ in (next, drop (sum $ map tokenSize $ next : ignored) input) in tI +tokenizeIncAll + :: forall s i n v. (Eq i, Ord s, Eq n, Eq s, Show s, Show i, Show n, Show v, Hashable i, Hashable s, Hashable n) + => (n -> Bool) -- ^ Function that returns True on DFA names we wish to filter __out__ of the results. + -> [(n, DFA s i)] + -> (Lexeme s -> n -> v) + -> (Set n -> [s] -> [(Token n v, [s])]) +tokenizeIncAll filterF dfaTuples fncn = let + + tI :: Set n -> [s] -> [(Token n v, [s])] + tI ns input = let + + dfaTuples' = filter (\(n,_) -> n `Set.member` ns || filterF n) dfaTuples + tokenized = tokenize dfaTuples' fncn input + + filterF' (Token n _ _) = filterF n + filterF' _ = False + + ignored = takeWhile filterF' tokenized + nextTokens = dropWhile filterF' tokenized + -- Yayy lazy function evaluation. + next = case nextTokens of + [] -> EOF + (t:_) -> t --D.traceShowId t + + input' = drop (sum $ map tokenSize $ next : ignored) input + + ns' = case next of + Token n _ _ -> n `Set.delete` ns + _ -> Set.empty + + in (next, input') : tI ns' input' + in tI + diff --git a/src/Text/ANTLR/Parser.hs b/src/Text/ANTLR/Parser.hs --- a/src/Text/ANTLR/Parser.hs +++ b/src/Text/ANTLR/Parser.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric, DeriveAnyClass, FlexibleContexts, InstanceSigs , UndecidableInstances, StandaloneDeriving, TypeFamilies , ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses - , OverloadedStrings, DeriveDataTypeable #-} + , OverloadedStrings, DeriveDataTypeable, ConstraintKinds #-} {-| Module : Text.ANTLR.Parser Description : Parsing API for constructing Haskell data types from lists of tokens @@ -21,6 +21,26 @@ import Language.Haskell.TH.Lift (Lift(..)) import Text.ANTLR.Set (Hashable) +-- | Nonterminals in a grammar are tabular, terminal symbols are tabular (as are +-- the EOF-stripped version), terminals are referenceable (can be symbolized), +-- and terminals are also tabular. +type CanParse nts t = + ( Tabular nts + , Tabular (Sym t) + , Tabular (StripEOF (Sym t)) + , HasEOF (Sym t) + , Ref t + , Tabular t) + +-- | Same as 'CanParse' but with second formal parameter representing (StripEOF (Sym t)) +-- aka "sts" (stripped terminal symbol). +type CanParse' nts sts = ( Tabular nts, Tabular sts ) + +type IsAST ast = ( Ord ast, Eq ast, Hashable ast ) + +type IsState st = ( Ord st, Hashable st, Prettify st ) +type Tabular sym = ( Ord sym, Hashable sym, Prettify sym, Eq sym ) + -- | Action functions triggered during parsing are given the nonterminal we just matched on, the -- corresponding list of production elements (grammar symbols) in the RHS of the matched production -- alternative, and the result of recursively. @@ -84,6 +104,12 @@ | EOFSymbol -- ^ End-of-file symbol deriving (Eq, Ord, Show, Hashable, Generic) +instance (Prettify n) => Prettify (TokenSymbol n) where + prettify (TokenSymbol n) = do + pStr "TokenSymbol " + prettify n + prettify EOFSymbol = pStr "EOFSymbol" + -- | A data type with an EOF constructor. There are two things you can do with a -- data type that has an EOF: -- @@ -109,7 +135,7 @@ instance HasEOF String where type StripEOF String = String - + isEOF "" = True isEOF _ = False diff --git a/src/Text/ANTLR/Pretty.hs b/src/Text/ANTLR/Pretty.hs --- a/src/Text/ANTLR/Pretty.hs +++ b/src/Text/ANTLR/Pretty.hs @@ -139,6 +139,12 @@ pshow' :: (Prettify t) => t -> String pshow' = T.unpack . pshow +pshowList :: (Prettify t) => [t] -> T.Text +pshowList t = str $ execState (prettifyList t) initPState + +pshowList' :: (Prettify t) => [t] -> String +pshowList' = T.unpack . pshowList + -- | Run the pretty-printer with a specific indentation level. pshowIndent :: (Prettify t) => Int -> t -> T.Text pshowIndent i t = str $ execState (prettify t) $ initPState { indent = i } diff --git a/test/allstar/AllStarTests.hs b/test/allstar/AllStarTests.hs --- a/test/allstar/AllStarTests.hs +++ b/test/allstar/AllStarTests.hs @@ -2,13 +2,20 @@ module AllStarTests where -import Test.HUnit +--import Test.HUnit import Text.ANTLR.Allstar.ParserGenerator import qualified Data.Set as DS +import Text.ANTLR.Parser (HasEOF(..)) +import Text.ANTLR.Grammar (Ref(..)) +import Test.Framework +import Test.Framework.Providers.HUnit +import Text.ANTLR.HUnit +import Text.ANTLR.Pretty + --------------------------------TESTING----------------------------------------- -instance Token Char where +{- instance Token Char where type Label Char = Char type Literal Char = Char getLabel c = c @@ -18,8 +25,22 @@ type Label (a, b) = a type Literal (a, b) = b getLabel (a, b) = a - getLiteral (a, b) = b + getLiteral (a, b) = b -} +instance (Show a, Show b) => Prettify (Either a b) where prettify = rshow + +instance Ref Char where + type Sym Char = Char + getSymbol = id + +instance HasEOF Char where + type StripEOF Char = Char + isEOF c = False + stripEOF c = Just c + +dumbTokenizer [] = [] +dumbTokenizer (t:ts) = [(t,ts)] + atnEnv = DS.fromList [ -- First path through the 'S' ATN (Init 'S', GS EPS, Middle 'S' 0 0), (Middle 'S' 0 0, GS (NT 'A'), Middle 'S' 0 1), @@ -47,49 +68,49 @@ -- For now, I'm only checking whether the input was accepted--not checking the derivation. -- Example from the manual trace of ALL(*)'s execution -parseTest1 = TestCase (assertEqual "for parse [a, b, c]," - (Right (Node 'S' - [Node 'A' +parseTest1 = ((@=?) --"for parse dumbTokenizer [a, b, c]," + (Right (Node 'S' [NT 'A', T 'c'] + [Node 'A' [T 'a', NT 'A'] [Leaf 'a', - Node 'A' + Node 'A' [T 'b'] [Leaf 'b']], Leaf 'c'])) - (parse ['a', 'b', 'c'] (NT 'S') atnEnv True)) + (parse dumbTokenizer ['a', 'b', 'c'] (NT 'S') atnEnv True)) -- Example #1 from the ALL(*) paper -parseTest2 = TestCase (assertEqual "for parse [b, c]," - (Right (Node 'S' - [Node 'A' +parseTest2 = ((@=?) --"for parse dumbTokenizer [b, c]," + (Right (Node 'S' [NT 'A', T 'c'] + [Node 'A' [T 'b'] [Leaf 'b'], Leaf 'c'])) - (parse ['b', 'c'] (NT 'S') atnEnv True)) + (parse dumbTokenizer ['b', 'c'] (NT 'S') atnEnv True)) -- Example #2 from the ALL(*) paper -parseTest3 = TestCase (assertEqual "for parse [b, d]," - (Right (Node 'S' - [Node 'A' +parseTest3 = ((@=?) --"for parse dumbTokenizer [b, d]," + (Right (Node 'S' [NT 'A', T 'd'] + [Node 'A' [T 'b'] [Leaf 'b'], Leaf 'd'])) - (parse ['b', 'd'] (NT 'S') atnEnv True)) + (parse dumbTokenizer ['b', 'd'] (NT 'S') atnEnv True)) -- Input that requires more recursive traversals of the A ATN -parseTest4 = TestCase (assertEqual "for parse [a a a b c]," - (Right (Node 'S' - [Node 'A' +parseTest4 = ((@=?) --"for parse dumbTokenizer [a a a b c]," + (Right (Node 'S' [NT 'A', T 'c'] + [Node 'A' [T 'a', NT 'A'] [Leaf 'a', - Node 'A' + Node 'A' [T 'a', NT 'A'] [Leaf 'a', - Node 'A' + Node 'A' [T 'a', NT 'A'] [Leaf 'a', - Node 'A' + Node 'A' [T 'b'] [Leaf 'b']]]], Leaf 'c'])) - (parse ['a', 'a', 'a', 'b', 'c'] (NT 'S') atnEnv True)) + (parse dumbTokenizer ['a', 'a', 'a', 'b', 'c'] (NT 'S') atnEnv True)) -- Make sure that the result of parsing an out-of-language string has a Left tag. -parseTest5 = TestCase (assertEqual "for parse [a b a c]," +parseTest5 = ((@=?) --"for parse dumbTokenizer [a b a c]," True - (let parseResult = parse ['a', 'b', 'a', 'c'] (NT 'S') atnEnv True + (let parseResult = parse dumbTokenizer ['a', 'b', 'a', 'c'] (NT 'S') atnEnv True isLeft pr = case pr of Left _ -> True _ -> False @@ -98,7 +119,7 @@ -- To do: Update these tests so that they use the new ATN state representation. {- -conflictsTest = TestCase (assertEqual "for getConflictSetsPerLoc()" +conflictsTest = ((@=?) --"for getConflictSetsPerLoc()" ([[(MIDDLE 5, 1, []), (MIDDLE 5, 2, []),(MIDDLE 5, 3, [])], [(MIDDLE 5, 1, [MIDDLE 1]), (MIDDLE 5, 2, [MIDDLE 1])], @@ -111,7 +132,7 @@ (MIDDLE 5, 2, [MIDDLE 1]), (MIDDLE 7, 2, [MIDDLE 6, MIDDLE 1])]))) -prodsTest = TestCase (assertEqual "for getProdSetsPerState()" +prodsTest = ((@=?) --"for getProdSetsPerState()" ([[(MIDDLE 5, 1, []), (MIDDLE 5, 2, []), @@ -144,31 +165,31 @@ (Middle 'S' 2 1, GS (T 'b'), Middle 'S' 2 2), (Middle 'S' 2 2, GS EPS, Final 'S')] -ambigParseTest1 = TestCase (assertEqual "for parse [a]," +ambigParseTest1 = ((@=?) --"for parse dumbTokenizer [a]," True - (let parseResult = parse ['a'] (NT 'S') ambigATNEnv True + (let parseResult = parse dumbTokenizer ['a'] (NT 'S') ambigATNEnv True isLeft pr = case pr of Left _ -> True _ -> False in isLeft parseResult)) -ambigParseTest2 = TestCase (assertEqual "for parse [a b]," - (Right (Node 'S' +ambigParseTest2 = ((@=?) --"for parse dumbTokenizer [a b]," + (Right (Node 'S' [T 'a', T 'b'] [Leaf 'a', Leaf 'b'])) - (parse ['a', 'b'] (NT 'S') ambigATNEnv True)) + (parse dumbTokenizer ['a', 'b'] (NT 'S') ambigATNEnv True)) -tests = [TestLabel "parseTest1" parseTest1, - TestLabel "parseTest2" parseTest2, - TestLabel "parseTest3" parseTest3, - TestLabel "parseTest4" parseTest4, - TestLabel "parseTest5" parseTest5, +tests = [testCase "parseTest1" parseTest1, + testCase "parseTest2" parseTest2, + testCase "parseTest3" parseTest3, + testCase "parseTest4" parseTest4, + testCase "parseTest5" parseTest5, - --TestLabel "conflictsTest" conflictsTest, - --TestLabel "prodsTest" prodsTest, + --testCase "conflictsTest" conflictsTest, + --testCase "prodsTest" prodsTest, - TestLabel "ambigParseTest1" ambigParseTest1, - TestLabel "ambigParseTest2" ambigParseTest2] + testCase "ambigParseTest1" ambigParseTest1, + testCase "ambigParseTest2" ambigParseTest2] -main = runTestTT (TestList tests) +--main = runTestTT (TestList tests) diff --git a/test/allstar/ConvertDFA.hs b/test/allstar/ConvertDFA.hs new file mode 100644 --- /dev/null +++ b/test/allstar/ConvertDFA.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell #-} +module ConvertDFA where +import Language.ANTLR4 + +mkInt :: String -> Int +mkInt _ = 3 + +data ConvertIt = + Start String + | End Int + deriving (Eq, Ord, Show) + +$( return [] ) + +[g4| + grammar Convert; + + root : 'START' LexemeA -> Start + | 'END' LexemeB -> End + ; + + LexemeA : 'abc' -> String ; + LexemeB : 'efg' -> mkInt ; +|] + diff --git a/test/allstar/ConvertP.hs b/test/allstar/ConvertP.hs new file mode 100644 --- /dev/null +++ b/test/allstar/ConvertP.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell, FlexibleContexts #-} +module ConvertP + ( module ConvertDFA + , module ConvertP + ) where +import Language.ANTLR4 +import ConvertDFA + +$(g4_parsers convertAST convertGrammar) + diff --git a/test/allstar/Main.hs b/test/allstar/Main.hs --- a/test/allstar/Main.hs +++ b/test/allstar/Main.hs @@ -9,8 +9,27 @@ import Test.QuickCheck (Property, quickCheck, (==>)) import qualified Test.QuickCheck.Monadic as TQM +import qualified AllStarTests +import qualified ConvertP +import ConvertP (ConvertIt(..)) + +convertP_simple = + case ConvertP.allstarParse (const False) "STARTabc" of + (Right ast) -> ConvertP.ast2root ast @=? (Start "abc") + (Left err) -> assertFailure err + +convertP_simple2 = + case ConvertP.allstarParse (const False) "ENDefg" of + (Right ast) -> ConvertP.ast2root ast @=? (End 3) + (Left err) -> assertFailure err + +tests = + [ testCase "convertP_simple" convertP_simple + , testCase "convertP_simple2" convertP_simple2 + ] + main :: IO () main = defaultMainWithOpts - [ - ] mempty + (AllStarTests.tests ++ tests) + mempty diff --git a/test/atn/ATN.hs b/test/atn/ATN.hs new file mode 100644 --- /dev/null +++ b/test/atn/ATN.hs @@ -0,0 +1,134 @@ +module ATN where + +import Text.ANTLR.Grammar +import Text.ANTLR.Allstar.ATN +import Example.Grammar +import Text.ANTLR.Set (fromList, union) +import System.IO.Unsafe (unsafePerformIO) + +-- This is the Grammar from page 6 of the +-- 'Adaptive LL(*) Parsing: The Power of Dynamic Analysis' +-- paper, namely the expected transitions based on Figures +-- 5 through 8: +paperATNGrammar = (defaultGrammar "C" :: Grammar () String String ()) + { ns = fromList ["S", "A"] + , ts = fromList ["a", "b", "c", "d"] + , s0 = "C" + , ps = + [ production "S" $ Prod Pass [NT "A", T "c"] + , production "S" $ Prod Pass [NT "A", T "d"] + , production "A" $ Prod Pass [T "a", NT "A"] + , production "A" $ Prod Pass [T "b"] + ] + } + +s i = ("S", i) + +-- Names as shown in paper: +pS = Start "S" +pS1 = Middle "S" 0 0 +p1 = Middle "S" 0 1 +p2 = Middle "S" 0 2 +pS2 = Middle "S" 1 0 +p3 = Middle "S" 1 1 +p4 = Middle "S" 1 2 +pS' = Accept "S" + +pA = Start "A" +pA1 = Middle "A" 2 0 +p5 = Middle "A" 2 1 +p6 = Middle "A" 2 2 +pA2 = Middle "A" 3 0 +p7 = Middle "A" 3 1 +pA' = Accept "A" + +exp_paperATN = ATN + { _Δ = fromList + -- Submachine for S: + [ (pS, Epsilon, pS1) + , (pS1, NTE "A", p1) + , (p1, TE "c", p2) + , (p2, Epsilon, pS') + , (pS, Epsilon, pS2) + , (pS2, NTE "A", p3) + , (p3, TE "d", p4) + , (p4, Epsilon, pS') + -- Submachine for A: + , (pA, Epsilon, pA1) + , (pA1, TE "a", p5) + , (p5, NTE "A", p6) + , (p6, Epsilon, pA') + , (pA, Epsilon, pA2) + , (pA2, TE "b", p7) + , (p7, Epsilon, pA') + ] + } + +--always _ = True +--never _ = False + +addPredicates = paperATNGrammar + { ps = + ps paperATNGrammar ++ + [ production "A" $ Prod (Sem (Predicate "always" ())) [T "a"] + , production "A" $ Prod (Sem (Predicate "never" ())) [] + , production "A" $ Prod (Sem (Predicate "always2" ())) [NT "A", T "a"] + ] + } + +(pX,pY,pZ) = (Start "A", Start "A", Start "A") +pX1 = Middle "A" 4 2 +pX2 = Middle "A" 4 0 +pX3 = Middle "A" 4 1 +pX4 = Accept "A" + +pY1 = Middle "A" 5 1 +pY2 = Middle "A" 5 0 +pY3 = Accept "A" + +pZ1 = Middle "A" 6 3 +pZ2 = Middle "A" 6 0 +pZ3 = Middle "A" 6 1 +pZ4 = Middle "A" 6 2 +pZ5 = Accept "A" + +exp_addPredicates = ATN + { _Δ = union (_Δ exp_paperATN) $ fromList + [ (pX, Epsilon, pX1) + , (pX1, PE $ Predicate "always" (), pX2) + , (pX2, TE "a", pX3) + , (pX3, Epsilon, pX4) + + , (pY, Epsilon, pY1) + , (pY1, PE $ Predicate "never" (), pY2) + , (pY2, Epsilon, pY3) + + , (pZ, Epsilon, pZ1) + , (pZ1, PE $ Predicate "always2" (), pZ2) + , (pZ2, NTE "A", pZ3) + , (pZ3, TE "a", pZ4) + , (pZ4, Epsilon, pZ5) + ] + } + +fireZeMissiles state = seq + (unsafePerformIO $ putStrLn "Missiles fired.") + undefined + +addMutators = addPredicates + { ps = ps addPredicates ++ + [ production "A" $ Prod (Action (Mutator "fireZeMissiles" ())) [] + , production "S" $ Prod (Action (Mutator "identity" ())) [] + ] + } + +exp_addMutators = ATN + { _Δ = union (_Δ exp_addPredicates) $ fromList + [ (Start "A", Epsilon, Middle "A" 7 0) + , (Middle "A" 7 0, ME $ Mutator "fireZeMissiles" (), Accept "A") + , (Start "S", Epsilon, Middle "S" 8 0) + , (Middle "S" 8 0, ME $ Mutator "identity" (), Accept "S") + ] + } + + diff --git a/test/atn/Main.hs b/test/atn/Main.hs --- a/test/atn/Main.hs +++ b/test/atn/Main.hs @@ -1,6 +1,6 @@ module Main where import Text.ANTLR.Allstar.ATN -import Text.ANTLR.Allstar.Example.ATN +import ATN import Text.ANTLR.Set (fromList, (\\)) import System.IO.Unsafe (unsafePerformIO) diff --git a/test/c/CParser.hs b/test/c/CParser.hs new file mode 100644 --- /dev/null +++ b/test/c/CParser.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell #-} +module CParser where +import Language.ANTLR4 + +{- + [The "BSD licence"] + Copyright (c) 2013 Sam Harwell + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. The name of the author may not be used to endorse or promote products + derived from this software without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +/** C 2011 grammar built from the C11 Spec */ +-} + +{- +[g4| +grammar C; + +primaryExpression + : Identifier + | Constant + | StringLiteral+ + | '(' expression ')' + | genericSelection + | '__extension__'? '(' compoundStatement ')' // Blocks (GCC extension) + | '__builtin_va_arg' '(' unaryExpression ',' typeName ')' + | '__builtin_offsetof' '(' typeName ',' unaryExpression ')' + ; + +genericSelection + : '_Generic' '(' assignmentExpression ',' genericAssocList ')' + ; + +genericAssocList + : genericAssociation + | genericAssocList ',' genericAssociation + ; + +genericAssociation + : typeName ':' assignmentExpression + | 'default' ':' assignmentExpression + ; + +postfixExpression + : primaryExpression + | postfixExpression '[' expression ']' + | postfixExpression '(' argumentExpressionList? ')' + | postfixExpression '.' Identifier + | postfixExpression '->' Identifier + | postfixExpression '++' + | postfixExpression '--' + | '(' typeName ')' '{' initializerList '}' + | '(' typeName ')' '{' initializerList ',' '}' + | '__extension__' '(' typeName ')' '{' initializerList '}' + | '__extension__' '(' typeName ')' '{' initializerList ',' '}' + ; + +argumentExpressionList + : assignmentExpression + | argumentExpressionList ',' assignmentExpression + ; + +unaryExpression + : postfixExpression + | '++' unaryExpression + | '--' unaryExpression + | unaryOperator castExpression + | 'sizeof' unaryExpression + | 'sizeof' '(' typeName ')' + | '_Alignof' '(' typeName ')' + | '&&' Identifier // GCC extension address of label + ; + +unaryOperator + : '&' | '*' | '+' | '-' | '~' | '!' + ; + +castExpression + : '(' typeName ')' castExpression + | '__extension__' '(' typeName ')' castExpression + | unaryExpression + | DigitSequence // for + ; + +multiplicativeExpression + : castExpression + | multiplicativeExpression '*' castExpression + | multiplicativeExpression '/' castExpression + | multiplicativeExpression '%' castExpression + ; + +additiveExpression + : multiplicativeExpression + | additiveExpression '+' multiplicativeExpression + | additiveExpression '-' multiplicativeExpression + ; + +shiftExpression + : additiveExpression + | shiftExpression '<<' additiveExpression + | shiftExpression '>>' additiveExpression + ; + +relationalExpression + : shiftExpression + | relationalExpression '<' shiftExpression + | relationalExpression '>' shiftExpression + | relationalExpression '<=' shiftExpression + | relationalExpression '>=' shiftExpression + ; + +equalityExpression + : relationalExpression + | equalityExpression '==' relationalExpression + | equalityExpression '!=' relationalExpression + ; + +andExpression + : equalityExpression + | andExpression '&' equalityExpression + ; + +exclusiveOrExpression + : andExpression + | exclusiveOrExpression '^' andExpression + ; + +inclusiveOrExpression + : exclusiveOrExpression + | inclusiveOrExpression '|' exclusiveOrExpression + ; + +logicalAndExpression + : inclusiveOrExpression + | logicalAndExpression '&&' inclusiveOrExpression + ; + +logicalOrExpression + : logicalAndExpression + | logicalOrExpression '||' logicalAndExpression + ; + +conditionalExpression + : logicalOrExpression ('?' expression ':' conditionalExpression)? + ; + +assignmentExpression + : conditionalExpression + | unaryExpression assignmentOperator assignmentExpression + | DigitSequence // for + ; + +assignmentOperator + : '=' | '*=' | '/=' | '%=' | '+=' | '-=' | '<<=' | '>>=' | '&=' | '^=' | '|=' + ; + +expression + : assignmentExpression + | expression ',' assignmentExpression + ; + +constantExpression + : conditionalExpression + ; + +declaration + : declarationSpecifiers initDeclaratorList ';' + | declarationSpecifiers ';' + | staticAssertDeclaration + ; + +declarationSpecifiers + : declarationSpecifier+ + ; + +declarationSpecifiers2 + : declarationSpecifier+ + ; + +declarationSpecifier + : storageClassSpecifier + | typeSpecifier + | typeQualifier + | functionSpecifier + | alignmentSpecifier + ; + +initDeclaratorList + : initDeclarator + | initDeclaratorList ',' initDeclarator + ; + +initDeclarator + : declarator + | declarator '=' initializer + ; + +storageClassSpecifier + : 'typedef' + | 'extern' + | 'static' + | '_Thread_local' + | 'auto' + | 'register' + ; + +m128_di : '__m128' | '__m128d' | '__m128i' ; + +typeSpecifier + : 'void' + | 'char' + | 'short' + | 'int' + | 'long' + | 'float' + | 'double' + | 'signed' + | 'unsigned' + | '_Bool' + | '_Complex' + | '__m128' + | '__m128d' + | '__m128i' + | '__extension__' '(' m128_di ')' + | atomicTypeSpecifier + | structOrUnionSpecifier + | enumSpecifier + | typedefName + | '__typeof__' '(' constantExpression ')' // GCC extension + | typeSpecifier pointer + ; + +structOrUnionSpecifier + : structOrUnion Identifier? '{' structDeclarationList '}' + | structOrUnion Identifier + ; + +structOrUnion + : 'struct' + | 'union' + ; + +structDeclarationList + : structDeclaration + | structDeclarationList structDeclaration + ; + +structDeclaration + : specifierQualifierList structDeclaratorList? ';' + | staticAssertDeclaration + ; + +specifierQualifierList + : typeSpecifier specifierQualifierList? + | typeQualifier specifierQualifierList? + ; + +structDeclaratorList + : structDeclarator + | structDeclaratorList ',' structDeclarator + ; + +structDeclarator + : declarator + | declarator? ':' constantExpression + ; + +enumSpecifier + : 'enum' Identifier? '{' enumeratorList '}' + | 'enum' Identifier? '{' enumeratorList ',' '}' + | 'enum' Identifier + ; + +enumeratorList + : enumerator + | enumeratorList ',' enumerator + ; + +enumerator + : enumerationConstant + | enumerationConstant '=' constantExpression + ; + +enumerationConstant + : Identifier + ; + +atomicTypeSpecifier + : '_Atomic' '(' typeName ')' + ; + +typeQualifier + : 'const' + | 'restrict' + | 'volatile' + | '_Atomic' + ; + +functionSpecifier + : 'inline' + | '_Noreturn' + | '__inline__' // GCC extension + | '__stdcall' + | gccAttributeSpecifier + | '__declspec' '(' Identifier ')' + ; + +alignmentSpecifier + : '_Alignas' '(' typeName ')' + | '_Alignas' '(' constantExpression ')' + ; + +declarator + : pointer? directDeclarator gccDeclaratorExtension* + ; + +directDeclarator + : Identifier + | '(' declarator ')' + | directDeclarator '[' typeQualifierList? assignmentExpression? ']' + | directDeclarator '[' 'static' typeQualifierList? assignmentExpression ']' + | directDeclarator '[' typeQualifierList 'static' assignmentExpression ']' + | directDeclarator '[' typeQualifierList? '*' ']' + | directDeclarator '(' parameterTypeList ')' + | directDeclarator '(' identifierList? ')' + | Identifier ':' DigitSequence // bit field + | '(' typeSpecifier? pointer directDeclarator ')' // function pointer like: (__cdecl *f) + ; + +gccDeclaratorExtension + : '__asm' '(' StringLiteral+ ')' + | gccAttributeSpecifier + ; + +gccAttributeSpecifier + : '__attribute__' '(' '(' gccAttributeList ')' ')' + ; + +gccCommaAttr : ',' gccAttribute ; + +gccAttributeList + : gccAttribute gccCommaAttr* + | // empty + ; + +NotCommaParen : [^,()] ; + +argExpList : '(' argumentExpressionList? ')' ; + +gccAttribute + : NotCommaParen // relaxed def for "identifier or reserved word" + argExpList? + | // empty + ; + +NotParens : [^()] ; + +nestedParenthesesBlockOne : + NotParens + | '(' nestedParenthesesBlock ')' + ; + +nestedParenthesesBlock + : nestedParenthesesBlockOne* + ; + +pointer + : '*' typeQualifierList? + | '*' typeQualifierList? pointer + | '^' typeQualifierList? // Blocks language extension + | '^' typeQualifierList? pointer // Blocks language extension + ; + +typeQualifierList + : typeQualifier + | typeQualifierList typeQualifier + ; + +parameterTypeList + : parameterList + | parameterList ',' '...' + ; + +parameterList + : parameterDeclaration + | parameterList ',' parameterDeclaration + ; + +parameterDeclaration + : declarationSpecifiers declarator + | declarationSpecifiers2 abstractDeclarator? + ; + +identifierList + : Identifier + | identifierList ',' Identifier + ; + +typeName + : specifierQualifierList abstractDeclarator? + ; + +abstractDeclarator + : pointer + | pointer? directAbstractDeclarator gccDeclaratorExtension* + ; + +directAbstractDeclarator + : '(' abstractDeclarator ')' gccDeclaratorExtension* + | '[' typeQualifierList? assignmentExpression? ']' + | '[' 'static' typeQualifierList? assignmentExpression ']' + | '[' typeQualifierList 'static' assignmentExpression ']' + | '[' '*' ']' + | '(' parameterTypeList? ')' gccDeclaratorExtension* + | directAbstractDeclarator '[' typeQualifierList? assignmentExpression? ']' + | directAbstractDeclarator '[' 'static' typeQualifierList? assignmentExpression ']' + | directAbstractDeclarator '[' typeQualifierList 'static' assignmentExpression ']' + | directAbstractDeclarator '[' '*' ']' + | directAbstractDeclarator '(' parameterTypeList? ')' gccDeclaratorExtension* + ; + +typedefName + : Identifier + ; + +initializer + : assignmentExpression + | '{' initializerList '}' + | '{' initializerList ',' '}' + ; + +initializerList + : designation? initializer + | initializerList ',' designation? initializer + ; + +designation + : designatorList '=' + ; + +designatorList + : designator + | designatorList designator + ; + +designator + : '[' constantExpression ']' + | '.' Identifier + ; + +staticAssertDeclaration + : '_Static_assert' '(' constantExpression ',' StringLiteral+ ')' ';' + ; + +asmBoth : '__asm' | '__asm__' ; + +volatileBoth : 'volatile' | '__volatile__' ; + +statement + : labeledStatement + | compoundStatement + | expressionStatement + | selectionStatement + | iterationStatement + | jumpStatement + | asmBoth volatileBoth '(' beforeColon? afterColon* ')' ';' + ; + +afterColon : ':' beforeColon? ; + +beforeColon : logicalOrExpression multiLogical* ; + +multiLogical : ',' logicalOrExpression ; + +labeledStatement + : Identifier ':' statement + | 'case' constantExpression ':' statement + | 'default' ':' statement + ; + +compoundStatement + : '{' blockItemList? '}' + ; + +blockItemList + : blockItem + | blockItemList blockItem + ; + +blockItem + : statement + | declaration + ; + +expressionStatement + : expression? ';' + ; + +elseStmt : 'else' statement ; + +selectionStatement + : 'if' '(' expression ')' statement elseStmt? + | 'switch' '(' expression ')' statement + ; + +iterationStatement + : While '(' expression ')' statement + | Do statement While '(' expression ')' ';' + | For '(' forCondition ')' statement + ; + +// | 'for' '(' expression? ';' expression? ';' forUpdate? ')' statement +// | For '(' declaration expression? ';' expression? ')' statement + +forCondition + : forDeclaration ';' forExpression? ';' forExpression? + | expression? ';' forExpression? ';' forExpression? + ; + +forDeclaration + : declarationSpecifiers initDeclaratorList + | declarationSpecifiers + ; + +forExpression + : assignmentExpression + | forExpression ',' assignmentExpression + ; + +jumpStatement + : 'goto' Identifier ';' + | 'continue' ';' + | 'break' ';' + | 'return' expression? ';' + | 'goto' unaryExpression ';' // GCC extension + ; + +compilationUnit + : translationUnit? EOF + ; + +translationUnit + : externalDeclaration + | translationUnit externalDeclaration + ; + +externalDeclaration + : functionDefinition + | declaration + | ';' // stray ; + ; + +functionDefinition + : declarationSpecifiers? declarator declarationList? compoundStatement + ; + +declarationList + : declaration + | declarationList declaration + ; + +Auto : 'auto'; +Break : 'break'; +Case : 'case'; +Char : 'char'; +Const : 'const'; +Continue : 'continue'; +Default : 'default'; +Do : 'do'; +Double : 'double'; +Else : 'else'; +Enum : 'enum'; +Extern : 'extern'; +Float : 'float'; +For : 'for'; +Goto : 'goto'; +If : 'if'; +Inline : 'inline'; +Int : 'int'; +Long : 'long'; +Register : 'register'; +Restrict : 'restrict'; +Return : 'return'; +Short : 'short'; +Signed : 'signed'; +Sizeof : 'sizeof'; +Static : 'static'; +Struct : 'struct'; +Switch : 'switch'; +Typedef : 'typedef'; +Union : 'union'; +Unsigned : 'unsigned'; +Void : 'void'; +Volatile : 'volatile'; +While : 'while'; + +Alignas : '_Alignas'; +Alignof : '_Alignof'; +Atomic : '_Atomic'; +Bool : '_Bool'; +Complex : '_Complex'; +Generic : '_Generic'; +Imaginary : '_Imaginary'; +Noreturn : '_Noreturn'; +StaticAssert : '_Static_assert'; +ThreadLocal : '_Thread_local'; + +LeftParen : '('; +RightParen : ')'; +LeftBracket : '['; +RightBracket : ']'; +LeftBrace : '{'; +RightBrace : '}'; + +Less : '<'; +LessEqual : '<='; +Greater : '>'; +GreaterEqual : '>='; +LeftShift : '<<'; +RightShift : '>>'; + +Plus : '+'; +PlusPlus : '++'; +Minus : '-'; +MinusMinus : '--'; +Star : '*'; +Div : '/'; +Mod : '%'; + +And : '&'; +Or : '|'; +AndAnd : '&&'; +OrOr : '||'; +Caret : '^'; +Not : '!'; +Tilde : '~'; + +Question : '?'; +Colon : ':'; +Semi : ';'; +Comma : ','; + +Assign : '='; +// '*=' | '/=' | '%=' | '+=' | '-=' | '<<=' | '>>=' | '&=' | '^=' | '|=' +StarAssign : '*='; +DivAssign : '/='; +ModAssign : '%='; +PlusAssign : '+='; +MinusAssign : '-='; +LeftShiftAssign : '<<='; +RightShiftAssign : '>>='; +AndAssign : '&='; +XorAssign : '^='; +OrAssign : '|='; + +Equal : '=='; +NotEqual : '!='; + +Arrow : '->'; +Dot : '.'; +Ellipsis : '...'; + +Identifier + : IdentifierNondigit + ( IdentifierNondigit + | Digit + )* + ; + +fragment +IdentifierNondigit + : Nondigit + | UniversalCharacterName + //| // other implementation-defined characters... + ; + +fragment +Nondigit + : [a-zA-Z_] + ; + +fragment +Digit + : [0-9] + ; + +fragment +UniversalCharacterName + : '\\u' HexQuad + | '\\U' HexQuad HexQuad + ; + +fragment +HexQuad + : HexadecimalDigit HexadecimalDigit HexadecimalDigit HexadecimalDigit + ; + +Constant + : IntegerConstant + | FloatingConstant + //| EnumerationConstant + | CharacterConstant + ; + +fragment +IntegerConstant + : DecimalConstant IntegerSuffix? + | OctalConstant IntegerSuffix? + | HexadecimalConstant IntegerSuffix? + | BinaryConstant + ; + +fragment +BinaryConstant + : '0' [bB] [0-1]+ + ; + +fragment +DecimalConstant + : NonzeroDigit Digit* + ; + +fragment +OctalConstant + : '0' OctalDigit* + ; + +fragment +HexadecimalConstant + : HexadecimalPrefix HexadecimalDigit+ + ; + +fragment +HexadecimalPrefix + : '0' [xX] + ; + +fragment +NonzeroDigit + : [1-9] + ; + +fragment +OctalDigit + : [0-7] + ; + +fragment +HexadecimalDigit + : [0-9a-fA-F] + ; + +fragment +IntegerSuffix + : UnsignedSuffix LongSuffix? + | UnsignedSuffix LongLongSuffix + | LongSuffix UnsignedSuffix? + | LongLongSuffix UnsignedSuffix? + ; + +fragment +UnsignedSuffix + : [uU] + ; + +fragment +LongSuffix + : [lL] + ; + +fragment +LongLongSuffix + : 'll' | 'LL' + ; + +fragment +FloatingConstant + : DecimalFloatingConstant + | HexadecimalFloatingConstant + ; + +fragment +DecimalFloatingConstant + : FractionalConstant ExponentPart? FloatingSuffix? + | DigitSequence ExponentPart FloatingSuffix? + ; + +fragment +HexadecimalFloatingConstant + : HexadecimalPrefix HexadecimalFractionalConstant BinaryExponentPart FloatingSuffix? + | HexadecimalPrefix HexadecimalDigitSequence BinaryExponentPart FloatingSuffix? + ; + +fragment +FractionalConstant + : DigitSequence? '.' DigitSequence + | DigitSequence '.' + ; + +fragment +ExponentPart + : 'e' Sign? DigitSequence + | 'E' Sign? DigitSequence + ; + +fragment +Sign + : '+' | '-' + ; + +DigitSequence + : Digit+ + ; + +fragment +HexadecimalFractionalConstant + : HexadecimalDigitSequence? '.' HexadecimalDigitSequence + | HexadecimalDigitSequence '.' + ; + +fragment +BinaryExponentPart + : 'p' Sign? DigitSequence + | 'P' Sign? DigitSequence + ; + +fragment +HexadecimalDigitSequence + : HexadecimalDigit+ + ; + +fragment +FloatingSuffix + : 'f' | 'l' | 'F' | 'L' + ; + +fragment +CharacterConstant + : '\'' CCharSequence '\'' + | 'L\'' CCharSequence '\'' + | 'u\'' CCharSequence '\'' + | 'U\'' CCharSequence '\'' + ; + +fragment +CCharSequence + : CChar+ + ; + +fragment +CChar + : ~['\\\r\n] + | EscapeSequence + ; + +fragment +EscapeSequence + : SimpleEscapeSequence + | OctalEscapeSequence + | HexadecimalEscapeSequence + | UniversalCharacterName + ; + +fragment +SimpleEscapeSequence + : '\\' ['"?abfnrtv\\] + ; + +fragment +OctalEscapeSequence + : '\\' OctalDigit + | '\\' OctalDigit OctalDigit + | '\\' OctalDigit OctalDigit OctalDigit + ; + +fragment +HexadecimalEscapeSequence + : '\\x' HexadecimalDigit+ + ; + +StringLiteral + : EncodingPrefix? '"' SCharSequence? '"' + ; + +fragment +EncodingPrefix + : 'u8' + | 'u' + | 'U' + | 'L' + ; + +fragment +SCharSequence + : SChar+ + ; + +fragment +SChar + : ~["\\\r\n] + | EscapeSequence + | '\\\n' // Added line + | '\\\r\n' // Added line + ; + +ComplexDefine + : '#' Whitespace? 'define' ~[#]* + -> skip + ; + +// ignore the following asm blocks: +/* + asm + { + mfspr x, 286; + } + */ +AsmBlock + : 'asm' ~'{'* '{' ~'}'* '}' + -> skip + ; + +// ignore the lines generated by c preprocessor +// sample line : '#line 1 "/home/dm/files/dk1.h" 1' +LineAfterPreprocessing + : '#line' Whitespace* ~[\r\n]* + -> skip + ; + +LineDirective + : '#' Whitespace? DecimalConstant Whitespace? StringLiteral ~[\r\n]* + -> skip + ; + +PragmaDirective + : '#' Whitespace? 'pragma' Whitespace ~[\r\n]* + -> skip + ; + +Whitespace + : [ \t]+ + -> skip + ; + +Newline + : ( '\r' '\n'? + | '\n' + ) + -> skip + ; + +BlockComment + : '/*' .*? '*/' + -> skip + ; + +LineComment + : '//' ~[\r\n]* + -> skip + ; +|] +-} + diff --git a/test/c/Main.hs b/test/c/Main.hs new file mode 100644 --- /dev/null +++ b/test/c/Main.hs @@ -0,0 +1,7 @@ +module Main where +import Language.ANTLR4 +import CParser + +main :: IO () +main = print "done" + diff --git a/test/chisel/Language/Chisel/Grammar.hs b/test/chisel/Language/Chisel/Grammar.hs --- a/test/chisel/Language/Chisel/Grammar.hs +++ b/test/chisel/Language/Chisel/Grammar.hs @@ -2,11 +2,12 @@ , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances , FlexibleInstances, UndecidableInstances #-} module Language.Chisel.Grammar - ( parse, Language.Chisel.Grammar.tokenize, ChiselNTSymbol(..), ChiselTSymbol(..), ChiselAST + ( ChiselNTSymbol(..), ChiselTSymbol(..), ChiselAST , lowerID, upperID, prim, int, arrow, lparen, rparen, pound , vertbar, colon, comma, atsymbol, carrot, dot, linecomm, ws , Primitive(..), chiselGrammar, TokenValue(..) - , the_ast, TokenName(..), chiselDFAs, lexeme2value, isWhitespace, glrParse + , chiselAST, TokenName(..), chiselDFAs, lexeme2value, isWhitespace + , ChiselToken(..), list, cons, append ) where import Language.ANTLR4 import Language.Chisel.Syntax as S @@ -128,6 +129,4 @@ dot = lookupToken "." linecomm x = Token T_LineComment (V_LineComment x) (length x) ws x = Token T_WS (V_WS x) (length x) - -parse = glrParse isWhitespace diff --git a/test/chisel/Language/Chisel/Parser.hs b/test/chisel/Language/Chisel/Parser.hs --- a/test/chisel/Language/Chisel/Parser.hs +++ b/test/chisel/Language/Chisel/Parser.hs @@ -3,14 +3,17 @@ , FlexibleInstances, UndecidableInstances, TemplateHaskell #-} module Language.Chisel.Parser ( module Language.Chisel.Grammar - , glrParseFast + , Language.Chisel.Parser.tokenize, glrParseFast + , parse, glrParse ) where import Language.ANTLR4 import Language.Chisel.Syntax as S import Language.Chisel.Grammar ---import qualified GHC.Types as G -import qualified Text.ANTLR.LR as LR +$(g4_parsers chiselAST chiselGrammar) -$(mkLRParser the_ast chiselGrammar) +$(mkLRParser chiselAST chiselGrammar) + +parse = glrParse isWhitespace + diff --git a/test/chisel/Main.hs b/test/chisel/Main.hs --- a/test/chisel/Main.hs +++ b/test/chisel/Main.hs @@ -8,6 +8,7 @@ import Language.Chisel.Syntax import Text.ANTLR.Grammar (Grammar(..), ProdElem(..)) import Language.ANTLR4.FileOpener (open) +import Language.ANTLR4.Boot.Syntax (Directive(..)) import System.IO.Unsafe (unsafePerformIO) import Data.Monoid @@ -132,7 +133,7 @@ e -> e @?= LR.ResultAccept LeafEps testPrettify = - unsafePerformIO (putStr $ T.unpack $ pshow (chiselGrammar :: Grammar () ChiselNTSymbol ChiselTSymbol)) + unsafePerformIO (putStr $ T.unpack $ pshow (chiselGrammar :: Grammar () ChiselNTSymbol ChiselTSymbol Directive)) @?= () testFast = diff --git a/test/coreg4/G4.hs b/test/coreg4/G4.hs new file mode 100644 --- /dev/null +++ b/test/coreg4/G4.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, DeriveDataTypeable #-} +module G4 where +import Language.ANTLR4 + +[g4| + grammar G4Basic; + exp : '1' + | '2' + | '3' + ; +|] + diff --git a/test/coreg4/G4Fast.hs b/test/coreg4/G4Fast.hs new file mode 100644 --- /dev/null +++ b/test/coreg4/G4Fast.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE TemplateHaskell #-} +module G4Fast where +import Language.ANTLR4 +import G4 +import G4Parser + +$(mkLRParser g4BasicAST g4BasicGrammar) + +{- +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM +-} + +{- +import Language.ANTLR4 hiding (tokenize) +import Text.ANTLR.Grammar +import qualified Language.ANTLR4.Example.Optionals as Opt +import Language.ANTLR4.Example.G4 as G4 +--import Language.ANTLR4.Example.G4 (g4BasicGrammar, G4BasicNTSymbol, G4BasicTSymbol, G4BasicAST) +import Text.ANTLR.Parser (AST(..)) +import qualified Text.ANTLR.LR as LR +import qualified Text.ANTLR.Lex.Tokenizer as T +-} + +{- +import Data.Map.Internal (fromList) +import qualified Text.ANTLR.MultiMap as M +import Text.ANTLR.MultiMap (Map(..)) +import qualified Text.ANTLR.Set as S +import qualified Data.HashSet as H +-} + diff --git a/test/coreg4/G4Parser.hs b/test/coreg4/G4Parser.hs new file mode 100644 --- /dev/null +++ b/test/coreg4/G4Parser.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell, FlexibleContexts #-} +module G4Parser where +import Language.ANTLR4 +import G4 + +$(g4_parsers g4BasicAST g4BasicGrammar) + diff --git a/test/coreg4/Hello.hs b/test/coreg4/Hello.hs new file mode 100644 --- /dev/null +++ b/test/coreg4/Hello.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, DeriveDataTypeable #-} +module Hello where +import Language.ANTLR4 + +[g4| + // Hello World grammar + // https://github.com/antlr/grammars-v4/blob/master/antlr4/examples/Hello.g4 + grammar Hello; + r : 'hello' WS ID; + ID : [a-zA-Z]+ -> String; + WS : [ \t\r\n]+ -> String; +|] + diff --git a/test/coreg4/HelloParser.hs b/test/coreg4/HelloParser.hs new file mode 100644 --- /dev/null +++ b/test/coreg4/HelloParser.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE QuasiQuotes, TemplateHaskell, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, DeriveDataTypeable, FlexibleContexts #-} +module HelloParser where +import Language.ANTLR4 +import Hello + +$(g4_parsers helloAST helloGrammar) + diff --git a/test/coreg4/Main.hs b/test/coreg4/Main.hs --- a/test/coreg4/Main.hs +++ b/test/coreg4/Main.hs @@ -10,8 +10,10 @@ import qualified Test.QuickCheck.Monadic as TQM import Language.ANTLR4 hiding (tokenize, Regex(..)) -import qualified Language.ANTLR4.Example.G4 as G4 -import Language.ANTLR4.Example.Hello +import qualified G4Parser as G4P +import qualified G4 as G4 +import Hello +import HelloParser import Text.ANTLR.Parser (AST(..)) import qualified Text.ANTLR.LR as LR import Language.ANTLR4.Boot.Syntax (Regex(..)) @@ -19,6 +21,8 @@ import qualified Language.ANTLR4.G4 as P -- Parser +import qualified G4Fast as Fast + test_g4_basic_type_check = do let _ = G4.g4BasicGrammar 1 @?= 1 @@ -44,10 +48,10 @@ -- TODO: implement 'read' instance for TokenValue type so that I don't have to -- hardcode the name for literal terminals (e.g. '1' == T_0 below) test_g4 = - G4.slrParse (G4.tokenize "1") + G4P.slrParse (G4P.tokenize "1") @?= LR.ResultAccept (AST G4.NT_exp [T G4.T_0] [Leaf _1]) - + test_hello = slrParse (tokenize "hello Matt") @?= @@ -59,6 +63,18 @@ ] ) +test_hello_allstar = + allstarParse (const False) ("hello Matt") + @?= + Right (AST NT_r [T T_0, T T_WS, T T_ID] [Leaf (Token T_0 V_0 5),Leaf (Token T_WS (V_WS " ") 1),Leaf + (Token T_ID (V_ID "Matt") 4)]) + --Right (AST NT_r [] []) + +testFastGLR = + Fast.glrParseFast (const False) "3" + @?= + G4P.glrParse (const False) "3" + main :: IO () main = defaultMainWithOpts [ testCase "g4_basic_compilation_type_check" test_g4_basic_type_check @@ -66,5 +82,7 @@ -- , testCase "regex_test" regex_test , testCase "test_g4" test_g4 , testCase "test_hello" test_hello + , testCase "test_hello_allstar" test_hello_allstar + , testCase "testFastGLR" testFastGLR ] mempty diff --git a/test/g4/DoubleSemi.hs b/test/g4/DoubleSemi.hs new file mode 100644 --- /dev/null +++ b/test/g4/DoubleSemi.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell #-} +module DoubleSemi where +import Language.ANTLR4 + +$( return [] ) + +[g4| + grammar Dbl; + dbl : 'a' | 'f' ; // ; + WS : [ \t\r\n]+ -> String; +|] + +isWS T_WS = True +isWS _ = False + diff --git a/test/g4/DoubleSemiP.hs b/test/g4/DoubleSemiP.hs new file mode 100644 --- /dev/null +++ b/test/g4/DoubleSemiP.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell, FlexibleContexts #-} +module DoubleSemiP + ( module DoubleSemiP + , module DoubleSemi + ) where +import Language.ANTLR4 +import DoubleSemi + +$(g4_parsers dblAST dblGrammar) + diff --git a/test/g4/Empty.hs b/test/g4/Empty.hs new file mode 100644 --- /dev/null +++ b/test/g4/Empty.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell #-} +module Empty where +import Language.ANTLR4 + +$( return [] ) + +[g4| + grammar Empty; + emp : 'a' b | 'f' d ; + b : 'c' + | // empty! + ; + + d : // empty! + | 'd' + ; + + WS : [ \t\r\n]+ -> String; +|] + +isWS T_WS = True +isWS _ = False + diff --git a/test/g4/EmptyP.hs b/test/g4/EmptyP.hs new file mode 100644 --- /dev/null +++ b/test/g4/EmptyP.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell, FlexibleContexts #-} +module EmptyP + ( module Empty + , module EmptyP + ) where +import Language.ANTLR4 +import Empty + +$(g4_parsers emptyAST emptyGrammar) + diff --git a/test/g4/G4.hs b/test/g4/G4.hs deleted file mode 100644 --- a/test/g4/G4.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module G4 where - -import System.IO.Unsafe (unsafePerformIO) -import Data.Monoid -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import Test.HUnit -import Test.QuickCheck (Property, quickCheck, (==>)) -import qualified Test.QuickCheck.Monadic as TQM - -import Language.ANTLR4 hiding (tokenize) -import Text.ANTLR.Grammar -import qualified Language.ANTLR4.Example.Optionals as Opt -import Language.ANTLR4.Example.G4 as G4 ---import Language.ANTLR4.Example.G4 (g4BasicGrammar, G4BasicNTSymbol, G4BasicTSymbol, G4BasicAST) -import Text.ANTLR.Parser (AST(..)) -import qualified Text.ANTLR.LR as LR -import qualified Text.ANTLR.Lex.Tokenizer as T - -import qualified Language.ANTLR4.G4 as P -- Parser - -import Data.Map.Internal (fromList) -import qualified Text.ANTLR.MultiMap as M -import Text.ANTLR.MultiMap (Map(..)) -import qualified Text.ANTLR.Set as S -import qualified Data.HashSet as H - -$(mkLRParser G4.the_ast g4BasicGrammar) - diff --git a/test/g4/Main.hs b/test/g4/Main.hs --- a/test/g4/Main.hs +++ b/test/g4/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, FlexibleContexts, TypeFamilies #-} module Main where import System.IO.Unsafe (unsafePerformIO) @@ -12,10 +12,6 @@ import Language.ANTLR4 hiding (tokenize, Regex(..)) import Text.ANTLR.Grammar -import qualified Language.ANTLR4.Example.Optionals as Opt -import qualified Language.ANTLR4.Example.G4 as G4 -import Language.ANTLR4.Example.G4 (g4BasicGrammar, G4BasicNTSymbol, G4BasicTSymbol, G4BasicAST) -import Language.ANTLR4.Example.Hello --import Language.ANTLR4.Regex import Text.ANTLR.Parser (AST(..)) import qualified Text.ANTLR.LR as LR @@ -23,67 +19,24 @@ import qualified Language.ANTLR4.G4 as P -- Parser -import qualified G4 as Fast - -test_g4_basic_type_check = do - let _ = G4.g4BasicGrammar - 1 @?= 1 - -hello_g4_test_type_check = do - let _ = helloGrammar - 1 @?= 1 - -{- -regex_test = do - parseRegex "[ab]* 'a' 'b' 'b'" - @?= Right - (Concat - [ Kleene $ CharSet "ab" - , Literal "a" - , Literal "b" - , Literal "b" - ]) --} - -_1 = G4.lookupToken "1" - --- TODO: implement 'read' instance for TokenValue type so that I don't have to --- hardcode the name for literal terminals (e.g. '1' == T_0 below) -test_g4 = - G4.slrParse (G4.tokenize "1") - @?= - LR.ResultAccept (AST G4.NT_exp [T G4.T_0] [Leaf _1]) - -test_hello = - slrParse (tokenize "hello Matt") - @?= - (LR.ResultAccept $ - AST NT_r [T T_0, T T_WS, T T_ID] - [ Leaf (T.Token T_0 V_0 1) - , Leaf (T.Token T_WS (V_WS " ") 1) - , Leaf (T.Token T_ID (V_ID "Matt") 4) - ] - ) +import qualified Optional as Opt +import qualified OptionalParser as Opt -test_hello_allstar = - allstarParse (tokenize "hello Matt") - @?= - Right (AST NT_r [] [Leaf (Token T_0 V_0 5),Leaf (Token T_WS (V_WS " ") 1),Leaf - (Token T_ID (V_ID "Matt") 4)]) - --Right (AST NT_r [] []) +import qualified EmptyP as E +import qualified Empty as E test_optional = Opt.glrParse Opt.isWS "a" @?= - (LR.ResultAccept $ AST Opt.NT_r [NT Opt.NT_a] [AST Opt.NT_a [T Opt.T_0] [Leaf (Token Opt.T_0 Opt.V_0 1)]]) + (LR.ResultAccept $ AST Opt.NT_r [NT Opt.NT_a] [AST Opt.NT_a [T Opt.T_1] [Leaf (Token Opt.T_1 Opt.V_1 1)]]) test_optional2 = - case Opt.glrParse Opt.isWS "a a b c d" of + case Opt.glrParse Opt.isWS "a a e b c d" of LR.ResultAccept ast -> Opt.ast2r ast @?= "accept" err -> error $ show err test_optional3 = - case Opt.glrParse Opt.isWS "a b b b c c d" of + case Opt.glrParse Opt.isWS "a e b b b c c d" of LR.ResultAccept ast -> Opt.ast2r ast @?= "accept" err -> error $ show err @@ -92,23 +45,33 @@ LR.ResultAccept ast -> Opt.ast2r ast @?= "reject" err -> error $ show err -testFastGLR = - Fast.glrParseFast (const False) "3" - @?= - G4.glrParse (const False) "3" +test_e v = + case v of + LR.ResultAccept ast -> E.ast2emp ast @?= () + err -> error $ show err +test_e_fail v = + case v of + LR.ResultAccept ast -> assertFailure $ show ast + err -> () @?= () + +test_empty = test_e (E.slrParse (E.tokenize "a")) +test_empty2 = test_e (E.slrParse (E.tokenize "f")) +test_empty3 = test_e (E.slrParse (E.tokenize "ac")) +test_empty4 = test_e (E.slrParse (E.tokenize "fd")) +test_empty5 = test_e_fail (E.slrParse (E.tokenize "fc")) +test_empty6 = test_e_fail (E.slrParse (E.tokenize "ad")) main :: IO () main = defaultMainWithOpts - [ testCase "g4_basic_compilation_type_check" test_g4_basic_type_check - , testCase "hello_parse_type_check" hello_g4_test_type_check --- , testCase "regex_test" regex_test - , testCase "test_g4" test_g4 - , testCase "test_hello" test_hello - , testCase "test_hello_allstar" test_hello_allstar - , testCase "test_optional" test_optional + [ testCase "test_optional" test_optional , testCase "test_optional2" test_optional2 , testCase "test_optional3" test_optional3 , testCase "test_optional4" test_optional4 - , testCase "testFastGLR" testFastGLR + , testCase "test_empty" test_empty + , testCase "test_empty2" test_empty2 + , testCase "test_empty3" test_empty3 + , testCase "test_empty4" test_empty4 + , testCase "test_empty5" test_empty5 + , testCase "test_empty6" test_empty6 ] mempty diff --git a/test/g4/Optional.hs b/test/g4/Optional.hs new file mode 100644 --- /dev/null +++ b/test/g4/Optional.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell #-} +module Optional where +import Language.ANTLR4 + +opt a b c d = (1, 'b', 2.0, [1,2,3]) + +foo :: () -> Maybe (Int, Char, Double, [Int]) -> String +foo a1 (Just (a,b,c,d)) = "accept" +foo a1 Nothing = "reject" + +$( return [] ) + +[g4| + grammar Optional; + r : a s? -> foo; + s : a? 'e' b* c+ d -> opt; + a : 'a'; + b : 'b'; + c : 'c'; + d : 'd'; + + ID : [a-zA-Z]+ -> String; + WS : [ \t\r\n]+ -> String; +|] + +isWS T_WS = True +isWS _ = False + diff --git a/test/g4/OptionalParser.hs b/test/g4/OptionalParser.hs new file mode 100644 --- /dev/null +++ b/test/g4/OptionalParser.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell, FlexibleContexts #-} +module OptionalParser where +import Language.ANTLR4 +import Optional + +$(g4_parsers optionalAST optionalGrammar) + diff --git a/test/ll/Main.hs b/test/ll/Main.hs --- a/test/ll/Main.hs +++ b/test/ll/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} module Main where -import Text.ANTLR.Example.Grammar +import Example.Grammar import Text.ANTLR.Grammar import Text.ANTLR.Parser import Text.ANTLR.Pretty @@ -29,7 +29,7 @@ uPIO = unsafePerformIO -grm :: Grammar () LL1NonTerminal LL1Terminal +grm :: Grammar () LL1NonTerminal LL1Terminal () grm = dragonBook428 termination = first grm [NT "E"] @?= first grm [NT "E"] @@ -69,7 +69,7 @@ , (T "id", fromList [Icon "id"]) ] -grm' :: Grammar () LL1NonTerminal LL1Terminal +grm' :: Grammar () LL1NonTerminal LL1Terminal () grm' = grm followAll :: IO () @@ -141,27 +141,29 @@ ] ]) -singleLang = (defaultGrammar "S" :: Grammar () String Char) +singleLang :: Grammar () String Char () +singleLang = (defaultGrammar "S" :: Grammar () String Char ()) { s0 = "S" , ns = fromList ["S", "X"] , ts = fromList ['a'] - , ps = [ Production "S" $ Prod Pass [NT "X", T 'a'] - , Production "X" $ Prod Pass [Eps] + , ps = [ production "S" $ Prod Pass [NT "X", T 'a'] + , production "X" $ Prod Pass [Eps] ] } testRemoveEpsilons = removeEpsilons singleLang @?= singleLang - { ps = [ Production "S" $ Prod Pass [NT "X", T 'a'] - , Production "S" $ Prod Pass [T 'a'] + { ps = [ production "S" $ Prod Pass [NT "X", T 'a'] + , production "S" $ Prod Pass [T 'a'] ] } +singleLang2 :: Grammar () String Char () singleLang2 = singleLang { ts = fromList ['a', 'b'] - , ps = [ Production "S" $ Prod Pass [NT "X", T 'a', NT "X", T 'b', NT "X"] - , Production "X" $ Prod Pass [Eps] + , ps = [ production "S" $ Prod Pass [NT "X", T 'a', NT "X", T 'b', NT "X"] + , production "X" $ Prod Pass [Eps] ] } @@ -169,42 +171,43 @@ (Set.fromList . ps . removeEpsilons) singleLang2 @?= fromList - [ Production "S" $ Prod Pass [ T 'a', T 'b' ] - , Production "S" $ Prod Pass [ T 'a', T 'b', NT "X"] - , Production "S" $ Prod Pass [ T 'a', NT "X", T 'b' ] - , Production "S" $ Prod Pass [ T 'a', NT "X", T 'b', NT "X"] - , Production "S" $ Prod Pass [NT "X", T 'a', T 'b' ] - , Production "S" $ Prod Pass [NT "X", T 'a', T 'b', NT "X"] - , Production "S" $ Prod Pass [NT "X", T 'a', NT "X", T 'b' ] - , Production "S" $ Prod Pass [NT "X", T 'a', NT "X", T 'b', NT "X"] + [ production "S" $ Prod Pass [ T 'a', T 'b' ] + , production "S" $ Prod Pass [ T 'a', T 'b', NT "X"] + , production "S" $ Prod Pass [ T 'a', NT "X", T 'b' ] + , production "S" $ Prod Pass [ T 'a', NT "X", T 'b', NT "X"] + , production "S" $ Prod Pass [NT "X", T 'a', T 'b' ] + , production "S" $ Prod Pass [NT "X", T 'a', T 'b', NT "X"] + , production "S" $ Prod Pass [NT "X", T 'a', NT "X", T 'b' ] + , production "S" $ Prod Pass [NT "X", T 'a', NT "X", T 'b', NT "X"] ] testRemoveEpsilons3 = removeEpsilons dragonBook428 - @?= (defaultGrammar "E" :: Grammar () String String) + @?= (defaultGrammar "E" :: Grammar () String String ()) { ns = fromList ["E", "E'", "T", "T'", "F"] , ts = fromList ["+", "*", "(", ")", "id"] , s0 = "E" - , ps = [ Production "E" $ Prod Pass [NT "T", NT "E'"] - , Production "E'" $ Prod Pass [T "+", NT "T", NT "E'"] - , Production "E'" $ Prod Pass [Eps] -- Implicitly epsilon - , Production "T" $ Prod Pass [NT "F", NT "T'"] - , Production "T'" $ Prod Pass [T "*", NT "F", NT "T'"] - , Production "T'" $ Prod Pass [Eps] - , Production "F" $ Prod Pass [T "(", NT "E", T ")"] - , Production "F" $ Prod Pass [T "id"] + , ps = [ production "E" $ Prod Pass [NT "T", NT "E'"] + , production "E'" $ Prod Pass [T "+", NT "T", NT "E'"] + , production "E'" $ Prod Pass [Eps] -- Implicitly epsilon + , production "T" $ Prod Pass [NT "F", NT "T'"] + , production "T'" $ Prod Pass [T "*", NT "F", NT "T'"] + , production "T'" $ Prod Pass [Eps] + , production "F" $ Prod Pass [T "(", NT "E", T ")"] + , production "F" $ Prod Pass [T "id"] ] } -leftGrammar0 = (defaultGrammar 'S' :: Grammar () Char String) +leftGrammar0 :: Grammar () Char Char () +leftGrammar0 = (defaultGrammar 'S' :: Grammar () Char Char ()) { ns = fromList "SABC" , ts = fromList "defg" , s0 = 'S' - , ps = [ Production 'S' $ Prod Pass [NT 'A'] - , Production 'A' $ Prod Pass [T 'd', T 'e', NT 'B'] - , Production 'A' $ Prod Pass [T 'd', T 'e', NT 'C'] - , Production 'B' $ Prod Pass [T 'f'] - , Production 'C' $ Prod Pass [T 'g'] + , ps = [ production 'S' $ Prod Pass [NT 'A'] + , production 'A' $ Prod Pass [T 'd', T 'e', NT 'B'] + , production 'A' $ Prod Pass [T 'd', T 'e', NT 'C'] + , production 'B' $ Prod Pass [T 'f'] + , production 'C' $ Prod Pass [T 'g'] ] } @@ -214,12 +217,12 @@ { ns = fromList $ map Prime [('S', 0), ('A', 0), ('B', 0), ('C', 0)] , ts = fromList "defg" , s0 = Prime ('S', 0) - , ps = [ Production (Prime ('S', 0)) $ Prod Pass [NT $ Prime ('A', 0)] - , Production (Prime ('A', 0)) $ Prod Pass [T 'd', T 'e', NT $ Prime ('A', 1)] - , Production (Prime ('A', 1)) $ Prod Pass [NT $ Prime ('B', 0)] - , Production (Prime ('A', 1)) $ Prod Pass [NT $ Prime ('C', 0)] - , Production (Prime ('B', 0)) $ Prod Pass [T 'f'] - , Production (Prime ('C', 0)) $ Prod Pass [T 'g'] + , ps = [ production (Prime ('S', 0)) $ Prod Pass [NT $ Prime ('A', 0)] + , production (Prime ('A', 0)) $ Prod Pass [T 'd', T 'e', NT $ Prime ('A', 1)] + , production (Prime ('A', 1)) $ Prod Pass [NT $ Prime ('B', 0)] + , production (Prime ('A', 1)) $ Prod Pass [NT $ Prime ('C', 0)] + , production (Prime ('B', 0)) $ Prod Pass [T 'f'] + , production (Prime ('C', 0)) $ Prod Pass [T 'g'] ] , _πs = fromList [] , _μs = fromList [] diff --git a/test/lr/EOF.hs b/test/lr/EOF.hs new file mode 100644 --- /dev/null +++ b/test/lr/EOF.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module EOF where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import Language.ANTLR4.Syntax (stripQuotesReadEscape) + +import EOFGrammar + +$(g4_parsers eOFAST eOFGrammar) + +test_eof = case glrParse (== T_WS) "anything that is not a comma" of + (ResultAccept ast) -> ast2words ast @?= ["anything", "that", "is", "not", "a", "comma"] + (ResultSet xs) -> assertFailure $ "Ambiguous parse: " ++ pshow' xs + rest -> assertFailure $ stripQuotesReadEscape $ "\"" ++ pshow' rest ++ "\"" + diff --git a/test/lr/EOFGrammar.hs b/test/lr/EOFGrammar.hs new file mode 100644 --- /dev/null +++ b/test/lr/EOFGrammar.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module EOFGrammar where +import Language.ANTLR4 + +data Plus = Plus String String | Minus String String + deriving (Eq, Show) + +[g4| + grammar EOF; + + words : word* ; + + word : WORD ; + + WORD : (~ [, ])* -> String; + + WS : [ \t\n\r\f\v]+ -> String; +|] + diff --git a/test/lr/GLRInc.hs b/test/lr/GLRInc.hs new file mode 100644 --- /dev/null +++ b/test/lr/GLRInc.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module GLRInc where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import Language.ANTLR4.Syntax (stripQuotesReadEscape) + +import GLRIncGrammar + +$(g4_parsers gLRIncAST gLRIncGrammar) + +test_GLRInc = case glrParse (== T_WS) "word - foo" of + (ResultAccept ast) -> ast2plus ast @?= Minus "word" "foo" + (ResultSet xs) -> assertFailure $ "Ambiguous parse: " ++ pshow' xs + rest -> assertFailure $ stripQuotesReadEscape $ "\"" ++ pshow' rest ++ "\"" + diff --git a/test/lr/GLRIncGrammar.hs b/test/lr/GLRIncGrammar.hs new file mode 100644 --- /dev/null +++ b/test/lr/GLRIncGrammar.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module GLRIncGrammar where +import Language.ANTLR4 + +data Plus = Plus String String | Minus String String + deriving (Eq, Show) + +[g4| + grammar GLRInc; + + plus : LowerID '+' Prim -> Plus + | Prim '-' LowerID -> Minus + ; + + LowerID : [a-z][a-zA-Z0-9_]* -> String; + Prim : 'word' -> String; + + WS : [ \t\n\r\f\v]+ -> String; +|] + diff --git a/test/lr/GLRPartial.hs b/test/lr/GLRPartial.hs new file mode 100644 --- /dev/null +++ b/test/lr/GLRPartial.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module GLRPartial where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR +import Language.ANTLR4.Syntax (stripQuotesReadEscape) + +import GLRPartialGrammar + +$(g4_parsers gLRPartialAST gLRPartialGrammar) + +test_GLRPartial = case glrParse (== T_WS) "word\nword\nword\nw0rd" of + (ResultAccept ast) -> assertFailure $ "Was not suppose to parse: " ++ pshow' (ast2words ast) + (ResultSet xs) -> assertFailure $ "Ambiguous parse: " ++ pshow' xs + (ErrorNoAction cfg asts _) -> return () -- Correct, should not have parsed + rest -> assertFailure $ stripQuotesReadEscape $ "\"" ++ pshow' rest ++ "\"" + diff --git a/test/lr/GLRPartialGrammar.hs b/test/lr/GLRPartialGrammar.hs new file mode 100644 --- /dev/null +++ b/test/lr/GLRPartialGrammar.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module GLRPartialGrammar where +import Language.ANTLR4 + +[g4| + grammar GLRPartial; + + words : word+ ; + + word : Prim ; + + LowerID : [a-z][a-zA-Z0-9_]* -> String; + Prim : 'word' -> String; + + WS : [ \t\n\r\f\v]+ -> String; +|] + diff --git a/test/lr/Main.hs b/test/lr/Main.hs --- a/test/lr/Main.hs +++ b/test/lr/Main.hs @@ -1,6 +1,6 @@ {-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeSynonymInstances #-} module Main where -import Text.ANTLR.Example.Grammar +import Example.Grammar import Text.ANTLR.Grammar import Text.ANTLR.LR import Text.ANTLR.Parser @@ -26,6 +26,12 @@ import Text.ANTLR.HUnit import Text.ANTLR.Pretty (pshow) import qualified Debug.Trace as D + +import qualified GLRInc +import qualified GLRPartial as GP + +import qualified EOF + uPIO = unsafePerformIO grm = dragonBook41 @@ -70,7 +76,7 @@ propClosureClosure items' = let items = S.map (\(I' is) -> is) items' in True ==> (c' . c') items == c' items -newtype Grammar' = G' (Grammar () String String) +newtype Grammar' = G' (Grammar () String String ()) deriving (Eq, Show) instance Arbitrary Grammar' where @@ -143,12 +149,12 @@ _I3 = fromList [ slrItem (ItemNT "T") [NT "F"] []] _I10 = fromList [ slrItem (ItemNT "T") [NT "F",T "*",NT "T"] []] -r1 = Reduce $ Production "E" $ Prod Pass [NT "E", T "+", NT "T"] -r2 = Reduce $ Production "E" $ Prod Pass [NT "T"] -r3 = Reduce $ Production "T" $ Prod Pass [NT "T", T "*", NT "F"] -r4 = Reduce $ Production "T" $ Prod Pass [NT "F"] -r5 = Reduce $ Production "F" $ Prod Pass [T "(", NT "E", T ")"] -r6 = Reduce $ Production "F" $ Prod Pass [T "id"] +r1 = Reduce $ production "E" $ Prod Pass [NT "E", T "+", NT "T"] +r2 = Reduce $ production "E" $ Prod Pass [NT "T"] +r3 = Reduce $ production "T" $ Prod Pass [NT "T", T "*", NT "F"] +r4 = Reduce $ production "T" $ Prod Pass [NT "F"] +r5 = Reduce $ production "F" $ Prod Pass [T "(", NT "E", T ")"] +r6 = Reduce $ production "F" $ Prod Pass [T "id"] -- Easier to debug when shown separately: testSLRTable = @@ -274,9 +280,9 @@ ] --r5 = Reduce ("F", Prod Pass [T "(", NT "E", T ")"]) -r1' = Reduce $ Production "S" $ Prod Pass [NT "C", NT "C"] -r2' = Reduce $ Production "C" $ Prod Pass [T "c", NT "C"] -r3' = Reduce $ Production "C" $ Prod Pass [T "d"] +r1' = Reduce $ production "S" $ Prod Pass [NT "C", NT "C"] +r2' = Reduce $ production "C" $ Prod Pass [T "c", NT "C"] +r3' = Reduce $ production "C" $ Prod Pass [T "d"] testLR1Items = lr1Items dragonBook455 @@ -378,5 +384,8 @@ , testCase "testLR1Table" testLR1Table , testCase "testPrettify" (testPrettify @?= ()) , testCase "testGLR" testGLRParse + , testCase "test_GLRInc" GLRInc.test_GLRInc + , testCase "test_GLRPartial" GP.test_GLRPartial + , testCase "eof_bug" EOF.test_eof ] mempty diff --git a/test/sexpression/Grammar.hs b/test/sexpression/Grammar.hs --- a/test/sexpression/Grammar.hs +++ b/test/sexpression/Grammar.hs @@ -62,11 +62,11 @@ | NUMBER -> Number ; - STRING : '"' ( ('\\' .) | ~ ["\\] )* '"' -> String; + STRING : ["] ( ('\\' .) | ~ ["\\] )* ["] -> String; WHITESPACE : [ \n\t\r]+ -> String; - NUMBER : ('+' | '-')? DIGIT+ ('.' DIGIT+)? -> Double; + NUMBER : [-+]? DIGIT+ ([\.] DIGIT+)? -> Double; SYMBOL : SYMBOL_START (SYMBOL_START | DIGIT)* -> String; diff --git a/test/sexpression/Parser.hs b/test/sexpression/Parser.hs --- a/test/sexpression/Parser.hs +++ b/test/sexpression/Parser.hs @@ -3,7 +3,8 @@ , FlexibleInstances, UndecidableInstances, TemplateHaskell #-} module Parser ( module Grammar - , glrParseFast + , glrParse, ast2sexpr +-- , glrParseFast ) where import Language.ANTLR4 import Grammar @@ -11,5 +12,7 @@ --import qualified GHC.Types as G import qualified Text.ANTLR.LR as LR -$(mkLRParser the_ast sexpressionGrammar) +$(g4_parsers sexpressionAST sexpressionGrammar) + +-- $(mkLRParser the_ast sexpressionGrammar) diff --git a/test/sexpression/sexpression.hs b/test/sexpression/sexpression.hs --- a/test/sexpression/sexpression.hs +++ b/test/sexpression/sexpression.hs @@ -1,6 +1,6 @@ module Main where import Language.ANTLR4 -import Grammar +import Parser import qualified Text.ANTLR.Set as S getAST (ResultAccept ast) = ast diff --git a/test/shared-hunit/Text/ANTLR/HUnit.hs b/test/shared-hunit/Text/ANTLR/HUnit.hs --- a/test/shared-hunit/Text/ANTLR/HUnit.hs +++ b/test/shared-hunit/Text/ANTLR/HUnit.hs @@ -5,7 +5,7 @@ import Data.List import Data.Typeable import Data.CallStack -import Test.HUnit.Lang hiding (assertEqual, (@?=)) +import Test.HUnit.Lang hiding (assertEqual, (@?=), (@=?)) import Text.ANTLR.Pretty import qualified Data.Text as T @@ -43,4 +43,6 @@ -> a -- ^ The expected value -> Assertion actual @?= expected = assertEqual "" expected actual + +(@=?) a b = (@?=) b a diff --git a/test/shared/Example/Grammar.hs b/test/shared/Example/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/shared/Example/Grammar.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE ExplicitForAll, DeriveAnyClass, DeriveGeneric, TypeFamilies + , DeriveDataTypeable #-} +module Example.Grammar where +import Text.ANTLR.Set (fromList, member, (\\), empty, Generic(..), Hashable(..)) +import Text.ANTLR.Grammar +import Text.ANTLR.Pretty +import Data.Data (toConstr, Data(..)) + +data NS0 = A | B | C deriving (Eq, Ord, Generic, Hashable, Bounded, Enum, Show, Data) +data TS0 = A_ | B_ | C_ deriving (Eq, Ord, Generic, Hashable, Bounded, Enum, Show, Data) +a = A_ +b = B_ +c = C_ + +-- TODO: boilerplate identity type classes for bounded enums +instance Ref NS0 where + type Sym NS0 = NS0 + getSymbol = id +instance Ref TS0 where + type Sym TS0 = TS0 + getSymbol = id +instance Prettify NS0 where prettify = rshow . toConstr +instance Prettify TS0 where prettify = rshow . toConstr +dG :: Grammar () NS0 TS0 () +dG = defaultGrammar C + +production :: nts -> (ProdRHS s nts ts) -> Production s nts ts dt +production lhs rhs = Production lhs rhs Nothing + +mattToolG :: Grammar () NS0 TS0 () +mattToolG = dG + { ns = fromList [A, B, C] + , ts = fromList [a, b, c] + , s0 = C + , ps = + [ production A $ Prod Pass [T a, T b] + , production A $ Prod Pass [T a] + , production B $ Prod Pass [NT A, T b] + , production B $ Prod Pass [T b] + , production C $ Prod Pass [NT A, NT B, NT C] + ] + } + +dG' :: Grammar () String String () +dG' = defaultGrammar "A" + +dragonBook428 :: Grammar () String String () +dragonBook428 = dG' + { ns = fromList ["E", "E'", "T", "T'", "F"] + , ts = fromList ["+", "*", "(", ")", "id"] + , s0 = "E" + , ps = [ production "E" $ Prod Pass [NT "T", NT "E'"] + , production "E'" $ Prod Pass [T "+", NT "T", NT "E'"] + , production "E'" $ Prod Pass [Eps] -- Implicitly epsilon + , production "T" $ Prod Pass [NT "F", NT "T'"] + , production "T'" $ Prod Pass [T "*", NT "F", NT "T'"] + , production "T'" $ Prod Pass [Eps] + , production "F" $ Prod Pass [T "(", NT "E", T ")"] + , production "F" $ Prod Pass [T "id"] + ] + } + +dragonBook41 :: Grammar () String String () +dragonBook41 = dG' + { ns = fromList ["E'", "E", "T", "F"] + , ts = fromList ["+", "*", "(", ")", "id"] + , s0 = "E" + , ps = [ production "E" $ Prod Pass [NT "E", T "+", NT "T"] + , production "E" $ Prod Pass [NT "T"] + , production "T" $ Prod Pass [NT "T", T "*", NT "F"] + , production "T" $ Prod Pass [NT "F"] + , production "F" $ Prod Pass [T "(", NT "E", T ")"] + , production "F" $ Prod Pass [T "id"] + ] + } + +dragonBook455 :: Grammar () String String () +dragonBook455 = dG' + { ns = fromList ["S", "C"] + , ts = fromList ["c", "d"] + , s0 = "S" + , ps = [ production "S" $ Prod Pass [NT "C", NT "C"] + , production "C" $ Prod Pass [T "c", NT "C"] + , production "C" $ Prod Pass [T "d"] + ] + } + +dumbGrammar :: Grammar () String String () +dumbGrammar = dG' + { ns = fromList ["S", "A", "B", "I", "D"] + , ts = fromList ["1","2","3","+","-","*"] + , s0 = "S" + , ps = [ production "S" $ Prod Pass [NT "A"] + , production "S" $ Prod Pass [NT "B"] + , production "S" $ Prod Pass [NT "D"] + , production "A" $ Prod Pass [NT "I", T "+", NT "I"] + , production "B" $ Prod Pass [NT "I", T "-", NT "I"] + , production "I" $ Prod Pass [T "1"] + , production "I" $ Prod Pass [T "2"] + , production "I" $ Prod Pass [T "3"] + , production "D" $ Prod Pass [NT "I", T "*", NT "I"] + ] + --, us = [(\_ -> True)] + } + diff --git a/test/shared/Grammar.hs b/test/shared/Grammar.hs deleted file mode 100644 --- a/test/shared/Grammar.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Grammar where -import Text.ANTLR.Grammar - -import System.IO.Unsafe (unsafePerformIO) -import Data.Monoid -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import Test.HUnit -import Test.QuickCheck (Property, quickCheck, (==>)) -import qualified Test.QuickCheck.Monadic as TQM - -main :: IO () -main = defaultMainWithOpts - [ - ] mempty - - diff --git a/test/shared/Language/ANTLR4/Example/G4.hs b/test/shared/Language/ANTLR4/Example/G4.hs deleted file mode 100644 --- a/test/shared/Language/ANTLR4/Example/G4.hs +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies - , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances - , FlexibleInstances, UndecidableInstances, FlexibleContexts, DeriveDataTypeable #-} -module Language.ANTLR4.Example.G4 where -import Language.ANTLR4 - -[g4| - grammar G4Basic; - exp : '1' - | '2' - | '3' - ; -|] - diff --git a/test/shared/Language/ANTLR4/Example/Hello.hs b/test/shared/Language/ANTLR4/Example/Hello.hs deleted file mode 100644 --- a/test/shared/Language/ANTLR4/Example/Hello.hs +++ /dev/null @@ -1,15 +0,0 @@ -{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies - , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances - , FlexibleInstances, UndecidableInstances, DeriveDataTypeable #-} -module Language.ANTLR4.Example.Hello where -import Language.ANTLR4 - -[g4| - // Hello World grammar - // https://github.com/antlr/grammars-v4/blob/master/antlr4/examples/Hello.g4 - grammar Hello; - r : 'hello' WS ID; - ID : [a-zA-Z]+ -> String; - WS : [ \t\r\n]+ -> String; -|] - diff --git a/test/shared/Language/ANTLR4/Example/Optionals.hs b/test/shared/Language/ANTLR4/Example/Optionals.hs deleted file mode 100644 --- a/test/shared/Language/ANTLR4/Example/Optionals.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE QuasiQuotes, DeriveAnyClass, DeriveGeneric, TypeFamilies - , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances - , FlexibleInstances, UndecidableInstances, FlexibleContexts #-} -module Language.ANTLR4.Example.Optionals where -import Language.ANTLR4 - -opt a b c d = (1, 'b', 2.0, [1,2,3]) - -foo :: () -> Maybe (Int, Char, Double, [Int]) -> String -foo a1 (Just (a,b,c,d)) = "accept" -foo a1 Nothing = "reject" - -[g4| - grammar Optional; - r : a s? -> foo; - s : a? b* c+ d -> opt; - a : 'a'; - b : 'b'; - c : 'c'; - d : 'd'; - - ID : [a-zA-Z]+ -> String; - WS : [ \t\r\n]+ -> String; -|] - -isWS T_WS = True -isWS _ = False - diff --git a/test/shared/Text/ANTLR/Allstar/Example/ATN.hs b/test/shared/Text/ANTLR/Allstar/Example/ATN.hs deleted file mode 100644 --- a/test/shared/Text/ANTLR/Allstar/Example/ATN.hs +++ /dev/null @@ -1,134 +0,0 @@ -module Text.ANTLR.Allstar.Example.ATN where - -import Text.ANTLR.Grammar -import Text.ANTLR.Allstar.ATN -import Text.ANTLR.Example.Grammar -import Text.ANTLR.Set (fromList, union) -import System.IO.Unsafe (unsafePerformIO) - --- This is the Grammar from page 6 of the --- 'Adaptive LL(*) Parsing: The Power of Dynamic Analysis' --- paper, namely the expected transitions based on Figures --- 5 through 8: -paperATNGrammar = (defaultGrammar "C" :: Grammar () String String) - { ns = fromList ["S", "A"] - , ts = fromList ["a", "b", "c", "d"] - , s0 = "C" - , ps = - [ Production "S" $ Prod Pass [NT "A", T "c"] - , Production "S" $ Prod Pass [NT "A", T "d"] - , Production "A" $ Prod Pass [T "a", NT "A"] - , Production "A" $ Prod Pass [T "b"] - ] - } - -s i = ("S", i) - --- Names as shown in paper: -pS = Start "S" -pS1 = Middle "S" 0 0 -p1 = Middle "S" 0 1 -p2 = Middle "S" 0 2 -pS2 = Middle "S" 1 0 -p3 = Middle "S" 1 1 -p4 = Middle "S" 1 2 -pS' = Accept "S" - -pA = Start "A" -pA1 = Middle "A" 2 0 -p5 = Middle "A" 2 1 -p6 = Middle "A" 2 2 -pA2 = Middle "A" 3 0 -p7 = Middle "A" 3 1 -pA' = Accept "A" - -exp_paperATN = ATN - { _Δ = fromList - -- Submachine for S: - [ (pS, Epsilon, pS1) - , (pS1, NTE "A", p1) - , (p1, TE "c", p2) - , (p2, Epsilon, pS') - , (pS, Epsilon, pS2) - , (pS2, NTE "A", p3) - , (p3, TE "d", p4) - , (p4, Epsilon, pS') - -- Submachine for A: - , (pA, Epsilon, pA1) - , (pA1, TE "a", p5) - , (p5, NTE "A", p6) - , (p6, Epsilon, pA') - , (pA, Epsilon, pA2) - , (pA2, TE "b", p7) - , (p7, Epsilon, pA') - ] - } - ---always _ = True ---never _ = False - -addPredicates = paperATNGrammar - { ps = - ps paperATNGrammar ++ - [ Production "A" $ Prod (Sem (Predicate "always" ())) [T "a"] - , Production "A" $ Prod (Sem (Predicate "never" ())) [] - , Production "A" $ Prod (Sem (Predicate "always2" ())) [NT "A", T "a"] - ] - } - -(pX,pY,pZ) = (Start "A", Start "A", Start "A") -pX1 = Middle "A" 4 2 -pX2 = Middle "A" 4 0 -pX3 = Middle "A" 4 1 -pX4 = Accept "A" - -pY1 = Middle "A" 5 1 -pY2 = Middle "A" 5 0 -pY3 = Accept "A" - -pZ1 = Middle "A" 6 3 -pZ2 = Middle "A" 6 0 -pZ3 = Middle "A" 6 1 -pZ4 = Middle "A" 6 2 -pZ5 = Accept "A" - -exp_addPredicates = ATN - { _Δ = union (_Δ exp_paperATN) $ fromList - [ (pX, Epsilon, pX1) - , (pX1, PE $ Predicate "always" (), pX2) - , (pX2, TE "a", pX3) - , (pX3, Epsilon, pX4) - - , (pY, Epsilon, pY1) - , (pY1, PE $ Predicate "never" (), pY2) - , (pY2, Epsilon, pY3) - - , (pZ, Epsilon, pZ1) - , (pZ1, PE $ Predicate "always2" (), pZ2) - , (pZ2, NTE "A", pZ3) - , (pZ3, TE "a", pZ4) - , (pZ4, Epsilon, pZ5) - ] - } - -fireZeMissiles state = seq - (unsafePerformIO $ putStrLn "Missiles fired.") - undefined - -addMutators = addPredicates - { ps = ps addPredicates ++ - [ Production "A" $ Prod (Action (Mutator "fireZeMissiles" ())) [] - , Production "S" $ Prod (Action (Mutator "identity" ())) [] - ] - } - -exp_addMutators = ATN - { _Δ = union (_Δ exp_addPredicates) $ fromList - [ (Start "A", Epsilon, Middle "A" 7 0) - , (Middle "A" 7 0, ME $ Mutator "fireZeMissiles" (), Accept "A") - , (Start "S", Epsilon, Middle "S" 8 0) - , (Middle "S" 8 0, ME $ Mutator "identity" (), Accept "S") - ] - } - - diff --git a/test/shared/Text/ANTLR/Example/Grammar.hs b/test/shared/Text/ANTLR/Example/Grammar.hs deleted file mode 100644 --- a/test/shared/Text/ANTLR/Example/Grammar.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# LANGUAGE ExplicitForAll, DeriveAnyClass, DeriveGeneric, TypeFamilies - , DeriveDataTypeable #-} -module Text.ANTLR.Example.Grammar where -import Text.ANTLR.Set (fromList, member, (\\), empty, Generic(..), Hashable(..)) -import Text.ANTLR.Grammar -import Text.ANTLR.Pretty -import Data.Data (toConstr, Data(..)) - -data NS0 = A | B | C deriving (Eq, Ord, Generic, Hashable, Bounded, Enum, Show, Data) -data TS0 = A_ | B_ | C_ deriving (Eq, Ord, Generic, Hashable, Bounded, Enum, Show, Data) -a = A_ -b = B_ -c = C_ - --- TODO: boilerplate identity type classes for bounded enums -instance Ref NS0 where - type Sym NS0 = NS0 - getSymbol = id -instance Ref TS0 where - type Sym TS0 = TS0 - getSymbol = id -instance Prettify NS0 where prettify = rshow . toConstr -instance Prettify TS0 where prettify = rshow . toConstr -dG :: Grammar () NS0 TS0 -dG = defaultGrammar C - -mattToolG :: Grammar () NS0 TS0 -mattToolG = dG - { ns = fromList [A, B, C] - , ts = fromList [a, b, c] - , s0 = C - , ps = - [ Production A $ Prod Pass [T a, T b] - , Production A $ Prod Pass [T a] - , Production B $ Prod Pass [NT A, T b] - , Production B $ Prod Pass [T b] - , Production C $ Prod Pass [NT A, NT B, NT C] - ] - } - -dG' :: Grammar () String String -dG' = defaultGrammar "A" - -dragonBook428 :: Grammar () String String -dragonBook428 = dG' - { ns = fromList ["E", "E'", "T", "T'", "F"] - , ts = fromList ["+", "*", "(", ")", "id"] - , s0 = "E" - , ps = [ Production "E" $ Prod Pass [NT "T", NT "E'"] - , Production "E'" $ Prod Pass [T "+", NT "T", NT "E'"] - , Production "E'" $ Prod Pass [Eps] -- Implicitly epsilon - , Production "T" $ Prod Pass [NT "F", NT "T'"] - , Production "T'" $ Prod Pass [T "*", NT "F", NT "T'"] - , Production "T'" $ Prod Pass [Eps] - , Production "F" $ Prod Pass [T "(", NT "E", T ")"] - , Production "F" $ Prod Pass [T "id"] - ] - } - -dragonBook41 :: Grammar () String String -dragonBook41 = dG' - { ns = fromList ["E'", "E", "T", "F"] - , ts = fromList ["+", "*", "(", ")", "id"] - , s0 = "E" - , ps = [ Production "E" $ Prod Pass [NT "E", T "+", NT "T"] - , Production "E" $ Prod Pass [NT "T"] - , Production "T" $ Prod Pass [NT "T", T "*", NT "F"] - , Production "T" $ Prod Pass [NT "F"] - , Production "F" $ Prod Pass [T "(", NT "E", T ")"] - , Production "F" $ Prod Pass [T "id"] - ] - } - -dragonBook455 :: Grammar () String String -dragonBook455 = dG' - { ns = fromList ["S", "C"] - , ts = fromList ["c", "d"] - , s0 = "S" - , ps = [ Production "S" $ Prod Pass [NT "C", NT "C"] - , Production "C" $ Prod Pass [T "c", NT "C"] - , Production "C" $ Prod Pass [T "d"] - ] - } - -dumbGrammar :: Grammar () String String -dumbGrammar = dG' - { ns = fromList ["S", "A", "B", "I", "D"] - , ts = fromList ["1","2","3","+","-","*"] - , s0 = "S" - , ps = [ Production "S" $ Prod Pass [NT "A"] - , Production "S" $ Prod Pass [NT "B"] - , Production "S" $ Prod Pass [NT "D"] - , Production "A" $ Prod Pass [NT "I", T "+", NT "I"] - , Production "B" $ Prod Pass [NT "I", T "-", NT "I"] - , Production "I" $ Prod Pass [T "1"] - , Production "I" $ Prod Pass [T "2"] - , Production "I" $ Prod Pass [T "3"] - , Production "D" $ Prod Pass [NT "I", T "*", NT "I"] - ] - --, us = [(\_ -> True)] - } - diff --git a/test/simple/Grammar.hs b/test/simple/Grammar.hs --- a/test/simple/Grammar.hs +++ b/test/simple/Grammar.hs @@ -36,6 +36,8 @@ decl : 'foo' -> Foo | 'bar' -> Bar ; + + UNICODE : '\u0008' -> String ; |] diff --git a/test/simple/Main.hs b/test/simple/Main.hs --- a/test/simple/Main.hs +++ b/test/simple/Main.hs @@ -19,7 +19,7 @@ import Grammar -foo = [ $(lift $ LR.lr1Table simpleGrammar) ] +--foo = [ $(lift $ LR.lr1Table simpleGrammar) ] --test_star = foo @?= [] test_star = () @?= () diff --git a/test/swift/Grammar.hs b/test/swift/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/swift/Grammar.hs @@ -0,0 +1,1138 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell #-} +module Grammar where +import Language.ANTLR4 + +-- This grammar is still in development / experimental. + +-- Original license below. +-- Modified by Karl Cronburg to work with v0.1.0.0 of antlr-haskell +-- +-- [The "BSD license"] +-- Copyright (c) 2014 Terence Parr +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- 1. Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- 2. Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- 3. The name of the author may not be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR +-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. +-- IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +-- NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +-- DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +-- THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +-- (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF +-- THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +-- +-- Converted from Apple's doc, http://tinyurl.com/n8rkoue, to ANTLR's +-- meta-language. + +[g4| + +grammar Swift; + +topLevel : statements? ; + +// Statements + +// GRAMMAR OF A STATEMENT + +statement + : declaration ';'? + | loopStatement ';'? + | branchStatement ';'? + | labeledStatement + | controlTransferStatement ';'? + | deferStatement ';' ? + | doStatement ':'? + | compilerControlStatement ';'? + | expression ';'? // Keep expression last to handle ambiguity + ; + +statements : statement+ ; + +// GRAMMAR OF A LOOP STATEMENT + +loopStatement : forInStatement + | whileStatement + | repeatWhileStatement + ; + +// GRAMMAR OF A FOR_IN STATEMENT + +forInStatement : 'for' 'case'? pattern 'in' expression whereClause? codeBlock ; + +// GRAMMAR OF A WHILE STATEMENT + +whileStatement : 'while' conditionList codeBlock ; + +// GRAMMAR OF A REPEAT WHILE STATEMENT + +repeatWhileStatement: 'repeat' codeBlock 'while' expression ; + +// GRAMMAR OF A BRANCH STATEMENT + +branchStatement : ifStatement | guardStatement | switchStatement ; + +// GRAMMAR OF AN IF STATEMENT + +ifStatement : 'if' conditionList codeBlock elseClause? ; +elseClause : 'else' codeBlock | 'else' ifStatement ; + +// GRAMMAR OF A GUARD STATEMENT + +guardStatement : 'guard' conditionList 'else' codeBlock ; + +// GRAMMAR OF A SWITCH STATEMENT + +switchStatement : 'switch' expression '{' switchCases? '}' ; +switchCases : switchCase+ ; +switchCase : caseLabel statements | defaultLabel statements | caseLabel ';' | defaultLabel ';' ; +caseLabel : 'case' caseItemList ':' ; +caseItemList : caseItem (',' caseItem)* ; +caseItem: pattern whereClause? ; +defaultLabel : 'default' ':' ; + +// GRAMMAR OF A LABELED STATEMENT + +labeledStatement : statementLabel labeledInner ; +statementLabel : labelName ':' ; +labelName : identifier ; +labeledInner : loopStatement | ifStatement | switchStatement | doStatement ; + +// GRAMMAR OF A CONTROL TRANSFER STATEMENT + +controlTransferStatement : breakStatement + | continueStatement + | fallthroughStatement + | returnStatement + | throwStatement + ; + +// GRAMMAR OF A BREAK STATEMENT + +breakStatement : 'break' labelName? ; + +// GRAMMAR OF A CONTINUE STATEMENT + +continueStatement : 'continue' labelName? ; + +// GRAMMAR OF A FALLTHROUGH STATEMENT + +fallthroughStatement : 'fallthrough' ; + +// GRAMMAR OF A RETURN STATEMENT + +returnStatement : 'return' expression? ; + +// GRAMMAR OF A THROW STATEMENT + +throwStatement : 'throw' expression ; + +// GRAMMAR OF A DEFER STATEMENT + +deferStatement: 'defer' codeBlock ; + +// GRAMMAR OF A DO STATEMENT + +doStatement: 'do' codeBlock catchClauses? ; +catchClauses: catchClause catchClauses? ; +catchClause: 'catch' pattern? whereClause? codeBlock ; + +conditionList : condition commaCondition* ; +commaCondition: ',' condition ; +condition: availabilityCondition | caseCondition | optionalBindingCondition | expression ; +caseCondition: 'case' pattern initializer ; +optionalBindingCondition: letORvar pattern initializer ; +letORvar : 'let' | 'var' ; + +whereClause: 'where' whereExpression ; +whereExpression: expression ; + +// GRAMMAR OF AN AVAILABILITY CONDITION + +availabilityCondition: '#available' '(' availabilityArguments ')' ; +availabilityArguments: availabilityArgument commaAvailArgs* ; +commaAvailArgs : ',' availabilityArguments ; +availabilityArgument: platformName platformVersion | '*' ; +platformName: 'iOS' | 'iOSApplicationExtension' | 'OSX' | 'OSXApplicationExtension' | 'watchOS' + | 'watchOSApplicationExtension' | 'tvOS' | 'tvOSApplicationExtension' ; +platformVersion: versionLiteral | DecimalLiteral | FloatingPointLiteral ; // TODO: Find a way to make this only versionLiteral + +// Generic Parameters and Arguments + +// GRAMMAR OF A GENERIC PARAMETER CLAUSE + +genericParameterClause : '<' genericParameterList '>' ; +genericParameterList : genericParameter commaGenParam* ; +commGenParam : ',' genericParameter ; +genericParameter : typeName | typeName ':' typeIdentifier | typeName ':' protocolCompositionType ; +genericWhereClause : 'where' requirementList ; +requirementList : requirement commaRequirement* ; +commaRequirement : ',' requirement ; +requirement : conformanceRequirement | sameTypeRequirement ; +conformanceRequirement : typeIdentifier ':' typeIdentifier | typeIdentifier ':' protocolCompositionType ; +sameTypeRequirement : typeIdentifier '==' sType ; + +// GRAMMAR OF A GENERIC ARGUMENT CLAUSE + +genericArgumentClause : '<' genericArgumentList '>' ; +genericArgumentList : genericArgument commaGenericArg* ; +commaGenericArg : ',' genericArgument ; +genericArgument : sType ; + +// Declarations + +// GRAMMAR OF A DECLARATION + +declaration + : importDeclaration ';'? + | constantDeclaration ';'? + | variableDeclaration ';'? + | typealiasDeclaration ';'? + | functionDeclaration ';'? + | enumDeclaration ';'? + | structDeclaration ';'? + | classDeclaration ';'? + | protocolDeclaration ';'? + | initializerDeclaration ';'? + | deinitializerDeclaration ';'? + | extensionDeclaration ';'? + | subscriptDeclaration ';'? + | operatorDeclaration ';'? + // compiler-control-statement not in Swift Language Reference + | compilerControlStatement ';'? + | precedenceGroupDeclaration ';'? + ; + +declarations : declaration+ ; +declarationModifiers : declarationModifier+ ; +declarationModifier : 'class' | 'convenience' | 'dynamic' | 'final' | 'infix' + | 'lazy' | 'optional' | 'override' | 'postfix' + | 'prefix' | 'required' | 'static' | 'unowned' | 'unowned' '(' 'safe' ')' + | 'unowned' '(' 'unsafe' ')' | 'weak' + | accessLevelModifier + | mutationModifier ; + +accessLevelModifier : 'private' | 'private' '(' 'set' ')' + | 'fileprivate' | 'fileprivate' '(' 'set' ')' + | 'internal' | 'internal' '(' 'set' ')' + | 'public' | 'public' '(' 'set' ')' + | 'open' | 'open' '(' 'set' ')' ; +accessLevelModifiers : accessLevelModifier+ ; + +mutationModifier: 'mutating' | 'nonmutating' ; + +// GRAMMAR OF A CODE BLOCK + +codeBlock : '{' statements? '}' ; + +// GRAMMAR OF AN IMPORT DECLARATION + +importDeclaration : attributes? 'import' importKind? importPath ; +// Swift Language Reference does not have let +importKind : 'typealias' | 'struct' | 'class' | 'enum' | 'protocol' | 'var' | 'func' | 'let' ; +importPath : importPathIdentifier | importPathIdentifier '.' importPath ; +importPathIdentifier : identifier | operator ; + +// GRAMMAR OF A CONSTANT DECLARATION + +constantDeclaration : attributes? declarationModifiers? 'let' patternInitializerList ; +patternInitializerList : patternInitializer commaPatInit* ; +commaPatInit : ',' patternInitializer ; +patternInitializer : pattern initializer? ; +initializer : '=' expression ; + +// GRAMMAR OF A VARIABLE DECLARATION + +variableDeclaration + : variableDeclarationHead variableName typeAnnotation getterSetterBlock + | variableDeclarationHead variableName typeAnnotation getterSetterKeywordBlock + | variableDeclarationHead variableName initializer willSetDidSetBlock + | variableDeclarationHead variableName typeAnnotation initializer? willSetDidSetBlock + // keep this below getter and setter rules for ambiguity reasons + | variableDeclarationHead variableName typeAnnotation codeBlock + | variableDeclarationHead patternInitializerList + ; + +variableDeclarationHead : attributes? declarationModifiers? 'var' ; +variableName : identifier ; +getterSetterBlock : '{' getterClause setterClause?'}' | '{' setterClause getterClause '}' ; +// declarationModifiers missing in the Swift Language Reference +getterClause : attributes? declarationModifiers? 'get' codeBlock ; +// declarationModifiers missing in the Swift Language Reference +setterClause : attributes? declarationModifiers? 'set' setterName? codeBlock ; +setterName : '(' identifier ')' ; +getterSetterKeywordBlock : '{' getterKeywordClause setterKeywordClause?'}' | '{' setterKeywordClause getterKeywordClause '}' ; +getterKeywordClause : attributes? 'get' ; +setterKeywordClause : attributes? 'set' ; +willSetDidSetBlock : '{' willSetClause didSetClause?'}' | '{' didSetClause willSetClause? '}' ; +willSetClause : attributes? 'willSet' setterName? codeBlock ; +didSetClause : attributes? 'didSet' setterName? codeBlock ; + +// GRAMMAR OF A TYPE ALIAS DECLARATION + +typealiasDeclaration : typealiasHead typealiasAssignment ; +typealiasHead : attributes? accessLevelModifier? 'typealias' typealiasName genericParameterClause? ; +typealiasName : identifier ; +typealiasAssignment : '=' sType ; + +// GRAMMAR OF A FUNCTION DECLARATION + +// HACK: functionBody? is intentionally not used to force the parser to try and match a functionBody first +// This can be removed once we figure out how to enforce that statements are either separated by semi colons or new line characters + +functionDeclaration : functionHead functionName genericParameterClause? functionSignature genericWhereClause? functionBody + | functionHead functionName genericParameterClause? functionSignature genericWhereClause? + ; + +functionHead : attributes? declarationModifiers? 'func' ; +functionName : identifier | operator ; +// rethrows is not marked as optional in the Swift Language Reference +functionSignature : parameterClause throwsORrethrows? functionResult? ; +throwsORrethrows : 'throws' | 'rethrows' ; +functionResult : '->' attributes? sType ; +functionBody : codeBlock ; +parameterClause : '(' ')' | '(' parameterList '...'? ')' ; +parameterList : parameter commaParameter* ; +commaParameter : ',' parameter ; +// Parameters don't have attributes in the Swift Language Reference +parameter + : attributes? externalParameterName? localParameterName typeAnnotation defaultArgumentClause? + | attributes? externalParameterName? localParameterName typeAnnotation '...' + ; +// Swift Language Reference does not have "keyword" or "_" +externalParameterName : identifier | keyword | '_'; +localParameterName : identifier | '_' ; +defaultArgumentClause : '=' expression ; + +// GRAMMAR OF AN ENUMERATION DECLARATION + +enumDeclaration : attributes? accessLevelModifier? enumDef ; +enumDef: unionStyleEnum | rawValueStyleEnum ; +unionStyleEnum : 'indirect'? 'enum' enumName genericParameterClause? typeInheritanceClause? genericWhereClause? '{' unionStyleEnumMembers?'}' ; +unionStyleEnumMembers : unionStyleEnumMember+ ; +unionStyleEnumMember : declaration | unionStyleEnumCaseClause ';'? | compilerControlStatement ; +unionStyleEnumCaseClause : attributes? 'indirect'? 'case' unionStyleEnumCaseList ; +unionStyleEnumCaseList : unionStyleEnumCase commanUnionStyleEnumCase* ; +commaUnionStyleEnumCase : ',' unionStyleEnumCase ; +unionStyleEnumCase : enumCaseName tupleType? ; +enumName : identifier ; +enumCaseName : identifier ; +// typeInheritanceClause is not optional in the Swift Language Reference +rawValueStyleEnum : 'enum' enumName genericParameterClause? typeInheritanceClause? genericWhereClause? '{' rawValueStyleEnumMembers?'}' ; +rawValueStyleEnumMembers : rawValueStyleEnumMember+ ; +rawValueStyleEnumMember : declaration | rawValueStyleEnumCaseClause | compilerControlStatement ; +rawValueStyleEnumCaseClause : attributes? 'case' rawValueStyleEnumCaseList ; +rawValueStyleEnumCaseList : rawValueStyleEnumCase commaRawValueStyleEnumCase* ; +commaRawValueStyleEnumCase : ',' rawValueStyleEnumCase ; +rawValueStyleEnumCase : enumCaseName rawValueAssignment? ; +rawValueAssignment : '=' literal ; + +// GRAMMAR OF A STRUCTURE DECLARATION + +structDeclaration : attributes? accessLevelModifier? 'struct' structName genericParameterClause? typeInheritanceClause? genericWhereClause? structBody ; +structName : identifier ; +structBody : '{' structMembers? '}' ; +structMembers: structMember+ ; +structMember: declaration | compilerControlStatement ; + +// GRAMMAR OF A CLASS DECLARATION + +classDeclaration : attributes? classDeclarationModifiers? 'class' className genericParameterClause? typeInheritanceClause? genericWhereClause? classBody ; +classDeclarationModifiers: accessLevelModifier 'final'? | 'final' accessLevelModifier? ; +className : identifier ; +classBody : '{' classMembers? '}' ; +classMembers: classMember+ ; +classMember: declaration | compilerControlStatement ; + +// GRAMMAR OF A PROTOCOL DECLARATION + +protocolDeclaration : attributes? accessLevelModifier? 'protocol' protocolName typeInheritanceClause? protocolBody ; +protocolName : identifier ; +protocolBody : '{' protocolMembers? '}' ; +protocolMembers: protocolMember+ ; +protocolMember: protocolMemberDeclaration | compilerControlStatement ; +protocolMemberDeclaration : protocolPropertyDeclaration ';'? + | protocolMethodDeclaration ';'? + | protocolInitializerDeclaration ';'? + | protocolSubscriptDeclaration ';'? + | protocolAssociatedTypeDeclaration ';'? + ; + +// GRAMMAR OF A PROTOCOL PROPERTY DECLARATION + +protocolPropertyDeclaration : variableDeclarationHead variableName typeAnnotation getterSetterKeywordBlock ; + +// GRAMMAR OF A PROTOCOL METHOD DECLARATION + +protocolMethodDeclaration : functionHead functionName genericParameterClause? functionSignature genericWhereClause? ; + +// GRAMMAR OF A PROTOCOL INITIALIZER DECLARATION + +protocolInitializerDeclaration : initializerHead genericParameterClause? parameterClause throwsORrethrows? genericWhereClause? ; + +// GRAMMAR OF A PROTOCOL SUBSCRIPT DECLARATION + +protocolSubscriptDeclaration : subscriptHead subscriptResult getterSetterKeywordBlock ; + +// GRAMMAR OF A PROTOCOL ASSOCIATED TYPE DECLARATION + +protocolAssociatedTypeDeclaration : attributes? accessLevelModifier? 'associatedtype' typealiasName typeInheritanceClause? typealiasAssignment?; + +// GRAMMAR OF AN INITIALIZER DECLARATION + +initializerDeclaration : initializerHead genericParameterClause? parameterClause throwsORrethrows? genericWhereClause? initializerBody ; +initializerHead : attributes? declarationModifiers? 'init' questORbang? ; +questORbang : '?' | '!' ; +initializerBody : codeBlock ; + +// GRAMMAR OF A DEINITIALIZER DECLARATION + +deinitializerDeclaration : attributes? 'deinit' codeBlock ; + +// GRAMMAR OF AN EXTENSION DECLARATION + +extensionDeclaration : attributes? accessLevelModifier? 'extension' typeIdentifier genericORtypeInherit? extensionBody ; +genericORtypeInherit : genericWhereClause | typeInheritanceClause ; +extensionBody : '{' extensionMembers?'}' ; +extensionMembers: extensionMember+ ; +extensionMember: declaration | compilerControlStatement ; + +// GRAMMAR OF A SUBSCRIPT DECLARATION + +subscriptDeclaration : subscriptHead subscriptResult getterSetterBlock + | subscriptHead subscriptResult getterSetterKeywordBlock + // most general form of subscript declaration; should be kept at the bottom. + | subscriptHead subscriptResult codeBlock + ; +subscriptHead : attributes? declarationModifiers? 'subscript' parameterClause ; +subscriptResult : '->' attributes? sType ; + +// GRAMMAR OF AN OPERATOR DECLARATION + +operatorDeclaration : prefixOperatorDeclaration | postfixOperatorDeclaration | infixOperatorDeclaration ; +prefixOperatorDeclaration : 'prefix' 'operator' operator ; +postfixOperatorDeclaration : 'postfix' 'operator' operator ; +infixOperatorDeclaration : 'infix' 'operator' operator infixOperatorGroup? ; +infixOperatorGroup: ':' precedenceGroupName ; + + +// GRAMMAR OF A PRECEDENCE GROUP DECLARATION + +precedenceGroupDeclaration: 'precedencegroup' precedenceGroupName '{' precedenceGroupAttributes? '}' ; + +precedenceGroupAttributes: precedenceGroupAttribute+; +precedenceGroupAttribute: precedenceGroupRelation | precedenceGroupAssignment | precedenceGroupAssociativity ; +precedenceGroupRelation: higherORlower ':' precedenceGroupNames; +higherORlower : 'higherThan' | 'lowerThan' ; +precedenceGroupAssignment: 'assignment' ':' booleanLiteral ; +precedenceGroupAssociativity: 'associativity' ':' lrn ; +lrn : 'left' | 'right' | 'none' ; + +precedenceGroupNames: precedenceGroupName commaPrecGN* ; +commaPrecGN : ',' precedenceGroupName ; +precedenceGroupName: identifier ; + + +// Patterns + + +// GRAMMAR OF A PATTERN + +pattern + : wildcardPattern typeAnnotation? + | identifierPattern typeAnnotation? + | valueBindingPattern + | tuplePattern typeAnnotation? + | enumCasePattern + | 'is' sType + | pattern 'as' sType + | expressionPattern + ; + +// GRAMMAR OF A WILDCARD PATTERN + +wildcardPattern : '_' ; + +// GRAMMAR OF AN IDENTIFIER PATTERN + +identifierPattern : identifier ; + +// GRAMMAR OF A VALUE_BINDING PATTERN + +valueBindingPattern : 'var' pattern | 'let' pattern ; + +// GRAMMAR OF A TUPLE PATTERN + +tuplePattern : '(' tuplePatternElementList? ')' ; +tuplePatternElementList : tuplePatternElement commaTupPatElem* ; +commaTypPatElem : ',' tuplePatternElement ; +tuplePatternElement : pattern | identifier ':' pattern ; + +// GRAMMAR OF AN ENUMERATION CASE PATTERN + +// Swift Language Reference has '.' as mandatory +enumCasePattern : typeIdentifier? '.'? enumCaseName tuplePattern? ; + +// GRAMMAR OF A TYPE CASTING PATTERN + +typeCastingPattern : isPattern | asPattern ; +isPattern : 'is' sType ; +asPattern : pattern 'as' sType ; + +// GRAMMAR OF AN EXPRESSION PATTERN + +expressionPattern : expression ; + +// Attributes + +// GRAMMAR OF AN ATTRIBUTE + +attribute : '@' attributeName attributeArgumentClause? ; +attributeName : identifier ; +attributeArgumentClause : '(' balancedTokens? ')' ; +attributes : attribute+ ; +// Swift Language Reference does not have ',' +balancedTokens : balancedToken+ ; +balancedToken + : '(' balancedTokens? ')' + | '[' balancedTokens? ']' + | '{' balancedTokens? '}' + // versionLiteral and availabilityArgument are not in the Swift Language Reference + | identifier | expression | contextSensitiveKeyword | literal | operator | versionLiteral | availabilityArgument + // | Any punctuation except ( , ')' , '[' , ']' , { , or } + // Punctuation is very ambiguous, interpreting punctuation as defined in www.thepunctuationguide.com + | ':' | ';' | ',' | '!' | '<' | '>' | '-' | '\'' | '/' | '...' | '"' + ; + +// Expressions + +// GRAMMAR OF AN EXPRESSION + +expression : tryOperator? prefixExpression binaryExpression* ; + +prefixExpression + : prefixOperator? postfixExpression ';'? + | inOutExpression + ; + +// /* +// expression +// : prefixOperator expression +// | inOutExpression +// | primaryExpression +// | expression binaryOperator expression +// | expression assignmentOperator expression +// | expression conditionalOperator expression +// | expression typeCastingOperator +// | expression postfixOperator +// | expression parenthesizedExpression trailingClosure? +// | expression '.' 'init' +// | expression '.' DecimalLiteral +// | expression '.' identifier genericArgumentClause? +// | expression '.' 'self' +// | expression '.' 'dynamicType' +// | expression '[' expressionList ']' +// | expression '!' +// | expression '?' +// ; +// */ + +// GRAMMAR OF A PREFIX EXPRESSION + +inOutExpression : '&' identifier ; + +// GRAMMAR OF A TRY EXPRESSION + +tryOperator : 'try' questORbang? ; + +// GRAMMAR OF A BINARY EXPRESSION + +binaryExpression + : binaryOperator prefixExpression + | assignmentOperator tryOperator? prefixExpression + | conditionalOperator tryOperator? prefixExpression + | typeCastingOperator + ; + +// GRAMMAR OF AN ASSIGNMENT OPERATOR + +assignmentOperator : '=' ; + +// GRAMMAR OF A CONDITIONAL OPERATOR + +conditionalOperator : '?' tryOperator? expression ':' ; + +// GRAMMAR OF A TYPE_CASTING OPERATOR + +typeCastingOperator + : 'is' sType + | 'as' '?' sType + | 'as' sType + | 'as' '!' sType + ; + +// GRAMMAR OF A PRIMARY EXPRESSION + +id_op_key_OR_cont : identifier | operator | keyword | contextSensitiveKeyword ; + +primaryExpression + : id_op_key_OR_cont genericArgumentClause? // operator, keyword, and contextSensitiveKeyword are not mentioned in the Swift Language Reference + | literalExpression + | selfExpression + | superclassExpression + | closureExpression + | parenthesizedExpression + | tupleExpression + | implicitMemberExpression +// | implicit_member_expression disallow as ambig with explicit member expr in postfix_expression + | wildcardExpression + | selectorExpression + | keyPathExpression + ; + +// GRAMMAR OF A LITERAL EXPRESSION + +literalExpression + : literal + | arrayLiteral + | dictionaryLiteral + | playgroundLiteral + | '#file' | '#line' | '#column' | '#function' + ; + +comma : ',' ; + +arrayLiteral : '[' arrayLiteralItems? ']' ; +arrayLiteralItems : arrayLiteralItem commaArrayLiteralItem* comma? ; +commaArrayLiteralItem : ',' arrayLiteralItem ; +arrayLiteralItem : expression ; + +dictionaryLiteral : '[' dictionaryLiteralItems ']' | '[' ':' ']' ; +dictionaryLiteralItems : dictionaryLiteralItem commaDictLitItem* comma? ; +commaDictLitItem : ',' dictionaryLiteralItem ; +dictionaryLiteralItem : expression ':' expression ; + +playgroundLiteral: '#colorLiteral' '(' 'red' ':' expression ',' 'green' ':' expression ',' 'blue' ':' expression ',' 'alpha' ':' expression ')' + | '#fileLiteral' '(' 'resourceName' ':' expression ')' + | '#imageLiteral' '(' 'resourceName' ':' expression ')' ; + +// GRAMMAR OF A SELF EXPRESSION + +selfExpression + : 'self' + | 'self' '.' identifier // self-method-expression + // Swift Language Reference uses expressionList + | 'self' '[' tupleElementList ']' // self-subscript-expression + | 'self' '.' 'init' // self-initializer-expression + ; + +// GRAMMAR OF A SUPERCLASS EXPRESSION + +superclassExpression + : superclassMethodExpression + | superclassSubscriptExpression + | superclassInitializerExpression + ; + +superclassMethodExpression : 'super' '.' identifier ; +// Swift Language Reference uses expressionList +superclassSubscriptExpression : 'super' '[' tupleElementList ']' ; +superclassInitializerExpression : 'super' '.' 'init' ; + +// GRAMMAR OF A CLOSURE EXPRESSION + +closureExpression : '{' closureSignature? statements? '}' ; + +closureSignature + : captureList? closureParameterClause 'throws'? functionResult? 'in' + | captureList 'in' + ; + +closureParameterClause: '(' ')' | '(' closureParameterList ')' | identifierList ; +closureParameterList: closureParameter commaClosureParameterList* ; +commaClosureParameterList : ',' closureParameterList ; +closureParameter: closureParameterName typeAnnotation? + | closureParameterName typeAnnotation '...' + ; +// Swift Language Reference does not have "_" +closureParameterName: identifier | '_'; + +captureList : '[' captureListItems ']' ; +captureListItems: captureListItem commaCaptureListItem* ; +commaCaptureListItem : ',' captureListItem ; +captureListItem: captureSpecifier? expression ; +captureSpecifier : 'weak' | 'unowned' | 'unowned(safe)' | 'unowned(unsafe)' ; + +// GRAMMAR OF A IMPLICIT MEMBER EXPRESSION + +implicitMemberExpression : '.' identifier ; + +// GRAMMAR OF A PARENTHESIZED EXPRESSION + +parenthesizedExpression : '(' expression ')' ; + +// GRAMMAR OF A TUPLE EXPRESSION + +tupleExpression: '(' tupleElementList? ')' ; +tupleElementList: tupleElement commaTupleElement* ; +commaTupleElement : ',' tupleElement ; +tupleElement: identifierColon? expression ; +identifierColon : identifier ':' ; + +// GRAMMAR OF A WILDCARD EXPRESSION + +wildcardExpression : '_' ; + +// GRAMMAR OF A SELECTOR EXPRESSION + +selectorExpression + : '#selector' '(' expression ')' + | '#selector' '(' getterORsetter expression ')' + ; +getterORsetter : 'getter:' | 'setter:' ; + +// GRAMMAR OF A KEY PATH EXPRESSION + +keyPathExpression + : '#keyPath' '(' expression ')' + | Backslash expression + ; + +Backslash : '[\\]' ; + +// GRAMMAR OF A POSTFIX EXPRESSION + +postfixExpression + : primaryExpression + | postfixExpression postfixOperator + // Function call with closure expression should always be above a lone parenthesized expression to reduce ambiguity + | postfixExpression functionCallArgumentClause? closureExpression + | postfixExpression functionCallArgumentClause + | postfixExpression '.' 'init' + | postfixExpression '.' 'init' '(' argumentNames ')' + // TODO: don't allow '_' here in DecimalLiteral: + | postfixExpression '.' DecimalLiteral + | postfixExpression '.' identifier genericArgumentClause? + | postfixExpression '.' identifier '(' argumentNames ')' + | postfixExpression '.' 'self' + | 'type' '(' 'of' ':' expression ')' + // Swift Language Reference uses expressionList + | postfixExpression '[' tupleElementList ']' + | postfixExpression '!' + | postfixExpression '?' + ; + +// GRAMMAR OF A FUNCTION CALL EXPRESSION +functionCallArgumentClause: '(' functionCallArgumentList? ')' ; +functionCallArgumentList: functionCallArgument commaFuncCallArg* ; +commaFuncCallArg : ',' functionCallArgument ; +// (expression | operator) is optional to handle selector expressions (see #425 for example) +functionCallArgument: functionCallIDColon expORop? + | functionCallIDColon? expORop? ; +expORop : expression | operator ; +functionCallIDColon : functionCallIdentifier ':' ; +// SwiftLanguageReference does not have keyword +functionCallIdentifier: identifier | keyword ; + +// GRAMMAR OF AN ARGUMENT NAME +argumentNames : argumentName+ ; +argumentName: idORunder ':' ; // Swift Language Reference has argumentName → identifier : +idORunder : identifier | '_' ; + +//trailing_closure : closure_expression ; + +//initializer_expression : postfix_expression '.' 'init' ; + +// /* +// explicitMemberExpression +// : postfixExpression '.' DecimalLiteral // TODO: don't allow '_' here in DecimalLiteral +// | postfixExpression '.' identifier genericArgumentClause? +// | postfixExpression '.' identifier '(' argumentNames ')' +// ; +// */ + +//postfix_self_expression : postfix_expression '.' 'self' ; + +// GRAMMAR OF A DYNAMIC TYPE EXPRESSION + +//dynamic_type_expression : postfix_expression '.' 'dynamicType' ; + +// GRAMMAR OF A SUBSCRIPT EXPRESSION + +//subscript_expression : postfix_expression '[' expression_list ']' ; + +// GRAMMAR OF A FORCED_VALUE EXPRESSION + +//forced_value_expression : postfix_expression '!' ; + +// GRAMMAR OF AN OPTIONAL_CHAINING EXPRESSION + +//optional_chaining_expression : postfix_expression '?' ; + +// GRAMMAR OF OPERATORS + +// split the operators out into the individual tokens as some of those tokens +// are also referenced individually. For example, type signatures use +// <...>. + +operatorHead: '=' | '<' | '>' | '!' | '*' | '&' | '==' | '?' | '-' | '&&' | '||' | '/' | '>=' | '->' | OperatorHead; +operatorCharacter: operatorHead | OperatorCharacter; + +operator: operatorHead operatorCharacter* + | '..' operatorCharacter* + | '...' + ; + +// WHITESPACE scariness: + +// /* http://tinyurl.com/oalzfus +// "If an operator has no whitespace on the left but is followed +// immediately by a dot (.), it is treated as a postfix unary +// operator. As an example, the ++ operator in a++.b is treated as a +// postfix unary operator (a++ . b rather than a ++ .b). For the +// purposes of these rules, the characters (, [, and { before an +// operator, the characters ), ], and } after an operator, and the +// characters ,, ;, and : are also considered whitespace. +// +// There is one caveat to the rules above. If the ! or ? operator has no +// whitespace on the left, it is treated as a postfix operator, +// regardless of whether it has whitespace on the right. To use the ? +// operator as syntactic sugar for the Optional type, it must not have +// whitespace on the left. To use it in the conditional (? :) operator, +// it must have whitespace around both sides." +// */ +// +// /** +// "If an operator has whitespace around both sides or around neither side, +// it is treated as a binary operator. As an example, the + operator in a+b +// and a + b is treated as a binary operator." +// */ +binaryOperator : operator ; + +// /** +// "If an operator has whitespace on the left side only, it is treated as a +// prefix unary operator. As an example, the ++ operator in a ++b is treated +// as a prefix unary operator." +// */ +prefixOperator : operator ; // only if space on left but not right + +// /** +// "If an operator has whitespace on the right side only, it is treated as a +// postfix unary operator. As an example, the ++ operator in a++ b is treated +// as a postfix unary operator." +// */ +postfixOperator : operator ; + +// Types + +// GRAMMAR OF A TYPE + +sType + : arrayType + | dictionaryType + | functionType + | typeIdentifier + | tupleType + | sType '?' // optional-type + | sType '!' // implicitly-unwrapped-optional-type + | protocolCompositionType + | sType '.' 'Type' | sType '.' 'Protocol' // metatype + | 'Any' | 'Self' + ; + +functionType: attributes? functionTypeArgumentClause throwsORrethrows? '->' sType ; +functionTypeArgumentClause: '(' ')' + | '(' functionTypeArgumentList '...'? ')' ; +functionTypeArgumentList: functionTypeArgument commaFunctionTypeArg* ; +commaFunctionTypeArg : ',' functionTypeArgument ; +functionTypeArgument: attributes? 'inout'? sType | argumentLabel typeAnnotation ; +argumentLabel: identifier ; + +arrayType: '[' sType ']' ; + +dictionaryType: '[' sType ':' sType ']' ; + +optionalType: sType '?' ; + +implicitlyUnwrappedOptionalType: sType '!' ; + +// GRAMMAR OF A TYPE ANNOTATION + +typeAnnotation : ':' attributes? 'inout'? sType ; + +// GRAMMAR OF A TYPE IDENTIFIER + +typeIdentifier + : typeName genericArgumentClause? + | typeName genericArgumentClause? '.' typeIdentifier + ; + +typeName : identifier ; + +// GRAMMAR OF A TUPLE TYPE + +tupleType : '(' tupleTypeElementList? ')' ; +tupleTypeElementList : tupleTypeElement commaTupleTypeElement* ; +commaTupleTypeElement : ',' tupleTypeElement ; +tupleTypeElement : elementName typeAnnotation | sType ; +elementName : identifier ; + +// GRAMMAR OF A PROTOCOL COMPOSITION TYPE + +protocolCompositionType: protocolIdentifier '&' protocolCompositionContinuation ; +protocolCompositionContinuation: protocolIdentifier | protocolCompositionType ; +protocolIdentifier: typeIdentifier ; + +// GRAMMAR OF A METATYPE TYPE + +metatypeType : sType '.' 'Type' | sType '.' 'Protocol'; + +// GRAMMAR OF A TYPE INHERITANCE CLAUSE + +typeInheritanceClause : ':' classRequirement ',' typeInheritanceList + | ':' classRequirement + | ':' typeInheritanceList + ; +typeInheritanceList : typeIdentifier commaTypeID* ; +commaTypeID : ',' typeIdentifier ; +classRequirement: 'class' ; + +// GRAMMAR OF A COMPILER CONTROL STATEMENT + +compilerControlStatement: conditionalCompilationBlock | lineControlStatement ; + +// GRAMMAR OF A CONDITIONAL COMPILATION BLOCK + +conditionalCompilationBlock: ifDirectiveClause elseifDirectiveClauses? elseDirectiveClause? '#endif' ; +ifDirectiveClause: '#if' compilationCondition statements? ; +elseifDirectiveClauses: elseifDirectiveClause+ ; +elseifDirectiveClause: '#elseif' compilationCondition statements? ; +elseDirectiveClause: '#else' statements? ; + +compilationCondition + : platformCondition + | identifier + | booleanLiteral + | '(' compilationCondition ')' + | '!' compilationCondition + | compilationCondition andORor compilationCondition + ; + +andORor : '&&' | '||' ; + +platformCondition + : 'os' '(' operatingSystem ')' + | 'arch' '(' architecture ')' + | 'swift' '(' '>=' swiftVersion ')' + ; + +operatingSystem: 'OSX' | 'iOS' | 'watchOS' | 'tvOS' ; +architecture: 'i386' | 'x86_64' | 'arm' | 'arm64' ; +swiftVersion: FloatingPointLiteral ; + +lineControlStatement: '#sourceLocation' '(' 'file' ':' fileName ',' 'line' ':' lineNumber ')' + | '#sourceLocation' '(' ')' ; +lineNumber: integerLiteral ; +fileName: StringLiteral ; + +// ---------- Lexical Structure ----------- + +BooleanLiteral: 'true' | 'false' ; +NilLiteral: 'nil' ; + +// GRAMMAR OF AN IDENTIFIER + +identifier : Identifier | contextSensitiveKeyword | grammarString ; + +keyword : + // Keywords used in declarations + 'associatedtype' | 'class' | 'deinit' | 'enum' | 'extension' | 'fileprivate' | 'func' | 'import' | 'init' | 'inout' + | 'internal' | 'let' | 'open' | 'operator' | 'private' | 'protocol' | 'public' | 'static' | 'struct' | 'subscript' + | 'typealias' | 'var' + // Keywords used in statements + | 'break' | 'case' | 'continue' | 'default' | 'defer' | 'do' | 'else' | 'fallthrough' | 'for' | 'guard' | 'if' | 'in' + | 'repeat' | 'return' | 'switch' | 'where' | 'while' + // Keywords used in expressions and types + | 'as' | 'Any' | 'catch' | 'dynamicType' | 'is' | 'nil' | 'rethrows' | 'super' | 'self' | 'Self' | 'throw' + | 'throws' | 'try' + | BooleanLiteral + // Keywords used in patterns + | '_' + // Keywords that begin with a number sign (#) + | '#available' | '#colorLiteral' | '#column' | '#else' | '#elseif' | '#endif' | '#file' | 'fileLiteral' | '#function' + | '#if' | 'imageLiteral' | '#line' | '#selector' + ; + +contextSensitiveKeyword : + 'associativity' | 'convenience' | 'dynamic' | 'didSet' | 'final' | 'get' | 'infix' | 'indirect' | + 'lazy' | 'left' | 'mutating' | 'none' | 'nonmutating' | 'optional' | 'operator' | 'override' | 'postfix' | 'precedence' | + 'prefix' | 'Protocol' | 'required' | 'right' | 'set' | 'Type' | 'unowned' | 'weak' | 'willSet' | + 'iOS' | 'iOSApplicationExtension' | 'OSX' | 'OSXApplicationExtension­' | 'watchOS' | 'x86_64' | + 'arm' | 'arm64' | 'i386' | 'os' | 'arch' | 'safe' | 'tvOS' | 'file' | 'line' | 'default' | 'Self' | 'var' + ; + +grammarString: + 'red' | 'blue' | 'green' | 'alpha' | 'resourceName' | 'of' | 'type' ; + +OperatorHead + : '/' | '=' | '-' | '+' | '!' | '*' | '%' | '<' | '>' | '&' | '|' | '^' | '~' | '?' + | [\u00A1-\u00A7] + | [\u00A9\u00AB\u00AC\u00AE] + | [\u00B0-\u00B1\u00B6\u00BB\u00BF\u00D7\u00F7] + | [\u2016-\u2017\u2020-\u2027] + | [\u2030-\u203E] + | [\u2041-\u2053] + | [\u2055-\u205E] + | [\u2190-\u23FF] + | [\u2500-\u2775] + | [\u2794-\u2BFF] + | [\u2E00-\u2E7F] + | [\u3001-\u3003] + | [\u3008-\u3030] + ; + +OperatorCharacter + : OperatorHead + | [\u0300–\u036F] + | [\u1DC0–\u1DFF] + | [\u20D0–\u20FF] + | [\uFE00–\uFE0F] + | [\uFE20–\uFE2F] + //| [\uE0100–\uE01EF] ANTLR can't do >16bit char + ; + +DotOperatorHead + : '..' + ; + +Identifier : IdentifierHead IdentifierCharacters? + | '`' IdentifierHead IdentifierCharacters? '`' + | ImplicitParameterName + ; + +identifierList : idORunder comma_idORunder* ; +comma_idORunder : ',' idORunder ; + +fragment IdentifierHead : [a-zA-Z] | '_' + | '\u00A8' | '\u00AA' | '\u00AD' | '\u00AF' | [\u00B2-\u00B5] | [\u00B7-\u00BA] + | [\u00BC-\u00BE] | [\u00C0-\u00D6] | [\u00D8-\u00F6] | [\u00F8-\u00FF] + | [\u0100-\u02FF] | [\u0370-\u167F] | [\u1681-\u180D] | [\u180F-\u1DBF] + | [\u1E00-\u1FFF] + | [\u200B-\u200D] | [\u202A-\u202E] | [\u203F-\u2040] | '\u2054' | [\u2060-\u206F] + | [\u2070-\u20CF] | [\u2100-\u218F] | [\u2460-\u24FF] | [\u2776-\u2793] + | [\u2C00-\u2DFF] | [\u2E80-\u2FFF] + | [\u3004-\u3007] | [\u3021-\u302F] | [\u3031-\u303F] | [\u3040-\uD7FF] + | [\uF900-\uFD3D] | [\uFD40-\uFDCF] | [\uFDF0-\uFE1F] | [\uFE30-\uFE44] + | [\uFE47-\uFFFD] +// /* +// | U+10000–U+1FFFD | U+20000–U+2FFFD | U+30000–U+3FFFD | U+40000–U+4FFFD +// | U+50000–U+5FFFD | U+60000–U+6FFFD | U+70000–U+7FFFD | U+80000–U+8FFFD +// | U+90000–U+9FFFD | U+A0000–U+AFFFD | U+B0000–U+BFFFD | U+C0000–U+CFFFD +// | U+D0000–U+DFFFD or U+E0000–U+EFFFD +// */ + ; + +fragment IdentifierCharacter : [0-9] + | [\u0300-\u036F] | [\u1DC0-\u1DFF] | [\u20D0-\u20FF] | [\uFE20-\uFE2F] + | IdentifierHead + ; + +fragment IdentifierCharacters : IdentifierCharacter+ ; + +ImplicitParameterName : '$' DecimalLiteral ; // TODO: don't allow '_' here + +// GRAMMAR OF A LITERAL + +booleanLiteral: BooleanLiteral ; +literal : numericLiteral | StringLiteral | BooleanLiteral | NilLiteral ; + +// GRAMMAR OF AN INTEGER LITERAL + +numericLiteral: '-'? integerLiteral | '-'? FloatingPointLiteral ; + +integerLiteral + : BinaryLiteral + | OctalLiteral + | DecimalLiteral + | HexadecimalLiteral + ; + +BinaryLiteral : '0b' BinaryDigit BinaryLiteralCharacters? ; +fragment BinaryDigit : [01] ; +fragment BinaryLiteralCharacter : BinaryDigit | '_' ; +fragment BinaryLiteralCharacters : BinaryLiteralCharacter+ ; + +OctalLiteral : '0o' OctalDigit OctalLiteralCharacters? ; +fragment OctalDigit : [0-7] ; +fragment OctalLiteralCharacter : OctalDigit | '_' ; +fragment OctalLiteralCharacters : OctalLiteralCharacter+ ; + +DecimalLiteral : DecimalDigit DecimalLiteralCharacters? ; +fragment DecimalDigit : [0-9] ; +fragment DecimalDigits : DecimalDigit+ ; +fragment DecimalLiteralCharacter : DecimalDigit | '_' ; +fragment DecimalLiteralCharacters : DecimalLiteralCharacter+ ; +HexadecimalLiteral : '0x' HexadecimalDigit HexadecimalLiteralCharacters? ; +fragment HexadecimalDigit : [0-9a-fA-F] ; +fragment HexadecimalLiteralCharacter : HexadecimalDigit | '_' ; +fragment HexadecimalLiteralCharacters : HexadecimalLiteralCharacter+ ; + +// GRAMMAR OF A FLOATING_POINT LITERAL + +FloatingPointLiteral + : DecimalLiteral DecimalFraction? DecimalExponent? + | HexadecimalLiteral HexadecimalFraction? HexadecimalExponent + ; +fragment DecimalFraction : '.' DecimalLiteral ; +fragment DecimalExponent : FloatingPointE Sign? DecimalLiteral ; +fragment HexadecimalFraction : '.' HexadecimalLiteral? ; +fragment HexadecimalExponent : FloatingPointP Sign? HexadecimalLiteral ; +fragment FloatingPointE : [eE] ; +fragment FloatingPointP : [pP] ; +fragment Sign : [+\-] ; + +versionLiteral: DecimalLiteral DecimalFraction DecimalFraction ; + +// GRAMMAR OF A STRING LITERAL + +StringLiteral : '"' QuotedText? '"' ; +fragment QuotedText : QuotedTextItem+ ; +fragment QuotedTextItem : EscapedCharacter | InterpolatedString +// | '\\(' expression ')' + | ~["\\\u000A\u000D] + ; +fragment InterpolatedString: '\\(' (QuotedTextItem | StringLiteral)* ')'; + +EscapedCharacter : '\\' [0\\tnr"'] + | '\\x' HexadecimalDigit HexadecimalDigit + | '\\u' '{' HexadecimalDigit HexadecimalDigit? HexadecimalDigit? HexadecimalDigit? HexadecimalDigit? HexadecimalDigit? HexadecimalDigit? HexadecimalDigit? '}' +; + +WS : [ \n\r\t\u000B\u000C\u0000] -> channel(HIDDEN) ; + +// /* Added optional newline character to prevent the whitespace lexer rule from matching newline +// * at the end of the comment. This affects how blank lines are counted around functions. +// */ +BlockComment : '/*' (BlockComment|.)*? '*/' '\n'? -> channel(HIDDEN) ; // nesting allow + +LineComment : '//' .*? '\n' -> channel(HIDDEN) ; + +|] + +--isWS T_WS = True +--isWS _ = False + diff --git a/test/swift/Parser.hs b/test/swift/Parser.hs new file mode 100644 --- /dev/null +++ b/test/swift/Parser.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, TemplateHaskell #-} +module Parser + ( module Grammar + , glrParse, ast2sexpr + ) where +import Language.ANTLR4 +import Grammar + +import qualified Text.ANTLR.LR as LR + +$(g4_parsers swiftAST swiftGrammar) +-- $(mkLRParser the_ast sexpressionGrammar) + diff --git a/test/swift/swift.hs b/test/swift/swift.hs new file mode 100644 --- /dev/null +++ b/test/swift/swift.hs @@ -0,0 +1,13 @@ +module Main where +import Language.ANTLR4 +import Parser +import qualified Text.ANTLR.Set as S + +getAST (ResultAccept ast) = ast +getAST _ = error "non-AST in ResultSet" + +main = + case glrParse isWS "var i = 0;" of + (ResultAccept ast) -> print $ ast2topLevel ast + (ResultSet xs) -> mapM_ (print . ast2topLevel . getAST) (S.toList xs) + diff --git a/test/unit/Main.hs b/test/unit/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Main where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR + +import PlusBug0 +$(g4_parsers plusBug0Grammar plusBug0AST) + +test_plusBug0 = case glrParse (== T_WS) "foo bar baz" of + (ResultAccept ast) -> ast2plus ast @?= Plus [ "foo", "bar", "baz" ] + _ -> assertFailure "Ambiguous parse" + +main :: IO () +main = defaultMainWithOpts + [ testCase "test_plusBug0" test_plusBug0 + ] mempty + diff --git a/test/unit/PlusBug0.hs b/test/unit/PlusBug0.hs new file mode 100644 --- /dev/null +++ b/test/unit/PlusBug0.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module PlusBug0 where +import Language.ANTLR4 + +data Plus = Plus [String] | NotPlus [String] + deriving (Eq, Show) + +[g4| + grammar PlusBug0; + + plus : LowerID+ -> Plus ; + + LowerID : [a-z][a-zA-Z0-9_]* -> String; + WS : [ \t\n\r\f\v]+ -> String; +|] + diff --git a/test/unit0/DupTerms.hs b/test/unit0/DupTerms.hs new file mode 100644 --- /dev/null +++ b/test/unit0/DupTerms.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module DupTerms where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR + +import DupTermsGrammar + +$(g4_parsers dupTermsAST dupTermsGrammar) + +test_dup_terms = case glrParse (== T_WS) "(" of + (ResultAccept ast) -> ast2justParen ast @?= 3 + rest -> assertFailure $ "Did not parse: " ++ pshow' rest + diff --git a/test/unit0/DupTermsGrammar.hs b/test/unit0/DupTermsGrammar.hs new file mode 100644 --- /dev/null +++ b/test/unit0/DupTermsGrammar.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module DupTermsGrammar where +import Language.ANTLR4 + +doesThisFire :: Int +doesThisFire = 3 + +orDoesThisFire :: String -> Int +orDoesThisFire _ = 4 + +$( return [] ) + +[g4| + grammar DupTerms; + + justParen : '(' -> doesThisFire ; + + LParen : '(' -> orDoesThisFire ; + + WS : [ \t\n\r\f\v]+ -> String; +|] + diff --git a/test/unit0/Main.hs b/test/unit0/Main.hs new file mode 100644 --- /dev/null +++ b/test/unit0/Main.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Main where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR + +import Star0 +import Star1 +import DupTerms + +main :: IO () +main = defaultMainWithOpts + [ testCase "test_star0" test_star0 + , testCase "test_star1" test_star1 + , testCase "duplicate_terminals" test_dup_terms + ] mempty + diff --git a/test/unit0/Star0.hs b/test/unit0/Star0.hs new file mode 100644 --- /dev/null +++ b/test/unit0/Star0.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Star0 where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR + +import Star0Grammar + +$(g4_parsers star0AST star0Grammar) + +test_star0 = case glrParse (== T_WS) "page page" of + (ResultAccept ast) -> ast2words ast @?= ["page", "page"] + rest -> assertFailure $ "Did not parse: " ++ pshow' rest + diff --git a/test/unit0/Star0Grammar.hs b/test/unit0/Star0Grammar.hs new file mode 100644 --- /dev/null +++ b/test/unit0/Star0Grammar.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Star0Grammar where +import Language.ANTLR4 + +[g4| + grammar Star0; + + words : page* -> ${\ps -> ps} ; + + page : Page ; + + Page : 'page' -> String ; + + WS : [ \t\n\r\f\v]+ -> String; +|] + diff --git a/test/unit0/Star1.hs b/test/unit0/Star1.hs new file mode 100644 --- /dev/null +++ b/test/unit0/Star1.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Star1 where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR +import Debug.Trace as D + +import Star1Grammar + +$(g4_parsers star1AST star1Grammar) + +test_star1 = D.trace (pshow' star1Grammar) $ + case glrParse (== T_WS) "me page you { byte, byte }" of + (ResultAccept ast) -> ast2words ast @?= Frst (Yep ("me", "page")) [] [Byte, Byte] + rest -> assertFailure $ "Did not parse: " ++ pshow' rest + diff --git a/test/unit0/Star1Grammar.hs b/test/unit0/Star1Grammar.hs new file mode 100644 --- /dev/null +++ b/test/unit0/Star1Grammar.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Star1Grammar where +import Language.ANTLR4 + +data MyMaybe x = Nope | Yep x + deriving (Eq, Ord, Show) + +data Mem = Byte + deriving (Eq, Ord, Show) + +data Words = + Frst (MyMaybe (String, String)) [String] [Mem] + | Snd + | Thrd (MyMaybe (String, String)) + deriving (Eq, Ord, Show) + +[g4| + grammar Star1; + + words : me 'you' page* '{' bytes '}' -> Frst + | me -> Thrd + | 'woops' -> Snd + ; + + bytes : 'byte' -> ${ [Byte] } + | bytes ',' 'byte' -> ${\bs -> Byte : bs} + ; + + me : me2? -> ${\m -> case m of Nothing -> Nope ; Just x -> Yep x}; + me2 : me3 ; + me3 : Me page ; + Me : 'me' -> String ; + + page : Page ; + Page : 'page' -> String ; + + WS : [ \t\n\r\f\v]+ -> String; +|] +