diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2014, attempto +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 attempto nor the + names of its 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 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/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/ace.cabal b/ace.cabal new file mode 100644 --- /dev/null +++ b/ace.cabal @@ -0,0 +1,44 @@ +name: ace +version: 0.0 +synopsis: Attempto Controlled English parser and printer +description: Attempto Controlled English is a formally defined unambiguous language which + is a subset of the English language. This package provides a tokenizer, + parser and printer for that language. Specifically, it implements the + declarative mood and the interrogative mood. + + The imperative mood is omitted at this time. Interpretation rules, + conversion to FoL, or any further analysis is not implemented by this + library. +license: BSD3 +license-file: LICENSE +author: Chris Done +maintainer: chrisdone@gmail.com +copyright: 2014 Chris Done +category: Linguistics +build-type: Simple +cabal-version: >=1.8 + +library + hs-source-dirs: src/ + ghc-options: -Wall -O2 + exposed-modules: ACE, ACE.Types.Syntax, ACE.Parsers, ACE.Tokenizer, ACE.Types.Tokens, ACE.Combinators + build-depends: attoparsec >= 0.11.1.0, + parsec >= 3.1.5, + data-default >= 0.5.3, + semigroups >= 0.12.2, + text >= 0.11.2.0, + base >= 4 && <5, + bifunctors + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: base, + ace, + HUnit, + hspec, + parsec, + bifunctors, + text, + mtl diff --git a/src/ACE.hs b/src/ACE.hs new file mode 100644 --- /dev/null +++ b/src/ACE.hs @@ -0,0 +1,11 @@ +-- | Attempto Controlled English parser and printer. + +module ACE + (module ACE.Types.Syntax + ,module ACE.Tokenizer + ,module ACE.Types.Tokens) + where + +import ACE.Tokenizer +import ACE.Types.Tokens +import ACE.Types.Syntax diff --git a/src/ACE/Combinators.hs b/src/ACE/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/ACE/Combinators.hs @@ -0,0 +1,128 @@ +{-# LANGUAGE FlexibleContexts #-} + +-- | Parser combinators. + +module ACE.Combinators where + +import ACE.Types.Tokens + +import Data.Text (Text) +import qualified Data.Text as T +import Text.Parsec.Pos +import Text.Parsec.Prim + +-- | Match a word with the given string. +string :: Stream s m Token => Text -> ParsecT s u m Text +string s = + satisfy + (\t -> + case t of + Word _ t' -> if t' == s then Just t' else Nothing + _ -> Nothing) + +-- | Match a Saxon genitive. +genitive :: Stream s m Token => ParsecT s u m Bool +genitive = + satisfy + (\t -> + case t of + Genitive _ hasS -> Just hasS + _ -> Nothing) + +-- | Match a word with the given string. +number :: Stream s m Token => ParsecT s u m Integer +number = + satisfy + (\t -> + case t of + Number _ t' -> Just t' + _ -> Nothing) + +-- | Quoted string. +quoted :: Stream s m Token => ParsecT s u m Text +quoted = + satisfy + (\t -> + case t of + QuotedString _ t' -> Just t' + _ -> Nothing) + +-- | A comma. +comma :: Stream s m Token => ParsecT s u m () +comma = + satisfy + (\t -> + case t of + Comma _ -> Just () + _ -> Nothing) + +-- | A period. +period :: Stream s m Token => ParsecT s u m () +period = + satisfy + (\t -> + case t of + Period _ -> Just () + _ -> Nothing) + +-- | Try to match all the given strings, or none at all. +strings :: Stream s m Token => [Text] -> ParsecT s u m () +strings ss = + try (sequence_ (map string ss)) + +-- | Satisfy the given predicate from the token stream. +satisfy :: Stream s m Token => (Token -> Maybe a) -> ParsecT s u m a +satisfy f = + tokenPrim tokenString + tokenPosition + f + +-- | The parser @anyToken@ accepts any kind of token. It is for example +-- used to implement 'eof'. Returns the accepted token. +anyToken :: (Stream s m Token) => ParsecT s u m Token +anyToken = satisfy Just + +-- | Make a string out of the token, for error message purposes. +tokenString :: Token -> [Char] +tokenString t = + case t of + Word _ w -> "word \"" ++ T.unpack w ++ "\"" + QuotedString _ s -> "quotation \"" ++ T.unpack s ++ "\"" + Period{} -> "period" + Comma{} -> "comma" + QuestionMark{} -> "question mark" + Genitive _ s -> + if s + then "genitive 's" + else "genitive '" + Number _ n -> "number: " ++ show n + +-- | Update the position by the token. +tokenPosition :: SourcePos -> Token -> t -> SourcePos +tokenPosition pos t _ = + setSourceColumn (setSourceLine pos line) col + where (line,col) = tokenPos t + +-- | @notFollowedBy p@ only succeeds when parser @p@ fails. This parser +-- does not consume any input. This parser can be used to implement the +-- \'longest match\' rule. For example, when recognizing keywords (for +-- example @let@), we want to make sure that a keyword is not followed +-- by a legal identifier character, in which case the keyword is +-- actually an identifier (for example @lets@). We can program this +-- behaviour as follows: +-- +-- > keywordLet = try (do{ string "let" +-- > ; notFollowedBy alphaNum +-- > }) +notFollowedBy :: (Stream s m Token) => ParsecT s u m Token -> ParsecT s u m () +notFollowedBy p = + try ((do c <- try p + unexpected (tokenString c)) <|> + return ()) + +-- | This parser only succeeds at the end of the input. This is not a +-- primitive parser but it is defined using 'notFollowedBy'. +-- +-- > eof = notFollowedBy anyToken "end of input" +eof :: (Stream s m Token) => ParsecT s u m () +eof = notFollowedBy anyToken "end of input" diff --git a/src/ACE/Parsers.hs b/src/ACE/Parsers.hs new file mode 100644 --- /dev/null +++ b/src/ACE/Parsers.hs @@ -0,0 +1,559 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +{-# OPTIONS -fno-warn-missing-signatures #-} + +-- | Parsers for ACE syntax types. + +module ACE.Parsers where + +import ACE.Combinators +import ACE.Types.Syntax +import ACE.Types.Tokens + +import Control.Applicative +import Control.Monad hiding (ap) +import Data.Text (Text) +import Text.Parsec () +import Text.Parsec.Prim (Stream,ParsecT,try,getState) + +-- | Parser configuration. +data ACEParser s m = ACE + { aceIntransitiveAdjective :: ParsecT s (ACEParser s m) m Text -- ^ Parser for intransitive adjectives. + , aceTransitiveAdjective :: ParsecT s (ACEParser s m) m Text -- ^ Parser for transitive adjectives. + , aceNoun :: ParsecT s (ACEParser s m) m Text -- ^ Parser for nouns. + , acePreposition :: ParsecT s (ACEParser s m) m Text -- ^ Parser for prepositions. + , aceVariable :: ParsecT s (ACEParser s m) m Text -- ^ Parser for variables. + , aceProperName :: ParsecT s (ACEParser s m) m Text -- ^ Parser for proper names. + , aceAdverb :: ParsecT s (ACEParser s m) m Text -- ^ Parser for adverbs. + , aceIntransitiveVerb :: ParsecT s (ACEParser s m) m Text -- ^ Parser for intransitive verbs. + , acePhrasalTransitiveV :: ParsecT s (ACEParser s m) m Text -- ^ Parser for phrasal transitive verbs. + , acePhrasalDistransitiveV :: ParsecT s (ACEParser s m) m Text -- ^ Parser for phrasal distransitive verbs. + , aceTransitiveVerb :: ParsecT s (ACEParser s m) m Text -- ^ Parser for transitive verbs. + , aceDistransitiveVerb :: ParsecT s (ACEParser s m) m Text -- ^ Parser for distransitive verbs. + , acePhrasalParticle :: ParsecT s (ACEParser s m) m Text -- ^ Parser for phrasal particles. + , acePhrasalIntransitiveV :: ParsecT s (ACEParser s m) m Text -- ^ Parser for phrasal intransitive verbs. + } + +-- | A default ACE parser configuration. Just fills in all the parsers as blanks: @\@, @\@, etc. +defaultACEParser :: Stream s m Token => ACEParser s m +defaultACEParser = + ACE { aceIntransitiveAdjective = string "" + , aceTransitiveAdjective = string "" + , aceNoun = string "" + , acePreposition = string "" + , aceVariable = string "" + , aceProperName = string "" + , aceAdverb = string "" + , aceIntransitiveVerb = string "" + , aceDistransitiveVerb = string "" + , acePhrasalParticle = string "" + , acePhrasalIntransitiveV = string "" + , acePhrasalDistransitiveV = string "" + , aceTransitiveVerb = string "" + , acePhrasalTransitiveV = string "" + } + +-- | Some specification. A 'sentenceCoord' followed by a 'period', and +-- optionally another 'specification'. +specification = + Specification + <$> sentenceCoord <* period + <*> optional (try specification) + +-- | Coordinated sentence, by: or +sentenceCoord = + SentenceCoord + <$> sentenceCoord_1 + <*> optional (try (string "or" *> sentenceCoord)) + +-- | Coordinated sentence, by: and +sentenceCoord_1 = + SentenceCoord_1 + <$> sentenceCoord_2 + <*> optional (try (comma *> string "and" *> sentenceCoord_1)) + +-- | Coordinated sentence, by: or +sentenceCoord_2 = + SentenceCoord_2 + <$> sentenceCoord_3 + <*> optional (try (string "or" *> sentenceCoord_2)) + +-- | Coordinated sentence, by: and +sentenceCoord_3 = + SentenceCoord_3 + <$> topicalizedSentence + <*> optional (try (string "and" *> sentenceCoord_3)) + +-- | A topicalized sentence. +topicalizedSentence = + (TopicalizedSentenceExistential <$> existentialTopic <*> optional (try sentenceCoord)) <|> + (TopicalizedSentenceUniversal <$> universalTopic <*> sentenceCoord) <|> + (TopicalizedSentenceComposite <$> compositeSentence) + +-- | A universally quantified topic. +universalTopic = + UniversalTopic <$> universalGlobalQuantor + <*> n' False + +-- | A composite sentence: 'conditionalSentence', 'negatedSentence' or 'sentence'. +compositeSentence = + compositeSentenceCond <|> + compositeSentenceNeg <|> + compositeSentence' + where compositeSentenceCond = + CompositeSentenceCond <$> conditionalSentence + compositeSentenceNeg = + CompositeSentenceNeg <$> negatedSentence + compositeSentence' = + CompositeSentence <$> sentence + +-- | A negated sentence: it is not the case that 'sentenceCoord' +negatedSentence = + NegatedSentence + <$> (strings ["it","is","not","the","case","that"] *> + sentenceCoord) + +-- | A condition if 'sentenceCoord' then 'sentenceCoord'. +conditionalSentence = + ConditionalSentence + <$> (string "if" *> sentenceCoord) + <*> (string "then" *> sentenceCoord) + +-- | Sentence: 'npCoord' 'vpCoord': a cat meows +sentence = + Sentence + <$> npCoord + <*> vpCoord + +-- | Existential topic, a 'existentialGlobalQuantor' and a 'npCoord': there is a chair +existentialTopic = + ExistentialTopic + <$> existentialGlobalQuantor + <*> npCoord + +-- | A noun specifier: \"a\", \"some\", \"1\", \"'s\". +specifier = + specifierDeterminer <|> + specifierPossessive <|> + specifierNumber + where specifierDeterminer = + SpecifyDeterminer <$> determiner + specifierPossessive = + SpecifyPossessive <$> possessiveNPCoord + specifierNumber = + SpecifyNumberP <$> numberP + +-- | A preposition. Configured by 'acePreposition'. +preposition = + Preposition <$> join (fmap acePreposition getState) + +-- | A genitive tail: dave's and a dog's +genitiveTail = + (GenitiveTailSaxonTail <$> saxonGenitiveTail) <|> + (GenitiveTailCoordtail <$> genitiveCoordTail) + +-- | A genitive coordination tail: dave's and a dog's +genitiveCoordTail = + GenitiveCoordTail <$> (try (string "and" *> genitiveNPCoord)) + +-- | Genitive tail. +saxonGenitiveTail = + SaxonGenitiveTail + <$> saxonGenitiveMarker + <*> optional + (try ((,) <$> genitiveN' + <*> saxonGenitiveTail)) + +-- | Apposition: either a 'variable' or a 'quotation'. +apposition = + (AppositionVar <$> variable) <|> + (AppositionQuote <$> quotation) + +-- | A apposition coordination: X and Y. +apposCoord = + ApposCoord + <$> apposition + <*> optional (try (string "and" *> apposCoord)) + +-- | A prepositional noun phrase coordination. +pp = + PP <$> preposition + <*> npCoord' + +-- | A 'relativeClause' coordination: person that walks and cake a +-- person made. +relativeClauseCoord = + RelativeClauseCoord + <$> relativeClause + <*> optional (try ((,) <$> coord + <*> relativeClauseCoord)) + +-- | A noun surrounded by optional 'adjectiveCoord', a noun word 'n', +-- an optional 'apposCoord', an optional 'ofPP', an optional +-- 'relativeClauseCoord'. +n' b = + N' <$> optional (try adjectiveCoord) + <*> n + <*> optional (try apposCoord) + <*> optional (try ofPP) + <*> if b + then pure Nothing + else optional (try relativeClauseCoord) + +-- | Unmarked noun phrase coordination: some thing and a thing. +unmarkedNPCoord b = + UnmarkedNPCoord + <$> np b + <*> optional (try (string "and" *> unmarkedNPCoord b)) + +-- | A noun phrase: a thing, some stuff, the thing. +np b = + NP <$> specifier + <*> n' b + +-- | A coordinated noun phrase. See 'npCoordX'. +npCoord = npCoordX False + +-- | A coordinated noun phrase. Inside a relative clause. See 'npCoordX'. +npCoord' = npCoordX True + +-- | Relative clause: person that walks, cake a person made, cake that a person made, etc. +relativeClause = + try (RelativeClauseThat <$> (string "that" *> vpCoord)) <|> + try (RelativeClauseNP <$> npCoord' <*> vpCoord) <|> + (RelativeClauseThatNPVP <$> (string "that" *> npCoord') <*> vpCoord) <|> + try (RelativeClauseNPVP <$> npCoord' <*> npCoord' <*> vpCoord) <|> + (RelativeClausePP <$> pp <*> npCoord' <*> vpCoord) + +-- | An "of" prepositional phrase: of the bank +ofPP = + string "of" *> npCoord + +-- | A coordinated noun phrase: each of some customers, some customers +npCoordX b = + distributed <|> unmarked + where distributed = + NPCoordDistributed <$> distributiveMarker <*> unmarkedNPCoord b + unmarked = + NPCoordUnmarked <$> unmarkedNPCoord b + +-- | A variable. Customized by 'aceVariable'. +variable = + Variable <$> join (fmap aceVariable getState) + +-- | A proper name. Customized by 'aceProperName'. +properName = + ProperName <$> join (fmap aceProperName getState) + +-- | Some quotation: \"foo bar\" +quotation = + Quotation <$> quoted + +-- | A noun. Customized by 'aceNoun'. +n = + N <$> join (fmap aceNoun getState) + +-- | A verb phrase coordination is either a 'vp' followed by a 'coord' +-- and more 'vpCoord', or just a 'vp': walks, walks and runs, bad and +-- is not valid +vpCoord = + do vp' <- vp + (try (VPCoord' + <$> pure vp' + <*> coord + <*> vpCoord) <|> + (VPCoordVP + <$> pure vp')) + +-- | A verb phrase. Can be normal 'v'' or a 'copula' followed by +-- \"not\" then 'v'': walks, is not valid, etc. +vp = + try (VP <$> v') <|> + (VPNeg <$> (copula <* string "not") <*> v') + +-- | A genitive noun: dog, red cat, person 1, movie \"We Need to Talk +-- About Kevin\". +genitiveN' = + GenitiveN' + <$> optional (try adjectiveCoord) + <*> n + <*> optional (try apposCoord) + +-- | A verb modifier: quickly and loudly, to a house, from now and forever +vModifier = + vModifierVC <|> try vModifierPP <|> vModifierAVPP + where vModifierVC = + VModifierVC <$> adverbCoord + vModifierPP = + VModifierPP <$> pp + vModifierAVPP = + VModifierAVPP <$> adverbialPP + +-- | Adverbial prepositional phrase: until here, by then, until now +-- and then +adverbialPP = + AdverbialPP + <$> preposition + <*> adverbCoord + +-- | A verb. Consists of an optional 'adverbCoord', a complemented +-- verb ('complV'), and one or more verb modifiers. +-- +-- TODO: I'm not actually sure whether it should be zero-to-1 or +-- zero-to-many. The paper isn't clear what VModifier* means. +v' = + V' <$> optional (try adverbCoord) + <*> complV + <*> many (try vModifier) + +-- | Genitive specifier: a, 1, some, his +genitiveSpecifier = + (GenitiveSpecifierD <$> determiner) <|> + (GenitiveSpecifierPPC <$> possessivePronounCoord) <|> + (GenitiveSpecifierN <$> number) + +-- | Either a 'genitiveNPCoord', or a 'possessivePronounCoord'. +possessiveNPCoord = + try (PossessiveNPCoordGen <$> genitiveNPCoord) <|> + (PossessiveNPCoordPronoun <$> possessivePronounCoord) + +-- | A \' or \'s saxon genitive. +saxonGenitiveMarker = + fmap (\s -> if s then ApostropheS else Apostrophe) + genitive + +-- | Possessive pronoun coordination: his and her +possessivePronounCoord = + PossessivePronounCoord + <$> possessivePronoun + <*> optional (try (string "and" *> possessivePronounCoord)) + +-- | A genitive noun phrase coordination: dave's, a dog's, a man and a dog's +genitiveNPCoord = + specifier' <|> name + where specifier' = + GenitiveNPCoord + <$> genitiveSpecifier + <*> genitiveN' + <*> genitiveTail + name = + GenitiveNPCoordName + <$> properName + <*> genitiveTail + +-- | A complemented verb. One of 'complVCopula', 'complVPDV', +-- 'complVDisV', 'complVPV', 'complVPV'', 'complVTV'. +complV = + complVIV <|> + complVPI <|> + complVTV <|> + complVPV <|> + complVPV' <|> + complVDisV <|> + complVPDV <|> + complVCopula + +-- | A complemented copula: is valid +complVCopula = + ComplVCopula <$> copula <*> copulaCompl + +-- | A distransitive phrasal verb: puts an error down to a customer +complVPDV = + ComplVPDV <$> phrasalDistransitiveV <*> compl <*> phrasalParticle <*> compl + +-- | A distransitive complemented verb: gives a card to a customer +complVDisV = + ComplVDisV <$> distransitiveV <*> compl <*> compl + +-- | A complemented phrasal transitive verb: gives away a code +complVPV = + ComplVPV <$> phrasalTransitiveV <*> phrasalParticle <*> compl + +-- | A complemented phrasal transitive verb, flipped: gives a code away +complVPV' = + ComplVPV' <$> phrasalTransitiveV <*> compl <*> phrasalParticle + +-- | Complemented transitive verb: inserts a card +complVTV = + ComplVTV <$> transitiveV <*> compl + +-- | A phrasal distransitive verb: puts an error down to a customer +phrasalDistransitiveV = + PhrasalDistransitiveV <$> join (fmap acePhrasalDistransitiveV getState) + +-- | A phrasal transitive verb: give away a thing +phrasalTransitiveV = + PhrasalTransitiveV <$> join (fmap acePhrasalTransitiveV getState) + +-- | Complemented non-copula verb, e.g. Mary sees him. +compl = + try (ComplNP <$> npCoord) <|> + (ComplPP <$> pp) + +-- | An intransitive verb. Takes no complement. E.g. walks. +complVIV = + ComplVIV <$> intransitiveV + +-- | A phrasal intransitive verb with a complement, in this case a +-- particle: gets in, sits up. +complVPI = + ComplVPI <$> phrasalIntransitiveV <*> phrasalParticle + +-- | A phrasal intransitive verb: gives, sits (e.g. gives up, sits +-- down). This is customized by 'acePhrasalIntransitiveV'. +phrasalIntransitiveV = + PhrasalIntransitiveV <$> join (fmap acePhrasalIntransitiveV getState) + +-- | A phrasal verb particle, e.g. in, up, out (get in, get up, get +-- out). This is customized via 'acePhrasalParticle'. +phrasalParticle = + PhrasalParticle <$> join (fmap acePhrasalParticle getState) + +-- | Either a graded adjective coordination (\"better than a duck and +-- faster than a mouse\"), or a noun phrase coordination (\"a goose +-- and an ocelot\"), or a prepositional phrase (\"to a bucket or a +-- kettle\"). +copulaCompl = + copulaComplAPC <|> + copulaComplNPC <|> + copulaComplPP + + where copulaComplAPC = CopulaComplAPC <$> apCoord + copulaComplNPC = CopulaComplNPC <$> npCoord + copulaComplPP = CopulaComplPP <$> pp + +-- | A coordination of a graded adjective: \"better than a potato and +-- nicer than some bacon\" +apCoord = apCoordAnd <|> apCoord' + where apCoordAnd = APCoordAnd <$> try (apGrad <* string "and") <*> apCoord + apCoord' = APCoord <$> apGrad + +-- | A graded adjective. Either comparative adjective phrase (\"better +-- than a potato\"), or a simple adjective phrase (see 'ap'). +apGrad = apGradThan <|> apGrad' + where apGradThan = APgradAPThan <$> try (ap <* string "than") <*> npCoord + apGrad' = APgradAP <$> ap + +-- | An adjective phrase. Transitive (fond of Mary, interested in an +-- account) or intransitive (correct, green, valid). +ap = + (APTrans <$> transitiveAdjective <*> pp) <|> + (APIntrans <$> intransitiveAdjective) + +-- | Some intransitive verb: walks +intransitiveV = + IntransitiveV <$> join (fmap aceIntransitiveVerb getState) + +-- | Some transitive verb: inserts +transitiveV = + TransitiveV <$> join (fmap aceTransitiveVerb getState) + +-- | Some distransitive verb: inserts +distransitiveV = + DistransitiveV <$> join (fmap aceDistransitiveVerb getState) + +-- | Adverb coordination: quickly and hastily and manually +adverbCoord = + AdverbCoord <$> adverb + <*> optional (try (string "and" *> adverbCoord)) + +-- | Adverb: quickly +adverb = + Adverb <$> join (fmap aceAdverb getState) + +-- | Adjective coordination: correct and green +adjectiveCoord = + AdjectiveCoord + <$> intransitiveAdjective + <*> optional (try (string "and" *> adjectiveCoord)) + +-- | Intransitive adjective: correct, green, valid +-- +-- The actual parser for this is provided as +-- 'aceIntransitiveAdjective' in the parser configuration. You can +-- configure this. +intransitiveAdjective = + IntransitiveAdjective <$> join (fmap aceIntransitiveAdjective getState) + +-- | Transitive adjective: correct, green, valid +transitiveAdjective = + TransitiveAdjective <$> join (fmap aceTransitiveAdjective getState) + +-- | A determiner: the, an, not every, etc. +determiner = + (string "the" *> pure The) <|> + (string "an" *> pure An) <|> + (string "a" *> pure A) <|> + (string "some" *> pure Some) <|> + (strings ["not","every"] *> pure NotEveryEach) <|> + (strings ["not","each"] *> pure NotEveryEach) <|> + (strings ["not","all"] *> pure NotAll) <|> + (string "no" *> pure No) <|> + (string "every" *> pure EveryEach) <|> + (string "each" *> pure EveryEach) <|> + (string "all" *> pure All) <|> + (string "which" *> pure Which) + +-- | A number phrase: more than 5 +numberP = + NumberP + <$> optional (try generalizedQuantor) + <*> number + +-- | There is/are. +existentialGlobalQuantor = + string "there" *> + (ExistentialGlobalQuantor <$> copula) + +-- | Is/are there? +existentialGlobalQuestionQuantor = + (ExistentialGlobalQuestionQuantor <$> copula) <* + string "there" + +-- | Do/does. +aux = + (string "do" *> pure Do) <|> + (string "does" *> pure Does) + +-- | And/or. +coord = + (string "and" *> pure And) <|> + (string "or" *> pure Or) + +-- | Is/are. +copula = + (string "is" *> pure Is) <|> + (string "are" *> pure Are) + +-- | A distributive global quantor: for each of +distributiveGlobalQuantor = + strings ["for","each","of"] *> pure ForEachOf + +-- | A distributive marker: each of +distributiveMarker = + strings ["each","of"] *> pure EachOf + +-- | A generalized quantor: at most, at least, etc. +generalizedQuantor = + (strings ["at","most"] *> pure AtMost) <|> + (strings ["at","least"] *> pure AtLeast) <|> + (strings ["more","than"] *> pure MoreThan) <|> + (strings ["less","than"] *> pure LessThan) <|> + (strings ["not","more","than"] *> pure NotMoreThan) <|> + (strings ["not","less","than"] *> pure NotLessThan) + +-- | A possessive pronoun: his, her, his/her. +possessivePronoun = + hisHer <|> its + where hisHer = + (string "his" <|> string "her" <|> string "his/her") *> + pure HisHer + its = string "its" *> pure Its + +-- | A universal global quantor: for every/for each, for all. +universalGlobalQuantor = + string "for" *> (everyEach <|> forAll) + where everyEach = (string "every" <|> string "each") *> pure ForEveryEach + forAll = string "all" *> pure ForAll diff --git a/src/ACE/Tokenizer.hs b/src/ACE/Tokenizer.hs new file mode 100644 --- /dev/null +++ b/src/ACE/Tokenizer.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE BangPatterns #-} +-- | Tokenizer for ACE. Tokens retain source locations (line and column). + +module ACE.Tokenizer where + +import ACE.Types.Tokens + +import Control.Applicative +import Control.Arrow +import Control.Monad +import Data.Attoparsec.Text hiding (number) +import Data.Char +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Read as T + +-- | Tokenize some complete ACE text. +tokenize :: Text -> Either String [Token] +tokenize = + parseOnly (fmap fst tokenizer <* endOfInput) + +-- | The tokenizer. +tokenizer :: Parser ([Token],(Int,Int)) +tokenizer = + manyWithPos (spaces >=> token) + genitive + (1,0) + +-- | Parse a token. +token :: (Int,Int) -> Parser (Token,(Int,Int)) +token pos = + number pos <|> + quotedString pos <|> + period pos <|> + comma pos <|> + questionMark pos <|> + word pos + +-- | Parse a number. +number :: (Int, Int) -> Parser (Token, (Int,Int)) +number pos = + fmap (\n -> (Number pos (either (const 0) fst (T.decimal n)),second (+ T.length n) pos)) + (takeWhile1 isDigit) + +-- | Parse a quoted string, @\"foobar\"@. +quotedString :: (Int,Int) -> Parser (Token,(Int,Int)) +quotedString pos = + char '"' *> (cons <$> takeWhile1 (/='"')) <* char '"' + where + cons x = + (QuotedString pos x + ,second (+ (T.length x + 2)) pos) + +-- | Parse a period \".\". +period :: (Int,Int) -> Parser (Token,(Int,Int)) +period pos = + char '.' *> pure (Period pos,second (+1) pos) + +-- | Parse a comma \",\". +comma :: (Int,Int) -> Parser (Token,(Int,Int)) +comma pos = + char ',' *> pure (Comma pos,second (+1) pos) + +-- | Parse a question mark \"?\". +questionMark :: (Int,Int) -> Parser (Token,(Int,Int)) +questionMark pos = + char '?' *> pure (QuestionMark pos,second (+1) pos) + +-- | Parse a word, which is any sequence of non-whitespace words +-- containing none of the other token characters. +word :: (Int,Int) -> Parser (Token,(Int,Int)) +word pos = + cons <$> takeWhile1 wordChar + where + cons w = (Word pos w,second (+ T.length w) pos) + wordChar c = + not (isSpace c) && + c /= '"' && + c /= '.' && + c /= '?' && + c /= ',' && + c /= '\'' + +-- | Parse the Saxon genitive ' or 's. This is ran after parsing every +-- token, but is expected to fail most of the time. +genitive :: (Int, Int) -> Parser (Maybe (Token,(Int, Int))) +genitive pos = + optional go + where + go = + do _ <- char '\'' + ms <- peekChar + case ms of + Just 's' -> anyChar *> pure (Genitive pos True,second (+1) pos) + _ -> pure (Genitive pos False,second (+1) pos) + +-- | Like 'many', but retains the current source position and supports +-- postfix-parsing of the genitive apostrophe. +manyWithPos :: (Monad m, Alternative m) + => ((t, t1) -> m (a, (t, t1))) -> ((t, t1) -> m (Maybe (a, (t, t1)))) + -> (t, t1) -> m ([a], (t, t1)) +manyWithPos p p' pos = + do r <- fmap (first Just) (p pos) <|> pure (Nothing,pos) + case r of + (Nothing,_) -> + return ([],pos) + (Just x,newpos@(!_,!_)) -> + do r' <- p' newpos + case r' of + Nothing -> + do (xs,finalpos) <- manyWithPos p p' newpos + return (x:xs,finalpos) + Just (y,newpos') -> + do (xs,finalpos) <- manyWithPos p p' newpos' + return (x:y:xs,finalpos) + +-- | Skip spaces (space, newline, tab (=4 spaces)) and keep +-- positioning information up to date. +spaces :: (Int,Int) -> Parser (Int,Int) +spaces (sline,scol) = + go sline scol + where + go line col = + do c <- peekChar + case c of + Just '\n' -> anyChar *> go (line+1) 0 + Just ' ' -> anyChar *> go line (col+1) + Just '\t' -> anyChar *> go line (col+4) + _ -> return (line,col) diff --git a/src/ACE/Types/Syntax.hs b/src/ACE/Types/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/ACE/Types/Syntax.hs @@ -0,0 +1,447 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE BangPatterns #-} + +-- | Types for the syntax tree. + +module ACE.Types.Syntax where + +import ACE.Pretty + +import Data.Semigroup +import Data.Text (Text) +import Prelude hiding (String) + +-- | Specifications consist of a sentence coordination followed by a +-- period and optionally one ore more subsequent specifications. +data Specification = + Specification !SentenceCoord !(Maybe Specification) + deriving (Show,Eq) + +-- | Sentences can be coordinated by @and@ and @or@. @And@ refers to the +-- logical conjunction, while @or@ de-notes the logical disjunction. The +-- logical conjunction has a higher precedence than the disjunction. +-- +-- Both connectors are right-associative. The expression +-- +-- A or B and C or D +-- +-- is therefore ordered like +-- +-- A ∨ ((B ∧ C) ∨ D) +-- +-- To enable more combinations, we have introduced comma-and and +-- comma-or. These expressions reverse the order of precedence. To +-- achieve the order +-- +-- A ∨ (B ∧ (C ∨ D)) +-- +-- we can write +-- +-- A, or B, and C or D +-- +-- A sentence coordination in general consists of a sentence +-- coordination of a lower level (thus ensuring right-associativity) +-- optionally followed by the respective connector and a sentence +-- coordination of the same level. +-- +data SentenceCoord = + SentenceCoord !SentenceCoord_1 !(Maybe SentenceCoord) + deriving (Show,Eq) + +data SentenceCoord_1 = + SentenceCoord_1 !SentenceCoord_2 !(Maybe SentenceCoord_1) + deriving (Show,Eq) + +data SentenceCoord_2 = + SentenceCoord_2 !SentenceCoord_3 !(Maybe SentenceCoord_2) + deriving (Show,Eq) + +data SentenceCoord_3 = + SentenceCoord_3 !TopicalizedSentence !(Maybe SentenceCoord_3) + deriving (Show,Eq) + +-- | Singular/plural. +data Plurality + = Singular + | Plural + deriving (Show,Eq) + +-- | A topicalized sentence can start with an existential topic or a +-- universal topic. It needs, however, not be topicalized at all but +-- can just be an ordinary composite sentence. +data TopicalizedSentence + = TopicalizedSentenceExistential !ExistentialTopic !(Maybe SentenceCoord) -- ^ Example: \"There is a card such that the code of the card is valid.\" + | TopicalizedSentenceUniversal !UniversalTopic !SentenceCoord -- ^ Example: \"For every code there is a card such that the code belongs to it.\" + | TopicalizedSentenceComposite !CompositeSentence -- ^ Example: \"Homer is a man.\" + deriving (Show,Eq) + +data UniversalTopic = + UniversalTopic !UniversalGlobalQuantor !N' + deriving (Show,Eq) + +data CompositeSentence + = CompositeSentenceCond !ConditionalSentence + | CompositeSentenceNeg !NegatedSentence + | CompositeSentence !Sentence + deriving (Show,Eq) + +data ConditionalSentence = + ConditionalSentence !SentenceCoord + !SentenceCoord + deriving (Show,Eq) + +data NegatedSentence = + NegatedSentence !SentenceCoord + deriving (Show,Eq) + +data Sentence = + Sentence !NPCoord !VPCoord + deriving (Show,Eq) + +data ExistentialTopic = + ExistentialTopic !ExistentialGlobalQuantor + !NPCoord + deriving (Show,Eq) + +data NPCoord + = NPCoordDistributed !DistributiveMarker !UnmarkedNPCoord + | NPCoordUnmarked !UnmarkedNPCoord + deriving (Show,Eq) + +data UnmarkedNPCoord = + UnmarkedNPCoord !NP !(Maybe UnmarkedNPCoord) + deriving (Show,Eq) + +-- | Modified noun. +data N' = + N' !(Maybe AdjectiveCoord) + !N + !(Maybe ApposCoord) + !(Maybe NPCoord) + !(Maybe RelativeClauseCoord) + deriving (Show,Eq) + +-- | Noun-phrase. +data NP = + NP !Specifier !N' + deriving (Show,Eq) + +-- | A noun. +data N = + N !Text + deriving (Show,Eq) + +data PP = + PP !Preposition !NPCoord + deriving (Show,Eq) + +data Preposition = + Preposition !Text + deriving (Show,Eq) + +data ApposCoord = + ApposCoord !Apposition !(Maybe ApposCoord) + deriving (Show,Eq) + +data Apposition + = AppositionVar !Variable + | AppositionQuote !Quotation + deriving (Show,Eq) + +data Quotation = + Quotation !Text + deriving (Show,Eq) + +data Variable = + Variable !Text + deriving (Show,Eq) + +data RelativeClauseCoord = + RelativeClauseCoord !RelativeClause !(Maybe (Coord,RelativeClauseCoord)) + deriving (Show,Eq) + +data PossessiveNPCoord + = PossessiveNPCoordGen !GenitiveNPCoord + | PossessiveNPCoordPronoun !PossessivePronounCoord + deriving (Show,Eq) + +data GenitiveNPCoord + = GenitiveNPCoord !GenitiveSpecifier !GenitiveN' !GenitiveTail + | GenitiveNPCoordName !ProperName !GenitiveTail + deriving (Show,Eq) + +data ProperName = + ProperName !Text + deriving (Show,Eq) + +data PossessivePronounCoord = + PossessivePronounCoord !PossessivePronoun + !(Maybe PossessivePronounCoord) + deriving (Show,Eq) + +data GenitiveTail + = GenitiveTailSaxonTail !SaxonGenitiveTail + | GenitiveTailCoordtail !GenitiveCoordTail + deriving (Show,Eq) + +data GenitiveCoordTail = + GenitiveCoordTail !GenitiveNPCoord + deriving (Show,Eq) + +data SaxonGenitiveTail = + SaxonGenitiveTail !SaxonGenitiveMarker !(Maybe (GenitiveN',SaxonGenitiveTail)) + deriving (Show,Eq) + +data RelativeClause + = RelativeClauseThat !VPCoord + | RelativeClauseNP !NPCoord !VPCoord + | RelativeClauseThatNPVP !NPCoord !VPCoord + | RelativeClauseNPVP !NPCoord !NPCoord !VPCoord + | RelativeClausePP !PP !NPCoord !VPCoord + deriving (Show,Eq) + +data VPCoord + = VPCoord' !VP !Coord !VPCoord + | VPCoordVP !VP + deriving (Show,Eq) + +data GenitiveSpecifier + = GenitiveSpecifierD !Determiner + | GenitiveSpecifierPPC !PossessivePronounCoord + | GenitiveSpecifierN !Integer + deriving (Show,Eq) + +data GenitiveN' = + GenitiveN' !(Maybe AdjectiveCoord) + !N + !(Maybe ApposCoord) + deriving (Show,Eq) + +data VP + = VP !V' + | VPNeg !Copula !V' + deriving (Show,Eq) + +data V' = + V' !(Maybe AdverbCoord) !ComplV ![VModifier] -- What is *? + deriving (Show,Eq) + +data AdverbCoord = + AdverbCoord !Adverb !(Maybe AdverbCoord) + deriving (Show,Eq) + +data ComplV + = ComplVIV !IntransitiveV + | ComplVPI !PhrasalIntransitiveV !PhrasalParticle + | ComplVTV !TransitiveV !Compl + | ComplVPV !PhrasalTransitiveV !PhrasalParticle !Compl + | ComplVPV' !PhrasalTransitiveV !Compl !PhrasalParticle + | ComplVDisV !DistransitiveV !Compl !Compl + | ComplVPDV !PhrasalDistransitiveV !Compl !PhrasalParticle !Compl + | ComplVCopula !Copula !CopulaCompl + deriving (Show,Eq) + +data PhrasalTransitiveV = + PhrasalTransitiveV !Text + deriving (Show,Eq) + +data PhrasalDistransitiveV = + PhrasalDistransitiveV !Text + deriving (Show,Eq) + +data CopulaCompl + = CopulaComplAPC !APCoord + | CopulaComplNPC !NPCoord + | CopulaComplPP !PP + deriving (Show,Eq) + +data APCoord + = APCoordAnd !APgrad !APCoord + | APCoord !APgrad + deriving (Show,Eq) + +data APgrad + = APgradAPThan !AP !NPCoord + | APgradAP !AP + deriving (Show,Eq) + +data AP + = APIntrans !IntransitiveAdjective + | APTrans !TransitiveAdjective !PP + deriving (Show,Eq) + +data TransitiveAdjective = + TransitiveAdjective !Text + deriving (Show,Eq) + +data Compl + = ComplNP !NPCoord + | ComplPP !PP + deriving (Show,Eq) + +data PhrasalIntransitiveV = + PhrasalIntransitiveV !Text + deriving (Show,Eq) + +data PhrasalParticle = + PhrasalParticle !Text + deriving (Show,Eq) + +data IntransitiveV = + IntransitiveV !Text + deriving (Show,Eq) + +data TransitiveV = + TransitiveV !Text + deriving (Show,Eq) + +data DistransitiveV = + DistransitiveV !Text + deriving (Show,Eq) + +data IntransitiveAdjective = + IntransitiveAdjective !Text + deriving (Show,Eq) + +data VModifier + = VModifierVC !AdverbCoord + | VModifierPP !PP + | VModifierAVPP !AdverbialPP + deriving (Show,Eq) + +data AdverbialPP = + AdverbialPP !Preposition !AdverbCoord + deriving (Show,Eq) + +data Adverb = + Adverb !Text + deriving (Show,Eq) + +data Specifier + = SpecifyDeterminer !Determiner + | SpecifyPossessive !PossessiveNPCoord + | SpecifyNumberP !NumberP + deriving (Show,Eq) + +data AdjectiveCoord = + AdjectiveCoord !IntransitiveAdjective + !(Maybe AdjectiveCoord) + deriving (Show,Eq) + +data NumberP = + NumberP !(Maybe GeneralizedQuantor) !Integer + deriving (Show,Eq) + +data ExistentialGlobalQuantor = + ExistentialGlobalQuantor !Copula + deriving (Show,Eq) + +data ExistentialGlobalQuestionQuantor = + ExistentialGlobalQuestionQuantor !Copula + deriving (Show,Eq) + +instance Pretty ExistentialGlobalQuestionQuantor where + pretty s x = + pretty s x <> " there" + +data Aux + = Do -- ^ \"do\" + | Does -- ^ \"does\" + deriving (Show,Eq) + +instance Pretty Aux where + pretty _ Do = "do" + pretty _ Does = "does" + +data Coord + = And -- ^ \"and\" + | Or -- ^ \"or\" + deriving (Show,Eq) + +instance Pretty Coord where + pretty _ And = "and" + pretty _ Or = "or" + +data Copula + = Is -- ^ \"is\" + | Are -- ^ \"are\" + deriving (Show,Eq) + +instance Pretty Copula where + pretty _ Is = "is" + pretty _ Are = "are" + +data Determiner + = The -- ^ \"the\" + | A -- ^ \"a\" + | An -- ^ \"an\" + | Some -- ^ \"some\" + | No -- ^ \"no\" + | EveryEach -- ^ \"every\" / \"each\" + | All -- ^ \"all\" + | NotEveryEach -- ^ \"not every\" / \"not each\" + | NotAll -- ^ \"not all\" + | Which -- ^ \"which\" + deriving (Show,Eq) + +data DistributiveGlobalQuantor = + ForEachOf -- ^ \"for each of\" + deriving (Show,Eq) + +data DistributiveMarker = + EachOf -- ^ \"each of\" + deriving (Show,Eq) + +data GeneralizedQuantor + = AtMost -- ^ \"at most\" + | AtLeast -- ^ \"at least\" + | MoreThan -- ^ \"more than\" + | LessThan -- ^ \"less than\" + | NotMoreThan -- ^ \"not more than\" + | NotLessThan -- ^ \"not less than\" + deriving (Show,Eq) + +data PossessivePronoun + = HisHer -- ^ \"his\" / \"her\" / \"his/her\" + | Its -- ^ \"its\" + | Their -- ^ \"their\" + | HisHerOwn -- ^ \"his own\" / \"her own\" / \"his/her own\" + | ItsOwn -- ^ \"its own\" + | TheirOwn -- ^ \"their own\" + | Whose -- ^ \"whose\" + deriving (Show,Eq) + +data Pronoun + = It -- ^ \"it\" + | HeShe -- ^ \"he\" / \"she\" + | Himher -- ^ \"him\" / \"her\" + | They -- ^ \"they\" + | Them -- ^ \"them\" + | Itself -- ^ \"itself\" + | HimHerSelf -- ^ \"himself\" / \"herself\" + | Themselves -- ^ \"themselves\" + | SomeoneSomebody -- ^ \"someone\" / \"somebody\" + | Something -- ^ \"something\" + | NoOneNobody -- ^ \"no one\" / \"nobody\" + | NoThing -- ^ \"nothing\" + | EveryoneEverybody -- ^ \"everyone\" / \"everybody\" + | Everything -- ^ \"everything\" + | NotEveryoneEverybody -- ^ \"not everyone\" / \"not everybody\" + | NotEverything -- ^ \"not everything\" + | WhatWho -- ^ \"what\" / \"who\" + | Whom -- ^ \"whom\" + | WhichWho -- ^ \"which\" / \"who\" + deriving (Show,Eq) + +-- | The Saxon genitive used for possession. +data SaxonGenitiveMarker + = Apostrophe -- ^ \"'\" + | ApostropheS -- ^ \"'s\" + deriving (Show,Eq) + +data UniversalGlobalQuantor + = ForEveryEach -- ^ \"for every\" / \"for each\" + | ForAll -- ^ \"for all\" + deriving (Show,Eq) diff --git a/src/ACE/Types/Tokens.hs b/src/ACE/Types/Tokens.hs new file mode 100644 --- /dev/null +++ b/src/ACE/Types/Tokens.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Tokens for ACE. + +module ACE.Types.Tokens + (Token(..) + ,tokenPos) + where + +import Data.Text (Text) + +-- | A token +data Token + = Word !(Int,Int) !Text + | QuotedString !(Int,Int) !Text + | Period !(Int,Int) + | Comma !(Int,Int) + | QuestionMark !(Int,Int) + | Genitive !(Int,Int) !Bool + | Number !(Int,Int) !Integer + deriving (Eq) + +-- | Get the position of the token. +tokenPos :: Token -> (Int, Int) +tokenPos t = + case t of + Word pos _ -> pos + QuotedString pos _ -> pos + Period pos -> pos + Comma pos -> pos + QuestionMark pos -> pos + Genitive pos _ -> pos + Number pos _ -> pos diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,608 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} + +-- | Test suite for ACE. + +module Main where + +import ACE.Combinators +import ACE.Parsers +import ACE.Tokenizer (tokenize) +import ACE.Types.Syntax +import ACE.Types.Tokens + +import Control.Applicative +import Control.Monad hiding (ap) +import Control.Monad.Identity hiding (ap) +import Data.Bifunctor +import Data.Text (Text) +import Test.HUnit +import Test.Hspec +import Text.Parsec (Stream,ParsecT,runP,try,Parsec,ParseError) +import Text.Parsec.Prim + +-- | Test suite entry point, returns exit failure if any test fails. +main :: IO () +main = hspec spec + +-- | Test suite. +spec :: Spec +spec = do + describe "tokenizer" tokenizer + describe "parser" parser + +-- | Tests for the tokenizer. +tokenizer :: Spec +tokenizer = + do it "empty string" + (tokenize "" == Right []) + it "word" + (tokenize "word" == Right [Word (1,0) "word"]) + it "period" + (tokenize "." == Right [Period (1,0)]) + it "comma" + (tokenize "," == Right [Comma (1,0)]) + it "number" + (tokenize "55" == Right [Number (1,0) 55]) + it "question mark" + (tokenize "?" == Right [QuestionMark (1,0)]) + it "quotation" + (tokenize "\"foo\"" == Right [QuotedString (1,0) "foo"]) + it "empty-quotation" + (isLeft (tokenize "\"\"")) + it "words" + (tokenize "foo bar" == Right [Word (1,0) "foo",Word (1,4) "bar"]) + it "genitive '" + (tokenize "foo'" == Right [Word (1,0) "foo",Genitive (1,3) False]) + it "genitive 's" + (tokenize "foo's" == Right [Word (1,0) "foo",Genitive (1,3) True]) + it "newline" + (tokenize "foo\nbar" == Right [Word (1,0) "foo",Word (2,0) "bar"]) + +-- | Parser tests. +parser :: Spec +parser = + do simple + adjective + ap' + copulae + complVs + genitiveNP + possessives + specifiers + verbs + adverbs + verbModifiers + nouns + relatives + noun + sentences + +sentences = + do it "existentialTopic" + (parsed existentialTopic "there is a " == + Right (ExistentialTopic + (ExistentialGlobalQuantor Is) + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))) + it "sentence" + (parsed sentence "a " == + Right (Sentence + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "")) + []))))) + it "sentence" + (parsed sentence "a that " == + Right + (Sentence + (NPCoordUnmarked + (UnmarkedNPCoord + (NP (SpecifyDeterminer A) + (N' Nothing + (N "") + Nothing + Nothing + (Just (RelativeClauseCoord + (RelativeClauseThat + (VPCoordVP + (VP + (V' Nothing + (ComplVIV (IntransitiveV "")) + [])))) + Nothing)))) + Nothing)) + (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "")) + []))))) + it "conditionalSentence" + (parsed conditionalSentence "if a then some " == + Right (ConditionalSentence + (SentenceCoord + (SentenceCoord_1 + (SentenceCoord_2 + (SentenceCoord_3 + (TopicalizedSentenceComposite + (CompositeSentence + (Sentence (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP + (VP + (V' Nothing + (ComplVIV (IntransitiveV "")) + [])))))) + Nothing) + Nothing) + Nothing) + Nothing) + (SentenceCoord + (SentenceCoord_1 + (SentenceCoord_2 + (SentenceCoord_3 + (TopicalizedSentenceComposite + (CompositeSentence + (Sentence + (NPCoordUnmarked + (UnmarkedNPCoord + (NP (SpecifyDeterminer Some) + (N' Nothing (N "") Nothing Nothing Nothing)) Nothing)) + (VPCoordVP + (VP (V' Nothing + (ComplVIV (IntransitiveV "")) + [])))))) + Nothing) + Nothing) + Nothing) + Nothing))) + it "universalTopic" + (parsed universalTopic "for all " == + Right (UniversalTopic ForAll (N' Nothing (N "") Nothing Nothing Nothing))) + it "negatedSentence" + (parsed negatedSentence "it is not the case that a " == + Right (NegatedSentence + (SentenceCoord + (SentenceCoord_1 + (SentenceCoord_2 + (SentenceCoord_3 + (TopicalizedSentenceComposite + (CompositeSentence + (Sentence + (NPCoordUnmarked + (UnmarkedNPCoord + (NP (SpecifyDeterminer A) + (N' Nothing (N "") Nothing Nothing Nothing)) + Nothing)) + (VPCoordVP + (VP (V' Nothing + (ComplVIV (IntransitiveV "")) + [])))))) + Nothing) + Nothing) + Nothing) + Nothing))) + it "specification" + (parsed specification "it is not the case that a ." == + Right + (Specification + (SentenceCoord + (SentenceCoord_1 + (SentenceCoord_2 + (SentenceCoord_3 + (TopicalizedSentenceComposite + (CompositeSentenceNeg + (NegatedSentence + (SentenceCoord + (SentenceCoord_1 + (SentenceCoord_2 + (SentenceCoord_3 + (TopicalizedSentenceComposite + (CompositeSentence + (Sentence (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "")) [])))))) + Nothing) + Nothing) + Nothing) + Nothing)))) + Nothing) + Nothing) + Nothing) + Nothing) + Nothing)) + +noun = + do it "pp" + (parsed pp " a " == + Right (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))) + it "n'" + (parsed (n' False) "" == Right (N' Nothing (N "") Nothing Nothing Nothing) ) + it "n'" + (parsed (n' False) " " == + Right (N' (Just (AdjectiveCoord (IntransitiveAdjective "") Nothing)) + (N "") Nothing Nothing Nothing)) + it "n'" + (parsed (n' False) " " == + Right (N' (Just (AdjectiveCoord (IntransitiveAdjective "") Nothing)) + (N "") + (Just (ApposCoord (AppositionVar (Variable "")) Nothing)) + Nothing + Nothing)) + it "n'" + (parsed (n' False) " of a a " == + Right (N' (Just (AdjectiveCoord (IntransitiveAdjective "") Nothing)) + (N "") + (Just (ApposCoord (AppositionVar (Variable "")) Nothing)) + (Just + (NPCoordUnmarked + (UnmarkedNPCoord + (NP (SpecifyDeterminer A) + (N' Nothing + (N "") + Nothing + Nothing + (Just + (RelativeClauseCoord + (RelativeClauseNP + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP + (VP + (V' Nothing + (ComplVIV (IntransitiveV "")) + [])))) + Nothing)))) + Nothing))) + Nothing)) + +relatives = + do it "relativeClauseCoord" + (parsed relativeClauseCoord "that and a " == + Right (RelativeClauseCoord + (RelativeClauseThat + (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "")) + [])))) + (Just (And + ,RelativeClauseCoord + (RelativeClauseNP + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP + (VP (V' Nothing (ComplVIV (IntransitiveV "")) + [])))) + Nothing)))) + it "relativeClause" + (parsed relativeClause "that " == + Right (RelativeClauseThat (VPCoordVP + (VP (V' Nothing (ComplVIV (IntransitiveV "")) + []))))) + it "relativeClause" + (parsed relativeClause "a " == + Right (RelativeClauseNP (NPCoordUnmarked + (UnmarkedNPCoord + (NP (SpecifyDeterminer A) + (N' Nothing (N "") Nothing Nothing Nothing)) + Nothing)) + (VPCoordVP (VP (V' Nothing + (ComplVIV (IntransitiveV "")) + []))))) + it "relativeClause" + (parsed relativeClause "that a " == + Right (RelativeClauseThatNPVP + (NPCoordUnmarked + (UnmarkedNPCoord + (NP (SpecifyDeterminer A) + (N' Nothing (N "") Nothing Nothing Nothing)) Nothing)) + (VPCoordVP (VP (V' Nothing + (ComplVIV (IntransitiveV "")) + []))))) + it "relativeClause" + (parsed relativeClause "a a " == + Right (RelativeClauseNPVP + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "")) + []))))) + it "relativeClause" + (parsed relativeClause " a a " == + Right (RelativeClausePP + (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)) + (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "")) + []))))) + +nouns = + do it "genitiveN'" + (parsed genitiveN' " " == + Right (GenitiveN' Nothing (N "") + (Just (ApposCoord (AppositionVar (Variable "")) Nothing)))) + it "genitiveN'" + (parsed genitiveN' " and " == + Right (GenitiveN' (Just (AdjectiveCoord + (IntransitiveAdjective "") + (Just (AdjectiveCoord (IntransitiveAdjective "") + Nothing)))) + (N "") + (Just (ApposCoord (AppositionVar (Variable "")) Nothing)))) + it "npCoord" + (parsed npCoord "each of some " == + Right (NPCoordDistributed + EachOf + (UnmarkedNPCoord (NP (SpecifyDeterminer Some) + (N' Nothing (N "") Nothing Nothing Nothing)) + Nothing))) + it "npCoord" + (parsed npCoord "some " == + Right (NPCoordUnmarked + (UnmarkedNPCoord (NP (SpecifyDeterminer Some) + (N' Nothing (N "") Nothing Nothing Nothing)) + Nothing))) + +verbModifiers = + do it "vModifier" + (parsed vModifier " and " == + Right (VModifierVC (AdverbCoord (Adverb "") (Just (AdverbCoord (Adverb "") Nothing))))) + it "vModifier" + (parsed vModifier " a " == + Right (VModifierPP (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) + it "vModifier" + (parsed vModifier " and " == + Right (VModifierAVPP + (AdverbialPP (Preposition "") + (AdverbCoord (Adverb "") + (Just (AdverbCoord (Adverb "") Nothing)))))) + +adverbs = + do it "adverbialPP" + (parsed adverbialPP " and " == + Right (AdverbialPP (Preposition "") + (AdverbCoord (Adverb "") + (Just (AdverbCoord (Adverb "") Nothing))))) + +verbs = + do -- An intransitive verb is OK: walks + it "v'" + (parsed v' "" == + Right (V' Nothing (ComplVIV (IntransitiveV "")) [])) + -- A transitive verb must take a preposition and a noun phrase. + it "v'" + (parsed v' " a " == + Right (V' Nothing + (ComplVTV (TransitiveV "") + (ComplPP (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) + [])) + -- A phrasal transitive verb with adverbs on both sides, e.g. + -- quickly walks up to a chair hastily + it "v'" + (parsed v' " a " == + Right (V' (Just (AdverbCoord (Adverb "") Nothing)) + (ComplVPV (PhrasalTransitiveV "") + (PhrasalParticle "") + (ComplPP (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) + [VModifierVC (AdverbCoord (Adverb "") Nothing)])) + it "vp" + (parsed vp "" == + Right (VP (V' Nothing (ComplVIV (IntransitiveV "")) []))) + it "vp" + (parsed vp "is not " == + Right (VPNeg Is (V' Nothing (ComplVIV (IntransitiveV "")) []))) + it "vpCoord" + (parsed vpCoord " and is not " == + Right (VPCoord' (VP (V' Nothing (ComplVIV (IntransitiveV "")) [])) + And + (VPCoordVP + (VPNeg Is + (V' Nothing (ComplVIV (IntransitiveV "")) + []))))) + +specifiers = + do it "specifier" + (parsed specifier "'s" == + Right (SpecifyPossessive + (PossessiveNPCoordGen + (GenitiveNPCoordName + (ProperName "") + (GenitiveTailSaxonTail + (SaxonGenitiveTail ApostropheS + Nothing)))))) + it "specifier" + (parsed specifier "1" == + Right (SpecifyNumberP (NumberP Nothing 1))) + it "specifier" + (parsed specifier "a" == + Right (SpecifyDeterminer A)) + it "genitiveSpecifier" + (parsed genitiveSpecifier "1" == + Right (GenitiveSpecifierN 1)) + it "genitiveSpecifier" + (parsed genitiveSpecifier "a" == + Right (GenitiveSpecifierD A)) + it "genitiveSpecifier" + (parsed genitiveSpecifier "some" == + Right (GenitiveSpecifierD Some)) + it "genitiveSpecifier" + (parsed genitiveSpecifier "his" == + Right (GenitiveSpecifierPPC (PossessivePronounCoord HisHer Nothing))) + +possessives = + do it "possessivePronounCoord" + (parsed possessivePronounCoord "his and her" == + Right (PossessivePronounCoord HisHer (Just (PossessivePronounCoord HisHer Nothing)))) + it "possessivePronounCoord" + (parsed possessivePronounCoord "its" == + Right (PossessivePronounCoord Its Nothing)) + it "possessiveNPCoord" + (parsed possessiveNPCoord "his and her" == + Right (PossessiveNPCoordPronoun (PossessivePronounCoord HisHer (Just (PossessivePronounCoord HisHer Nothing))))) + it "possessiveNPCoord" + (parsed possessiveNPCoord "a 's" == + Right (PossessiveNPCoordGen + (GenitiveNPCoord (GenitiveSpecifierD A) + (GenitiveN' Nothing (N "") Nothing) + (GenitiveTailSaxonTail (SaxonGenitiveTail ApostropheS Nothing))))) + +genitiveNP = + do it "genitiveNPCoord" + (parsed genitiveNPCoord "'s" == + Right (GenitiveNPCoordName (ProperName "") + (GenitiveTailSaxonTail (SaxonGenitiveTail ApostropheS Nothing)))) + it "genitiveNPCoord" + (parsed genitiveNPCoord "some 's" == + Right (GenitiveNPCoord (GenitiveSpecifierD Some) + (GenitiveN' Nothing (N "") Nothing) + (GenitiveTailSaxonTail (SaxonGenitiveTail ApostropheS Nothing)))) + it "genitiveNPCoord" + (parsed genitiveNPCoord "some and a 's" == + Right (GenitiveNPCoord (GenitiveSpecifierD Some) + (GenitiveN' Nothing (N "") Nothing) + (GenitiveTailCoordtail + (GenitiveCoordTail + (GenitiveNPCoord + (GenitiveSpecifierD A) + (GenitiveN' Nothing (N "") Nothing) + (GenitiveTailSaxonTail + (SaxonGenitiveTail ApostropheS Nothing))))))) + +adjective = + do it "adjectiveCoord" + (parsed adjectiveCoord "" == + Right (AdjectiveCoord intransAdj + Nothing)) + it "adjectiveCoord" + (parsed adjectiveCoord " and " == + Right (AdjectiveCoord intransAdj + (Just (AdjectiveCoord intransAdj + Nothing)))) + it "adverbCoord" + (parsed adverbCoord " and " == + Right (AdverbCoord adverb' + (Just (AdverbCoord adverb' + Nothing)))) + +ap' = + do it "ap" + (parsed ap "" == + Right (APIntrans intransAdj)) + it "ap" + (parsed ap " a " == + Right (APTrans (TransitiveAdjective "") + (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) + it "apGrad" + (parsed apGrad " than a " == + Right (APgradAPThan (APIntrans intransAdj) + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))) + it "apCoord" + (parsed apCoord " than a and than a " == + Right (APCoordAnd (APgradAPThan (APIntrans intransAdj) + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) + (APCoord (APgradAPThan (APIntrans intransAdj) + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))) + +copulae = + do it "copulaCompl" + (parsed copulaCompl " a " == + Right (CopulaComplPP (PP (Preposition "") + (NPCoordUnmarked + (UnmarkedNPCoord anoun + Nothing))))) + it "copulaCompl" + (parsed copulaCompl "a and a " == + Right (CopulaComplNPC (NPCoordUnmarked + (UnmarkedNPCoord anoun + (Just (UnmarkedNPCoord anoun Nothing)))))) + it "copulaCompl" + (parsed copulaCompl " than a and a " == + Right (CopulaComplAPC + (APCoord + (APgradAPThan (APIntrans intransAdj) + (NPCoordUnmarked (UnmarkedNPCoord anoun + (Just (UnmarkedNPCoord anoun Nothing)))))))) + +simple = + do it "universalGlobalQuantor" + (parsed universalGlobalQuantor "for every" == Right ForEveryEach) + it "possessivePronoun" + (parsed possessivePronoun "his" == Right HisHer) + it "generalizedQuantor" + (parsed generalizedQuantor "not more than" == Right NotMoreThan) + it "distributiveMarker" + (parsed distributiveMarker "each of" == Right EachOf) + it "distributiveGlobalQuantor" + (parsed distributiveGlobalQuantor "for each of" == Right ForEachOf) + it "existentialGlobalQuestionQuantor" + (parsed existentialGlobalQuestionQuantor "is there" == + Right (ExistentialGlobalQuestionQuantor Is)) + it "existentialGlobalQuantor" + (parsed existentialGlobalQuantor "there is" == + Right (ExistentialGlobalQuantor Is)) + it "numberP" + (parsed numberP "not more than 5" == + Right (NumberP (Just NotMoreThan) 5)) + it "numberP" + (parsed numberP "5" == Right (NumberP Nothing 5)) + it "determiner" + (parsed determiner "the" == Right The) + it "determiner" + (parsed determiner "not every" == Right NotEveryEach) + +complVs = + do it "complVPI" + (parsed complV " " == + Right (ComplVPI (PhrasalIntransitiveV "") + (PhrasalParticle ""))) + it "complVIV" + (parsed complV "" == + Right (ComplVIV (IntransitiveV ""))) + it "complVTV" + (parsed complV " a " == + Right (ComplVTV (TransitiveV "") + (ComplPP (PP (Preposition "") + (NPCoordUnmarked + (UnmarkedNPCoord anoun Nothing)))))) + it "complVPV" + (parsed complV " a " == + Right (ComplVPV (PhrasalTransitiveV "") + (PhrasalParticle "") + (ComplNP (NPCoordUnmarked + (UnmarkedNPCoord anoun Nothing))))) + it "complVDisV" + (parsed complV " a a " == + Right (ComplVDisV (DistransitiveV "") + (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) + (ComplPP (PP (Preposition "") + (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))) + it "complVPDV" + (parsed complV " a a " == + Right (ComplVPDV (PhrasalDistransitiveV "") + (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))) + (PhrasalParticle "") + (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) + it "complCopula" + (parsed complV "is a " == + Right (ComplVCopula Is + (CopulaComplNPC (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))) + +intransAdj = IntransitiveAdjective "" + +adverb' = Adverb "" + +anoun = (NP (SpecifyDeterminer A) + (N' Nothing + (N "") + Nothing + Nothing + Nothing)) + +-- | Is that left? +isLeft :: Either a b -> Bool +isLeft = either (const True) (const False) + +-- | Get the parsed result after tokenizing. +parsed :: Parsec [Token] (ACEParser [Token] Identity) c -> Text -> Either String c +parsed p = tokenize >=> bimap show id . runP (p <* eof) defaultACEParser "" + +-- | Test a parser. +testp :: Show a => Parsec [Token] (ACEParser [Token] Identity) a -> Text -> IO () +testp p i = + case parsed p i of + Left e -> putStrLn e + Right p -> print p