diff --git a/penntreebank-megaparsec.cabal b/penntreebank-megaparsec.cabal --- a/penntreebank-megaparsec.cabal +++ b/penntreebank-megaparsec.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 51655472fc364cb3aeec7d393dc61d5a63bc39a28b01833e78f57bec3545b7c8 +-- hash: 036bc4d19d0a78ab78a47028866e8797551bb1f1cae0234cec98bc3809355351 name: penntreebank-megaparsec -version: 0.1.0 +version: 0.2.0 synopsis: Parser combinators for trees in the Penn Treebank format description: This Haskell package provides parsers for syntactic trees annotated in the Penn Treebank format, powered by Megaparsec. @@ -31,6 +31,7 @@ library exposed-modules: Data.Tree.Parser.Penn.Megaparsec.Char + Data.Tree.Parser.Penn.Megaparsec.Char.QQ Data.Tree.Parser.Penn.Megaparsec.Internal Text.PennTreebank.Parser.Megaparsec.Char other-modules: @@ -42,6 +43,7 @@ , containers >=0.5 && <0.7 , megaparsec >=8.0 && <9 , mtl >=2.2.2 && <3 + , template-haskell >=2.13 && <3 , transformers >=0.4 && <0.6 default-language: Haskell2010 @@ -63,6 +65,7 @@ , megaparsec >=8.0 && <9 , mtl >=2.2.2 && <3 , penntreebank-megaparsec + , template-haskell >=2.13 && <3 , text >=0.2 && <1.3 , transformers >=0.4 && <0.6 default-language: Haskell2010 diff --git a/src/Data/Tree/Parser/Penn/Megaparsec/Char.hs b/src/Data/Tree/Parser/Penn/Megaparsec/Char.hs --- a/src/Data/Tree/Parser/Penn/Megaparsec/Char.hs +++ b/src/Data/Tree/Parser/Penn/Megaparsec/Char.hs @@ -11,14 +11,19 @@ -} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Tree.Parser.Penn.Megaparsec.Char ( + -- * Type Classes for Node Parsers + ParsableAsTerm(..), + UnsafelyParsableAsTerm(..), + -- * Parsers pTree, - ParsableAsTerm(..), + pUnsafeTree, -- * Parser Type Synonyms PennTreeParserT, @@ -35,7 +40,7 @@ runParserT' ) where -import Data.Char as DCh +import Data.Char (isSpace) import Data.Tree import Data.Void (Void) import Data.Proxy (Proxy(..)) @@ -50,6 +55,40 @@ import Data.Tree.Parser.Penn.Megaparsec.Internal +{-| + A type class for node label types @term@ + data of which can be obtained by parsing a stream of type @str@ + that is supposed to be embedded into the parser + 'Data.Tree.Parser.Penn.Megaparsec.Char.pUnsafeTree'. + It is your own responsibility to avoid these parsers to crash + by letting them unintendedly consume + symbols preserved for tree node demarcation + (e.g. parentheses and spaces). + + @since 0.1.1 +-} +class (Stream str) => UnsafelyParsableAsTerm str term where + {-| + A parser for non-terminal node labels. + -} + pUnsafeNonTerm :: (Ord err) => ParsecT err str m term + + {-| + A parser for terminal node labels. + This parser may not comsume empty inputs, + for otherwise parsing will fall into infinte recursion. + -} + pUnsafeTerm :: (Ord err) => ParsecT err str m term + +instance (Stream str, Tokens str ~ term, Token str ~ Char) + => UnsafelyParsableAsTerm str term where + pUnsafeNonTerm + = takeWhileP (Just "Non-Terminal Label") + (\c -> c /= '(' && c /= ')' && not (isSpace c)) + pUnsafeTerm + = takeWhile1P (Just "Terminal Label") + (\c -> c /= '(' && c /= ')' && not (isSpace c)) + -- | A parser (monad transformer) that consumes spaces. spaceConsumer :: (MonadParsec err str m, Token str ~ Char) => m () spaceConsumer @@ -82,7 +121,7 @@ invokeLabelParserRaw = takeWhile1P (Just "Literal String") - (\x -> x /= '(' && x /= ')' && not (DCh.isSpace x)) + (\x -> x /= '(' && x /= ')' && not (isSpace x)) {-| A vertial parser (monad transformer) compositor that @@ -105,6 +144,7 @@ forM_ errors registerParseError return undefined Right label -> return label + {-| A parser (parser monad transformer) for trees in the Penn Treebank format, where @err@ is the type of custom errors, @@ -112,8 +152,11 @@ @m@ is the type of the undelying monad and @term@ is the type of node labels. - This parser will do a secondary parse for node labels (of type @term@). - The secondary node label parser is designated by + This parser will do a preliminary parse for + node labels as raw strings of type @str@. + The carved strings will contain no spaces or parentheses. + A seconsary parsing will take place on the spot + the way of parsing of which is designated by you specifying the type @term@ as an instance of 'ParsableAsTerm'. This parser accepts various types of text stream, @@ -123,7 +166,6 @@ > (pTree :: ParsecT Void Text Identity (Tree Text)) -} - pTree :: ( Ord err, @@ -177,6 +219,64 @@ } invokeLabelParser pTerm substate return $ Node labelParsed [] + +{-| + Another parser for trees in the Penn Treebank format, + where @err@ is the type of custom errors, + @str@ is the type of the stream, + @m@ is the type of the undelying monad and + @term@ is the type of node labels. + + Apart from 'pTree', you can customize node label parsers + in a more liberal way + by specifying the type @term@ + as an instance of 'UnsafelyParsableAsTerm'. + You can let parsers consume spaces and parentheses + (perhaps with quotation markers) + unless they do not broke the parsing of the whole trees. + It is all your responsibility to make sure of it. + + This parser accepts various types of text stream, + including 'String', 'Data.Text.Text' and 'Data.Text.Lazy.Text'. + You might need to manually annotate the type of this parser + to specify what type of stream you target at in the following way: + + > (pUnsafeTree :: ParsecT Void Text Identity (Tree Text)) + + @since 0.1.1 +-} +pUnsafeTree :: + ( + Ord err, + UnsafelyParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m (Tree term) +pUnsafeTree + = pParens pTreeInside <|> pTerminalNode "Parsed Tree" + where + pTreeInside :: forall str. forall err. forall m. forall term. ( + Ord err, + UnsafelyParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m (Tree term) + pTreeInside + = Node + <$> lexer pUnsafeNonTerm + <*> (many $ lexer pUnsafeTree) + + pTerminalNode :: ( + Ord err, + UnsafelyParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m (Tree term) + pTerminalNode + = Node <$> lexer pUnsafeTerm <*> pure [] type PennTreeParserT str m term = ParsecT Void str m (Tree term) type PennTreeParser str term = PennTreeParserT str Identity term diff --git a/src/Data/Tree/Parser/Penn/Megaparsec/Char/QQ.hs b/src/Data/Tree/Parser/Penn/Megaparsec/Char/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Parser/Penn/Megaparsec/Char/QQ.hs @@ -0,0 +1,104 @@ +{-| + Module : Data.Tree.Parser.Penn.Megaparsec + Description : Quasiquoters that quotes strings representation of treebank trees. + Copyright : (c) 2020 Nori Hayashi + License : BSD3 + Maintainer : Nori Hayashi + Stability : experimental + Portability : portable + Language : Haskell2010 +-} + +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Tree.Parser.Penn.Megaparsec.Char.QQ ( + pennTreeQQ + , penn + , pennTreeUnsafeQQ + , pennUnsafe +) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Quote +import Text.Megaparsec +import qualified Text.Megaparsec.Char as MC + +import Data.Tree +import Data.Tree.Parser.Penn.Megaparsec.Char + +instance (Lift a) => Lift (Tree a) where + lift (Node root children) = do + qRoot <- lift root + qChildren <- mapM lift children + return $ (ConE 'Node) + `AppE` qRoot + `AppE` (ListE qChildren) + +pennTreeQQ :: + forall a. (ParsableAsTerm String a, Lift a) + => QuasiQuoter +pennTreeQQ = QuasiQuoter + { + quoteDec = error "Exp quoter only" + , quoteExp = expQ + , quotePat = error "Dec quoter only" + , quoteType = error "Dec quoter only" + } + where + parser :: PennTreeParser String a + parser = do + MC.space + tree <- pTree + MC.space + eof + return tree + expQ :: String -> Q Exp + expQ str = do + let pres = parse + parser + "Haskell QuasiQuote" + str + case pres of + Left errbundle -> do + reportError $ errorBundlePretty errbundle + return undefined + Right t -> lift t + +penn = pennTreeQQ + +pennTreeUnsafeQQ :: + forall a. (UnsafelyParsableAsTerm String a, Lift a) + => QuasiQuoter +pennTreeUnsafeQQ = QuasiQuoter + { + quoteDec = error "Exp quoter only" + , quoteExp = expQ + , quotePat = error "Dec quoter only" + , quoteType = error "Dec quoter only" + } + where + parser :: PennTreeParser String a + parser = do + MC.space + tree <- pUnsafeTree + MC.space + eof + return tree + expQ :: String -> Q Exp + expQ str = do + let pres = parse + parser + "Haskell QuasiQuote" + str + case pres of + Left errbundle -> do + reportError $ errorBundlePretty errbundle + return undefined + Right t -> lift t + +pennUnsafe = pennTreeUnsafeQQ diff --git a/src/Data/Tree/Parser/Penn/Megaparsec/Internal.hs b/src/Data/Tree/Parser/Penn/Megaparsec/Internal.hs --- a/src/Data/Tree/Parser/Penn/Megaparsec/Internal.hs +++ b/src/Data/Tree/Parser/Penn/Megaparsec/Internal.hs @@ -15,24 +15,33 @@ {-# LANGUAGE TypeFamilies #-} module Data.Tree.Parser.Penn.Megaparsec.Internal ( - ParsableAsTerm(..) + ParsableAsTerm(..), ) where import Text.Megaparsec {-| A type class for node label types @term@ - data of which can be obtained by parsing a stream of type @str@. + data of which can be obtained by parsing a stream of type @str@ + that is safely carved by the tree parser + 'Data.Tree.Parser.Penn.Megaparsec.Char.pTree' + containing no spaces and parenthese. -} class (Stream str) => ParsableAsTerm str term where {-| - A parser that extracts exactly one token - of the node label type @term@ from an input stream of type @str@. + A parser for non-terminal node labels. + Empty inputs are expected. -} pNonTerm :: (Ord err) => ParsecT err str m term + + {-| + A parser for terminal node labels. + Empty inputs are not expected. + -} pTerm :: (Ord err) => ParsecT err str m term instance (Stream str, Tokens str ~ term) => ParsableAsTerm str term where pNonTerm = takeRest pTerm = takeRest + diff --git a/src/Text/PennTreebank/Parser/Megaparsec/Char.hs b/src/Text/PennTreebank/Parser/Megaparsec/Char.hs --- a/src/Text/PennTreebank/Parser/Megaparsec/Char.hs +++ b/src/Text/PennTreebank/Parser/Megaparsec/Char.hs @@ -14,7 +14,12 @@ module Text.PennTreebank.Parser.Megaparsec.Char ( -- * Parser pDoc, + pUnsafeDoc, + -- * Parser Type Synonyms + PennDocParserT, + PennDocParser, + -- * Parser Runners -- | Re-imported from "Text.Megaparsec". parse, @@ -65,12 +70,15 @@ @m@ is the type of the undelying monad and @term@ is the type of node labels. - This parser will do a secondary parse for node labels, - results of which are of type @term@. - Failures are registered to the main tree parsing process. - The secondary node label parser is designated by - specifying @term@ as an instance of 'Data.Tree.Parser.Penn.Megaparsec.Internal.ParsableAsTerm'. - + This parser invokes + 'Data.Tree.Parser.Penn.Megaparsec.Char.pTree' + which will do inside an initial parse for + node labels as raw strings of type @str@. + A seconsary parsing will take place on the spot + the way of parsing of which is designated by you + specifying the type @term@ as an instance of + 'Data.Tree.Parser.Penn.Megaparsec.Internal.ParsableAsTerm'. + This parser accepts various types of text stream, including 'String', 'Data.Text.Text' and 'Data.Text.Lazy.Text'. You might need to manually annotate the type of this parser @@ -90,3 +98,45 @@ doc <- many $ lexer TPC.pTree eof return doc + +{-| + Another parser + for treebank files in the Penn Treebank format + via 'Data.Tree.Parser.Penn.Megaparsec.Char.pUnsafeTree'. + + This parser will do a secondary parse for node labels, + results of which are of type @term@. + You can customize node label parsers + in a more liberal way + by specifying the type @term@ + as an instance of + 'Data.Tree.Parser.Penn.Megaparsec.Char.UnsafelyParsableAsTerm'. + You can let parsers consume spaces and parentheses + (perhaps with quotation markers) + unless they do not broke the parsing of the whole trees. + It is all your responsibility to make sure of it. + + This parser accepts various types of text stream, + including 'String', 'Data.Text.Text' and 'Data.Text.Lazy.Text'. + You might need to manually annotate the type of this parser + to specify what type of stream you target at in the following way: + + > (pUnsafeDoc :: ParsecT Void Text Identity [Tree Text]) + + @since 0.1.1 +-} +pUnsafeDoc :: ( + Ord err, + TPC.UnsafelyParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m [Tree term] +pUnsafeDoc = do + MC.space + doc <- many $ lexer TPC.pUnsafeTree + eof + return doc + +type PennDocParserT str m term = ParsecT Void str m [Tree term] +type PennDocParser str term = PennDocParserT str Identity term diff --git a/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs b/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs --- a/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs +++ b/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs @@ -1,5 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} - +{-# LANGUAGE QuasiQuotes #-} module Data.Tree.Parser.Penn.Megaparsec.CharSpec ( spec ) where @@ -15,10 +15,14 @@ import Text.Megaparsec import Data.Tree.Parser.Penn.Megaparsec.Char as TC +import Data.Tree.Parser.Penn.Megaparsec.Char.QQ parser :: (Monad m) => TC.PennTreeParserT Text m Text parser = TC.pTree +parserUnsafe :: (Monad m) => TC.PennTreeParserT Text m Text +parserUnsafe = TC.pUnsafeTree + spec :: Spec spec = do describe "pTree" $ do @@ -30,6 +34,37 @@ parseTest parser "A B V" parseTest parser "A (B V)" parseTest parser "(A (B V))" + parseTest parser "( A (B V))" parseTest parser "(A (B C (D E)))" it "fails against broken trees" $ do parseTest parser "(A (B C (D E)" + describe "pTreeQQ" $ do + it "parses" $ example $ do + return [penn| () |] + return [penn| ( ) |] + return [penn| A |] + return [penn| (A (B V)) |] + return [penn| ( A (B V)) |] + return [penn| (A (B C (D E))) |] + return () + describe "pUnsafeTree" $ do + it "parses" $ do + parseTest parserUnsafe "" + parseTest parserUnsafe "()" + parseTest parserUnsafe "( )" + parseTest parserUnsafe "A" + parseTest parserUnsafe "A B V" + parseTest parserUnsafe "A (B V)" + parseTest parserUnsafe "(A (B V))" + parseTest parserUnsafe "(A (B C (D E)))" + it "fails against broken trees" $ do + parseTest parserUnsafe "(A (B C (D E)" + describe "pUnsafeTreeQQ" $ do + it "parses" $ example $ do + return [pennUnsafe| () |] + return [pennUnsafe| ( ) |] + return [pennUnsafe| A |] + return [pennUnsafe| (A (B V)) |] + return [pennUnsafe| ( A (B V)) |] + return [pennUnsafe| (A (B C (D E))) |] + return ()