packages feed

antlr-haskell 0.1.0.0 → 0.1.0.1

raw patch · 76 files changed

+5370/−2616 lines, 76 filesdep ~QuickCheckdep ~call-stackdep ~hashable

Dependency ranges changed: QuickCheck, call-stack, hashable, template-haskell, th-lift

Files

README.md view
@@ -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.
antlr-haskell.cabal view
@@ -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 <https://github.com/cronburg/antlr-haskell#readme> and <https://www.cronburg.com/2018/antlr-haskell-project/>.-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.*
src/Language/ANTLR4.hs view
@@ -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(..))
src/Language/ANTLR4/Boot/Quote.hs view
@@ -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'
src/Language/ANTLR4/Boot/SplicedParser.hs view
@@ -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)
src/Language/ANTLR4/Boot/Syntax.hs view
@@ -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
src/Language/ANTLR4/G4.hs view
@@ -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
src/Language/ANTLR4/Parser.hs view
@@ -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-	;-|]--}
src/Language/ANTLR4/Syntax.hs view
@@ -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 [] = []
src/Text/ANTLR/Allstar.hs view
@@ -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
src/Text/ANTLR/Allstar/ATN.hs view
@@ -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
src/Text/ANTLR/Allstar/ParserGenerator.hs view
@@ -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 =
src/Text/ANTLR/Grammar.hs view
@@ -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 =
src/Text/ANTLR/LL1.hs view
@@ -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
src/Text/ANTLR/LR.hs view
@@ -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
src/Text/ANTLR/Lex/Tokenizer.hs view
@@ -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+
src/Text/ANTLR/Parser.hs view
@@ -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
src/Text/ANTLR/Pretty.hs view
@@ -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 }
test/allstar/AllStarTests.hs view
@@ -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)
+ test/allstar/ConvertDFA.hs view
@@ -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 ;+|]+
+ test/allstar/ConvertP.hs view
@@ -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)+
test/allstar/Main.hs view
@@ -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
+ test/atn/ATN.hs view
@@ -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")+    ]+  }++
test/atn/Main.hs view
@@ -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)
+ test/c/CParser.hs view
@@ -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+    ;+|]+-}+
+ test/c/Main.hs view
@@ -0,0 +1,7 @@+module Main where+import Language.ANTLR4+import CParser++main :: IO ()+main = print "done"+
test/chisel/Language/Chisel/Grammar.hs view
@@ -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
test/chisel/Language/Chisel/Parser.hs view
@@ -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+
test/chisel/Main.hs view
@@ -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 =
+ test/coreg4/G4.hs view
@@ -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'+      ;+|]+
+ test/coreg4/G4Fast.hs view
@@ -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+-}+
+ test/coreg4/G4Parser.hs view
@@ -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)+
+ test/coreg4/Hello.hs view
@@ -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;+|]+
+ test/coreg4/HelloParser.hs view
@@ -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)+
test/coreg4/Main.hs view
@@ -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
+ test/g4/DoubleSemi.hs view
@@ -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+
+ test/g4/DoubleSemiP.hs view
@@ -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)+
+ test/g4/Empty.hs view
@@ -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+
+ test/g4/EmptyP.hs view
@@ -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)+
− test/g4/G4.hs 
@@ -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)-
test/g4/Main.hs view
@@ -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
+ test/g4/Optional.hs view
@@ -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+
+ test/g4/OptionalParser.hs view
@@ -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)+
test/ll/Main.hs view
@@ -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 []
+ test/lr/EOF.hs view
@@ -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 ++ "\""+
+ test/lr/EOFGrammar.hs view
@@ -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;+|]+
+ test/lr/GLRInc.hs view
@@ -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 ++ "\""+
+ test/lr/GLRIncGrammar.hs view
@@ -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;+|]+
+ test/lr/GLRPartial.hs view
@@ -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 ++ "\""+
+ test/lr/GLRPartialGrammar.hs view
@@ -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;+|]+
test/lr/Main.hs view
@@ -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
test/sexpression/Grammar.hs view
@@ -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;
test/sexpression/Parser.hs view
@@ -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)
test/sexpression/sexpression.hs view
@@ -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
test/shared-hunit/Text/ANTLR/HUnit.hs view
@@ -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
+ test/shared/Example/Grammar.hs view
@@ -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)]+  }+
− test/shared/Grammar.hs 
@@ -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--
− test/shared/Language/ANTLR4/Example/G4.hs 
@@ -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'-      ;-|]-
− test/shared/Language/ANTLR4/Example/Hello.hs 
@@ -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;-|]-
− test/shared/Language/ANTLR4/Example/Optionals.hs 
@@ -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-
− test/shared/Text/ANTLR/Allstar/Example/ATN.hs 
@@ -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")-    ]-  }--
− test/shared/Text/ANTLR/Example/Grammar.hs 
@@ -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)]-  }-
test/simple/Grammar.hs view
@@ -36,6 +36,8 @@   decl  : 'foo' -> Foo         | 'bar' -> Bar         ;+  +  UNICODE : '\u0008' -> String ;  |]
test/simple/Main.hs view
@@ -19,7 +19,7 @@  import Grammar -foo = [ $(lift $ LR.lr1Table simpleGrammar) ]+--foo = [ $(lift $ LR.lr1Table simpleGrammar) ]  --test_star = foo @?= [] test_star = () @?= ()
+ test/swift/Grammar.hs view
@@ -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+
+ test/swift/Parser.hs view
@@ -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)+
+ test/swift/swift.hs view
@@ -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)+
+ test/unit/Main.hs view
@@ -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+
+ test/unit/PlusBug0.hs view
@@ -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;+|]+
+ test/unit0/DupTerms.hs view
@@ -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+
+ test/unit0/DupTermsGrammar.hs view
@@ -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;+|]+
+ test/unit0/Main.hs view
@@ -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+
+ test/unit0/Star0.hs view
@@ -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+
+ test/unit0/Star0Grammar.hs view
@@ -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;+|]+
+ test/unit0/Star1.hs view
@@ -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+
+ test/unit0/Star1Grammar.hs view
@@ -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;+|]+