ace (empty) → 0.0
raw patch · 10 files changed
+1986/−0 lines, 10 filesdep +HUnitdep +acedep +attoparsecsetup-changed
Dependencies added: HUnit, ace, attoparsec, base, bifunctors, data-default, hspec, mtl, parsec, semigroups, text
Files
- LICENSE +24/−0
- Setup.hs +2/−0
- ace.cabal +44/−0
- src/ACE.hs +11/−0
- src/ACE/Combinators.hs +128/−0
- src/ACE/Parsers.hs +559/−0
- src/ACE/Tokenizer.hs +129/−0
- src/ACE/Types/Syntax.hs +447/−0
- src/ACE/Types/Tokens.hs +34/−0
- test/Main.hs +608/−0
+ LICENSE view
@@ -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 <COPYRIGHT HOLDER> 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ace.cabal view
@@ -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
+ src/ACE.hs view
@@ -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
+ src/ACE/Combinators.hs view
@@ -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"
+ src/ACE/Parsers.hs view
@@ -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: @\<noun\>@, @\<prep\>@, etc.+defaultACEParser :: Stream s m Token => ACEParser s m+defaultACEParser =+ ACE { aceIntransitiveAdjective = string "<intrans-adj>"+ , aceTransitiveAdjective = string "<trans-adj>"+ , aceNoun = string "<noun>"+ , acePreposition = string "<prep>"+ , aceVariable = string "<var>"+ , aceProperName = string "<proper-name>"+ , aceAdverb = string "<adverb>"+ , aceIntransitiveVerb = string "<intrans-verb>"+ , aceDistransitiveVerb = string "<distrans-verb>"+ , acePhrasalParticle = string "<pparticle>"+ , acePhrasalIntransitiveV = string "<pintrans-verb>"+ , acePhrasalDistransitiveV = string "<pdistrans-verb>"+ , aceTransitiveVerb = string "<trans-verb>"+ , acePhrasalTransitiveV = string "<ptrans-verb>"+ }++-- | 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\", \"<proper-name>'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
+ src/ACE/Tokenizer.hs view
@@ -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)
+ src/ACE/Types/Syntax.hs view
@@ -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)
+ src/ACE/Types/Tokens.hs view
@@ -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
+ test/Main.hs view
@@ -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 <noun>" ==+ Right (ExistentialTopic+ (ExistentialGlobalQuantor Is)+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))+ it "sentence"+ (parsed sentence "a <noun> <intrans-verb>" ==+ Right (Sentence+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))+ it "sentence"+ (parsed sentence "a <noun> that <intrans-verb> <intrans-verb>" ==+ Right+ (Sentence+ (NPCoordUnmarked+ (UnmarkedNPCoord+ (NP (SpecifyDeterminer A)+ (N' Nothing+ (N "<noun>")+ Nothing+ Nothing+ (Just (RelativeClauseCoord+ (RelativeClauseThat+ (VPCoordVP+ (VP+ (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))+ Nothing))))+ Nothing))+ (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))+ it "conditionalSentence"+ (parsed conditionalSentence "if a <noun> <intrans-verb> then some <noun> <intrans-verb>" ==+ Right (ConditionalSentence+ (SentenceCoord+ (SentenceCoord_1+ (SentenceCoord_2+ (SentenceCoord_3+ (TopicalizedSentenceComposite+ (CompositeSentence+ (Sentence (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (VPCoordVP+ (VP+ (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))))+ Nothing)+ Nothing)+ Nothing)+ Nothing)+ (SentenceCoord+ (SentenceCoord_1+ (SentenceCoord_2+ (SentenceCoord_3+ (TopicalizedSentenceComposite+ (CompositeSentence+ (Sentence+ (NPCoordUnmarked+ (UnmarkedNPCoord+ (NP (SpecifyDeterminer Some)+ (N' Nothing (N "<noun>") Nothing Nothing Nothing)) Nothing))+ (VPCoordVP+ (VP (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))))+ Nothing)+ Nothing)+ Nothing)+ Nothing)))+ it "universalTopic"+ (parsed universalTopic "for all <noun>" ==+ Right (UniversalTopic ForAll (N' Nothing (N "<noun>") Nothing Nothing Nothing)))+ it "negatedSentence"+ (parsed negatedSentence "it is not the case that a <noun> <intrans-verb>" ==+ Right (NegatedSentence+ (SentenceCoord+ (SentenceCoord_1+ (SentenceCoord_2+ (SentenceCoord_3+ (TopicalizedSentenceComposite+ (CompositeSentence+ (Sentence+ (NPCoordUnmarked+ (UnmarkedNPCoord+ (NP (SpecifyDeterminer A)+ (N' Nothing (N "<noun>") Nothing Nothing Nothing))+ Nothing))+ (VPCoordVP+ (VP (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))))+ Nothing)+ Nothing)+ Nothing)+ Nothing)))+ it "specification"+ (parsed specification "it is not the case that a <noun> <intrans-verb>." ==+ 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 "<intrans-verb>")) []))))))+ Nothing)+ Nothing)+ Nothing)+ Nothing))))+ Nothing)+ Nothing)+ Nothing)+ Nothing)+ Nothing))++noun =+ do it "pp"+ (parsed pp "<prep> a <noun>" ==+ Right (PP (Preposition "<prep>")+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))+ it "n'"+ (parsed (n' False) "<noun>" == Right (N' Nothing (N "<noun>") Nothing Nothing Nothing) )+ it "n'"+ (parsed (n' False) "<intrans-adj> <noun>" ==+ Right (N' (Just (AdjectiveCoord (IntransitiveAdjective "<intrans-adj>") Nothing))+ (N "<noun>") Nothing Nothing Nothing))+ it "n'"+ (parsed (n' False) "<intrans-adj> <noun> <var>" ==+ Right (N' (Just (AdjectiveCoord (IntransitiveAdjective "<intrans-adj>") Nothing))+ (N "<noun>")+ (Just (ApposCoord (AppositionVar (Variable "<var>")) Nothing))+ Nothing+ Nothing))+ it "n'"+ (parsed (n' False) "<intrans-adj> <noun> <var> of a <noun> a <noun> <intrans-verb>" ==+ Right (N' (Just (AdjectiveCoord (IntransitiveAdjective "<intrans-adj>") Nothing))+ (N "<noun>")+ (Just (ApposCoord (AppositionVar (Variable "<var>")) Nothing))+ (Just+ (NPCoordUnmarked+ (UnmarkedNPCoord+ (NP (SpecifyDeterminer A)+ (N' Nothing+ (N "<noun>")+ Nothing+ Nothing+ (Just+ (RelativeClauseCoord+ (RelativeClauseNP+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (VPCoordVP+ (VP+ (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))+ Nothing))))+ Nothing)))+ Nothing))++relatives =+ do it "relativeClauseCoord"+ (parsed relativeClauseCoord "that <intrans-verb> and a <noun> <intrans-verb>" ==+ Right (RelativeClauseCoord+ (RelativeClauseThat+ (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))+ (Just (And+ ,RelativeClauseCoord+ (RelativeClauseNP+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (VPCoordVP+ (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ []))))+ Nothing))))+ it "relativeClause"+ (parsed relativeClause "that <intrans-verb>" ==+ Right (RelativeClauseThat (VPCoordVP+ (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))+ it "relativeClause"+ (parsed relativeClause "a <noun> <intrans-verb>" ==+ Right (RelativeClauseNP (NPCoordUnmarked+ (UnmarkedNPCoord+ (NP (SpecifyDeterminer A)+ (N' Nothing (N "<noun>") Nothing Nothing Nothing))+ Nothing))+ (VPCoordVP (VP (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))+ it "relativeClause"+ (parsed relativeClause "that a <noun> <intrans-verb>" ==+ Right (RelativeClauseThatNPVP+ (NPCoordUnmarked+ (UnmarkedNPCoord+ (NP (SpecifyDeterminer A)+ (N' Nothing (N "<noun>") Nothing Nothing Nothing)) Nothing))+ (VPCoordVP (VP (V' Nothing+ (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))+ it "relativeClause"+ (parsed relativeClause "a <noun> a <noun> <intrans-verb>" ==+ Right (RelativeClauseNPVP+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))+ it "relativeClause"+ (parsed relativeClause "<prep> a <noun> a <noun> <intrans-verb>" ==+ Right (RelativeClausePP+ (PP (Preposition "<prep>")+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))+ (VPCoordVP (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))++nouns =+ do it "genitiveN'"+ (parsed genitiveN' "<noun> <var>" ==+ Right (GenitiveN' Nothing (N "<noun>")+ (Just (ApposCoord (AppositionVar (Variable "<var>")) Nothing))))+ it "genitiveN'"+ (parsed genitiveN' "<intrans-adj> and <intrans-adj> <noun> <var>" ==+ Right (GenitiveN' (Just (AdjectiveCoord+ (IntransitiveAdjective "<intrans-adj>")+ (Just (AdjectiveCoord (IntransitiveAdjective "<intrans-adj>")+ Nothing))))+ (N "<noun>")+ (Just (ApposCoord (AppositionVar (Variable "<var>")) Nothing))))+ it "npCoord"+ (parsed npCoord "each of some <noun>" ==+ Right (NPCoordDistributed+ EachOf+ (UnmarkedNPCoord (NP (SpecifyDeterminer Some)+ (N' Nothing (N "<noun>") Nothing Nothing Nothing))+ Nothing)))+ it "npCoord"+ (parsed npCoord "some <noun>" ==+ Right (NPCoordUnmarked+ (UnmarkedNPCoord (NP (SpecifyDeterminer Some)+ (N' Nothing (N "<noun>") Nothing Nothing Nothing))+ Nothing)))++verbModifiers =+ do it "vModifier"+ (parsed vModifier "<adverb> and <adverb>" ==+ Right (VModifierVC (AdverbCoord (Adverb "<adverb>") (Just (AdverbCoord (Adverb "<adverb>") Nothing)))))+ it "vModifier"+ (parsed vModifier "<prep> a <noun>" ==+ Right (VModifierPP (PP (Preposition "<prep>")+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))+ it "vModifier"+ (parsed vModifier "<prep> <adverb> and <adverb>" ==+ Right (VModifierAVPP+ (AdverbialPP (Preposition "<prep>")+ (AdverbCoord (Adverb "<adverb>")+ (Just (AdverbCoord (Adverb "<adverb>") Nothing))))))++adverbs =+ do it "adverbialPP"+ (parsed adverbialPP "<prep> <adverb> and <adverb>" ==+ Right (AdverbialPP (Preposition "<prep>")+ (AdverbCoord (Adverb "<adverb>")+ (Just (AdverbCoord (Adverb "<adverb>") Nothing)))))++verbs =+ do -- An intransitive verb is OK: walks+ it "v'"+ (parsed v' "<intrans-verb>" ==+ Right (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>")) []))+ -- A transitive verb must take a preposition and a noun phrase.+ it "v'"+ (parsed v' "<trans-verb> <prep> a <noun>" ==+ Right (V' Nothing+ (ComplVTV (TransitiveV "<trans-verb>")+ (ComplPP (PP (Preposition "<prep>")+ (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' "<adverb> <ptrans-verb> <pparticle> <prep> a <noun> <adverb>" ==+ Right (V' (Just (AdverbCoord (Adverb "<adverb>") Nothing))+ (ComplVPV (PhrasalTransitiveV "<ptrans-verb>")+ (PhrasalParticle "<pparticle>")+ (ComplPP (PP (Preposition "<prep>")+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))+ [VModifierVC (AdverbCoord (Adverb "<adverb>") Nothing)]))+ it "vp"+ (parsed vp "<intrans-verb>" ==+ Right (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>")) [])))+ it "vp"+ (parsed vp "is not <intrans-verb>" ==+ Right (VPNeg Is (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>")) [])))+ it "vpCoord"+ (parsed vpCoord "<intrans-verb> and is not <intrans-verb>" ==+ Right (VPCoord' (VP (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>")) []))+ And+ (VPCoordVP+ (VPNeg Is+ (V' Nothing (ComplVIV (IntransitiveV "<intrans-verb>"))+ [])))))++specifiers =+ do it "specifier"+ (parsed specifier "<proper-name>'s" ==+ Right (SpecifyPossessive+ (PossessiveNPCoordGen+ (GenitiveNPCoordName+ (ProperName "<proper-name>")+ (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 <noun>'s" ==+ Right (PossessiveNPCoordGen+ (GenitiveNPCoord (GenitiveSpecifierD A)+ (GenitiveN' Nothing (N "<noun>") Nothing)+ (GenitiveTailSaxonTail (SaxonGenitiveTail ApostropheS Nothing)))))++genitiveNP =+ do it "genitiveNPCoord"+ (parsed genitiveNPCoord "<proper-name>'s" ==+ Right (GenitiveNPCoordName (ProperName "<proper-name>")+ (GenitiveTailSaxonTail (SaxonGenitiveTail ApostropheS Nothing))))+ it "genitiveNPCoord"+ (parsed genitiveNPCoord "some <noun>'s" ==+ Right (GenitiveNPCoord (GenitiveSpecifierD Some)+ (GenitiveN' Nothing (N "<noun>") Nothing)+ (GenitiveTailSaxonTail (SaxonGenitiveTail ApostropheS Nothing))))+ it "genitiveNPCoord"+ (parsed genitiveNPCoord "some <noun> and a <noun>'s" ==+ Right (GenitiveNPCoord (GenitiveSpecifierD Some)+ (GenitiveN' Nothing (N "<noun>") Nothing)+ (GenitiveTailCoordtail+ (GenitiveCoordTail+ (GenitiveNPCoord+ (GenitiveSpecifierD A)+ (GenitiveN' Nothing (N "<noun>") Nothing)+ (GenitiveTailSaxonTail+ (SaxonGenitiveTail ApostropheS Nothing)))))))++adjective =+ do it "adjectiveCoord"+ (parsed adjectiveCoord "<intrans-adj>" ==+ Right (AdjectiveCoord intransAdj+ Nothing))+ it "adjectiveCoord"+ (parsed adjectiveCoord "<intrans-adj> and <intrans-adj>" ==+ Right (AdjectiveCoord intransAdj+ (Just (AdjectiveCoord intransAdj+ Nothing))))+ it "adverbCoord"+ (parsed adverbCoord "<adverb> and <adverb>" ==+ Right (AdverbCoord adverb'+ (Just (AdverbCoord adverb'+ Nothing))))++ap' =+ do it "ap"+ (parsed ap "<intrans-adj>" ==+ Right (APIntrans intransAdj))+ it "ap"+ (parsed ap "<trans-adj> <prep> a <noun>" ==+ Right (APTrans (TransitiveAdjective "<trans-adj>")+ (PP (Preposition "<prep>")+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))+ it "apGrad"+ (parsed apGrad "<intrans-adj> than a <noun>" ==+ Right (APgradAPThan (APIntrans intransAdj)+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))+ it "apCoord"+ (parsed apCoord "<intrans-adj> than a <noun> and <intrans-adj> than a <noun>" ==+ Right (APCoordAnd (APgradAPThan (APIntrans intransAdj)+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))+ (APCoord (APgradAPThan (APIntrans intransAdj)+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))))++copulae =+ do it "copulaCompl"+ (parsed copulaCompl "<prep> a <noun>" ==+ Right (CopulaComplPP (PP (Preposition "<prep>")+ (NPCoordUnmarked+ (UnmarkedNPCoord anoun+ Nothing)))))+ it "copulaCompl"+ (parsed copulaCompl "a <noun> and a <noun>" ==+ Right (CopulaComplNPC (NPCoordUnmarked+ (UnmarkedNPCoord anoun+ (Just (UnmarkedNPCoord anoun Nothing))))))+ it "copulaCompl"+ (parsed copulaCompl "<intrans-adj> than a <noun> and a <noun>" ==+ 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 "<pintrans-verb> <pparticle>" ==+ Right (ComplVPI (PhrasalIntransitiveV "<pintrans-verb>")+ (PhrasalParticle "<pparticle>")))+ it "complVIV"+ (parsed complV "<intrans-verb>" ==+ Right (ComplVIV (IntransitiveV "<intrans-verb>")))+ it "complVTV"+ (parsed complV "<trans-verb> <prep> a <noun>" ==+ Right (ComplVTV (TransitiveV "<trans-verb>")+ (ComplPP (PP (Preposition "<prep>")+ (NPCoordUnmarked+ (UnmarkedNPCoord anoun Nothing))))))+ it "complVPV"+ (parsed complV "<ptrans-verb> <pparticle> a <noun>" ==+ Right (ComplVPV (PhrasalTransitiveV "<ptrans-verb>")+ (PhrasalParticle "<pparticle>")+ (ComplNP (NPCoordUnmarked+ (UnmarkedNPCoord anoun Nothing)))))+ it "complVDisV"+ (parsed complV "<distrans-verb> a <noun> <prep> a <noun>" ==+ Right (ComplVDisV (DistransitiveV "<distrans-verb>")+ (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))+ (ComplPP (PP (Preposition "<prep>")+ (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing))))))+ it "complVPDV"+ (parsed complV "<pdistrans-verb> a <noun> <pparticle> a <noun>" ==+ Right (ComplVPDV (PhrasalDistransitiveV "<pdistrans-verb>")+ (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))+ (PhrasalParticle "<pparticle>")+ (ComplNP (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))+ it "complCopula"+ (parsed complV "is a <noun>" ==+ Right (ComplVCopula Is+ (CopulaComplNPC (NPCoordUnmarked (UnmarkedNPCoord anoun Nothing)))))++intransAdj = IntransitiveAdjective "<intrans-adj>"++adverb' = Adverb "<adverb>"++anoun = (NP (SpecifyDeterminer A)+ (N' Nothing+ (N "<noun>")+ 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>"++-- | 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