packages feed

antlr-haskell (empty) → 0.1.0.0

raw patch · 59 files changed

+9600/−0 lines, 59 filesdep +HUnitdep +QuickCheckdep +antlr-haskellsetup-changed

Dependencies added: HUnit, QuickCheck, antlr-haskell, base, call-stack, containers, deepseq, hashable, haskell-src-meta, mtl, template-haskell, test-framework, test-framework-hunit, test-framework-quickcheck2, text, th-lift, transformers, unordered-containers

Files

+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Change Log++* April 14, 2018: Moved to hpack's package.yaml format instead of native cabal+  file.+
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017-2018, Karl Cronburg & Sam Lasser++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Karl Cronburg, Sam Lasser, nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,62 @@+# antlr-haskell+A Haskell implementation of ANTLR.++In implementing ANTLR we referenced the behavior of the original Java version+(ANTLR4):+[The definitive ANTLR4 Reference.](https://pragprog.com/book/tpantlr2/the-definitive-antlr-4-reference)+However we have taken much liberty in the design of this library compared to the+workflow of the original Java version. In particular in implementing ANTLR for+Haskell we have followed the following principles:++- Parsing backends should be interchangeable+  - GLR, LR, SLR, LL, ALL(\*)+- Code should be first class and declarative+  - The implementation of G4 is metacircular+  - Regular expressions are interpreted+- Implement algorithms from first principles+  - Set notation is used in implementing LL and LR algorithms.+  - Pure functional implementations of parsing algorithms can eventually support+    embedding of arbitrary (including IO) actions without breaking the predictive+    parsing abstraction.++## Build instructions++The library can be built with:++```+stack build # stack version 1.9.1.1+stack test antlr-haskell:simpl+```++Or with cabal-2.4.0.1 like:++```+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++```haskell+*Test.AllStarTests> parse ['a', 'b', 'c'] (NT 'S') atnEnv+(Just True, Node 'S' [Node 'A' [Leaf 'a', Node 'A' [Leaf 'b']], Leaf 'c'])+```++```haskell+*Test.AllStarTests> parse ['b', 'd'] (NT 'S') atnEnv+(Just True, Node 'S' [Node 'A' [Leaf 'b'], Leaf 'd'])+```++```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'])+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ antlr-haskell.cabal view
@@ -0,0 +1,457 @@+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+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+extra-source-files:+    README.md+    ChangeLog.md++source-repository head+    type: git+    location: https://github.com/cronburg/antlr-haskell++library+    exposed-modules:+        Text.ANTLR.Allstar+        Text.ANTLR.Grammar+        Text.ANTLR.Allstar.Stacks+        Text.ANTLR.Allstar.ATN+        Text.ANTLR.Allstar.ParserGenerator+        Text.ANTLR.Lex+        Text.ANTLR.Lex.NFA+        Text.ANTLR.Lex.DFA+        Text.ANTLR.Lex.Automata+        Text.ANTLR.Lex.Regex+        Text.ANTLR.Lex.Tokenizer+        Text.ANTLR.LL1+        Text.ANTLR.LR+        Text.ANTLR.Parser+        Text.ANTLR.Set+        Text.ANTLR.MultiMap+        Text.ANTLR.Pretty+        Language.ANTLR4+        Language.ANTLR4.Boot.Quote+        Language.ANTLR4.Boot.Syntax+        Language.ANTLR4.G4+        Language.ANTLR4.Syntax+        Language.ANTLR4.FileOpener+    hs-source-dirs: src+    other-modules:+        Data.Set.Monad+        Language.ANTLR4.Boot.SplicedParser+        Language.ANTLR4.Parser+        Text.ANTLR.Common+        Text.ANTLR.Language+        Paths_antlr_haskell+    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.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    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+        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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    other-modules:+        Grammar+        Language.ANTLR4.Example.G4+        Language.ANTLR4.Example.Hello+        Language.ANTLR4.Example.Optionals+        Text.ANTLR.Allstar.Example.ATN+        Text.ANTLR.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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    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+    build-depends:+        HUnit ==1.6.*,+        QuickCheck ==2.11.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    other-modules:+        Grammar+        Language.ANTLR4.Example.G4+        Language.ANTLR4.Example.Hello+        Language.ANTLR4.Example.Optionals+        Text.ANTLR.Allstar.Example.ATN+        Text.ANTLR.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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    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+        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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    other-modules:+        Grammar+        Language.ANTLR4.Example.G4+        Language.ANTLR4.Example.Hello+        Language.ANTLR4.Example.Optionals+        Text.ANTLR.Allstar.Example.ATN+        Text.ANTLR.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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    other-modules:+        Grammar+        Language.ANTLR4.Example.G4+        Language.ANTLR4.Example.Hello+        Language.ANTLR4.Example.Optionals+        Text.ANTLR.Allstar.Example.ATN+        Text.ANTLR.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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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+    other-modules:+        Grammar+        Language.ANTLR4.Example.G4+        Language.ANTLR4.Example.Hello+        Language.ANTLR4.Example.Optionals+        Text.ANTLR.Allstar.Example.ATN+        Text.ANTLR.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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        transformers ==0.5.*,+        unordered-containers ==0.2.*++test-suite 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+    build-depends:+        antlr-haskell -any,+        base >=4.11 && <5,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        transformers ==0.5.*,+        unordered-containers ==0.2.*++test-suite 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+    build-depends:+        HUnit ==1.6.*,+        QuickCheck ==2.11.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        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:+        Grammar+        Language.ANTLR4.Example.G4+        Language.ANTLR4.Example.Hello+        Language.ANTLR4.Example.Optionals+        Text.ANTLR.Allstar.Example.ATN+        Text.ANTLR.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.*,+        antlr-haskell -any,+        base >=4.11 && <5,+        call-stack ==0.1.*,+        containers ==0.6.*,+        deepseq ==1.4.*,+        hashable ==1.2.*,+        haskell-src-meta ==0.8.*,+        mtl ==2.2.*,+        template-haskell ==2.14.*,+        test-framework ==0.8.*,+        test-framework-hunit ==0.3.*,+        test-framework-quickcheck2 ==0.3.*,+        text ==1.2.*,+        th-lift >=0.7.11 && <0.8,+        transformers ==0.5.*,+        unordered-containers ==0.2.*
+ src/Data/Set/Monad.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE Safe  #-}+{-# LANGUAGE GADTs #-}++{-|++The @set-monad@ library exports the @Set@ abstract data type and+set-manipulating functions. These functions behave exactly as their namesakes+from the @Data.Set@ module of the @containers@ library. In addition, the+@set-monad@ library extends @Data.Set@ by providing @Functor@, @Applicative@,+@Alternative@, @Monad@, and @MonadPlus@ instances for sets.++In other words, you can use the @set-monad@ library as a drop-in replacement+for the @Data.Set@ module of the @containers@ library and, in addition, you+will also get the aforementioned instances which are not available in the+@containers@ package.++It is not possible to directly implement instances for the aforementioned+standard Haskell type classes for the @Set@ data type from the @containers@+library. This is because the key operations @map@ and @union@, are constrained+with @Ord@ as follows.++> map :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b+> union :: (Ord a) => Set a -> Set a -> Set a++The @set-monad@ library provides the type class instances by wrapping the+constrained @Set@ type into a data type that has unconstrained constructors+corresponding to monadic combinators. The data type constructors that+represent monadic combinators are evaluated with a constrained run function.+This elevates the need to use the constraints in the instance definitions+(this is what prevents a direct definition). The wrapping and unwrapping+happens internally in the library and does not affect its interface.++For details, see the rather compact definitions of the @run@ function and+type class instances. The left identity and associativity monad laws play a+crucial role in the definition of the @run@ function. The rest of the code+should be self explanatory.++The technique is not new. This library was inspired by [1]. To my knowledge,+the original, systematic presentation of the idea to represent monadic+combinators as data is given in [2]. There is also a Haskell library that+provides a generic infrastructure for the aforementioned wrapping and+unwrapping [3].++The @set-monad@ library is particularly useful for writing set-oriented code+using the do and/or monad comprehension notations. For example, the following+definitions now type check.++> s1 :: Set (Int,Int)+> s1 = do a <- fromList [1 .. 4]+>         b <- fromList [1 .. 4]+>         return (a,b)++> -- with -XMonadComprehensions+> s2 :: Set (Int,Int)+> s2 = [ (a,b) | (a,b) <- s1, even a, even b ]++> s3 :: Set Int+> s3 = fmap (+1) (fromList [1 .. 4])++As noted in [1], the implementation technique can be used for monadic+libraries and EDSLs with restricted types (compiled EDSLs often restrict the+types that they can handle). Haskell's standard monad type class can be used+for restricted monad instances. There is no need to resort to GHC extensions+that rebind the standard monadic combinators with the library or EDSL specific+ones.++@[@1@]@ CSDL Blog: The home of applied functional programming at KU. Monad+Reification in Haskell and the Sunroof Javascript compiler.+<http://www.ittc.ku.edu/csdlblog/?p=88>++@[@2@]@ Chuan-kai Lin. 2006. Programming monads operationally with Unimo. In+Proceedings of the eleventh ACM SIGPLAN International Conference on Functional+Programming (ICFP '06). ACM.++@[@3@]@ Heinrich Apfelmus. The operational package.+<http://hackage.haskell.org/package/operational>++-}+++module Data.Set.Monad (+  -- * Set type+  Set+  -- * Operators+  , (\\)++  -- * Query+  , null+  , size+  , member+  , notMember+  , isSubsetOf+  , isProperSubsetOf++  -- * Construction+  , empty+  , singleton+  , insert+  , delete++  -- * Combine+  , union+  , unions+  , difference+  , intersection++  -- * Filter+  , filter+  , partition+  , split+  , splitMember++  -- * Map+  , map+  , mapMonotonic++  -- * Folds+  , foldr+  , foldl+  -- ** Strict folds+  , foldr'+  , foldl'+  -- ** Legacy folds+  , fold++  -- * Min\/Max+  , findMin+  , findMax+  , deleteMin+  , deleteMax+  , deleteFindMin+  , deleteFindMax+  , maxView+  , minView++  -- * Conversion++  -- ** List+  , elems+  , toList+  , fromList++  -- ** Ordered list+  , toAscList+  , fromAscList+  , fromDistinctAscList++  -- * Debugging+  , showTree+  , showTreeWith+  , valid+  ) where++import Prelude hiding (null, filter, map, foldr, foldl)+import qualified Data.List            as L+import qualified Data.Set             as S+import qualified Data.Functor         as F+import qualified Control.Applicative  as A+import qualified Data.Foldable        as Foldable++import Data.Foldable (Foldable)+import Control.Arrow+import Control.Monad+import Control.DeepSeq++data Set a where+  Prim   :: (Ord a) => S.Set a -> Set a+  Return :: a -> Set a+  Bind   :: Set a -> (a -> Set b) -> Set b+  Zero   :: Set a+  Plus   :: Set a -> Set a -> Set a++run :: (Ord a) => Set a -> S.Set a+run (Prim s)                        = s+run (Return a)                      = S.singleton a+run (Zero)                          = S.empty+run (Plus ma mb)                    = run ma `S.union` run mb+run (Bind (Prim s) f)               = S.foldl' S.union S.empty (S.map (run . f) s)+run (Bind (Return a) f)             = run (f a)+run (Bind Zero _)                   = S.empty+run (Bind (Plus (Prim s) ma) f)     = run (Bind (Prim (s `S.union` run ma)) f)+run (Bind (Plus ma (Prim s)) f)     = run (Bind (Prim (run ma `S.union` s)) f)+run (Bind (Plus (Return a) ma) f)   = run (Plus (f a) (Bind ma f))+run (Bind (Plus ma (Return a)) f)   = run (Plus (Bind ma f) (f a))+run (Bind (Plus Zero ma) f)         = run (Bind ma f)+run (Bind (Plus ma Zero) f)         = run (Bind ma f)+run (Bind (Plus (Plus ma mb) mc) f) = run (Bind (Plus ma (Plus mb mc)) f)+run (Bind (Plus ma mb) f)           = run (Plus (Bind ma f) (Bind mb f))+run (Bind (Bind ma f) g)            = run (Bind ma (\a -> Bind (f a) g))++instance F.Functor Set where+  fmap = liftM++instance A.Applicative Set where+  pure  = return+  (<*>) = ap++instance A.Alternative Set where+  empty = Zero+  (<|>) = Plus++instance Monad Set where+  return = Return+  (>>=)  = Bind++instance MonadPlus Set where+  mzero = Zero+  mplus = Plus++instance Semigroup (Set a) where+  (<>) = Plus++instance (Ord a) => Monoid (Set a) where+  mempty  = empty+  mappend = union+  mconcat = unions++instance Foldable Set where+    foldr f def m =+        case m of+            Prim s -> S.foldr f def s+            Return a -> f a def+            Zero -> def+            Plus ma mb -> Foldable.foldr f (Foldable.foldr f def ma) mb+            Bind s g -> Foldable.foldr f' def s+                where f' x b = Foldable.foldr f b (g x)++instance (Ord a) => Eq (Set a) where+  s1 == s2 = run s1 == run s2++instance (Ord a) => Ord (Set a) where+  compare s1 s2 = compare (run s1) (run s2)++instance (Show a, Ord a) => Show (Set a) where+  show = show . run++instance (Read a, Ord a) => Read (Set a) where+  readsPrec i s = L.map (first Prim) (readsPrec i s)++instance (NFData a, Ord a) => NFData (Set a) where+  rnf = rnf . run++infixl 9 \\++(\\) :: (Ord a) => Set a -> Set a -> Set a+m1 \\ m2 = difference m1 m2++null :: (Ord a) => Set a -> Bool+null = S.null . run++size :: (Ord a) => Set a -> Int+size = S.size . run++member :: (Ord a) => a -> Set a -> Bool+member a s = S.member a (run s)++notMember :: (Ord a) => a -> Set a -> Bool+notMember a t = not (member a t)++isSubsetOf :: Ord a => Set a -> Set a -> Bool+isSubsetOf s1 s2 = S.isSubsetOf (run s1) (run s2)++isProperSubsetOf :: Ord a => Set a -> Set a -> Bool+isProperSubsetOf s1 s2 = S.isProperSubsetOf (run s1) (run s2)++empty :: (Ord a) => Set a+empty = Prim S.empty++singleton :: (Ord a) => a -> Set a+singleton a = Prim (S.singleton a)++insert :: (Ord a) => a -> Set a -> Set a+insert a s = Prim (S.insert a (run s))++delete :: (Ord a) => a -> Set a -> Set a+delete a s = Prim (S.delete a (run s))++union :: (Ord a) => Set a -> Set a -> Set a+union s1 s2 = Prim (run s1 `S.union` run s2)++unions :: (Ord a) => [Set a] -> Set a+unions ss = Prim (S.unions (L.map run ss))++difference :: (Ord a) => Set a -> Set a -> Set a+difference s1 s2 = Prim (S.difference (run s1) (run s2))++intersection :: (Ord a) => Set a -> Set a -> Set a+intersection s1 s2 = Prim (S.intersection (run s1) (run s2))++filter :: (Ord a) => (a -> Bool) -> Set a -> Set a+filter f s = Prim (S.filter f (run s))++partition :: (Ord a) => (a -> Bool) -> Set a -> (Set a,Set a)+partition f s = (Prim *** Prim) (S.partition f (run s))++split :: (Ord a) => a -> Set a -> (Set a,Set a)+split a s = (Prim *** Prim) (S.split a (run s))++splitMember :: (Ord a) => a -> Set a -> (Set a, Bool, Set a)+splitMember a s = (\(s1,b,s2) -> (Prim s1,b,Prim s2)) (S.splitMember a (run s))++map :: (Ord a,Ord b) => (a -> b) -> Set a -> Set b+map f s = Prim (S.map f (run s))++mapMonotonic :: (Ord a,Ord b) => (a -> b) -> Set a -> Set b+mapMonotonic f s = Prim (S.mapMonotonic f (run s))++foldr :: (Ord a) => (a -> b -> b) -> b -> Set a -> b+foldr f z s = S.foldr f z (run s)++foldl :: (Ord a) => (b -> a -> b) -> b -> Set a -> b+foldl f z s = S.foldl f z (run s)++foldr' :: (Ord a) => (a -> b -> b) -> b -> Set a -> b+foldr' f z s = S.foldr' f z (run s)++foldl' :: (Ord a) => (b -> a -> b) -> b -> Set a -> b+foldl' f z s = S.foldl' f z (run s)++fold :: (Ord a) => (a -> b -> b) -> b -> Set a -> b+fold = foldr++findMin :: (Ord a) => Set a -> a+findMin = S.findMin . run++findMax :: (Ord a) => Set a -> a+findMax = S.findMax . run++deleteMin :: (Ord a) => Set a -> Set a+deleteMin = Prim . S.deleteMin . run++deleteMax :: (Ord a) => Set a -> Set a+deleteMax = Prim . S.deleteMax . run++deleteFindMin :: (Ord a) => Set a -> (a,Set a)+deleteFindMin s = second Prim (S.deleteFindMin (run s))++deleteFindMax :: (Ord a) => Set a -> (a,Set a)+deleteFindMax s = second Prim (S.deleteFindMax (run s))++maxView :: (Ord a) => Set a -> Maybe (a,Set a)+maxView = fmap (second Prim) . S.maxView . run++minView :: (Ord a) => Set a -> Maybe (a,Set a)+minView = fmap (second Prim) . S.minView . run++elems :: (Ord a) => Set a -> [a]+elems = toList++toList :: (Ord a) => Set a -> [a]+toList = S.toList . run++fromList :: (Ord a) => [a] -> Set a+fromList as = Prim (S.fromList as)++toAscList :: (Ord a) => Set a -> [a]+toAscList = S.toAscList . run++fromAscList :: (Ord a) => [a] -> Set a+fromAscList = Prim . S.fromAscList++fromDistinctAscList :: (Ord a) => [a] -> Set a+fromDistinctAscList = Prim . S.fromDistinctAscList++showTree :: (Show a,Ord a) => Set a -> String+showTree = S.showTree . run++showTreeWith :: (Show a, Ord a) => Bool -> Bool -> Set a -> String+showTreeWith b1 b2 s = S.showTreeWith b1 b2 (run s)++valid :: (Ord a) => Set a -> Bool+valid = S.valid . run+
+ src/Language/ANTLR4.hs view
@@ -0,0 +1,57 @@+{-|+  Module      : Language.ANTLR4+  Description : Primary entrypoint for top-level antlr-haskell users+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX+-}+module Language.ANTLR4 (+  -- * Functions+  -- | Compile-time support for expanding LR-specific data types:+    mkLRParser+  -- | Other basic functions used in generated code:+  , (&&&)+  -- * Module exports+  -- | Most importantly for the Grammar type so that the quasiquoter can generate+  -- new grammar itself:+  , module Text.ANTLR.Grammar+  -- | Supporting data types and instances so that the spliced AST translator+  -- functions can talk about parse events, tokens, and EOF:+  , module Text.ANTLR.Parser+  -- | Regular expressions used during tokenization, as opposed to+  -- '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+  -- | For defining pretty-printable instances of quasiquoter-generated data types:+  , module Text.ANTLR.Pretty+  -- | Tokenizer:+  , module T+  -- * Type exports+  -- | Typeclass instances for quasiquoter-generated data types:+  , Hashable(..), Generic(..), Data(..), Lift(..)+  -- | Parser interface data types:+  , S.Set(..), T.Token(..), LRResult(..)+  )+where++import Text.ANTLR.Grammar+import Text.ANTLR.Parser++import Text.ANTLR.LR as LR+import Text.ANTLR.Lex.Tokenizer as T+import Text.ANTLR.Set as S++import Text.ANTLR.Set (Hashable(..), Generic(..))+import Text.ANTLR.Pretty+import Control.Arrow ( (&&&) )+import Text.ANTLR.Lex.Regex++import Language.ANTLR4.G4+import Language.ANTLR4.Boot.Quote (mkLRParser)++import Data.Data (Data(..))+import Language.Haskell.TH.Lift (Lift(..))+
+ src/Language/ANTLR4/Boot/Quote.hs view
@@ -0,0 +1,1031 @@+{-# LANGUAGE  QuasiQuotes, TemplateHaskell, ScopedTypeVariables, DataKinds,+              LambdaCase, FlexibleContexts #-}+{-|+  Module      : Language.ANTLR4.Boot.Quote+  Description : ANTLR4 boot-level quasiquoter+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX+-}+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+                            $(conT nameAST)+            glrParseFast filterF =+              LR.glrParseInc'+                $(name')+                (M.fromList' lr1Table)+                lr1Goto+                lr1S0+                (LR.tokenizerFirstSets convState $(name'))+                event2ast+                (T.tokenizeInc filterF $(varE nameDFAs) lexeme2value)+            |]+
+ src/Language/ANTLR4/Boot/SplicedParser.hs view
@@ -0,0 +1,566 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances #-}+{-|+  Module      : Language.ANTLR4.Boot.SplicedParser+  Description : Module as compiled by the core G4 quasiquoter+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX+-}+module Language.ANTLR4.Boot.SplicedParser where+import Text.ANTLR.Grammar+import Text.ANTLR.Parser+import qualified Text.ANTLR.LR as LR+--import Language.Chisel.Tokenizer+import Text.ANTLR.Lex.Tokenizer as T+import qualified Text.ANTLR.Set as S+import Text.ANTLR.Set (Hashable(..), Generic(..))+import Text.ANTLR.Pretty+import Control.Arrow ( (&&&) )+import Text.ANTLR.Lex.Regex (regex2dfa, Regex(..))+import Text.ANTLR.Lex (Token(..))+import Text.ANTLR.Allstar (parse, atnOf)+import Data.Maybe (fromJust)+import qualified Text.ANTLR.LL1+import qualified Text.ANTLR.Allstar as ALL++import Language.Haskell.TH.Quote (QuasiQuoter(..))+import qualified Language.Haskell.TH as TH+import Language.ANTLR4.Syntax+import qualified Language.ANTLR4.Boot.Syntax  as G4S++import Debug.Trace as D++-- | Construct a list from a single element+list a = [a]+cons = (:)+lexemeDirective r d = G4S.LRHS r (Just d)+lexemeNoDir     r   = G4S.LRHS r Nothing+lexDecl = G4S.Lex Nothing+lexFragment = G4S.Lex (Just G4S.Fragment)++literalRegex :: String -> G4S.Regex Char+literalRegex = G4S.Literal++prodDirective as d = G4S.PRHS as Nothing Nothing (Just d)+prodNoDir     as   = G4S.PRHS as Nothing Nothing Nothing++list2 a b = [a,b]+range a b = [a .. b]++gterm         = G4S.GTerm    G4S.NoAnnot+gnonTerm      = G4S.GNonTerm G4S.NoAnnot++maybeGTerm    = G4S.GTerm    (G4S.Regular '?')+maybeGNonTerm = G4S.GNonTerm (G4S.Regular '?')++starGTerm    = G4S.GTerm    (G4S.Regular '*')+starGNonTerm = G4S.GNonTerm (G4S.Regular '*')++plusGTerm    = G4S.GTerm    (G4S.Regular '+')+plusGNonTerm = G4S.GNonTerm (G4S.Regular '+')++regexAnyChar = G4S.Negation (G4S.CharSet [])++data G4NTSymbol+  = NT_decls |+    NT_decl1 |+    NT_prods |+    NT_lexemeRHS |+    NT_prodRHS |+    NT_regexes1 |+    NT_directive |+    NT_alphas |+    NT_alpha |+    NT_regexes |+    NT_regex |+    NT_regex1 |+    NT_charSet |+    NT_unionR |+    NT_charSet1+  deriving (Eq, Ord, Show, Hashable, Generic, Bounded, Enum)+data G4TSymbol+  = T_0 |+    T_1 |+    T_2 |+    T_3 |+    T_4 |+    T_5 |+    T_6 |+    T_7 |+    T_8 |+    T_9 |+    T_10 |+    T_11 |+    T_12 |+    T_13 |+    T_14 |+    T_15 |+    T_UpperID |+    T_LowerID |+    T_Literal |+    T_LineComment |+    T_EscapedChar |+    T_SetChar |+    T_WS+  deriving (Eq, Ord, Show, Hashable, Generic, Bounded, Enum)+g4Grammar' ::+  Prettify s_aLE0 => Grammar s_aLE0 G4NTSymbol G4TSymbol+g4Grammar'+  = (defaultGrammar NT_decls :: Grammar s_aLE0 G4NTSymbol G4TSymbol)+    {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+g4Grammar = Text.ANTLR.LL1.removeEpsilons g4Grammar'+type TokenName = G4TSymbol+data TokenValue+  = V_UpperID String |+    V_LowerID String |+    V_Literal String |+    V_LineComment String |+    V_EscapedChar Char |+    V_SetChar Char |+    V_WS String |+    V_0 |+    V_1 |+    V_2 |+    V_3 |+    V_4 |+    V_5 |+    V_6 |+    V_7 |+    V_8 |+    V_9 |+    V_10 |+    V_11 |+    V_12 |+    V_13 |+    V_14 |+    V_15+  deriving (Show, Ord, Eq, Generic, Hashable)+prettifyT_aLDY T_0 = pStr "';'"+prettifyT_aLDY T_1 = pStr "'grammar'"+prettifyT_aLDY T_2 = pStr "':'"+prettifyT_aLDY T_3 = pStr "'fragment'"+prettifyT_aLDY T_4 = pStr "'|'"+prettifyT_aLDY T_5 = pStr "'->'"+prettifyT_aLDY T_6 = pStr "'?'"+prettifyT_aLDY T_7 = pStr "'*'"+prettifyT_aLDY T_8 = pStr "'+'"+prettifyT_aLDY T_9 = pStr "'~'"+prettifyT_aLDY T_10 = pStr "'['"+prettifyT_aLDY T_11 = pStr "']'"+prettifyT_aLDY T_12 = pStr "'('"+prettifyT_aLDY T_13 = pStr "')'"+prettifyT_aLDY T_14 = pStr "'.'"+prettifyT_aLDY T_15 = pStr "'-'"+prettifyT_aLDY T_UpperID = pStr "UpperID"+prettifyT_aLDY T_LowerID = pStr "LowerID"+prettifyT_aLDY T_Literal = pStr "Literal"+prettifyT_aLDY T_LineComment = pStr "LineComment"+prettifyT_aLDY T_EscapedChar = pStr "EscapedChar"+prettifyT_aLDY T_SetChar = pStr "SetChar"+prettifyT_aLDY T_WS = pStr "WS"+prettifyValue_aLDZ V_0 = pStr "';'"+prettifyValue_aLDZ V_1 = pStr "'grammar'"+prettifyValue_aLDZ V_2 = pStr "':'"+prettifyValue_aLDZ V_3 = pStr "'fragment'"+prettifyValue_aLDZ V_4 = pStr "'|'"+prettifyValue_aLDZ V_5 = pStr "'->'"+prettifyValue_aLDZ V_6 = pStr "'?'"+prettifyValue_aLDZ V_7 = pStr "'*'"+prettifyValue_aLDZ V_8 = pStr "'+'"+prettifyValue_aLDZ V_9 = pStr "'~'"+prettifyValue_aLDZ V_10 = pStr "'['"+prettifyValue_aLDZ V_11 = pStr "']'"+prettifyValue_aLDZ V_12 = pStr "'('"+prettifyValue_aLDZ V_13 = pStr "')'"+prettifyValue_aLDZ V_14 = pStr "'.'"+prettifyValue_aLDZ V_15 = pStr "'-'"+prettifyValue_aLDZ (V_UpperID v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+prettifyValue_aLDZ (V_LowerID v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+prettifyValue_aLDZ (V_Literal v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+prettifyValue_aLDZ (V_LineComment v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+prettifyValue_aLDZ (V_EscapedChar v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+prettifyValue_aLDZ (V_SetChar v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+prettifyValue_aLDZ (V_WS v)+  = (((pChr '\'') >> (prettify v)) >> (pChr '\''))+instance Prettify G4NTSymbol where+  prettify = rshow+instance Prettify G4TSymbol where+  prettify = prettifyT_aLDY+instance Prettify TokenValue where+  prettify = prettifyValue_aLDZ+lookupToken ";" = ((Token T_0) V_0) 1+lookupToken "grammar" = ((Token T_1) V_1) 7+lookupToken ":" = ((Token T_2) V_2) 1+lookupToken "fragment" = ((Token T_3) V_3) 8+lookupToken "|" = ((Token T_4) V_4) 1+lookupToken "->" = ((Token T_5) V_5) 2+lookupToken "?" = ((Token T_6) V_6) 1+lookupToken "*" = ((Token T_7) V_7) 1+lookupToken "+" = ((Token T_8) V_8) 1+lookupToken "~" = ((Token T_9) V_9) 1+lookupToken "[" = ((Token T_10) V_10) 1+lookupToken "]" = ((Token T_11) V_11) 1+lookupToken "(" = ((Token T_12) V_12) 1+lookupToken ")" = ((Token T_13) V_13) 1+lookupToken "." = ((Token T_14) V_14) 1+lookupToken "-" = ((Token T_15) V_15) 1+lookupToken s = error ("Error: '" ++ (s ++ "' is not a token"))+lexeme2value l T_0 = V_0+lexeme2value l T_1 = V_1+lexeme2value l T_2 = V_2+lexeme2value l T_3 = V_3+lexeme2value l T_4 = V_4+lexeme2value l T_5 = V_5+lexeme2value l T_6 = V_6+lexeme2value l T_7 = V_7+lexeme2value l T_8 = V_8+lexeme2value l T_9 = V_9+lexeme2value l T_10 = V_10+lexeme2value l T_11 = V_11+lexeme2value l T_12 = V_12+lexeme2value l T_13 = V_13+lexeme2value l T_14 = V_14+lexeme2value l T_15 = V_15+lexeme2value l T_UpperID = V_UpperID l+lexeme2value l T_LowerID = V_LowerID l+lexeme2value l T_Literal+  = V_Literal+      ((stripQuotesReadEscape l :: String))+lexeme2value l T_LineComment = V_LineComment l+lexeme2value l T_EscapedChar+  = V_EscapedChar+      ((readEscape l :: Char))+lexeme2value l T_SetChar+  = V_SetChar ((head l :: Char))+lexeme2value l T_WS = V_WS l+g4Regexes+  = [(T_0, Text.ANTLR.Lex.Regex.Symbol ';'),+     (T_1, Text.ANTLR.Lex.Regex.Literal "grammar"),+     (T_2, Text.ANTLR.Lex.Regex.Symbol ':'),+     (T_3, Text.ANTLR.Lex.Regex.Literal "fragment"),+     (T_4, Text.ANTLR.Lex.Regex.Symbol '|'),+     (T_5, Text.ANTLR.Lex.Regex.Literal "->"),+     (T_6, Text.ANTLR.Lex.Regex.Symbol '?'),+     (T_7, Text.ANTLR.Lex.Regex.Symbol '*'),+     (T_8, Text.ANTLR.Lex.Regex.Symbol '+'),+     (T_9, Text.ANTLR.Lex.Regex.Symbol '~'),+     (T_10, Text.ANTLR.Lex.Regex.Symbol '['),+     (T_11, Text.ANTLR.Lex.Regex.Symbol ']'),+     (T_12, Text.ANTLR.Lex.Regex.Symbol '('),+     (T_13, Text.ANTLR.Lex.Regex.Symbol ')'),+     (T_14, Text.ANTLR.Lex.Regex.Symbol '.'),+     (T_15, Text.ANTLR.Lex.Regex.Symbol '-'),+     (T_UpperID,+      Text.ANTLR.Lex.Regex.Concat+        [Text.ANTLR.Lex.Regex.Class "ABCDEFGHIJKLMNOPQRSTUVWXYZ",+         Text.ANTLR.Lex.Regex.Kleene+           (Text.ANTLR.Lex.Regex.Class+              "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_")]),+     (T_LowerID,+      Text.ANTLR.Lex.Regex.Concat+        [Text.ANTLR.Lex.Regex.Class "abcdefghijklmnopqrstuvwxyz",+         Text.ANTLR.Lex.Regex.Kleene+           (Text.ANTLR.Lex.Regex.Class+              "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_")]),+     (T_Literal,+      Text.ANTLR.Lex.Regex.Concat+        [Text.ANTLR.Lex.Regex.Symbol '\'',+         Text.ANTLR.Lex.Regex.Concat+           [Text.ANTLR.Lex.Regex.PosClos+              (Union (Literal "\\'")+                     (NotClass "'")), --Text.ANTLR.Lex.Regex.NotClass "'"),+            Text.ANTLR.Lex.Regex.Symbol '\'']]),+     (T_LineComment,+      Text.ANTLR.Lex.Regex.Concat+        [Text.ANTLR.Lex.Regex.Literal "//",+         Text.ANTLR.Lex.Regex.Concat+           [Text.ANTLR.Lex.Regex.Kleene (Text.ANTLR.Lex.Regex.NotClass "\n"),+            Text.ANTLR.Lex.Regex.Symbol '\n']]),+     (T_EscapedChar,+      Text.ANTLR.Lex.Regex.Concat+        [Text.ANTLR.Lex.Regex.Symbol '\\',+         Text.ANTLR.Lex.Regex.Class "tnrfv"]),+     (T_SetChar, Text.ANTLR.Lex.Regex.NotClass "]"),+     (T_WS,+      Text.ANTLR.Lex.Regex.PosClos+        (Text.ANTLR.Lex.Regex.Class " \t\n\r\f\v"))]+g4DFAs = (map (fst &&& (regex2dfa . snd))) g4Regexes+type G4AST = AST G4NTSymbol G4Token+type G4Token = Token G4TSymbol TokenValue+instance Ref G4NTSymbol where+  type Sym G4NTSymbol = G4NTSymbol+  getSymbol = id+tokenize_aLE7 :: String -> [G4Token]+tokenize_aLE7 = (tokenize g4DFAs) lexeme2value+slrParse_aLE6 ::+  [G4Token]+  -> LR.LRResult (LR.CoreSLRState G4NTSymbol (StripEOF (Sym G4Token))) G4Token G4AST+slrParse_aLE6 = (LR.slrParse g4Grammar) event2ast+glrParse_aLE5 ::+  (TokenName -> Bool)+  -> [Char]+     -> LR.LR1Result (LR.CoreLR1State G4NTSymbol (StripEOF (Sym G4Token))) Char G4AST+glrParse_aLE5 filterF_aLE8+  = ((LR.glrParseInc g4Grammar) event2ast)+      (((tokenizeInc filterF_aLE8) g4DFAs) lexeme2value)+instance ALL.Token G4Token where+  type Label G4Token = StripEOF (Sym G4Token)+  type Literal G4Token = TokenValue+  getLabel+    = (Data.Maybe.fromJust . (stripEOF . getSymbol))+  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)))+      True+ast2EscapedChar (Leaf (Token _ (V_EscapedChar t) _)) = t+ast2LineComment (Leaf (Token _ (V_LineComment t) _)) = t+ast2Literal (Leaf (Token _ (V_Literal t) _)) = t+ast2LowerID (Leaf (Token _ (V_LowerID t) _)) = t+ast2SetChar (Leaf (Token _ (V_SetChar t) _)) = t+ast2UpperID (Leaf (Token _ (V_UpperID t) _)) = t+ast2WS (Leaf (Token _ (V_WS t) _)) = t+ast2alpha (AST NT_alpha [T T_Literal, T T_6] [v0_Literal, _])+  = maybeGTerm (ast2Literal v0_Literal)+ast2alpha (AST NT_alpha [T T_LowerID, T T_6] [v0_LowerID, _])+  = maybeGNonTerm (ast2LowerID v0_LowerID)+ast2alpha (AST NT_alpha [T T_UpperID, T T_6] [v0_UpperID, _])+  = maybeGNonTerm (ast2UpperID v0_UpperID)+ast2alpha (AST NT_alpha [T T_Literal, T T_7] [v0_Literal, _])+  = starGTerm (ast2Literal v0_Literal)+ast2alpha (AST NT_alpha [T T_LowerID, T T_7] [v0_LowerID, _])+  = starGNonTerm (ast2LowerID v0_LowerID)+ast2alpha (AST NT_alpha [T T_UpperID, T T_7] [v0_UpperID, _])+  = starGNonTerm (ast2UpperID v0_UpperID)+ast2alpha (AST NT_alpha [T T_Literal, T T_8] [v0_Literal, _])+  = plusGTerm (ast2Literal v0_Literal)+ast2alpha (AST NT_alpha [T T_LowerID, T T_8] [v0_LowerID, _])+  = plusGNonTerm (ast2LowerID v0_LowerID)+ast2alpha (AST NT_alpha [T T_UpperID, T T_8] [v0_UpperID, _])+  = plusGNonTerm (ast2UpperID v0_UpperID)+ast2alpha (AST NT_alpha [T T_Literal] [v0_Literal])+  = gterm (ast2Literal v0_Literal)+ast2alpha (AST NT_alpha [T T_LowerID] [v0_LowerID])+  = gnonTerm (ast2LowerID v0_LowerID)+ast2alpha (AST NT_alpha [T T_UpperID] [v0_UpperID])+  = gnonTerm (ast2UpperID v0_UpperID)+ast2alpha ast2 = error (show ast2)+ast2alphas (AST NT_alphas [NT NT_alpha] [v0_alpha])+  = list (ast2alpha v0_alpha)+ast2alphas+  (AST NT_alphas [NT NT_alpha, NT NT_alphas] [v0_alpha, v1_alphas])+  = (cons (ast2alpha v0_alpha)) (ast2alphas v1_alphas)+ast2alphas ast2 = error (show ast2)+ast2charSet (AST NT_charSet [NT NT_charSet1] [v0_charSet1])+  = id (ast2charSet1 v0_charSet1)+ast2charSet+  (AST NT_charSet+       [NT NT_charSet1, NT NT_charSet]+       [v0_charSet1, v1_charSet])+  = ((++) (ast2charSet1 v0_charSet1)) (ast2charSet v1_charSet)+ast2charSet ast2 = error (show ast2)+ast2charSet1+  (AST NT_charSet1+       [T T_SetChar, T T_15, T T_SetChar]+       [v0_SetChar, _, v2_SetChar])+  = (range (ast2SetChar v0_SetChar)) (ast2SetChar v2_SetChar)+ast2charSet1 (AST NT_charSet1 [T T_SetChar] [v0_SetChar])+  = list (ast2SetChar v0_SetChar)+ast2charSet1 (AST NT_charSet1 [T T_EscapedChar] [v0_EscapedChar])+  = list (ast2EscapedChar v0_EscapedChar)+ast2charSet1 ast2 = error (show ast2)+ast2decl1 (AST NT_decl1 [T T_1, T T_UpperID] [_, v1_UpperID])+  = G4S.Grammar (ast2UpperID v1_UpperID)+ast2decl1+  (AST NT_decl1+       [T T_LowerID, T T_2, NT NT_prods]+       [v0_LowerID, _, v2_prods])+  = (G4S.Prod (ast2LowerID v0_LowerID)) (ast2prods v2_prods)+ast2decl1+  (AST NT_decl1+       [T T_UpperID, T T_2, NT NT_lexemeRHS]+       [v0_UpperID, _, v2_lexemeRHS])+  = (lexDecl (ast2UpperID v0_UpperID)) (ast2lexemeRHS v2_lexemeRHS)+ast2decl1+  (AST NT_decl1+       [T T_3, T T_UpperID, T T_2, NT NT_lexemeRHS]+       [_, v1_UpperID, _, v3_lexemeRHS])+  = (lexFragment (ast2UpperID v1_UpperID))+      (ast2lexemeRHS v3_lexemeRHS)+ast2decl1 ast2 = error (show ast2)+ast2decls (AST NT_decls [NT NT_decl1, T T_0] [v0_decl1, _])+  = list (ast2decl1 v0_decl1)+ast2decls+  (AST NT_decls+       [NT NT_decl1, T T_0, NT NT_decls]+       [v0_decl1, _, v2_decls])+  = (cons (ast2decl1 v0_decl1)) (ast2decls v2_decls)+ast2decls ast2 = error (show ast2)+ast2directive (AST NT_directive [T T_UpperID] [v0_UpperID])+  = G4S.UpperD $ ast2UpperID v0_UpperID+ast2directive (AST NT_directive [T T_LowerID] [v0_LowerID])+  = G4S.LowerD $ ast2LowerID v0_LowerID+ast2directive (AST NT_directive [T T_UpperID, T T_14, NT NT_directive] [v0_UpperID, _, v1_dir])+  = G4S.UpperD $ (ast2UpperID v0_UpperID) ++ "." ++ ((\(G4S.UpperD s) -> s) (ast2directive v1_dir))+ast2directive ast2 = error (show ast2)+ast2lexemeRHS+  (AST NT_lexemeRHS+       [NT NT_regexes1, T T_5, NT NT_directive]+       [v0_regexes1, _, v2_directive])+  = (lexemeDirective (ast2regexes1 v0_regexes1))+      (ast2directive v2_directive)+ast2lexemeRHS (AST NT_lexemeRHS [NT NT_regexes1] [v0_regexes1])+  = lexemeNoDir (ast2regexes1 v0_regexes1)+ast2lexemeRHS ast2 = error (show ast2)+ast2prodRHS+  (AST NT_prodRHS+       [NT NT_alphas, T T_5, NT NT_directive]+       [v0_alphas, _, v2_directive])+  = (prodDirective (ast2alphas v0_alphas))+      (ast2directive v2_directive)+ast2prodRHS (AST NT_prodRHS [NT NT_alphas] [v0_alphas])+  = prodNoDir (ast2alphas v0_alphas)+ast2prodRHS ast2 = error (show ast2)+ast2prods (AST NT_prods [NT NT_prodRHS] [v0_prodRHS])+  = list (ast2prodRHS v0_prodRHS)+ast2prods+  (AST NT_prods+       [NT NT_prodRHS, T T_4, NT NT_prods]+       [v0_prodRHS, _, v2_prods])+  = (cons (ast2prodRHS v0_prodRHS)) (ast2prods v2_prods)+ast2prods ast2 = error (show ast2)+ast2regex (AST NT_regex [NT NT_regex1, T T_6] [v0_regex1, _])+  = G4S.Question (ast2regex1 v0_regex1)+ast2regex (AST NT_regex [NT NT_regex1, T T_7] [v0_regex1, _])+  = G4S.Kleene (ast2regex1 v0_regex1)+ast2regex (AST NT_regex [NT NT_regex1, T T_8] [v0_regex1, _])+  = G4S.PosClos (ast2regex1 v0_regex1)+ast2regex (AST NT_regex [T T_9, NT NT_regex1] [_, v1_regex1])+  = G4S.Negation (ast2regex1 v1_regex1)+ast2regex (AST NT_regex [NT NT_regex1] [v0_regex1])+  = id (ast2regex1 v0_regex1)+ast2regex ast2 = error (show ast2)+ast2regex1+  (AST NT_regex1 [T T_10, NT NT_charSet, T T_11] [_, v1_charSet, _])+  = G4S.CharSet (ast2charSet v1_charSet)+ast2regex1 (AST NT_regex1 [T T_Literal] [v0_Literal])+  = literalRegex (ast2Literal v0_Literal)+ast2regex1 (AST NT_regex1 [T T_UpperID] [v0_UpperID])+  = G4S.Named (ast2UpperID v0_UpperID)+ast2regex1+  (AST NT_regex1+       [T T_12, NT NT_regexes1, T T_13]+       [_, v1_regexes1, _])+  = ast2regexes1 v1_regexes1+ast2regex1 (AST NT_regex1 [NT NT_unionR] [v0_unionR])+  = G4S.Union (ast2unionR v0_unionR)+ast2regex1 (AST NT_regex1 [T T_14] [_]) = regexAnyChar+ast2regex1 ast2 = error (show ast2)+ast2regexes (AST NT_regexes [NT NT_regex] [v0_regex])+  = list (ast2regex v0_regex)+ast2regexes+  (AST NT_regexes+       [NT NT_regex, NT NT_regexes]+       [v0_regex, v1_regexes])+  = (cons (ast2regex v0_regex)) (ast2regexes v1_regexes)+ast2regexes ast2 = error (show ast2)+ast2regexes1 (AST NT_regexes1 [NT NT_regexes] [v0_regexes])+  = G4S.Concat (ast2regexes v0_regexes)+ast2regexes1 ast2 = error (show ast2)+ast2unionR+  (AST NT_unionR+       [NT NT_regex, T T_4, NT NT_regex]+       [v0_regex, _, v2_regex])+  = (list2 (ast2regex v0_regex)) (ast2regex v2_regex)+ast2unionR+  (AST NT_unionR+       [NT NT_regex, T T_4, NT NT_unionR]+       [v0_regex, _, v2_unionR])+  = (cons (ast2regex v0_regex)) (ast2unionR v2_unionR)+ast2unionR ast2 = error (show ast2)++-----------------------------------------------------------------------------+isWhitespace T_LineComment = True+isWhitespace T_WS = True+isWhitespace _ = False++parseANTLR = glrParse_aLE5 isWhitespace+
+ src/Language/ANTLR4/Boot/Syntax.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE DeriveLift, DeriveAnyClass, DeriveGeneric #-}+{-|+  Module      : Language.ANTLR4.Boot.Syntax+  Description : Both the boot and core syntax data types for G4+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX+-}+module Language.ANTLR4.Boot.Syntax+  ( G4(..), PRHS(..), ProdElem(..), GAnnot(..)+  , Directive(..)+  , LRHS(..), Regex(..), isGTerm, isGNonTerm+  , TermAnnot(..), isMaybeAnnot, isNoAnnot, annot+  ) where+import Text.ANTLR.Grammar ()+import Language.Haskell.TH.Lift (Lift(..))++import Language.Haskell.TH.Syntax (Exp)+import qualified Language.Haskell.TH.Syntax as S++import Text.ANTLR.Set ( Hashable(..), Generic(..) )++-- | .g4 style syntax representation+data G4 = -- | Grammar name declaration in g4+          Grammar { gName :: String -- ^ Name+                  }+        -- | One or more g4 productions+        | Prod { pName    :: String -- ^ Production's name+               , patterns :: [PRHS] -- ^ List of rules to match on+               }+        -- | A single, possibly annotated, g4 lexical rule+        | Lex  { annotation :: Maybe GAnnot -- ^ Lexical annotation (@fragment@)+               , lName      :: String       -- ^ Lexical rule name+               , pattern    :: LRHS         -- ^ The regex to match on+               }+  deriving (Show, Eq, Lift, Generic, Hashable)++instance Lift Exp++-- | The right-hand side of a G4 production rule.+data PRHS = PRHS+  { alphas      :: [ProdElem] -- ^ In-order list of elements defining this rule+  , pred        :: Maybe Exp  -- ^ Arbitrary boolean predicate to test whether or not this rule should fire+  , mutator     :: Maybe Exp  -- ^ Arbitrary mutator to run when this rule fires+  , pDirective  :: Maybe Directive -- ^ How to construct a Haskell type when this rules fires+  } deriving (Show, Eq, Lift, Generic)++-- | 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)++instance Hashable PRHS where+  hashWithSalt salt prhs = salt `hashWithSalt` alphas prhs++-- | Annotations on a term (nonterminal or terminal) for extending our G4+--   BNF-like syntax with regular expression modifiers.+data TermAnnot =+    Regular Char -- ^ Regular expression modifier (e.g. +, ?, *)+  | NoAnnot      -- ^ Term is not annotated with anything+  deriving (Show, Eq, Ord, Lift, Generic, Hashable)++-- | Get the annotation from a 'ProdElem'+annot :: ProdElem -> TermAnnot+annot (GTerm a _) = a+annot (GNonTerm a _) = a++-- | Is this 'TermAnnot' a maybe?+isMaybeAnnot :: TermAnnot -> Bool+isMaybeAnnot (Regular '?') = True+isMaybeAnnot _             = False++-- | Does this 'TermAnnot' have no annotation?+isNoAnnot :: TermAnnot -> Bool+isNoAnnot NoAnnot = True+isNoAnnot _       = False++-- | A single production element with any accompanying regex annotation+data ProdElem =+    GTerm     TermAnnot String -- ^ G4 terminal+  | GNonTerm  TermAnnot String -- ^ G4 nonterminal+  deriving (Show, Eq, Ord, Lift, Generic, Hashable)++-- | Is this a terminal G4 element?+isGTerm (GTerm _ _) = True+isGTerm _           = False++-- | Is this a nonterminal G4 element?+isGNonTerm (GNonTerm _ _) = True+isGNonTerm _              = False++-- | Allowable annotations on a lexical production rule+data    GAnnot   = Fragment -- ^ For now the only annotation is @fragment@.+  deriving (Show, Eq, Lift, Generic, Hashable)++-- | Right-hand side of a lexical G4 rule+data LRHS = LRHS+  { regex     :: Regex Char      -- ^ A regular expression over characters as tokens.+  , directive :: Maybe Directive -- ^ Optional directive: @Nothing@ is equivalent to @(Just "String")@.+  }+  deriving (Show, Eq, Lift, Generic, Hashable)++-- | G4 representation of a regex (G4 regex syntax, not regexs used by tokenizer)+data Regex s =+    Epsilon              -- ^ Consume no input+  | Literal    [s]       -- ^ Match on a literal string (sequence of characters)+  | Union      [Regex s] -- ^ Match on any+  | Concat     [Regex s] -- ^ Match in sequence+  | Kleene     (Regex s) -- ^ Match zero or more times+  | PosClos    (Regex s) -- ^ Match one or more times+  | Question   (Regex s) -- ^ Match zero or one time.+  | CharSet    [s]       -- ^ Match once on any of the characters+  | Negation   (Regex s) -- ^ Match anything that doesn't match this+  | Named      String    -- ^ A reference to some other regex (need to track an environment)+  deriving (Lift, Eq, Show, Generic, Hashable)+-- TODO: Lex regexs (e.g. complement sets, escape chars, ...)+-- TODO: Set s, and ranges of characters+
+ src/Language/ANTLR4/FileOpener.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, ScopedTypeVariables,+    OverloadedStrings #-}+{-|+  Module      : Language.ANTLR4.FileOpener+  Description : Quasiquoter for reading files by name at compile time+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++  Just do the following. It'll make sense:++  @+    foo = id+    file_contents = [open| test/file.foo |]+  @+-}+module Language.ANTLR4.FileOpener (+  -- * File opening quasiquoter+    open+  ) where+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Syntax (Exp(..), addDependentFile)+import Language.Haskell.TH.Quote (QuasiQuoter(..))++import Data.Text (strip, splitOn, pack, unpack)++-- | A quasiquoter for opening a file on disk, reading its contents, and running+--   a function by the same name as the file extension. e.g.:+--+-- @+--   foo = id+--   file_contents = [open| test/file.foo |]+-- @+--+-- @foo@ gets called on the contents of files with the extension @.foo@.+open :: QuasiQuoter+open = QuasiQuoter+  { quoteExp  = openExp+  , quotePat  = error "parse pattern"+  , quoteType = error "parse type"+  , quoteDec  = error "parse decl?"+  }++-- | Reads a file and runs a function with the name of the file extension,+--   returning the result for use by a quasiquoter.+openExp :: String -> TH.Q TH.Exp+openExp s = let+    fn  = unpack $ strip $ pack s+    ext = unpack $ last $ splitOn "." $ pack fn+  in do+    file_contents <- TH.runIO (readFile fn)+    addDependentFile fn+    [| $(return $ TH.VarE $ TH.mkName ext) file_contents |]+
+ src/Language/ANTLR4/G4.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances, DeriveDataTypeable+    , TemplateHaskell #-}+{-|+  Module      : Language.ANTLR4.G4+  Description : Core G4 quasiquoter for antlr-haskell+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++  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++import Control.Arrow ( (&&&) )+import Data.Char (isUpper)++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+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(..))++import Language.Haskell.TH.Quote (QuasiQuoter(..))+import qualified Language.Haskell.TH as TH+import Language.ANTLR4.Boot.Quote (antlr4)+import Language.ANTLR4.Syntax+import qualified Language.ANTLR4.Boot.Syntax  as G4S+import qualified Language.ANTLR4.Boot.Quote   as G4Q++import Debug.Trace as D++char :: String -> Char+char = head++append :: String -> String -> String+append = (++)++list a = [a]+cons = (:)+lexemeDirective r d = G4S.LRHS r (Just d)+lexemeNoDir     r   = G4S.LRHS r Nothing+lexDecl = G4S.Lex Nothing+lexFragment = G4S.Lex (Just G4S.Fragment)++literalRegex :: String -> G4S.Regex Char+literalRegex = G4S.Literal++prodDirective as d = G4S.PRHS as Nothing Nothing (Just d)+prodNoDir     as   = G4S.PRHS as Nothing Nothing Nothing++list2 a b = [a,b]+range a b = [a .. b]++gterm         = G4S.GTerm    G4S.NoAnnot+gnonTerm      = G4S.GNonTerm G4S.NoAnnot++maybeGTerm    = G4S.GTerm    (G4S.Regular '?')+maybeGNonTerm = G4S.GNonTerm (G4S.Regular '?')++starGTerm    = G4S.GTerm    (G4S.Regular '*')+starGNonTerm = G4S.GNonTerm (G4S.Regular '*')++plusGTerm    = G4S.GTerm    (G4S.Regular '+')+plusGNonTerm = G4S.GNonTerm (G4S.Regular '+')++regexAnyChar = G4S.Negation (G4S.CharSet [])++dQual [] = G4S.UpperD []+dQual xs = case last xs of+  [] -> G4S.UpperD $ concatWith "." xs+  (a:as)+    | isUpper a -> G4S.UpperD $ concatWith "." xs+    | otherwise -> G4S.LowerD $ concatWith "." xs++qDir l u = [l,u]++-- Force the above declarations (and their types) into scope:+$( return [] )++[antlr4|+  grammar G4;++  decls : decl1 ';'                 -> list+        | decl1 ';' decls           -> cons+        ;++  decl1 : 'grammar' UpperID                 -> G4S.Grammar+        | LowerID ':' prods                 -> G4S.Prod+        | UpperID ':' lexemeRHS             -> lexDecl+        | 'fragment' UpperID ':' lexemeRHS  -> lexFragment+        ;++  prods : prodRHS                   -> list+        | prodRHS '|' prods         -> cons+        ;++  lexemeRHS : regexes1 '->' directive  -> lexemeDirective+            | regexes1                 -> lexemeNoDir+            ;++  prodRHS : alphas '->' directive   -> prodDirective+          | alphas                  -> prodNoDir+          ;++  directive : qDirective          -> dQual+            | UpperID             -> G4S.UpperD+            | LowerID             -> G4S.LowerD+            | '${' HaskellExp '}' -> G4S.HaskellD+            ;++  qDirective  : UpperID '.' qDot -> qDir+              ;++  qDot  : UpperID+        | LowerID+        ;++  HaskellExp : ( ~ '}' )+ -> String;++  alphas : alpha                    -> list+         | alpha alphas             -> cons+         | '(' alphas ')'+         | '(' alphas ')' '?'+         | '(' alphas ')' '*'+         | '(' alphas ')' '+'+         ;++  alpha : Literal '?'               -> maybeGTerm+        | LowerID '?'               -> maybeGNonTerm+        | UpperID '?'               -> maybeGNonTerm+        | Literal '*'               -> starGTerm+        | LowerID '*'               -> starGNonTerm+        | UpperID '*'               -> starGNonTerm+        | Literal '+'               -> plusGTerm+        | LowerID '+'               -> plusGNonTerm+        | UpperID '+'               -> plusGNonTerm+        | Literal                   -> gterm+        | LowerID                   -> gnonTerm+        | UpperID                   -> gnonTerm+        ;++  // Regex Stuff:++  regexes1 : regexes                -> G4S.Concat+           ;++  regexes : regex                   -> list+          | regex regexes           -> cons+          ;++  regex   :     regex1 '?'          -> G4S.Question+          |     regex1 '*'          -> G4S.Kleene+          |     regex1 '+'          -> G4S.PosClos+          | '~' regex1              -> G4S.Negation+          |     regex1              -> id+          ;++  regex1  : '[' charSet ']'           -> G4S.CharSet+          | Literal                   -> literalRegex+          | UpperID                   -> G4S.Named+          | '(' regexes1 ')'+          | unionR                    -> G4S.Union+          | '.'                       -> regexAnyChar+          ;++  unionR  : regex '|' regex         -> list2+          | regex '|' unionR        -> cons+          ;++  charSet : charSet1                -> id+          | charSet1 charSet        -> append+          ;++  charSet1 : SetChar '-' SetChar    -> range+           | SetChar                -> list+           | EscapedChar            -> list+           ;++  UpperID : [A-Z][a-zA-Z0-9_]*      -> String;+  LowerID : [a-z][a-zA-Z0-9_]*      -> String;+  Literal     : '\'' (~ '\'')+ '\'' -> stripQuotesReadEscape;+  LineComment : '//' (~ '\n')* '\n' -> 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
@@ -0,0 +1,416 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances #-}+{-|+  Module      : Language.ANTLR4.G4+  Description : Version of G4 from public ANTLR repo of parsers+  Copyright   : (c) Karl Cronburg, 2018+  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+   ;++ebnfSuffix+   : QUESTION QUESTION?+   | STAR QUESTION?+   | PLUS QUESTION?+   ;++lexerAtom+   : characterRange+   | terminal+   | notSet+   | LEXER_CHAR_SET+   | DOT elementOptions?+   ;++atom+   : terminal+   | ruleref+   | notSet+   | DOT elementOptions?+   ;++// --------------------+// Inverted element set+notSet+   : NOT setElement+   | NOT blockSet+   ;++blockSet+   : LPAREN setElement (OR setElement)* RPAREN+   ;++setElement+   : TOKEN_REF elementOptions?+   | STRING_LITERAL elementOptions?+   | characterRange+   | LEXER_CHAR_SET+   ;++// -------------+// Grammar Block+block+   : LPAREN (optionsSpec? ruleAction* COLON)? altList RPAREN+   ;++// ----------------+// Parser rule ref+ruleref+   : RULE_REF argActionBlock? elementOptions?+   ;++// ---------------+// Character Range+characterRange+   : STRING_LITERAL RANGE STRING_LITERAL+   ;++terminal+   : TOKEN_REF elementOptions?+   | STRING_LITERAL elementOptions?+   ;++// Terminals may be adorned with certain options when+// reference in the grammar: TOK<,,,>+elementOptions+   : LT elementOption (COMMA elementOption)* GT+   ;++elementOption+   : identifier+   | identifier ASSIGN (identifier | STRING_LITERAL)+   ;++identifier+  : RULE_REF+  | TOKEN_REF+	;+|]+-}
+ src/Language/ANTLR4/Syntax.hs view
@@ -0,0 +1,57 @@+{-|+  Module      : Language.ANTLR4.Syntax+  Description : Helper syntax functions used by core G4 parser+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX+-}+module Language.ANTLR4.Syntax where+import Language.ANTLR4.Boot.Syntax++import qualified Debug.Trace as D++-- | Debugging support+trace s = D.trace ("Language.ANTLR4.Syntax] " ++ s)++-- | Parse an escape characters allowable in G4:+readEscape :: String -> Char+readEscape s = let+    eC ('\\':'n':xs)   = '\n'+    eC ('\\':'r':xs)   = '\r'+    eC ('\\':'t':xs)   = '\t'+    eC ('\\':'b':xs)   = '\b'+    eC ('\\':'f':xs)   = '\f'+    eC ('\\':'v':xs)   = '\v'+    eC ('\\':'"':xs)   = '\"'+    eC ('\\':'\'':xs)  = '\''+    eC ('\\':'\\':xs)  = '\\'+  in eC s++-- | Parse a literal String by stripping the quotes at the beginning and end of+--   the String, and replacing all escaped characters with the actual escape+--   character code.+stripQuotesReadEscape :: String -> String+stripQuotesReadEscape s = let++    eC [] = error "String ended in a single escape '\\': '" ++ s ++ "'"+    eC ('n':xs)   = "\n" ++ sQRE xs+    eC ('r':xs)   = "\r" ++ sQRE xs+    eC ('t':xs)   = "\t" ++ sQRE xs+    eC ('b':xs)   = "\b" ++ sQRE xs+    eC ('f':xs)   = "\f" ++ sQRE xs+    eC ('v':xs)   = "\v" ++ sQRE xs+    eC ('"':xs)   = "\"" ++ sQRE xs+    eC ('\'':xs)  = "\'" ++ sQRE xs+    eC ('\\':xs)  = "\\" ++ sQRE xs+    eC (x:xs)     = error $ "Invalid escape character '" ++ [x] ++ "' in string '" ++ s ++ "'"++    sQRE [] = []+    sQRE ('\\':xs) = eC xs+    sQRE (x:xs) = x : sQRE xs++  --in trace s $ (sQRE . init . tail) s+  in (sQRE . init . tail) s+  --read $ "\"" ++ (init . tail) s ++ "\"" :: String+
+ src/Text/ANTLR/Allstar.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, FlexibleContexts #-}+{-|+  Module      : Text.ANTLR.Allstar+  Description : Entrypoint for using the ALL(*) parsing algorithm+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++  This module contains the glue code for hooking Sam's+  'Text.ANTLR.Allstar.ParserGenerator' implementation into the rest of+  this package.+-}+module Text.ANTLR.Allstar+  ( parse, atnOf+  , ALL.Token(..)+  , ALL.GrammarSymbol(..)+  , ALL.ATNEnv+  ) where++import qualified Text.ANTLR.Allstar.ParserGenerator as ALL++import qualified Text.ANTLR.Parser as P+import qualified Text.ANTLR.Grammar as G+import qualified Text.ANTLR.Allstar.ATN as ATN++import qualified Data.Set as DS+import qualified Text.ANTLR.Set as S++-- | 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.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+atnOf g = DS.fromList (map convTrans (S.toList (ATN._Δ (ATN.atnOf g))))++-- | ATN Transition to AllStar version+convTrans (st0, e, st1) = (convState st0, convEdge e, convState st1)++-- | ATN State to AllStar version+convState (ATN.Start nt)        = ALL.Init nt+convState (ATN.Middle nt i0 i1) = ALL.Middle nt i0 i1+convState (ATN.Accept nt)       = ALL.Final nt++-- | ATN Edge to AllStar version+convEdge (ATN.NTE nt) = ALL.GS (ALL.NT nt)+convEdge (ATN.TE t)   = ALL.GS (ALL.T t)+convEdge (ATN.PE p)   = ALL.PRED True -- TODO+convEdge (ATN.ME m)   = ALL.PRED True -- TODO+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++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+
+ src/Text/ANTLR/Allstar/ATN.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE ScopedTypeVariables, DeriveAnyClass, DeriveGeneric+           , FlexibleContexts, UndecidableInstances, StandaloneDeriving+           , OverloadedStrings #-}+{-|+  Module      : Text.ANTLR.Allstar.ATN+  Description : Augmented recursive transition network algorithms+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Allstar.ATN where+-- Augmented recursive Transition Network+import Text.ANTLR.Grammar+--import Text.ANTLR.Allstar.GSS hiding (Edge, Node)+import Text.ANTLR.Allstar.Stacks+import Text.ANTLR.Set (Set(..), empty, fromList, toList, Hashable, Generic)+import Text.ANTLR.Pretty++-- | Graph-structured stack over ATN states.+type Gamma nt = Stacks (ATNState nt)++-- | An ATN defining some language we wish to parse+data ATN s nt t = ATN+  { _Δ :: Set (Transition s nt t) -- ^ The transition function+  } deriving (Eq, Ord, Show)++instance (Prettify s, Prettify nt, Prettify t, Hashable nt, Hashable t, Eq nt, Eq t) => Prettify (ATN s nt t) where+  prettify atn = do+    pLine "_Δ:"+    incrIndent 4+    prettify $ _Δ atn+    incrIndent (-4)++-- | Tuple corresponding to a distinct transition in the ATN:+type Transition s nt t = (ATNState nt, Edge s nt t, ATNState nt)++-- | The possible subscripts from Figure 8 of the ALL(*) paper+data ATNState nt  = Start  nt+                  | Middle nt Int Int+                  | Accept nt+  deriving (Eq, Generic, Hashable, Ord, Show)++-- | LaTeX style ATN states. TODO: check length of NT printed and put curly braces+-- around it if more than one character.+instance (Prettify nt) => Prettify (ATNState nt) where+  prettify (Start nt)  = pStr "p_"  >> prettify nt+  prettify (Accept nt) = pStr "p'_" >> prettify nt+  prettify (Middle nt i j) = do+    pStr "p_{"+    prettify i+    pStr ","+    prettify j+    pStr "}"++-- | An edge in an ATN.+data Edge s nt t =+    NTE nt              -- ^ Nonterminal edge+  | TE  t               -- ^ Terminal edge+  | PE  (Predicate ())  -- ^ Predicated edge with no state+  | ME  (Mutator   ())  -- ^ Mutator edge with no state+  | Epsilon             -- ^ Nondeterministic edge parsing nothing+  deriving (Eq, Generic, Hashable, Ord, Show)++instance (Prettify s, Prettify nt, Prettify t) => Prettify (Edge s nt t) where+  prettify x = do+    pStr "--"+    case x of+      NTE nt -> prettify nt+      TE   t -> prettify t+      PE   p -> prettify p+      ME   m -> prettify m+      Epsilon -> pStr "ε"+    pStr "-->"++-- | 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+atnOf g = let++  _Δ :: Int -> Production s nt t -> [Transition s nt t]+  _Δ i (Production lhs rhs) = let+  --(Prod _α)) = let++    -- Construct an internal production state from the given ATN identifier+    st :: nt -> Int -> Int -> ATNState nt+    st = Middle++    -- Create the transition for the k^th production element in the i^th+    -- production:+    _Δ' :: Int -> ProdElem nt t -> Transition s nt t+    _Δ' k (NT nt) = (st lhs i (k - 1), NTE nt, st lhs i k)+    _Δ' k (T  t)  = (st lhs i (k - 1), TE  t,  st lhs i k)++    -- The epsilon (or mu) transition for the accepting / final state:+    sϵ    = (Start lhs, Epsilon, Middle lhs i 0)+    fϵ _α = (Middle lhs i (length _α), Epsilon, Accept lhs)++    sem_state _α = Middle lhs i (length _α + 1)+    sϵ_sem _π _α = [(Start lhs, Epsilon, sem_state _α), (sem_state _α, PE _π, Middle lhs i 0)]+    fϵ_sem       = fϵ++    sϵ_mut    = sϵ+    fϵ_mut _μ = (Middle lhs i 0, ME _μ, Accept lhs)++    in  (case rhs of+          (Prod Pass _α)        -> [sϵ, fϵ _α]                 ++ zipWith _Δ' [1..(length _α)] _α+          (Prod (Sem _π) _α)    -> sϵ_sem _π _α ++ [fϵ_sem _α] ++ zipWith _Δ' [1..(length _α)] _α+          (Prod (Action _μ) _)  -> [sϵ_mut, fϵ_mut _μ]+        )++  in ATN+    { _Δ = fromList $ concat $ zipWith _Δ [0..length (ps g)] $ ps g+    }
+ src/Text/ANTLR/Allstar/ParserGenerator.hs view
@@ -0,0 +1,350 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts #-}+{-|+  Module      : Text.ANTLR.Allstar.ParserGenerator+  Description : ALL(*) parsing algorithm+  Copyright   : (c) Sam Lasser,+                (c) Karl Cronburg, 2017-2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Allstar.ParserGenerator+  ( GrammarSymbol(..), Token(..), ATNEnv(..)+  , AST(..), ATNState(..), ATNEdge(..)+  , ATNEdgeLabel(..)+  , parse+  ) where++import Data.List+import qualified Data.Set as DS+import Debug.Trace++--------------------------------TYPE DEFINITIONS--------------------------------++-- Add another synonym for NT names+-- Change ATN repr. so NT name is the key, NT name doesn't appear in state identifiers+-- Consider more nested representation of ATN, where integer path IDs are keys++-- | Grammar symbol types+data GrammarSymbol nt t = NT nt | T t | EPS deriving (Eq, Ord, Show)++-- ATN types++{-++type ATN nt t       = [ATNPath nt t]+type ATNPath nt t   = [ATNEdge nt t]+type ATNEdge nt t   = (ATNState nt, ATNEdgeLabel nt t, ATNState nt)+data ATNEdgeLabel nt t = GS (GrammarSymbol nt t) | PRED Bool+data ATNState nt    = INIT nt | CHOICE nt Int | MIDDLE Int | FINAL nt deriving+                      (Eq, Ord, Show)++-}++-- | Specifies the nonterminal we're currently parsing as well as+--   what state we are in for parsing some NT symbol.+data ATNState nt =+    Init nt            -- ^ Starting state+  | Middle nt Int Int  -- ^ Intermediate state+  | Final nt           -- ^ Accepting state+  deriving (Eq, Ord, Show)++-- | Starting state, NT/T symbol to parse, and ending state.+type ATNEdge nt t = (ATNState nt, ATNEdgeLabel nt t, ATNState nt)++-- | The domain of labels on edges in an augmented recursive transition network,+--   namely the symbol we parse upon traversing an edge.+data ATNEdgeLabel nt t =+    GS (GrammarSymbol nt t)  -- ^ The symbol to parse upon traversing an edge+  | PRED Bool                -- ^ Unimplemented predicates in ALL(*)+  deriving (Eq, Ord, Show)++-- | A set of ATN edges, defining the grammar over which the ALL(*) parsing+--   algorithm operates.+type ATNEnv nt t = DS.Set (ATNEdge nt t)++isInit :: ATNState nt -> Bool+isInit (Init nt) = True+isInit _ = False++outgoingEdge :: (Eq nt, Show nt) => ATNState nt -> ATNEnv nt t -> ATNEdge nt t+outgoingEdge p atnEnv = let edges = outgoingEdges p atnEnv+                        in  case edges of+                              [edge] -> edge+                              _ -> error "Multiple edges found"++-- 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 p atnEnv = DS.toList (DS.filter (\(p',_,_) -> p' == p) atnEnv)++++type ATNStack nt    = [ATNState nt]+-- type ATNEnv nt t    = [(GrammarSymbol nt t, ATN nt t)]+type ATNConfig nt   = (ATNState nt, Int, ATNStack nt)++-- DFA types+type DFA nt t       = [DFAEdge nt t]+type DFAEdge nt t   = (DFAState nt, t, DFAState nt)+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)]++-- | Input sequence type+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)++--------------------------------CONSTANTS---------------------------------------++emptyEnv        = []+emptyStack      = []+emptyDerivation = []++--------------------------------AUXILIARY FUNCTIONS-----------------------------++{-++-- Return the ATN edge with ATN state p on the left+-- Q: Should I handle the "no edge found" case here, or in the caller?+outgoingEdge :: Eq nt => ATNState nt -> ATNEnv nt t -> Maybe (ATNEdge nt t)+outgoingEdge p atnEnv = let edges = (concat . concat) (map snd atnEnv)+                        in  find (\(p', t, q) -> p == p') edges++-- Return all ATN edges with ATN state p on the left+outgoingEdges :: Eq nt => ATNState nt -> ATNEnv nt t -> [ATNEdge nt t]+outgoingEdges p atnEnv = let edges = (concat . concat) (map snd atnEnv)+                         in  filter (\(p', t, q) -> p == p') edges++-}++-- Better way to ensure that the parameter is a D DFA state?+getConflictSetsPerLoc :: (Eq nt, Ord nt) => DFAState nt -> [[ATNConfig nt]]+getConflictSetsPerLoc q =+  case q of+    F _       -> error "final state passed to getConflictSetsPerLoc"+    Derror    -> error "error state passed to getConflictSetsPerLoc"+    D configs -> let sortedConfigs = sortOn (\(p, i, gamma) -> (p, gamma)) configs+                 in  groupBy (\(p, i, gamma) (p', j, gamma') ->+                               p == p' && i /= j && gamma == gamma')+                             sortedConfigs++getProdSetsPerState :: (Eq nt, Ord nt) => DFAState nt -> [[ATNConfig nt]]+getProdSetsPerState q = +  case q of+    F _       -> error "final state passed to getProdSetsPerState"+    Derror    -> error "error state passed to getProdSetsPerState"+    D configs -> let sortedConfigs = sortOn (\(p, i, gamma) -> (p, gamma)) configs+                 in  groupBy (\(p, _, _) (p', _, _) -> p == p')+                             sortedConfigs++dfaTrans :: (Eq nt, Eq t) => DFAState nt -> t -> DFA nt t -> Maybe (DFAEdge nt t)+dfaTrans d t dfa = find (\(d1, label, _) -> d1 == d && label == t) dfa++findInitialState :: DFA nt t -> Maybe (DFAState nt)+findInitialState dfa =+  let isInit d = case d of+                   Dinit _ -> True+                   _       -> False+  in  case find (\(d1, _, _) -> isInit d1) dfa of+        Just (d1, _, _) -> Just d1+        Nothing         -> Nothing+++allEqual :: Eq a => [a] -> Bool+allEqual []       = True+allEqual (x : xs) = all (== x) xs++bind :: Eq a => a -> b -> [(a, b)] -> [(a, b)]+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'++--------------------------------ALL(*) FUNCTIONS--------------------------------+-- should parse() also return residual input sequence?++-- | 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 =+        case (currState, startSym) of+          (Final c, NT c') ->+            if c == c' then+              Right (Node c subtrees)+            else+              case (stack, astStack) of+                (q : stack', leftSiblings : astStack') ->+                  parseLoop input q stack' dfaEnv (leftSiblings ++ [Node c 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+                                        else+                                          Left ("remaining input: " ++ show input)+                  (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+                  (PRED _, _)        -> error "not implemented"++      initialDfaEnv = DS.toList (DS.foldr (\(p,_,_) ntNames ->+                                  case p of Init ntName -> DS.insert (NT ntName, []) ntNames+                                            _ -> ntNames)+                                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"++  where++    -- adaptivePredict :: (GrammarSymbol nt (Label tok)) -> [tok] -> ATNStack nt -> DFAEnv nt (Label tok) -> Maybe (Int, DFAEnv nt (Label tok))+    adaptivePredict sym input stack dfaEnv  =+      case lookup sym dfaEnv of+        Nothing  -> error ("No DFA found for " ++ show sym)+        Just dfa -> let d0  = case findInitialState dfa of+                                Just d0 -> d0+                                Nothing -> startState sym emptyStack+                        in sllPredict sym input d0 stack dfaEnv++    startState sym stack =+      case sym of+        NT ntName ->+          let initEdges = outgoingEdges (Init ntName) atnEnv+              loopOverAtnPaths initEdges =+                case initEdges of+                  [] -> []+                  (Init _, GS EPS, q@(Middle _ i _)) : es ->+                    (closure [] (q, i, stack)) ++ loopOverAtnPaths es+                  _ -> error "ATN path must begin with an epsilon edge from Init to Choice"+          in  D (loopOverAtnPaths initEdges)+        _ -> error "Symbol passed to startState must be a nonterminal"++    closure busy currConfig =+      if elem currConfig busy then+        []+      else+        let busy'            = currConfig : busy+            (p, i, gamma)    = currConfig+            pEdges           = outgoingEdges p atnEnv+            loopOverEdges es =+              case es of+                []                      -> [] +                (_, GS (NT ntName), q) : es' ->+                  closure busy' (Init ntName, i, q : gamma) +++                  loopOverEdges es'+                (_, GS EPS, q) : es'       ->+                  closure busy' (q, i, gamma) +++                  loopOverEdges es'+                (_, GS (T _), _) : es'       ->+                  loopOverEdges es'+        in  case (p, gamma) of+          (Final _, [])         -> [currConfig]+          (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 ->+                let (d', dfaEnv') =+                      if useCache then+                        case lookup sym dfaEnv of+                          Nothing  -> error ("No DFA found for nonterminal " ++ show sym ++ show dfaEnv)+                          Just dfa ->+                            case dfaTrans d (getLabel t) dfa of+                              Just (_, _, d2) -> (d2, dfaEnv)+                              Nothing         -> let d' = target d t+                                in  (d', bind sym ((d, getLabel t, d') : dfa) dfaEnv)+                      else+                        (target d t, dfaEnv) -- don't use the cache, or add any new information to it+                in  case d' of+                      Derror            -> Nothing+                      F i               -> Just (i, dfaEnv')+                      D atnConfigs      ->+                        let conflictSets   = getConflictSetsPerLoc d'+                            prodSets       = getProdSetsPerState d'+                            stackSensitive =+                              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?+                            else+                              predictionLoop d' ts dfaEnv'+      in  predictionLoop d0 input 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 =+      let d0 = startState sym stack+          predictionLoop d tokens =+            case tokens of+              []     -> error ("Empty input in llPredict")+              t : ts -> +                let mv = move d (getLabel t)+                    d' = D (concat (map (closure []) mv))+                in  case d' of+                      D []         -> error ("empty DFA state in llPredict")+                      D atnConfigs ->+                        case nub (map (\(_, j, _) -> j) atnConfigs) of+                          [i] -> i+                          _   ->+                            let altSets = getConflictSetsPerLoc d'+                            in  case altSets of+                                  []     -> error ("No alt sets found")+                                  a : as ->+                                    if allEqual altSets && length a > 1 then+                                      minimum (map (\(_, i, _) -> i) a)+                                    else+                                      predictionLoop d' ts+      in  predictionLoop d0 input+      ++    target d a =+      let mv = move d (getLabel a)+          d' = D (concat (map (closure []) mv))+      in  case d' of+            D []         -> Derror+            D atnConfigs ->+              case nub (map (\(_, j, _) -> j) atnConfigs) of+                [i] -> F i+                _   -> d'+                +    move q t = +      case q of+        D atnConfigs ->+          let qsForP (p, i, gamma) =+                let pOutgoingEdges = outgoingEdges p atnEnv+                in  foldr (\(p', label, q) acc ->+                            case label of+                              GS (T a) -> if t == a then+                                            (q, i, gamma) : acc+                                          else+                                            acc+                              _   -> acc)+                          []+                          pOutgoingEdges+          in concat (map qsForP atnConfigs)+
+ src/Text/ANTLR/Allstar/Stacks.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ScopedTypeVariables, DeriveAnyClass, DeriveGeneric,+    OverloadedStrings #-}+{-|+  Module      : Text.ANTLR.Allstar.Stacks+  Description : Graph-structured stack (GSS) for the ALL(*) algorithm+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Allstar.Stacks+  ( Stacks(..)+  , (#)+  , merge+  , push+  , pop+  ) where+import qualified Prelude as P+import Prelude hiding (map, foldr, filter)+import Text.ANTLR.Set+  ( union, Set(..), foldr, map, filter+  , fromList, singleton, Hashable(..), Generic(..)+  )+import qualified Text.ANTLR.Set as Set+import Data.List (nub)+import Text.ANTLR.Pretty++-- | Graph-structured stack representation+data Stacks a =+    Empty+  | Wildcard+  | Stacks (Set [a])+  deriving (Eq, Ord, Generic, Hashable, Show)++instance (Prettify a, Hashable a, Eq a) => Prettify (Stacks a) where+  prettify Empty      = pStr "[]"+  prettify Wildcard   = pStr "#"+  prettify (Stacks s) = prettify s++-- | Represents the set of __all__ stacks+(#) = Wildcard++-- | Combine two GSSs+merge :: (Eq a, Hashable a) => Stacks a -> Stacks a -> Stacks a+merge Wildcard _   = Wildcard+merge _ Wildcard   = Wildcard+merge Empty Empty  = Empty+merge (Stacks _Γ)  Empty       = Stacks $ _Γ `union` fromList [[]]+merge Empty       (Stacks _Γ)  = Stacks $ _Γ `union` fromList [[]]+merge (Stacks _Γ) (Stacks _Γ') = Stacks $ _Γ `union` _Γ'++-- | Push a state onto all the leaves of the given GSS+push :: (Eq a, Hashable a) => a -> Stacks a -> Stacks a+push a Empty        = Stacks $ singleton [a]+push a Wildcard     = Wildcard+push a (Stacks _Γ)  = Stacks $ map ((:) a) _Γ++-- | Get heads of non-empty stacks / lists:+heads :: (Eq a, Hashable a) => Set [a] -> [a]+heads = let+    heads' :: [a] -> [a] -> [a]+    heads' []     bs = bs+    heads' (a:as) bs = a:bs+  in foldr heads' []++-- | Pop off all the current states from the given GSS+pop  :: (Eq a, Hashable a) => Stacks a -> [(a, Stacks a)]+pop Empty = []+pop Wildcard = []+pop (Stacks _Γ) = let+--    ss :: a -> Stacks a+    ss a = Stacks $ map tail $ filter (\as -> (not . null) as && ((== a) . head) as) _Γ+  in P.map (\a -> (a, ss a)) (nub . heads $ _Γ)+
+ src/Text/ANTLR/Common.hs view
@@ -0,0 +1,16 @@+{-|+  Module      : Text.ANTLR.Common+  Description : Haskell-level helper functions used throughout Text.ANTLR+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Common where++concatWith cs [] = []+concatWith cs [x] = x+concatWith cs (x:xs) = x ++ cs ++ concatWith cs xs+
+ src/Text/ANTLR/Grammar.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses+  , DeriveGeneric, DeriveAnyClass, TypeFamilies, FlexibleContexts+  , StandaloneDeriving, OverloadedStrings, DeriveDataTypeable #-}+{-|+  Module      : Text.ANTLR.Grammar+  Description : Grammar data types and API for parsing algorithms+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Grammar+  ( -- * Data types+    Grammar(..)+  , ProdElem(..), ProdElems+  , Production(..), ProdRHS(..), StateFncn(..)+  , Predicate(..), Mutator(..), Ref(..)+  -- * Basic setter / getter functions:+  , getRHS, getLHS+  , isSem, isAction+  , sameNTs, sameTs+  , isNT, isT, isEps, getNTs, getTs, getEps+  , prodsFor, getProds+  , validGrammar, hasAllNonTerms, hasAllTerms, startIsNonTerm+  , symbols, defaultGrammar+  ) where+import Prelude hiding (pi)+import Data.List (nub, sort)++import System.IO.Unsafe (unsafePerformIO)+import qualified Debug.Trace as D+import Data.Data (Data(..), Typeable(..))+import Language.Haskell.TH.Lift (Lift(..))++import qualified Text.ANTLR.Set as S+import Text.ANTLR.Set+  ( Set(..), empty, fromList, member, union+  , Hashable(..), Generic(..)+  )++import Text.ANTLR.Pretty++uPIO :: IO a -> a+uPIO = unsafePerformIO++----------------------------------------------------------------+-- When we *Show* production elements, they should contain source location+-- information, but when we *compare* them, we should ignore the source info.++-- | Something is "Ref" if it can be symbolized by some symbol in a set of+--   symbols. Symbols are typically Strings, an enum data type, or some other+--   Eq-able (best if finite) set of things.+class Ref v where+  -- | One symbol type for every value type v.+  type Sym v :: *+  -- | Compute (or extract) the symbol for some concrete value.+  getSymbol :: v -> Sym v++compareSymbols :: (Ref ref, Eq (Sym ref)) => ref -> ref -> Bool+compareSymbols a b = getSymbol a == getSymbol b++-- | Nonterminals can be symbolized (for now the types are equivalent, i.e.+--   nt == Sym nt)+sameNTs :: forall nt. (Ref nt, Eq (Sym nt)) => nt -> nt -> Bool+sameNTs = compareSymbols++-- | Terminals can be symbolized (in the current implementation, the input+--   terminal type to a parser is @(t == 'Text.ANTLR.Lex.Tokenizer.Token' n v)@ and the terminal symbol type is+--   @(ts == 'Sym t' == n)@ where @n@ is defined as the name of a token @('Text.ANTLR.Lex.Tokenizer.Token' n v)@.+sameTs :: forall t. (Ref t, Eq (Sym t)) => t -> t -> Bool+sameTs = compareSymbols++instance Ref String where+  type Sym String = String+  getSymbol = id++instance Ref (String, b) where+  type Sym (String, b) = String+  getSymbol = fst++-- | Grammar ProdElems+--   +--   > nts == Non Terminal Symbol (type)+--   > ts == Terminal Symbol (type)+--+--   Production elements are only used in the grammar data structure and parser,+--   therefore these types (nt and ts) are __not__ necessarily equivalent to the+--   terminal types seen by the tokenizer (nonterminals are special because no one+--   sees them until after parsing). Also pushing @(ts = Sym t)@ up to the top of+--   data constructors gets rid of a lot of unnecessary standalone deriving+--   instances. Standalone deriving instances in this case are a programming+--   anti-pattern for allowing you to improperly parametrize your types. In this+--   case a 'ProdElem' cares about the __terminal symbol type__, not the __terminal+--   token type__. In fact it's redundant to say *terminal token* because all+--   tokens are terminals in the grammar. A token is by definition a tokenized+--   __value__ with a __named__ terminal symbol, which is in fact exactly what the+--   'Text.ANTLR.Lex.Tokenizer.Token' type looks like in 'Text.ANTLR.Lex.Tokenizer': @'Text.ANTLR.Lex.Tokenizer.Token' n v@ (name and+--   value). So wherever I see an @n@ type variable in the tokenizer, this is+--   equivalent to @('Sym' t)@ in the parser. And wherever I see a @('Text.ANTLR.Lex.Tokenizer.Token' n v)@ in the+--   tokenizer, this gets passed into the parser as @t@:+--+--   @+--     n           == 'Sym' t+--     ('Text.ANTLR.Lex.Tokenizer.Token' n v) == t+--   @+--+data ProdElem nts ts =+    NT nts -- ^ Nonterminal production element+  | T  ts  -- ^ Terminal production element+  | Eps    -- ^ Empty string production element+  deriving (Eq, Ord, Generic, Hashable, Show, Data, Lift)++instance (Prettify nts, Prettify ts) => Prettify (ProdElem nts ts) where+  prettify (NT nts) = prettify nts+  prettify (T  ts)  = prettify  ts+  prettify Eps      = pStr "ε"++-- | Is the 'ProdElem' a nonterminal?+isNT (NT _) = True+isNT _      = False++-- | Is the 'ProdElem' a terminal?+isT (T _) = True+isT _     = False++-- | Is the 'ProdElem' an epsilon?+isEps Eps = True+isEps _   = False++-- | Get just the nonterminals from a list+getNTs = map (\(NT nt) -> nt) . filter isNT+-- | Get just the terminals from a list+getTs  = map (\(T t) -> t) . filter isT+-- | Get just the epsilons from a list (umm...)+getEps = map (\Eps -> Eps) . filter isEps++-- | Zero or more production elements+type ProdElems nts ts = [ProdElem nts ts]++-- | A function to run when a production rule fires, operating some state @s@.+data StateFncn s =+    Pass                    -- ^ No predicate or mutator+  | Sem    (Predicate ())   -- ^ Semantic predicate+  | Action (Mutator ())     -- ^ Mutator, ProdElems is always empty in this one+  deriving (Eq, Ord, Generic, Hashable, Show, Data, Lift)++instance Prettify (StateFncn s) where+  prettify Pass       = return ()+  prettify (Sem p)    = prettify p+  prettify (Action a) = prettify a++-- | Right-hand side of a single production rule+data ProdRHS s nts ts = Prod (StateFncn s) (ProdElems nts ts)+  deriving (Eq, Ord, Generic, Hashable, Show, Data, Lift)++instance (Prettify s, Prettify nts, Prettify ts) => Prettify (ProdRHS s nts ts) where+  prettify (Prod sf ps) = do+    prettify sf+    prettify ps++-- | Is this 'ProdRHS' a semantic predicate?+isSem (Prod (Sem _) _) = True+isSem _ = False++-- | Is this 'ProdRHS' a mutator?+isAction (Prod (Action _) _) = True+isAction _ = False++-- | 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)+  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+    len <- pCount nts+    -- Put the indentation level after the nonterminal, or just incr by 2 if+    -- lazy...+    incrIndent (len + 4)+    pStr " -> "+    prettify sf+    prettify ps+    incrIndent (-4)++instance (Show s, Show nts, Show ts) => Show (Production s nts ts) where+  show (Production nts rhs) = show nts ++ " -> " ++ show rhs++-- | Inline get 'ProdRHS' of a 'Production'+getRHS :: Production s nts ts -> ProdRHS s nts ts+getRHS (Production lhs rhs) = rhs++-- | Inline get the nonterminal symbol naming a 'Production'+getLHS :: Production s nts ts -> nts+getLHS (Production lhs rhs) = lhs++-- | 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 g nts = let+    matchesNT :: Production s nts t -> Bool+    matchesNT (Production nts' _) = nts' == nts+  in filter matchesNT (ps g)++-- TODO: boiler plate auto deriving for "named" of a user defined type?++-- | Predicates and Mutators act over some state. The String+--   identifiers should eventually correspond to source-level+--   e.g. location / allocation site information, i.e. two+--   predicates or mutators are equivalent iff they were+--   constructed from the same production rule.+data Predicate p = Predicate String p+  deriving (Data)++instance (Data s, Typeable s) => Lift (Predicate s)+instance (Data s, Typeable s) => Lift (Mutator s)++instance Eq (Predicate s) where+  Predicate p1 _ == Predicate p2 _ = p1 == p2++instance Ord (Predicate s) where+  Predicate p1 _ `compare` Predicate p2 _ = p1 `compare` p2++instance Show (Predicate s) where+  show (Predicate p1 _) = "π(" ++ show p1 ++ ")"++instance Hashable (Predicate s) where+  hashWithSalt salt (Predicate p1 _) = salt `hashWithSalt` p1++instance Prettify (Predicate s) where+  prettify (Predicate n _) = pStr' n++instance Prettify (Mutator s) where+  prettify (Mutator n _) = pStr' n++-- | Function for mutating the state of the parser when a certain+--   production rule fires.+data Mutator   s = Mutator String ()+  deriving (Data)++instance Eq (Mutator s) where+  Mutator m1 _ == Mutator m2 _ = m1 == m2++instance Ord (Mutator s) where+  Mutator m1 _ `compare` Mutator m2 _ = m1 `compare` m2++instance Show (Mutator s) where+  show (Mutator m1 _) = "µ(" ++ show m1 ++ ")"++instance Hashable (Mutator s) where+  hashWithSalt salt (Mutator m1 _) = salt `hashWithSalt` m1++-- | Core representation of a grammar, as used by the parsing algorithms.+data Grammar s nts ts = G+  { ns  :: Set nts+  , ts  :: Set ts+  , ps  :: [Production s nts ts]+  , 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+  g1 == g2 = ns g1 == ns g2+          && ts g1 == ts g2+          && eqLists (nub $ ps g1) (nub $ ps g2)+          && s0 g1 == s0 g2+          && _πs g1 == _πs g2+          && _μs g1 == _μs g2++eqLists [] [] = True+eqLists [] vs = False+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+  prettify G {ns = ns, ts = ts, ps = ps, s0 = s0, _πs = _πs, _μs = _μs} = do+    pLine "Grammar:"+    pStr "{ "+    incrIndent 2+    pStr  "  ns = "      ; prettify ns; pLine ""+    pStr  ", ts = "      ; prettify ts; pLine ""+    pStr  ", ps = "      ; pListLines $ sort ps; pLine ""+    pStr  ", s0 = "      ; prettify s0; pLine ""+    pStr  ", _πs = "     ; prettify _πs ; pLine ""+    pStr  ", _μs = "     ; prettify _μs ; pLine ""+    incrIndent (-2)+    pStr "}"++-- | 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)+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+defaultGrammar start = G+  { ns  = S.singleton start+  , ts  = empty+  , ps  = []+  , _πs = empty+  , _μs = empty+  , s0  = start+  }++-- | Does the given grammar make any sense?+validGrammar+  :: forall s nts ts.+  (Eq nts, Ord nts, Eq ts, Ord ts, Hashable nts, Hashable ts)+  => Grammar s nts ts -> Bool+validGrammar g =+     hasAllNonTerms g+  && hasAllTerms g+  && startIsNonTerm g+--  && distinctTermsNonTerms g++-- | 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+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+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+startIsNonTerm g = s0 g `member` ns g++--distinctTermsNonTerms g =+--  (ns g `intersection` ts g) == empty+
+ src/Text/ANTLR/LL1.hs view
@@ -0,0 +1,464 @@+{-# LANGUAGE ScopedTypeVariables, MonadComprehensions, DeriveGeneric+ , DeriveAnyClass, FlexibleContexts, OverloadedStrings #-}+{-|+  Module      : Text.ANTLR.LL1+  Description : LL1 parsing algorithm and accompanying first/follow functions+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.LL1+  ( recognize+  , first, follow+  , foldWhileEpsilon+  , isLL1, parseTable+  , predictiveParse+  , removeEpsilons, removeEpsilons'+  , leftFactor+  , Prime(..), ParseTable, PTKey, PTValue+  ) where+import Text.ANTLR.Grammar+import Text.ANTLR.Pretty+import Text.ANTLR.Parser+import Text.ANTLR.Allstar.ATN+--import Data.Set.Monad+import Text.ANTLR.Set+  ( Set(..), singleton, fromList, union, empty, member, size, toList+  , insert, delete, intersection, Hashable(..), Generic(..), maybeMin+  )+import Data.List (maximumBy, isPrefixOf)+import Data.Ord (comparing)++import qualified Data.Map.Strict as M+import qualified Data.Text as T+import qualified Debug.Trace as D+import System.IO.Unsafe (unsafePerformIO)+uPIO = unsafePerformIO++-- Fold while the given pred function is true:+foldWhile :: (a -> b -> Bool) -> (a -> b -> b) -> b -> [a] -> b+foldWhile pred fncn = let+    fW' b0 []     = b0+    fW' b0 [a]    = b0+    fW' b0 (a:as)+      | pred a b0 = fW' (fncn a b0) as+      | otherwise = b0+  in fW'++epsIn set _ = IconEps `member` set++-- | Fold over a set of ProdElems (symbols) while all the previous sets of+--   symbols contains an epsilon.+foldWhileEpsilon fncn b0 []     = empty+foldWhileEpsilon fncn b0 [a]    = fncn a b0+foldWhileEpsilon fncn b0 (a:as)+  | epsIn a b0 = foldWhile epsIn fncn (fncn a b0) as+  | otherwise  = fncn a b0++-- | 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)+first g = let+    firstOne :: Set (ProdElem nts sts) -> ProdElem nts sts -> Set (Icon sts)+    firstOne _ t@(T x) = singleton $ Icon x+    firstOne _ Eps     = singleton IconEps+    firstOne busy nts@(NT x)+      | nts `member` busy = empty+      | otherwise = foldr union empty+            [ foldWhileEpsilon union empty+              [ firstOne (insert nts busy) y+              | y <- (\(Prod _ ss) -> ss) rhs+              ]+            | Production _ rhs <- prodsFor g x ]+    +    firstMany :: [Set (Icon sts)] -> Set (Icon sts)+    firstMany []   = singleton IconEps+    firstMany (ts:tss)+      | IconEps `member` ts = ts `union` firstMany tss+      | otherwise           = ts+  in firstMany . map (firstOne empty)++-- | 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)+follow g = let+    follow' busy _B+      | _B `member` busy = empty+      | otherwise = let++        busy' = insert _B busy+        +        followProd :: nts -> ProdElems nts sts -> Set (Icon sts)+        followProd _  []  = empty+        followProd _A [s]+              -- If A -> αB then everything in FOLLOW(A) is in FOLLOW(B)+          | s == NT _B = follow' busy' _A+          | otherwise  = empty+        followProd _A (s:β)+              -- Recursively find all other instances of B in this production+          | s /= NT _B = followProd _A β+          | otherwise  =+              -- Recursively find all other instances of B in this production+              followProd _A β+              `union`+              -- If A -> αBβ, then everything in FIRST(β) is in FOLLOW(B)+              (delete IconEps $ first g β)+              `union`+              -- If A -> αBβ and Epsilon `member` FIRST(β), then everything+              -- in FOLLOW(A) is in FOLLOW(B)+              (if IconEps `member` first g β+                then follow' busy' _A+                else empty+              )++            -- Start state contains IconEOF (aka '$', end of input) in FOLLOW()+      in  (if _B == s0 g then singleton IconEOF else empty)+          `union`+          foldr union empty+            [ followProd lhs_nts ss+            | Production lhs_nts (Prod _ ss) <- ps g+            ]+  in follow' empty++-- | Is the given grammar in LL(1)?+--   +-- @+--   A -> α | β for all distinct ordered pairs of α and β,+--        first(α) `intersection` first(β) == empty+--   and if epsilon is in α, then+--        first(α) `intersection` follow(A) == empty+-- @+isLL1+  :: (Eq nts, Eq sts, Ord nts, Ord sts, Hashable nts, Hashable sts)+  => Grammar () nts sts -> Bool+isLL1 g =+  validGrammar g && and+      [  (first g α `intersection` first  g β  == empty)+      && (not (IconEps `member` first g α)+         || ((first g α `intersection` follow g nts) == empty))+      | nts       <- toList $ ns g+      , (Prod _ α) <- map getRHS $ prodsFor g nts+      , (Prod _ β) <- map getRHS $ prodsFor g nts+      , α /= β+      ]++-- | Keys in the LL1 parse table.+type PTKey nts sts = (nts, Icon sts)++-- | All possible productions we could reduce. Empty implies parse error,+--   singleton implies unambiguous entry, multiple implies ambiguous:+type PTValue nts sts = Set (ProdElems nts sts)++ambigVal+  :: (Ord nts, Ord sts, Hashable nts, Hashable sts)+  => PTValue nts sts -> Bool+ambigVal = (1 >) . size++-- | M[A,s] = α for each symbol s `member` FIRST(α)+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+parseTable' fncn g = let++    insertMe ::+      (nts, Icon sts, ProdElems nts sts) -> (ParseTable nts sts -> ParseTable nts sts)+    insertMe (_A, a, α) = M.insertWith fncn (_A, a) $ singleton α++  in+    foldr insertMe M.empty+      -- For each terminal a `member` FIRST(α), add A -> α to M[A,α]+      [ (_A, Icon a, α)+      | Production _A (Prod _ α) <- ps g+      , Icon a <- toList $ first g α+      ]+    `M.union`+    foldr insertMe M.empty+      -- If Eps `member` FIRST(α), add A -> α to M[A,b]+      -- for each b `member` FOLLOW(A)+      [ (_A, Icon b, α)+      | Production _A (Prod _ α) <- ps g+      , IconEps `member` first g α+      , Icon b <- toList $ follow g _A+      ]+    `M.union`+    foldr insertMe M.empty+      -- If Eps `member` FIRST(α)+      -- , AND IconEOF `member` FOLLOW(_A)+      -- add A -> α to M[A,IconEOF]+      [ (_A, IconEOF, α)+      | Production _A (Prod _ α) <- 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+parseTable = parseTable' union+++data TreeNode ast nts sts =+    Comp   ast+  | InComp nts (ProdElems nts sts) [ast] Int+  deriving (Eq, Ord, Show)++instance (Prettify ast, Prettify nts, Prettify sts) => Prettify (TreeNode ast nts sts) where+  prettify (Comp ast)            = do+    pStr "(Complete "+    prettify ast+    pStr ")"+  prettify (InComp nts es asts i) = pParens $ do+    pStr "InComp"+    incrIndent 2+    pLine ""+    pStr "nts="+    prettify nts+    pLine ""+    pStr "es="+    prettify es+    pLine ""+    pStr "asts="+    prettify asts+    pLine ""+    pStr "i="+    prettify i+    incrIndent (-2)++-- A stack tree is a list of tree nodes with terminal *tokens* (not terminal+-- symbols)+type StackTree ast nts ts = [TreeNode ast nts (StripEOF ts)]++isComp (Comp _) = True+isComp _ = False+isInComp = not . isComp++-- | Language recognizer using 'predictiveParse'.+recognize ::+  ( Eq nts, Ref t, Eq (Sym t), HasEOF (Sym t)+  , 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+recognize g = (Nothing /=) . predictiveParse g (const ())++-- | Top-down predictive parsing algorithm.+predictiveParse+  :: forall nts t ast.+  (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+predictiveParse g act w0 = let++    --reduce :: StackTree ast -> StackTree ast+    reduce :: StackTree ast nts (Sym t) -> StackTree ast nts (Sym t)+    reduce stree@(InComp nts ss asts 0 : rst) = reduce $ Comp (act $ NonTE (nts, ss, reverse asts)) : rst+    reduce stree@(InComp{}:_) = stree+    reduce stree = let+        +        cmps = map (\(Comp ast) -> ast) $ takeWhile isComp stree+        (InComp nts ss asts i : rst) = dropWhile isComp stree+        -- @(InComp nts ss ast i:rst) = dropWhile isComp stree+        +      in case dropWhile isComp stree of+            []                          -> stree+            (InComp nts ss asts i : rst) -> reduce (InComp nts ss (cmps ++ asts) (i - length cmps) : rst)+      +    -- Push a production elements (NT, T, or Eps) onto a possibly incomplete+    -- stack of trees+    --pushStack :: ProdElem -> ProdElems -> StackTree ast -> StackTree ast+    pushStack :: ProdElem nts t -> ProdElems nts (StripEOF (Sym t)) -> StackTree ast nts (Sym t) -> StackTree ast nts (Sym t)+    pushStack (NT nts) ss stree = reduce $ InComp nts ss [] (length ss) : stree+    pushStack (T t)   _  (InComp nts ss asts i:stree) = reduce $ InComp nts ss (act (TermE t) : asts) (i - 1) : stree+    pushStack Eps     _  (InComp nts ss asts i:stree) = reduce $ InComp nts ss (act EpsE             : asts) (i - 1) : stree+   +    -- 'ParseTable' terminal type *has* an EOF (not StripEOF (Sym t))+    _M :: ParseTable nts (StripEOF (Sym t))+    _M = parseTable g++    -- input word LL1 symbols -> Stack of symbols -> AST+    -- [ast] - a stack (list) of the asts the user has computed for us+    --         intermixed (in proper order) with the Terminals in the production+    --         rule for which we reduced the NonTerminal in question.+    parse' :: [t] -> ProdElems nts (StripEOF (Sym t)) -> StackTree ast nts (Sym t) -> Maybe (StackTree ast nts (Sym t)) --Maybe ast+    parse' [] [] asts                        = Just asts  -- Success? (TODO - EOF assumed on empty input)+    parse' [t] [] asts | isEOF $ getSymbol t = Just asts  -- Success!+    parse' _   [] asts  = Nothing    -- Parse failure because no end of input found+    parse' (a:ws) (T x:xs) asts+      | stripEOF (getSymbol a) == Just x = parse' ws xs $ pushStack (T a) [] asts+      | otherwise  = Nothing+    parse' ws@(a:_) (NT _X:xs) asts = do+      let sym  = getSymbol a+      sym' <- if isEOF sym then Just IconEOF else Icon <$> stripEOF (getSymbol a)+      ss  <- (_X, sym') `M.lookup` _M+      --D.traceM $ "ss=" ++ pshow ss+      ss' <- maybeMin ss+      --D.traceM $ "ss'=" ++ pshow ss'+      parse' ws (ss' ++ xs) (pushStack (NT _X) ss' asts)+    parse' ws (Eps:xs) asts = parse' ws xs (pushStack Eps [] asts)+    parse' ws xs asts = D.trace (T.unpack $ "Bug in parser: " `T.append` pshow (ws, xs, asts)) Nothing -- Bug in parser++  in do asts <- parse' w0 [NT $ s0 g] []+        case asts of+          [Comp ast] -> Just ast+          _          -> Nothing++-- | 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]+removeEpsilons' ps_init = let++    epsNT :: Production s nts t -> [nts] -> [nts]+    epsNT (Production nts (Prod _ []))    = (:) nts+    epsNT (Production nts (Prod _ [Eps])) = (:) nts+    epsNT prod             = id+  +    -- All NTs with an epsilon production+    epsNTs :: [nts]+    epsNTs = foldr epsNT [] ps_init++    {-+    isEpsProd :: Production s nts t -> Bool+    isEpsProd []         = True+    isEpsProd [Prod Eps] = True+    isEPsProd _          = False+    -}++    replicateProd :: nts -> Production s nts t -> [Production s nts t]+    replicateProd nts0 (Production nt1 (Prod sf es)) = let+        +        rP :: ProdElems nts t -> ProdElems nts t -> [Production s nts t]+        rP ys []   = [Production nt1 (Prod sf $ reverse ys)]+        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+              : (  rP ys     xs  -- Recursively with nts0 removed+                ++ rP (x:ys) xs) -- Recursively without nts0 removed+          | otherwise = rP (x:ys) xs+      in rP [] es++    orderNub ps p1+      | p1 `elem` ps = ps+      | otherwise    = p1 : ps++    ps' :: [Production s nts t]+    ps' = case epsNTs of+      []         -> ps_init+      (nts:ntss) -> removeEpsilons' $+                    foldl orderNub []+                          [ p' +                          | p  <- ps_init+                          , p' <- replicateProd nts p+                          , p' /= Production nts (Prod Pass [])+                          , p' /= Production nts (Prod Pass [Eps])]++  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+removeEpsilons g = g { ps = removeEpsilons' $ ps g }++-- | Add primes to nonterminal symbols.+newtype Prime nts = Prime (nts, Int)+  deriving (Eq, Ord, Generic, Hashable, Show)++instance (Prettify nts) => Prettify (Prime nts) where+  prettify (Prime (nts,i)) = do+    prettify nts+    pStr $ T.replicate i (T.singleton '\'')++-- | Left-factor a grammar to make it LL(1). This is experimental and mostly untested.+--   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+leftFactor = let++  primeify :: Grammar s nts t -> Grammar s (Prime nts) t+  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 ]+    , s0 = Prime (s0 g, 0)+    , _πs = _πs g+    , _μs = _μs g+    }++  prmPE :: ProdElem nts t -> ProdElem (Prime nts) t+  prmPE (NT nts) = NT $ Prime (nts, 0)+  prmPE (T x)   = T x+  prmPE Eps     = Eps+  +  lF :: Grammar s (Prime nts) t -> Grammar s (Prime nts) t+  lF g = let+    -- Longest common prefix of two lists+    lcp :: ProdElems (Prime nts) t -> ProdElems (Prime nts) t -> ProdElems (Prime nts) t+    lcp [] ys = []+    lcp xs [] = []+    lcp (x:xs) (y:ys)+      | x == y    = x : lcp xs ys+      | otherwise = []++    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)+                   , xs /= ys+                   ])+           | nts0 <- toList $ ns g ]++    --longest_lcps :: [(nts, ProdElems nts t)]+    --longest_lcps = filter (not . null . snd) lcps++    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' ((nts, xs):_) =+        -- Unaffected productions+        [ Production nts0 (Prod v rhs)+        | Production nts0 (Prod v rhs) <- ps g+        , nts0 /= nts+        ]+      +++        -- Unaffected productions+        [ Production nts0 (Prod v rhs)+        | Production nts0 (Prod v rhs) <- 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+        , nts == nts0 && xs `isPrefixOf` rhs+        ]+      ++ [Production nts (Prod Pass $ xs ++ [NT $ incr nts])]+  {- [ (prime nts, drop (length xs) ys)+                    | (nt1, ys) <- ps g+                    , nt1 == nts+                    , xs `isPrefixOf` ys -}+                    +    in g { ps = ps' lcps }+  in lF . primeify+
+ src/Text/ANTLR/LR.hs view
@@ -0,0 +1,795 @@+{-# LANGUAGE ScopedTypeVariables, ExplicitForAll, DeriveGeneric, DeriveAnyClass+  , FlexibleContexts, StandaloneDeriving, OverloadedStrings, MonadComprehensions+  , InstanceSigs, DeriveDataTypeable, DeriveLift #-}+{-|+  Module      : Text.ANTLR.LR+  Description : Entrypoint for all parsing algorithms based on LR+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.LR+  ( Item(..), ItemLHS(..)+  , kernel, items+  , slrClosure, slrGoto, slrItems, allSLRItems, slrTable, slrParse, slrRecognize+  , lr1Closure, lr1Goto, lr1Items, lr1Table, lr1Parse, lr1Recognize+  , LR1LookAhead+  , CoreLRState, CoreLR1State, CoreSLRState, LRTable, LRTable', LRAction(..)+  , lrParse, LRResult(..), LR1Result(..), glrParse, glrParseInc, isAccept, isError+  , lr1S0, glrParseInc', glrParseInc2+  , convGoto, convStateInt, convGotoStatesInt, convTableInt, tokenizerFirstSets+  , disambiguate+  , SLRClosure, SLRItem, SLRTable, Closure, LR1Item, Goto, Goto', Config, Tokenizer+  ) where+import Text.ANTLR.Grammar+import qualified Text.ANTLR.LL1 as LL+import Text.ANTLR.Parser+import Data.Maybe (catMaybes, mapMaybe, fromMaybe, fromJust)+import Text.ANTLR.Set ( Set(..), fromList, empty, member, toList, size+  , union, (\\), insert, toList, singleton+  )+import qualified Text.ANTLR.Set as S+import Text.ANTLR.Set (Hashable, Generic)+import qualified Text.ANTLR.MultiMap as M+import Text.ANTLR.Common++--import Data.Map ( Map(..) )+import qualified Data.Map as M1+import Data.Data (Data(..))+import Language.Haskell.TH.Lift (Lift(..))+import Data.List (sort)++import Text.ANTLR.Pretty+import qualified Debug.Trace as D+--import System.IO.Unsafe (unsafePerformIO)+--uPIO = unsafePerformIO++--trace = D.trace+trace x y = y++-- | The nonterminal symbol for which an item refers to.+data ItemLHS nts =+    Init   nts -- ^ This is S' if S is the grammar start symbol+  | ItemNT nts -- ^ Just an item wrapper around a nonterminal symbol+  deriving (Eq, Ord, Generic, Hashable, Data, Lift)++-- | An Item is a production with a dot in it indicating how far+--   into the production we have parsed:+--+-- @A ->  α . β@+--+data Item a nts sts = Item (ItemLHS nts) (ProdElems nts sts) {- . -} (ProdElems nts sts) a+  deriving (Generic, Eq, Ord, Hashable, Show, Data, Lift)++-- | Functions for computing the state (set of items) we can go to+--   next without consuming any input.+type Closure lrstate          = lrstate -> lrstate+-- | An LR goto implemented as one-to-one mapping.+type Goto nts sts lrstate     = M1.Map (lrstate, ProdElem nts sts) lrstate+-- | Function form of a 'Goto'+type Goto' nts sts lrstate    = lrstate -> ProdElem nts sts -> lrstate++-- | Ambiguous LR tables (can perform more than one action per @lrstate@)+type LRTable nts sts lrstate   = M.Map (lrstate, Icon sts) (LRAction nts sts lrstate)+-- | Disambiguated LR table (only one action performable per @lrstate@)+type LRTable' nts sts lrstate  = M1.Map (lrstate, Icon sts) (LRAction nts sts lrstate)++-- | CoreLRState is the one computed from the grammar (no information loss)+type CoreLRState a nts sts = Set (Item a nts sts)++-- | An LR1 action is just a regular 'LRAction'.+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+-- | 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.+type LR1Table nts sts lrstate   = LRTable nts sts lrstate+-- | LR1 lookahead is a single 'Icon'+type LR1LookAhead sts           = Icon sts+-- | An LR1 state is a set of items with one lookahead symbol.+type CoreLR1State nts sts       = Set (LR1Item nts sts)++-- | An SLRClosure is just a LR 'Closure' in disguise.+type SLRClosure lrstate = Closure lrstate+-- | SLR items have no lookahead.+type SLRItem  nts sts = Item    () nts sts+-- | An 'SLRTable' is just an 'LRTable' in disguise.+type SLRTable nts sts lrstate = LRTable nts sts lrstate+-- | An SLR state is a set of items without a lookahead.+type CoreSLRState nts sts = Set (Item () nts sts)++-- | 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.+  deriving (Generic, Eq, Ord, Hashable, Show, Data, Lift)++-- | An LR configurate telling you the current stack of states @[lrstate]@,+--   and the rest of the input tokens @[t]@.+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.+  deriving (Eq, Ord, Show, Generic, Hashable)++-- | A tokenizer is a function that, given a set of DFA names to try tokenizing,+--   returns a parsed token @t@ and the remaining untokenized input @[c]@.+type Tokenizer t c = Set (StripEOF (Sym t)) -> [c] -> (t, [c])++instance (Prettify nts) => Prettify (ItemLHS nts) where+  prettify (Init nts)   = prettify nts >> pStr "_0"+  prettify (ItemNT nts) = prettify nts++instance (Show nts) => Show (ItemLHS nts) where+  show (Init nts)   = show nts ++ "'"+  show (ItemNT nts) = show nts++instance (Prettify a, Prettify nts, Prettify sts) => Prettify (Item a nts sts) where+  prettify (Item _A α β a) = do+    prettify _A+    pStr " -> "+    prettify α+    pStr " . "+    prettify β+    pParens (prettify a)++instance+  ( Prettify lrstate, Prettify nts, Prettify sts+  , Hashable lrstate, Hashable sts, Hashable nts+  , Eq lrstate, Eq sts, Eq nts)+  => Prettify (LRAction nts sts lrstate) where+  prettify (Shift ss) = pStr "Shift  {" >> prettify ss >> pLine "}"+  prettify (Reduce p) = pStr "Reduce  " >> prettify p  >> pLine ""+  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+  +  prettify (ErrorNoAction (s:states, ws) asts) = do+    pStr "ErrorNoAction: Current input = '"+    if null ws then return () else prettify (head ws)+    pLine "'"+    incrIndent 7+    +    pStr "Current state = <"+    prettify s+    pLine ">"++    pStr "Rest of input = '"+    prettify ws+    pLine "'"+  +  prettify (ErrorTable (s:states, ws) asts) = do+    pStr "ErrorTable: Current input = '"+    if null ws then return () else prettify (head ws)+    pLine "'"+    incrIndent 7+    +    pStr "Current state = <"+    prettify s+    pLine ">"++    pStr "Rest of input = '"+    prettify ws+    pLine "'"+    +  prettify (ErrorAccept   (s:states, ws) asts) = do+    pStr "ErrorAccept: Current input = "+    (if null ws then return () else prettify (head ws))+    pLine ""+    incrIndent 7+    +    pStr "Current state = "+    prettify s+    pLine ""+    +    pStr "Rest of input = "+    prettify ws+    pLine ""+ +  prettify (ResultSet s) = pStr "ResultSet: " >> prettify s++  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 g is' = let++    closure' :: SLRClosure (CoreSLRState nts sts)+    closure' _J = let+      add = fromList+            [ Item (ItemNT _B) [] γ ()+            | Item _A α rst@(pe@(NT _B) : β) () <- toList _J+            , not $ null rst+            , isNT pe+            , Production _ (Prod _ γ) <- prodsFor g _B+            ]+      in case size $ add \\ _J of+        0 -> _J `union` add+        _ -> closure' $ _J `union` add++  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 g is' = let++    tokenToProdElem (Icon a) = [T a]+    tokenToProdElem _ = []++    closure' :: Closure (CoreLR1State nts sts)+    closure' _J = let+      add = fromList+            -- TODO: Handle IconEOF in LL.first set calculation properly?:+            [ Item (ItemNT _B) [] γ (if b == IconEps then IconEOF else b)+            | Item _A α rst@(pe@(NT _B) : β) a <- toList _J+            , not $ null rst+            , isNT pe+            , Production _ (Prod _ γ) <- prodsFor g _B+            , b <- toList $ LL.first g (β ++ tokenToProdElem a)+            ]+      in case size $ add \\ _J of+        0 -> _J `union` add+        _ -> closure' $ _J `union` add++  in closure' is'++-- | fmap over @lrstate@s of a 'LRAction'.+convAction :: (lrstate -> lrstate') -> LRAction nts sts lrstate -> LRAction nts sts lrstate'+convAction fncn (Shift state) = Shift $ fncn state+convAction _ (Reduce p) = Reduce p+convAction _ Accept = Accept+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)+  => (lrstate -> lrstate') -> LRTable nts sts lrstate -> LRTable nts sts lrstate'+convTable fncn tbl = M.fromList'+  [ ((fncn state, icon), S.map (convAction fncn) action)+  | ((state, icon), action) <- M.toList tbl+  ]++-- | 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)+  => 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)+  => (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)+  => 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)+  => [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' _ (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 g goto states = M1.fromList+  [ ((st0, e), goto st0 e)+  | st0 <- states+  , e   <- allProdElems g+  ]++-- | Get a list of all possible production elements (no epsilon) for the given grammar.+allProdElems :: Grammar () nts ts -> [ProdElem nts ts]+allProdElems g =+      map NT (S.toList $ ns g)+  ++  map T  (S.toList $ ts g)++allProdElems' :: forall nts ts. (Bounded nts, Bounded ts, Enum nts, Enum ts)+  => [ProdElem nts ts]+allProdElems' =+      map NT ([minBound .. maxBound] :: [nts])+  ++  map T  ([minBound .. maxBound] :: [ts])++-- | 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 g closure is _X = closure $ fromList+  [ Item _A (_X : α) β  a+  | Item _A α (_X' : β) a <- toList is+  , _X == _X'+  ]++-- | 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 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 g goto s0 = let+    items' :: Set (CoreLRState a nts sts) -> Set (CoreLRState a nts sts)+    items' _C = let+      add = fromList+            [ goto is _X+            | is <- toList _C+            , _X <- toList $ symbols g+            , not . null $ goto is _X+            ]+      in case size $ add \\ _C of+        0 -> _C `union` add+        _ -> items' $ _C `union` add+  in items' $ singleton s0+--  singleton (Item (Init $ s0 g) [] [NT $ s0 g])++-- | 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)+  => Set (Item a nts sts) -> Set (Item a nts sts)+kernel = let+    kernel' (Item (Init   _) _  _ _) = True+    kernel' (Item (ItemNT _) [] _ _) = False+    kernel' _ = True+  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 g = fromList+    [ Item (Init $ s0 g) [] [NT $ s0 g] ()+    , Item (Init $ s0 g) [NT $ s0 g] [] ()+    ]+  `union`+  fromList+    [ Item (ItemNT nts) (reverse $ take n γ) (drop n γ) ()+    | nts <- toList $ ns g+    , 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 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 = 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 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 g = let++    --slr' :: a -> b -> b+    --slr' :: Set Item -> Item -> LRTable -> LRTable+    --slr' :: SLRState nts sts -> SLRTable nts sts+    slr' _Ii = let+        --slr'' :: SLRItem nts sts -> SLRTable nts sts+        slr'' (Item (ItemNT nts) α (T a:β) ()) = --uPIO (prints ("TABLE:", a, slrGoto g _Ii $ T a, _Ii)) `seq`+                  [((_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 α)))+                                          | a <- (toList . LL.follow g) nts+                                          ]+        slr'' (Item (Init nts) α [] ())   = [((_Ii, IconEOF), Accept)]+        slr'' _ = []+      in concat (S.toList $ S.map slr'' _Ii)++  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 g = let+    --lr1' :: LR1State nts sts -> LRTable nts sts+    lr1' _Ii = let+        --lr1'' :: LR1Item nts sts -> LRTable nts sts+        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 (Init nts) α [] IconEOF)  = Just ((_Ii, IconEOF), Accept)+        lr1'' _ = Nothing+      in catMaybes (S.toList $ S.map lr1'' _Ii)++  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)+  => (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++-- | Is the 'LRResult' an accept?+isAccept (ResultAccept _) = True+isAccept _                = False++-- | Is this 'LRResult' an error?+isError (ResultAccept _) = False+isError _                = True++-- | Get just the LR results which accepted.+getAccepts xs = fromList [x | x <- toList xs, isAccept x]++-- | 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+  -> lrstate -> Action ast nts t+  -> [t] -> LRResult lrstate t ast+lrParse g tbl goto s_0 act w = let+  +    lr :: Config lrstate t -> [ast] -> LRResult lrstate t ast+    lr (s:states, a:ws) asts = let+        +        lr' :: LRAction nts (StripEOF (Sym t)) lrstate -> LRResult lrstate 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' (Shift t) = trace ("Shift: " ++ pshow' t) $ lr (t:s:states, ws) $ act (TermE a) : asts+        lr' (Reduce p@(Production _A (Prod _ β))) = let+              ss'@(t:_) = drop (length β) (s:states)+              result =+                case (t, NT _A) `M1.lookup` goto of+                  Nothing -> ErrorTable (s:states, a:ws) asts+                  Just s  -> lr (s : ss', a:ws) (act (NonTE (_A, β, reverse $ take (length β) asts)) : drop (length β) asts)+            in trace ("Reduce: " ++ pshow' p) result++      -- TODO: handle empty file test case+        lookVal = case stripEOF $ getSymbol a of+                    Just sym -> look (s, Icon sym) tbl+                    Nothing  -> look (s, IconEOF)  tbl++      in if S.null lookVal+          then ErrorNoAction (s:states, a: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+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++-- | 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++-- | 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 = 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 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 = 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 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 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+  -> lrstate -> Action ast nts t+  -> [t] -> LRResult lrstate t ast+glrParse' g tbl goto s_0 act w = let+  +    lr :: Config lrstate t -> [ast] -> LRResult lrstate t ast+    lr (s:states, a:ws) asts = let+        +        lr' :: LRAction nts (StripEOF (Sym t)) lrstate -> LRResult lrstate 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' (Shift t) = trace ("Shift: " ++ pshow' t) $ lr (t:s:states, ws) $ act (TermE a) : asts+        lr' (Reduce p@(Production _A (Prod _ β))) = let+              ss'@(t:_) = drop (length β) (s:states)+              result =+                case (t, NT _A) `M1.lookup` goto of+                  Nothing -> ErrorTable (s:states, a:ws) asts+                  Just s  -> lr (s : ss', a:ws) (act (NonTE (_A, β, reverse $ take (length β) asts)) : drop (length β) asts)+            in trace ("Reduce: " ++ pshow' p) result++        lookVal = case stripEOF $ getSymbol a of+                    Just sym -> look (s, Icon sym) tbl+                    Nothing  -> look (s, IconEOF)  tbl++        parseResults = S.map lr' lookVal+        justAccepts  = getAccepts parseResults++      in if S.null lookVal+          then ErrorNoAction (s:states, a:ws) asts+          else (if S.null justAccepts+                  then (case S.size parseResults of+                          0 -> undefined+                          1 -> S.findMin parseResults+                          _ -> ResultSet parseResults)+                  else ResultSet justAccepts)++  in lr ([s_0], w) []++-- | 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+  -> lrstate -> M1.Map lrstate (Set (StripEOF (Sym t))) -> Action ast nts t+  -> Tokenizer t c -> [c] -> LR1Result lrstate c ast+glrParseInc' g tbl goto s_0 tokenizerFirstSets act tokenizer w = let+    +    lr :: Config lrstate c -> [ast] -> LR1Result lrstate c ast+    lr (s:states, cs) asts = let++        -- The set of token symbols that are feasible to be seen next given the+        -- current grammar context - i.e. the Set of LR1LookAheads stripped from+        -- the current state on top of the configuration stack. Luckily enough,+        -- 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+        (a, ws) = tokenizer dfaNames cs+        +        lr' :: LR1Action nts (StripEOF (Sym t)) lrstate -> LR1Result lrstate c ast+        lr' Accept    = case length asts of+              1 -> ResultAccept $ head asts+              _ -> ErrorAccept (s:states, cs) asts+        lr' Error     = ErrorNoAction (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+              ss'@(t:_) = drop (length β) (s:states)+              result =+                case (t, NT _A) `M1.lookup` goto of+                  Nothing -> ErrorTable (s:states, cs) asts+                  Just s  -> lr (s : ss', cs) (act (NonTE (_A, β, reverse $ take (length β) asts)) : drop (length β) asts)+            in trace ("Reduce: " ++ pshow' p) result++        lookVal = case stripEOF $ getSymbol a of+                    Just sym -> look (s, Icon sym) tbl+                    Nothing  -> look (s, IconEOF)  tbl++        concatSets (ResultSet ss) ss' = ss' `S.union` ss+        concatSets r              ss' = r   `S.insert` ss'++        parseResults = S.foldr concatSets S.empty $ S.map lr' lookVal+        justAccepts  = getAccepts parseResults++      in if S.null lookVal+          then ErrorNoAction (s:states, cs) asts+          else (if S.null justAccepts+                  then (case S.size parseResults of+                          0 -> undefined+                          1 -> S.findMin parseResults+                          _ -> ResultSet parseResults)+                  else (case S.size justAccepts of+                          1 -> S.findMin justAccepts+                          _ -> ResultSet justAccepts))++  in lr ([s_0], w) []++-- | Mapping from parse states to which symbols can be seen next so that the+--   incremental tokenizer can check which DFAs to try tokenizing.+tokenizerFirstSets convState g = let+    tbl = lr1Table g++    first s = let+        removeIcons (Icon t) = Just t+        removeIcons IconEps  = Nothing+        removeIcons IconEOF  = Nothing++        itemHeads (Item (Init   nt) _ [] _) = []+        itemHeads (Item (ItemNT nt) _ [] _) = S.toList $ LL.follow g nt -- TODO: Use stack context+        itemHeads (Item _ _ (b:bs)  _)      = S.toList $ LL.first  g [b]++      in S.fromList $ mapMaybe removeIcons $ concatMap itemHeads s++  in M1.fromList [ (convState s, first $ S.toList s) | ((s, _), _) <- M.toList tbl ]++-- | Entrypoint for an incremental GLR parser.+glrParseInc g = glrParseInc' g+  (lr1Table g)+  (convGoto g (lr1Goto g) (sort $ S.toList $ lr1Items g))+  (lr1Closure g $ lr1S0 g)+  (tokenizerFirstSets id g)++-- | Incremental GLR parser with parse states compressed into integers.+glrParseInc2 g = let+    is = sort $ S.toList $ lr1Items g+    convState = convStateInt is+  in glrParseInc' g+      (convTableInt (lr1Table g) is)+      (convGotoStatesInt (convGoto g (lr1Goto g) is) is)+      (convState $ lr1Closure g $ lr1S0 g)+      (tokenizerFirstSets convState g)++-- | 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)+  => LRTable nts sts lrstate -> (LRTable' nts sts lrstate, Int)+disambiguate tbl = let++    mkConflict s = concatWith "/" $ map (show . toConstr) $ S.toList s++    mkSingle st icon s+      | S.size s == 1 = (S.findMin s, 0)+      | S.size s == 0 = D.trace ("Table entry " ++ pshow' (st,icon) ++ " has no Shift/Reduce entry.") undefined+      | otherwise     = D.trace ("Table entry " ++ pshow' (st,icon) ++ " has " ++ mkConflict s ++ " conflict: \n"+                        ++  (pshow' $ S.toList s)) (S.findMin s, 1)+  in (M1.fromList+    [ ((st, icon), fst (mkSingle st icon action))+    | ((st, icon), action) <- M.toList tbl+    ], sum+    [ snd (mkSingle st icon action)+    | ((st, icon), action) <- M.toList tbl+    ])
+ src/Text/ANTLR/Language.hs view
@@ -0,0 +1,43 @@+{-|+  Module      : Text.ANTLR.Language+  Description : Viewing a language as a set of words accepted+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Language+  ( Alphabet(..), ascii, isASCII+  ) where+import Prelude hiding (Word)+import Data.Set.Monad (Set(..))+import qualified Data.Set.Monad as Set++import Data.Char++type Alphabet a = Set a++ascii :: Alphabet Char+ascii     = Set.fromList $ map chr [0 .. 127]++isASCII :: Char -> Bool+isASCII c = ord c < 127++type Word a = [a]++type Language a = Set (Word a) ++union :: (Ord a) => Set a -> Set a -> Set a+union  = Set.union++concat :: (Ord a) => Language a -> Language a -> Language a+concat a b = Set.fromList+  [ s ++ t+  | s <- Set.toList a+  , t <- Set.toList b+  ]++kleene = undefined+
+ src/Text/ANTLR/Lex.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE FlexibleInstances, InstanceSigs, DeriveDataTypeable+    , ScopedTypeVariables #-}+{-|+  Module      : Text.ANTLR.Lex+  Description : Entrypoint for lexical and tokenization algorithms+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Lex+  ( tokenize+  , Token(..)+  , tokenName, tokenValue+  ) where++import Text.ANTLR.Lex.Tokenizer+
+ src/Text/ANTLR/Lex/Automata.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE ScopedTypeVariables, MonadComprehensions #-}+{-|+  Module      : Text.ANTLR.Automata+  Description : Automatons and algorithms as used during tokenization+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Lex.Automata where+import Text.ANTLR.Set (Set(..), member, toList, union, notMember, Hashable(..), fromList)+import qualified Text.ANTLR.Set as Set++-- | An automaton with edges @e@, symbols @s@, and state indices @i@+data Automata e s i = Automata+  { _S :: Set i                  -- ^ Finite set of states.+  , _Σ :: Set s                  -- ^ Input (edge) alphabet+  , _Δ :: Set (Transition e i)   -- ^ Transition function+  , s0 :: i                      -- ^ Start state+  , _F :: Set i                  -- ^ Accepting states+  } deriving (Eq)++instance (Eq e, Eq s, Eq i, Hashable e, Hashable s, Hashable i, Show e, Show s, Show i) => Show (Automata e s i) where+  show (Automata s sigma delta s0 f) =+    show s+    ++ "\n  Σ:  " ++ show sigma+    ++ "\n  Δ:  " ++ show delta+    ++ "\n  s0: " ++ show s0+    ++ "\n  F:  " ++ show f+    ++ "\n"++-- | Edge label of an automaton, on which we traverse if we match+--   on one of the tokens @t@ in the set. The boolean is for negation+--   of the set.+type AutomataEdge t = (Bool, Set t)++-- | A triplet with an edge alphabet of @e@ and node states of @i@.+type Transition e i = (i, AutomataEdge e, i)++-- | The from-node component of a 'Transition'+tFrom :: Transition e i -> i+tFrom (a,b,c) = a++-- | The to-node component of a 'Transition'+tTo   :: Transition e i -> i+tTo (a,b,c) = c++-- | The set of edge characters in @e@ of a 'Transition'+tEdge :: Transition e i -> Set e+tEdge (a,(comp, b),c) = b++-- | Determine the edge-label alphabet of a set of transitions.+transitionAlphabet __Δ =+  [ e+  | (_, (c, es), _) <- toList __Δ+  , e               <- es+  ]++-- | Compress a set of transitions such that every pair of (start,end) states+--   appears at most once in the set.+compress ::+  (Eq i, Eq e, Hashable i, Hashable e)+  => Set (Transition e i) -> Set (Transition e i)+compress __Δ = fromList+  [ ( a, (c, fromList [ e+             | (a', (c', es'), b') <- toList __Δ+             , a' == a && b' == b && c' == c+             , e <- toList es'+             ])+    , b)+  | (a, (c, es), b) <- toList __Δ+  ]++-- | XOR helper function over booleans.+xor a b = (not a && b) || (not b && a)++-- | Is the given transition triplet (with a single @e@ character as the edge+--   edge label) in some set of transitions? Note that we need to handle complement+--   sets here, in case the given @e@ is in the complement of one of the+--   transitions in the set.+transitionMember ::+  (Eq i, Hashable e, Eq e)+  => (i, e, i) -> Set (Transition e i) -> Bool+transitionMember (a, e, b) _Δ =+  or+      [ xor complement (e `member` es)+      | (a', (complement, es), b') <- toList _Δ+      , a' == a+      , b' == b+      ]++-- | Is the given character @s@ accepted by the given edge label?+edgeMember s (complement, es) = xor complement (s `member` es)++-- | An automaton must either 'Accept' or 'Reject'.+data Result = Accept | Reject++-- | Is the start state valid?+validStartState nfa = s0 nfa `member` _S nfa++-- | Are all of the ending states valid?+validFinalStates nfa = and [s `member` _S nfa | s <- toList $ _F nfa]++-- | Can all of the nodes as defined by the set of transitions be found+--   in the set of allowable states '_S'?+validTransitions ::+  forall e s i. (Hashable e, Hashable i, Eq e, Eq i)+  => Automata e s i -> Bool+validTransitions nfa = let+    vT :: [Transition e i] -> Bool+    vT [] = True+    vT ((s1, es, s2):rest) =+         s1 `member` _S nfa+      && s2 `member` _S nfa+      && vT rest+  in vT $ (toList . _Δ) nfa++-- | An automaton configuration is the set of state (indices) your+--   can currently be in.+type Config i = Set i++-- | Generic closure function so that *someone* never asks "what's a closure?" ever+--   again. For an epsilon-closure the given @fncn@ needs to return 'True' when+--   given an @e@ that is an epsilon, and 'False' in all other cases.+closureWith+  :: forall e s i. (Hashable e, Hashable i, Eq e, Eq i)+  => (e -> Bool) -> Automata e s i -> Config i -> Config i+closureWith fncn Automata{_S = _S, _Δ = _Δ'} states = let++    -- Check which edges are "epsilons" (or something else).+    _Δ = Set.map (\(a,(comp, b),c) -> (a, (comp, Set.map fncn b), c)) _Δ'++    cl :: Config i -> Config i -> Config i+    cl busy ss+      | Set.null ss = Set.empty+      | otherwise = let+          ret = fromList+                [ s'  | s  <- toList ss+                      , s' <- toList _S+                      , s' `notMember` busy+                      , (s, True, s') `transitionMember` _Δ ]+        in ret `union` cl (ret `union` busy) ret+  in states `union` cl Set.empty states+  --in Set.foldr (\a b -> union (cl a) b) Set.empty states++-- | Consume the @e@ character given, based on the fact that we are currently+--   in some 'Config i' of states, resulting in a new config consisting of the+--   states that we can get to by doing so.+move+  :: forall e s i. (Hashable e, Hashable i, Eq i, Eq e)+  => Automata e s i -> Config i -> e -> Config i+move Automata{_S = _S, _Δ = _Δ} _T a = fromList+  [ s'  | s  <- toList _T+        , s' <- toList _S+        , (s, a, s') `transitionMember` _Δ ]++-- | Whether or not (a, (True, _), b) is a transition in our set of transitions.+complementMember+  :: (Hashable i, Eq i, Hashable e, Eq e)+  => (i, i) -> Set (Transition e i) -> Bool+complementMember (a, b) =+  not . null . Set.filter (\(a', (c, _), b') -> a' == a && b' == b && c)++-- | Set of states you can move to if you see a character not in the alphabet.+moveComplement+  :: forall e s i. (Hashable e, Hashable i, Eq i, Eq e)+  => Automata e s i -> Config i -> Config i+moveComplement Automata{_S = _S, _Δ = _Δ} _T = fromList+  [ s'  | s  <- toList _T+        , s' <- toList _S+        , (s, s') `complementMember` _Δ ]+
+ src/Text/ANTLR/Lex/DFA.hs view
@@ -0,0 +1,23 @@+{-|+  Module      : Text.ANTLR.Lex.DFA+  Description : Deterministic finite automaton types+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Lex.DFA where+import Text.ANTLR.Lex.Automata++-- | DFA edges are just the symbols of our alphabet.+type Edge s = s++-- | DFA states are just some Eq-able value, likely integers @i@+type State i = i++-- | A DFA is an automata with edges labeled by symbols @s@ and nodes representing+--   states labeled by some type @i@.+type DFA s i = Automata (Edge s) s (State i)+
+ src/Text/ANTLR/Lex/NFA.hs view
@@ -0,0 +1,257 @@+{-# LANGUAGE ScopedTypeVariables, MonadComprehensions, DeriveAnyClass,+             DeriveGeneric #-}+{-|+  Module      : Text.ANTLR.Lex.NFA+  Description : Nondeterministic finite automatons and algorithms to compute DFAs+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Lex.NFA where+import Text.ANTLR.Lex.Automata+import Text.ANTLR.Lex.DFA (DFA(..))+import qualified Text.ANTLR.Lex.DFA as DFA++import Text.ANTLR.Set (singleton, notMember, union, Set(..), member, Hashable)+import qualified Text.ANTLR.Set as Set+import Text.ANTLR.Set (fromList, toList)++import Data.List (maximumBy)+import GHC.Generics (Generic)++-- | NFA edges can be labeled with either a symbol in symbol alphabet @s@,+--   or an epsilon.+data Edge s = Edge s | NFAEpsilon+  deriving (Ord, Eq, Hashable, Generic)++instance (Show s) => Show (Edge s) where+  show NFAEpsilon = "ϵ"+  show (Edge s)   = "E(" ++ show s ++ ")"++-- | Is this an edge (not an epsilon)?+isEdge :: Edge s -> Bool+isEdge (Edge _) = True+isEdge _        = False++-- | An NFA is an automata with edges @'Edge' s@ and nodes @i@.+type NFA s i = Automata (Edge s) s i++-- | NFA states+type State i = i++-- | DFA states as constructed from an NFA is a set (config) of NFA states.+type DFAState i = Config (State i)++-- | Epsilon closure of an NFA is a closure where we can traverse epsilons.+epsClosure ::+  (Ord i, Hashable i, Hashable s, Eq s)+  => Automata (Edge s) s i -> Config i -> Config i+epsClosure = closureWith (NFAEpsilon ==)++-- | Subset construction algorithm for constructing a DFA from an NFA.+nfa2dfa_slow :: forall s i. (Hashable s, Eq s, Hashable i, Eq i, Ord i)+  => NFA s i -> DFA s (Set (State i))+nfa2dfa_slow nfa@Automata{s0 = s0, _Σ = _Σ, _F = _F0} = let+    +    epsCl = epsClosure nfa+    mv    = move nfa++    dS :: Config (DFAState i) -> Config (DFAState i) -> Set (Transition (DFA.Edge s) (DFAState i))+    dS marked ts+      | Set.null ts = Set.empty+      | otherwise = let+        +          _Δ  = fromList+                [ (_T, (False, singleton a), epsCl (mv _T (Edge a)))+                | _T <- toList ts+                , _T `notMember` marked+                , a  <- toList _Σ+                ]++          _Us = Set.map (\(a,b,c) -> c) _Δ+          fromStates = Set.map (\(a,b,c) -> a) _Δ++        in _Δ `union` dS (fromStates `union` marked) _Us+    +    _Δ' :: Set (Transition (DFA.Edge s) (DFAState i))+    _Δ' = dS Set.empty (singleton s0')++    s0' = epsCl $ singleton s0++  in Automata+      { _S = fromList [ tFrom x | x <- toList _Δ' ] `union` fromList [ tTo x | x <- toList _Δ' ]+      , _Σ = _Σ+      , _Δ = _Δ'+      , s0 = s0'+      , _F = fromList [nfaState | (_,_,nfaState) <- toList _Δ', c <- toList nfaState, c `member` _F0]+      }++-- | Subset construction but where we compress our sets of transitions along the way.+nfa2dfa :: forall s i. (Hashable s, Eq s, Hashable i, Eq i, Ord i)+  => NFA s i -> DFA s (Set (State i))+nfa2dfa nfa@Automata{s0 = s0, _Σ = _Σ, _S = _S, _F = _F0} = let+    +    epsCl = epsClosure nfa+    mv    = move nfa++    dS :: Config (DFAState i) -> Config (DFAState i) -> Set (Transition (DFA.Edge s) (DFAState i))+    dS marked ts+      | Set.null ts = Set.empty+      | otherwise = let+        +          _Δ  =+            Set.fromList+                [ (_T, (False, singleton a), epsCl (mv _T (Edge a)))+                | _T <- Set.toList ts+                , _T `notMember` marked+                , a  <- Set.toList _Σ+                ]+            `union`+            Set.fromList+                [ (_T, (True, _Σ), epsCl $ moveComplement nfa _T)+                | _T <- Set.toList ts+                , _T `notMember` marked+                ]++          _Us = fromList [ c | (a,b,c) <- toList _Δ ]+          fromStates = fromList [ a | (a,b,c) <- toList _Δ ]++        in _Δ `union` dS (fromStates `union` marked) _Us+    +    _Δ' :: Set (Transition (DFA.Edge s) (DFAState i))+    _Δ' = let run_dS = dS Set.empty (singleton s0')+          in  Set.filter (\(_, _, b) -> not $ Set.null b) $ compress run_dS++    s0' = epsCl $ singleton s0++  in Automata+      { _S = fromList [ tFrom x | x <- toList _Δ' ] `union` fromList [ tTo x | x <- toList _Δ' ]+      , _Σ = _Σ+      , _Δ = _Δ'+      , s0 = s0'+      , _F = fromList [nfaState | (_,_,nfaState) <- toList _Δ', c <- toList nfaState, c `member` _F0]+      }++-- | Compute all the states statically used in a particular set of transitions.+allStates :: forall s i. (Hashable i, Eq i) => Set (Transition (Edge s) i) -> Set (State i)+allStates ts = fromList [ n | (n, _, _) <- toList ts ] `union` fromList [ n | (_, _, n) <- toList ts ]++-- | Converts the given list of transitions into a complete NFA / Automata+--   structure, assuming two things:+--+-- > The first node of the first edge is the start state+-- > The last  node of the last  edge is the (only) final state+--+list2nfa :: forall s i. (Hashable i, Eq i, Hashable s, Eq s) => [Transition (Edge s) i] -> NFA s i+list2nfa [] = undefined+list2nfa ((t@(n1,_,_)):ts) = Automata+  { _S = allStates $ Set.fromList (t:ts)+  , _Σ = Set.fromList [ e+          | (_, es, _) <- t:ts+          , Edge e     <- filter isEdge (Set.toList $ snd es)+          ]+  , s0 = n1+  , _F = Set.fromList [ (\(_,_,c) -> c) $ last (t:ts) ]+  , _Δ = Set.fromList $ t:ts+  }++-- | Rename the states in the second NFA such that they start at the index+--   one greater than the maximum index of the first NFA.+shiftAllStates ::+  forall s i. (Hashable i, Eq i, Ord i, Hashable s, Eq s)+  => (i -> Int) -> (Int -> i) -> NFA s i -> NFA s i -> NFA s i+shiftAllStates from to+  n1 (n2@Automata{_Δ = _Δ2, _S = _S2, _F = _F2, s0 = s2_0})+  = n2 { _Δ = fromList [ (to $ from i0 + shift, e, to $ from i1 + shift) | (i0, e, i1) <- toList _Δ2 ]+       , _S = fromList [ to $ from i + shift | i <- toList _S2 ]+       , _F = fromList [ to $ from i + shift | i <- toList _F2 ]+       , s0 = to $ from s2_0 + shift+       }+  where+    shift = 1 + foldr (\(i0, _, i1) i -> from $ maximum [to i, i0, i1]) 0 (_Δ n1)++-- | Take the union of two NFAs, renaming states according to 'shiftAllStates'.+nfaUnion ::+  forall s i. (Ord i, Hashable i, Eq i, Hashable s, Eq s)+  => (i -> Int) -> (Int -> i) -> NFA s i -> NFA s i -> NFA s i+nfaUnion from to+  (n1@Automata{_Δ = _Δ1, _S = _S1, _F = _F1, s0 = s1_0}) n2+  = let++    Automata{_Δ = _Δ2, _S = _S2, _F = _F2, s0 = s2_0} = shiftAllStates from to n1 n2+    mx2 = 1 + foldr (\(i0, _, i1) i -> from $ maximum [to i, i0, i1]) 0 _Δ2++    _Δ' =     _Δ1+      `union` _Δ2+      `union` Set.singleton (s0', (False, singleton NFAEpsilon), s1_0)+      `union` Set.singleton (s0', (False, singleton NFAEpsilon), s2_0)+      `union` fromList [ (f1_0, (False, singleton NFAEpsilon), f0') | f1_0 <- toList _F1 ]+      `union` fromList [ (f2_0, (False, singleton NFAEpsilon), f0') | f2_0 <- toList _F2 ]++    s0' = to mx2+    f0' = to $ mx2 + 1++  in Automata+    { _S = allStates _Δ'+    , _Σ =  fromList [ e+            | (_, es, _)  <- toList _Δ'+            , Edge e      <- toList $ Set.filter isEdge $ snd es+            ]+    , s0 = s0'+    , _F = Set.fromList [f0']+    , _Δ = _Δ'+    }++-- | Concatenate two NFAs, renaming states in the second NFA according to 'shiftAllStates'.+nfaConcat ::+  forall s i. (Hashable i, Eq i, Ord i, Hashable s, Eq s) => (i -> Int) -> (Int -> i) -> NFA s i -> NFA s i -> NFA s i+nfaConcat from to+  (n1@Automata{_Δ = _Δ1, _S = _S1, _F = _F1, s0 = s1_0}) n2+  = let+    Automata{_Δ = _Δ2, _S = _S2, _F = _F2, s0 = s2_0} = shiftAllStates from to n1 n2+    +    _Δ' =     _Δ1+      `union` _Δ2+      `union` fromList [ (f1_0, (False, singleton NFAEpsilon), s2_0) | f1_0 <- toList _F1 ]+  +  in Automata+    { _S = allStates _Δ'+    , _Σ =  fromList [ e+            | (_, es, _)  <- toList _Δ'+            , Edge e      <- toList $ Set.filter isEdge $ snd es+            ]+    , s0 = s1_0+    , _F = _F2+    , _Δ = _Δ'+    }++-- | Take the Kleene-star of an NFA, adding epsilons as needed.+nfaKleene :: forall s i. (Ord i, Hashable i, Eq i, Hashable s, Eq s) => (i -> Int) -> (Int -> i) -> NFA s i -> NFA s i+nfaKleene from to +  (n1@Automata{_Δ = _Δ1, _S = _S1, _F = _F1, s0 = s1_0})+  = let+    mx1 = 1 + foldr (\(i0, _, i1) i -> from $ maximum [to i, i0, i1]) 0 _Δ1++    s0' = to mx1+    f0' = to $ mx1 + 1++    _Δ' =     _Δ1+      `union` Set.singleton (s0', (False, singleton NFAEpsilon), s1_0)+      `union` Set.singleton (s0', (False, singleton NFAEpsilon), f0')+      `union` fromList [ (f1_0, (False, singleton NFAEpsilon), s1_0) | f1_0 <- toList _F1 ]+      `union` fromList [ (f1_0, (False, singleton NFAEpsilon), f0')  | f1_0 <- toList _F1 ]++  in Automata+    { _S = allStates _Δ'+    , _Σ =  fromList [ e+            | (_, es, _)  <- toList _Δ'+            , Edge e      <- toList $ Set.filter isEdge $ snd es+            ]+    , s0 = s0'+    , _F = Set.fromList [f0']+    , _Δ = _Δ'+    }+
+ src/Text/ANTLR/Lex/Regex.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE ScopedTypeVariables, DeriveLift #-}+{-|+  Module      : Text.ANTLR.Lex.Regex+  Description : Regular expressions as used during tokenization+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Lex.Regex where++import Text.ANTLR.Set (Hashable, singleton, fromList)+import Text.ANTLR.Lex.NFA+import qualified Text.ANTLR.Lex.DFA as DFA+import Language.Haskell.TH.Syntax (Lift(..))++-- | Regular expression data representation as used by the tokenizer.+data Regex s =+    Epsilon                         -- ^ Regex accepting the empty string+  | Symbol     s                    -- ^ An individual symbol in the alphabet+  | Literal    [s]                  -- ^ A literal sequence of symbols (concatenated together)+  | Class      [s]                  -- ^ A set of alternative symbols (unioned together)+  | Union      (Regex s) (Regex s)  -- ^ Union of two arbitrary regular expressions+  | Concat     [Regex s]            -- ^ Concatenation of 2 or more regular expressions+  | Kleene     (Regex s)            -- ^ Kleene closure of a regex+  | PosClos    (Regex s)            -- ^ Positive closure+  | Question   (Regex s)            -- ^ 0 or 1 instances+  | MultiUnion [Regex s]            -- ^ Union of two or more arbitrary regexs+  | NotClass   [s]                  -- ^ Complement of a character class+  deriving (Lift)++instance (Show s) => Show (Regex s) where+  show Epsilon       = "ϵ"+  show (Symbol s)    = show s+  show (Literal s)   = show s+  show (Class s)     = "[" ++ show s ++ "]"+  show (Union r1 r2) = "(" ++ show r1 ++ "|" ++ show r2 ++ ")"+  show (Concat rs)   = concatMap show rs+  show (Kleene r)    = "(" ++ show r ++ ")*"+  show (PosClos r)   = "(" ++ show r ++ ")+"+  show (Question r)  = "(" ++ show r ++ ")?"+  show (MultiUnion rs) = tail $ concatMap (\r -> "|" ++ show r) rs+  show (NotClass rs)   = "[^" ++ tail (concatMap show rs) ++ "]"++-- | Translation code of a regular expresion to an NFA.+regex2nfa' ::+  forall s i. (Hashable i, Ord i, Hashable s, Eq s)+  => (i -> Int) -> (Int -> i) -> Regex s -> NFA s i+regex2nfa' from to r = let+    r2n :: Regex s -> NFA s i+    r2n Epsilon         = list2nfa [ (to 0, (False, singleton   NFAEpsilon), to 1) ]+    r2n (Symbol s)      = list2nfa [ (to 0, (False, singleton $ Edge s),     to 1) ]+    r2n (Union r1 r2)   = nfaUnion   from to (r2n r1) (r2n r2)+    r2n (Concat [])     = r2n Epsilon -- TODO: empty concat +    r2n (Concat (r:rs)) = foldl (nfaConcat  from to) (r2n r) (map r2n rs)+    r2n (Kleene r1)     = nfaKleene  from to (r2n r1)+    r2n (PosClos r1)    = r2n $ Concat [r1, Kleene r1]+    r2n (Question r1)   = nfaUnion from to (r2n r1) (r2n Epsilon)+    r2n (Class [])      = r2n Epsilon -- TODO: empty character class shouldn't accept empty string?+    r2n (Class (s:ss))  = list2nfa [ (to 0, (False, fromList $ map Edge $ s:ss), to 1) ] --r2n $ foldl Union (Symbol s) (map Symbol ss)+    r2n (MultiUnion []) = r2n Epsilon+    r2n (MultiUnion (r:rs)) = r2n $ foldl Union r rs+    r2n (Literal ss)    = list2nfa $ map (\(s,i) -> (to i, (False, singleton $ Edge s), to $ i + 1)) (zip ss [0..length ss - 1])+    r2n (NotClass [])     = list2nfa $ [ (to 0, (True, fromList []), to 1) ] -- Not nothing = everything+    r2n (NotClass (s:ss)) = list2nfa $ [ (to 0, (True, fromList $ map Edge $ s:ss), to 1) ]+  in r2n r ++-- | Entrypoint for translating a regular expression into an 'NFA' with integer indices.+regex2nfa :: (Hashable s, Ord s) => Regex s -> NFA s Int+regex2nfa = regex2nfa' id id++-- | Entrypoint for translating a regular expression into a 'DFA.DFA' with integer indices.+regex2dfa :: (Hashable s, Ord s) => Regex s -> DFA.DFA s (DFAState Int)+regex2dfa = nfa2dfa . regex2nfa+
+ src/Text/ANTLR/Lex/Tokenizer.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE ScopedTypeVariables, DeriveGeneric, DeriveAnyClass+  , OverloadedStrings #-}+{-|+  Module      : Text.ANTLR.Lex.Tokenizer+  Description : Tokenization algorithms+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Lex.Tokenizer where+import Text.ANTLR.Lex.Automata+import Text.ANTLR.Lex.DFA++import qualified Text.ANTLR.Set as Set+import Text.ANTLR.Set (Hashable, member, Generic(..), Set(..))++import Text.ANTLR.Pretty+import qualified Debug.Trace as D+import Data.List (find)+import qualified Data.Text as T++-- | Token with names @n@, values @v@, and number of input symbols consumed to match+--   it.+data Token n v =+    Token n v Int  -- ^ Tokenized a token+  | EOF            -- ^ The end-of-file token+  | Error T.Text   -- ^ Error encountered while tokenizing+  deriving (Show, Ord, Generic, Hashable)++instance (Prettify n, Prettify v) => Prettify (Token n v) where+  prettify EOF = pStr "EOF"+  prettify (Error s) = pStr "Token Error: " >> pStr s+  prettify (Token n v i) =+    prettify v++instance Eq n => Eq (Token n v) where+  Token s _ _ == Token s1 _ _ = s == s1+  EOF         == EOF          = True+  Error s     == Error s1     = s == s1+  _           == _            = False++-- | Token Names are Input Symbols to the parser.+tokenName :: Token n v -> n+tokenName (Token n v _) = n++-- | Get the value of a token, ignoring its name.+tokenValue :: Token n v -> v+tokenValue (Token n v _) = v++-- | Get the number of characters from the input that this token matched on.+tokenSize :: Token n v -> Int+tokenSize (Token _ _ i) = i+tokenSize EOF = 0++-- | A Lexeme is a sequence of zero or more (matched) input symbols+type Lexeme s = [s]++-- | A named DFA over symbols @s@, indices @i@, and names @n@.+type NDFA s i n = (n, DFA s i)++-- | Entrypoint for tokenizing an input stream given a list of named DFAs that+--   we can match on.+--   +--   > @dfaTuples@: converts from DFAs to the names associated with them in+--     the specification of the lexer.+--+--   > @fncn@: function for constructing the value of a token from the lexeme+--     matched (e.g. @varName@) and the associated token name (e.g. @id@)+--+tokenize ::+  forall s i n v. (Eq i, Ord s, Eq s, Show s, Show i, Show n, Show v, Hashable i, Hashable s)+  => [(n, DFA s i)]       -- ^ Association list of named DFAs.+  -> (Lexeme s -> n -> v) -- ^ Constructs the value of a token from lexeme matched.+  -> [s]                  -- ^ The input string.+  -> [Token n v]          -- ^ The tokenized tokens.+tokenize dfaTuples fncn input0 = let++    dfas0 = map snd dfaTuples++    allTok :: [(NDFA s i n, State i)] -> [s] -> [Token n v]+    allTok dfaSims0 currInput = let+        oneTok :: [(NDFA s i n, State i)] -> [s] -> Maybe (Lexeme s, NDFA s i n)+        oneTok dfaSims []     = Nothing+        oneTok []      ss     = Nothing+        oneTok dfaSims (s:ss) = let+            dfaSims' =+              [ ((n, dfa), stop)+              | ((n, dfa), cursor)     <- dfaSims+              , (start, es, stop) <- Set.toList $ _Δ dfa+              , start == cursor && s `edgeMember` es ]++            accepting = [ (n,dfa) | ((n, dfa), cursor) <- dfaSims', cursor `member` _F dfa ]++          in (case (oneTok dfaSims' ss, accepting) of+              (Nothing, [])   -> Nothing+              (Nothing, d:ds) -> Just ([s], d)+              (Just (l,d), _) -> Just (s:l, d))+      in case (currInput, oneTok dfaSims0 currInput) of+          ([], _)       -> [EOF]+          (ss, Nothing) -> [Error $ T.pack $ show ss]+          (ss, Just (l, (name,d))) ->+            Token name (fncn l name) (length l)+            : allTok dfaSims0 (drop (length l) currInput)+  in allTok (zip dfaTuples (map s0 dfas0)) input0++-- | Incremental tokenizer takes in the same list of DFAs and AST value+--   constructor function, but instead returns an incremental tokenizer function+--   that expects a set of names that we currently expect to tokenize on,+--   the current input stream, and returns a single tokenized token along+--   with the modified input stream to iteratively call 'tokenizeInc' on.+tokenizeInc+  :: 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)]                      -- ^ Closure over association list of named DFAs.+  -> (Lexeme s -> n -> v)                -- ^ Token value constructor from lexemes.+  -> (Set n -> [s] -> (Token n v, [s]))  -- ^ The incremental tokenizer closure.+tokenizeInc 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+      +      in (next, drop (sum $ map tokenSize $ next : ignored) input)+  in tI+
+ src/Text/ANTLR/MultiMap.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, MonadComprehensions, DeriveLift,+      DeriveDataTypeable #-}+{-|+  Module      : Text.ANTLR.MultiMap+  Description : A one-to-many key value map+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.MultiMap where+import qualified Data.Map.Strict as M+import Data.Maybe (fromMaybe)+import Text.ANTLR.Set (Generic(..), Hashable(..), Set(..))+import qualified Text.ANTLR.Set as S+import Prelude hiding (lookup)+import Text.ANTLR.Pretty++import Data.Data (Data(..))+import Language.Haskell.TH.Syntax (Lift(..))++instance (Lift k, Lift v, Data k, Data v, Ord k, Ord v) => Lift (M.Map k v)++-- | A multi 'Map' is a mapping from keys @k@ to sets of values @v@. A nice+--   invariant to maintain while using a multi-map is to never have empty+--   sets mapped to by some key.+newtype Map k v = Map (M.Map k (Set v))+  deriving (Generic, Hashable, Eq, Show, Lift)++instance (Prettify k, Prettify v, Hashable v, Eq v) => Prettify (Map k v) where+  prettify (Map m) = prettify m++-- | The singleton multimap, given a single key and a __single__ value.+singleton :: (Hashable v, Eq v) => k -> v -> Map k v+singleton k v = Map (M.singleton k (S.singleton v))++-- | Construct a multi 'Map' from a list of key-value pairs.+fromList :: (Hashable v, Ord k, Eq k, Eq v) => [(k, v)] -> Map k v+fromList kvs = Map (M.fromList+  [ (k1, S.fromList [v2 | (k2, v2) <- kvs, k1 == k2])+  | (k1, _) <- kvs])++-- | Same as 'fromList' but where the values in the key-value tuples are already in sets.+fromList' :: (Ord k, Eq k, Hashable v, Eq v) => [(k, Set v)] -> Map k v+fromList' kvs = fromList [(k, v) | (k, vs) <- kvs, v <- S.toList vs]++-- | Inverse of 'fromList\''.+toList :: Map k v -> [(k, Set v)]+toList (Map m) = M.toList m++-- | Take the union of two maps.+union :: (Ord k, Eq k, Hashable v, Eq v) => Map k v -> Map k v -> Map k v+union m1 m2 = fromList' (toList m1 ++ toList m2)++-- | The empty multi-map.+empty :: Map k v+empty = Map M.empty++-- | Get the set of values mapped to by some key @k@.+lookup :: (Ord k, Hashable v, Eq v) => k -> Map k v -> Set v+lookup k (Map m) = fromMaybe S.empty (M.lookup k m)++-- | Number of keys in the multi-map.+size (Map m) = M.size m++-- | Map difference of two multi-maps, deleting individual key-value pairs+--   rather than deleting the entire key. Invariant maintained is that+--   input maps with non-null value sets will result in an output with+--   non-null value sets.+difference (Map m1) m2 = Map $ M.fromList+  [ (k1, vs)+  | (k1, vs1) <- M.toList m1+  , let vs2 = k1 `lookup` m2+  , let vs  = vs1 `S.difference` vs2+  , (not . S.null) vs+  ]+
+ src/Text/ANTLR/Parser.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass, FlexibleContexts, InstanceSigs+           , UndecidableInstances, StandaloneDeriving, TypeFamilies+           , ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses+           , OverloadedStrings, DeriveDataTypeable #-}+{-|+  Module      : Text.ANTLR.Parser+  Description : Parsing API for constructing Haskell data types from lists of tokens+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Parser where+import Text.ANTLR.Grammar hiding (Action)+import Text.ANTLR.Pretty+import Text.ANTLR.Set (Generic(..))+import Text.ANTLR.Lex.Tokenizer (Token(..))+import Data.Data (Data(..))+import Language.Haskell.TH.Lift (Lift(..))+import Text.ANTLR.Set (Hashable)++-- | 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.+--+--   A 'ParseEvent' may also be just a terminal matched on, or an epsilon event+--   based heavily on which parsing algorithm is being run.+--+--   __This__ data type is one of the data types that tie together terminal (token) types+--   and terminal symbol types. When the parser produces a terminal event, you're+--   seeing a __token__, but when the parser produces a nonterminal event, you're+--   seeing a production in the grammar firing which contains terminal __symbols__,+--   not tokens.+data ParseEvent ast nts t =+    TermE t -- ^ A terminal was seen in the input+  | NonTE (nts, ProdElems nts (StripEOF (Sym t)), [ast]) -- ^ A non-terminal was seen in the input+  | EpsE -- ^ Epsilon event++deriving instance (Show ast, Show nts, Show (StripEOF (Sym t)), Show t) => Show (ParseEvent ast nts t)++instance (Prettify ast, Prettify nts, Prettify (StripEOF (Sym t)), Prettify t) => Prettify (ParseEvent ast nts t) where+  prettify e = do+    pStr "Terminal Event: "+    incrIndent 2+    prettify e+    incrIndent (-2)++-- | An Action as seen by the host language (Haskell) is a function from parse+--   events to an abstract-syntax tree that the function constructs based on which+--   non-terminal or terminal symbol was seen.+type Action ast nts t = ParseEvent ast nts t -> ast++-- | An Icon (as used in first and follow sets of the LL1 parser and the+--   shift-reduce table of the LR1 parser) is just a terminal symbol taken from+--   the grammar, or it's an epsilon or EOF.+data Icon ts =+    Icon ts  -- ^ Terminal symbol icon+  | IconEps  -- ^ Epsilon icon+  | IconEOF  -- ^ EOF (end of file / input) icon+  deriving (Generic, Hashable, Show, Eq, Ord, Data, Lift)++-- | __This__ is the function defining the (n == Sym t == ts) relationship between+--   the __name__ type of a token, the __symbol__ type of a terminal token (as+--   constructed by the tokenizer), and the __terminal symbol__ type as used by the+--   parser. When a parser wants to compare the symbol of an input token to a+--   terminal symbol found in the grammar, it should convert the token to an icon+--   using this function and then compare icons using Eq because icons throw away+--   the value of a token, leaving only the Eq-able piece that we care about.+token2symbol :: Token n v -> TokenSymbol n+token2symbol (Token n v _) = TokenSymbol n+token2symbol EOF = EOFSymbol+token2symbol (Error s) = EOFSymbol++-- | Tokens are symbolized by an icon containing their name.+instance Ref (Token n v) where+  type Sym (Token n v) = TokenSymbol n+  getSymbol = token2symbol++-- | The symbol for some tokenize is either just it's name @n@ or the special EOF symbol.+data TokenSymbol n =+    TokenSymbol n  -- ^ Named symbol+  | EOFSymbol      -- ^ End-of-file symbol+  deriving (Eq, Ord, Show, Hashable, Generic)++-- | A data type with an EOF constructor. There are two things you can do with a+--   data type that has an EOF:+--+-- > Ask for the type *without* the EOF at compile time+-- > Ask whether or not an instance is the EOF symbol at runtime+--+class HasEOF t where+  -- | The unwrapped type (without the EOF data constructor alternative)+  type StripEOF t :: *+  -- | Whether or not the given value of type t is the EOF value+  isEOF :: t -> Bool+  -- | Take a token and try to unwrap its name (an EOF should result in Nothing)+  stripEOF :: t -> Maybe (StripEOF t)++instance HasEOF (TokenSymbol n) where+  type StripEOF (TokenSymbol n) = n++  isEOF EOFSymbol = True+  isEOF     _     = False++  stripEOF EOFSymbol       = Nothing+  stripEOF (TokenSymbol n) = Just n++instance HasEOF String where+  type StripEOF String = String+  +  isEOF "" = True+  isEOF _  = False++  stripEOF "" = Nothing+  stripEOF x  = Just x++instance (Prettify ts) => Prettify (Icon ts) where+  prettify IconEps  = pStr "iϵ"+  prettify IconEOF  = pStr "iEOF"+  prettify (Icon ts) = do+    pStr "Icon "+    prettify ts++-- | Is this a terminal-symbol icon?+isIcon Icon{} = True+isIcon _ = False++-- | Is this an epsilon icon?+isIconEps IconEps = True+isIconEps _    = False++-- | Is this the EOF icon?+isIconEOF IconEOF = True+isIconEOF _   = False++-- | Universal Abstract Syntax Tree data type. All internal AST "nodes" have a+--   nonterminal, the grammar production symbols it reduced from, and the+--   resulting recursively defined AST nodes acquired from the parser. Leaf AST+--   nodes can be either an epsilon (when explicit epsilons are used in the+--   grammar) or more importantly a terminal symbol.+--   __This__ is another type that defines the relationship between the terminal+--   token type @t@ and the terminal symbol type @(ts == Sym t)@ where the AST tells+--   you the production rule that fired containing @ts@ as well as the tokens @t@+--   contained in leaves of the AST.+data AST nts t =+    LeafEps -- ^ Epsilon leaf AST node+  | Leaf t  -- ^ Terminal token leaf in the AST+  | AST nts (ProdElems nts (StripEOF (Sym t))) [AST nts t] -- ^ Internal AST node+  deriving (Generic)++deriving instance (Eq (StripEOF (Sym t)), Eq nts, Eq t) => Eq (AST nts t)+deriving instance (Ord (StripEOF (Sym t)), Ord nts, Ord t) => Ord (AST nts t)+deriving instance (Show (StripEOF (Sym t)), Show nts, Show t) => Show (AST nts t)+deriving instance (Hashable (StripEOF (Sym t)), Hashable nts, Hashable t) => Hashable (AST nts t)++instance (Prettify nts, Prettify t) => Prettify (AST nts t) where+  prettify LeafEps  = pStr "ϵ"+  prettify (Leaf t) = prettify t+  prettify (AST nts ps asts) = do+    prettify nts+    pStr "{"+    prettify asts+    pStr "}"++-- | Default AST-constructor function which just copies over the contents of+--   some parse event into an 'AST'.+event2ast :: ParseEvent (AST nts t) nts t -> AST nts t+event2ast (TermE t)               = Leaf t+event2ast (NonTE (nts, ss, asts)) = AST nts ss asts+
+ src/Text/ANTLR/Pretty.hs view
@@ -0,0 +1,263 @@+{-# LANGUAGE FlexibleInstances, DefaultSignatures, UndecidableInstances+    , OverloadedStrings #-}+{-|+  Module      : Text.ANTLR.Pretty+  Description : A pretty-printing type class to be used across antlr-haskell modules+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++  I want to have something like Show whereby every time I add a new type to the+  system, I can implement a function that gets called by existing code which+  happens to have types that get parametrized by that type. I don't want to+  modify an existing file / centralizing all of the types in my system into a+  single file makes little sense because then that one file becomes a hub /+  single point of failure.++  * I need a typeclass (no modifying existing files, but they need to call my+  new code without passing around a new show function)++  * The prettify function of that typeclass needs to return a state monad so+  that recursive calls keep the state++  * A pshow function needs to evalState on the prettify function with an+  initial indentation of zero (along with any other future state values...)++-}+module Text.ANTLR.Pretty where+import Control.Monad.Trans.State.Lazy+import qualified Data.Map.Strict as M+import Data.Data (toConstr, Data(..))++import qualified Data.Text as T++-- | Pretty-printing state+data PState = PState+  { indent   :: Int     -- ^ current indentation level+  , vis_chrs :: Int     -- ^ number of visible characters consumed so far+  , str :: T.Text       -- ^ the string, 'T.Text', that we've constructed so far+  , columns_soft :: Int -- ^ soft limit on number of columns to consume per row+  , columns_hard :: Int -- ^ hard limit on number of columns to consume per row+  , curr_col :: Int     -- ^ column number we're on in the current row of 'str'+  , curr_row :: Int     -- ^ number of rows (newlines) we've printed to 'str'+  }++-- | The pretty state monad+type PrettyM val = State PState val++-- | No value being threaded through the monad (because result is in 'str')+type Pretty = PrettyM ()++-- | Define the 'Prettify' type class for your pretty-printable type @t@.+class Prettify t where+  {-# MINIMAL prettify #-}++  -- | Defines how to pretty-print some type.+  prettify :: t -> Pretty+  default prettify :: (Show t) => t -> Pretty+  prettify = rshow++  -- | Lists are pretty-printed specially.+  prettifyList :: [t] -> Pretty+  prettifyList = prettifyList_++-- | Initial Pretty state with safe soft and hard column defaults.+initPState = PState+  { indent       = 0   -- Indentation level+  , vis_chrs     = 0   -- Number of visible characters consumed.+  , str          = T.empty -- The string+  , columns_soft = 100  -- Soft limit on terminal width.+  , columns_hard = 120  -- Hard limit on terminal width.+  , curr_col     = 0   -- Column position in the current row.+  , curr_row     = 0   -- Number of newlines seen+  }++-- | Prettify a string by putting it on the end of the current string state+pLine :: T.Text -> Pretty+pLine s = do+  pStr s+  _pNewLine++-- | Pretty print a literal string by just printing the string.+pStr' :: String -> Pretty+pStr' = pStr . T.pack++-- | This currently assumes all input strings contain no newlines, and that this is+--   only called on relatively small strings because strings running over the end+--   of the hard column limit get dumped onto the next line __no matter what__.+--   T.Texts can run over the soft limit, but hitting the soft limit after a call+--   to 'pStr' forces a newline.+pStr :: T.Text -> Pretty+pStr s = do+  pstate <- get+  _doIf _pNewLine (T.length s + curr_col pstate > columns_hard pstate && curr_col pstate /= 0)+  pstate <- get+  _doIf _pIndent  (curr_col pstate == 0 && indent pstate > 0)+  pstate <- get+  put $ pstate+    { str = T.append (str pstate) s+    , curr_col = (curr_col pstate) + T.length s+    }+  pstate <- get+  _doIf _pNewLine (curr_col pstate > columns_soft pstate)++-- | Print a single character to the output.+pChr :: Char -> Pretty+pChr c = pStr $ T.singleton c++-- | Gets rid of if-then-else lines in the Pretty monad code:+_doIf fncn True  = fncn+_doIf fncn False = return ()++-- | Indent by the number of spaces specified in the state.+_pIndent :: Pretty+_pIndent = do+  pstate <- get+  put $ pstate+    { str      = str pstate `T.append` T.replicate (indent pstate) (T.singleton ' ')+    , curr_col = curr_col pstate + indent pstate+    , vis_chrs = vis_chrs pstate + indent pstate+    }++-- | Insert a newline+_pNewLine :: Pretty+_pNewLine = do+  pstate <- get+  put $ pstate+    { str = T.snoc (str pstate) '\n'+    , curr_col = 0+    , curr_row = curr_row pstate + 1+    }++-- | Run the pretty-printer, returning a 'T.Text'.+pshow :: (Prettify t) => t -> T.Text+pshow t = str $ execState (prettify t) initPState++-- | Run the pretty-printer, returning a 'String'.+pshow' :: (Prettify t) => t -> String+pshow' = T.unpack . pshow++-- | 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 }++-- | Plain-vanilla show of something in the 'Pretty' state monad.+rshow :: (Show t) => t -> Pretty+rshow t = do+  pstate <- get+  let s = show t+  put $ pstate+    { str      = str pstate `T.append` T.pack s+    , curr_row = curr_row pstate + (T.length . T.filter (== '\n')) (T.pack s)+    , curr_col = curr_col pstate -- TODO+    }++-- | Parenthesize something in 'Pretty'.+pParens fncn = do+  pChr '('+  fncn+  pChr ')'++-- | Increment the indentation level by modifying the pretty-printer state.+incrIndent :: Int -> Pretty+incrIndent n = do+  pstate <- get+  put $ pstate { indent = indent pstate + n }++-- | Like 'incrIndent' but set indentation level instead of incrementing.+setIndent :: Int -> Pretty+setIndent n = do+  pstate <- get+  put $ pstate { indent = n }++-- | Prettify the given value and compute the number of characters consumed as a+--   result.+pCount :: (Prettify v) => v -> PrettyM Int+pCount v = do+  i0 <- indent <$> get+  prettify v+  i1 <- indent <$> get+  return (i1 - i0)++-- | Pretty-print a list with one entry per line.+pListLines :: (Prettify v) => [v] -> Pretty+pListLines vs = do+  pStr $ T.pack "[ "+  col0 <- curr_col <$> get+  i0   <- indent   <$> get+  setIndent (col0 - 2)+  sepBy (pLine T.empty >> (pStr $ T.pack ", ")) (map prettify vs)+  pLine T.empty >> pChr ']'+  setIndent i0 -- Reset indentation back to what it was++instance (Prettify k, Prettify v) => Prettify (M.Map k v) where+  prettify m = do+    -- (5 == length of "Map: ") ==> TODO: indentation "discipline"+    pStr "Map: "; incrIndent 5+    prettify $ M.toList m -- TODO: prettier map+    incrIndent (-5)++instance (Prettify v) => Prettify (Maybe v) where+  prettify Nothing  = pStr "Nope"+  prettify (Just v) = pStr "Yep" >> pParens (prettify v)++-- | Prettify a list with possibly more than one entry per line.+prettifyList_ [] = pStr "[]"+prettifyList_ vs = do+  pChr '['+  sepBy (pStr ", ") (map prettify vs)+  pChr ']'++instance (Prettify v) => Prettify [v] where+  prettify = prettifyList ++-- TODO: template haskell-ify for larger tuples+instance (Prettify a, Prettify b) => Prettify (a,b) where+  prettify (a,b) = do+    pChr '('+    prettify a+    pChr ','+    prettify b+    pChr ')'++instance (Prettify a, Prettify b, Prettify c) => Prettify (a,b,c) where+  prettify (a,b,c) = do+    pChr '('+    prettify a+    pChr ','+    prettify b+    pChr ','+    prettify c+    pChr ')'++instance (Prettify a, Prettify b, Prettify c, Prettify d) => Prettify (a,b,c,d) where+  prettify (a,b,c,d) = do+    pChr '('+    prettify a+    pChr ','+    prettify b+    pChr ','+    prettify c+    pChr ','+    prettify d+    pChr ')'++-- | Pretty-print a list of values, separated by some other pretty-printer.+sepBy s [] = return ()+sepBy s (v:vs) = foldl (_sepBy s) v vs++-- | Reorder pretty-printer bind.+_sepBy s ma mb = ma >> s >> mb ++instance Prettify Char where+  prettify = pChr+  prettifyList = pStr . T.pack++instance Prettify () where prettify = rshow+instance Prettify Bool where prettify = rshow+instance Prettify Int where prettify = rshow++instance Prettify Double where prettify = rshow+
+ src/Text/ANTLR/Set.hs view
@@ -0,0 +1,288 @@+{-# LANGUAGE GADTs, DeriveAnyClass, DeriveGeneric, OverloadedStrings, DeriveLift+    , QuasiQuotes, TemplateHaskell, DeriveDataTypeable #-}+{-|+  Module      : Text.ANTLR.Set+  Description : Entrypoint for swapping out different underlying set representations+  Copyright   : (c) Karl Cronburg, 2018+  License     : BSD3+  Maintainer  : karl@cs.tufts.edu+  Stability   : experimental+  Portability : POSIX++-}+module Text.ANTLR.Set+  ( Set, null, size, member, notMember+  , empty, singleton, insert, delete, union, unions+  , difference, intersection, filter, map, foldr, foldl', fold+  , toList, fromList, (\\), findMin, maybeMin+  , Hashable(..), Generic(..)+  ) where+import Text.ANTLR.Pretty++import GHC.Generics (Generic, Rep)+import Data.Hashable (Hashable(..))+import Language.Haskell.TH.Syntax (Lift(..))++import qualified Data.Functor         as F+import qualified Control.Applicative  as A+import qualified Data.Foldable        as Foldable++import Data.Map ( Map(..) )+import qualified Data.Map as M++import qualified Data.HashSet as S+import Data.HashSet as S+  ( HashSet(..), member, toList, union+  , null, empty, map, size, singleton, insert+  , delete, unions, difference, intersection, foldl'+  , fromList+  )++import Prelude hiding (null, filter, map, foldr, foldl)++-- | Use a hash-based set (hashable keys) for our internal set representation+--   during parsing.+type Set = S.HashSet++-- | Is @e@ not a member of the set @s@.+notMember e s = not $ member e s++-- | Set fold+fold = S.foldr++-- | Set fold+foldr = S.foldr++-- | Find the minimum value of an orderable set.+findMin :: (Ord a, Hashable a) => Set a -> a+findMin = minimum . toList++--maybeMin :: (Ord a, Hashable a) => Set a -> Maybe a+-- | Get minimum of a set without erroring out on empty set.+maybeMin as+  | S.size as == 0  = Nothing+  | otherwise       = Just $ findMin as++infixl 9 \\++-- | Set difference+(\\) :: (Hashable a, Eq a) => Set a -> Set a -> Set a+m1 \\ m2 = difference m1 m2++instance (Hashable a, Eq a, Lift a) => Lift (S.HashSet a) where+  lift set = [| fromList $(lift $ toList set) |]++instance (Hashable k, Hashable v) => Hashable (Map k v) where+  hashWithSalt salt mp = salt `hashWithSalt` M.toList mp++instance (Prettify a, Hashable a, Eq a) => Prettify (S.HashSet a) where+  prettify s = do+    pStr "Set: "; incrIndent 5+    pListLines $ toList s+    incrIndent (-5)+    pLine ""++--filter :: (Hashable a, Eq a) => (a -> Bool) -> Set a -> Set a+-- | Set filter+filter f s = S.filter f s++--instance (Hashable a, Eq a) => Hashable (S.HashSet a) where+--  hashWithSalt salt set = salt `hashWithSalt` S.toList (run set)+++{-++--import Data.Set.Monad (Set(..), member, toList, union, notMember)+--import qualified Data.Set.Monad as Set++import Prelude hiding (null, filter, map, foldr, foldl)+import qualified Data.List            as L+--import qualified Data.Set             as S+import qualified Data.Functor         as F+import qualified Control.Applicative  as A+import qualified Data.Foldable        as Foldable++import Data.Monoid+import Data.Foldable (Foldable)+import Control.Arrow+import Control.Monad+import Control.DeepSeq++import Data.Hashable (Hashable(..))+import GHC.Generics (Generic, Rep)+import Control.DeepSeq (NFData(..))+import Language.Haskell.TH.Syntax (Lift(..))+import Data.Data (Data(..))++import Data.Map ( Map(..) )+import qualified Data.Map as M++import Text.ANTLR.Pretty++instance (Hashable k, Hashable v) => Hashable (Map k v) where+  hashWithSalt salt mp = salt `hashWithSalt` M.toList mp++instance (Hashable a, Eq a) => Hashable (Set a) where+  hashWithSalt salt set = salt `hashWithSalt` S.toList (run set)++instance (Hashable a, Ord a) => Ord (Set a) where+  s1 <= s2 = S.toList (run s1) <= S.toList (run s2)++data Set a where+  Prim   :: (Hashable a, Eq a) => S.HashSet a -> Set a+  Return :: a -> Set a+  Bind   :: Set a -> (a -> Set b) -> Set b+  Zero   :: Set a+  Plus   :: Set a -> Set a -> Set a++instance (Data a) => Data (Set a)++instance (Hashable a, Eq a, Lift a) => Lift (Set a) where+  lift set = [| fromList $(lift $ toList set) |]++run :: (Hashable a, Eq a) => Set a -> S.HashSet a+run (Prim s)                        = s+run (Return a)                      = S.singleton a+run (Zero)                          = S.empty+run (Plus ma mb)                    = run ma `S.union` run mb+run (Bind (Prim s) f)               = S.foldl' S.union S.empty (S.map (run . f) s)+run (Bind (Return a) f)             = run (f a)+run (Bind Zero _)                   = S.empty+run (Bind (Plus (Prim s) ma) f)     = run (Bind (Prim (s `S.union` run ma)) f)+run (Bind (Plus ma (Prim s)) f)     = run (Bind (Prim (run ma `S.union` s)) f)+run (Bind (Plus (Return a) ma) f)   = run (Plus (f a) (Bind ma f))+run (Bind (Plus ma (Return a)) f)   = run (Plus (Bind ma f) (f a))+run (Bind (Plus Zero ma) f)         = run (Bind ma f)+run (Bind (Plus ma Zero) f)         = run (Bind ma f)+run (Bind (Plus (Plus ma mb) mc) f) = run (Bind (Plus ma (Plus mb mc)) f)+run (Bind (Plus ma mb) f)           = run (Plus (Bind ma f) (Bind mb f))+run (Bind (Bind ma f) g)            = run (Bind ma (\a -> Bind (f a) g))++instance F.Functor Set where+  fmap = liftM++instance A.Applicative Set where+  pure  = return+  (<*>) = ap++instance A.Alternative Set where+  empty = Zero+  (<|>) = Plus++instance Monad Set where+  return = Return+  (>>=)  = Bind++instance MonadPlus Set where+  mzero = Zero+  mplus = Plus++instance (Hashable a, Eq a) => Monoid (Set a) where+  mempty  = empty+  mappend = union+  mconcat = unions++instance Foldable Set where+    foldr f def m = +        case m of+            Prim s -> S.foldr f def s+            Return a -> f a def+            Zero -> def+            Plus ma mb -> Foldable.foldr f (Foldable.foldr f def ma) mb+            Bind s g -> Foldable.foldr f' def s+                where f' x b = Foldable.foldr f b (g x)++instance (Hashable a, Eq a) => Eq (Set a) where+  s1 == s2 = run s1 == run s2++--instance (Hashable a, Eq a, Ord a) => Ord (Set a) where+--  compare s1 s2 = compare (run s1) (run s2)++instance (Show a, Hashable a, Eq a) => Show (Set a) where+  show = show . run++instance (Prettify a, Hashable a, Eq a) => Prettify (Set a) where+  prettify s = do+    pStr "Set: "; incrIndent 5+    pListLines $ toList s+    incrIndent (-5)+    pLine ""++instance (Read a, Hashable a, Eq a) => Read (Set a) where+  readsPrec i s = L.map (first Prim) (readsPrec i s)++instance (NFData a, Hashable a, Eq a) => NFData (Set a) where+  rnf = rnf . run++infixl 9 \\++(\\) :: (Hashable a, Eq a) => Set a -> Set a -> Set a+m1 \\ m2 = difference m1 m2++null :: (Hashable a, Eq a) => Set a -> Bool+null = S.null . run++size :: (Hashable a, Eq a) => Set a -> Int+size = S.size . run++member :: (Hashable a, Eq a) => a -> Set a -> Bool+member a s = S.member a (run s)++notMember :: (Hashable a, Eq a) => a -> Set a -> Bool+notMember a t = not (member a t)++empty :: (Hashable a, Eq a) => Set a+empty = Prim S.empty++singleton :: (Hashable a, Eq a) => a -> Set a+singleton a = Prim (S.singleton a)++insert :: (Hashable a, Eq a) => a -> Set a -> Set a+insert a s = Prim (S.insert a (run s))++delete :: (Hashable a, Eq a) => a -> Set a -> Set a+delete a s = Prim (S.delete a (run s))++union :: (Hashable a, Eq a) => Set a -> Set a -> Set a+union s1 s2 = Prim (run s1 `S.union` run s2)++unions :: (Hashable a, Eq a) => [Set a] -> Set a+unions ss = Prim (S.unions (L.map run ss))++difference :: (Hashable a, Eq a) => Set a -> Set a -> Set a+difference s1 s2 = Prim (S.difference (run s1) (run s2))++intersection :: (Hashable a, Eq a) => Set a -> Set a -> Set a+intersection s1 s2 = Prim (S.intersection (run s1) (run s2))++filter :: (Hashable a, Eq a) => (a -> Bool) -> Set a -> Set a+filter f s = Prim (S.filter f (run s))++map :: (Hashable a, Eq a, Hashable b, Eq b) => (a -> b) -> Set a -> Set b+map f s = Prim (S.map f (run s))++foldr :: (Hashable a, Eq a) => (a -> b -> b) -> b -> Set a -> b+foldr f z s = S.foldr f z (run s)++fold :: (Hashable a, Eq a) => (a -> b -> b) -> b -> Set a -> b+fold f z s = S.foldr f z (run s)++foldl' :: (Hashable a, Eq a) => (b -> a -> b) -> b -> Set a -> b+foldl' f z s = S.foldl' f z (run s)++toList :: (Hashable a, Eq a) => Set a -> [a]+toList = S.toList . run++fromList :: (Hashable a, Eq a) => [a] -> Set a+fromList as = Prim (S.fromList as)++findMin :: (Ord a, Hashable a) => Set a -> a+findMin = minimum . toList++maybeMin :: (Ord a, Hashable a) => Set a -> Maybe a+maybeMin as+  | size as == 0 = Nothing+  | otherwise    = Just $ findMin as++-}+
+ test/allstar/AllStarTests.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE TypeFamilies #-}++module AllStarTests where++import Test.HUnit+import Text.ANTLR.Allstar.ParserGenerator+import qualified Data.Set as DS++--------------------------------TESTING-----------------------------------------++instance Token Char where+  type Label Char = Char+  type Literal Char = Char+  getLabel c = c+  getLiteral c = c++instance Token (a, b) where+  type Label (a, b) = a+  type Literal (a, b) = b+  getLabel (a, b) = a+  getLiteral (a, b) = b++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),+                       (Middle 'S' 0 1, GS (T 'c'), Middle 'S' 0 2),+                       (Middle 'S' 0 2, GS EPS, Final 'S'),++                       -- Second path through the 'S' ATN+                       (Init 'S', GS EPS, Middle 'S' 1 0),+                       (Middle 'S' 1 0, GS (NT 'A'), Middle 'S' 1 1),+                       (Middle 'S' 1 1, GS (T 'd'), Middle 'S' 1 2),+                       (Middle 'S' 1 2, GS EPS, Final 'S'),++                       -- First path through the 'A' ATN+                       (Init 'A', GS EPS, Middle 'A' 0 0),+                       (Middle 'A' 0 0, GS (T 'a'), Middle 'A' 0 1),+                       (Middle 'A' 0 1, GS (NT 'A'), Middle 'A' 0 2),+                       (Middle 'A' 0 2, GS EPS, Final 'A'),++                       -- Second path through the 'A' ATN+                       (Init 'A', GS EPS, Middle 'A' 1 0),+                       (Middle 'A' 1 0, GS (T 'b'), Middle 'A' 1 1),+                       (Middle 'A' 1 1, GS EPS, Final 'A')]+++-- 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'+                                              [Leaf 'a',+                                               Node 'A'+                                                [Leaf 'b']],+                                             Leaf 'c']))+                                   (parse ['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'+                                               [Leaf 'b'],+                                              Leaf 'c']))+                                    (parse ['b', 'c'] (NT 'S') atnEnv True))+                                    +-- Example #2 from the ALL(*) paper+parseTest3 = TestCase (assertEqual "for parse [b, d],"+                                   (Right (Node 'S'+                                            [Node 'A'+                                              [Leaf 'b'],+                                             Leaf 'd']))+                                   (parse ['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'+                                              [Leaf 'a',+                                               Node 'A'+                                                [Leaf 'a',+                                                 Node 'A'+                                                  [Leaf 'a',+                                                   Node 'A'+                                                    [Leaf 'b']]]],+                                             Leaf 'c']))+                                   (parse ['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],"+                                   True+                                   (let parseResult = parse ['a', 'b', 'a', 'c'] (NT 'S') atnEnv True+                                        isLeft pr = case pr of+                                                      Left _ -> True+                                                      _ -> False+                                    in  isLeft parseResult))++-- To do: Update these tests so that they use the new ATN state representation.+{-++conflictsTest = TestCase (assertEqual "for getConflictSetsPerLoc()"+                         +                                      ([[(MIDDLE 5, 1, []), (MIDDLE 5, 2, []),(MIDDLE 5, 3, [])],+                                        [(MIDDLE 5, 1, [MIDDLE 1]), (MIDDLE 5, 2, [MIDDLE 1])],+                                        [(MIDDLE 7, 2, [MIDDLE 6, MIDDLE 1])]] :: [[ATNConfig Char]])+                                         +                                      (getConflictSetsPerLoc (D [(MIDDLE 5, 1, []),+                                                                 (MIDDLE 5, 2, []),+                                                                 (MIDDLE 5, 3, []),+                                                                 (MIDDLE 5, 1, [MIDDLE 1]),+                                                                 (MIDDLE 5, 2, [MIDDLE 1]),+                                                                 (MIDDLE 7, 2, [MIDDLE 6, MIDDLE 1])])))++prodsTest = TestCase (assertEqual "for getProdSetsPerState()"+                     +                                  ([[(MIDDLE 5, 1, []),+                                     (MIDDLE 5, 2, []),+                                     (MIDDLE 5, 3, []),+                                     (MIDDLE 5, 1, [MIDDLE 1]),+                                     (MIDDLE 5, 2, [MIDDLE 1])],+                                     +                                    [(MIDDLE 7, 2, [MIDDLE 6, MIDDLE 1])]] :: [[ATNConfig Char]])+                                         +                                  (getProdSetsPerState (D [(MIDDLE 5, 1, []),+                                                           (MIDDLE 5, 2, []),+                                                           (MIDDLE 5, 3, []),+                                                           (MIDDLE 5, 1, [MIDDLE 1]),+                                                           (MIDDLE 5, 2, [MIDDLE 1]),+                                                           (MIDDLE 7, 2, [MIDDLE 6, MIDDLE 1])])))++-}+++ambigATNEnv = DS.fromList [(Init 'S', GS EPS, Middle 'S' 0 0),+                           (Middle 'S' 0 0, GS (T 'a'), Middle 'S' 0 1),+                           (Middle 'S' 0 1, GS EPS, Final 'S'),+               +                           (Init 'S', GS EPS, Middle 'S' 1 0),+                           (Middle 'S' 1 0, GS (T 'a'), Middle 'S' 1 1),+                           (Middle 'S' 1 1, GS EPS, Final 'S'),+               +                           (Init 'S', GS EPS, Middle 'S' 2 0),+                           (Middle 'S' 2 0, GS (T 'a'), Middle 'S' 2 1),+                           (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],"+                                        True+                                        (let parseResult = parse ['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'+                                                 [Leaf 'a',+                                                  Leaf 'b']))+                                        (parse ['a', 'b'] (NT 'S') ambigATNEnv True))++        +tests = [TestLabel "parseTest1"    parseTest1,+         TestLabel "parseTest2"    parseTest2,+         TestLabel "parseTest3"    parseTest3,+         TestLabel "parseTest4"    parseTest4,+         TestLabel "parseTest5"    parseTest5,+                  +         --TestLabel "conflictsTest" conflictsTest,+         --TestLabel "prodsTest"     prodsTest,++         TestLabel "ambigParseTest1" ambigParseTest1,+         TestLabel "ambigParseTest2" ambigParseTest2]+       +main = runTestTT (TestList tests)
+ test/allstar/Main.hs view
@@ -0,0 +1,16 @@+module Main 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++main :: IO ()+main = defaultMainWithOpts+  [+  ] mempty+
+ test/atn/Main.hs view
@@ -0,0 +1,50 @@+module Main where+import Text.ANTLR.Allstar.ATN+import Text.ANTLR.Allstar.Example.ATN+import Text.ANTLR.Set (fromList, (\\))++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     ++-- ATNs should be same:+test_paperATNGrammar =+  atnOf paperATNGrammar+  @?=+  exp_paperATN++-- Set difference to make debugging easier:+test_paperATNGrammar2 =+  ((_Δ . atnOf) paperATNGrammar \\ _Δ exp_paperATN)+  @?=+  fromList []++test_addPredicates =+  atnOf addPredicates+  @?=+  exp_addPredicates++test_addPredicates2 =+  ((_Δ . atnOf) addPredicates \\ _Δ exp_addPredicates)+  @?=+  fromList []++test_addMutators =+  atnOf addMutators+  @?=+  exp_addMutators++main :: IO ()+main = defaultMainWithOpts+  [ testCase "paper_ATN_Grammar"  test_paperATNGrammar+  , testCase "paper_ATN_Grammar2" test_paperATNGrammar2+  , testCase "paper_ATN_Predicates2" test_addPredicates2+  , testCase "paper_ATN_Predicates" test_addPredicates+  , testCase "paper_ATN_Mutators" test_addMutators+  ] mempty+
+ test/chisel/Language/Chisel/Grammar.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances #-}+module Language.Chisel.Grammar+  ( parse, Language.Chisel.Grammar.tokenize, 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+  ) where+import Language.ANTLR4+import Language.Chisel.Syntax as S++list a = [a]+cons = (:)+append = (++)++[g4|+  grammar Chisel;+  chiselProd : prodSimple+             | '(' prodSimple ')'+             ;++  prodSimple : prodID formals magnitude alignment '->' group    -> S.prodFMA+             | prodID formals '->' group                        -> S.prodF+             | prodID magnitude alignment '->' group            -> S.prodMA+             | prodID magnitude '->' group                      -> S.prodM+             | LowerID prodID magnitude alignment '->' group    -> S.prodNMA+             ;++  formals : LowerID formals             -> cons+          | LowerID                     -> list+          ;++  magnitude : '|' '#' sizeArith '|'     -> magWild+            | '|'     sizeArith '|'     -> magNorm+            | '|'     prodID    '|'     -> magID+            ;++  alignment : '@' '(' sizeArith ')';++  group :     groupExp1                 -> list+        | '(' groupExp  ')'+        ;+  +  groupExp : groupExp1                  -> list+           | groupExp1 ',' groupExp     -> cons+           ;++  groupExp1 : '#' chiselProd            -> gProdWild+            | '#' sizeArith             -> gSizeWild+            | '(' flags ')'             -> GFlags+            | chiselProd                -> gProdNorm+            | sizeArith                 -> gSizeNorm+            | label                     -> GLabel+            | arith chiselProd          -> gProdArith+            | arith prodApp             -> GProdApp+            | '(' labels ')'            -> GLabels+            ;++  flags : prodID                        -> list+        | prodID '|' flags              -> cons+        ;++  labels : label                        -> list+         | label '|' labels             -> cons+         ;++  label : LowerID ':' labelExp    -> Label+        ;++  labelExp : '#' chiselProd       -> lProdWild+           | '#' prodApp          -> lProdAppWild+           | '#' sizeArith        -> lSizeWild+           | chiselProd           -> lProd+           | prodApp              -> lProdApp+           | sizeArith            -> lSize+           ;++  prodApp : prodID prodApp        -> cons+          | prodID                -> list+          ;++  sizeArith : arith Prim          -> SizeArith+            | Prim                -> singleArith+            ;+  +  arith : INT                     -> SizeInt+        | LowerID                 -> SizeID+        | arith '^' arith         -> SizeExp+        ;++  prodID  : UpperID               -> id+          | UpperID '.' prodID    -> append+          ;++  Prim     : ( 'bit' | 'byte' ) 's'?      -> Primitive;+  ArchPrim : ( 'page' | 'word' ) 's'?     -> Primitive;+  UpperID  : [A-Z][a-zA-Z0-9_]*           -> String;+  LowerID  : [a-z][a-zA-Z0-9_]*           -> String;+  INT      : [0-9]+                       -> Int;+  LineComment : '//' (~ '\n')* '\n'       -> String;+  WS      : [ \t\n\r\f\v]+                -> String;+|]++-- Types used to the right of the '->' directive must instance Read++isWhitespace T_LineComment = True+isWhitespace T_WS = True+isWhitespace _ = False++{- Helper functions to construct all the various Tokens from either the desired+ - (arbitrary) lexeme or by looking it up based on the static lexeme it always+ - matches. -}+lowerID  x = Token T_LowerID (V_LowerID x) (length x)+upperID  x = Token T_UpperID (V_UpperID x) (length x)+prim     x = Token T_Prim    (V_Prim x)    (length $ show x)+int      x = Token T_INT     (V_INT x)     (length $ show x)+arrow      = lookupToken "->"+lparen     = lookupToken "("+rparen     = lookupToken ")"+pound      = lookupToken "#"+vertbar    = lookupToken "|"+colon      = lookupToken ":"+comma      = lookupToken ","+atsymbol   = lookupToken "@"+carrot     = lookupToken "^"+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
@@ -0,0 +1,16 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances, TemplateHaskell #-}+module Language.Chisel.Parser+  ( module Language.Chisel.Grammar+  , glrParseFast+  ) 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++$(mkLRParser the_ast chiselGrammar)+
+ test/chisel/Language/Chisel/Syntax.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric #-}+module Language.Chisel.Syntax where+import Language.ANTLR4 (Data(..))+import Text.ANTLR.Pretty+import Text.ANTLR.Set (Hashable(..), Generic(..))++data ChiselProd = ChiselProd+  { prodID    :: UpperID+  , count     :: Maybe LowerID+  , formals   :: Maybe [Formal]+  , magnitude :: Maybe Magnitude+  , alignment :: Maybe SizeArith+  , rhs       :: Group+  }++prodFMA s f m a   = ChiselProd s Nothing  (Just f)  (Just m) (Just a)+prodF s f         = ChiselProd s Nothing  (Just f)  Nothing Nothing+prodMA s m a      = ChiselProd s Nothing  Nothing   (Just m) (Just a)+prodM s m         = ChiselProd s Nothing  Nothing   (Just m) Nothing+prodNMA s n m a   = ChiselProd s (Just n) Nothing   (Just m) (Just a)++type Formal = String++-- Whether or not '#' was used:+type Wild = Bool++data Magnitude = Mag Wild SizeArith++magWild = Mag True  -- Variable magnitude+magNorm = Mag False -- Fixed magnitude+magID   = Mag False . SizeID++type Alignment = SizeArith++type Group = [GroupExp]++-- Left False == no size annotation+-- Left True  == '#' annotation+-- Right sz   == fixed size annotation+type Count = Either Wild SizeArith++data GroupExp =+    GProd Count ChiselProd+  | GSize Wild  SizeArith+  | GFlags      [Flag]+  | GLabel      Label+  | GLabels     [Label]+  | GProdApp    SizeArith ProdApp++gProdWild     = GProd (Left True)+gProdNorm     = GProd (Left False)+gProdArith a  = GProd (Right a)++gSizeWild = GSize True+gSizeNorm = GSize False++type Flag = ProdID++type ProdApp = [ProdID]++type UpperID = String+type LowerID = String+type ProdID = String+type LabelID = String++data Label = Label LabelID LabelExp++data LabelExp =+    LProd     Wild ChiselProd+  | LProdApp  Wild ProdApp+  | LSize     Wild SizeArith++lProdWild = LProd True+lProd     = LProd False++lProdAppWild = LProdApp True+lProdApp     = LProdApp False++lSizeWild = LSize True+lSize     = LSize False++data SizeArith =+    SizeInt   Int+  | SizeID    LowerID+  | SizeExp   SizeArith SizeArith+  | SizeArith SizeArith Primitive++singleArith = SizeArith (SizeInt 1)++data Primitive = Page | Word | Byte | Bit+  deriving (Show, Eq, Ord, Generic, Hashable, Data)++lexeme2prim "page"  = Just Page+lexeme2prim "pages" = Just Page+lexeme2prim "word"  = Just Word+lexeme2prim "words" = Just Word+lexeme2prim "byte"  = Just Byte+lexeme2prim "bytes" = Just Byte+lexeme2prim "bit"   = Just Bit+lexeme2prim "bits"  = Just Bit+lexeme2prim _       = Nothing++instance Read Primitive where+  readsPrec _ input = case lexeme2prim input of+    Just x  -> [(x,"")]+    Nothing -> []++instance Prettify Primitive where prettify = rshow+
+ test/chisel/Main.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE QuasiQuotes, TemplateHaskell, ScopedTypeVariables #-}+module Main where+-- Project imports go here, e.g.:+--import Language.Chisel.Tokenizer+import Text.ANTLR.Lex.Tokenizer (Token(..))+import Text.ANTLR.Parser (AST(..))+import Language.Chisel.Parser+import Language.Chisel.Syntax+import Text.ANTLR.Grammar (Grammar(..), ProdElem(..))+import Language.ANTLR4.FileOpener (open)++import System.IO.Unsafe (unsafePerformIO)+import Data.Monoid+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding ((@?=), assertEqual)+import Test.QuickCheck (Property, quickCheck, (==>))+import qualified Test.QuickCheck.Monadic as TQM++import Text.ANTLR.HUnit+import Debug.Trace as D+import qualified Text.ANTLR.LR as LR+import Text.ANTLR.Pretty (pshow)+import qualified Data.Text as T++chi = id++ghc_val = [open| test/chisel/Language/Chisel/Examples/GHC.chi |]+tokenizeGHC_val = tokenize ghc_val++tokenizeGHC_exp =+  [ upperID "Heap", ws " ", lowerID "m", ws " ", lowerID "k", ws " ", arrow+  , ws "\n  ", pound, ws " ", upperID "MegaBlock", ws " "+  , vertbar, int 2, carrot, lowerID "m", ws " ", prim Byte, vertbar, ws " "+  , atsymbol, lparen, int 2, carrot, lowerID "m", ws " ", prim Byte, rparen+  , ws " ", arrow, ws "\n    ", linecomm "// -------Megablock \"Header\"------------------"+  , ws "\n    ", lparen, ws " ", upperID "Descrs", ws " "+  , vertbar, int 2, carrot, lowerID "k", ws " ", prim Byte, vertbar, ws " "+  , arrow, ws "\n      ", lparen, ws " ", lowerID "padMB", ws " ", prim Byte+  , ws "\n      ", linecomm "// +++++++++++++++++++++++++++++++++++++++++\n"+  , ws "      ", comma, ws " ", lowerID "bds", ws " "+  , colon, ws " ", lowerID "n", ws " ", upperID "BlockDescr", ws " "+  , vertbar, int 2, carrot, lowerID "d", ws " ", prim Byte, vertbar+  , ws " ", atsymbol, lparen, int 2, carrot, lowerID "k", ws " ", prim Byte, rparen+  , ws " ", arrow, ws "\n        "+  , lparen, ws " ", lowerID "start", ws " ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "Stg", dot, upperID "Word", ws "\n        "+  , comma, ws " ", lowerID "free", ws "  ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "Stg", dot, upperID "Word", ws "\n        "+  , comma, ws " ", lowerID "link", ws "  ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "BlockDescr", ws "\n        "+  , comma, ws " ", lparen, ws " ", lowerID "back", ws "   ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "BlockDescr", ws "\n          "+  , vertbar, ws " ", lowerID "bitmap", ws " ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "Stg", dot, upperID "Word", ws "\n          "+  , vertbar, ws " ", lowerID "scan", ws "   ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "Stg", dot, upperID "Word", rparen, ws "\n        "+  , comma, ws " ", lowerID "gen", ws "     ", colon, ws " "+  , upperID "Ptr", ws " ", upperID "Generation", ws "\n    ", comma, ws " "+  , lowerID "gen_no", ws "  ", colon, ws " "+  , upperID "Stg", dot, upperID "Word16", ws "\n      "+  , comma, ws " ", lowerID "dest_no", ws " ", colon, ws " "+  , upperID "Stg", dot, upperID "Word16", ws "\n        "+  , comma, ws " ", lowerID "node", ws "    ", colon, ws " "+  , upperID "Stg", dot, upperID "Word16", ws "\n        "+  , comma, ws " ", upperID "Flags", ws " "+  , vertbar, upperID "Stg", dot, upperID "Word16", vertbar, ws " ", arrow, ws "\n          "+  , lparen, ws " ", upperID "LARGE", ws "  ", vertbar, ws " "+  , upperID "EVACUATED", ws "", vertbar, ws " "+  , upperID "FREE", ws "\n          ", vertbar, ws " "+  , upperID "PINNED", ws " ", vertbar, ws " "+  , upperID "MARKED", ws "     ", vertbar, ws " "+  , upperID "KNOWN", ws "\n          ", vertbar, ws " "+  , upperID "EXEC", ws "   ", vertbar, ws " "+  , upperID "FRAGMENTED", ws " ", vertbar, ws " "+  , upperID "SWEPT", ws "\n          ", vertbar, ws " "+  , upperID "COMPACT", ws " ", rparen, ws "\n        ", comma, ws " "+  , lowerID "n_blocks", ws " ", colon, ws " "+  , upperID "Stg", dot, upperID "Word32", ws "\n        "+  , comma, ws " ", lowerID "padD", ws " ", prim Byte, rparen, rparen, ws "\n      "+  , linecomm "// +++++++++++++++++++++++++++++++++++++++++\n", ws "    "+  , linecomm "// -------Megablock payload-------------------\n", ws "    ", comma, ws " "+  , lowerID "blocks", ws " ", colon, ws " ", lowerID "n", ws " "+  , upperID "Block", ws " ", vertbar, int 2, carrot+  , lowerID "k", ws " ", prim Byte, vertbar, ws " "+  , atsymbol, lparen, int 2, carrot, lowerID "k", ws " ", prim Byte, rparen+  , ws " ", arrow, ws "\n      ", lparen, ws " "+  , lowerID "closures", ws " ", colon, ws " ", pound, ws " "+  , upperID "Stg", dot, upperID "Closures", ws "\n      ", comma, ws " "+  , lowerID "free", ws "     ", colon, ws " ", pound, ws " ", prim Byte, rparen+  , ws "\n    ", rparen, ws "\n", EOF+  ]++tokenizeGHC =+  tokenizeGHC_val+  @?=+  tokenizeGHC_exp++tokenizeGHC2 =+  dropWhile (\(a,b) -> a == b) (zip tokenizeGHC_val tokenizeGHC_exp)+  @?=+  []++tokenizeSmall = tokenize "Foo x -> x Bar"++parseTestSmall =+  D.traceShowId (parse "Foo x -> x Bar")+  @?=+  LR.ResultAccept+    ( AST NT_chiselProd [NT NT_prodSimple]+      [ AST NT_prodSimple [NT NT_prodID, NT NT_formals, T T_2, NT NT_group]+        [ AST NT_prodID [T T_UpperID] [Leaf $ upperID "Foo"]+        , AST NT_formals [T T_LowerID] +          [ Leaf $ lowerID "x"]+        , Leaf arrow+        , AST NT_group [NT NT_groupExp1]+            [ AST NT_groupExp1 [NT NT_arith, NT NT_prodApp]+              [ AST NT_arith [T T_LowerID] [Leaf $ lowerID "x"]+              , AST NT_prodApp [NT NT_prodID]+                [ AST NT_prodID [T T_UpperID] [Leaf $ upperID "Bar"] ]+                ]]]])++tokenizeSmallTest =+  tokenizeSmall+  @?=+  [upperID "Foo", ws " ", lowerID "x", ws " ", arrow, ws " ", lowerID "x", ws " ", upperID "Bar", EOF]++parseGHCTestBig =+  case parse ghc_val of+    (LR.ResultAccept _)   -> (1 :: Int) @?= 1+    e                     -> e @?= LR.ResultAccept LeafEps++testPrettify =+  unsafePerformIO (putStr $ T.unpack $ pshow (chiselGrammar :: Grammar () ChiselNTSymbol ChiselTSymbol))+  @?= ()++testFast =+  glrParseFast isWhitespace "Foo x -> x Bar"+  @?=+  glrParse isWhitespace "Foo x -> x Bar"++main :: IO ()+main = defaultMainWithOpts+  [ testCase "Tokenize GHC" tokenizeGHC+  , testCase "Tokenize GHC2" tokenizeGHC2+  , testCase "Tokenize Small" tokenizeSmallTest+  , testCase "Parse Test (Small)" parseTestSmall+  , testCase "Parse GHC"  parseGHCTestBig+  , testCase "Prettify speed" testPrettify+  , testCase "Run glrParseFast build" testFast+  ] mempty+
+ test/coreg4/Main.hs view
@@ -0,0 +1,70 @@+module Main 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, Regex(..))+import qualified Language.ANTLR4.Example.G4 as G4+import Language.ANTLR4.Example.Hello+import Text.ANTLR.Parser (AST(..))+import qualified Text.ANTLR.LR as LR+import Language.ANTLR4.Boot.Syntax (Regex(..))+--import Language.ANTLR4.Regex (parseRegex)++import qualified Language.ANTLR4.G4 as P -- Parser++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 (Token T_0 V_0 1)+        , Leaf (Token T_WS (V_WS " ") 1)+        , Leaf (Token T_ID (V_ID "Matt") 4)+        ]+  )++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+  ] mempty+
+ test/g4/G4.hs view
@@ -0,0 +1,31 @@+{-# 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
@@ -0,0 +1,114 @@+{-# LANGUAGE TemplateHaskell #-}+module Main 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, 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+import qualified Text.ANTLR.Lex.Tokenizer as T++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)+        ]+  )++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 [] [])++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)]])++test_optional2 =+  case Opt.glrParse Opt.isWS "a a 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+    LR.ResultAccept ast -> Opt.ast2r ast @?= "accept"+    err                 -> error $ show err++test_optional4 =+  case Opt.glrParse Opt.isWS "a" of+    LR.ResultAccept ast -> Opt.ast2r ast @?= "reject"+    err                 -> error $ show err++testFastGLR =+  Fast.glrParseFast (const False) "3"+  @?=+  G4.glrParse (const False) "3"++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_optional2" test_optional2+  , testCase "test_optional3" test_optional3+  , testCase "test_optional4" test_optional4+  , testCase "testFastGLR" testFastGLR+  ] mempty+
+ test/lexer/Main.hs view
@@ -0,0 +1,317 @@+module Main where++import Text.ANTLR.Lex+import Text.ANTLR.Lex.Automata+import Text.ANTLR.Lex.NFA as NFA+import qualified Text.ANTLR.Lex.DFA as DFA++import Text.ANTLR.Lex.Regex++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 Text.ANTLR.Set (fromList, Set(..), singleton, Hashable)++singleEdge s = (False, singleton s)++fL :: (Hashable a, Eq a) => [a] -> Set a+fL = fromList++nfa0 :: NFA Char Int+nfa0 = Automata+  { _S = fL [0, 1, 2, 3]+  , _Σ = fL "ab"+  , s0 = 0+  , _F = fL [3]+  , _Δ = fL+    [ (0, singleEdge $ Edge 'a', 0)+    , (0, singleEdge $ Edge 'a', 1)+    , (0, singleEdge $ Edge 'b', 0)+    , (1, singleEdge $ Edge 'b', 2)+    , (2, singleEdge $ Edge 'b', 3)+    ]+  }++testValid0 =+  (  validStartState nfa0+  && validFinalStates nfa0+  && validTransitions nfa0+  )+  @?=+  True++testClosureWith0 =+  closureWith (Edge 'a' ==) nfa0 (singleton 0)+  @?=+  fromList [0, 1]++testClosureWith1 =+  closureWith (NFAEpsilon ==) nfa0 (singleton 0)+  @?=+  fromList [0]++testClosureWith2 =+  closureWith (const True) nfa0 (singleton 0)+  @?=+  fromList [0, 1, 2, 3]++testClosureWith3 =+  closureWith (Edge 'b' ==) nfa0 (singleton 0)+  @?=+  fromList [0]++testMove0 =+  move nfa0 (fromList [0,1,2]) (Edge 'a')+  @?=+  fromList [0,1]++nfa334 :: NFA Char Int+nfa334 = Automata+  { _S = fL [0 .. 10]+  , _Σ = fL "ab"+  , s0 = 0+  , _F = fL [10]+  , _Δ = fL+    [ (0, singleEdge NFAEpsilon, 1)+    , (0, singleEdge NFAEpsilon, 7)+    , (1, singleEdge NFAEpsilon, 2)+    , (1, singleEdge NFAEpsilon, 4)+    , (2, singleEdge $ Edge 'a', 3)+    , (3, singleEdge NFAEpsilon, 6)+    , (4, singleEdge $ Edge 'b', 5)+    , (5, singleEdge NFAEpsilon, 6)+    , (6, singleEdge NFAEpsilon, 1)+    , (6, singleEdge NFAEpsilon, 7)+    , (7, singleEdge $ Edge 'a', 8)+    , (8, singleEdge $ Edge 'b', 9)+    , (9, singleEdge $ Edge 'b', 10)+    ]+  }++_A = fromList [0,1,2,4,7]+_B = fromList [1,2,3,4,6,7,8]+_C = fromList [1,2,4,5,6,7]+_D = fromList [1,2,4,5,6,7,9]+_E = fromList [1,2,4,5,6,7,10]++a = singleEdge 'a'+b = singleEdge 'b'++dfa336 :: DFA.DFA Char (Set Int)+dfa336 = Automata+  { _S = fL [_A, _B, _C, _D, _E]+  , _Σ = fL "ab"+  , s0 = _A+  , _F = fL [_E]+  , _Δ = fL+    [ (_A, a, _B), (_A, b, _C)+    , (_B, a, _B), (_B, b, _D)+    , (_C, a, _B), (_C, b, _C)+    , (_D, a, _B), (_D, b, _E)+    , (_E, a, _B), (_E, b, _C)+    ]+  }++nfa2dfa0 =+ nfa2dfa nfa334+ @?=+ dfa336++nfa334Eps0 =+  NFA.epsClosure nfa334++epsilonNFA = +  Automata+    { _S = fL [0, 1]+    , _Σ = fL ""+    , s0 = 0+    , _F = fL [1]+    , _Δ = fL [ (0, singleEdge NFAEpsilon, 1) ]+    }++regexTest0 =+  regex2nfa Epsilon+  @?=+  epsilonNFA++regexTest1 =+  regex2nfa (Symbol 'a')+  @?=+  epsilonNFA { _Σ = fL "a", _Δ = fL [ (0, singleEdge $ Edge 'a', 1) ] }++regexTestUnion =+  regex2nfa (Union (Symbol 'a') (Symbol 'b'))+  @?= Automata+    { _S = fL [0..5]+    , _Σ = fL "ab"+    , s0 = 4+    , _F = fL [5]+    , _Δ = fL [ (0, singleEdge $ Edge 'a', 1)+              , (2, singleEdge $ Edge 'b', 3)+              , (4, singleEdge NFAEpsilon, 0)+              , (4, singleEdge NFAEpsilon, 2)+              , (1, singleEdge NFAEpsilon, 5)+              , (3, singleEdge NFAEpsilon, 5) ]+    }++regexTestConcat =+  regex2nfa (Concat [Symbol 'a', Symbol 'b'])+  @?= Automata+    { _S = fL [0..3]+    , _Σ = fL "ab"+    , s0 = 0+    , _F = fL [3]+    , _Δ = fL [ (0, singleEdge $ Edge 'a', 1)+              , (1, singleEdge NFAEpsilon, 2)+              , (2, singleEdge $ Edge 'b', 3) ]+    }++regexTestKleene =+  regex2nfa (Kleene (Concat [Symbol 'a', Symbol 'b']))+  @?= Automata+    { _S = fL [0..5]+    , _Σ = fL "ab"+    , s0 = 4+    , _F = fL [5]+    , _Δ = fL [ (0, singleEdge $ Edge 'a', 1)+              , (1, singleEdge NFAEpsilon, 2)+              , (2, singleEdge $ Edge 'b', 3)+              , (4, singleEdge NFAEpsilon, 0)+              , (4, singleEdge NFAEpsilon, 5)+              , (3, singleEdge NFAEpsilon, 0)+              , (3, singleEdge NFAEpsilon, 5)]+    }++regexTestPosclos =+  regex2nfa (PosClos (Concat [Symbol 'a', Symbol 'b']))+  @?= Automata+    { _S = fL [0..9]+    , _Σ = fL "ab"+    , s0 = 0+    , _F = fL [9]+    , _Δ = fL [ (0, singleEdge $ Edge 'a', 1)+              , (1, singleEdge NFAEpsilon, 2)+              , (2, singleEdge $ Edge 'b', 3)+              , (3, singleEdge NFAEpsilon, 8)+              , (4, singleEdge $ Edge 'a', 5)+              , (5, singleEdge NFAEpsilon, 6)+              , (6, singleEdge $ Edge 'b', 7)+              , (8, singleEdge NFAEpsilon, 4)+              , (8, singleEdge NFAEpsilon, 9)+              , (7, singleEdge NFAEpsilon, 4)+              , (7, singleEdge NFAEpsilon, 9)]+    }++dfaABPlus = regex2dfa (PosClos (Concat [Symbol 'a', Symbol 'b']))+dfaWS     = regex2dfa (PosClos (Symbol ' '))++{-+dfaGetName x+  | x == dfaWS     = "ws"+  | x == dfaABPlus = "ab+"+  | otherwise      = "Error"+-}++tokenizeTest0 =+  tokenize [("ab+", dfaABPlus), ("ws", dfaWS)] const "abab ab ababab"+  @?=+  [ Token "ab+" "abab"    4+  , Token "ws"  " "       1+  , Token "ab+" "ab"      2+  , Token "ws"  " "       1+  , Token "ab+" "ababab"  6+  , EOF+  ]++{-+dfaID = regex2dfa+  (PosClos $ MultiUnion+              [ Class ['a' .. 'z']+              , Class ['A' .. 'Z']+              , Symbol '_'+              ])+-}++dfaID = regex2dfa+  (PosClos $ Class $ '_' : ['a' .. 'z'] ++ ['A' .. 'Z'])++-- For profiling runtime of DFA subset construction (nfa2dfa):+dfaIDTest =+  dfaID+  @?=+  dfaID++dfaEQ   = regex2dfa (Symbol '=')+dfaSEMI = regex2dfa (Symbol ';')++dfaINT  = regex2dfa (PosClos $ Class [ '0' .. '9' ])++data TermSymbol = T_ID | T_INT | T_WS | T_EQ | T_SEMI+  deriving (Eq, Ord, Show)++data TermValue =+    ID  String+  | INT Int+  | WS  String+  | EQSIGN+  | SEMI+  deriving (Eq, Ord, Show)++lexeme2value lexeme T_WS   = WS lexeme+lexeme2value lexeme T_ID   = ID lexeme+lexeme2value lexeme T_INT  = INT $ read lexeme+lexeme2value lexeme T_EQ   = EQSIGN+lexeme2value lexeme T_SEMI = SEMI++tokenizeTest1 =+  tokenize+    [ (T_WS, dfaWS), (T_ID, dfaID), (T_INT, dfaINT)+    , (T_EQ, dfaEQ), (T_SEMI, dfaSEMI) ]+    lexeme2value "_matt = 0;"+  @?=+  [ Token T_ID (ID "_matt") 5+  , Token T_WS (WS " ") 1+  , Token T_EQ EQSIGN 1+  , Token T_WS (WS " ") 1+  , Token T_INT (INT 0) 1+  , Token T_SEMI SEMI 1+  , EOF+  ]++lineCommentDFA = regex2dfa $ Concat [Literal "//", Kleene $ NotClass ['\n'], Symbol '\n']++lineCommentTest =+  tokenize [("LineComment", lineCommentDFA)] const+  "// This is a line comment.\n"+  @?=+  [ Token "LineComment" "// This is a line comment.\n" 27+  , EOF+  ]++main :: IO ()+main = defaultMainWithOpts+  [ testCase "testValid0" testValid0+  , testCase "testClosureWith0" testClosureWith0+  , testCase "testClosureWith1" testClosureWith1+  , testCase "testClosureWith2" testClosureWith2+  , testCase "testClosureWith3" testClosureWith3+  , testCase "testMove0" testMove0+  , testCase "nfa2dfa0" nfa2dfa0+  , testCase "regexTest0" regexTest0+  , testCase "regexTest1" regexTest1+  , testCase "regexTestUnion" regexTestUnion+  , testCase "regexTestConcat" regexTestConcat+  , testCase "regexTestKleene" regexTestKleene+  , testCase "regexTestPosclos" regexTestPosclos+  , testCase "tokenizeTest0" tokenizeTest0+  , testCase "dfaIDTest" dfaIDTest+  , testCase "tokenizeTest1" tokenizeTest1+  , testCase "lineCommentTest" lineCommentTest+  ] mempty+
+ test/ll/Main.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE FlexibleContexts #-}+module Main where+import Text.ANTLR.Example.Grammar+import Text.ANTLR.Grammar+import Text.ANTLR.Parser+import Text.ANTLR.Pretty+import qualified Data.Text as T+import Text.ANTLR.LL1++import Text.ANTLR.Set (fromList, union, empty, Set(..))+import qualified Text.ANTLR.Set as Set++import qualified Data.Map.Strict as M++import System.IO.Unsafe (unsafePerformIO)+import Data.Monoid+import Test.Framework+import Test.Framework (defaultMainWithOpts)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding ((@?=), assertEqual)+import Test.QuickCheck (Property, quickCheck, (==>))+import qualified Test.QuickCheck.Monadic as TQM++import Text.ANTLR.HUnit++type LL1NonTerminal = String+type LL1Terminal    = String++uPIO = unsafePerformIO++grm :: Grammar () LL1NonTerminal LL1Terminal+grm = dragonBook428++termination = first grm [NT "E"] @?= first grm [NT "E"]++firstF = first grm [NT "F"] @?= fromList [Icon "(", Icon "id"]++noEps = first grm [NT "E"] @?= fromList [Icon "(", Icon "id"]++firstT' =+  first grm [NT "T'"]+  @?=+  fromList [Icon "*", IconEps]++foldEpsTest = foldWhileEpsilon union empty+  [ fromList [Icon "(", Icon "id"]+  , fromList [Icon ")"]+  ]+  @?=+  fromList [Icon "(", Icon "id"]++firstAll =+  ( Set.map ((\nt -> (nt, first grm [nt])) . NT) (ns grm)+    `union`+    Set.map ((\t  -> (t,  first grm [t]))  . T)  (ts grm)+  )+  @?=+  fromList+    [ (NT "E",  fromList [Icon "(", Icon "id"])+    , (NT "E'", fromList [Icon "+", IconEps])+    , (NT "F",  fromList [Icon "(", Icon "id"])+    , (NT "T",  fromList [Icon "(", Icon "id"])+    , (NT "T'", fromList [Icon "*", IconEps])+    , (T "(",   fromList [Icon "("])+    , (T ")",   fromList [Icon ")"])+    , (T "*",   fromList [Icon "*"])+    , (T "+",   fromList [Icon "+"])+    , (T "id",  fromList [Icon "id"])+    ]++grm' :: Grammar () LL1NonTerminal LL1Terminal+grm' = grm++followAll :: IO ()+followAll = let+    fncn :: LL1NonTerminal -> (ProdElem LL1NonTerminal LL1Terminal, Set (Icon LL1Terminal))+    fncn nt = (NT nt, follow grm' nt)+  in Set.map fncn (ns grm')+  @?=+  fromList+    [ (NT "E",  fromList [Icon ")", IconEOF])+    , (NT "E'", fromList [Icon ")", IconEOF])+    , (NT "T",  fromList [Icon ")", Icon "+", IconEOF])+    , (NT "T'", fromList [Icon ")", Icon "+", IconEOF])+    , (NT "F",  fromList [Icon ")", Icon "*", Icon "+", IconEOF])+    ]++parseTableTest =+  parseTable grm+  @?=+  M.fromList (map (\((a,b),c) -> ((a,b), Set.singleton c))+    -- Figure 4.17 of dragon book:+    [ (("E",  Icon "id"), [NT "T", NT "E'"])+    , (("E",  Icon "("),  [NT "T", NT "E'"])+    , (("E'", Icon "+"),  [T "+", NT "T", NT "E'"])+    , (("E'", Icon ")"),  [Eps])+    , (("E'", IconEOF),       [Eps])+    , (("T",  Icon "id"), [NT "F", NT "T'"])+    , (("T",  Icon "("),  [NT "F", NT "T'"])+    , (("T'", Icon "+"),  [Eps])+    , (("T'", Icon "*"),  [T "*", NT "F", NT "T'"])+    , (("T'", Icon ")"),  [Eps])+    , (("T'", IconEOF),       [Eps])+    , (("F",  Icon "id"), [T "id"])+    , (("F",  Icon "("),  [T "(", NT "E", T ")"])+    ])++type LLAST = AST LL1NonTerminal LL1Terminal++action0 EpsE                  = LeafEps+action0 (TermE t)             = Leaf t+action0 (NonTE (nt, ss, us))  = AST nt ss us++action1 ::+  (Prettify t, Prettify (StripEOF (Sym t)), Prettify nts)+  => ParseEvent (AST nts t) nts t -> AST nts t+action1 (NonTE (nt, ss, trees)) = uPIO (putStrLn $ T.unpack $ pshow ("Act:", nt, ss, trees)) `seq` action0 $ NonTE (nt,ss,trees)+action1 (TermE x) = uPIO (putStrLn $ T.unpack $ pshow ("Act:", x)) `seq` action0 $ TermE x+action1 EpsE      = action0 EpsE++dragonPredParse =+  predictiveParse grm action0 ["id", "+", "id", "*", "id", ""]+  @?=+  (Just $ AST "E" [NT "T", NT "E'"]+            [ AST "T" [NT "F", NT "T'"]+                [ AST "F"  [T "id"] [Leaf "id"]+                , AST "T'" [Eps]    [LeafEps]+                ]+            , AST "E'" [T "+", NT "T", NT "E'"]+                [ Leaf "+"+                , AST "T" [NT "F", NT "T'"]+                    [ AST "F" [T "id"] [Leaf "id"]+                    , AST "T'" [T "*", NT "F", NT "T'"]+                        [ Leaf "*"+                        , AST "F" [T "id"] [Leaf "id"]+                        , AST "T'" [Eps] [LeafEps]+                        ]+                    ]+                , AST "E'" [Eps] [LeafEps]+                ]+            ])++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]+          ]+  }++testRemoveEpsilons =+  removeEpsilons singleLang+  @?= singleLang+    { ps =  [ Production "S" $ Prod Pass [NT "X", T 'a']+            , Production "S" $ Prod Pass [T 'a']+            ]+    }++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]+          ]+  }++testRemoveEpsilons2 =+  (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"]+    ]++testRemoveEpsilons3 =+  removeEpsilons dragonBook428+  @?= (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"]+           ]+    } ++leftGrammar0 = (defaultGrammar 'S' :: Grammar () Char String)+  { 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']+         ]+  }++testLeftFactor =+  leftFactor leftGrammar0+  @?= G+  { 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']+         ]+  , _πs = fromList []+  , _μs = fromList []+  }++main :: IO ()+main = defaultMainWithOpts+  [ testCase "fold_epsilon" foldEpsTest+  , testCase "termination" termination+  , testCase "no_epsilon" noEps+  , testCase "firstF" firstF+  , testCase "firstT'" firstT'+  , testCase "firstAll" firstAll+  , testCase "followAll" followAll+  , testCase "dragonHasAllNonTerms" $ hasAllNonTerms grm @?= True+  , testCase "dragonHasAllTerms" $ hasAllTerms grm @?= True+  , testCase "dragonStartIsNonTerm" $ startIsNonTerm grm @?= True+  , testCase "dragonIsValid" $ validGrammar grm @?= True+  , testCase "dragonIsLL1" $ isLL1 grm @?= True+  , testCase "dragonParseTable" parseTableTest+  , testCase "dragonPredParse" dragonPredParse+  , testCase "testRemoveEpsilons" testRemoveEpsilons+  , testCase "testRemoveEpsilons2" testRemoveEpsilons2+  , testCase "testLeftFactor" testLeftFactor+  ] mempty+
+ test/lr/Main.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeSynonymInstances #-}+module Main where+import Text.ANTLR.Example.Grammar+import Text.ANTLR.Grammar+import Text.ANTLR.LR+import Text.ANTLR.Parser+import qualified Data.Text as T+import qualified Text.ANTLR.Lex.Tokenizer as T++import Text.ANTLR.Set (fromList, union, empty, Set(..), (\\), Hashable(..), Generic(..))+import qualified Text.ANTLR.Set as S+import qualified Text.ANTLR.MultiMap as M++import System.IO.Unsafe (unsafePerformIO)+import Data.Monoid+import Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import Test.HUnit hiding ((@?=), assertEqual)+import Test.QuickCheck+--import Test.QuickCheck ( Property, quickCheck, (==>)+--  , elements, Arbitrary(..)+--  )+import qualified Test.QuickCheck.Monadic as TQM++import Text.ANTLR.HUnit+import Text.ANTLR.Pretty (pshow)+import qualified Debug.Trace as D+uPIO = unsafePerformIO++grm = dragonBook41++slrItem x y z = Item x y z ()++testClosure =+  slrClosure grm (S.singleton $ slrItem (Init "E") [] [NT "E"])+  @?=+  fromList+    [ slrItem (Init "E")   [] [NT "E"]+    , slrItem (ItemNT "E") [] [NT "E", T "+", NT "T"]+    , slrItem (ItemNT "E") [] [NT "T"]+    , slrItem (ItemNT "T") [] [NT "T", T "*", NT "F"]+    , slrItem (ItemNT "T") [] [NT "F"]+    , slrItem (ItemNT "F") [] [T "(", NT "E", T ")"]+    , slrItem (ItemNT "F") [] [T "id"]+    ]++testKernel =+  kernel (slrClosure grm (S.singleton $ slrItem (Init "E") [] [NT "E"]))+  @?=+  fromList+    [ slrItem (Init "E") [] [NT "E"] ]++type LR1Terminal = String+type LR1NonTerminal = String++newtype Item' = I' (Item () String String)+  deriving (Eq, Show, Generic, Hashable)++instance Arbitrary Item' where+  arbitrary = (elements . map I' . S.toList . allSLRItems) grm++instance (Eq a, Hashable a, Arbitrary a) => Arbitrary (Set a) where+  arbitrary = fmap S.fromList arbitrary+  shrink = map S.fromList . shrink . S.toList++c' = slrClosure grm++propClosureClosure :: Set Item' -> Property+propClosureClosure items' = let items = S.map (\(I' is) -> is) items' in True ==>+  (c' . c') items == c' items++newtype Grammar' = G' (Grammar () String String)+  deriving (Eq, Show)++instance Arbitrary Grammar' where+  arbitrary = return $ G' grm+{-+  arbitrary = do+    (uPIO $ print "damnit") `seq` return ()+    i <- elements [1..10]+    j <- elements [1..10]+    ns' <- infiniteList :: Gen [NonTerminal]+    ts' <- infiniteList :: Gen [Terminal]+    let ns = take i ns'+    let ts = take j ts'+    s0 <- elements ns+    let g = defaultGrammar {ns = fromList ns, ts = fromList ts, s0 = s0}+    let prod = do+          lhs <- elements ns+          rhs <- listOf (elements $ S.toList $ symbols g)+          return (lhs, Prod rhs)+    ps <- suchThat (listOf1 prod) (\ps -> validGrammar $ g { ps = ps })+    (uPIO $ print $ G' $ g { ps = ps }) `seq` return ()+    return $ G' $ g { ps = ps }+-}++closedItems :: Grammar' -> Property+closedItems (G' g) = True ==> null (S.foldr union empty (slrItems g) \\ allSLRItems g)++closedItems0 =+  S.foldr union empty (slrItems grm) \\ allSLRItems grm+  @?=+  empty++testItems =+  slrItems grm+  @?=+  fromList [_I0, _I1, _I2, _I3, _I4, _I5, _I6, _I7, _I8, _I9, _I10, _I11]++_I0 = fromList  [ slrItem (Init "E") [] [NT "E"]+                , slrItem (ItemNT "E") [] [NT "E",T "+",NT "T"]+                , slrItem (ItemNT "E") [] [NT "T"]+                , slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]+                , slrItem (ItemNT "F") [] [T "id"]+                , slrItem (ItemNT "T") [] [NT "F"]+                , slrItem (ItemNT "T") [] [NT "T",T "*",NT "F"]]+_I1 = fromList  [ slrItem (Init "E") [NT "E"] []+                , slrItem (ItemNT "E") [NT "E"] [T "+",NT "T"]]+_I4 = fromList  [ slrItem (ItemNT "E") [] [NT "E",T "+",NT "T"]+                , slrItem (ItemNT "E") [] [NT "T"]+                , slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]+                , slrItem (ItemNT "F") [] [T "id"]+                , slrItem (ItemNT "F") [T "("] [NT "E",T ")"]+                , slrItem (ItemNT "T") [] [NT "F"]+                , slrItem (ItemNT "T") [] [NT "T",T "*",NT "F"]]+_I8 = fromList  [ slrItem (ItemNT "E") [NT "E"] [T "+",NT "T"]+                , slrItem (ItemNT "F") [NT "E",T "("] [T ")"]]+_I2 = fromList  [ slrItem (ItemNT "E") [NT "T"] []+                , slrItem (ItemNT "T") [NT "T"] [T "*",NT "F"]]+_I9 = fromList  [ slrItem (ItemNT "E") [NT "T",T "+",NT "E"] []+                , slrItem (ItemNT "T") [NT "T"] [T "*",NT "F"]]+_I6 = fromList  [ slrItem (ItemNT "E") [T "+",NT "E"] [NT "T"]+                , slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]+                , slrItem (ItemNT "F") [] [T "id"]+                , slrItem (ItemNT "T") [] [NT "F"]+                , slrItem (ItemNT "T") [] [NT "T",T "*",NT "F"]]+_I7 = fromList  [ slrItem (ItemNT "F") [] [T "(",NT "E",T ")"]+                , slrItem (ItemNT "F") [] [T "id"]+                , slrItem (ItemNT "T") [T "*",NT "T"] [NT "F"]]+_I11 = fromList  [ slrItem (ItemNT "F") [T ")",NT "E",T "("] []]+_I5  = fromList  [ slrItem (ItemNT "F") [T "id"] []]+_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"]++-- Easier to debug when shown separately:+testSLRTable =+  M.size (slrTable grm+  `M.difference`+  testSLRExp)+  @?=+  0++testSLRTable2 =+  M.size (testSLRExp+  `M.difference`+  slrTable grm)+  @?=+  0++testSLRTable3 =+  slrTable grm+  @?=+  testSLRExp++testSLRExp = M.fromList+    [ ((_I0, Icon "id"), Shift _I5)+    , ((_I0, Icon "("),  Shift _I4)+    , ((_I1, Icon "+"),  Shift _I6)+    , ((_I1, IconEOF),        Accept)+    , ((_I2, Icon "+"),  r2)+    , ((_I2, Icon "*"),  Shift _I7)+    , ((_I2, Icon ")"),  r2)+    , ((_I2, IconEOF),        r2)+    , ((_I3, Icon "+"),  r4)+    , ((_I3, Icon "*"),  r4)+    , ((_I3, Icon ")"),  r4)+    , ((_I3, IconEOF),        r4)+    , ((_I4, Icon "id"), Shift _I5)+    , ((_I4, Icon "("),  Shift _I4)+    , ((_I5, Icon "+"),  r6)+    , ((_I5, Icon "*"),  r6)+    , ((_I5, Icon ")"),  r6)+    , ((_I5, IconEOF),        r6)+    , ((_I6, Icon "id"), Shift _I5)+    , ((_I6, Icon "("),  Shift _I4)+    , ((_I7, Icon "id"), Shift _I5)+    , ((_I7, Icon "("),  Shift _I4)+    , ((_I8, Icon "+"),  Shift _I6)+    , ((_I8, Icon ")"),  Shift _I11)+    , ((_I9, Icon "+"),  r1)+    , ((_I9, Icon "*"),  Shift _I7)+    , ((_I9, Icon ")"),  r1)+    , ((_I9, IconEOF),        r1)+    , ((_I10, Icon "+"), r3)+    , ((_I10, Icon "*"), r3)+    , ((_I10, Icon ")"), r3)+    , ((_I10, IconEOF),       r3)+    , ((_I11, Icon "+"), r5)+    , ((_I11, Icon "*"), r5)+    , ((_I11, Icon ")"), r5)+    , ((_I11, IconEOF),       r5)+    ]++testLRRecognize =+  slrRecognize grm w0+  @?=+  True++testLRRecognize2 =+  slrRecognize grm ["id", "*", "id", "+", "+", ""]+  @?=+  False++type LRAST = AST LR1NonTerminal LR1Terminal++action0 :: ParseEvent LRAST LR1NonTerminal LR1Terminal -> LRAST+action0 (TermE "")              = LeafEps+action0 (TermE t)               = Leaf t+action0 (NonTE (nt, ss, asts))  = AST nt ss asts++testLRParse =+  slrParse grm action0 w0+  @?=+  (ResultAccept $+    AST "E" [NT "E", T "+", NT "T"]+      [ AST "E" [NT "T"]+          [ AST "T" [NT "T", T "*", NT "F"]+              [ AST "T" [NT "F"] [AST "F" [T "id"] [Leaf "id"]]+              , Leaf "*"+              , AST "F" [T "id"] [Leaf "id"]+              ]+          ]+      , Leaf "+"+      , AST "T" [NT "F"] [AST "F" [T "id"] [Leaf "id"]]+      ])++testLRParse2 =+  isError (slrParse grm action0 ["id", "*", "id", "+", "+", "_"])+  @?=+  True++w0 = ["id", "*", "id", "+", "id", ""]++testLR1Table =+  lr1Table dragonBook455+  @?=+  lr1TableExp++lr1TableExp = M.fromList+  [ ((i0, Icon "c"), Shift i3)+  , ((i0, Icon "d"), Shift i4)+  , ((i1, IconEOF),       Accept)+  , ((i2, Icon "c"), Shift i6)+  , ((i2, Icon "d"), Shift i7)+  , ((i3, Icon "c"), Shift i3)+  , ((i3, Icon "d"), Shift i4)+  , ((i4, Icon "c"), r3')+  , ((i4, Icon "d"), r3')+  , ((i5, IconEOF),       r1')+  , ((i6, Icon "c"), Shift i6)+  , ((i6, Icon "d"), Shift i7)+  , ((i7, IconEOF),       r3')+  , ((i8, Icon "c"), r2')+  , ((i8, Icon "d"), r2')+  , ((i9, IconEOF),       r2')+  ]++--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"]++testLR1Items =+  lr1Items dragonBook455+  @?=+  fromList [i0,i1,i2,i3,i4,i5,i6,i7,i8,i9]++-- page 262 of soft cover dragon book:+i0 = fromList+  [ Item (Init   "S") [] [NT "S"]         IconEOF+  , Item (ItemNT "S") [] [NT "C", NT "C"] IconEOF+  , Item (ItemNT "C") [] [T "c", NT "C"]  (Icon "c")+  , Item (ItemNT "C") [] [T "c", NT "C"]  (Icon "d")+  , Item (ItemNT "C") [] [T "d"]          (Icon "c")+  , Item (ItemNT "C") [] [T "d"]          (Icon "d")+  ]++i1 = fromList [ Item (Init "S") [NT "S"] [] IconEOF ]++i2 = fromList+  [ Item (ItemNT "S") [NT "C"] [NT "C"]   IconEOF+  , Item (ItemNT "C") [] [T "c", NT "C"]  IconEOF+  , Item (ItemNT "C") [] [T "d"]          IconEOF+  ]++i3 = fromList+  [ Item (ItemNT "C") [T "c"] [NT "C"]    (Icon "c")+  , Item (ItemNT "C") [T "c"] [NT "C"]    (Icon "d")+  , Item (ItemNT "C") [] [T "c", NT "C"]  (Icon "c")+  , Item (ItemNT "C") [] [T "c", NT "C"]  (Icon "d")+  , Item (ItemNT "C") [] [T "d"]          (Icon "c")+  , Item (ItemNT "C") [] [T "d"]          (Icon "d")+  ]++i4 = fromList+  [ Item (ItemNT "C") [T "d"] [] (Icon "c")+  , Item (ItemNT "C") [T "d"] [] (Icon "d")+  ]++i5 = fromList [ Item (ItemNT "S") [NT "C", NT "C"] [] IconEOF ]++i6 = fromList+  [ Item (ItemNT "C") [T "c"] [NT "C"]    IconEOF+  , Item (ItemNT "C") [] [T "c", NT "C"]  IconEOF+  , Item (ItemNT "C") [] [T "d"]          IconEOF+  ]++i7 = fromList [ Item (ItemNT "C") [T "d"] [] IconEOF ]++i8 = fromList+  [ Item (ItemNT "C") [NT "C", T "c"] [] (Icon "c")+  , Item (ItemNT "C") [NT "C", T "c"] [] (Icon "d")+  ]++i9 = fromList [ Item (ItemNT "C") [NT "C", T "c"] [] IconEOF ]++getAST (ResultAccept ast) = ast+getAST _ = error "bad parse"++testLR1Parse =+  getAST (lr1Parse grm action0 w0)+  @?=+  getAST (slrParse grm action0 w0)++testPrettify = unsafePerformIO $ putStrLn $ T.unpack $ pshow testSLRExp++testGLRParse =+  glrParse grm action0 w0+  @?=+  (ResultSet $ S.fromList [ ResultAccept (+    AST "E" [NT "E",T "+",NT "T"]+      [AST "E" [NT "T"]+        [AST "T" [NT "T",T "*",NT "F"]+          [AST "T" [NT "F"]+            [AST "F" [T "id"] [Leaf "id"]]+          ,Leaf "*"+          ,AST "F" [T "id"]+            [Leaf "id"]]]+        ,Leaf "+"+        ,AST "T" [NT "F"]+          [AST "F" [T "id"] [Leaf "id"]]])])++main :: IO ()+main = defaultMainWithOpts+  [ testCase "closure" testClosure+  , testCase "kernel"  testKernel+  , testProperty "closure-closure" propClosureClosure+  , testCase "items" testItems+  , testCase "closedItems0" closedItems0+  , testProperty  "closedItems" closedItems+  , testCase "slrTable" testSLRTable+  , testCase "slrTable2" testSLRTable2+  , testCase "slrTable3" testSLRTable3+  , testCase "testLRRecognize" testLRRecognize+  , testCase "testLRRecognize2" testLRRecognize2+  , testCase "testLRParse" testLRParse+  , testCase "testLRParse2" testLRParse2+  , testCase "testLR1Parse" testLR1Parse+  , testCase "testLR1Items" testLR1Items+  , testCase "testLR1Table" testLR1Table+  , testCase "testPrettify" (testPrettify @?= ())+  , testCase "testGLR" testGLRParse+  ] mempty+
+ test/sexpression/Grammar.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances, TemplateHaskell #-}+module Grammar where+import Language.ANTLR4++{-+  The MIT License+  Copyright (c) 2008 Robert Stehwien+  Permission is hereby granted, free of charge, to any person obtaining a copy+  of this software and associated documentation files (the "Software"), to deal+  in the Software without restriction, including without limitation the rights+  to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+  copies of the Software, and to permit persons to whom the Software is+  furnished to do so, subject to the following conditions:+  The above copyright notice and this permission notice shall be included in+  all copies or substantial portions of the Software.+  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+  OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+  THE SOFTWARE.+  +  Port to Antlr4 by Tom Everett+  Subsequent port to antlr-haskell by Karl Cronburg+-}++data Atom+  = Str String+  | Symb String+  | Number Double+  deriving (Eq, Ord, Show)++data Item+  = Atm   Atom+  | List  [Item]+  | Field Item Item+  deriving (Eq, Ord, Show)++[g4|+  grammar Sexpression;++  sexpr+     : item*+     ;++  item+     : atom                   -> ${\a -> Atm a}+     | list                   -> List+     | '(' item '.' item ')'  -> Field+     ;++  list+     : '(' item* ')'+     ;++  atom+     : STRING -> Str+     | SYMBOL -> Symb+     | NUMBER -> Number+     ;++  STRING : '"' ( ('\\' .) | ~ ["\\] )* '"' -> String;++  WHITESPACE : [ \n\t\r]+ -> String;++  NUMBER : ('+' | '-')? DIGIT+ ('.' DIGIT+)? -> Double;++  SYMBOL : SYMBOL_START (SYMBOL_START | DIGIT)* -> String;++  fragment SYMBOL_START : [a-zA-Z+\-*/] ;++  fragment DIGIT : [0-9] ;++|]++isWS T_WHITESPACE = True+isWS _ = False+
+ test/sexpression/Parser.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances, TemplateHaskell #-}+module Parser+  ( module Grammar+  , glrParseFast+  ) where+import Language.ANTLR4+import Grammar++--import qualified GHC.Types as G+import qualified Text.ANTLR.LR as LR++$(mkLRParser the_ast sexpressionGrammar)+
+ test/sexpression/sexpression.hs view
@@ -0,0 +1,13 @@+module Main where+import Language.ANTLR4+import Grammar+import qualified Text.ANTLR.Set as S++getAST (ResultAccept ast) = ast+getAST _ = error "non-AST in ResultSet"++main =+  case glrParse isWS "((m1lk ju1ce 3.1) . (h0ney marmalade \"jam\"))" of+    (ResultAccept ast) -> print $ ast2sexpr ast+    (ResultSet xs)     -> mapM_ (print . ast2sexpr . getAST) (S.toList xs)+
+ test/shared-hunit/Text/ANTLR/HUnit.hs view
@@ -0,0 +1,46 @@+module Text.ANTLR.HUnit where+import           Control.DeepSeq+import           Control.Exception as E+import           Control.Monad+import           Data.List+import           Data.Typeable+import           Data.CallStack+import Test.HUnit.Lang hiding (assertEqual, (@?=))++import Text.ANTLR.Pretty+import qualified Data.Text as T++location :: HasCallStack => Maybe SrcLoc+location = case reverse callStack of+  (_, loc) : _ -> Just loc+  [] -> Nothing++-- | Asserts that the specified actual value is equal to the expected value.+-- The output message will contain the prefix, the expected value, and the+-- actual value.+--+-- If the prefix is the empty string (i.e., @\"\"@), then the prefix is omitted+-- and only the expected and actual values are output.+assertEqual :: (HasCallStack, Eq a, Prettify a)+                              => String -- ^ The message prefix+                              -> a      -- ^ The expected value+                              -> a      -- ^ The actual value+                              -> Assertion+assertEqual preface expected actual =+  unless (actual == expected) $ do+    (prefaceMsg `deepseq` expectedMsg `deepseq` actualMsg `deepseq` E.throwIO (HUnitFailure location $ ExpectedButGot prefaceMsg expectedMsg actualMsg))+  where+    prefaceMsg+      | null preface = Nothing+      | otherwise = Just preface+    expectedMsg = '\n' : T.unpack (pshowIndent 4 expected)+    actualMsg   = '\n' : T.unpack (pshowIndent 4 actual)++-- | Asserts that the specified actual value is equal to the expected value+--   (with the actual value on the left-hand side).+(@?=) :: (HasCallStack, Eq a, Prettify a)+                        => a -- ^ The actual value+                        -> a -- ^ The expected value+                        -> Assertion+actual @?= expected = assertEqual "" expected actual+
+ test/shared/Grammar.hs view
@@ -0,0 +1,18 @@+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 view
@@ -0,0 +1,14 @@+{-# 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 view
@@ -0,0 +1,15 @@+{-# 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 view
@@ -0,0 +1,28 @@+{-# 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 view
@@ -0,0 +1,134 @@+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 view
@@ -0,0 +1,102 @@+{-# 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
@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes+    , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances+    , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell+    , DeriveDataTypeable #-}+module Grammar 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)++data Attr = A | B++data Decl = Foo | Bar++[g4|+	grammar Simple;++	attrDecl : attr* decl ;++  attrDecl2 : attr? decl ;++  attrDecl3 : attr+ decl ;++	attr  : 'a' ';' -> A+        | 'b' ';' -> B+        ;++  decl  : 'foo' -> Foo+        | 'bar' -> Bar+        ;++|]+
+ test/simple/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 Grammar++foo = [ $(lift $ LR.lr1Table simpleGrammar) ]++--test_star = foo @?= []+test_star = () @?= ()++main :: IO ()+main = defaultMainWithOpts+  [ testCase "test_star" test_star+  ] mempty+
+ test/template/Main.hs view
@@ -0,0 +1,16 @@+module Main 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++main :: IO ()+main = defaultMainWithOpts+  [+  ] mempty+