diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Change Log + +* April 14, 2018: Moved to hpack's package.yaml format instead of native cabal + file. + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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']) +``` + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/antlr-haskell.cabal b/antlr-haskell.cabal new file mode 100644 --- /dev/null +++ b/antlr-haskell.cabal @@ -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 and . +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.* diff --git a/src/Data/Set/Monad.hs b/src/Data/Set/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Data/Set/Monad.hs @@ -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. + + +@[@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. + + +-} + + +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 + diff --git a/src/Language/ANTLR4.hs b/src/Language/ANTLR4.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4.hs @@ -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(..)) + diff --git a/src/Language/ANTLR4/Boot/Quote.hs b/src/Language/ANTLR4/Boot/Quote.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/Boot/Quote.hs @@ -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) + |] + diff --git a/src/Language/ANTLR4/Boot/SplicedParser.hs b/src/Language/ANTLR4/Boot/SplicedParser.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/Boot/SplicedParser.hs @@ -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 + diff --git a/src/Language/ANTLR4/Boot/Syntax.hs b/src/Language/ANTLR4/Boot/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/Boot/Syntax.hs @@ -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 + diff --git a/src/Language/ANTLR4/FileOpener.hs b/src/Language/ANTLR4/FileOpener.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/FileOpener.hs @@ -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 |] + diff --git a/src/Language/ANTLR4/G4.hs b/src/Language/ANTLR4/G4.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/G4.hs @@ -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 + diff --git a/src/Language/ANTLR4/Parser.hs b/src/Language/ANTLR4/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/Parser.hs @@ -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 + ; +|] +-} diff --git a/src/Language/ANTLR4/Syntax.hs b/src/Language/ANTLR4/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/ANTLR4/Syntax.hs @@ -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 + diff --git a/src/Text/ANTLR/Allstar.hs b/src/Text/ANTLR/Allstar.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Allstar.hs @@ -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 + diff --git a/src/Text/ANTLR/Allstar/ATN.hs b/src/Text/ANTLR/Allstar/ATN.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Allstar/ATN.hs @@ -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 + } diff --git a/src/Text/ANTLR/Allstar/ParserGenerator.hs b/src/Text/ANTLR/Allstar/ParserGenerator.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Allstar/ParserGenerator.hs @@ -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) + diff --git a/src/Text/ANTLR/Allstar/Stacks.hs b/src/Text/ANTLR/Allstar/Stacks.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Allstar/Stacks.hs @@ -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 $ _Γ) + diff --git a/src/Text/ANTLR/Common.hs b/src/Text/ANTLR/Common.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Common.hs @@ -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 + diff --git a/src/Text/ANTLR/Grammar.hs b/src/Text/ANTLR/Grammar.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Grammar.hs @@ -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 + diff --git a/src/Text/ANTLR/LL1.hs b/src/Text/ANTLR/LL1.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/LL1.hs @@ -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 + diff --git a/src/Text/ANTLR/LR.hs b/src/Text/ANTLR/LR.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/LR.hs @@ -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 + ]) diff --git a/src/Text/ANTLR/Language.hs b/src/Text/ANTLR/Language.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Language.hs @@ -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 + diff --git a/src/Text/ANTLR/Lex.hs b/src/Text/ANTLR/Lex.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Lex.hs @@ -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 + diff --git a/src/Text/ANTLR/Lex/Automata.hs b/src/Text/ANTLR/Lex/Automata.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Lex/Automata.hs @@ -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` _Δ ] + diff --git a/src/Text/ANTLR/Lex/DFA.hs b/src/Text/ANTLR/Lex/DFA.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Lex/DFA.hs @@ -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) + diff --git a/src/Text/ANTLR/Lex/NFA.hs b/src/Text/ANTLR/Lex/NFA.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Lex/NFA.hs @@ -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'] + , _Δ = _Δ' + } + diff --git a/src/Text/ANTLR/Lex/Regex.hs b/src/Text/ANTLR/Lex/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Lex/Regex.hs @@ -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 + diff --git a/src/Text/ANTLR/Lex/Tokenizer.hs b/src/Text/ANTLR/Lex/Tokenizer.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Lex/Tokenizer.hs @@ -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 + diff --git a/src/Text/ANTLR/MultiMap.hs b/src/Text/ANTLR/MultiMap.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/MultiMap.hs @@ -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 + ] + diff --git a/src/Text/ANTLR/Parser.hs b/src/Text/ANTLR/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Parser.hs @@ -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 + diff --git a/src/Text/ANTLR/Pretty.hs b/src/Text/ANTLR/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Pretty.hs @@ -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 + diff --git a/src/Text/ANTLR/Set.hs b/src/Text/ANTLR/Set.hs new file mode 100644 --- /dev/null +++ b/src/Text/ANTLR/Set.hs @@ -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 + +-} + diff --git a/test/allstar/AllStarTests.hs b/test/allstar/AllStarTests.hs new file mode 100644 --- /dev/null +++ b/test/allstar/AllStarTests.hs @@ -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) diff --git a/test/allstar/Main.hs b/test/allstar/Main.hs new file mode 100644 --- /dev/null +++ b/test/allstar/Main.hs @@ -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 + diff --git a/test/atn/Main.hs b/test/atn/Main.hs new file mode 100644 --- /dev/null +++ b/test/atn/Main.hs @@ -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 + diff --git a/test/chisel/Language/Chisel/Grammar.hs b/test/chisel/Language/Chisel/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/chisel/Language/Chisel/Grammar.hs @@ -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 + diff --git a/test/chisel/Language/Chisel/Parser.hs b/test/chisel/Language/Chisel/Parser.hs new file mode 100644 --- /dev/null +++ b/test/chisel/Language/Chisel/Parser.hs @@ -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) + diff --git a/test/chisel/Language/Chisel/Syntax.hs b/test/chisel/Language/Chisel/Syntax.hs new file mode 100644 --- /dev/null +++ b/test/chisel/Language/Chisel/Syntax.hs @@ -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 + diff --git a/test/chisel/Main.hs b/test/chisel/Main.hs new file mode 100644 --- /dev/null +++ b/test/chisel/Main.hs @@ -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 + diff --git a/test/coreg4/Main.hs b/test/coreg4/Main.hs new file mode 100644 --- /dev/null +++ b/test/coreg4/Main.hs @@ -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 + diff --git a/test/g4/G4.hs b/test/g4/G4.hs new file mode 100644 --- /dev/null +++ b/test/g4/G4.hs @@ -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) + diff --git a/test/g4/Main.hs b/test/g4/Main.hs new file mode 100644 --- /dev/null +++ b/test/g4/Main.hs @@ -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 + diff --git a/test/lexer/Main.hs b/test/lexer/Main.hs new file mode 100644 --- /dev/null +++ b/test/lexer/Main.hs @@ -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 + diff --git a/test/ll/Main.hs b/test/ll/Main.hs new file mode 100644 --- /dev/null +++ b/test/ll/Main.hs @@ -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 + diff --git a/test/lr/Main.hs b/test/lr/Main.hs new file mode 100644 --- /dev/null +++ b/test/lr/Main.hs @@ -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 + diff --git a/test/sexpression/Grammar.hs b/test/sexpression/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/sexpression/Grammar.hs @@ -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 + diff --git a/test/sexpression/Parser.hs b/test/sexpression/Parser.hs new file mode 100644 --- /dev/null +++ b/test/sexpression/Parser.hs @@ -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) + diff --git a/test/sexpression/sexpression.hs b/test/sexpression/sexpression.hs new file mode 100644 --- /dev/null +++ b/test/sexpression/sexpression.hs @@ -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) + diff --git a/test/shared-hunit/Text/ANTLR/HUnit.hs b/test/shared-hunit/Text/ANTLR/HUnit.hs new file mode 100644 --- /dev/null +++ b/test/shared-hunit/Text/ANTLR/HUnit.hs @@ -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 + diff --git a/test/shared/Grammar.hs b/test/shared/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/shared/Grammar.hs @@ -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 + + diff --git a/test/shared/Language/ANTLR4/Example/G4.hs b/test/shared/Language/ANTLR4/Example/G4.hs new file mode 100644 --- /dev/null +++ b/test/shared/Language/ANTLR4/Example/G4.hs @@ -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' + ; +|] + diff --git a/test/shared/Language/ANTLR4/Example/Hello.hs b/test/shared/Language/ANTLR4/Example/Hello.hs new file mode 100644 --- /dev/null +++ b/test/shared/Language/ANTLR4/Example/Hello.hs @@ -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; +|] + diff --git a/test/shared/Language/ANTLR4/Example/Optionals.hs b/test/shared/Language/ANTLR4/Example/Optionals.hs new file mode 100644 --- /dev/null +++ b/test/shared/Language/ANTLR4/Example/Optionals.hs @@ -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 + diff --git a/test/shared/Text/ANTLR/Allstar/Example/ATN.hs b/test/shared/Text/ANTLR/Allstar/Example/ATN.hs new file mode 100644 --- /dev/null +++ b/test/shared/Text/ANTLR/Allstar/Example/ATN.hs @@ -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") + ] + } + + diff --git a/test/shared/Text/ANTLR/Example/Grammar.hs b/test/shared/Text/ANTLR/Example/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/shared/Text/ANTLR/Example/Grammar.hs @@ -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)] + } + diff --git a/test/simple/Grammar.hs b/test/simple/Grammar.hs new file mode 100644 --- /dev/null +++ b/test/simple/Grammar.hs @@ -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 + ; + +|] + diff --git a/test/simple/Main.hs b/test/simple/Main.hs new file mode 100644 --- /dev/null +++ b/test/simple/Main.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, TypeFamilies, QuasiQuotes + , DataKinds, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances + , FlexibleInstances, UndecidableInstances, FlexibleContexts, TemplateHaskell + , DeriveDataTypeable #-} +module Main where +import Language.ANTLR4 + +import System.IO.Unsafe (unsafePerformIO) +import Data.Monoid +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import Test.HUnit +import Test.QuickCheck (Property, quickCheck, (==>)) +import qualified Test.QuickCheck.Monadic as TQM + +import Language.Haskell.TH.Syntax (lift) +import qualified Text.ANTLR.LR as LR + +import Grammar + +foo = [ $(lift $ LR.lr1Table simpleGrammar) ] + +--test_star = foo @?= [] +test_star = () @?= () + +main :: IO () +main = defaultMainWithOpts + [ testCase "test_star" test_star + ] mempty + diff --git a/test/template/Main.hs b/test/template/Main.hs new file mode 100644 --- /dev/null +++ b/test/template/Main.hs @@ -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 +