diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright T. N. Hayashi (c) 2020 + +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 T. N. Hayashi 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,69 @@ +# penntreebank-megaparsec :: Megaparsec parsers for trees in the Penn Treebank format +![Travis CI build :: master](https://img.shields.io/travis/aslemen/penntreebank-megaparsec/master?label=Travis%20CI%20build%20%3A%3A%20master) + +This Haskell package provides parsers for syntactic trees annotated + in the Penn Treebank format, powered + by [Megaparsec](https://hackage.haskell.org/package/megaparsec). + +It supports vertical composition of custom label parsers with tree parsers, + which means you can customize your label parsers + and use these parsers to perform parsing of labels + at the same time as that of trees. +For the following example of categorial grammar trees, + +``` +(A/B (B He) + (B\ thinks)) +``` + +the result of tree parsing is: + +```haskell +Node "A/B" [ + Node "B" [ + Node "He" [] + ], + Node "B\" [ + Node "thinks" [] + ] +] +``` + +which you can make followed by a secondary parsing of labels (= categories): + +```haskell +Node (CatRight (Atom B) (Atom A)) [ + Node (Atom B) [ + Node (Lex "He") [] + ], + Node (CatLeft (Atom B) (CatRight (Atom B) (Atom A))) [ + Node (Lex "thinks") [] + ] +] +``` + +## Usage +```haskell +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +import Data.Tree.Parser.Penn.Megaparsec.Char as TC +import Data.Text (Text) +import Text.Megaparsec as MegaP + +-- define the node type +data PennNode = NonTerm Text | Term Text deriving (Show) + +-- define the node parsers +instance {-# OVERLAPS #-} TC.ParsableAsTerm Text PennNode where + pNonTerm = NonTerm <$> MegaP.takeRest + pTerm = Term <$> MegaP.takeRest + +-- specify and disambiguate the type of the input stream +parser :: (Monad m) => TC.PennTreeParserT Text m PennNode +parser = TC.pTree + +main :: IO () +main = MegaP.parseTest parser "(A (B C (D E)))" + +``` diff --git a/penntreebank-megaparsec.cabal b/penntreebank-megaparsec.cabal new file mode 100644 --- /dev/null +++ b/penntreebank-megaparsec.cabal @@ -0,0 +1,68 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 51655472fc364cb3aeec7d393dc61d5a63bc39a28b01833e78f57bec3545b7c8 + +name: penntreebank-megaparsec +version: 0.1.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. +category: Parsing, Natural Language Processing +homepage: https://github.com/aslemen/penntreebank-megaparsec#readme +bug-reports: https://github.com/aslemen/penntreebank-megaparsec/issues +author: Nori Hayashi +maintainer: Nori Hayashi +copyright: 2020 Nori Hayashi +license: BSD3 +license-file: LICENSE +tested-with: GHC==8.4.4, GHC==8.6.5, GHC==8.8.1 +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/aslemen/penntreebank-megaparsec + +library + exposed-modules: + Data.Tree.Parser.Penn.Megaparsec.Char + Data.Tree.Parser.Penn.Megaparsec.Internal + Text.PennTreebank.Parser.Megaparsec.Char + other-modules: + Paths_penntreebank_megaparsec + hs-source-dirs: + src + build-depends: + base >=4.11 && <5 + , containers >=0.5 && <0.7 + , megaparsec >=8.0 && <9 + , mtl >=2.2.2 && <3 + , transformers >=0.4 && <0.6 + default-language: Haskell2010 + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Data.Tree.Parser.Penn.Megaparsec.CharSpec + Paths_penntreebank_megaparsec + hs-source-dirs: + test/unit + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-tool-depends: + hspec-discover:hspec-discover + build-depends: + base >=4.11 && <5 + , containers >=0.5 && <0.7 + , hspec >=2.0 && <3.0 + , megaparsec >=8.0 && <9 + , mtl >=2.2.2 && <3 + , penntreebank-megaparsec + , 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 new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Parser/Penn/Megaparsec/Char.hs @@ -0,0 +1,182 @@ +{-| + Module : Data.Tree.Parser.Penn.Megaparsec + Description : Parser combinators that parse 'Data.Text' + or 'String' streams to generate Penn Treebank trees. + Copyright : (c) 2020 Nori Hayashi + License : BSD3 + Maintainer : Nori Hayashi + Stability : experimental + Portability : portable + Language : Haskell2010 +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Tree.Parser.Penn.Megaparsec.Char ( + -- * Parsers + pTree, + ParsableAsTerm(..), + + -- * Parser Type Synonyms + PennTreeParserT, + PennTreeParser, + + -- * Parser Runners + -- | Re-imported from "Text.Megaparsec". + parse, + parseMaybe, + parseTest, + runParser, + runParser', + runParserT, + runParserT' +) where + +import Data.Char as DCh +import Data.Tree +import Data.Void (Void) +import Data.Proxy (Proxy(..)) + +import Text.Megaparsec +import qualified Text.Megaparsec.Char as MC +import qualified Text.Megaparsec.Char.Lexer as Lex + +import Control.Monad (forM_) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Identity (Identity) + +import Data.Tree.Parser.Penn.Megaparsec.Internal + +-- | A parser (monad transformer) that consumes spaces. +spaceConsumer :: (MonadParsec err str m, Token str ~ Char) => m () +spaceConsumer + = Lex.space + MC.space1 -- Space + empty -- LineComment + empty -- BlockComment + +-- | A parser (monad transformer) wrapper to make lexemes separated by spaces. +lexer :: (MonadParsec err str m, Token str ~ Char) + => m term -- ^ A lexeme parser to be wrapped + -> m term -- ^ The parser wrapped by spaces +lexer = Lex.lexeme spaceConsumer + +-- | A parser (monad transformer) wrapper that parenthesize the given parser. +pParens :: ( + MonadParsec err str m, + Token str ~ Char, + Tokens str ~ str + ) => m term -- ^ A parser to be wrapped + -> m term -- ^ The parser wrapped by parentheses +pParens = + between + (lexer $ single '(') + (lexer $ single ')') + +-- | A parser for raw node labels. +invokeLabelParserRaw :: (MonadParsec err str m, Token str ~ Char) + => m (Tokens str) +invokeLabelParserRaw + = takeWhile1P + (Just "Literal String") + (\x -> x /= '(' && x /= ')' && not (DCh.isSpace x)) + +{-| + A vertial parser (monad transformer) compositor that + make raw node labels get a secondary parse + by another parser. +-} +invokeLabelParser :: ( + Ord err, + ParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m term -- ^ A secondary parser for node labels + -> State str err -- ^ The state given by the main parsing thread + -> ParsecT err str m term -- ^ The resulting parser that is going to be embedded in the main thread +invokeLabelParser labelParser substate = do + (_, res) <- lift $ runParserT' (labelParser <* eof) substate + case res of + Left b@(ParseErrorBundle errors _) -> do + 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, + @str@ is the type of the stream, + @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 + specifying the type @term@ as an instance of '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 + to specify what type of stream you target at in the following way: + + > (pTree :: ParsecT Void Text Identity (Tree Text)) +-} + +pTree :: + ( + Ord err, + ParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m (Tree term) +pTree + = pParens pTreeInside <|> pTerminalNode "Parsed Tree" + where + pTreeInside :: forall str. forall err. forall m. forall term. ( + Ord err, + ParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m (Tree term) + pTreeInside = do + state <- getParserState + maybeLabelRaw <- lexer $ optional invokeLabelParserRaw + let substate = state { + stateInput + = case maybeLabelRaw of + Just labelRaw -> labelRaw + Nothing -> tokensToChunk pxy [] + , + stateOffset = 0 + } + labelParsed <- invokeLabelParser pNonTerm substate + children <- many $ lexer pTree -- Recursion + return $ Node labelParsed children + where + pxy :: Proxy str + pxy = Proxy + + pTerminalNode :: ( + Ord err, + ParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m (Tree term) + pTerminalNode = do + state <- getParserState + labelRaw <- lexer $ invokeLabelParserRaw + labelParsed <- do + let substate = state { + stateInput = labelRaw, + stateOffset = 0 + } + invokeLabelParser pTerm substate + return $ Node labelParsed [] + +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/Internal.hs b/src/Data/Tree/Parser/Penn/Megaparsec/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Tree/Parser/Penn/Megaparsec/Internal.hs @@ -0,0 +1,38 @@ +{-| + Module : Data.Tree.Parser.Penn.Megaparsec.Internal + Description : The internal module for tree parsers + Copyright : (c) 2020 Nori Hayashi + License : BSD3 + Maintainer : Nori Hayashi + Stability : experimental + Portability : portable + Language : Haskell2010 +-} + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Tree.Parser.Penn.Megaparsec.Internal ( + 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@. +-} +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@. + -} + pNonTerm :: (Ord err) => ParsecT err str m term + 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 new file mode 100644 --- /dev/null +++ b/src/Text/PennTreebank/Parser/Megaparsec/Char.hs @@ -0,0 +1,92 @@ +{-| + Module : Data.Tree.Parser.Penn.Megaparsec + Description : Parser combinators that parse Penn Trebank files. + Copyright : (c) 2020 Nori Hayashi + License : BSD3 + Maintainer : Nori Hayashi + Stability : experimental + Portability : portable + Language : Haskell2010 +-} + +{-# LANGUAGE TypeFamilies #-} + +module Text.PennTreebank.Parser.Megaparsec.Char ( + -- * Parser + pDoc, + + -- * Parser Runners + -- | Re-imported from "Text.Megaparsec". + parse, + parseMaybe, + parseTest, + runParser, + runParser', + runParserT, + runParserT' +) where + +import Text.Megaparsec +import Text.Megaparsec.Char.Lexer as Lex + +import Data.Maybe (fromMaybe, catMaybes) +import Data.Tree +import Data.Void (Void) +import qualified Text.Megaparsec.Char as MC +import qualified Data.Tree.Parser.Penn.Megaparsec.Char as TPC + +import Control.Monad (forM_) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Identity (Identity) + +data ParserOption = ParserOption { + ignoreLabelError :: Bool +} + +-- | A parser (monad transformer) that consumes spaces. +spaceConsumer :: (MonadParsec err str m, Token str ~ Char) => m () +spaceConsumer + = Lex.space + MC.space1 -- Space + empty -- LineComment + empty -- BlockComment + +-- | A parser (monad transformer) wrapper to make lexemes separated by spaces. +lexer :: (MonadParsec err str m, Token str ~ Char) + => m term -- ^ A lexeme parser to be wrapped + -> m term -- ^ The parser wrapped by spaces +lexer = Lex.lexeme spaceConsumer + +{-| + A parser (parser monad transformer) + for treebank files 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. + + 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 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: + + > (pDoc :: ParsecT Void Text Identity [Tree Text]) +-} +pDoc :: ( + Ord err, + TPC.ParsableAsTerm str term, + Monad m, + Token str ~ Char, + Tokens str ~ str + ) => ParsecT err str m [Tree term] +pDoc = do + MC.space + doc <- many $ lexer TPC.pTree + eof + return doc diff --git a/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs b/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Data/Tree/Parser/Penn/Megaparsec/CharSpec.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Tree.Parser.Penn.Megaparsec.CharSpec ( + spec +) where + +import Test.Hspec +-- import Test.QuickCheck +-- import Control.Exception (evaluate) +import Control.Monad.Identity + +import Data.Void (Void) +import Data.Text (Text) +import Data.Tree +import Text.Megaparsec + +import Data.Tree.Parser.Penn.Megaparsec.Char as TC + +parser :: (Monad m) => TC.PennTreeParserT Text m Text +parser = TC.pTree + +spec :: Spec +spec = do + describe "pTree" $ do + it "parses" $ do + parseTest parser "" + parseTest parser "()" + parseTest parser "( )" + parseTest parser "A" + 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)" diff --git a/test/unit/Spec.hs b/test/unit/Spec.hs new file mode 100644 --- /dev/null +++ b/test/unit/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}